Gnu make replacement

[dmvianna]

I am shopping around for a Haskell replacement for Gnu make / npm script. How would I accomplish this with turtle? Also, how would it compare to shake?

[Gabriella439]

So, first off, I would highly recommend trying out nix or shake first before other alternatives.

However, I do have a "low-tech" build system that only requires about ~100 lines of Haskell code to implement. Here's the implementation:

{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE GADTs                     #-}

import Control.Applicative
import Control.Concurrent.STM (STM)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Managed (Managed)
import Data.Functor ((<$))
import Data.Monoid ((<>))
import Data.String (IsString(..))
import System.FSNotify (Event(..))
import System.FilePath ((</>))

import qualified Control.Concurrent.Async
import qualified Control.Concurrent.STM        as STM
import qualified Control.Concurrent.STM.TQueue as TQueue
import qualified Control.Monad.Managed
import qualified System.Directory
import qualified System.FilePath
import qualified System.FSNotify
import qualified System.Process

data Pair a b = Pair !a !b

-- | Variation on `Control.Foldl.FoldM` with a pure `done` function
data FoldM m a b = forall x . FoldM (x -> a -> m x) (m x) (x -> b)

instance Monad m => Functor (FoldM m a) where
    fmap f (FoldM step start done) = FoldM step start done'
      where
        done' x = f (done x)

instance Monad m => Applicative (FoldM m a) where
    pure b = FoldM (\() _ -> return ()) (return ()) (\() -> b)

    FoldM stepL beginL doneL <*> FoldM stepR beginR doneR =
        let step (Pair xL xR) a = do
                xL' <- stepL xL a
                xR' <- stepR xR a
                return $! Pair xL' xR'
            begin = do
                xL <- beginL
                xR <- beginR
                return $! Pair xL xR
            done (Pair xL xR) = doneL xL (doneR xR)
        in  FoldM step begin done

instance (Monad m, Monoid b) => Monoid (FoldM m a b) where
    mempty = pure mempty

    mappend = liftA2 mappend

data Buildable a = forall e . Buildable (Managed (STM e, FoldM IO e a))

instance Functor Buildable where
    fmap k (Buildable m) = Buildable (fmap (fmap (fmap k)) m)

instance Applicative Buildable where
    pure x = Buildable (pure (empty, pure x))

    Buildable mL <*> Buildable mR = Buildable (liftA2 merge mL mR)
      where
        merge (stmL, foldL) (stmR, foldR) = (stm, fold)
          where
            stm = fmap Left stmL <|> fmap Right stmR

            fold = onLeft foldL <*> onRight foldR

instance Monoid a => Monoid (Buildable a) where
    mempty = pure mempty

    mappend = liftA2 mappend

instance (() ~ a) => IsString (Buildable a) where
    fromString = watch

onLeft :: Monad m => FoldM m i o -> FoldM m (Either i x) o
onLeft (FoldM step begin done) = FoldM step' begin done
  where
    step' x (Left  i) = step x i
    step' x (Right _) = return x

onRight :: Monad m => FoldM m i o -> FoldM m (Either x i) o
onRight (FoldM step begin done) = FoldM step' begin done
  where
    step' x (Left  _) = return x
    step' x (Right i) = step x i

run :: Buildable a -> IO ()
run (Buildable m) = Control.Monad.Managed.runManaged (do
    (stm, FoldM step begin _) <- m

    let go x = do
            e <- STM.atomically stm
            x' <- step x e
            go x'

    x0 <- liftIO begin
    liftIO (go x0) )

listen :: (a -> IO r) -> Buildable a -> Buildable a
listen handler (Buildable m) = Buildable (fmap adapt m)
  where
    adapt (stm, FoldM step begin done) = (stm, FoldM step' begin' done)
      where
        begin' = do
            x <- begin
            handler (done x)
            return x
        step' x e = do
            x' <- step x e
            handler (done x')
            return x'

watch :: FilePath -> Buildable ()
watch file = Buildable m
  where
    directory = System.FilePath.takeDirectory file

    m = do
        manager <- Control.Monad.Managed.managed System.FSNotify.withManager

        pwd <- liftIO System.Directory.getCurrentDirectory
        let predicate event = System.FSNotify.eventPath event == pwd </> file

        tQueue  <- liftIO (STM.atomically TQueue.newTQueue)
        let action (Added    _ _) = STM.atomically (TQueue.writeTQueue tQueue ())
            action (Modified _ _) = STM.atomically (TQueue.writeTQueue tQueue ())
            action (Removed  _ _) = return ()

        let io = System.FSNotify.watchDir manager directory predicate action
        Control.Monad.Managed.managed (Control.Concurrent.Async.withAsync io)

        return (TQueue.readTQueue tQueue, mempty)

... and here's an example of how you would use it:

baz :: Buildable ()
baz = listen handler ("foo.txt" <> "bar.txt")
  where
    handler _ = System.Process.system "cat foo.txt bar.txt > baz.txt"

test :: Buildable ()
test = listen handler "test.c"
  where
    handler _ = System.Process.system ("gcc -c test.c -o test.o")

main :: IO ()
main = run (baz <> test)

... which basically implements a continuous make system that watches your filesystem and rebuilds things automatically, and the above code is somewhat analogous to this make file:

baz.txt: foo.txt bar.txt
    cat foo.txt bar.txt > baz.txt

test.o: test.c
    gcc -c test.c -o test.o

Try to run the above code. If you create a foo.txt and bar.txt while it is running then it will auto-generate baz.txt and if you create a test.c file it will automatically compile it to test.o object code.

[mitchellwrosen]

Wow, Buildable is a great type!

[mitchellwrosen]

But spawning a separate directory-watching manager thread for every single distinct path in your makefile seems... ill-advised =)

[Gabriella439]

Yeah, this is just a proof of concept. I'd typically recommend Nix as a build system these days

[3noch]

Unless, of course, you're on Windows. :/ Nix sorta works on Windows, but it's not usable enough to be recommended.