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
data MakeState = MS {
prebuilds :: Recipe
, postbuilds :: Recipe
, recipes :: Set Recipe
, sloc :: Location
, makeDeps :: Set File
, placement :: [File]
, includes :: Set File
, errors :: String
, warnings :: String
, outputFile :: File
}
initialMakeState mf = MS defr defr mempty mempty mempty mempty mempty mempty mempty mf where
defr = emptyRecipe "<internal>"
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) })
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 }
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)
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)
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
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
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' m a = A' { unA' :: StateT Recipe m a }
deriving(Monad, Functor, Applicative, MonadState Recipe, MonadIO,MonadFix)
type A a = A' (Make' IO) a
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
runA' :: (Monad m) => Recipe -> A' m a -> m (Recipe, a)
runA' r act = do
(a,r) <- runStateT (unA' act) r
return (r,a)
runA :: (Monad m)
=> String
-> A' m a
-> m (Recipe, a)
runA loc act = runA' (emptyRecipe loc) act
runA_ :: (Monad m) => String -> A' m a -> m Recipe
runA_ loc act = runA loc act >>= return .fst
targets :: (Applicative m, Monad m) => A' m (Set File)
targets = rtgt <$> get
prerequisites :: (Applicative m, Monad m) => A' m (Set File)
prerequisites = rsrc <$> get
markPhony :: (Monad m) => A' m ()
markPhony = modify $ \r -> r { rflags = S.insert Phony (rflags r) }
markIntermediate :: (Monad m) => A' m ()
markIntermediate = modify $ \r -> r { rflags = S.insert Intermediate (rflags r) }
readFileForMake :: (MonadMake m)
=> File
-> m BS.ByteString
readFileForMake f = liftMake (addMakeDep f >> liftIO (BS.readFile (toFilePath f)))
newtype CommandGen' m = CommandGen' { unCommand :: A' m Command }
type CommandGen = CommandGen' (Make' IO)
commandGen :: A Command -> CommandGen
commandGen mcmd = CommandGen' mcmd
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
shell :: (Monad m)
=> CommandGen' m
-> A' m [File]
shell cmdg = do
line <- unCommand cmdg
commands [line]
r <- get
return (S.toList (rtgt r))
unsafeShell :: (Monad m) => CommandGen' m -> A' m [File]
unsafeShell cmdg = ignoreDepends (shell cmdg)
newtype CakeString = CakeString String
deriving(Show,Eq,Ord)
string :: String -> CakeString
string = CakeString
class (Monad m) => RefOutput m x where
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
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 (MonadAction a m) => RefInput a m x where
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
instance (MonadAction a m) => RefInput a m (CommandGen' m) where
refInput (CommandGen' a) = liftAction a
depend :: (RefInput a m x)
=> x
-> a ()
depend x = refInput x >> return ()
produce :: (RefOutput m x)
=> x
-> A' m ()
produce x = refOutput x >> return ()
variables :: (Foldable t, Monad m)
=> (t Variable)
-> A' m ()
variables vs = modify (\r -> r { rvars = foldl' (\a v -> S.insert v a) (rvars r) vs } )
commands :: (Monad m) => [Command] -> A' m ()
commands cmds = modify (\r -> r { rcmd = (rcmd r) ++ cmds } )
location :: (Monad m) => String -> A' m ()
location l = modify (\r -> r { rloc = l } )
flags :: (Monad m) => Set Flag -> A' m ()
flags f = modify (\r -> r { rflags = (rflags r) `mappend` f } )
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)