cake3 (empty) → 0.1.0.0
raw patch · 12 files changed
+1166/−0 lines, 12 filesdep +QuasiTextdep +basedep +bytestringsetup-changed
Dependencies added: QuasiText, base, bytestring, containers, deepseq, directory, filepath, haskell-src-meta, monadloc, mtl, process, system-filepath, template-haskell, text, text-format
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- cake3.cabal +40/−0
- src/CakeScript.hs +22/−0
- src/CakeScript.sh +143/−0
- src/Development/Cake3.hs +298/−0
- src/Development/Cake3/Monad.hs +186/−0
- src/Development/Cake3/Rules/UrWeb.hs +146/−0
- src/Development/Cake3/Types.hs +65/−0
- src/Development/Cake3/Utils/Find.hs +47/−0
- src/Development/Cake3/Writer.hs +118/−0
- src/System/FilePath/Wrapper.hs +69/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Sergey Mironov++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Sergey Mironov nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cake3.cabal view
@@ -0,0 +1,40 @@+-- Initial hmg.cabal generated by cabal init. For further documentation, +-- 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+ 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: +category: Development+build-type: Simple+cabal-version: >=1.8+data-dir: src+data-files: CakeScript.sh++library+ exposed-modules: Development.Cake3, Development.Cake3.Types,+ Development.Cake3.Writer, System.FilePath.Wrapper,+ Development.Cake3.Monad,+ Development.Cake3.Rules.UrWeb+ Development.Cake3.Utils.Find++ build-depends: base ==4.6.*, haskell-src-meta, template-haskell,+ QuasiText, filepath, containers, text, monadloc, mtl,+ bytestring,deepseq, system-filepath, text-format,+ directory++ hs-source-dirs: src++executable cake3+ hs-source-dirs: src+ main-is: CakeScript.hs+ build-depends: base ==4.6.*, process+ other-modules: Paths_cake3+
+ src/CakeScript.hs view
@@ -0,0 +1,22 @@+module Main where++import System.Environment+import System.Process+import System.Exit+import Paths_cake3++main = do+ args <- getArgs+ src <- getDataFileName "CakeScript.sh"+ (_,_,_,ph) <- createProcess $ CreateProcess+ { cmdspec = RawCommand "sh" (src : args)+ , cwd = Nothing+ , env = Nothing+ , std_in = Inherit+ , std_out = Inherit+ , std_err = Inherit+ , close_fds = True+ , create_group = False+ }+ ret <- waitForProcess ph+ exitWith ret
+ src/CakeScript.sh view
@@ -0,0 +1,143 @@+#!/bin/sh++die() { echo "$@" >&2 ; exit 1 ; }+err() { echo "$@" >&2 ; }++CAKEURL=https://github.com/grwlf/cake3++cakepath() {+cat <<EOF+-- This file was autogenerated by cake3.+-- $CAKEURL++module ${1}_P(file,cakefiles,projectroot,moduleroot) where++import Development.Cake3++file :: String -> File+file x = file' "$TOP" "$2" x++projectroot :: File+projectroot = file "$TOP"++moduleroot :: File+moduleroot = file "$2"++cakefiles :: [File]+cakefiles = case "$2" of+ "$TOP" -> map (file' "$TOP" "$TOP") \$ $3+ _ -> error "cakefiles are defined for top-level cake only"++EOF+}++caketemplate() {+cat <<"EOF"+{-# LANGUAGE RecursiveDo, QuasiQuotes #-}+module Cakefile where++import Development.Cake3+import Cakefile_P (file, cakefiles)++elf = rule (file "main.elf") $ do+ shell [cmd| echo "Your commands go here" ; exit 1 ; |]++main = runMake (place (phony "all" (depend elf)) >> place defaultSelfUpdate)++EOF+}++while test -n "$1" ; do+ case "$1" in+ --help|-h|help) + err "Cake3 the Makefile generator help"+ err "$CAKEURL"+ err "Usage: cake3 [--help|-h] [init]"+ err "cake3 init"+ err " - Create default Cakefile.hs"+ err "cake3"+ err " - Build the Makefile"+ exit 1;+ ;;+ init)+ test -f Cakefile.hs &&+ die "Cakefile.hs already exists"+ caketemplate > Cakefile.hs+ echo "Cakefile.hs has been created"+ exit 0;+ ;;+ esac+ shift+done++CWD=`pwd`+T=`mktemp -d`++cakes() {+ 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].*'+}++IFS=$'\n'+CAKES=`cakes`+CAKELIST="[]"+for f in $CAKES ; do+ CAKELIST="\"$f\" : $CAKELIST" +done++MAIN_=+MAIN=+TOP=+for f in $CAKES ; do+ fname_=$(basename "$f")+ tgt=$T/$fname_+ fname=$(echo "$fname_" | sed 's/\.l\?hs//')+ pname="${fname}_P.hs"+ fdir=$(dirname "$f")+ case $fdir in+ .) fdir_abs=$(pwd) ;;+ *) fdir_abs=$(pwd)/$fdir ;;+ esac++ if test "$fdir" = "." ; then+ if test -n "$MAIN" ; then+ die 'More than one Cake* file in current dir'+ fi+ MAIN=$fname+ MAIN_=$fname_+ TOP=$fdir_abs+ fi++ if test -f "$tgt" ; then+ die "More than one file named '${fname}.hs' in the filetree"+ fi++ cp "$f" "$tgt" ||+ die "cp $f $tgt failed. Duplicate names?"++ if cat "$f" | grep -q "import.*${fname}_P" ; then+ echo "Creating $fdir/${pname}" >&2+ 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+ fi+done++if test -z "$MAIN" ; then+ die "No Cake* file exist in the current directory. Consider running \`cake3 --help'."+fi++(+set -e+cd $T+ghc --make "$MAIN_" -main-is "$MAIN" -o Cakegen+cp -t "$CWD" Cakegen+) &&++./Cakegen > Makefile && echo "Makefile created" >&2+
+ src/Development/Cake3.hs view
@@ -0,0 +1,298 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FunctionalDependencies #-}++module Development.Cake3 (++ Alias+ , Variable+ , Recipe+ , Referal(..)+ , Placable(..)+ , Reference+ , ReferenceLike(..)++ -- Monads+ , A+ , Make+ , toMake+ , runMake+ , runMake_++ -- Rules+ , Rule+ , Rules+ , rule+ , ruleM+ , phony+ , phonyM+ , depend+ , unsafe+ , defaultSelfUpdate+ + -- Files+ , FileLike(..)+ , File+ , file'+ , (.=)+ , (</>)+ , toFilePath+ , fromFilePath++ -- Make parts+ , prerequisites+ , shell+ , cmd+ , makevar+ , extvar+ , dst+ , makefile+ , CommandGen(..)+ , unCommand++ -- More+ , 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)+import qualified Data.Map as M+import Data.Map (Map)+import qualified Data.Set as S+import Data.Set (Set,member,insert)+import Data.String as S+import Data.Tuple+import System.IO+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]++-- | 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++ruleM :: (Monad m, Rulable f a) => f -> A () -> m a+ruleM a b = return (rule a b)++list1 a = [a]+fmap1 f a = f a++list2 (a1,a2) = [a1,a2]+fmap2 f (a1,a2) = (f a1,f a2)++list3 (a1,a2,a3) = [a1,a2,a3]+fmap3 f (a1,a2,a3) = (f a1,f a2,f a3)++list4 (a1,a2,a3,a4) = [a1,a2,a3,a4]+fmap4 f (a1,a2,a3,a4) = (f a1,f a2,f a3,f a4)++phony name = rule' fmap1 list1 True (fromFilePath name)++phonyM :: (Monad m) => String -> A () -> m Alias+phonyM n a = return $ phony n a++rule' fmapX listX isPhony dst act = flip fmapX dst $ \x -> Alias (x, listX dst, 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++-- | 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+--+-- return Command $ do+-- s1 <- ref "gcc "+-- s2 <- ref (flags :: Variable)+-- s3 <- ref " "+-- s4 <- ref (file :: File)+-- return (s1 ++ s2 ++ s3)+--+-- Later, this command may be examined or passed to the shell function to apply+-- it to the recepi+--+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)++
+ src/Development/Cake3/Monad.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+module Development.Cake3.Monad where++import Control.Applicative+import Control.Monad+import Control.Monad.State+import Control.Monad.Reader+import Control.Monad.Loc+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 Data.Either+import qualified Data.Foldable as F+import qualified Data.Traversable as F+import Development.Cake3.Types+import qualified System.IO as IO+import Text.Printf++import System.FilePath.Wrapper++type Recipe = Recipe1++type Recipe1 = RecipeT (Map String (Set Variable))++type Recipe2 = RecipeT (Map String Variable)+++type Location = String++type Target = Set File++data MakeState = MS {+ srecipes :: Map Target (Set Recipe1)+ , sloc :: Location+ , makeDeps :: Set File+ , placement :: [Target]+ } deriving(Show)++addPlacement :: RecipeT x -> Make ()+addPlacement r = modify $ \ms -> ms { placement = (placement ms) ++ [rtgt r] }++modifyRecipes f = modify $ \ms -> ms { srecipes = f (srecipes ms) }++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)++addMakeDep :: File -> Make ()+addMakeDep f = modify (\ms -> ms { makeDeps = S.insert f (makeDeps ms) })++defMS = MS mempty mempty mempty mempty++-- | 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)++-- unalias :: [Alias] -> Make ()+-- unalias as = F.sequence_ $ map (\(Alias (_,_,x)) -> x) as++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"++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++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)++ selectBySrc f = map snd . M.toList . fst $ M.partition (\r -> f`S.member`(rsrc r)) rs++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)++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)++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)++modifyLoc f = modify $ \ms -> ms { sloc = f (sloc ms) }++addRecipe :: Recipe1 -> 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) }++getLoc :: Make String+getLoc = sloc <$> get++instance MonadLoc Make 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)++addVariable :: Variable -> A ()+addVariable v = modify $ \r -> r { rvars = M.insertWith mappend (vname v) (S.singleton v) (rvars r) }++targets :: A (Set File)+targets = rtgt <$> get++prerequisites :: A (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'++readFile :: File -> A String+readFile f = do+ A (lift $ addMakeDep f)+ liftIO (IO.readFile (unpack f))++class Placable a where+ place :: a -> Make ()++-- instance Placable (Make ()) where+-- place = id++instance Placable Alias where+ place (Alias (_,_,x)) = do+ x >>= addPlacement++instance Placable (Alias,Alias) where+ place (a,b) = place a >> place b++instance Placable (Alias,Alias,Alias) where+ place (a,b,c) = place a >> place b >> place c++instance Placable (Alias,Alias,Alias,Alias) where+ place (a,b,c,d) = place a >> place b >> place c >> place d++instance Placable x => Placable (Make x) where+ place mk = mk >>= place++instance Placable x => Placable [x] where+ place xs = sequence_ (map place xs)+
+ src/Development/Cake3/Rules/UrWeb.hs view
@@ -0,0 +1,146 @@+{-# 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
@@ -0,0 +1,65 @@+module Development.Cake3.Types where++import Data.Monoid+import qualified Data.List as L+import Data.List hiding(foldr)+import qualified Data.Map as M+import Data.Map (Map)+import qualified Data.Set as S+import Data.Set (Set)++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+data Variable = Variable {+ vname :: String+ , vval :: Maybe String+ -- ^ Nothing means that variable is defined elsewhere (eg. borrowed from the+ -- environment)+ } deriving(Show, Eq, Ord)++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]++return_text x = return [Left x]+return_file x = return [Right x]++-- | Recipe answers to the question 'How to build the targets'+data RecipeT v = Recipe {+ rtgt :: Set File+ -- ^ Targets + , rsrc :: Set File+ -- ^ Prerequisites+ , rcmd :: [Command]+ -- ^ A list of shell commands+ , rvars :: v+ -- ^ Container of variables+ , rloc :: String+ -- FIXME: actually, PHONY is a file's attribute, not recipe's+ , rphony :: Bool+ } deriving(Show, Eq, Ord)
+ src/Development/Cake3/Utils/Find.hs view
@@ -0,0 +1,47 @@+module Development.Cake3.Utils.Find where++import Control.Applicative+import Control.Monad.Trans+import System.Directory+import System.IO.Unsafe (unsafeInterleaveIO)++import System.FilePath.Wrapper+import Development.Cake3+import Development.Cake3.Types+import Development.Cake3.Monad+++filterExts :: [String] -> [File] -> [File]+filterExts exts files = filter (\f -> or $ map (isExt f) exts) files where+ isExt f e = takeExtension f == (sureDot e)+ sureDot [] = error "filterExt: empty extantion passed"+ sureDot e@('.':cs) = e+ sureDot e@(c:cs) = '.':e++-- FIMXE: Find a way to record dependencies like+-- 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 [""])+ where+ recurseDirectories :: [FilePath] -> IO [FilePath]+ recurseDirectories [] = return []+ recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do+ (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir </> dir)+ files' <- recurseDirectories (dirs' ++ dirs)+ return (files ++ files')++ where+ collect files dirs' [] = return (reverse files, reverse dirs')+ collect files dirs' (entry:entries) | ignore entry+ = collect files dirs' entries+ collect files dirs' (entry:entries) = do+ let dirEntry = dir </> entry+ isDirectory <- doesDirectoryExist (topdir </> dirEntry)+ if isDirectory+ then collect files (dirEntry:dirs') entries+ else collect (dirEntry:files) dirs' entries++ ignore ['.'] = True+ ignore ['.', '.'] = True+ ignore _ = False
+ src/Development/Cake3/Writer.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE FlexibleInstances #-}+module Development.Cake3.Writer (toMake) where++import Control.Monad (when)+import Control.Applicative+import Control.Monad.State (State(..), execState, runState, modify, get, put)+import Data.List as L+import Data.Char+import Data.String+import Data.Foldable (forM_)+import Data.Traversable (forM)+import Data.Set (Set)+import qualified Data.Set as S+import Data.Map (Map)+import qualified Data.Map as M+import Text.Printf++import System.FilePath.Wrapper+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++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)++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)++line :: String -> MakeWriter ()+line s = modify $ \ws -> ws { ls = concat [ls ws, s, "\n"] }++mmap f = map (f . snd) . M.toList+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 ""++ when (not (null vs)) $ do+ line "GUARD = .GUARD_$(1)_$(shell echo $($(1)) | md5sum | cut -d ' ' -f 1)"++ -- Variables+ forM_ vs $ \v -> case v of+ (Variable n (Just v)) -> line (printf "%s = %s" n v)+ (Variable n Nothing) -> return ()++ -- 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 tgts = intercalate " " $ (smap toMakeText (rtgt r))++ when (rphony r) $ do+ line (printf ".PHONY: %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))++ -- Rules for variable's guards+ -- FIXME: add those on the higher level+ forM_ vs $ \v -> do+ line (printf "$(call GUARD,%s):" (vname v))+ line (printf "\trm -f .GUARD_%s_*" (vname v))+ line "\ttouch $@"+
+ src/System/FilePath/Wrapper.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+module System.FilePath.Wrapper where++import Control.Applicative+import Control.Monad.State+import Control.Monad.Trans+import qualified System.FilePath as F hiding ((</>))+import qualified Data.Map as M+import Data.Monoid+import Text.Printf++newtype FileT a = FileT a+ deriving(Show,Eq,Ord)++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+ 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+(</>) = combine++(.=) :: (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)+ takeExtension (FileT a) = takeExtension a+ takeExtensions (FileT a) = takeExtensions a+ makeRelative (FileT a) (FileT b) = FileT (makeRelative a b)+ replaceExtension (FileT a) ext = FileT (replaceExtension a ext)+ takeDirectory (FileT a) = FileT (takeDirectory a)+ dropExtensions (FileT a) = FileT (dropExtensions a)++instance FileLike FilePath where+ fromFilePath = id+ combine = F.combine+ takeBaseName = F.takeBaseName+ takeFileName = F.takeFileName+ makeRelative = F.makeRelative+ replaceExtension = F.replaceExtension+ takeDirectory = F.takeDirectory+ takeExtension = F.takeExtension+ takeExtensions = F.takeExtensions+ dropExtensions = F.dropExtensions++unpack :: (FileT FilePath) -> FilePath+unpack (FileT f) = f++toFilePath = unpack+