cake3 0.1.0.0 → 0.2.1.0
raw patch · 13 files changed
+1734/−636 lines, 13 filesdep +attoparsecdep +language-javascriptdep +mime-typesdep −QuasiTextnew-component:exe:urembed
Dependencies added: attoparsec, language-javascript, mime-types, optparse-applicative, syb
Dependencies removed: QuasiText
Files
- cake3.cabal +77/−12
- src/CakeScript.sh +93/−27
- src/Development/Cake3.hs +103/−223
- src/Development/Cake3/Ext/UrWeb.hs +492/−0
- src/Development/Cake3/Ext/UrWeb/UrEmbed.hs +125/−0
- src/Development/Cake3/Monad.hs +333/−110
- src/Development/Cake3/Rules/UrWeb.hs +0/−146
- src/Development/Cake3/Types.hs +101/−34
- src/Development/Cake3/Utils/Find.hs +2/−1
- src/Development/Cake3/Writer.hs +253/−64
- src/System/FilePath/Wrapper.hs +27/−19
- src/Text/QuasiMake.hs +100/−0
- src/UrEmbedHelp.txt +28/−0
cake3.cabal view
@@ -2,33 +2,88 @@ -- see http://haskell.org/cabal/users-guide/ name: cake3-version: 0.1.0.0-synopsis: Third cake - Makefile DSL-description: Thirdcake is a Makefile DSL written in Haskell. Write your build logic in+version: 0.2.1.0+synopsis: Third cake the Makefile EDSL+description: Cake3 is a Makefile EDSL written in Haskell. Write your build logic in Haskell, obtain clean and safe Makefile, distribute it to the end-users. GNU Make is required. license: BSD3 license-file: LICENSE author: Sergey Mironov maintainer: grrwlf@gmail.com--- copyright: +homepage: https://github.com/grwlf/cake3+description: + Cake3 is a EDSL for building Makefiles, written in Haskell. With cake3,+ developer can write their build logic in Haskell, obtain clean and safe Makefile+ and distribute it among the non-Haskell-aware users. Currenly, GNU Make is+ the only backend supported.+ .+ /Example program/+ .+ > module Cakefile where+ >+ > import Development.Cake3+ > import Cakefile_P+ >+ > cs = map file ["main.c", "second.c"]+ >+ > main = writeMake (file "Makefile") $ do+ > selfUpdate+ > d <- rule $ do+ > shell [cmd|gcc -M $cs -MF @(file "depend.mk")|]+ > os <- forM cs $ \c -> do+ > rule $ do+ > shell [cmd| gcc -c $(extvar "CFLAGS") -o @(c.="o") $c |]+ > elf <- rule $ do+ > shell [cmd| gcc -o @(file "main.elf") $os |]+ > rule $ do+ > phony "clean"+ > unsafeShell [cmd|rm $elf $os $d|]+ > rule $ do+ > phony "all"+ > depend elf+ > includeMakefile d+ .+ /Basic workflow/+ .+ * Install the cake3+ .+ * Create Cakefile.hs in the project root+ .+ * Build the application using cake3 script provided+ . + * Execute the application to obtain the Makefile+ .+ See the README on the GitHub <https://github.com/grwlf/cake3> for more information.+ .+ /Changes/+ .+ * 0.1 - Initial release+ .+ * 0.2 - Redesign (simplify) monadic interface, add support for prebuild/postbuild actions.++ category: Development build-type: Simple cabal-version: >=1.8 data-dir: src-data-files: CakeScript.sh+data-files: CakeScript.sh, UrEmbedHelp.txt library- exposed-modules: Development.Cake3, Development.Cake3.Types,- Development.Cake3.Writer, System.FilePath.Wrapper,- Development.Cake3.Monad,- Development.Cake3.Rules.UrWeb+ exposed-modules: Development.Cake3+ Development.Cake3.Types+ Development.Cake3.Writer+ System.FilePath.Wrapper+ Development.Cake3.Monad+ Development.Cake3.Ext.UrWeb Development.Cake3.Utils.Find+ Text.QuasiMake build-depends: base ==4.6.*, haskell-src-meta, template-haskell,- QuasiText, filepath, containers, text, monadloc, mtl,- bytestring,deepseq, system-filepath, text-format,- directory+ filepath, containers, text, monadloc, mtl,+ bytestring, deepseq, system-filepath, text-format,+ directory, attoparsec, mime-types,+ language-javascript ==0.5.*, syb hs-source-dirs: src @@ -36,5 +91,15 @@ hs-source-dirs: src main-is: CakeScript.hs build-depends: base ==4.6.*, process+ other-modules: Paths_cake3++executable urembed+ hs-source-dirs: src+ main-is: Development/Cake3/Ext/UrWeb/UrEmbed.hs+ build-depends: base == 4.6.*, mtl, language-javascript ==0.5.*, process,+ filepath, syb, optparse-applicative, directory,+ text, bytestring, containers, language-javascript,+ haskell-src-meta, template-haskell, attoparsec, monadloc,+ mime-types other-modules: Paths_cake3
src/CakeScript.sh view
@@ -10,53 +10,105 @@ -- This file was autogenerated by cake3. -- $CAKEURL -module ${1}_P(file,cakefiles,projectroot,moduleroot) where+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE QuasiQuotes #-}+module ${1}_P(file, cakefiles, selfUpdate,filterDirectoryContentsRecursive) where +import Control.Monad.Trans+import Control.Monad.State import Development.Cake3+import Development.Cake3.Monad+import Development.Cake3.Utils.Find+import GHC.Exts (IsString(..)) +pl = ProjectLocation projectroot moduleroot+ file :: String -> File-file x = file' "$TOP" "$2" x+file x = file' pl x -projectroot :: File-projectroot = file "$TOP"+-- instance IsString File where+-- fromString = file -moduleroot :: File-moduleroot = file "$2"+projectroot :: FilePath+projectroot = "$TOP" +moduleroot :: FilePath+moduleroot = "$2"+ cakefiles :: [File]-cakefiles = case "$2" of- "$TOP" -> map (file' "$TOP" "$TOP") \$ $3- _ -> error "cakefiles are defined for top-level cake only"+cakefiles = + let rl = ProjectLocation projectroot projectroot in+ case "$2" of+ "$TOP" -> map (file' rl) ($3)+ _ -> error "cakefiles are defined for top-level cake only" +selfUpdate :: Make [File]+selfUpdate = do+ makefile <- outputFile <$> get+ (_,cg) <- rule2 $ do+ depend cakefiles+ produce (file "Cakegen")+ shell [cmd|cake3|]+ (_,f) <- rule2 $ do+ produce makefile+ shell [cmd|\$cg|]+ return f++filterDirectoryContentsRecursive :: (MonadIO m) => [String] -> m [File]+filterDirectoryContentsRecursive exts = liftM (filterExts exts) (getDirectoryContentsRecursive (file "."))+ EOF } caketemplate() { cat <<"EOF"-{-# LANGUAGE RecursiveDo, QuasiQuotes #-}+{-# LANGUAGE QuasiQuotes, OverloadedStrings #-} module Cakefile where import Development.Cake3-import Cakefile_P (file, cakefiles)+import Cakefile_P (file,projectroot) -elf = rule (file "main.elf") $ do- shell [cmd| echo "Your commands go here" ; exit 1 ; |] -main = runMake (place (phony "all" (depend elf)) >> place defaultSelfUpdate)+main = writeMake "Makefile" $ do + cs <- filterDirectoryContentsRecursive [".c"]++ d <- rule $ do+ shell [cmd|gcc -M @cfiles -MF %(file "depend.mk")|]++ os <- forM cs $ \c -> do+ rule $ do+ shell [cmd| gcc -c $(extvar "CFLAGS") -o %(c.="o") @c |]++ elf <- rule $ do+ shell [cmd| gcc -o %(file "main.elf") @os |]++ rule $ do+ phony "all"+ depend elf++ includeMakefile d+ EOF } +ARGS_PASS=""+GHCI=n+GHC_EXTS="-XFlexibleInstances -XTypeSynonymInstances -XOverloadedStrings -XQuasiQuotes"+ while test -n "$1" ; do case "$1" in --help|-h|help) - err "Cake3 the Makefile generator help"+ err "Cake3 the Makefile generator" err "$CAKEURL"- err "Usage: cake3 [--help|-h] [init]"+ err "Usage: cake3 [--help|-h] [init] args" err "cake3 init"- err " - Create default Cakefile.hs"- err "cake3"- err " - Build the Makefile"+ err " - Create the default Cakefile.hs"+ err "cake3 <args>"+ err " - Compile the ./Cakegen and run it. Args are passed as is."+ err ""+ err "Other arguments are passed to the ./Cakgegen as is" exit 1; ;; init)@@ -66,6 +118,12 @@ echo "Cakefile.hs has been created" exit 0; ;;+ ghci)+ GHCI=y+ ;;+ *)+ ARGS_PASS="$ARGS_PASS $1"+ ;; esac shift done@@ -77,9 +135,11 @@ find -type f '(' -name 'Cake*\.hs' -or -name 'Cake*\.lhs' \ -or -name '*Cake\.hs' -or -name '*Cake\.lhs' ')' \ -and -not -name '*_P.hs' \- | grep -v '^\.[a-zA-Z].*'+ | grep -v '^\.[a-zA-Z].*' \+ | sort } +OIFS=$IFS IFS=$'\n' CAKES=`cakes` CAKELIST="[]"@@ -111,20 +171,21 @@ fi if test -f "$tgt" ; then- die "More than one file named '${fname}.hs' in the filetree"+ err "Warning: duplicate file name, ignoring $f."+ continue fi cp "$f" "$tgt" ||- die "cp $f $tgt failed. Duplicate names?"+ die "Couldn't cp $f $tgt" if cat "$f" | grep -q "import.*${fname}_P" ; then- echo "Creating $fdir/${pname}" >&2+ err "Creating $fdir/${pname}" cakepath "$fname" "$fdir_abs" "$CAKELIST" > "$fdir/${pname}" cp "$fdir/${pname}" "$T/${pname}" || die -n "cp $fdir/${pname} $T/${pname} failed" else- echo "Skipping creating $fdir/${pname}" >&2+ err "Warning: ${pname} is not required by $f" fi done @@ -132,12 +193,17 @@ die "No Cake* file exist in the current directory. Consider running \`cake3 --help'." fi +IFS=$OIFS+ ( set -e cd $T-ghc --make "$MAIN_" -main-is "$MAIN" -o Cakegen+case $GHCI in+ n) ghc --make "$MAIN_" $GHC_EXTS -main-is "$MAIN" -o Cakegen ;;+ y) exec ghci -main-is "$MAIN" $GHC_EXTS ;;+esac+ cp -t "$CWD" Cakegen ) &&--./Cakegen > Makefile && echo "Makefile created" >&2+./Cakegen $ARGS_PASS
src/Development/Cake3.hs view
@@ -1,37 +1,36 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FunctionalDependencies #-} module Development.Cake3 ( - Alias- , Variable+ Variable , Recipe- , Referal(..)- , Placable(..)- , Reference- , ReferenceLike(..)+ , RefInput(..)+ , RefOutput(..)+ , CakeString+ , string -- Monads , A , Make- , toMake+ , buildMake , runMake- , runMake_+ , writeMake+ , includeMakefile+ , MonadMake(..) -- Rules- , Rule- , Rules , rule- , ruleM+ , rule2+ , rule' , phony- , phonyM , depend- , unsafe- , defaultSelfUpdate+ , produce+ , ignoreDepends+ , prebuild+ , postbuild -- Files , FileLike(..)@@ -40,33 +39,32 @@ , (.=) , (</>) , toFilePath- , fromFilePath+ , readFileForMake -- Make parts , prerequisites , shell+ , unsafeShell , cmd , makevar , extvar- , dst- , makefile- , CommandGen(..)- , unCommand+ , CommandGen'(..)+ , make+ , ProjectLocation(..)+ , currentDirLocation - -- More+ -- Import several essential modules+ , module Data.String , module Control.Monad , module Control.Applicative ) where -import Prelude (id, Char(..), Bool(..), Maybe(..), Either(..), flip, ($), (+), (.), (/=), undefined, error,not)- import Control.Applicative import Control.Monad import Control.Monad.Trans import Control.Monad.Writer import Control.Monad.State import Control.Monad.Loc-import qualified Data.Text as T import qualified Data.List as L import Data.List (concat,map, (++), reverse,elem,intercalate,delete) import Data.Foldable (Foldable(..), foldr)@@ -74,225 +72,107 @@ import Data.Map (Map) import qualified Data.Set as S import Data.Set (Set,member,insert)-import Data.String as S+import Data.String import Data.Tuple import System.IO+import System.Directory import qualified System.FilePath as F-import Text.QuasiText import Text.Printf -import Language.Haskell.TH.Quote-import Language.Haskell.TH hiding(unsafe)-import Language.Haskell.Meta (parseExp)- import Development.Cake3.Types import Development.Cake3.Writer import Development.Cake3.Monad-import System.FilePath.Wrapper--makefile :: File-makefile = makefileT--file' :: String -> String -> String -> File-file' root cwd f' =- let f = F.dropTrailingPathSeparator f' in- (fromFilePath ".") </> makeRelative (fromFilePath root)- ((fromFilePath cwd) </> (fromFilePath f))--defaultSelfUpdate = rule makefile $ do- -- shell [cmd|./Cakegen > Makefile |]- shell (CommandGen (concat <$> sequence [- ref $ (fromFilePath ".") </> (fromFilePath "Cakegen" :: File)- , ref $ string " > "- , ref makefile]))--runMake_ :: Make () -> IO ()-runMake_ mk = evalMake mk >>= output where- output (Left err) = hPutStrLn stderr err- output (Right a) = hPutStrLn stdout (toMake a)--runMake :: Make () -> IO String-runMake mk = evalMake mk >>= output where- output (Left err) = fail err- output (Right a) = return (toMake a)---- | CommandGen is a recipe packed in the newtype to prevent partial expantion-newtype CommandGen = CommandGen (A Command)-unCommand (CommandGen a) = a--type Rule = Alias-type Rules = [Alias]+import System.FilePath.Wrapper as W --- | Means that data structure f (containing Files) may be used to create data--- structure a (containing Aliases).-class Rulable f a | f -> a where- rule :: f -> A () -> a+data ProjectLocation = ProjectLocation {+ root :: FilePath+ , off :: FilePath+ } deriving (Show, Eq, Ord) -ruleM :: (Monad m, Rulable f a) => f -> A () -> m a-ruleM a b = return (rule a b)+currentDirLocation :: (MonadIO m) => m ProjectLocation+currentDirLocation = do+ cwd <- liftIO $ getCurrentDirectory+ return $ ProjectLocation cwd cwd -list1 a = [a]-fmap1 f a = f a+file' :: ProjectLocation -> String -> File+file' pl f' = fromFilePath (addpoint (F.normalise rel)) where+ rel = makeRelative (root pl) ((off pl) </> f)+ f = F.dropTrailingPathSeparator f'+ addpoint "." = "."+ addpoint p = "."</>p -list2 (a1,a2) = [a1,a2]-fmap2 f (a1,a2) = (f a1,f a2)+runMake'+ :: File -- ^ Output file+ -> Make a -- ^ Make builder+ -> (String -> IO b) -- ^ Handler to output the file+ -> IO b+runMake' makefile mk output = do+ ms <- evalMake makefile mk+ when (not $ L.null (warnings ms)) $ do+ hPutStr stderr (warnings ms)+ when (not $ L.null (errors ms)) $ do+ fail (errors ms)+ case buildMake ms of+ Left e -> fail e+ Right s -> output s -list3 (a1,a2,a3) = [a1,a2,a3]-fmap3 f (a1,a2,a3) = (f a1,f a2,f a3)+-- | Execute the Make monad, build the Makefile, write it to the output file. Also+-- note, that errors (if any) go to the stderr. fail will be executed in such+-- cases+writeMake+ :: File -- ^ Output file+ -> Make a -- ^ Makefile builder+ -> IO ()+writeMake f mk = runMake' f mk (writeFile (toFilePath f)) -list4 (a1,a2,a3,a4) = [a1,a2,a3,a4]-fmap4 f (a1,a2,a3,a4) = (f a1,f a2,f a3,f a4)+-- | A General Make runner. Executes the monad, returns the Makefile as a+-- String. Errors go to stdout. fail is possible.+runMake :: Make a -> IO String+runMake mk = runMake' defaultMakefile mk return -phony name = rule' fmap1 list1 True (fromFilePath name)+-- | Execute Make action, place the recipe above all other recipes (it will be+-- higher in the final Makefile)+withPlacement :: (MonadMake m) => m (Recipe,a) -> m (Recipe,a)+withPlacement mk = do+ (r,a) <- mk+ liftMake $ do+ addPlacement 0 (S.findMin (rtgt r))+ return (r,a) -phonyM :: (Monad m) => String -> A () -> m Alias-phonyM n a = return $ phony n a+-- | Adds the phony target for a rule. Typical usage:+-- +-- > rule $ do+-- > phony "clean"+-- > unsafeShell [cmd|rm $elf $os $d|]+-- >+phony :: String -> A ()+phony name = do+ produce (W.fromFilePath name :: File)+ markPhony -rule' fmapX listX isPhony dst act = flip fmapX dst $ \x -> Alias (x, listX dst, do+-- | Build a Recipe using recipe builder @act. Don't change recipe's priority.+rule2 :: (MonadMake m) => A a -> m (Recipe,a)+rule2 act = liftMake $ do loc <- getLoc- runA (Recipe (S.fromList (listX dst)) mempty [] M.empty loc isPhony) act)--instance Rulable File Alias where- rule = rule' fmap1 list1 False--instance Rulable (File,File) (Alias,Alias) where- rule = rule' fmap2 list2 False--instance Rulable (File,File,File) (Alias,Alias,Alias) where- rule = rule' fmap3 list3 False--instance Rulable (File,File,File,File) (Alias,Alias,Alias,Alias) where- rule = rule' fmap4 list4 False--instance Rulable [File] [Alias] where- rule = rule' map id False---- FIXME: depend can be used under unsafe but it doesn't work-unsafe :: A () -> A ()-unsafe action = do- r <- get- action- modify $ \r' -> r' { rsrc = rsrc r, rvars = rvars r }--shell :: CommandGen -> A ()-shell cmd = do- line <- unCommand cmd- modify (\r -> r { rcmd = (rcmd r) ++ [line] })--depend :: (Referal x) => x -> A ()-depend x = ref x >> return ()--var :: String -> Maybe String -> Variable-var n v = Variable n v--makevar :: String -> String -> Variable-makevar n v = var n (Just v)--extvar :: String -> Variable-extvar n = var n Nothing--newtype Reference = Reference String--class ReferenceLike a where- string :: a -> Reference--instance ReferenceLike String where- string s = Reference s--instance ReferenceLike File where- string (FileT x) = string x--instance ReferenceLike Alias where- string (Alias (x,_,_)) = string x--dst :: A (Set File)-dst = rtgt <$> get---- | Data structure x may be referenced from within the command. Referal--- class specifies side effects of such referencing. For example, referencig the--- file leads to adding it to the prerequisites list.-class Referal x where- ref :: x -> A Command--instance Referal Command where- ref = return--instance Referal Reference where- ref v@(Reference s) = do- return_text s--instance Referal Variable where- ref v@(Variable n _) = do- addVariable v- return_text $ printf "$(%s)" n---- Alias may be referenced from the recipe of itself, so we have to prevent--- the recursion-not_myself :: File -> A a -> A ()-not_myself f act = targets >>= \ts -> do- when (not (f `member` ts)) (act >> return ())--instance Referal File where- ref f = do- not_myself f $ do- modify $ \r -> r { rsrc = f `insert` (rsrc r)}- return_file f--instance Referal Alias where- ref (Alias (f,_,mr)) = do- not_myself f (A (lift mr))- ref f--instance Referal [Alias] where- ref as = concat <$> (mapM ref as)--instance Referal (Set File) where- ref as = ref (S.toList as)--instance Referal [File] where- ref fs = concat <$> mapM ref fs--instance Referal x => Referal (A x) where- ref mx = mx >>= ref--instance Referal x => Referal (Make x) where- ref mx = (A $ lift mx) >>= ref--instance Referal x => Referal (IO x) where- ref mx = liftIO mx >>= ref--instance Referal CommandGen where- ref (CommandGen acmd) = ref acmd+ (r,a) <- runA loc act+ addRecipe r+ return (r,a) --- | Has effect of a function :: QQ -> CommandGen where QQ is a string supporting--- $VARs. Each $VAR will be dereferenced using Ref typeclass. Result will--- be equivalent to+-- | Version of rule2 which places it's recipe above all other recipies. ----- return Command $ do--- s1 <- ref "gcc "--- s2 <- ref (flags :: Variable)--- s3 <- ref " "--- s4 <- ref (file :: File)--- return (s1 ++ s2 ++ s3)+-- > let c = file "main.c" ----- Later, this command may be examined or passed to the shell function to apply--- it to the recepi+-- Declare a rule to build "main.o" out of "main.c" and "CFLAGS" variable ---cmd :: QuasiQuoter-cmd = QuasiQuoter- { quotePat = undefined- , quoteType = undefined- , quoteDec = undefined- , quoteExp = \s -> appE [| \x -> CommandGen x |] (qqact s)- } where- qqact s = - let chunks = flip map (getChunks (S.fromString s)) $ \c ->- case c of- T t -> [| return_text t |]- E t -> case parseExp (T.unpack t) of- Left e -> error e- Right e -> appE [| ref |] (return e)- V t -> appE [| ref |] (global (mkName (T.unpack t)))- in appE [| \l -> L.concat <$> (sequence l) |] (listE chunks)+-- > rule $ shell [cmd| gcc -c $(extvar "CFLAGS") -o @(c.="o") $c |]+--+rule+ :: A a -- ^ Rule builder+ -> Make a+rule act = snd <$> withPlacement (rule2 act)++-- | Version of rule2, without Make monad set explicitly+rule' :: (MonadMake m) => A a -> m a+rule' act = liftMake $ snd <$> withPlacement (rule2 act)
+ src/Development/Cake3/Ext/UrWeb.hs view
@@ -0,0 +1,492 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+module Development.Cake3.Ext.UrWeb where++import Data.Data+import Data.Char+import Data.Typeable+import Data.Generics+import Data.Maybe+import Data.Monoid+import Data.List ()+import qualified Data.List as L+import Data.Set (Set)+import qualified Data.Set as S+import Data.Foldable (Foldable(..), foldl')+import qualified Data.Foldable as F+import Data.ByteString.Char8 (ByteString(..))+import qualified Data.ByteString.Char8 as BS+import qualified Data.Text as T+import Data.String+import Control.Applicative+import Control.Monad.Trans+import Control.Monad.State+import Control.Monad.Writer+import Control.Monad.Error+import Language.JavaScript.Parser+import Network.Mime (defaultMimeLookup)+import System.Directory+import Text.Printf+import qualified System.FilePath as F+import System.IO as IO++import System.FilePath.Wrapper+import Development.Cake3.Monad+import Development.Cake3++data UrpAllow = UrpMime | UrpUrl+ deriving(Show,Data,Typeable)++data UrpRewrite = UrpStyle+ deriving(Show,Data,Typeable)++data UrpHdrToken = UrpDatabase String+ | UrpSql File+ | UrpAllow UrpAllow String+ | UrpRewrite UrpRewrite String+ | UrpLibrary File+ | UrpDebug+ | UrpInclude File+ | UrpLink File+ | UrpFFI File+ | UrpJSFunc String String+ | UrpSafeGet String+ deriving(Show,Data,Typeable)++data UrpModToken+ = UrpModule1 File+ | UrpModule2 File File+ | UrpModuleSys String+ deriving(Show,Data,Typeable)++data Urp = Urp {+ urp :: File+ , uexe :: Maybe File+ , uhdr :: [UrpHdrToken]+ , umod :: [UrpModToken]+ } deriving(Show,Data,Typeable)++newtype UWLib = UWLib Urp+ deriving (Show,Data,Typeable)++newtype UWExe = UWExe Urp+ deriving (Show,Data,Typeable)++instance (MonadAction a m) => RefInput a m UWLib where+ refInput (UWLib u) = refInput (urp u)+ +instance (MonadAction a m) => RefInput a m UWExe where+ refInput (UWExe u) = refInput (urpExe u)+ ++urpDeps :: Urp -> [File]+urpDeps (Urp _ _ hdr mod) = foldl' scan2 (foldl' scan1 mempty hdr) mod where+ scan1 a (UrpLink f) = f:a+ scan1 a (UrpInclude f) = f:a+ scan1 a _ = a+ scan2 a (UrpModule1 f) = f:a+ scan2 a (UrpModule2 f1 f2) = f1:f2:a+ scan2 a _ = a++urpSql' :: Urp -> Maybe File+urpSql' (Urp _ _ hdr _) = find hdr where+ find [] = Nothing+ find ((UrpSql f):hs) = Just f+ find (h:hs) = find hs++urpSql :: Urp -> File+urpSql u = case urpSql' u of+ Nothing -> error "ur project defines no SQL file"+ Just sql -> sql++urpObjs (Urp _ _ hdr _) = foldl' scan [] hdr where+ scan a (UrpLink f) = f:a+ scan a _ = a++urpLibs (Urp _ _ hdr _) = foldl' scan [] hdr where+ scan a (UrpLibrary f) = f:a+ scan a _ = a++urpExe u = case uexe u of+ Nothing -> error "ur project defines no EXE file"+ Just exe -> exe++data UrpState = UrpState {+ urpst :: Urp+ } deriving (Show)++defState urp = UrpState (Urp urp Nothing [] [])++class ToUrpWord a where+ toUrpWord :: a -> String++instance ToUrpWord UrpAllow where+ toUrpWord (UrpMime) = "mime"+ toUrpWord (UrpUrl) = "url"++instance ToUrpWord UrpRewrite where+ toUrpWord (UrpStyle) = "style"++class ToUrpLine a where+ toUrpLine :: FilePath -> a -> String++instance ToUrpLine UrpHdrToken where+ toUrpLine up (UrpDatabase dbs) = printf "database %s" dbs+ toUrpLine up (UrpSql f) = printf "sql %s" (up </> toFilePath f)+ toUrpLine up (UrpAllow a s) = printf "allow %s %s" (toUrpWord a) s+ toUrpLine up (UrpRewrite a s) = printf "rewrite %s %s" (toUrpWord a) s+ toUrpLine up (UrpLibrary f) = printf "library %s" (up </> toFilePath (dropExtensions f))+ toUrpLine up (UrpDebug) = printf "debug"+ toUrpLine up (UrpInclude f) = printf "include %s" (up </> toFilePath f)+ toUrpLine up (UrpLink f) = printf "link %s" (up </> toFilePath f)+ toUrpLine up (UrpFFI s) = printf "ffi %s" (up </> toFilePath (dropExtensions s))+ toUrpLine up (UrpSafeGet s) = printf "safeGet %s" (dropExtensions s)++instance ToUrpLine UrpModToken where+ toUrpLine up (UrpModule1 f) = up </> toFilePath (dropExtensions f)+ toUrpLine up (UrpModule2 f _) = up </> toFilePath (dropExtensions f)+ toUrpLine up (UrpModuleSys s) = printf "$/%s" s++newtype UrpGen m a = UrpGen { unUrpGen :: StateT UrpState m a }+ deriving(Functor, Applicative, Monad, MonadState UrpState, MonadMake, MonadIO)++instance (Monad m) => MonadAction (UrpGen (A' m)) m where+ liftAction a = UrpGen (lift a)++toFile f wr = liftIO $ writeFile (toFilePath f) $ execWriter $ wr++line :: (MonadWriter String m) => String -> m ()+line s = tell (s++"\n")++uwlib :: File -> UrpGen (A' (Make' IO)) () -> Make UWLib+uwlib urpfile m = do+ (_,u) <- rule2 $ do+ ((),s) <- runStateT (unUrpGen m) (defState urpfile)+ let u@(Urp _ _ hdr mod) = urpst s+ let up = urpUp urpfile++ toFile urpfile $ do+ forM hdr (line . toUrpLine up)+ line ""+ forM mod (line . toUrpLine up)++ forM_ (urpObjs u) $ \o -> do+ let incl = makevar "URINCL" "$(shell urweb -print-cinclude)"+ let cc = makevar "URCC" "$(shell $(shell urweb -print-ccompiler) -print-prog-name=gcc)"+ rule2 $ do+ shell [cmd| $cc -c -I $incl -o @o $(o .= "c") |]++ depend (urpDeps u)+ depend (urpLibs u)+ shell [cmd|touch @urpfile|]+ return u++ return $ UWLib u++uwapp :: String -> File -> UrpGen (A' (Make' IO)) () -> Make UWExe+uwapp opts urpfile m = do+ (UWLib u') <- uwlib urpfile m+ let u = u' { uexe = Just (urpfile .= "exe") }+ rule $ do+ depend urpfile+ produce (urpExe u)+ case urpSql' u of+ Nothing -> return ()+ Just sql -> produce sql+ unsafeShell [cmd|urweb $(string opts) $((takeDirectory urpfile)</>(takeBaseName urpfile))|]+ return $ UWExe u++liftUrp m = m++addHdr h = modify $ \s -> let u = urpst s in s { urpst = u { uhdr = (uhdr u) ++ [h] } }+addMod m = modify $ \s -> let u = urpst s in s { urpst = u { umod = (umod u) ++ [m] } }++database :: (MonadMake m) => String -> UrpGen m ()+database dbs = addHdr $ UrpDatabase dbs+ +allow :: (MonadMake m) => UrpAllow -> String -> UrpGen m ()+allow a s = addHdr $ UrpAllow a s++rewrite :: (MonadMake m) => UrpRewrite -> String -> UrpGen m ()+rewrite a s = addHdr $ UrpRewrite a s++urpUp :: File -> FilePath+urpUp f = F.joinPath $ map (const "..") $ filter (/= ".") $ F.splitDirectories $ F.takeDirectory $ toFilePath f++newtype UrEmbed = Urembed File+ deriving (Show)++data UrpLibReference+ = UrpLibStandalone File + | UrpLibInternal UWLib+ | UrpLibEmbed UrEmbed+ deriving(Show)++library' :: (MonadMake m) => File -> UrpGen m ()+library' l = do+ when ((takeExtension l) /= ".urp") $ do+ fail "library declaration for %s should ends with '.urp'" (toFilePath l)+ addHdr $ UrpLibrary l++library :: (MonadMake m) => UrpLibReference -> UrpGen m ()+library (UrpLibStandalone l) = do+ library' l+ when ((toFilePath $ takeDirectory l) /= ".") $ do+ prebuild [cmd| $(make) -C $(takeDirectory l) |]+library (UrpLibInternal (UWLib u)) = library' (urp u)+library (UrpLibEmbed ue) = error "urembed is not defined"++standalone f = UrpLibStandalone f+internal u = UrpLibInternal u+embed e = UrpLibEmbed e++module_ :: (MonadMake m) => UrpModToken -> UrpGen m ()+module_ = addMod++pair f = UrpModule2 (f.="ur") (f.="urs")+single f = UrpModule1 f+sys s = UrpModuleSys s++debug :: (MonadMake m) => UrpGen m ()+debug = addHdr $ UrpDebug++include :: (MonadMake m) => File -> UrpGen m ()+include f = addHdr $ UrpInclude f++link :: (MonadMake m) => File -> UrpGen m ()+link f = addHdr $ UrpLink f++ffi :: (MonadMake m) => File -> UrpGen m ()+ffi s = addHdr $ UrpFFI s++sql :: (MonadMake m) => File -> UrpGen m ()+sql f = addHdr $ UrpSql f+ +jsFunc n s = addHdr $ UrpJSFunc n s++safeGet s = addHdr $ UrpSafeGet s++url = UrpUrl++mime = UrpMime++style = UrpStyle++guessMime inf = fixup $ BS.unpack (defaultMimeLookup (fromString inf)) where+ fixup "application/javascript" = "text/javascript"+ fixup m = m++data JSFunc = JSFunc {+ urdecl :: String+ , urname :: String+ , jsname :: String+ } deriving(Show)++data JSType = JSType {+ urtdecl :: String+ } deriving(Show)++-- | Parse the JavaScript file, extract top-level functions, convert their+-- signatures into Ur/Web format, return them as the list of strings+parse_js :: BS.ByteString -> Make (Either String ([JSType],[JSFunc]))+parse_js contents = do+ runErrorT $ do+ c <- either fail return (parse (BS.unpack contents) "<urembed_input>")+ f <- concat <$> (forM (findTopLevelFunctions c) $ \f@(fn:_) -> (do+ ts <- mapM extractEmbeddedType (f`zip`(False:repeat True))+ let urdecl_ = urs_line ts+ let urname_ = (fst (head ts))+ let jsname_ = fn+ return [JSFunc urdecl_ urname_ jsname_]+ ) `catchError` (\(e::String) -> do+ err $ printf "ignoring function %s, reason:\n\t%s" fn e+ return []))+ t <- concat <$> (forM (findTopLevelVars c) $ \vn -> (do+ (n,t) <- extractEmbeddedType (vn,False)+ return [JSType $ printf "type %s" t]+ )`catchError` (\(e::String) -> do+ err $ printf "ignoring variable %s, reason:\n\t%s" vn e+ return []))+ return (t,f)++ where+ urs_line :: [(String,String)] -> String+ urs_line [] = error "wrong function signature"+ urs_line ((n,nt):args) = printf "val %s : %s" n (fmtargs args) where+ fmtargs :: [(String,String)] -> String+ fmtargs ((an,at):as) = printf "%s -> %s" at (fmtargs as)+ fmtargs [] = let pf = L.stripPrefix "pure_" nt in+ case pf of+ Just p -> p+ Nothing -> printf "transaction %s" nt++ extractEmbeddedType :: (Monad m) => (String,Bool) -> m (String,String)+ extractEmbeddedType ([],_) = error "BUG: empty identifier"+ extractEmbeddedType (name,fallback) = check (msum [span2 "__" name , span2 "_as_" name]) where+ check (Just (n,t)) = return (n,t)+ check _ | fallback == True = return (name,name)+ | fallback == False = fail $ printf "Can't extract the type from the identifier '%s'" name++ findTopLevelFunctions :: JSNode -> [[String]]+ findTopLevelFunctions top = map decls $ listify is_func top where+ is_func n@(JSFunction a b c d e f) = True+ is_func _ = False+ decls (JSFunction a b c d e f) = (identifiers b) ++ (identifiers d)++ findTopLevelVars :: JSNode -> [String]+ findTopLevelVars top = map decls $ listify is_var top where+ is_var n@(JSVarDecl a []) = True+ is_var _ = False+ decls (JSVarDecl a _) = (head $ identifiers a);+ + identifiers x = map name $ listify ids x where+ ids i@(JSIdentifier s) = True+ ids _ = False+ name (JSIdentifier n) = n++ err,out :: (MonadIO m) => String -> m ()+ err = hio stderr+ out = hio stdout++ span2 :: String -> String -> Maybe (String,String)+ span2 inf s = span' [] s where+ span' _ [] = Nothing+ span' acc (c:cs)+ | L.isPrefixOf inf (c:cs) = Just (acc, drop (length inf) (c:cs))+ | otherwise = span' (acc++[c]) cs++ hio :: (MonadIO m) => Handle -> String -> m ()+ hio h = liftIO . hPutStrLn h++bin :: (MonadIO m, MonadMake m) => File -> File -> UrpGen m ()+bin dir src = do+ c <- readFileForMake src+ bin' dir (toFilePath src) c++bin' :: (MonadIO m, MonadMake m) => File -> FilePath -> BS.ByteString -> UrpGen m ()+bin' dir src_name src_contents = do++ let mime = guessMime src_name+ let mn = (mkname src_name)+ let wrapmod ext = (dir </> mn) .= ext+ let binmod ext = (dir </> (mn ++ "_c")) .= ext+ let jsmod ext = (dir </> (mn ++ "_js")) .= ext++ -- Binary module+ let binfunc = printf "uw_%s_binary" (modname binmod)+ let textfunc = printf "uw_%s_text" (modname binmod)+ toFile (binmod ".c") $ do+ line $ "/* Thanks, http://stupefydeveloper.blogspot.ru/2008/08/cc-embed-binary-data-into-elf.html */"+ line $ "#include <urweb.h>"+ line $ "#include <stdio.h>"+ line $ printf "#define BLOBSZ %d" (BS.length src_contents)+ line $ "static char blob[BLOBSZ];"+ line $ "uw_Basis_blob " ++ binfunc ++ " (uw_context ctx, uw_unit unit)"+ line $ "{"+ line $ " uw_Basis_blob uwblob;"+ line $ " uwblob.data = &blob[0];"+ line $ " uwblob.size = BLOBSZ;"+ line $ " return uwblob;"+ line $ "}"+ line $ ""+ line $ "uw_Basis_string " ++ textfunc ++ " (uw_context ctx, uw_unit unit) {"+ line $ " char* data = &blob[0];"+ line $ " size_t size = sizeof(blob);"+ line $ " char * c = uw_malloc(ctx, size+1);"+ line $ " char * write = c;"+ line $ " int i;"+ line $ " for (i = 0; i < size; i++) {"+ line $ " *write = data[i];"+ line $ " if (*write == '\\0')"+ line $ " *write = '\\n';"+ line $ " *write++;"+ line $ " }"+ line $ " *write=0;"+ line $ " return c;"+ line $ " }"+ line $ ""++ let append f wr = liftIO $ BS.appendFile f $ execWriter $ wr+ append (toFilePath (binmod ".c")) $ do+ let line s = tell ((BS.pack s)`mappend`(BS.pack "\n"))+ line $ ""+ line $ "static char blob[BLOBSZ] = {"+ let buf = reverse $ BS.foldl (\a c -> (BS.pack (printf "0x%02X ," c)) : a) [] src_contents+ tell (BS.concat buf)+ line $ "};"+ line $ ""++ toFile (binmod ".h") $ do+ line $ "#include <urweb.h>"+ line $ "uw_Basis_blob " ++ binfunc ++ " (uw_context ctx, uw_unit unit);"+ line $ "uw_Basis_string " ++ textfunc ++ " (uw_context ctx, uw_unit unit);"++ toFile (binmod ".urs") $ do+ line $ "val binary : unit -> transaction blob"+ line $ "val text : unit -> transaction string"++ include (binmod ".h")+ link (binmod ".o")+ ffi (binmod ".urs")++ -- JavaScript FFI Module+ (jstypes,jsdecls) <- if ((takeExtension src_name) == ".js") then do+ e <- liftMake $ parse_js src_contents+ case e of+ Left e -> do+ fail $ printf "Error while parsing %s" src_name+ Right decls -> do+ return decls+ else+ return ([],[])++ toFile (jsmod ".urs") $ do+ forM_ jstypes $ \decl -> line (urtdecl decl)+ forM_ jsdecls $ \decl -> line (urdecl decl)+ + -- Wrapper module+ toFile (wrapmod ".urs") $ do+ line $ "val binary : unit -> transaction blob"+ line $ "val text : unit -> transaction string"+ line $ "val blobpage : unit -> transaction page"+ line $ "val geturl : url"+ forM_ jstypes $ \decl -> line (urtdecl decl)+ forM_ jsdecls $ \d -> line (urdecl d)++ toFile (wrapmod ".ur") $ do+ line $ "val binary = " ++ modname binmod ++ ".binary"+ line $ "val text = " ++ modname binmod ++ ".text"+ forM_ jsdecls $ \d ->+ line $ printf "val %s = %s.%s" (urname d) (modname jsmod) (urname d)+ line $ printf "fun blobpage {} = b <- binary () ; returnBlob b (blessMime \"%s\")" mime+ line $ "val geturl = url(blobpage {})"++ forM_ jsdecls $ \decl -> do+ jsFunc (printf "%s.%s = %s" (modname jsmod) (urname decl)) (jsname decl)+ ffi (jsmod ".urs")++ safeGet $ printf "%s/blobpage" (modname wrapmod)+ safeGet $ printf "%s/blob" (modname wrapmod)+ module_ (pair $ wrapmod ".ur")++ where++ mkname :: FilePath -> String+ mkname = upper1 . notnum . map under . takeFileName where+ under c | c`elem`"_-. /" = '_'+ | otherwise = c+ upper1 [] = []+ upper1 (x:xs) = (toUpper x) : xs+ notnum n@(x:xs) | isDigit x = "f" ++ n+ | otherwise = n++ modname :: (String -> File) -> String+ modname f = upper1 . takeBaseName $ f ".urs" where+ upper1 [] = []+ upper1 (x:xs) = (toUpper x) : xs+
+ src/Development/Cake3/Ext/UrWeb/UrEmbed.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ImpredicativeTypes #-}+module Main where++import Control.Monad.Error+import Control.Monad.State+import Control.Monad.Writer+import Data.Either+import Data.Generics+import Data.Char+import Data.List+import Data.Data+import Data.Typeable+import Data.Maybe+import Data.String+-- import qualified Data.Text as T+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as BS+import Language.JavaScript.Parser+import Options.Applicative+import System.Environment+import System.Process+import System.Exit+import System.IO+-- import System.FilePath+import System.Directory+import System.Info+import Text.Printf++import Development.Cake3+import Development.Cake3.Ext.UrWeb+++import Paths_cake3++io :: (MonadIO m) => IO a -> m a+io = liftIO++hio :: (MonadIO m) => Handle -> String -> m ()+hio h = io . hPutStrLn h++err,out :: (MonadIO m) => String -> m ()+err = hio stderr+out = hio stdout++data Args = A+ { tgtdir :: FilePath+ , fversion :: Bool+ , dontrunmake :: Bool+ , files :: [FilePath]+ }++pargs :: Parser Args+pargs = A+ <$> strOption+ ( long "output"+ <> short 'o'+ <> metavar "FILE.urp"+ <> help "Name of the Ur/Web project being generated"+ <> value "")+ <*> flag False True ( long "version" <> help "Show version information" )+ <*> flag False True ( long "dont-run-make" <> help "Do not run the makefile generated" )+ <*> arguments str ( metavar "FILE" <> help "File to embed" )++main :: IO ()+main = do+ h <- (getDataFileName >=> readFile) "UrEmbedHelp.txt" + main_ =<< execParser (+ info (helper <*> pargs)+ ( fullDesc+ <> progDesc h+ <> header "UrEmebed is the Ur/Web module generator" ))+++main_ (A tgturp True drm ins) = do+ hPutStrLn stderr $ "urembed version " ++ (show version)++main_ (A tgturp False drm ins) = do+ let tgtdir = takeDirectory tgturp++ when (null tgtdir) $ do+ fail "An output directory should be specified, use -o"++ when (null ins) $ do+ fail "At least one file should be specified, see --help"++ exists <- doesDirectoryExist tgtdir+ when (not exists) $ do+ fail $ "Couldn't create output file, no such directory " ++ show tgtdir++ when (null tgtdir) $ do+ fail "An output directory should be specified, use -o"++ when (null ins) $ do+ fail "At least one file should be specified, see --help"++ exists <- doesDirectoryExist tgtdir+ when (not exists) $ do+ fail "Output is not a directory"++ cntnts <- mapM BS.readFile ins++ setCurrentDirectory tgtdir+ loc <- currentDirLocation+ let file = file' loc+ let bin = bin' (file ".")++ s <- runMake $ do+ let urp = file (takeFileName tgturp)+ u <- uwlib urp $ do+ forM_ (ins`zip`cntnts) $ \(i,c) -> do+ bin i c+ rule $ do+ phony "all"+ depend u+ + let mk = (("." </> takeFileName tgturp) .= "mk")+ writeFile mk s++ when (drm == False) $ do+ system $ printf "make -f %s" mk+ return ()+
src/Development/Cake3/Monad.hs view
@@ -1,186 +1,409 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable #-} module Development.Cake3.Monad where import Control.Applicative import Control.Monad import Control.Monad.State import Control.Monad.Reader+import Control.Monad.Trans import Control.Monad.Loc+import Data.Data+import Data.Typeable import Data.Monoid import Data.Maybe import qualified Data.Map as M import Data.Map(Map) import qualified Data.Set as S import Data.Set(Set)-import Data.List as L+import qualified Data.String as STR+import Data.List as L hiding (foldl') import Data.Either+import Data.Foldable (Foldable(..), foldl')+import qualified Data.ByteString.Char8 as BS import qualified Data.Foldable as F import qualified Data.Traversable as F+import qualified Data.Text as T import Development.Cake3.Types import qualified System.IO as IO import Text.Printf--import System.FilePath.Wrapper--type Recipe = Recipe1+import Text.QuasiMake -type Recipe1 = RecipeT (Map String (Set Variable))+import Language.Haskell.TH.Quote+import Language.Haskell.TH hiding(unsafe)+import Language.Haskell.Meta (parseExp) -type Recipe2 = RecipeT (Map String Variable)+import System.FilePath.Wrapper type Location = String -type Target = Set File-+-- | MakeState describes the state of the EDSL synthesizers during the+-- the program execution. data MakeState = MS {- srecipes :: Map Target (Set Recipe1)+ prebuilds :: Recipe+ -- ^ Prebuild commands. targets/prerequsites of the recipe are ignored,+ -- commands are executed before any target+ , postbuilds :: Recipe+ -- ^ Postbuild commands.+ , recipes :: Set Recipe+ -- ^ The set of recipes , sloc :: Location+ -- ^ Current location. FIXME: fix or remove , makeDeps :: Set File- , placement :: [Target]- } deriving(Show)+ -- ^ Set of files which the Makefile depends on+ , placement :: [File]+ -- ^ Placement list is the order of targets to be placed in the output file+ , includes :: Set File+ -- ^ Set of files to include in the output file (Makefile specific thing)+ , errors :: String+ -- ^ Errors found so far+ , warnings :: String+ -- ^ Warnings found so far+ , outputFile :: File+ } -addPlacement :: RecipeT x -> Make ()-addPlacement r = modify $ \ms -> ms { placement = (placement ms) ++ [rtgt r] }+-- Oh, such a boilerplate+initialMakeState mf = MS defr defr mempty mempty mempty mempty mempty mempty mempty mf where+ defr = emptyRecipe "<internal>" -modifyRecipes f = modify $ \ms -> ms { srecipes = f (srecipes ms) }+getPlacementPos :: Make Int+getPlacementPos = L.length <$> placement <$> get -applyPlacement :: (Eq x) => Map Target (RecipeT x) -> [Target] -> [RecipeT x]-applyPlacement rs p = nub $ (mapMaybe id $ map (flip M.lookup rs) p) ++ (map snd $ M.toList rs)+addPlacement :: Int -> File -> Make ()+addPlacement pos r = modify $ \ms -> ms { placement = r`insertInto`(placement ms) } where+ insertInto x xs = let (h,t) = splitAt pos xs in h ++ (x:t) addMakeDep :: File -> Make () addMakeDep f = modify (\ms -> ms { makeDeps = S.insert f (makeDeps ms) }) -defMS = MS mempty mempty mempty mempty+-- | Add prebuild command+prebuild, postbuild :: (MonadMake m) => CommandGen -> m ()+prebuild cmdg = liftMake $ do+ s <- get+ pb <- fst <$> runA' (prebuilds s) (shell cmdg)+ put s { prebuilds = pb }+postbuild cmdg = liftMake $ do+ s <- get+ pb <- fst <$> runA' (postbuilds s) (shell cmdg)+ put s { postbuilds = pb } --- | The File Alias records the file which may be referenced from other rules,--- it's "Brothers", and the recipes required to build this file.-newtype Alias = Alias (File, [File], Make Recipe)+-- | Find recipes without targets+checkForEmptyTarget :: (Foldable f) => f Recipe -> String+checkForEmptyTarget rs = foldl' checker mempty rs where+ checker es r | S.null (rtgt r) = es++e+ | otherwise = es where+ e = printf "Error: Recipe without targets\n\t%s\n" (show r) --- unalias :: [Alias] -> Make ()--- unalias as = F.sequence_ $ map (\(Alias (_,_,x)) -> x) as+-- | Find recipes sharing a target+checkForTargetConflicts :: (Foldable f) => f Recipe -> String+checkForTargetConflicts rs = foldl' checker mempty (groupRecipes rs) where+ checker es rs | S.size rs > 1 = es++e+ | otherwise = es where+ e = printf "Error: Recipes share one or more targets\n\t%s\n" (show rs) -newtype Make a = Make { unMake :: (StateT MakeState IO) a }- deriving(Monad, Functor, Applicative, MonadState MakeState, MonadIO, MonadFix) -makefileT :: (FileLike x) => (FileT x)-makefileT= fromFilePath "Makefile"+-- | A Monad providing access to MakeState. TODO: not mention IO here.+class (Monad m) => MonadMake m where+ liftMake :: (Make' IO) a -> m a -addRebuildDeps :: Set File -> Map Target Recipe2 -> Map Target Recipe2-addRebuildDeps md rs = M.map mkd rs where- mkd r | makefileT `S.member` (rtgt r) = r{ rsrc = ((rsrc r) `mappend` md) }- | otherwise = r+newtype Make' m a = Make { unMake :: (StateT MakeState m) a }+ deriving(Monad, Functor, Applicative, MonadState MakeState, MonadIO, MonadFix) -addMakeDeps :: Map Target Recipe2 -> Map Target Recipe2-addMakeDeps rs- | M.null makeRules = rs- | otherwise = M.map addMakeDeps' rs- where- makeRules = M.filter (\r -> makefileT `S.member` (rtgt r)) rs- addMakeDeps' r | not (makefileT `dependsOn` r) = r{ rsrc = (S.insert makefileT (rsrc r)) }- | otherwise = r- dependsOn :: File -> Recipe2 -> Bool- dependsOn f r = if f`S.member`(rtgt r) then True else godeeper where- godeeper = or $ map (\tgt -> or $ map (dependsOn f) (selectBySrc tgt)) (S.toList $ rtgt r)+type Make a = Make' IO a - selectBySrc f = map snd . M.toList . fst $ M.partition (\r -> f`S.member`(rsrc r)) rs+instance MonadMake (Make' IO) where+ liftMake = id -flattern :: (Ord x, Ord y, Show y) => Map x (Set y) -> Either String (Map x y)-flattern m = mapM check1 (M.toList m) >>= \m -> return (M.fromList m) where- check1 (k,s) = do- case S.size s of- 1 -> return (k, S.findMin s)- _ -> fail $ printf "More than 1 value describes single entity: %s" (show s)+instance (MonadMake m) => MonadMake (A' m) where+ liftMake m = A' (lift (liftMake m)) -flattern' :: (Ord x, Ord y, Show y) => Map x (Set y) -> Map x y-flattern' m = M.map check1 m where- check1 s = do- case S.size s of- 1 -> S.findMin s- _ -> error $ printf "More than 1 value describes single entity: %s" (show s)+instance (MonadMake m) => MonadMake (StateT s m) where+ liftMake = lift . liftMake -check :: Map Target (Set Recipe1) -> Either String (Map String Variable, Map Target Recipe2)-check rs1 = do- rs1' <- flattern rs1- let vs = F.foldr (\b a -> M.unionWith mappend a (rvars b)) mempty rs1'- vs' <- flattern vs- let rs2 = M.map (\(Recipe a b c d e f) -> let d' = flattern' d in (Recipe a b c d' e f)) rs1'- return (vs',rs2) --- forMapM :: (Monad m, Ord x, Ord a) => Map x a -> (a -> m b) -> m (Map x b)--- forMapM s f = F.foldrM (\a b -> f a >>= \a -> return $ M.insert a b) S.empty s--evalMake :: Make () -> IO (Either String (Map String Variable, Map Target Recipe2, [Target]))-evalMake mk = do- flip evalStateT defMS $ unMake $ mk >> do- md <- makeDeps <$> get- rs <- srecipes <$> get- p <- placement <$> get- return $ case check rs of- Left err -> Left err- Right (v,r) -> Right (v, addMakeDeps $ addRebuildDeps md $ r, p)+-- | Returns a MakeState+evalMake :: (Monad m) => File -> Make' m a -> m MakeState+evalMake mf mk = do+ ms <- flip execStateT (initialMakeState mf) (unMake mk)+ return ms {+ errors = checkForEmptyTarget (recipes ms) ++ checkForTargetConflicts (recipes ms)+ } modifyLoc f = modify $ \ms -> ms { sloc = f (sloc ms) } -addRecipe :: Recipe1 -> Make ()+addRecipe :: Recipe -> Make () addRecipe r = modify $ \ms -> - let rs = srecipes ms ; k = rtgt r- in ms { srecipes = (M.unionWith mappend (M.singleton k (S.singleton r)) rs) }+ let rs = recipes ms ; k = rtgt r+ in ms { recipes = (S.insert r (recipes ms)) } getLoc :: Make String getLoc = sloc <$> get -instance MonadLoc Make where+-- | Add 'include ...' directive to the final Makefile for each input file.+includeMakefile :: (Foldable t) => t File -> Make ()+includeMakefile fs = foldl' scan (return ()) fs where+ scan a f = do+ modify $ \ms -> ms {includes = S.insert f (includes ms)}+ return ()++instance (Monad m) => MonadLoc (Make' m) where withLoc l' (Make um) = Make $ do modifyLoc (\l -> l') >> um -newtype A a = A { unA :: StateT Recipe1 Make a }- deriving(Monad, Functor, Applicative, MonadState Recipe1, MonadIO,MonadFix)+-- | 'A' here stands for Action. It is a State monad carrying a Recipe as its+-- state. Various monadic actions add targets, prerequisites and shell commands+-- to this recipe. After that, @rule@ function records it to the @MakeState@.+-- After the recording, no modification is allowed for this recipe.+newtype A' m a = A' { unA' :: StateT Recipe m a }+ deriving(Monad, Functor, Applicative, MonadState Recipe, MonadIO,MonadFix) -addVariable :: Variable -> A ()-addVariable v = modify $ \r -> r { rvars = M.insertWith mappend (vname v) (S.singleton v) (rvars r) }+-- | Verison of Action monad with fixed parents+type A a = A' (Make' IO) a -targets :: A (Set File)+-- | A class of monads providing access to the underlying A monad+class (Monad m, Monad t) => MonadAction t m | t -> m where+ liftAction :: A' m x -> t x++instance (Monad m) => MonadAction (A' m) m where+ liftAction = id++-- | Run the Action monad, using already existing Recipe as input.+runA' :: (Monad m) => Recipe -> A' m a -> m (Recipe, a)+runA' r act = do+ (a,r) <- runStateT (unA' act) r+ return (r,a)++-- | Create new empty recipe and run action on it.+runA :: (Monad m)+ => String -- ^ Location string (in the Cakefile.hs)+ -> A' m a -- ^ Recipe builder+ -> m (Recipe, a)+runA loc act = runA' (emptyRecipe loc) act++-- | Version of runA discarding the result of A's computation+runA_ :: (Monad m) => String -> A' m a -> m Recipe+runA_ loc act = runA loc act >>= return .fst++-- | Get a list of targets added so far+targets :: (Applicative m, Monad m) => A' m (Set File) targets = rtgt <$> get -prerequisites :: A (Set File)+-- | Get a list of prerequisites added so far+prerequisites :: (Applicative m, Monad m) => A' m (Set File) prerequisites = rsrc <$> get -runA :: Recipe1 -> A a -> Make Recipe1-runA r a = do- r' <- snd <$> runStateT (unA a) r- addRecipe r'- return r'+-- | Mark the recipe as 'PHONY' i.e. claim that all it's targets are not real+-- files. Makefile-specific.+markPhony :: (Monad m) => A' m ()+markPhony = modify $ \r -> r { rflags = S.insert Phony (rflags r) } -readFile :: File -> A String-readFile f = do- A (lift $ addMakeDep f)- liftIO (IO.readFile (unpack f))+-- | Mark the recipe as 'INTERMEDIATE' i.e. claim that all it's targets may be+-- removed after the build process. Makefile-specific.+markIntermediate :: (Monad m) => A' m ()+markIntermediate = modify $ \r -> r { rflags = S.insert Intermediate (rflags r) } -class Placable a where- place :: a -> Make ()+-- | Obtain the contents of a File. Note, that this generally means, that+-- Makefile should be regenerated each time the File is changed.+readFileForMake :: (MonadMake m)+ => File -- ^ File to read contents of+ -> m BS.ByteString+readFileForMake f = liftMake (addMakeDep f >> liftIO (BS.readFile (toFilePath f))) --- instance Placable (Make ()) where--- place = id+-- | CommandGen is a recipe-builder packed in the newtype to prevent partial+-- expantion of it's commands+newtype CommandGen' m = CommandGen' { unCommand :: A' m Command }+type CommandGen = CommandGen' (Make' IO) -instance Placable Alias where- place (Alias (_,_,x)) = do- x >>= addPlacement+-- | Pack the command builder into a CommandGen+commandGen :: A Command -> CommandGen+commandGen mcmd = CommandGen' mcmd -instance Placable (Alias,Alias) where- place (a,b) = place a >> place b+-- | Modifie the recipe builder: ignore all the dependencies+ignoreDepends :: (Monad m) => A' m a -> A' m a+ignoreDepends action = do+ r <- get+ a <- action+ modify $ \r' -> r' { rsrc = rsrc r, rvars = rvars r }+ return a -instance Placable (Alias,Alias,Alias) where- place (a,b,c) = place a >> place b >> place c+-- | Apply the recipe builder to the current recipe state. Return the list of+-- targets of the current @Recipe@ under construction+shell :: (Monad m)+ => CommandGen' m -- ^ Command builder as returned by cmd quasi-quoter+ -> A' m [File]+shell cmdg = do+ line <- unCommand cmdg+ commands [line]+ r <- get+ return (S.toList (rtgt r)) -instance Placable (Alias,Alias,Alias,Alias) where- place (a,b,c,d) = place a >> place b >> place c >> place d+-- | Version of @shell@ which doesn't track it's dependencies+unsafeShell :: (Monad m) => CommandGen' m -> A' m [File]+unsafeShell cmdg = ignoreDepends (shell cmdg) -instance Placable x => Placable (Make x) where- place mk = mk >>= place+-- | Simple wrapper for strings, a target for various typeclass instances.+newtype CakeString = CakeString String+ deriving(Show,Eq,Ord) -instance Placable x => Placable [x] where- place xs = sequence_ (map place xs)+-- | An alias to CakeString constructor+string :: String -> CakeString+string = CakeString++-- | Class of things which may be referenced using '\@(expr)' syntax of the+-- quasi-quoted shell expressions.+class (Monad m) => RefOutput m x where+ -- | Register the output item, return it's shell-command representation. Files+ -- are rendered using space protection quotation, variables are wrapped into+ -- $(VAR) syntax, item lists are converted into space-separated lists.+ refOutput :: x -> A' m Command++instance (Monad m) => RefOutput m File where+ refOutput f = do+ modify $ \r -> r { rtgt = f `S.insert` (rtgt r)}+ return_file f++-- FIXME: inbetween will not notice if spaces are already exists+inbetween x mx = (concat`liftM`mx) >>= \l -> return (inbetween' x l) where+ inbetween' x [] = []+ inbetween' x [a] = [a]+ inbetween' x (a:as) = a:x:(inbetween' x as)++spacify l = (CmdStr " ") `inbetween` l++instance (Monad m) => RefOutput m [File] where+ refOutput xs = spacify $ mapM refOutput (xs)++instance (Monad m) => RefOutput m (Set File) where+ refOutput xs = refOutput (S.toList xs)++instance (RefOutput m x) => RefOutput m (Maybe x) where+ refOutput mx = case mx of+ Nothing -> return mempty+ Just x -> refOutput x++-- | Class of things which may be referenced using '\$(expr)' from inside+-- of quasy-quoted shell expressions+class (MonadAction a m) => RefInput a m x where+ -- | Register the input item, return it's shell-script representation+ refInput :: x -> a Command++instance (MonadAction a m) => RefInput a m File where+ refInput f = liftAction $ do+ modify $ \r -> r { rsrc = f `S.insert` (rsrc r)}+ return_file f++instance (MonadAction a m) => RefInput a m Recipe where+ refInput r = refInput (rtgt r)++instance (RefInput a m x) => RefInput a m [x] where+ refInput xs = spacify $ mapM refInput xs++instance (MonadAction a m) => RefInput a m (Set File) where+ refInput xs = refInput (S.toList xs)++instance (MonadIO a, RefInput a m x) => RefInput a m (IO x) where+ refInput mx = liftIO mx >>= refInput++instance (MonadAction a m, MonadMake a) => RefInput a m (Make Recipe) where+ refInput mr = liftMake mr >>= refInput++instance (RefInput a m x, MonadMake a) => RefInput a m (Make x) where+ refInput mx = liftMake mx >>= refInput++instance (RefInput a m x) => RefInput a m (Maybe x) where+ refInput mx = case mx of+ Nothing -> return mempty+ Just x -> refInput x++instance (MonadAction a m) => RefInput a m Variable where+ refInput v@(Variable n _) = liftAction $ do+ variables [v]+ return_text $ printf "$(%s)" n++instance (MonadAction a m) => RefInput a m CakeString where+ refInput v@(CakeString s) = do+ return_text s++-- | Add it's argument to the list of dependencies (prerequsites) of a current+-- recipe under construction+depend :: (RefInput a m x)+ => x -- ^ File or [File] or (Set File) or other form of dependency.+ -> a ()+depend x = refInput x >> return ()++-- | Declare that current recipe produces some producable item.+produce :: (RefOutput m x)+ => x -- ^ File or [File] or other form of target.+ -> A' m ()+produce x = refOutput x >> return ()++-- | Add variables to the list of variables referenced by the current recipe+variables :: (Foldable t, Monad m)+ => (t Variable) -- ^ A set of variables to depend the recipe on+ -> A' m ()+variables vs = modify (\r -> r { rvars = foldl' (\a v -> S.insert v a) (rvars r) vs } )++-- | Add commands to the list of commands of a current recipe under+-- construction. Warning: this function behaves like unsafeShell i.e. it doesn't+-- analyze the command text+commands :: (Monad m) => [Command] -> A' m ()+commands cmds = modify (\r -> r { rcmd = (rcmd r) ++ cmds } )++-- | Set the recipe's location in the Cakefile.hs+location :: (Monad m) => String -> A' m ()+location l = modify (\r -> r { rloc = l } )++-- | Set additional flags+flags :: (Monad m) => Set Flag -> A' m ()+flags f = modify (\r -> r { rflags = (rflags r) `mappend` f } )++-- | Has effect of a function @QQ -> CommandGen@ where QQ is a string supporting+-- the following syntax:+--+-- * $(expr) evaluates to expr and adds it to the list of dependencies (prerequsites)+--+-- * \@(expr) evaluates to expr and adds it to the list of targets+--+-- * $$ and \@\@ evaluates to $ and \@+--+-- /Example/+--+-- > [cmd|gcc $flags -o @file|]+--+-- is equivalent to+--+-- > return $ CommandGen $ do+-- > s1 <- refInput "gcc "+-- > s2 <- refInput (flags :: Variable)+-- > s3 <- refInput " -o "+-- > s4 <- refOutput (file :: File)+-- > return (s1 ++ s2 ++ s3 ++ s4)+--+-- Later, this command may be examined or passed to the shell function to apply+-- it to the recipe+--+cmd :: QuasiQuoter+cmd = QuasiQuoter+ { quotePat = undefined+ , quoteType = undefined+ , quoteDec = undefined+ , quoteExp = \s -> appE [| \x -> CommandGen' x |] (qqact s)+ } where+ qqact s = + let chunks = flip map (getChunks (STR.fromString s)) $ \c ->+ case c of+ T t -> let t' = T.unpack t in [| return_text t' |]+ E c t -> case parseExp (T.unpack t) of+ Left e -> error e+ Right e -> case c of+ '$' -> appE [| refInput |] (return e)+ '@' -> appE [| refOutput |] (return e)+ in appE [| \l -> L.concat <$> (sequence l) |] (listE chunks)
− src/Development/Cake3/Rules/UrWeb.hs
@@ -1,146 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE FlexibleContexts #-}-module Development.Cake3.Rules.UrWeb(- urweb- , Config(..)- , defaultConfig- , urdeps- ) where--import Data.Monoid-import Data.List-import Data.Set (member)-import Control.Applicative-import Control.Monad.Trans-import Control.Monad.State-import System.Directory-import System.IO as IO--import System.FilePath.Wrapper-import Development.Cake3-import Development.Cake3.Types-import Development.Cake3.Monad as C3--splitWhen c l = (h,if null t then [] else tail t) where- (h,t) = span (/=c) l---- | URP file parser. Takes file name and 2 callbacks: one for header lines and--- one for source lines-urpparse :: (Monad m) => String -> ((String,String) -> m ()) -> (FilePath -> m ()) -> m ()-urpparse inp hact sact = do- parseline False (lines inp) where- parseline _ [] = return ()- parseline False (l:ls)- | (unwords (words l)) == [] = parseline True ls- | otherwise = hact (splitWhen ' ' l) >> parseline False ls- parseline True (l:ls) = sact l >> parseline True ls--data Config = Config {- urObjRule :: File -> Rule- , urInclude :: Variable- , urEmbed :: [(String, [File])]- }--defaultConfig = Config {- urObjRule = \f -> rule f (fail "urobj: not set")- , urInclude = makevar "UR_INCLUDE_DIR" "/usr/local/include/urweb"- , urEmbed = []- }---- | Helper function, parses dependencies of an *urp-urdeps :: Config -> File -> A ()-urdeps cfg f = do- ps <- prerequisites- let check = msum [ lookup (unpack (takeBaseName f)) (urEmbed cfg)- , lookup (unpack (takeFileName f)) (urEmbed cfg)- ]- case check of- Just embeddable -> do- depend (urembed cfg f embeddable)- Nothing -> do- depend f- inp <- C3.readFile f- urpparse inp lib src- where- relative x = takeDirectory f </> (fromFilePath x)-- lib (h,x)- | (h=="library") = do- let nested = relative x- isdir <- liftIO $ doesDirectoryExist (unpack nested)- case isdir of- True -> urdeps cfg (nested </> (fromFilePath "lib.urp"))- False -> urdeps cfg (nested .= "urp")- | (h=="ffi") = do- depend ((relative x) .= "urs")- | (h=="include") = do- depend (relative x)- | (h=="link") = do- depend (urObjRule cfg (relative x))- | otherwise = return ()-- src d@(c:_)- | (c/='$') = do- depend ((relative d) .= "ur" :: File)- let urs = (relative d) .= "urs"- e <- liftIO $ doesFileExist (toFilePath urs)- when e $ do- depend ((relative d) .= "urs" :: File)- | otherwise = return ()- src _ = return ()---- | Search for @sect@ in the urp file's header.-urpline :: String -> File -> String -> IO File-urpline sect f c = flip execStateT mempty $ urpparse c lib (const $ return ()) where- relative x = takeDirectory f </> (fromFilePath x)- lib (n,x) | n == sect = put (relative x)- | otherwise = return ()---- | Search for section @sect@ in the urp file's database line--- FIXME: actually supports only 'databse dbname=XXX' format-urpdb :: String -> File -> String -> IO File-urpdb dbsect f c = flip execStateT mempty $ urpparse c lib (const $ return ()) where- relative x = takeDirectory f </> (fromFilePath x)- lib (n,x) | n == "database" = put (relative $ snd (splitWhen '=' x))- | otherwise = return ()---- | Get executable name of an URP project-urpexe :: File -> File-urpexe f = f .= "exe"---- | Take the URP file and the build action. Provide three aliases: one for--- executable, one for SQL-file and one for database file------ FIXME: Rewrite in urembed style: fill urweb_cmd and pass it back to the user-urweb :: Config -> File -> A() -> IO (Alias, Alias, Alias)-urweb cfg f act = do- c <- liftIO (IO.readFile $ unpack f)- exe <- return (urpexe f)- sql <- urpline "sql" f c- db <- urpdb "name" f c- ruleM (exe,sql,db) (act >> urdeps cfg f)---- | Generate Ur/Web project file @urp@ providing embedded files @files@--- FIXME: Generate unique variable name instead of URGCC--- FIXME: implement variable dependency-urembed :: Config -> File -> [File] -> Alias-urembed cfg urp files =- let- dir = takeDirectory urp- makefile = (dir </> takeBaseName urp) .= "mk"- dir_ = string dir- urp_ = string urp- mf_ = string (takeFileName makefile)- in rule urp $ do- let urcc = makevar "URCC" "$(shell urweb -print-ccompiler)"- let gcc = makevar "CC" "$(shell $(URCC) -print-prog-name=gcc)"- let ld = makevar "LD" "$(shell $(URCC) -print-prog-name=ld)"- let mf = rule makefile $ do- -- FIXME: strange recursion occures if uncomment- -- depend urp- shell [cmd|mkdir -pv $(dir_)|]- shell [cmd|urembed -o $(urp_) $files|]- depend urcc- depend mf- shell [cmd|$(extvar "MAKE") -C $(dir_) -f $(mf_) CC=$gcc LD=$ld UR_INCLUDE_DIR=$(urInclude cfg) urp|]-
src/Development/Cake3/Types.hs view
@@ -1,8 +1,14 @@+{-# LANGUAGE DeriveDataTypeable #-} module Development.Cake3.Types where +import Control.Applicative+import Data.Maybe import Data.Monoid+import Data.Data+import Data.Typeable+import Data.Foldable (Foldable(..), foldl') import qualified Data.List as L-import Data.List hiding(foldr)+import Data.List hiding(foldr, foldl') import qualified Data.Map as M import Data.Map (Map) import qualified Data.Set as S@@ -10,56 +16,117 @@ import System.FilePath.Wrapper --- | Item wich have it's position in the Makefile. Positioned adds the metric to--- the contained datatype. Note, that the metric is not the subject of Eq or--- Ord. mappend-ing two metrics results in taking the minimal one.--- data Pos a = Pos { ppos :: Int, pwhat :: a }--- deriving(Show, Eq)---- instance Ord a => Ord (Pos a) where--- compare (Pos p w) (Pos p2 w2) =--- case p`compare`p2 of--- EQ -> w`compare`w2--- x -> x---- instance Monoid a => Monoid (Pos a) where--- mempty = Pos 0 mempty--- mappend (Pos a ad) (Pos b bd) = Pos (min a b) (mappend ad bd)---- -- higher positions go first--- cmpPos (Pos a _) (Pos b _) = a`compare`b--- unposition (Pos _ x) = x----- | Makefile variable+-- | The representation of Makefile variable data Variable = Variable { vname :: String+ -- ^ The name of a variable , vval :: Maybe String -- ^ Nothing means that variable is defined elsewhere (eg. borrowed from the -- environment)- } deriving(Show, Eq, Ord)+ } deriving(Show, Eq, Ord, Data, Typeable) -type Vars = Map String (Set Variable)+-- type Vars = Map String (Set Variable) -- | Command represents OS command line and consists of a list of fragments. -- Each fragment is either text (may contain spaces) or FilePath (spaces should -- be escaped)-type Command = [Either String File]+type Command = [CommandPiece] -return_text x = return [Left x]-return_file x = return [Right x]+data CommandPiece = CmdStr String | CmdFile File+ deriving (Show, Eq, Ord, Data, Typeable) --- | Recipe answers to the question 'How to build the targets'-data RecipeT v = Recipe {+return_text x = return [CmdStr x]+return_file f = return [CmdFile f]++data Flag = Phony | Intermediate+ deriving(Show,Eq,Ord, Data, Typeable)++-- | Recipe answers to the question 'How to build the targets'. Internally, it+-- contains sets of targets and prerequisites, as well as shell commands+-- required to build former from latter+data Recipe = Recipe { rtgt :: Set File -- ^ Targets , rsrc :: Set File -- ^ Prerequisites , rcmd :: [Command] -- ^ A list of shell commands- , rvars :: v+ , rvars :: Set Variable -- ^ Container of variables , rloc :: String- -- FIXME: actually, PHONY is a file's attribute, not recipe's- , rphony :: Bool- } deriving(Show, Eq, Ord)+ , rflags :: Set Flag+ } deriving(Show, Eq, Ord, Data, Typeable)++emptyRecipe :: String -> Recipe+emptyRecipe loc = Recipe mempty mempty mempty mempty loc mempty++addPrerequisites :: Set File -> Recipe -> Recipe+addPrerequisites p r = r { rsrc = p`mappend`(rsrc r)}++addPrerequisite :: File -> Recipe -> Recipe+addPrerequisite f = addPrerequisites (S.singleton f)++type Target = Set File++groupSet :: (Ord k, Ord x, Foldable t) => (x -> Set k) -> t x -> Map k (Set x)+groupSet keys s = foldl' f' mempty s where+ f' m x = foldl' ins m (keys x) where+ ins m k = M.insertWith mappend k (S.singleton x) m++groupRecipes :: (Foldable t) => t Recipe -> Map File (Set Recipe)+groupRecipes = groupSet rtgt++flattern :: [Set x] -> [x]+flattern = concat . map S.toList++applyPlacement' :: (Eq x) => [File] -> Map File x -> [x]+applyPlacement' pl m = + let placed = nub $ catMaybes $ L.map (\k -> M.lookup k m) pl+ all = L.map snd $ M.toList m+ in placed ++ (all \\ placed)++applyPlacement :: (Foldable t) => [File] -> t Recipe -> [Recipe]+applyPlacement pl rs = flattern $ applyPlacement' pl (groupRecipes rs)++-- applyPlacement2 :: (Foldable t) => [File] -> t File -> [File]+-- applyPlacement2 pl fs = flattern $ applyPlacement' pl (groupSet S.singleton fs)+ ++transformRecipes :: (Applicative m) => (Recipe -> m (Set Recipe)) -> Set Recipe -> m (Set Recipe)+transformRecipes f m = S.foldl' f' (pure mempty) m where+ f' a r = mappend <$> (f r) <*> a++transformRecipesM_ :: (Monad m, Foldable t) => (Recipe -> m ()) -> t Recipe -> m ()+transformRecipesM_ f rs = foldl' (\a r -> a >> f r) (return mempty) rs++queryVariables :: (Foldable t) => t Recipe -> Set Variable+queryVariables rs = foldl' (\a r -> a`mappend`(rvars r)) mempty rs++queryVariablesE :: (Foldable t) => t Recipe -> Either String (Set Variable)+queryVariablesE rs = check where+ vs = queryVariables rs+ bads = M.filter (\s -> (S.size s) /= 1) (groupSet (\v -> S.singleton (vname v)) vs)+ check | (M.size bads) > 0 = Left "Some variables share same name"+ | otherwise = Right vs++queryTargets :: (Foldable t) => t Recipe -> Set File+queryTargets rs = foldl' (\a r -> a`mappend`(rtgt r)) mempty rs++var :: String -> Maybe String -> Variable+var n v = Variable n v++-- | Declare the variable which is defined in the current Makefile and has it's+-- default value+makevar+ :: String -- ^ Variable name+ -> String -- ^ Default value+ -> Variable+makevar n v = var n (Just v)++-- | Declare the variable which is not defined in the target Makefile+extvar :: String -> Variable+extvar n = var n Nothing++-- | Special variable @$(MAKE)@+make = extvar "MAKE"+
src/Development/Cake3/Utils/Find.hs view
@@ -22,7 +22,7 @@ -- FIXME: Figure out how to add ./relative notation (./file instead of file) -- Makefile : contents_of(directory) getDirectoryContentsRecursive :: (MonadIO m) => File -> m [File]-getDirectoryContentsRecursive (FileT topdir) = map (fromFilePath . (topdir</>)) `liftM` (liftIO $ recurseDirectories [""])+getDirectoryContentsRecursive td@(FileT topdir) = map (td</>) `liftM` (liftIO $ recurseDirectories [""]) where recurseDirectories :: [FilePath] -> IO [FilePath] recurseDirectories [] = return []@@ -45,3 +45,4 @@ ignore ['.'] = True ignore ['.', '.'] = True ignore _ = False+
src/Development/Cake3/Writer.hs view
@@ -1,12 +1,20 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-module Development.Cake3.Writer (toMake) where+module Development.Cake3.Writer (defaultMakefile,buildMake) where -import Control.Monad (when) import Control.Applicative-import Control.Monad.State (State(..), execState, runState, modify, get, put)+import Control.Monad (when)+import Control.Monad.Identity (runIdentity)+import Control.Monad.State (MonadState, StateT(..), runStateT, State(..), execState, evalState, runState, modify, get, put)+import Control.Monad.Trans import Data.List as L import Data.Char+import Data.Maybe (catMaybes)+import Data.Monoid import Data.String+import Data.Foldable (Foldable(..), foldl') import Data.Foldable (forM_) import Data.Traversable (forM) import Data.Set (Set)@@ -19,65 +27,257 @@ import Development.Cake3.Types import Development.Cake3.Monad -gen :: MakeWriter Int-gen = do- x <- head <$> cnt <$> get- modify (\ws -> ws { cnt = tail (cnt ws) })- return x---- | Writer state-data WS = WS { cnt :: [Int] , ls :: String }- deriving(Show)--type MakeWriter a = State WS a- class ToMakeText x where toMakeText :: x -> String instance ToMakeText [Char] where toMakeText = id -instance ToMakeText [[Char]] where- toMakeText = concat . map toMakeText---- instance ToMakeText (Set File) where--- toMakeText = concat . map toMakeText . S.toList+escapeFile f = escapeFile' (toFilePath f)+escapeFile' [] = []+escapeFile' (' ':xs) = "\\ " ++ escapeFile' xs+escapeFile' (x:xs) = (x:(escapeFile' xs)) instance ToMakeText File where- toMakeText (FileT f) = escape f where- escape [] = []- escape (' ':xs) = "\\ " ++ escape xs- escape (x:xs) = (x:(escape xs))--trimE = dropWhileEnd isSpace-trimB = dropWhile isSpace--cs a b = a ++ (' ':b)+ toMakeText = escapeFile instance ToMakeText Command where- toMakeText [x] = either toMakeText toMakeText x- toMakeText ((Left str):(Right f):cmd) = toMakeText ((Left ((trimE str)`cs` (toMakeText f))):cmd)- toMakeText ((Right f):(Left str):cmd) = toMakeText ((Left ((toMakeText f)`cs`(trimB str))):cmd)- toMakeText ((Right a):(Right b):cmd) = toMakeText ((Left ((toMakeText a)`cs`(toMakeText b))):cmd)- toMakeText ((Left s1):(Left s2):cmd) = toMakeText ((Left (s1++s2)):cmd)+ toMakeText cmd = concat $ map toMakeText cmd -line :: String -> MakeWriter ()-line s = modify $ \ws -> ws { ls = concat [ls ws, s, "\n"] }+instance ToMakeText CommandPiece where+ toMakeText (CmdStr s) = s+ toMakeText (CmdFile f) = toMakeText f -mmap f = map (f . snd) . M.toList+instance ToMakeText (Set File) where+ toMakeText s = intercalate " " (map toMakeText (S.toList s))+ smap f = map f . S.toList -toMake :: (Map String Variable, Map Target Recipe2, [Target]) -> String-toMake (vs_, rs_, p) = - let (vs,rs) = (map snd $ M.toList vs_, applyPlacement rs_ p)- in ls $ flip execState (WS [1..] "") $ do- line "# This Makefile was generated by the ThirdCake"- line "# https://github.com/grwlf/cake3"- line ""+line :: (MonadState String m) => String -> m ()+line s = modify $ \ws -> concat [ws, s, "\n"] - when (not (null vs)) $ do+text :: (MonadState String m) => String -> m ()+text s = modify $ \ws -> concat [ws, s]++newtype MakeLL a = MakeLL { unMakeLL :: State ([File], Set Recipe) a }+ deriving(Functor, Monad, MonadState ([File], Set Recipe), Applicative)++fresh :: MakeLL File+fresh = do+ (f:fs,rs) <- get+ put (fs,rs)+ return f++runMakeLL :: String -> MakeLL () -> Set Recipe+runMakeLL templ m = snd $ execState (unMakeLL m) (names, S.empty) where+ names = map fromFilePath $ map (\x -> printf ".%s%d" templ x) $ ([1..] :: [Int])++produceLL :: Recipe -> MakeLL ()+produceLL r = modify (\(a,b) -> (a,S.insert r b))++ruleLL :: A' MakeLL a -> MakeLL Recipe+ruleLL act = do+ (r,_) <- runA "<internal>" act+ produceLL r+ return r++applySubprojects :: Map File [Command] -> Set Recipe -> Set Recipe+applySubprojects sp rs = runMakeLL "subproject" (transformRecipesM_ f rs) where+ f r | L.null scmds = produceLL r+ | otherwise = do+ n1 <- fresh+ n2 <- fresh+ r1 <- ruleLL $ do+ produce n2+ commands scmds+ markPhony+ r2 <- ruleLL $ do+ produce n1+ depend (rsrc r)+ commands (rcmd r)+ ruleLL $ do+ produce (rtgt r)+ depend r1+ depend r2+ return ()+ where+ scmds :: [Command]+ scmds = concat $ catMaybes $ map (flip M.lookup sp) (S.toList $ rsrc r)+++-- | Turns multi-target rules of the form+--+-- a b c : d e f+-- cmd1+--+-- into the pair:+--+-- a : stampX+-- b : stampX+-- c : stampX+--+-- .INTERMEDIATE:stampX+-- stampX : d e f+-- cmd1+--+fixMultiTarget :: (Foldable t) => t Recipe -> Set Recipe+fixMultiTarget rs = runMakeLL "fix-multy" (transformRecipesM_ f rs) where+ f r | (S.size (rtgt r)) > 1 = do+ s <- fresh+ forM_ (S.toList $ rtgt r) $ \t -> do+ ruleLL $ do+ produce t+ location (rloc r)+ depend s+ flags (rflags r)+ ruleLL $ do+ produce s+ depend (rsrc r)+ variables (rvars r)+ commands (rcmd r)+ location (rloc r)+ markIntermediate+ return ()+ | otherwise = do+ produceLL r++-- | Operate on a prerequisites which themselfs are targets of a multitarget rule. Make+-- the conversion from:+--+-- a b c : x+-- x : a+-- y : b+--+-- to+--+-- a b c : x+-- x : a b c+-- y : a b c+--+--+completeMultiTarget :: Set Recipe -> Set Recipe+completeMultiTarget rs = + let+ badlist = S.foldl' (\ts r -> do+ if (S.size (rtgt r)) > 1 then (rtgt r):ts else ts) [] rs+ in+ flip S.map rs $ \r ->+ L.foldl' (\r mulpack ->+ case (not . S.null) ((rsrc r)`S.intersection` mulpack) of+ True -> r { rsrc = (rsrc r) `S.union` mulpack }+ False -> r) r badlist++-- | Rule referring to the +defaultMakefile :: File+defaultMakefile = fromFilePath ("." </> "Makefile")++addRebuildDeps :: File -> Set File -> Set Recipe -> Set Recipe+addRebuildDeps makefile deps rs = S.map mkd rs where+ mkd r | makefile `S.member` (rtgt r) = addPrerequisites deps r+ | otherwise = r++isRequiredFor :: Set Recipe -> Recipe -> File -> Bool+isRequiredFor rs r f = if f`S.member`(rtgt r) then True else godeeper where+ godeeper = or $ map (\tgt -> or $ map (\r -> isRequiredFor rs r f) (selectBySrc tgt)) (S.toList $ rtgt r)+ selectBySrc f = S.toList . fst $ S.partition (\r -> f`S.member`(rsrc r)) rs++-- | There are only 2 kind of rules: 1) ones that depend on a Makefile, and 2) ones+-- that Makefile depends on. Case-2 is known in advance (for example, when the+-- the contents of a file is required to build a Makefile then Makefile depends+-- on this file). This function adds the case-1 dependencies.+addMakeDeps :: File -> Set Recipe -> Set Recipe+addMakeDeps makefile rs+ | S.null (S.filter (\r -> makefile `S.member` (rtgt r)) rs) = rs+ | otherwise = S.map addMakeDeps_ rs+ where+ addMakeDeps_ r | not (isRequiredFor rs r makefile) = addPrerequisite makefile r+ | otherwise = r++++-- | Render the Makefile. Return either the content (Right), or error messages+-- (Left).+buildMake :: MakeState -> Either String String+buildMake ms = do++ mr <- region "MAIN" $ do+ line ""+ line "# Main section"+ line ""+ writeRules rs'+ forM_ (includes ms) $ \i -> do+ line (printf "include %s" (toMakeText i))+ line ""++ sr <- region "SERVICE" $ do+ line ""+ line "# Prebuild/postbuild section"+ line ""+ r <- runA_ "<internal>" $ do+ produce (queryTargets (recipes ms))+ commands (rcmd $ prebuilds ms)+ commands [[CmdStr "$(MAKE) MAIN=1 $(MAKECMDGOALS)"]]+ commands (rcmd $ postbuilds ms)+ variables (rvars $ prebuilds ms)+ variables (rvars $ postbuilds ms)+ markPhony+ writeRules $ applyPlacement (placement ms) $ fixMultiTarget [r]+ line ""++ hdr <- runLines $ do+ line "# This Makefile was generated by the Cake3"+ line "# https://github.com/grwlf/cake3"+ line "" line "GUARD = .GUARD_$(1)_$(shell echo $($(1)) | md5sum | cut -d ' ' -f 1)"+ line ""+ + writeRegions hdr [mr,sr] + where+ make = extvar "MAKE"+ makecmdgoals = extvar "MAKECMDGOALS"++ rs' = applyPlacement (placement ms)+ $ fixMultiTarget+ $ completeMultiTarget+ $ addMakeDeps (outputFile ms)+ $ addRebuildDeps (outputFile ms) (makeDeps ms)+ $ recipes ms++data MakeRegion = MR {+ mrname :: String+ , mrtext :: String+}++type Lines = StateT String (Either String) ()++runLines :: Lines -> Either String String+runLines s = let e = runStateT s "" in+ case e of+ Left e -> Left e+ Right ((),st) -> Right st++writeRegions :: String -> [MakeRegion] -> Either String String+writeRegions hdr rs = mappend <$> (pure hdr) <*> (writeRegions' rs) where+ writeRegions' [] = fail "No regions are defined"+ writeRegions' (r:rs)+ | L.null rs = return (mrtext r)+ | otherwise = do+ inner <- writeRegions' rs+ runLines $ do+ line (printf "ifdef %s" (map toUpper $ mrname r))+ text (mrtext r)+ line "else"+ text inner+ line "endif"++region name mlines = do+ lines <- runLines mlines+ return $ MR { mrname = name , mrtext = lines}++writeRules rs = do+ vs <- lift $ queryVariablesE rs+ -- Variables forM_ vs $ \v -> case v of (Variable n (Just v)) -> line (printf "%s = %s" n v)@@ -86,30 +286,19 @@ -- Rules forM_ rs $ \r -> do let varguard v = printf "$(call GUARD,%s)" (vname v)- let deps = intercalate " " $ (smap toMakeText (rsrc r)) ++ (mmap varguard (rvars r))+ let deps = intercalate " " $ (smap toMakeText (rsrc r)) ++ (smap varguard (rvars r)) let tgts = intercalate " " $ (smap toMakeText (rtgt r)) - when (rphony r) $ do+ when (Phony `S.member` (rflags r)) $ do line (printf ".PHONY: %s" tgts)+ when (Intermediate `S.member` (rflags r)) $ do+ line (printf ".INTERMEDIATE: %s" tgts) - case (S.size (rtgt r)) of- 0 -> do- return ()- 1 -> do- let s = (S.findMin (rtgt r))- line $ printf "%s: %s" (toMakeText s) deps- forM_ (rcmd r) $ \c -> do- line (printf "\t%s" (toMakeText c))- _ -> do- i <- gen- let s = (printf "stamp%d" i :: String)- line (printf "%s: %s" tgts s)- line (printf ".INTERMEDIATE: %s" s)- line (printf "%s: %s" s deps)- forM_ (rcmd r) $ \c -> do- line (printf "\t%s" (toMakeText c))+ line (printf "%s: %s" tgts deps)+ forM_ (rcmd r) $ \c -> do+ line (printf "\t%s" (toMakeText c)) - -- Rules for variable's guards+ -- Rules for variable guards -- FIXME: add those on the higher level forM_ vs $ \v -> do line (printf "$(call GUARD,%s):" (vname v))
src/System/FilePath/Wrapper.hs view
@@ -1,8 +1,11 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable #-} module System.FilePath.Wrapper where +import Data.Data+import Data.Typeable import Control.Applicative import Control.Monad.State import Control.Monad.Trans@@ -12,37 +15,47 @@ import Text.Printf newtype FileT a = FileT a- deriving(Show,Eq,Ord)+ deriving(Show,Eq,Ord,Data,Typeable) +-- | Simple wrapper for FilePath.+type File = FileT FilePath++-- | Convert File back to FilePath+toFilePath :: (FileT FilePath) -> FilePath+toFilePath (FileT f) = f++fromFilePath :: FilePath -> FileT FilePath+fromFilePath f = FileT f+ instance (Monoid a) => Monoid (FileT a) where mempty = FileT mempty mappend (FileT a) (FileT b) = FileT (a`mappend`b) -type File = FileT FilePath- class FileLike a where- fromFilePath :: FilePath -> a- combine :: a -> a -> a- takeBaseName :: a -> a- takeFileName :: a -> a+ -- fromFilePath :: FilePath -> a+ combine :: a -> String -> a+ takeDirectory :: a -> a+ takeBaseName :: a -> String+ takeFileName :: a -> String makeRelative :: a -> a -> a replaceExtension :: a -> String -> a takeExtension :: a -> String takeExtensions :: a -> String- takeDirectory :: a -> a dropExtensions :: a -> a -(</>) :: (FileLike a) => a -> a -> a+-- | Redefine standard @</>@ operator to work with Files+(</>) :: (FileLike a) => a -> String -> a (</>) = combine +-- | Alias for replaceExtension (.=) :: (FileLike a) => a -> String -> a (.=) = replaceExtension instance FileLike a => FileLike (FileT a) where- fromFilePath fp = FileT (fromFilePath fp)- combine (FileT a) (FileT b) = FileT (combine a b)- takeBaseName (FileT a) = FileT (takeBaseName a)- takeFileName (FileT a) = FileT (takeFileName a)+ -- fromFilePath fp = FileT (fromFilePath fp)+ combine (FileT a) b = FileT (combine a b)+ takeBaseName (FileT a) = takeBaseName a+ takeFileName (FileT a) = takeFileName a takeExtension (FileT a) = takeExtension a takeExtensions (FileT a) = takeExtensions a makeRelative (FileT a) (FileT b) = FileT (makeRelative a b)@@ -51,7 +64,7 @@ dropExtensions (FileT a) = FileT (dropExtensions a) instance FileLike FilePath where- fromFilePath = id+ -- fromFilePath = id combine = F.combine takeBaseName = F.takeBaseName takeFileName = F.takeFileName@@ -61,9 +74,4 @@ takeExtension = F.takeExtension takeExtensions = F.takeExtensions dropExtensions = F.dropExtensions--unpack :: (FileT FilePath) -> FilePath-unpack (FileT f) = f--toFilePath = unpack
+ src/Text/QuasiMake.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE ExistentialQuantification, TemplateHaskell, QuasiQuotes, OverloadedStrings, FlexibleInstances, UndecidableInstances, IncoherentInstances #-}++-- | QuasyString-like module. Tweaked for the cake3+module Text.QuasiMake (Chunk (..), getChunks) where+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax+import Language.Haskell.TH+import Language.Haskell.Meta (parseExp)++import Data.Attoparsec.Text+import qualified Data.Text as T +import Data.Text (Text)+import Data.Char++import Data.Monoid+import Control.Applicative+ +instance Lift Text where+ lift = litE . stringL . T.unpack++-- | Chunk is a part of quasy-quotation+data Chunk + = T Text+ -- ^ the text+ | E Char Text+ -- ^ \$(expr) or \@(expr)+ deriving (Show, Eq)++class Textish a where+ toText :: a -> Text++instance Textish Text where+ {-# INLINE toText #-}+ toText x = x++instance Textish [Char] where+ {-# INLINE toText #-}+ toText x = T.pack x++instance Show a => Textish a where + {-# INLINE toText #-}+ toText x = T.pack (show x)+++-- | A simple 'QuasiQuoter' to interpolate 'Text' into other pieces of 'Text'.+-- Expressions can be embedded using \$(expr) or \@(expr), and values can be+-- interpolated with $name. Inside \$( )s, if you have a string of ambiguous+-- type, it will default to the Show instance for toText, which will escape+-- unicode characters in the string, and add quotes around them.+getChunks :: Text -> [Chunk]+getChunks i = case parseOnly parser (T.strip i) of+ Right m -> m+ _ -> error "Unclosed parenthesis."++ where+ parenthesis '(' = True+ parenthesis ')' = True+ parenthesis _ = False++ parseExpression :: Int -> Parser [Text]+ parseExpression level = do+ expr <- takeTill parenthesis+ paren <- anyChar+ case paren of+ ')' | level <= 0 -> return [expr]+ | otherwise -> do+ next <- parseExpression (level - 1)+ return ([expr, ")"] ++ next)++ '(' -> do+ next <- parseExpression (level + 1)+ return ([expr, "("] ++ next)++ _ -> return [expr, T.singleton paren]++ parser :: Parser [Chunk]+ parser = fmap concat $ flip manyTill endOfInput $ do+ text <- takeTill (\c -> elem c "@$")+ end <- atEnd+ if end+ then return [T text]+ else do+ delim <- anyChar+ next <- anyChar+ case next of+ -- opening an experssion+ '(' -> do+ expr <- T.concat <$> parseExpression 0+ return [T text, E delim expr]+ c | c == delim -> do+ -- escaped '$', '@' or '%' + return [T (text <> T.singleton delim)]++ | otherwise -> do+ -- value+ name <- takeTill (\c -> not (isAlphaNum c || c == '_') )+ return [T text, E delim (T.cons next name)]+ ++
+ src/UrEmbedHelp.txt view
@@ -0,0 +1,28 @@++ Converts a set of FILEs into the Ur/Web modules. Each Module will contain+ following functions:++ val binary : unit -> transaction blob+ val blobpage : unit -> transaction page+ val text : unit -> transaction string++ Additionally, FFI signatures will be provided for JavaScript files. In order+ to enable this, you have to name your JS functions using the name__type+ scheme. See README for details. Also, uru project uses this a lot.++ (NOTE: the interface is not stable. Pleas, fork the Urembed sources+ before using)++ The master project (specified with -o FILE.urp) will contain a dictionary+ version of those functions taking the datatype key as an argument, instead of+ unit. In order to actually compile the binaries, you have to call++ make -f FILE.mk CC=.. LD=.. UR_INCLUDE_DIR=.. urp++ Where FILE.mk is the Makefile, generated by urembed.++ Example: urembed -o static/Static.urp Style.css Script.js+ make -C static -f Static.mk CC=gcc LD=ld UR_INCLUDE_DIR=/usr/local/include/urweb urp++ Note: output directory should exist+