module MonadLab.CommonTypes (
Layer(..),
ErrorName, StateName, EnvName, WriterName,
LayerType(..),
layerType, hasLayerType,
Monad, MonadName, MonadTypeCon,
ReturnExpQ, BindExpQ, LiftExpQ, JoinExpQ, RunExpQ, NonProperMorphismExpQ,
MonadTransformer,
LayerNPM,
getTypeCon, getReturn, getBind, getLayerNPMs, getBaseLift, getJoin,
int, bool, string,
composition, arrow
) where
import Prelude hiding (Monad)
import Language.Haskell.TH
data Layer
= Io
| List
| ErrorT ErrorName TypeQ
| StateT StateName TypeQ
| EnvT EnvName TypeQ
| WriterT WriterName TypeQ
| ContT TypeQ
| ResT MonadName
type ErrorName = String
type StateName = String
type EnvName = String
type WriterName = String
data LayerType = IoLayerType
| ListLayerType
| StateLayerType
| EnvLayerType
| ErrorLayerType
| WriterLayerType
| ContLayerType
| ResLayerType
deriving Eq
layerType :: Layer -> LayerType
layerType Io = IoLayerType
layerType List = ListLayerType
layerType (StateT _ _) = StateLayerType
layerType (EnvT _ _) = EnvLayerType
layerType (ErrorT _ _) = ErrorLayerType
layerType (WriterT _ _) = WriterLayerType
layerType (ContT _) = ContLayerType
layerType (ResT _) = ResLayerType
hasLayerType :: LayerType -> Layer -> Bool
hasLayerType lt l = layerType l == lt
type Monad = (MonadTypeCon, ReturnExpQ, BindExpQ, [LayerNPM], LiftExpQ)
type MonadName = String
type MonadTypeCon = TypeQ -> TypeQ
type ReturnExpQ = ExpQ
type BindExpQ = ExpQ
type LiftExpQ = ExpQ
type JoinExpQ = ExpQ
type RunExpQ = ExpQ
type NonProperMorphismExpQ = ExpQ
type LayerNPM = (Layer , [NonProperMorphismExpQ])
type MonadTransformer = Monad -> Monad
getTypeCon :: Monad -> MonadTypeCon
getTypeCon (tc, _, _,_, _) = tc
getReturn :: Monad -> ReturnExpQ
getReturn (_, ret, _, _, _) = ret
getBind :: Monad -> BindExpQ
getBind (_, _, bind, _, _) = bind
getLayerNPMs :: Monad -> [LayerNPM]
getLayerNPMs (_, _, _, lnpms, _) = lnpms
getBaseLift :: Monad -> LiftExpQ
getBaseLift (_, _, _, _, baseLift) = baseLift
getJoin :: Monad -> JoinExpQ
getJoin m = let return = getReturn m
bind = getBind m
in [| \x -> $bind x (\a -> a) |]
int, bool , string :: TypeQ
int = [t| Int |]
bool = [t| Bool |]
string = [t| String |]
composition :: ExpQ
composition = [| \f -> \g -> \x -> f (g x) |]
arrow :: TypeQ -> TypeQ -> TypeQ
arrow t1 t2 = appT (appT (conT $ mkName "(->)") t1) t2