{-# 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 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 Text.QuasiMake
import Language.Haskell.TH.Quote
import Language.Haskell.TH hiding(unsafe)
import Language.Haskell.Meta (parseExp)
import System.FilePath.Wrapper
type Location = String
-- | MakeState describes the state of the EDSL synthesizers during the
-- the program execution.
data MakeState = MS {
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
-- ^ 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
}
-- Oh, such a boilerplate
initialMakeState mf = MS defr defr mempty mempty mempty mempty mempty mempty mempty mf where
defr = emptyRecipe ""
getPlacementPos :: Make Int
getPlacementPos = L.length <$> placement <$> get
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) })
-- | 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 }
-- | 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)
-- | 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)
-- | A Monad providing access to MakeState. TODO: not mention IO here.
class (Monad m) => MonadMake m where
liftMake :: (Make' IO) a -> m a
newtype Make' m a = Make { unMake :: (StateT MakeState m) a }
deriving(Monad, Functor, Applicative, MonadState MakeState, MonadIO, MonadFix)
type Make a = Make' IO a
instance MonadMake (Make' IO) where
liftMake = id
instance (MonadMake m) => MonadMake (A' m) where
liftMake m = A' (lift (liftMake m))
instance (MonadMake m) => MonadMake (StateT s m) where
liftMake = lift . liftMake
-- | 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 :: Recipe -> Make ()
addRecipe r = modify $ \ms ->
let rs = recipes ms ; k = rtgt r
in ms { recipes = (S.insert r (recipes ms)) }
getLoc :: Make String
getLoc = sloc <$> get
-- | 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
-- | '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)
-- | Verison of Action monad with fixed parents
type A a = A' (Make' IO) a
-- | 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
-- | Get a list of prerequisites added so far
prerequisites :: (Applicative m, Monad m) => A' m (Set File)
prerequisites = rsrc <$> get
-- | 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) }
-- | 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) }
-- | 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)))
-- | 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)
-- | Pack the command builder into a CommandGen
commandGen :: A Command -> CommandGen
commandGen mcmd = CommandGen' mcmd
-- | 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
-- | 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))
-- | Version of @shell@ which doesn't track it's dependencies
unsafeShell :: (Monad m) => CommandGen' m -> A' m [File]
unsafeShell cmdg = ignoreDepends (shell cmdg)
-- | Simple wrapper for strings, a target for various typeclass instances.
newtype CakeString = CakeString String
deriving(Show,Eq,Ord)
-- | 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)