diff --git a/MLabCompileStub.hs b/MLabCompileStub.hs --- a/MLabCompileStub.hs +++ b/MLabCompileStub.hs @@ -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] diff --git a/MonadLab.cabal b/MonadLab.cabal --- a/MonadLab.cabal +++ b/MonadLab.cabal @@ -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 } diff --git a/MonadLab/CommonTypes.hs b/MonadLab/CommonTypes.hs --- a/MonadLab/CommonTypes.hs +++ b/MonadLab/CommonTypes.hs @@ -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 diff --git a/MonadLab/Declarations.hs b/MonadLab/Declarations.hs --- a/MonadLab/Declarations.hs +++ b/MonadLab/Declarations.hs @@ -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 diff --git a/MonadLab/MLabParser.hs b/MonadLab/MLabParser.hs --- a/MonadLab/MLabParser.hs +++ b/MonadLab/MLabParser.hs @@ -74,6 +74,13 @@ ; return (ContT (typeParser t)) } ) + <|> + try ( + do{ reserved lexer "ResT" + ; n <- identifier lexer + ; return (ResT n) + } + ) "layer spec" diff --git a/MonadLab/MonadLab.hs b/MonadLab/MonadLab.hs --- a/MonadLab/MonadLab.hs +++ b/MonadLab/MonadLab.hs @@ -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 ---------------------------------------------------------- diff --git a/MonadLab/Res.hs b/MonadLab/Res.hs new file mode 100644 --- /dev/null +++ b/MonadLab/Res.hs @@ -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 + + +-} diff --git a/RELEASE-NOTES b/RELEASE-NOTES --- a/RELEASE-NOTES +++ b/RELEASE-NOTES @@ -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 diff --git a/examples/Res.mlab b/examples/Res.mlab new file mode 100644 --- /dev/null +++ b/examples/Res.mlab @@ -0,0 +1,1 @@ +monad N = ResT K + StateT(Int) Store