Open dmvianna opened 7 years ago
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.
Wow, Buildable
is a great type!
But spawning a separate directory-watching manager thread for every single distinct path in your makefile seems... ill-advised =)
Yeah, this is just a proof of concept. I'd typically recommend Nix
as a build system these days
Unless, of course, you're on Windows. :/ Nix sorta works on Windows, but it's not usable enough to be recommended.
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?