Grow 1.0 → 1.1
raw patch · 6 files changed
+296/−53 lines, 6 filesdep +definitive-reactivedep +processdep ~definitive-basedep ~definitive-filesystemdep ~definitive-parser
Dependencies added: definitive-reactive, process
Dependency ranges changed: definitive-base, definitive-filesystem, definitive-parser
Files
- Grow.cabal +54/−7
- Grow.hs +17/−9
- Grow/Syntax.hs +0/−37
- LICENSE +39/−0
- Language/Grow.hs +134/−0
- Language/Syntax/Grow.hs +52/−0
Grow.cabal view
@@ -1,18 +1,65 @@+-- content information name: Grow-version: 1.0-+category: Build synopsis: A declarative make-like interpreter.-description: +description: Grow is a well-defined replacement for Makefiles and the like to build complex+ hierarchies of files with minimal effort. + + Like many Makefile-like tools, Grow depends on the notion of+ timestamps to determine whether a file should be recompiled or+ not. Grow is much simpler than those, though, and I might argue way+ easier to use as well.+ + On startup, Grow will look for a file named "Seed" in the current+ directory, and evaluate the grow expressions contained within.+ + For example, here is a simple Seed file to compile a single C file+ into an executable.+ + tee $$arg:in {+ all = ($main:seq "All done !"):in $execs+ execs = hook ld [main] [main.o] :in $objects+ objects = hook cc [main.o] [main.c]+ }+ + Notice the `hook` function ? It is the Grow primitive that calls an+ external program to perform actual tasks. + + In Grow, hooks are expected to only accept files as their arguments,+ so we have to write the wrapper scripts `cc` and `ld` that accept+ arguments in the form "<destination>... <source>...". They are pretty+ trivial to write since they only involve renaming variables and+ swapping arguments.+ + Here are sample `cc` and `ld` scripts to show you there is nothing+ magical about them :+ + #!/bin/bash+ obj="$1" ; shift ; src="$1"+ gcc -c "$src" -o "$obj"+ + #!/bin/bash+ bin="$1" ; shift ; obj="$1"+ gcc "$obj" -o "$bin"+ + In grow, instead of writing recipes in the configuration, we just declare+ hooks and then write the appropriate wrapper scripts to call compilers with+ the correct flags and arguments.++-- meta-information author: Marc Coiffier maintainer: marc.coiffier@gmail.com-license: PublicDomain+version: 1.1+license: OtherLicense+license-file: LICENSE +-- build information build-type: Simple cabal-version: >=1.10 library- exposed-modules: Grow Grow.Syntax- build-depends: base (== 4.6.*), definitive-base (== 1.0.*), containers (== 0.5.*), deepseq (== 1.3.*), array (== 0.5.*), bytestring (== 0.10.*), definitive-filesystem (== 1.0.*), clock (== 0.4.*), directory (== 1.2.*), filepath (== 1.3.*), time (== 1.4.*), old-locale (== 1.0.*), unix (== 2.7.*), definitive-parser (== 1.0.*), vector (== 0.10.*), primitive (== 0.5.*)- default-extensions: RebindableSyntax NoMonomorphismRestriction+ exposed-modules: Grow Language.Grow Language.Syntax.Grow+ build-depends: base (== 4.6.*), definitive-base (== 1.2.*), containers (== 0.5.*), deepseq (== 1.3.*), array (== 0.5.*), bytestring (== 0.10.*), vector (== 0.10.*), primitive (== 0.5.*), definitive-parser (== 1.2.*), definitive-filesystem (== 1.2.*), definitive-reactive (== 1.0.*), clock (== 0.4.*), directory (== 1.2.*), filepath (== 1.3.*), time (== 1.4.*), old-locale (== 1.0.*), unix (== 2.7.*), process (== 1.2.*)+ default-extensions: RebindableSyntax NoMonomorphismRestriction GeneralizedNewtypeDeriving FlexibleInstances LambdaCase FlexibleContexts MultiParamTypeClasses ImplicitParams ghc-options: default-language: Haskell2010
Grow.hs view
@@ -1,14 +1,22 @@-{-# LANGUAGE RebindableSyntax, NoMonomorphismRestriction, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} module Grow where -import Algebra-import IO.Filesystem-import qualified Prelude as P-import Algebra.Parser-import Grow.Syntax+import Definitive+import Language.Parser+import Language.Grow+import Language.Syntax.Grow -pureVal :: SyntaxT Id -> SyntaxT Id-pureVal = id+c'growing :: Constraint (SyntaxT Growing)+c'growing = id +trans t = map (getMax . fst) . grow t . reduce+-- trans = id+ main :: IO ()-main = print =<< (P.readFile "Seed" <&> map2 pureVal growExpr^..parser)+main = cli "Grow" $ case ?cliargs of+ [t] -> void $ do+ l <- (readString "Seed" <&> map2 c'growing (cut growExpr)^..parser)+ case l of+ [] -> putStrLn "Couldn't parse the Seed file"+ _ -> forl_ (traverse.l'2.traverse) l $ \a -> print =<< trans t a+ _ -> error "Usage: grow <target>"+
− Grow/Syntax.hs
@@ -1,37 +0,0 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}-module Grow.Syntax(- module Data.Syntax,- growExpr- ) where--import Algebra-import Algebra.Parser-import Data.Containers-import Data.Syntax-import Data.Char--instance MonadReader a Id where- ask = pure undefined- local _ = id--growExpr :: Parser String [SyntaxT Id]-growExpr = free expr `sepBy1` free (single ';')- where- decl = (,)<$>symbol<*>(free (single '=') >> free expr)- free = (many space >> )- symbol = many1 (satisfy symChar)- where symChar c = isAlphaNum c || (c`elem`"/+-_~%*!")- funAp = (atom`sepBy1`spaces) <&> ValList . map pure- expr = chainr funAp (op <$> free (single ':' >> (atom <* space))) funAp- where op f a b = ValList [pure f,pure a,pure b]- atom = between (single '(') (free $ single ')') (free inParen) + list + dictionary + (Text<$>symbol) + dollar- where dollar = single '$' >> (atom <&> \e -> ValList [pure $ Text "$",pure e])- inParen = Function . lambdaSum<$>(free abstract`sepBy`free (single '|'))- <+> expr- abstract = lambda<$>atom<*>free (several "~>")*>free expr- - list = funcall (pure $ Function id).pure.ValList . map pure- <$>between (single '[') (free $ single ']') (free expr`sepBy`free (single ','))- dictionary = mkDict<$>between (single '{') (free $ single '}') (free decl`sepBy`free (single ','))- mkDict = Dictionary . fromList . map (\(s,v) -> (s,pure v))-
LICENSE view
@@ -0,0 +1,39 @@+THE FREE BEER PUBLIC LICENSE+--------++The Free Beer Public License is designed to provide free (as in beer,+hence the name), unlimited access to any content for anyone who wishes+it, without restrictions such as property rights or affordability.++This license embodies the philosophy that all software (and more+generally all good ideas) is designed to solve a particular problem,+and that the only way to judge its quality is by how well it solves+that problem, rather than other unrelated criteria such as sellability+or merchandability.++All kinds of works may be licensed under the FBPL, as long as the+aforementioned works are within the legal rights of the provider to+give.++TERMS AND CONDITIONS+--------------------++### 1. Free as in Beer++The provider of this work shall make it available, free of any charge,+monetary or otherwise, to the consumer, to use without restrictions or+any kind of supervision.++### 2. Freely taken is freely given++The consumer of this work may redistribute it as well as derived works+in any way he or she chooses, as long as the work itself and any+derived work remain Free as in Beer, as per the first clause.++### 3. The Burden of Proof++The provider of this work shall also supply explanations for how the+work was realized if requested, in the form of source code for example, or+supply the means to access such explanations.++Every such explanation shall be Free as in Beer, as per the first clause.
+ Language/Grow.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE RankNTypes #-}+module Language.Grow where++import Definitive+import IO.Filesystem+import Language.Parser+import IO.Time+import Data.Syntax+import Data.Containers+import System.Process+import System.IO.Unsafe (unsafeInterleaveIO)+import Control.Concurrent (forkIO,newEmptyMVar,putMVar,takeMVar)+import System.Directory (getDirectoryContents)++il = liftIO . unsafeInterleaveIO++type GrowSt = Env Growing+type TimeStamp = Max (TimeVal Seconds)+newtype Growing a = Growing (ReaderT GrowSt (WriterT TimeStamp IO) a)+ deriving (Functor,Applicative,Unit,Monad,+ MonadFix,MonadWriter TimeStamp,MonadReader GrowSt,MonadIO)+_Growing :: Iso (Growing a) (Growing b) (ReaderT GrowSt (WriterT TimeStamp IO) a) (ReaderT GrowSt (WriterT TimeStamp IO) b)+_Growing = iso Growing (\(Growing a) -> a)++class (MonadWriter TimeStamp m,MonadReader (Env m) m,MonadIO m) => MonadGrow m+instance MonadGrow Growing++instance Semigroup (SyntaxT f) where+ Text t + Text t' = Text (t+t')+ ValList l + ValList l' = ValList (l+l')+ Dictionary d + Dictionary d' = Dictionary (d+d')+ Function f + Function f' = Function (f'.f)+ a + ValList [] = a+ ValList [] + a = a+ a + b = error $ "Illegal shape for + "+shape a+" "+shape b+instance Monoid (SyntaxT f) where+ zero = nil++initial :: GrowSt+initial = fromList [+ ("+", builtin2 $ liftA2 (+)),+ ("cache", b_cache),+ ("hook", b_hook),+ ("words", b_words),+ ("head", b_head),+ ("tee", b_tee),+ ("in", b_in),+ ("eval",b_eval),+ ("environment", pure (Dictionary initial)),+ ("keys", b_keys),+ ("fold", b_fold),+ ("shape", b_shape),+ ("map", b_map),+ ("seq", b_seq),+ ("lambda", b_lambda),+ ("ls", b_ls)+ ]+ where ++type Builtin = forall m. MonadGrow m => ThunkT m++illegalShape fun args = error $ "Illegal shape for function '"+fun+"' : "+show (shape<$>args)++b_ls, b_lambda, b_seq, b_map,b_shape, b_fold, b_keys, b_eval, b_head, b_words, b_hook, b_cache, b_in, b_tee, b_dollar :: Builtin+b_ls = builtin (mute >=> ls)+ where ls (Text s) = do+ tell $ Max (modTime s^.thunk)+ return $ ValList [pure (Text (s+"/"+n)) | n <- getDirectoryContents s^.thunk]+ +b_lambda = builtin2 (\a b -> a >>= flip lambda b)+ where lambda (Text v) x = pure (Function (\a -> local (insert v a) x)) + lambda x _ = illegalShape "lambda" [x]+b_seq = builtin2 (liftA2 _seq)+ where _seq (Text _) a = a+ _seq _ a = a+b_map = builtin2 (liftA2 _map)+ where _map (Function f) (ValList l) = ValList (map f l)+ _map (Function f) (Dictionary d) = Dictionary (map f d)+ _map x y = illegalShape "map" [x,y]+b_eval = builtin (>>= reduce)+b_shape = builtin (map (Text . shape))+b_fold = builtin (>>= _fold)+ where _fold (ValList l) = fold<$>sequence l+ _fold (Dictionary d) = fold<$>sequence d+ _fold x = illegalShape "fold" [x]++b_keys = builtin (map _keys)+ where _keys (Dictionary d) = ValList (pure . Text . fst <$> toList (d^.keyed))+ _keys x = illegalShape "keys" [x]+b_head = builtin (>>= _head)+ where _head (ValList (h:t)) = h+ _head x = illegalShape "head" [x]+ +b_words = builtin (map _words)+ where _words (Text t) = ValList [pure (Text w) | w <- words t]+b_hook = builtin3 (bind3 hook)+ where hook (Text prg) (ValList dsts) (ValList args) = do+ (args,dsts) <- mute ((,)<$>sequence args<*>sequence dsts)+ (tsrc,srcVals) <- intercept (traverse getVal args)+ (tdsts,dstVals) <- unzip <$> traverse (intercept . getVal) dsts+ done <- when (any (liftA2 (||) (<tsrc) (==zero)) tdsts) $ il $ do+ vars <- sequence (newEmptyMVar<$srcVals)+ tids <- for (zip vars srcVals) $ \(v,x) -> do+ forkIO $ x^..thunk >> putMVar v ()+ traverse_ takeMVar vars+ callProcess ("./"+prg) [t | Text t <- dsts + args]+ let dstFile n = tell (Max (modTime n^.thunk) + tsrc) >> seq done . Text <$> il (readString n)+ pure (Dictionary $ fromList [(n,dstFile n) | Text n <- dsts])+b_cache = builtin2 $ \x y -> bind2 cache x (listen y)+ where cache (Text f) (Max t,Text c) = do+ t' <- liftIO (modTime f) + if t>t' then+ Text c <$ liftIO (writeString f c)+ else Text<$> il (readString f)+ cache x (_,y) = illegalShape "cache" [x,y]+ +b_in = builtin2 $ \e d -> mute d >>= \(Dictionary d') -> local (d'+) e++b_tee = builtin (>>= tee)+ where tee (Text t) = Text t <$ liftIO (putStrLn t)+ tee x = illegalShape "tee" [x]+b_dollar = builtin (mute >=> getVal)++getVal :: MonadGrow m => SyntaxT m -> ThunkT m+getVal (Text t) = ask >>= \d -> sequence (d^.at t) >>= \case+ Nothing -> do+ stamp <- liftIO (Max<$>modTime t)+ Text (readString t^.thunk) <$ tell stamp+ Just x -> pure x+getVal x = illegalShape "getVal" [x]++grow :: String -> Growing a -> IO (TimeStamp,a)+grow t g = (g^..mapping writerT.readerT._Growing) (insert "arg" (pure (Text t)) initial)+
+ Language/Syntax/Grow.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE UndecidableInstances #-}+module Language.Syntax.Grow(+ module Data.Syntax,+ growExpr+ ) where++import Definitive+import Language.Parser+import Data.Containers+import Data.Syntax+import Data.Char+import Language.Grow++instance MonadReader a Id where+ ask = Id undefined+ local _ = id+instance Monoid m => MonadWriter m Id where+ tell _ = pure ()+ listen (Id a) = Id (zero,a)+ censor (Id (a,f)) = Id a+instance MonadIO Id where+ liftIO a = pure undefined++-- ^ For debugging purposes+instance MonadGrow Id++growExpr :: MonadGrow m => Parser String [SyntaxT m]+growExpr = free expr `sepBy1` free (single ';')+ where+ decl = (,)<$>symbol<*>(free (single '=') >> free expr)+ free = (skipMany space >> )+ symbol = many1 (satisfy symChar) <+> quotedString '"'+ where symChar c = isAlphaNum c || (c`elem`".-_/+~%*!")+ funAp = (atom`sepBy1`spaces) <&> call+ where call [x] = x+ call t = ValList $ b_dollar : map pure t+ expr = chainr funAp (op <$> free (single ':' >> (atom <* space))) funAp + where op f a b = ValList [b_dollar,pure f,pure a,pure b]+ atom :: MonadGrow m => Parser String (SyntaxT m)+ atom = sum [+ between (single '(') (free $ single ')') (free inParen)+ ,list,dictionary,Text<$>symbol,dollar]+ where dollar = single '$' >> (atom <&> \e -> ValList [b_dollar,pure e])+ inParen = Function . lambdaSum<$>many1 (free (single '|' >> abstract))+ <+> expr+ abstract = lambda<$>atom<*>free (several "~>")*>free expr+ + list = Quote . ValList . map pure+ <$>between (single '[') (free $ single ']') (free expr`sepBy`free (single ','))+ dictionary = mkDict<$>between (single '{') (free $ single '}') (free decl`sepBy`free (single ','))+ mkDict = Dictionary . fromList . map (\(s,v) -> (s,pure v))+