diff --git a/Grow.cabal b/Grow.cabal --- a/Grow.cabal +++ b/Grow.cabal @@ -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 "... ...". 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 diff --git a/Grow.hs b/Grow.hs --- a/Grow.hs +++ b/Grow.hs @@ -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 " + diff --git a/Grow/Syntax.hs b/Grow/Syntax.hs deleted file mode 100644 --- a/Grow/Syntax.hs +++ /dev/null @@ -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)) - diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/Language/Grow.hs b/Language/Grow.hs new file mode 100644 --- /dev/null +++ b/Language/Grow.hs @@ -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 (||) ( 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) + diff --git a/Language/Syntax/Grow.hs b/Language/Syntax/Grow.hs new file mode 100644 --- /dev/null +++ b/Language/Syntax/Grow.hs @@ -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)) +