module Development.Cake3.Writer (defaultMakefile,buildMake) where
import Control.Applicative
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)
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
class ToMakeText x where
toMakeText :: x -> String
instance ToMakeText [Char] where
toMakeText = id
escapeFile f = escapeFile' (toFilePath f)
escapeFile' [] = []
escapeFile' (' ':xs) = "\\ " ++ escapeFile' xs
escapeFile' (x:xs) = (x:(escapeFile' xs))
instance ToMakeText File where
toMakeText = escapeFile
instance ToMakeText Command where
toMakeText cmd = concat $ map toMakeText cmd
instance ToMakeText CommandPiece where
toMakeText (CmdStr s) = s
toMakeText (CmdFile f) = toMakeText f
instance ToMakeText (Set File) where
toMakeText s = intercalate " " (map toMakeText (S.toList s))
smap f = map f . S.toList
line :: (MonadState String m) => String -> m ()
line s = modify $ \ws -> concat [ws, s, "\n"]
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)
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
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
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
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
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))
unsafeShell [cmd|-mkdir .cake3|]
commands (rcmd $ prebuilds ms)
unsafeShell [cmd|$(make) f $(outputFile ms) MAIN=1 $(makecmdgoals)|]
commands (rcmd $ 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 = .cake3/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
forM_ vs $ \v -> case v of
(Variable n (Just v)) -> line (printf "%s = %s" n v)
(Variable n Nothing) -> return ()
forM_ rs $ \r -> do
let varguard v = printf "$(call GUARD,%s)" (vname v)
let deps = intercalate " " $ (smap toMakeText (rsrc r)) ++ (smap varguard (rvars r))
let tgts = intercalate " " $ (smap toMakeText (rtgt r))
when (Phony `S.member` (rflags r)) $ do
line (printf ".PHONY: %s" tgts)
when (Intermediate `S.member` (rflags r)) $ do
line (printf ".INTERMEDIATE: %s" tgts)
line (printf "%s: %s" tgts deps)
forM_ (rcmd r) $ \c -> do
line (printf "\t%s" (toMakeText c))
forM_ vs $ \v -> do
line (printf "$(call GUARD,%s):" (vname v))
line (printf "\trm -f .cake3/GUARD_%s_*" (vname v))
line "\ttouch $@"