MonadLab 0.0.1 → 0.0.2
raw patch · 9 files changed
+233/−14 lines, 9 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ MonadLab.CommonTypes: ResLayerType :: LayerType
+ MonadLab.CommonTypes: ResT :: MonadName -> Layer
+ MonadLab.MonadLab: ResT :: MonadName -> Layer
Files
- MLabCompileStub.hs +1/−1
- MonadLab.cabal +2/−2
- MonadLab/CommonTypes.hs +5/−0
- MonadLab/Declarations.hs +13/−6
- MonadLab/MLabParser.hs +7/−0
- MonadLab/MonadLab.hs +23/−5
- MonadLab/Res.hs +177/−0
- RELEASE-NOTES +4/−0
- examples/Res.mlab +1/−0
MLabCompileStub.hs view
@@ -26,7 +26,7 @@ else c:(dropAll p rest) - let munge = (dropAll "GHC.Base.") . (dropAll "GHC.List.") . (dropAll "GHC.Err.")+ let munge = (dropAll "GHC.Base.") . (dropAll "GHC.List.") . (dropAll "GHC.Err.") . (dropAll "GHC.Unit.") -- FIXME: End duct tape let lines :: String -> [String]
MonadLab.cabal view
@@ -1,5 +1,5 @@ Name: MonadLab-Version: 0.0.1+Version: 0.0.2 Synopsis: Automatically generate layered monads Category: Monads @@ -39,5 +39,5 @@ MonadLab.Identity, MonadLab.Io, MonadLab.IoList, MonadLab.ListIo, MonadLab.List, MonadLab.State, MonadLab.Env, MonadLab.Error, MonadLab.Cont, MonadLab.Run,- MonadLab.Declarations+ MonadLab.Declarations, MonadLab.Res }
MonadLab/CommonTypes.hs view
@@ -60,6 +60,9 @@ continuation passing style programming. -} | ContT TypeQ+ {- | The Resumption layer.+ -}+ | ResT MonadName type ErrorName = String type StateName = String@@ -74,6 +77,7 @@ | ErrorLayerType | WriterLayerType | ContLayerType+ | ResLayerType deriving Eq layerType :: Layer -> LayerType@@ -84,6 +88,7 @@ layerType (ErrorT _ _) = ErrorLayerType layerType (WriterT _ _) = WriterLayerType layerType (ContT _) = ContLayerType+layerType (ResT _) = ResLayerType hasLayerType :: LayerType -> Layer -> Bool hasLayerType lt l = layerType l == lt
MonadLab/Declarations.hs view
@@ -2,11 +2,11 @@ module MonadLab.Declarations ( createMonadDecls, createRunDecl,- createResBaseDecls, createResDecl,- createReactiveBaseDecls, createReactiveDecl,- createStepTypeSig, createStepDecl,- createSignalTypeSig, createSignalDecl,- createSignullTypeSig, createSignullDecl+-- createResBaseDecls, createResDecl,+-- createReactiveBaseDecls, createReactiveDecl,+-- createStepTypeSig, createStepDecl,+-- createSignalTypeSig, createSignalDecl,+-- createSignullTypeSig, createSignullDecl ) where import Prelude hiding (Monad)@@ -78,6 +78,11 @@ --------------------------------------------- --Basic Resumption Declarations ++{-+createResDecls :: MonadName -> LayerNPM -> [DecQ]+createResDecls monadName (ResT _, []) = []+ createResBaseDecls :: Q [Dec] createResBaseDecls = [d| data Prelude.Monad m => ResT m a = Done a | Pause (m (ResT m a))@@ -90,11 +95,13 @@ createResDecl :: MonadName -> MonadName -> DecQ createResDecl resName innerName = return $ TySynD (mkName resName) [] (AppT (ConT (mkName "ResT")) (ConT (mkName innerName))) +-} --------------------------------------------- --Reactive Resumption Declarations +{- createReactiveBaseDecls :: Q [Dec] createReactiveBaseDecls = [d| data Prelude.Monad m => ReactT q r m a = D a@@ -138,7 +145,7 @@ createSignullDecl :: MonadName -> DecQ createSignullDecl reactiveName = mkValDecl ("signull" ++ reactiveName) [| \q -> $(conE (mkName "P")) (q, \_ -> return . return $ ()) |]-+-} ------------------------------- --State Declarations
MonadLab/MLabParser.hs view
@@ -74,6 +74,13 @@ ; return (ContT (typeParser t)) } )+ <|>+ try (+ do{ reserved lexer "ResT"+ ; n <- identifier lexer+ ; return (ResT n)+ }+ ) <?> "layer spec"
MonadLab/MonadLab.hs view
@@ -24,6 +24,7 @@ import MonadLab.Error import MonadLab.Writer import MonadLab.Cont+import MonadLab.Res import MonadLab.Run import MonadLab.Declarations import MonadLab.TypeParser@@ -52,14 +53,24 @@ mkMonad :: MonadName -> [Layer] -> Q [Dec] mkMonad monadName ls = let ls' = leftAlignErrors . rightAlignCont $ ls in do checkInsanity ls'- monadDecls <- createMonadDecls monadName (createMonad ls')- runDecl <- createRunDecl ls' monadName (createRun ls')- return $ monadDecls ++ [runDecl]+ 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) +{- mkResumption :: String -> String -> Q [Dec] mkResumption resName innerName = do baseDecls <- recover createResBaseDecls (reify (mkName "Done") >> return []) resDecl <- createResDecl resName innerName@@ -76,7 +87,7 @@ signullTypeSig <- createSignullTypeSig reactiveName reqT signullDecl <- createSignullDecl reactiveName return $ baseDecls ++ [reactiveDecl, stepTypeSig, stepDecl, signalTypeSig, signalDecl, signullTypeSig, signullDecl]-+-} createMonad :: [Layer] -> Monad@@ -104,8 +115,14 @@ checkInsanity :: InsanityCheck checkInsanity ls = mapM_ (\check -> check ls) insanityChecks- where insanityChecks = [checkIoList, checkIoRepeats, checkListRepeats, checkContRepeats, checkNameRepeats]+ 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"@@ -143,6 +160,7 @@ EnvT n _ -> n:ns WriterT n _ -> n:ns ContT _ -> ns+ ResT _ -> ns ----------------------------------------------------------
+ MonadLab/Res.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE TemplateHaskell #-}++module MonadLab.Res (+ createResDecls+ ) where++import Prelude hiding (Monad)+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import MonadLab.CommonTypes+++createResDecls :: MonadName -> MonadName -> Q [Dec]+createResDecls resName baseName = sequenceQ [createResDataDecl resName baseName,+ createResMonadInstance resName baseName,+ createResStep resName+ ] >>= return . concat++--+-- FIXME: Surely there's got to be a way to use quasi-quoting here!+--++createResDataDecl :: MonadName -> MonadName -> Q [Dec]+createResDataDecl resName baseName = qNewName "a" >>= \ nameA ->+ dataD (cxt []) (mkName resName) [nameA]+ [normalC (mkName $ "Done" ++ resName) [strictType notStrict (varT nameA)],+ normalC (mkName $ "Pause" ++ resName) [strictType notStrict (appT (conT (mkName baseName)) + (appT (conT (mkName resName)) + (varT nameA)+ )+ )+ ]+ ]+ []+ >>= \dec -> return [dec]++createResMonadInstance :: MonadName -> MonadName -> Q [Dec]+createResMonadInstance resName baseName = instanceD (cxt []) (appT (conT (mkName "Prelude.Monad")) (conT (mkName resName)))+ [funD (mkName "(>>=)") [qNewName "f" >>= \ nameF ->+ qNewName "v" >>= \ nameV ->+ clause [conP (mkName $ "Done" ++ resName) [varP nameV],+ varP nameF+ ]+ (normalB (appE (varE nameF) (varE nameV))) + [],+ + qNewName "r" >>= \ nameR ->+ qNewName "f" >>= \ nameF ->+ qNewName "k" >>= \ nameK ->+ clause [conP (mkName $ "Pause" ++ resName) [varP nameR],+ varP nameF+ ]+ (normalB (appE (conE (mkName $ "Pause" ++ resName))+ (infixApp+ (varE nameR)+ (varE (mkName ">>="))+ (lamE [varP nameK]+ (appE (varE (mkName "return"))+ (infixApp (varE nameK)+ (varE (mkName ">>="))+ (varE nameF)+ )+ )+ )+ )+ )+ )+ []+ ],+ funD (mkName "return") [clause [] + (normalB (conE (mkName $ "Done" ++ resName)))+ []+ ]+ ]+ >>= \ dec -> return [dec]++createResStep :: MonadName -> Q [Dec]+createResStep resName = qNewName "x" >>= \ nameX ->+ funD (mkName $ "step" ++ resName)+ [clause [varP nameX]+ (normalB (appE (conE (mkName $ "Pause" ++ resName))+ (infixApp (varE nameX)+ (varE (mkName ">>="))+ (infixApp (varE (mkName "return"))+ (varE (mkName "."))+ (conE (mkName $ "Done" ++ resName))+ )+ )+ )+ )+ []+ ]+ >>= \ dec -> return [dec]++{-+resT :: Layer -> MonadTransformer+resT l@(ResT _) = \m -> ( resTransTypeCon m+ , resTransReturn m+ , resTransBind m+ , resTransLayerNPM l : resTransLiftLayerNPMs m+ , [| $(resTransLift m) . $(getBaseLift m) |]+ )++--------------------------------++resTransTypeCon :: Monad -> MonadTypeCon+resTransTypeCon m = getTypeCon m++resTransReturn :: Monad -> ReturnExpQ+resTransReturn m = getReturn m++resTransBind :: Monad -> BindExpQ+resTransBind m = getBind m++resTransLift :: Monad -> LiftExpQ+resTransLift _ = [| id |]++--------------------------------++resTransLayerNPM :: Layer -> LayerNPM+resTransLayerNPM l = (l, [])+++resTransLiftLayerNPMs :: Monad -> [LayerNPM]+resTransLiftLayerNPMs m = map (resTransLiftLayerNPM m) (getLayerNPMs m) ++ where resTransLiftLayerNPM :: Monad -> LayerNPM -> LayerNPM+ resTransLiftLayerNPM m l = case l of+ (Io, [liftIO]) -> (Io, [resTransLiftLiftIO m liftIO])+ (List, [merge, halt]) -> (List, [resTransLiftMerge m, resTransLiftHalt m])+ (StateT n t, [get,put]) -> (StateT n t, [resTransLiftGet m get, resTransLiftPut m put])+ (EnvT n t, [rdEnv,inEnv]) -> (EnvT n t, [resTransLiftRdEnv m rdEnv, resTransLiftInEnv m inEnv])+ (ErrorT n t, [throw,catch]) -> (ErrorT n t, [resTransLiftThrow m throw, resTransLiftCatch catch])+ (WriterT n t, [tell, listen, pass]) -> (WriterT n t, [resTransLiftTell m tell, resTransLiftListen m listen, resTransLiftPass m pass])+ (ContT t, [callcc]) -> (ContT t, [resTransLiftCallCC m callcc])++resTransLiftGet :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ +resTransLiftGet _ get = get++resTransLiftPut :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ+resTransLiftPut _ put = put++resTransLiftRdEnv :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ +resTransLiftRdEnv _ rdEnv = rdEnv++resTransLiftInEnv :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ+resTransLiftInEnv _ inEnv = inEnv++resTransLiftThrow :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ +resTransLiftThrow _ throw = throw++resTransLiftCatch :: NonProperMorphismExpQ -> NonProperMorphismExpQ+resTransLiftCatch catch = catch++resTransLiftMerge :: Monad -> NonProperMorphismExpQ+resTransLiftMerge _ = error "resTransLiftMerge: Cannot lift 'merge' through res transformer"++resTransLiftHalt :: Monad -> NonProperMorphismExpQ+resTransLiftHalt _ = error "resTransLiftHalt: Cannot lift 'halt' through res transformer"++resTransLiftLiftIO :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ +resTransLiftLiftIO m liftIO = [| $(resTransLift m) . $liftIO |]++resTransLiftTell :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ+resTransLiftTell _ tell = tell++resTransLiftListen :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ+resTransLiftListen _ listen = listen++resTransLiftPass :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ+resTransLiftPass _ pass = pass++resTransLiftCallCC :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ+resTransLiftCallCC _ callcc = callcc+++-}
RELEASE-NOTES view
@@ -1,3 +1,7 @@+0.0.2+-----+* Added support for the resumption monad transformer ResT+ 0.0.1 ----- * Added workaround to bug in TH's pretty-printer that causes ContT to output
+ examples/Res.mlab view
@@ -0,0 +1,1 @@+monad N = ResT K + StateT(Int) Store