module MonadLab.MonadLab (
mkMonad,
Layer(..),
errorTRec,
stateTRec,
envTRec,
writerTRec,
contTRec,
) where
import Prelude hiding (Monad)
import Data.List (nub)
import Language.Haskell.TH
import MonadLab.CommonTypes
import MonadLab.Identity
import MonadLab.Io
import MonadLab.List
import MonadLab.IoList
import MonadLab.ListIo
import MonadLab.State
import MonadLab.Env
import MonadLab.Error
import MonadLab.Writer
import MonadLab.Cont
import MonadLab.Res
import MonadLab.Run
import MonadLab.Declarations
import MonadLab.TypeParser
errorTRec :: String -> String -> Layer
errorTRec n t = ErrorT n (typeParser t)
stateTRec :: String -> String -> Layer
stateTRec n t = StateT n (typeParser t)
envTRec :: String -> String -> Layer
envTRec n t = EnvT n (typeParser t)
writerTRec :: String -> String -> Layer
writerTRec n t = WriterT n (typeParser t)
contTRec :: String -> Layer
contTRec t = ContT (typeParser t)
mkMonad :: MonadName -> [Layer] -> Q [Dec]
mkMonad monadName ls = let ls' = leftAlignErrors . rightAlignCont $ ls
in do checkInsanity ls'
if isResumptive ls
then do
let (ResT resName):ls'' = ls'
monadDecls <- createMonadDecls resName (createMonad ls'')
runDecl <- createRunDecl ls'' resName (createRun ls'')
resDecls <- createResDecls monadName resName
return $ monadDecls ++ [runDecl] ++ resDecls
else do
monadDecls <- createMonadDecls monadName (createMonad ls')
runDecl <- createRunDecl ls' monadName (createRun ls')
return $ monadDecls ++ [runDecl]
where rightAlignCont, leftAlignErrors :: [Layer] -> [Layer]
rightAlignCont ls = filter (not . hasLayerType ContLayerType) ls ++ filter (hasLayerType ContLayerType) ls
leftAlignErrors ls = filter (hasLayerType ErrorLayerType) ls ++ filter (not . hasLayerType ErrorLayerType) ls
isResumptive = any (hasLayerType ResLayerType)
createMonad :: [Layer] -> Monad
createMonad ls = let baseMonad = if any (hasLayerType ListLayerType) ls
then if any (hasLayerType IoLayerType) ls
then listIoMonad
else listMonad
else if any (hasLayerType IoLayerType) ls
then ioMonad
else identityMonad
in foldr addLayer baseMonad ls
where addLayer :: Layer -> Monad -> Monad
addLayer l@(StateT name t) m = stateT l m
addLayer l@(EnvT name t) m = envT l m
addLayer l@(ErrorT name t) m = errorT l m
addLayer l@(List) m = m
addLayer l@(Io) m = m
addLayer l@(WriterT name t) m = writerT l m
addLayer l@(ContT t) m = contT l m
type InsanityCheck = [Layer] -> Q ()
checkInsanity :: InsanityCheck
checkInsanity ls = mapM_ (\check -> check ls) insanityChecks
where insanityChecks = [checkResT, checkIoList, checkIoRepeats, checkListRepeats, checkContRepeats, checkNameRepeats]
checkResT :: InsanityCheck
checkResT (l:ls) = if (any (hasLayerType ResLayerType) ls)
then error "ResT is only allowed as the leftmost layer"
else return ()
checkResT _ = return ()
checkIoList :: InsanityCheck
checkIoList ls = if (any (hasLayerType IoLayerType) ls) && (any (hasLayerType ListLayerType) ls)
then error "The Io and List Layers cannot be used together"
else return ()
checkIoRepeats :: InsanityCheck
checkIoRepeats ls = if length (filter (hasLayerType IoLayerType) ls) > 1
then error "Only one Io component is allowed"
else return ()
checkListRepeats :: InsanityCheck
checkListRepeats ls = if length (filter (hasLayerType ListLayerType) ls) > 1
then error "Only one List component is allowed"
else return ()
checkContRepeats :: InsanityCheck
checkContRepeats ls = if length (filter (hasLayerType ContLayerType) ls) > 1
then error "Only one Cont component is allowed"
else return ()
checkNameRepeats :: InsanityCheck
checkNameRepeats ls = let ns = getNames ls
in if not $ ns == nub ns
then error "Each component must have a unique name"
else return ()
getNames :: [Layer] -> [String]
getNames = foldr addName []
where addName l ns = case l of
Io -> ns
List -> ns
ErrorT n _ -> n:ns
StateT n _ -> n:ns
EnvT n _ -> n:ns
WriterT n _ -> n:ns
ContT _ -> ns
ResT _ -> ns