packages feed

MonadLab (empty) → 0.0

raw patch · 32 files changed

+2281/−0 lines, 32 filesdep +basedep +haskell98dep +parsecsetup-changed

Dependencies added: base, haskell98, parsec, process, template-haskell

Files

+ FrontEnd.hs view
@@ -0,0 +1,14 @@+module Main where++import System+import System.Cmd+import Paths_MonadLab++main :: IO ()+main = do+          shellWrapper <- getDataFileName "mlab.sh"+          compileStub  <- getDataFileName "MLabCompileStub.hs"+          args         <- getArgs+          let sourceFile = if args /= [] then head args else error "Syntax: mlab [filename.mlab]"+          rawSystem "bash" [shellWrapper,compileStub,sourceFile]+          return ()
+ LICENSE view
@@ -0,0 +1,25 @@+Copyright (c) 2008, Pericles S. Kariotis
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright notice,
+      this list of conditions and the following disclaimer.
+    * Redistributions in binary form must reproduce the above copyright notice,
+      this list of conditions and the following disclaimer in the documentation
+      and/or other materials provided with the distribution.
+    * Neither the name of Pericles S. Kariotis nor the names of contributors
+      may be used to endorse or promote products derived from this software
+      without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ MLabCompileStub.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE TemplateHaskell #-}++module Main where++import System+import IO+import Data.List+import Data.Maybe+import Language.Haskell.TH+import MonadLab.CommonTypes+import MonadLab.MonadLab+import MonadLab.MLabParser++$(do+	specFileName      <- runIO $ getEnv "MLAB_FILENAME"+	let moduleName     = takeWhile (/= '.') specFileName+	let moduleFileName = moduleName ++ ".hs"++	-- FIXME: Begin duct tape+	-- TH's pretty-printer inserts some spurious qualifiers into its output, so+	-- we drop them here. I'm not sure I'm getting everything here, though!+        let dropAll :: String -> String -> String+            dropAll _ []         = []+            dropAll p s@(c:rest) = if p `isPrefixOf` s then+                                      let s' = drop (length p) s in dropAll p s'+                                   else+                                      c:(dropAll p rest)++        let munge = (dropAll "GHC.Base.") . (dropAll "GHC.List.") . (dropAll "GHC.Err.")+        -- FIXME: End duct tape++        let lines :: String -> [String]+            lines ('\n':cs) = lines cs+            lines []        = []+            lines cs        = let+                                 (line,rest) = span (/= '\n') cs+                              in+                                 line : lines rest++	specFileContents  <- runIO $ readFile specFileName+        let specFileLines  = lines specFileContents+	let monadDecls     = mapMaybe (\ line -> if "monad " `isPrefixOf` line then Just (mlabParser line) else Nothing) specFileLines+	let regularDecls   = concat $ intersperse "\n" $ filter (not . ("monad " `isPrefixOf`)) specFileLines++	monadDecs         <- mapM (uncurry mkMonad) monadDecls+	let monadDecls     = (munge . pprint) monadDecs++	runIO $ writeFile moduleFileName ("module " ++ moduleName ++ " where\n\n")+	runIO $ appendFile moduleFileName ("import qualified Data.Monoid\nimport qualified Data.Tuple\nimport qualified Data.Either\n")+	runIO $ appendFile moduleFileName "--\n-- Regular declarations\n--\n\n"+	runIO $ appendFile moduleFileName (regularDecls ++ "\n\n\n")+	runIO $ appendFile moduleFileName "--\n-- Monad declarations\n--\n\n"+	runIO $ appendFile moduleFileName (monadDecls ++ "\n")	++	runIO $ putStrLn ("Generated " ++ moduleFileName)++	return [])++main :: IO ()+main = return ()
+ MonadLab.cabal view
@@ -0,0 +1,44 @@+Name:          MonadLab+Version:       0.0+Synopsis:      Automatically generate layered monads+Category:      Monads++Stability:     experimental++Author:        Pericles Kariotis+Maintainer:    Adam Procter <amp269@mizzou.edu>+Homepage:      http://monadgarden.cs.missouri.edu/MonadLab+License:       BSD3+License-File:  LICENSE++Cabal-Version: >= 1.2++Build-type: Simple++Extra-Source-Files: examples/InterpA.hs, examples/InterpB.hs,+                    examples/InterpC.hs, examples/InterpD.hs,+                    examples/InterpMonadA.mlab, examples/InterpMonadB.mlab,+                    examples/InterpMonadC.mlab, examples/InterpMonadD.mlab,+		    README++Data-Files:         MLabCompileStub.hs, mlab.sh++Executable mlab {+  Main-is:         FrontEnd.hs+  Build-Depends:   base, haskell98, process+}++Library {+  Build-Depends:   base+  Build-Depends:   parsec+  Build-Depends:   template-haskell+  Exposed-Modules: MonadLab.MonadLab, MonadLab.CommonTypes,+                   MonadLab.MLabParser, MonadLab.TypeParser,+                   MonadLab.Reduction, MonadLab.Writer,+                   MonadLab.Identity, MonadLab.Io,+                   MonadLab.IoList, MonadLab.ListIo,+                   MonadLab.List, MonadLab.State,+                   MonadLab.Env, MonadLab.Error,+                   MonadLab.Cont, MonadLab.Run,+                   MonadLab.Declarations+}
+ MonadLab/CommonTypes.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE TemplateHaskell #-}++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++{- |+	The Layer data type.+	A monad is constructed from a list of layers.+	Each layer adds a corresponding set of non-proper+	morphisms (npms) for use in the monad.  The non-proper morphisms+	can be thought of as the interface of the monad or+	primitives in the constructed monad \"language\".+-} +data Layer+	{- |  The Io layer.+	      Adds an npm for IO operations.+	-}+	= Io+	{- |  The List layer.+	      Adds an npm for expressing nondeterministic computation.+	-}+	| List++	{- | The Error (or Exception) layer.+	     Adds npms for exception throwing/handling.+	-}+	| ErrorT ErrorName TypeQ++	{- | The State layer.+	     Adds npms for the manipulation of a mutable state.+	-}+	| StateT StateName TypeQ++	{- | The Environment layer.+	     Adds npms for reading/pre-setting an immutable environment.+	-}+	| EnvT EnvName TypeQ++	{- | The Writer layer.+	     Adds npms for the production/manipulation of sequenced output. +	-}+	| WriterT WriterName TypeQ++	{- | The Continuation layer.+	     f no List layer is included in the li , then the corresponding Layer transformers are composed Adds an npm for accessing current continuation to facilate+	     continuation passing style programming.+	-}+	| ContT TypeQ++type ErrorName		= String+type StateName		= String+type EnvName		= String+type WriterName		= String+++data LayerType	= IoLayerType+		| ListLayerType+		| StateLayerType+		| EnvLayerType+		| ErrorLayerType+		| WriterLayerType+		| ContLayerType+		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++hasLayerType :: LayerType -> Layer -> Bool+hasLayerType lt l = layerType l == lt++----------------------------------------------++-- | The monad type.  Each component contains abstract+-- syntax of the Haskell code to implement the monad. +type Monad = ( MonadTypeCon		-- ^ Code for the data type +	     , ReturnExpQ		-- ^ Code for the return+	     , BindExpQ			-- ^ Code for the bind+	     , [LayerNPM]		-- ^ Code for the non-proper morphisms+	     , LiftExpQ			-- ^ Code for base monad lifting+	     )++-- | The name of monad type constructor identifier+type MonadName		= String++-- | The monad type constructor type.    +type MonadTypeCon	= TypeQ -> TypeQ++-- Data types for monad code components.+-- All are type synonyms for ExpQ+type ReturnExpQ			= ExpQ	-- ^ Code for a monad return+type BindExpQ			= ExpQ	-- ^ Code for a monad bind+type LiftExpQ			= ExpQ  -- ^ Code for a monad lifting+type JoinExpQ			= ExpQ	-- ^ Code for a monad join+type RunExpQ			= ExpQ	-- ^ Code for a monad run (evaluation)+type NonProperMorphismExpQ	= ExpQ	-- ^ Code for a monad non-proper morphism++-- | Data type to hold a layer's non-proper morphisms+type LayerNPM		= (Layer , [NonProperMorphismExpQ])++-- | Monad transformer data type+type MonadTransformer	= Monad -> Monad+++-- | Type constructor accessor+getTypeCon :: Monad -> MonadTypeCon+getTypeCon (tc, _, _,_, _) = tc++-- | Return accessor+getReturn :: Monad -> ReturnExpQ+getReturn (_, ret, _, _, _) = ret++-- | Bind accessor+getBind :: Monad -> BindExpQ+getBind (_, _, bind, _, _) = bind ++-- | Layers accessor+getLayerNPMs :: Monad -> [LayerNPM]+getLayerNPMs (_, _, _, lnpms, _) = lnpms++-- | Base monad lifting accessor+getBaseLift :: Monad -> LiftExpQ+getBaseLift (_, _, _, _, baseLift) = baseLift++-- | Join accessor+getJoin :: Monad -> JoinExpQ+getJoin m = let return = getReturn m+		bind   = getBind m+	    in  [| \x -> $bind x (\a -> a) |]++----------------------------------------------++-- | Short hand for [t| Int |], [t| Bool |], and [t| String |]+int, bool , string :: TypeQ+int    = [t| Int |]+bool   = [t| Bool |]+string = [t| String |]++-- | Definition of composition function for use in TH expressions+composition	:: ExpQ+composition	= [| \f -> \g -> \x -> f (g x) |]++-- | Convenience function for expressing type @t -> t'@ in TH+arrow :: TypeQ -> TypeQ -> TypeQ+arrow t1 t2 = appT (appT arrowT t1) t2++
+ MonadLab/Cont.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE TemplateHaskell #-}++module MonadLab.Cont (+   contT+ ) where++import Prelude hiding (Monad)+import Language.Haskell.TH+import MonadLab.CommonTypes+++contT :: Layer -> MonadTransformer+contT l@(ContT t) = \m -> ( contTransTypeCon t m+			  , contTransReturn+			  , contTransBind+			  , contTransLayerNPM l : contTransLiftLayerNPMs m+			  , [| $(contTransLift m) . $(getBaseLift m) |]+			  )++--------------------------------++contTransTypeCon :: TypeQ -> Monad -> MonadTypeCon+contTransTypeCon ans m = let tc = getTypeCon m+			 in  \t -> arrow (arrow t (tc ans)) (tc ans) ++contTransReturn :: ReturnExpQ+contTransReturn = [| \v -> \k -> k v |]++contTransBind :: BindExpQ+contTransBind = [| \x -> \f -> \k -> x (\a -> f a k) |]++contTransCallCC :: NonProperMorphismExpQ+contTransCallCC = [| \f -> \k -> f (\a -> \_ -> k a) k |]++contTransLift :: Monad -> LiftExpQ+contTransLift m = [| $(getBind m) |]++--------------------------------++contTransLayerNPM :: Layer -> LayerNPM+contTransLayerNPM l = (l, [contTransCallCC])+++contTransLiftLayerNPMs :: Monad -> [LayerNPM]+contTransLiftLayerNPMs m = map (contTransLiftLayerNPM m) (getLayerNPMs m) ++	where	contTransLiftLayerNPM :: Monad -> LayerNPM -> LayerNPM+		contTransLiftLayerNPM m l = case l of+			(Io, [liftIO]) 		 	    -> (Io, [contTransLiftLiftIO m liftIO])+			(List, [merge, halt]) 		    -> (List, [contTransLiftMerge m, contTransLiftHalt m])+			(StateT n t, [get,put]) 	    -> (StateT n t, [contTransLiftGet m get, contTransLiftPut m put])+			(EnvT n t, [rdEnv,inEnv])   	    -> (EnvT n t, [contTransLiftRdEnv m rdEnv, contTransLiftInEnv m rdEnv inEnv])+			(ErrorT n t, [throw,catch]) 	    -> (ErrorT n t, [contTransLiftThrow m throw, contTransLiftCatch catch])+			(WriterT n t, [tell, listen, pass]) -> (WriterT n t, [stateTransLiftTell m tell, stateTransLiftListen m listen, stateTransLiftPass m pass])++contTransLiftGet :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ +contTransLiftGet m get = [| $(contTransLift m) $get |]++contTransLiftPut :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ+contTransLiftPut m put = [| $composition $(contTransLift m) $put |]++contTransLiftRdEnv :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ +contTransLiftRdEnv m rdEnv = [| $(contTransLift m) $rdEnv |]++contTransLiftInEnv :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ -> NonProperMorphismExpQ+contTransLiftInEnv m rdEnv inEnv = [| \r -> \c -> \k -> $(getBind m) $rdEnv (\o -> $inEnv r (c ($composition ($inEnv o) k))) |]++contTransLiftThrow :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ +contTransLiftThrow m throw = [| $composition $(contTransLift m) $throw |]++contTransLiftCatch :: NonProperMorphismExpQ -> NonProperMorphismExpQ+contTransLiftCatch catch = error "contTransLiftCatch:  Cannot lift 'catch' through cont transformer"++contTransLiftMerge :: Monad -> NonProperMorphismExpQ+contTransLiftMerge m = let newJoin     = [| \x -> $contTransBind x (\a -> a) |]+			   newBaseLift = [| $(contTransLift m) . $(getBaseLift m) |]+		       in  [| $composition $newJoin $newBaseLift |]++contTransLiftHalt :: Monad -> NonProperMorphismExpQ+contTransLiftHalt m = let newBaseLift = [| $(contTransLift m) . $(getBaseLift m) |]+		      in  [| $newBaseLift [] |]++contTransLiftLiftIO :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ +contTransLiftLiftIO m liftIO = [| $(contTransLift m) . $liftIO |]++stateTransLiftTell :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ+stateTransLiftTell m tell = error "contTransLiftTell: Cannot lift 'tell' through cont transformer"++stateTransLiftListen :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ+stateTransLiftListen m listen = error "contTransLiftListen: Cannot lift 'listen' through cont transformer"++stateTransLiftPass :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ+stateTransLiftPass m pass = error "contTransLiftPass: Cannot lift 'pass' through cont transformer"++++
+ MonadLab/Declarations.hs view
@@ -0,0 +1,265 @@+{-# LANGUAGE TemplateHaskell #-}++module MonadLab.Declarations (+   createMonadDecls, createRunDecl,+   createResBaseDecls, createResDecl,+   createReactiveBaseDecls, createReactiveDecl,+   createStepTypeSig, createStepDecl,+   createSignalTypeSig, createSignalDecl,+   createSignullTypeSig, createSignullDecl+ ) where++import Prelude hiding (Monad)+import qualified Prelude (Monad)+import Language.Haskell.TH+import MonadLab.CommonTypes+import MonadLab.Reduction+++-------------------------------+--General Declarations++mkValDecl :: String -> ExpQ -> DecQ+mkValDecl name e = valD (varP $ mkName name) (normalB e) []+++createMonadDecls :: MonadName -> Monad -> Q [Dec]+createMonadDecls monadName m = do+			typeDecl	  <- createTypeDecl monadName m+			returnDecl	  <- createReturnDecl monadName m+			bindDecl	  <- createBindDecl monadName m+			monadInstanceDecl <- createMonadInstanceDecl monadName m+			npmDecls	  <- createNPMDecls monadName m+			return $ typeDecl : monadInstanceDecl : npmDecls++createTypeDecl :: MonadName -> Monad -> DecQ+createTypeDecl monadName m = let tc = getTypeCon m+				 a  = mkName "a"+				 deM  = mkName ("de" ++ monadName)+			     in  tc (varT a) >>= \t -> return $ NewtypeD [] (mkName monadName) [a] (RecC (mkName monadName) [(deM, NotStrict, t)]) []++++createMonadInstanceDecl :: MonadName -> Monad -> DecQ+createMonadInstanceDecl monadName m = instanceD (return []) (appT (conT $ mkName "Prelude.Monad") (conT $ mkName monadName)) [createReturnDecl monadName m, createBindDecl monadName m] ++createReturnDecl :: MonadName -> Monad -> DecQ+createReturnDecl monadName m = let conM   = conE (mkName monadName)+				   return = getReturn m+			       in  reduceM $ mkValDecl "return" [| $composition $conM $return |]++createBindDecl :: MonadName -> Monad -> DecQ+createBindDecl monadName m = let deM  = dyn ("de" ++ monadName)+				 conM = conE (mkName monadName)+				 bind = getBind m+			     in  reduceM $ mkValDecl ">>=" ([| \x -> \f -> $conM $ $bind ($deM x) ($composition $deM f) |])++---------------------------------------------++createRunDecl :: [Layer] -> MonadName -> RunExpQ -> DecQ+createRunDecl ls monadName run = let deM = dyn ("de" ++ monadName)+				 in  reduceM $ mkValDecl ("run" ++ monadName) [| $composition $run $deM |]++---------------------------------------------++createNPMDecls :: MonadName -> Monad -> Q [Dec]+createNPMDecls monadName m = let lnpms = getLayerNPMs m+			     in  sequence $ concatMap (createLayerNPMDecls monadName) lnpms++		where	createLayerNPMDecls :: MonadName -> LayerNPM -> [DecQ]+			createLayerNPMDecls monadName c@(Io, _)	 	 = createIoDecls monadName c+			createLayerNPMDecls monadName c@(List, _)	 = createListMonadDecls monadName c+			createLayerNPMDecls monadName c@(ErrorT _ _, _)  = createErrorDecls monadName c+			createLayerNPMDecls monadName c@(StateT _ _, _)  = createStateDecls monadName c+			createLayerNPMDecls monadName c@(EnvT _ _, _) 	 = createEnvDecls monadName c+			createLayerNPMDecls monadName c@(WriterT _ _, _) = createWriterDecls monadName c+			createLayerNPMDecls monadName c@(ContT _, _)	 = createContDecls monadName c++---------------------------------------------+--Basic Resumption Declarations++createResBaseDecls :: Q [Dec]+createResBaseDecls = [d|+			data Prelude.Monad m => ResT m a = Done a | Pause (m (ResT m a))++			instance Prelude.Monad m => Prelude.Monad (ResT m) where+				return v       = Done v+				Done  v >>= f  = f v+				Pause m >>= f  = Pause (m >>= \r -> return (r >>= f))+		     |]++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+								 | P (q, r -> m (ReactT q r m a))+				+				instance Prelude.Monad m => Prelude.Monad (ReactT q r m) where+					return         = D+					D v      >>= f = f v+					P (r, s) >>= f = P (r, \rsp -> (s rsp) >>= \m -> return (m >>= f))+			  |]+++createReactiveDecl :: MonadName -> TypeQ -> TypeQ -> MonadName -> DecQ+createReactiveDecl reactiveName reqT rspT innerName = tySynD (mkName reactiveName) [] (appsT [conT (mkName "ReactT"), reqT, rspT, conT (mkName innerName)])+					where appsT = foldl1 appT++createStepTypeSig :: MonadName -> MonadName -> DecQ+createStepTypeSig reactiveName innerName = do+					   a <- newName "a"+					   return $ SigD (mkName $ "step" ++ reactiveName) (ForallT [a] [] (AppT (AppT ArrowT (AppT (ConT (mkName innerName)) (VarT a))) (AppT (ConT (mkName reactiveName)) (VarT a))))++createStepDecl :: MonadName -> MonadName -> DecQ+createStepDecl reactiveName innerName = do+					x <- newName "x"+					mkValDecl ("step" ++ reactiveName) (return $ LamE [VarP x] (AppE (ConE (mkName "P")) (TupE [ConE (mkName "Cont"), LamE [ConP (mkName "Ack") []] (InfixE (Just (VarE x)) (VarE (mkName ">>=")) (Just (InfixE (Just (VarE (mkName "return"))) (VarE (mkName ".")) (Just (ConE (mkName "D"))))))])))++createSignalTypeSig :: MonadName -> TypeQ -> TypeQ -> DecQ+createSignalTypeSig reactiveName reqT rspT = do+					req <- reqT+					rsp <- rspT+					return $ SigD (mkName ("signal" ++ reactiveName)) (AppT (AppT ArrowT req) (AppT (ConT (mkName reactiveName)) rsp)) +		+createSignalDecl :: MonadName -> DecQ+createSignalDecl reactiveName = mkValDecl ("signal" ++ reactiveName) [| \q -> $(conE (mkName "P")) (q, return . return) |]+++createSignullTypeSig :: MonadName -> TypeQ -> DecQ+createSignullTypeSig reactiveName reqT = do+					req <- reqT+					return $SigD (mkName ("signull" ++ reactiveName)) (AppT (AppT ArrowT req) (AppT (ConT (mkName reactiveName)) (ConT (mkName "()")))) +		+createSignullDecl :: MonadName -> DecQ+createSignullDecl reactiveName = mkValDecl ("signull" ++ reactiveName) [| \q -> $(conE (mkName "P")) (q, \_ -> return . return $ ()) |]+++-------------------------------+--State Declarations++createStateDecls :: MonadName -> LayerNPM -> [DecQ]+createStateDecls monadName (StateT stateName _, [get, put]) = [createGetDecl monadName stateName get, createPutDecl monadName stateName put, createUpdateDecl monadName stateName]++createGetDecl :: MonadName -> StateName -> NonProperMorphismExpQ -> DecQ+createGetDecl monadName stateName get = let conM = conE (mkName monadName)+					in  reduceM $ mkValDecl ("get" ++ stateName ++ monadName) [| $conM $get |]++createPutDecl :: MonadName -> StateName -> NonProperMorphismExpQ -> DecQ+createPutDecl monadName stateName put = let conM = conE (mkName monadName)+					in  reduceM $ mkValDecl ("put" ++ stateName ++ monadName) [| $composition $conM $put |]++createUpdateDecl :: MonadName -> StateName -> DecQ+createUpdateDecl monadName stateName = let get = dyn ("get" ++ stateName ++ monadName)+				           put = dyn ("put" ++ stateName ++ monadName)+				       in  mkValDecl ("update" ++ stateName ++ monadName) [| \f -> $get >>= \s -> $put (f s) >> $get |]+++-------------------------------+--Environment Declarations++createEnvDecls :: MonadName -> LayerNPM -> [DecQ]+createEnvDecls monadName (EnvT envName _, [rdEnv,inEnv]) = [createRdEnvDecl monadName envName rdEnv, createInEnvDecl monadName envName inEnv]++createRdEnvDecl :: MonadName -> EnvName -> NonProperMorphismExpQ -> DecQ+createRdEnvDecl monadName envName rdEnv = reduceM $ mkValDecl ("rd" ++ envName ++ monadName) [| $(conE (mkName monadName)) $ $rdEnv |]++createInEnvDecl :: MonadName -> EnvName -> NonProperMorphismExpQ -> DecQ+createInEnvDecl monadName envName inEnv = let deM  = dyn ("de" ++ monadName)+					      conM = conE (mkName monadName)+					  in  reduceM $ mkValDecl ("in" ++ envName ++ monadName)  [| \r -> \m -> $conM $ $inEnv r ($deM m) |]+++-------------------------------+--Error Declarations++createErrorDecls :: MonadName -> LayerNPM -> [DecQ]+createErrorDecls monadName (ErrorT errorName _, [throw,catch]) = [createThrowDecl monadName errorName throw, createCatchDecl monadName errorName catch]++createThrowDecl :: MonadName -> ErrorName -> NonProperMorphismExpQ -> DecQ+createThrowDecl monadName errorName throw = let conM = conE (mkName monadName)+					    in  reduceM $ mkValDecl ("throw" ++ errorName ++ monadName) [| $composition $conM $throw |]++createCatchDecl :: MonadName -> ErrorName -> NonProperMorphismExpQ -> DecQ+createCatchDecl monadName errorName catch = let deM  = dyn ("de" ++ monadName)+						conM = conE (mkName monadName)+					    in  reduceM $ mkValDecl ("catch" ++ errorName ++ monadName)  [| \x -> \h -> $conM $ $catch ($deM x) ($composition $deM h) |]+++-------------------------------+--List Declarations++createListMonadDecls :: MonadName -> LayerNPM -> [DecQ]+createListMonadDecls monadName (List, [merge, halt])           = [createMergeDecl monadName merge, createHaltDecl monadName halt]+++createMergeDecl :: MonadName -> NonProperMorphismExpQ -> DecQ+createMergeDecl monadName merge = let deM  = dyn ("de" ++ monadName)+				      conM = conE (mkName monadName)+				  in  reduceM $ mkValDecl ("merge" ++ monadName) [| \xs -> $conM $ $merge (map $deM xs) |] ++createHaltDecl :: MonadName -> NonProperMorphismExpQ -> DecQ+createHaltDecl monadName halt = let conM = conE (mkName monadName)+				in  reduceM $ mkValDecl ("halt" ++ monadName) [| $conM $halt |] +++-------------------------------+--Io Declarations++createIoDecls :: MonadName -> LayerNPM -> [DecQ]+createIoDecls monadName (Io, [liftIO])           = [createLiftIODecl monadName liftIO]+++createLiftIODecl :: MonadName -> NonProperMorphismExpQ -> DecQ+createLiftIODecl monadName liftIO = let conM = conE (mkName monadName)+				    in  reduceM $ mkValDecl ("liftIO" ++ monadName) [| $conM . $liftIO |] +++-------------------------------+--Writer Declarations++createWriterDecls :: MonadName -> LayerNPM -> [DecQ]+createWriterDecls monadName (WriterT writerName _, [tell, listen, pass]) = [ createTellDecl monadName writerName tell+									   , createListenDecl monadName writerName listen+									   , createPassDecl monadName writerName pass+									   , createCensorDecl monadName writerName+									   ]++createTellDecl :: MonadName -> WriterName -> NonProperMorphismExpQ -> DecQ+createTellDecl monadName writerName tell = let conM = conE (mkName monadName)+					   in  reduceM $ mkValDecl ("tell" ++ writerName ++ monadName) [| $composition $conM $tell |]++createListenDecl :: MonadName -> WriterName -> NonProperMorphismExpQ -> DecQ+createListenDecl monadName writerName listen = let deM  = dyn ("de" ++ monadName)+						   conM = conE (mkName monadName)+					       in  reduceM $ mkValDecl ("listen" ++ writerName ++ monadName)  [| \m -> $conM ( $listen ($deM m) ) |]++createPassDecl :: MonadName -> WriterName -> NonProperMorphismExpQ -> DecQ+createPassDecl monadName writerName pass = let deM  = dyn ("de" ++ monadName)+					       conM = conE (mkName monadName)+					   in  reduceM $ mkValDecl ("pass" ++ writerName ++ monadName)  [| \m -> $conM ( $pass ($deM m) ) |]++createCensorDecl :: MonadName -> WriterName -> DecQ+createCensorDecl monadName writerName = let pass = varE (mkName ("pass" ++ writerName ++ monadName))+					in  reduceM $ mkValDecl ("censor" ++ writerName ++ monadName) [| \f -> \m -> $pass (m >>= \a -> return (a, f)) |]+++++-------------------------------+--Continuation Declarations++createContDecls :: MonadName -> LayerNPM -> [DecQ]+createContDecls monadName (ContT _, [callcc]) = [createCallCCDecl monadName callcc]++createCallCCDecl :: MonadName -> NonProperMorphismExpQ -> DecQ+createCallCCDecl monadName callcc =let deM  = dyn ("de" ++ monadName)+				       conM = conE (mkName monadName)+				   in  reduceM $ mkValDecl ("callcc" ++ monadName) [| \h -> $conM $ $callcc ($deM . (\y -> h ($conM . y))) |]++
+ MonadLab/Env.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE TemplateHaskell #-}++module MonadLab.Env (+   envT+ ) where++import Prelude hiding (Monad)+import Language.Haskell.TH+import MonadLab.CommonTypes++envT :: Layer -> MonadTransformer+envT l@(EnvT name t0) = \m -> ( envTransTypeCon t0 m+			      , envTransReturn m+			      , envTransBind m+			      , envTransLayerNPM l m : envTransLiftLayerNPMs m+			      , [| $envTransLift . $(getBaseLift m) |]+			      )++--------------------------------++envTransTypeCon :: TypeQ -> Monad -> MonadTypeCon+envTransTypeCon r m = let tc = getTypeCon m+		      in  \t -> arrow r (tc t)++envTransReturn :: Monad -> ReturnExpQ+envTransReturn m = let return = getReturn m+		   in  [| \v -> \r -> $return v |]++envTransBind :: Monad -> BindExpQ+envTransBind m = let bind = getBind m+		 in  [| \m -> \f -> \r -> $bind (m r) (\v -> f v r) |]++envTransRdEnv :: Monad -> NonProperMorphismExpQ+envTransRdEnv m = let return = getReturn m+		  in  [| \r -> $return r |]++envTransInEnv :: NonProperMorphismExpQ+envTransInEnv = [| \r -> \m -> \_ -> m r |]++envTransLift :: LiftExpQ+envTransLift = [| \m -> \r -> m |]+++--------------------------------++envTransLayerNPM :: Layer -> Monad -> LayerNPM+envTransLayerNPM l m = (l, [envTransRdEnv m, envTransInEnv])++envTransLiftLayerNPMs :: Monad -> [LayerNPM]+envTransLiftLayerNPMs m = map (envTransLiftLayerNPM m) (getLayerNPMs m) ++	where	envTransLiftLayerNPM :: Monad -> LayerNPM -> LayerNPM+		envTransLiftLayerNPM m l = case l of+			(Io, [liftIO]) 		   	    -> (Io, [envTransLiftLiftIO liftIO])+			(List, [merge, halt]) 		    -> (List, [envTransLiftMerge m, envTransLiftHalt m])+			(StateT n t, [get,put]) 	    -> (StateT n t, [envTransLiftGet get, envTransLiftPut put])+			(EnvT n t, [rdEnv,inEnv])   	    -> (EnvT n t, [envTransLiftRdEnv rdEnv, envTransLiftInEnv inEnv])+			(ErrorT n t, [throw,catch]) 	    -> (ErrorT n t, [envTransLiftThrow throw, envTransLiftCatch catch])+			(WriterT n t, [tell, listen, pass]) -> (WriterT n t, [envTransLiftTell tell, envTransLiftListen m listen, envTransLiftPass m pass])+			(ContT t, [callcc])		    -> (ContT t, [envTransLiftCallCC m callcc])+++envTransLiftRdEnv :: NonProperMorphismExpQ -> NonProperMorphismExpQ +envTransLiftRdEnv rdEnv = [| $envTransLift $rdEnv |]++envTransLiftInEnv :: NonProperMorphismExpQ -> NonProperMorphismExpQ+envTransLiftInEnv inEnv = [| \r -> \m -> \r' -> $inEnv r (m r') |]++envTransLiftGet :: NonProperMorphismExpQ -> NonProperMorphismExpQ+envTransLiftGet get = [| $envTransLift $get |]++envTransLiftPut :: NonProperMorphismExpQ -> NonProperMorphismExpQ+envTransLiftPut put = [| $composition $envTransLift $put |] ++envTransLiftThrow :: NonProperMorphismExpQ -> NonProperMorphismExpQ +envTransLiftThrow throw = [| $composition $envTransLift $throw |]++envTransLiftCatch :: NonProperMorphismExpQ -> NonProperMorphismExpQ+envTransLiftCatch catch = [| \m -> \h -> \r -> $catch (m r) (\e -> h e r) |]++envTransLiftMerge :: Monad -> NonProperMorphismExpQ+envTransLiftMerge m = let newJoin     = [| \x -> $(envTransBind m) x (\a -> a) |]+			  newBaseLift = [| $envTransLift . $(getBaseLift m) |]+		      in  [| $composition $newJoin $newBaseLift |]++envTransLiftHalt :: Monad -> NonProperMorphismExpQ+envTransLiftHalt m = let newBaseLift = [| $envTransLift . $(getBaseLift m) |]+		     in  [| $newBaseLift [] |]++envTransLiftLiftIO :: NonProperMorphismExpQ -> NonProperMorphismExpQ +envTransLiftLiftIO liftIO = [| $envTransLift . $liftIO |]++envTransLiftTell :: NonProperMorphismExpQ -> NonProperMorphismExpQ+envTransLiftTell tell = [| $composition $envTransLift $tell |]++envTransLiftListen :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ+envTransLiftListen m listen = let return = getReturn m+				  bind   = getBind m+			      in  [| \m -> \r -> $listen (m r) |]+++envTransLiftPass :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ+envTransLiftPass m pass = let return = getReturn m+			      bind   = getBind m+			  in  [| \m -> \r -> $pass (m r) |]+++envTransLiftCallCC :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ+envTransLiftCallCC m callcc = [| \f -> \r -> $callcc (\k -> f (\a -> \r' -> k a) r) |]+
+ MonadLab/Error.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE TemplateHaskell #-}++module MonadLab.Error (+   errorT+ ) where++import Prelude hiding (Monad)+import Language.Haskell.TH+import MonadLab.CommonTypes++++errorT :: Layer -> MonadTransformer+errorT l@(ErrorT name t0) = \m -> ( errorTransTypeCon t0 m+				  , errorTransReturn m+				  , errorTransBind m+				  , errorTransLayerNPM l m : errorTransLiftLayerNPMs m+				  , [| $(errorTransLift m) . $(getBaseLift m) |]+				  )++----------------------------------------------++errorTransTypeCon :: TypeQ -> Monad -> MonadTypeCon+errorTransTypeCon e m = let tc = getTypeCon m+			    either a b = appT (appT (conT (mkName "Either")) a) b +			in  \t -> tc (either e t)++errorTransReturn :: Monad -> ReturnExpQ+errorTransReturn m = let return = getReturn m+		     in  [| \v -> $return (Right v) |]++errorTransBind :: Monad -> BindExpQ+errorTransBind m = let bind = getBind m+		       return = getReturn m	+		   in  [| \x -> \f -> $bind x (\a -> case a of+		   					Left l  -> $return (Left l)+							Right r -> f r )      +		       |]	++errorTransThrow :: Monad -> NonProperMorphismExpQ+errorTransThrow m = let return = getReturn m+		    in  [| \l -> $return (Left l) |]++errorTransCatch :: Monad -> NonProperMorphismExpQ+errorTransCatch m = let return = getReturn m+			bind   = getBind m+		    in  [| \x -> \h -> $bind x (\a -> case a of+		    					Left l  -> h l+							Right r -> $return (Right r) )+			|]++errorTransLift :: Monad -> LiftExpQ+errorTransLift m = let return = getReturn m+		       bind   = getBind m+		   in  [| \x -> $bind x (\a -> $return (Right a)) |]++----------------------------------------------++errorTransLayerNPM :: Layer -> Monad -> LayerNPM+errorTransLayerNPM l m = (l, [errorTransThrow m, errorTransCatch m])++errorTransLiftLayerNPMs :: Monad -> [LayerNPM]+errorTransLiftLayerNPMs m = map (errorTransLiftLayerNPM m) (getLayerNPMs m) ++	where	errorTransLiftLayerNPM :: Monad -> LayerNPM -> LayerNPM+		errorTransLiftLayerNPM m lnpms = case lnpms of+			(Io, [liftIO]) 		 	    -> (Io, [errorTransLiftLiftIO m liftIO])+			(List, [merge, halt]) 		    -> (List, [errorTransLiftMerge m, errorTransLiftHalt m])+			(StateT n t, [get,put]) 	    -> (StateT n t, [errorTransLiftGet m get, errorTransLiftPut m put])+			(EnvT n t, [rdEnv,inEnv])   	    -> (EnvT n t, [errorTransLiftRdEnv m rdEnv, errorTransLiftInEnv inEnv])+			(ErrorT n t, [throw,catch]) 	    -> (ErrorT n t, [errorTransLiftThrow m throw, errorTransLiftCatch catch])+			(WriterT n t, [tell, listen, pass]) -> (WriterT n t, [errorTransLiftTell m tell, errorTransLiftListen m listen, errorTransLiftPass m pass])+			(ContT t, [callcc])		    -> (ContT t, [errorTransLiftCallCC m callcc])++errorTransLiftGet :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ +errorTransLiftGet m get = [| $(errorTransLift m) $get |]++errorTransLiftPut :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ+errorTransLiftPut m put = [| $composition $(errorTransLift m) $put |]++errorTransLiftRdEnv :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ +errorTransLiftRdEnv m rdEnv = [| $(errorTransLift m) $rdEnv |]++errorTransLiftInEnv :: NonProperMorphismExpQ -> NonProperMorphismExpQ+errorTransLiftInEnv inEnv = inEnv++errorTransLiftThrow :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ +errorTransLiftThrow m throw = [| $composition $(errorTransLift m) $throw |]++errorTransLiftCatch :: NonProperMorphismExpQ -> NonProperMorphismExpQ+errorTransLiftCatch catch = catch++errorTransLiftMerge :: Monad -> NonProperMorphismExpQ+errorTransLiftMerge m = let newJoin     = [| \x -> $(errorTransBind m) x (\a -> a) |]+			    newBaseLift = [| $(errorTransLift m) . $(getBaseLift m) |]+			in  [| $composition $newJoin $newBaseLift |]++errorTransLiftHalt :: Monad -> NonProperMorphismExpQ+errorTransLiftHalt m = let newBaseLift = [| $(errorTransLift m) . $(getBaseLift m) |]+		       in  [| $newBaseLift [] |]++errorTransLiftLiftIO :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ +errorTransLiftLiftIO m liftIO = [| $(errorTransLift m) . $liftIO |]++errorTransLiftTell :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ+errorTransLiftTell m tell = [| $composition $(errorTransLift m) $tell |]++errorTransLiftListen :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ+errorTransLiftListen m listen = let return = getReturn m+				    bind   = getBind m+			        in  [| \m -> $bind ($listen m) (\(v, w) ->+						$return (case v of+							    Left  l -> Left l+							    Right r -> Right (r, w) )+				       	     )+				    |]+++errorTransLiftPass :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ+errorTransLiftPass m pass = let return = getReturn m+				bind   = getBind m+			    in  [| \m -> $pass $ $bind m (\v ->+			    			    $return (case v of+							        Left  l      -> (Left l, id)+							        Right (r, f) -> (Right r, f) )+				                  )+				|]+++errorTransLiftCallCC :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ+errorTransLiftCallCC m callcc = [| \f -> $callcc (\k -> f(\a -> k (Right a))) |]+
+ MonadLab/Identity.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE TemplateHaskell #-}++module MonadLab.Identity (+   identityMonad+ ) where++import Prelude hiding (Monad)+import Language.Haskell.TH+import MonadLab.CommonTypes++identityMonad :: Monad+identityMonad = (identityTypeCon , identityReturn , identityBind, [], identityBaseLift)++identityTypeCon :: MonadTypeCon+identityTypeCon = \t -> t ++identityReturn :: ReturnExpQ+identityReturn = [| \v -> v |]++identityBind :: BindExpQ+identityBind = [| \m -> \f -> f m |]++identityBaseLift :: LiftExpQ+identityBaseLift = [| id |]
+ MonadLab/Io.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE TemplateHaskell #-}++module MonadLab.Io (+   ioMonad+ ) where++import Prelude hiding (Monad)+import Language.Haskell.TH+import MonadLab.CommonTypes++ioMonad :: Monad+ioMonad = (ioTypeCon , ioReturn , ioBind, [(Io, [liftIO])], ioBaseLift)++ioTypeCon :: MonadTypeCon+ioTypeCon = \t -> appT (conT ''IO) t ++ioReturn :: ReturnExpQ+ioReturn = [| return |]++ioBind :: BindExpQ+ioBind = [| (>>=) |]++liftIO :: NonProperMorphismExpQ+liftIO = [| id |]++ioBaseLift :: LiftExpQ+ioBaseLift = [| id |]
+ MonadLab/IoList.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE TemplateHaskell #-}++module MonadLab.IoList (+   ioListMonad+ ) where++import Prelude hiding (Monad)+import qualified Control.Monad+import Language.Haskell.TH+import MonadLab.CommonTypes++ioListMonad :: Monad+ioListMonad = (ioListTypeCon , ioListReturn , ioListBind, [(Io, [liftIO]), (List, [merge])], ioListBaseLift)++ioListTypeCon :: MonadTypeCon+ioListTypeCon = \t -> appT (conT ''IO) (appT listT t) ++ioListReturn :: ReturnExpQ+ioListReturn = [| return . (\x -> [x]) |]++ioListBind :: BindExpQ+ioListBind = [| \m -> \f -> m >>= \vs ->+			    Control.Monad.mapM f vs >>= \vs's ->+			    return (concat vs's) |]++liftIO :: NonProperMorphismExpQ+liftIO = [| \io -> io >>= \v -> return [v] |]++merge :: NonProperMorphismExpQ+merge = [| (\m -> $ioListBind m id) . return |]++ioListBaseLift :: LiftExpQ+ioListBaseLift = [| return |]
+ MonadLab/List.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE TemplateHaskell #-}++module MonadLab.List (+   listMonad+ ) where++import Prelude hiding (Monad)+import Language.Haskell.TH+import MonadLab.CommonTypes++listMonad :: Monad+listMonad = (listTypeCon , listReturn , listBind, [(List, [merge, halt])], listBaseLift)++listTypeCon :: MonadTypeCon+listTypeCon = \t -> appT listT t++listReturn :: ReturnExpQ+listReturn = [| \v -> [v] |]++listBind :: BindExpQ+listBind = [| \m -> \f -> concatMap f m |]++merge :: NonProperMorphismExpQ+merge = [| concat |]++halt :: NonProperMorphismExpQ+halt = [| [] |]+		++listBaseLift :: LiftExpQ+listBaseLift = [| id |]+
+ MonadLab/ListIo.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE TemplateHaskell #-}++module MonadLab.ListIo (+   listIoMonad+ ) where++import Prelude hiding (Monad)+import Language.Haskell.TH+import MonadLab.CommonTypes++listIoMonad :: Monad+listIoMonad = (listIoTypeCon , listIoReturn , listIoBind, [(List, [merge]), (Io, [liftIO])], listIoBaseLift)++listIoTypeCon :: MonadTypeCon+listIoTypeCon = \t -> appT listT (appT (conT ''IO) t) ++listIoReturn :: ReturnExpQ+listIoReturn = [| \v -> [return v] |]++listIoBind :: BindExpQ+listIoBind = [| \m -> \f -> concatMap (>>= f) m |]++liftIO :: NonProperMorphismExpQ+liftIO = [| \io -> [io] |]++merge :: NonProperMorphismExpQ+merge = [| concat |]++listIoBaseLift :: LiftExpQ+listIoBaseLift = [| map return |]
+ MonadLab/MLabParser.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE TemplateHaskell #-}++module MonadLab.MLabParser (+   mlabParser+ ) where++import MonadLab.CommonTypes+import MonadLab.MonadLab+import Language.Haskell.TH+import MonadLab.TypeParser+import Text.ParserCombinators.Parsec hiding (State)+import Text.ParserCombinators.Parsec.Token+import Text.ParserCombinators.Parsec.Language++mlabParser :: String -> (MonadName,[Layer])+mlabParser s = case (parse monadSpecParser "" s) of+                  Left err -> error $ "MonadLab monad spec parser error " ++ show err+                  Right  r -> r ++lexer :: TokenParser ()+lexer  = makeTokenParser+	 (emptyDef { reservedNames   = ["monad"]+		   , reservedOpNames = ["=","+"]+		   });++layerSpecParser :: Parser Layer+layerSpecParser = try (+                    do{ reserved lexer "List"+                      ; return List+                      }+                  )+                  <|>+                  try (+                    do{ reserved lexer "Io"+                      ; return Io+                      }+                  )+		  <|>+		  try (+                    do{ reserved lexer "ErrorT"+                      ; t <- parens lexer (many (noneOf ")"))+                      ; n <- identifier lexer+                      ; return (ErrorT n (typeParser t))+                    }+                  )+                  <|>+                  try (+                    do{ reserved lexer "StateT"+                      ; t <- parens lexer (many (noneOf ")"))+                      ; n <- identifier lexer+                      ; return (StateT n (typeParser t))+                    }+                  )+                  <|>+                  try (+                    do{ reserved lexer "EnvT"+                      ; t <- parens lexer (many (noneOf ")"))+                      ; n <- identifier lexer+                      ; return (EnvT n (typeParser t))+                    }+                  )+                  <|>+                  try (+                    do{ reserved lexer "WriterT"+                      ; t <- parens lexer (many (noneOf ")"))+                      ; n <- identifier lexer+                      ; return (WriterT n (typeParser t))+                    }+                  )+                  <|>+                  try (+                    do{ reserved lexer "ContT"+                      ; t <- parens lexer (many (noneOf ")"))+                      ; return (ContT (typeParser t))+                    }+                  )+                  <?>+                  "layer spec"++monadSpecParser :: Parser (MonadName,[Layer])+monadSpecParser = do{ reserved lexer "monad"+                    ; mName <- identifier lexer+                    ; reservedOp lexer "="+                    ; layerSpecs <- sepBy layerSpecParser (reservedOp lexer "+")+                    ; eof+                    ; return (mName,layerSpecs)+                  }
+ MonadLab/MonadLab.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE TemplateHaskell #-}++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.Run+import MonadLab.Declarations+import MonadLab.TypeParser+++----------------------------------------+--Recursive Layers++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'+		     	      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+++mkResumption :: String -> String -> Q [Dec]+mkResumption resName innerName = do baseDecls <- recover createResBaseDecls (reify (mkName "Done") >> return [])+				    resDecl   <- createResDecl resName innerName+				    return $ baseDecls ++ [resDecl]+++mkReactive :: String -> TypeQ -> TypeQ -> String -> Q [Dec]+mkReactive reactiveName reqT rspT innerName = do baseDecls	<- recover createReactiveBaseDecls (reify (mkName "D") >> return [])+					         reactiveDecl	<- createReactiveDecl reactiveName reqT rspT innerName+					         stepTypeSig	<- createStepTypeSig reactiveName innerName+					         stepDecl	<- createStepDecl reactiveName innerName+					         signalTypeSig	<- createSignalTypeSig reactiveName reqT rspT+					         signalDecl	<- createSignalDecl reactiveName+					         signullTypeSig	<- createSignullTypeSig reactiveName reqT+					         signullDecl	<- createSignullDecl reactiveName+					         return $ baseDecls ++ [reactiveDecl, stepTypeSig, stepDecl, signalTypeSig, signalDecl, signullTypeSig, signullDecl]++++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 = [checkIoList, checkIoRepeats, checkListRepeats, checkContRepeats, checkNameRepeats]++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+				+----------------------------------------------------------+++++
+ MonadLab/Reduction.hs view
@@ -0,0 +1,124 @@+module MonadLab.Reduction (reduceM) where++import Control.Monad+import Language.Haskell.TH++type Env = [(Exp , Exp)]++class Reducible a where+	recurse	:: (Exp -> Exp) -> a -> a+	reduce	:: a -> a+	reduceM	:: Monad m => m a -> m a+	subst	:: Env -> a -> a++	reduce	   = recurse simpleReduction+	reduceM m  = m >>= \r -> return (reduce r)+	subst env  = recurse $ expSubst env+	++instance Reducible Exp where+	recurse f (VarE n)				= f $ VarE n+	recurse f (ConE n)				= f $ ConE n+	recurse f (LitE l)				= f $ LitE l --error "recurse: undefined on LitE"+	recurse f (AppE e1 e2)				= f $ AppE (recurse f e1) (recurse f e2)+	recurse f (InfixE (Just e1) opE (Just e2))	= f $ InfixE (Just $ recurse f e1) (recurse f opE) (Just $ recurse f e2)+	recurse f (InfixE (Just e1) opE Nothing)	= f $ InfixE (Just $ recurse f e1) (recurse f opE) Nothing+	recurse f (InfixE Nothing  opE (Just e2))	= f $ InfixE Nothing (recurse f opE) (Just $ recurse f e2)+	recurse f (InfixE Nothing opE Nothing)		= f $ InfixE Nothing (recurse f opE) Nothing --error "recurse: undefined on partial InfixE application"+	recurse f (LamE pats e)				= f $ LamE pats (recurse f e)+	recurse f (TupE es)				= f $ TupE $ map (recurse f) es+	recurse f (CondE _ _ _)				= error "recurse: undefined on CondE"+	recurse f (LetE decs e)				= f $ LetE (map (recurse f) decs) (recurse f e)+	recurse f (CaseE e matches)			= f $ CaseE (recurse f e) (map (recurse f) matches)+	recurse f (DoE _)				= error "recurse: undefined on DoE"+	recurse f (CompE _)				= error "recurse: undefined on CompE"+	recurse f (ArithSeqE _)				= error "recurse: undefined on ArithSeqE"+	recurse f (ListE es)				= f $ ListE $ map (recurse f) es+	recurse f (SigE _ _)				= error "recurse: undefined on SigE"+	recurse f (RecConE _ _)				= error "recurse: undefined on RecConE"+	recurse f (RecUpdE _ _)				= error "recurse: undefined on RecUpdE"++++instance Reducible Dec where+	recurse f (FunD _ _)				= error "recurse: undefined on FunD"+	recurse f (ValD pat body decs)			= ValD pat (recurse f body) (map (recurse f) decs)+	recurse f (DataD _ _ _ _ _)			= error "recurse: undefined on DataD"+	recurse f (NewtypeD _ _ _ _ _)			= error "recurse: undefined on NewtypeD"+	recurse f (TySynD _ _ _)			= error "recurse: undefined on TySynD"+	recurse f (ClassD _ _ _ _ _)			= error "recurse: undefined on ClassD"+	recurse f (InstanceD _ _ _)			= error "recurse: undefined on InstanceD"+	recurse f (SigD _ _)				= error "recurse: undefined on SigD"+	recurse f (ForeignD _)				= error "recurse: undefined on ForeignD"+	++instance Reducible Body where+	recurse f (GuardedB _)				= error "recurse: undefined on GuardedB"+	recurse f (NormalB e)				= NormalB (recurse f e)+++instance Reducible Match where+	recurse f (Match pat body decs)			= Match pat (recurse f body) (map (recurse f) decs)++++simpleReduction	:: Exp -> Exp+simpleReduction e@(VarE n)				= e+simpleReduction e@(ConE n)				= e+simpleReduction e@(LitE l)				= LitE l --error "simpleReduction: undefined on LitE"+simpleReduction e@(AppE e1 e2)				= case e1 of+								LamE (p:ps) e1'	  -> case bindPatterns p e2 of+											Just env  -> reduce $ LamE ps $ reduce $ subst env e1'+											Nothing   -> e+								otherwise	  -> e+								+simpleReduction e@(InfixE (Just e1) opE (Just e2))	= e+simpleReduction e@(InfixE _ _ _)			= e --error "simpleReduction: undefined on partial InfixE application"+simpleReduction e@(LamE pats e')			= case pats of+								[] 	  -> e'+								otherwise -> e+simpleReduction e@(TupE es)				= e+simpleReduction e@(CondE _ _ _)				= error "simpleReduction: undefined on CondE"+simpleReduction e@(LetE decs e')			= error "simpleReduction: undefined on LetE"+simpleReduction e@(CaseE e' matches)			= e+simpleReduction e@(DoE _)				= error "simpleReduction: undefined on DoE"+simpleReduction e@(CompE _)				= error "simpleReduction: undefined on CompE"+simpleReduction e@(ArithSeqE _)				= error "simpleReduction: undefined on ArithSeqE"+simpleReduction e@(ListE es)				= e+simpleReduction e@(SigE _ _)				= error "simpleReduction: undefined on SigE"+simpleReduction e@(RecConE _ _)				= error "simpleReduction: undefined on RecConE"+simpleReduction e@(RecUpdE _ _)				= error "simpleReduction: undefined on RecUpdE"+++expSubst	:: Env -> Exp -> Exp+expSubst env e						= case lookup e env of+								Just x  -> x+								Nothing -> e+++bindPatterns :: Pat -> Exp -> Maybe Env+bindPatterns (VarP n)         e  = Just [(VarE n, e)]+bindPatterns (WildP)          _  = Just []+bindPatterns (TupP ps) (TupE es) = if length ps /= length es+				   then Nothing+				   else do+				   	let tupEnvs = map2 bindPatterns ps es+					foldM addEnv [] tupEnvs+				   	where map2 f as bs = map (\(a,b) -> f a b) (zip as bs)+					      addEnv env        Nothing      = Nothing+					      addEnv env    (Just env')      = Just $ env ++ env'+bindPatterns _ _		 = Nothing++--test = bindPatterns p1 e1++var x = VarE $ mkName x+pat x = VarP $ mkName x++e1 = TupE [var "a", TupE [var "b", var "c"]]+p1 = TupP [pat "p1", TupP [pat "p2", pat "p3"]]++++++
+ MonadLab/Run.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE TemplateHaskell #-}++module MonadLab.Run (+   createRun+ ) where++import Language.Haskell.TH+import Control.Monad++import Prelude hiding (Monad)+import MonadLab.CommonTypes+++createRun :: [Layer] -> RunExpQ+createRun cs = do+		let listMonad  = any (hasLayerType ListLayerType) cs+		let contMonad  = any (hasLayerType ContLayerType) cs+		let ioMonad    = any (hasLayerType IoLayerType) cs+		paramNames    <- mkNames (numRunArgs cs)+		let params     = map varP paramNames+		let args       = map varE paramNames+		let extractExp = createExtractExp cs+		if not contMonad+			then do	if not listMonad+					then if not ioMonad+						then lamE params [| $extractExp $(appsE args) |]+						else lamE params [| $(appsE args) >>= \v -> return ($extractExp v) |]+					else	lamE params [| map $extractExp $(appsE args) |]+			else do	let k     = last args+				let args' = init args+				if not listMonad+					then do	let k' = [| $k . $extractExp |]+						if not ioMonad+						    then lamE params [| $(appsE (args' ++ [k'])) |]+						    else lamE params [| $(appsE (args' ++ [ [| return . $k' |] ])) |]+					else do let k' = [| (\x -> [x]) . $k . $extractExp |]+						lamE params [| $(appsE (args' ++ [k'])) |]+				++numRunArgs :: [Layer] -> Int+numRunArgs = (1 +) . length . filter (\l -> layerType l == StateLayerType+	 				    || layerType l == EnvLayerType+					    || layerType l == ContLayerType)++mkNames :: Int -> Q [Name]+mkNames i = sequence [ newName "q" | _ <- [1..i] ]++createExtractExp :: [Layer] -> ExpQ+createExtractExp = foldr augmentExtractExp [| id |]++	where	augmentExtractExp :: Layer -> ExpQ -> ExpQ+		augmentExtractExp Io		     e  = e+		augmentExtractExp List		     e  = e+		augmentExtractExp (StateT _ _)       e  = [| fst . $e |]+		augmentExtractExp (EnvT _ _)  	     e  = e+		augmentExtractExp (ErrorT n _)	     e  = let h = [| \v -> case v of+									Left  l -> error (n ++ " exception thrown")+									Right r -> r+							          |]+						           in  [| $h . $e |]+		augmentExtractExp (WriterT _ _)	     e  = [| fst . $e |]+		augmentExtractExp (ContT _)	     e  = e+
+ MonadLab/State.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE TemplateHaskell #-}++module MonadLab.State (+   stateT+ ) where++import Prelude hiding (Monad)+import Language.Haskell.TH+import MonadLab.CommonTypes+++stateT :: Layer -> MonadTransformer+stateT l@(StateT name t) = \m -> ( stateTransTypeCon t m+				 , stateTransReturn m+				 , stateTransBind m+				 , stateTransLayerNPM l m : stateTransLiftLayerNPMs m+				 , [| $(stateTransLift m) . $(getBaseLift m) |]+				 )++--------------------------------++stateTransTypeCon :: TypeQ -> Monad -> MonadTypeCon+stateTransTypeCon s m = let tc = getTypeCon m+			in  \t -> appT (appT arrowT s) (tc (appT (appT (tupleT 2) t) s))++stateTransReturn :: Monad -> ReturnExpQ+stateTransReturn m = let return = getReturn m+		     in  [| \v -> \s -> $return (v, s) |]++stateTransBind :: Monad -> BindExpQ+stateTransBind m = let bind = getBind m+		   in  [| \m -> \f -> \s0 -> $bind (m s0) (\(v, s1) -> f v s1) |]++stateTransGet :: Monad -> NonProperMorphismExpQ+stateTransGet m = let return = getReturn m+		  in  [| \s -> $return (s,s) |]++stateTransPut :: Monad -> NonProperMorphismExpQ+stateTransPut m = let return = getReturn m+		  in  [| \s -> \_ -> $return ((),s) |]++stateTransLift :: Monad -> LiftExpQ+stateTransLift m = let return = getReturn m+		       bind   = getBind m+		   in  [| \m -> \s -> $bind m (\v -> $return (v, s)) |]++--------------------------------++stateTransLayerNPM :: Layer -> Monad -> LayerNPM+stateTransLayerNPM l m = (l, [stateTransGet m, stateTransPut m])++stateTransLiftLayerNPMs :: Monad -> [LayerNPM]+stateTransLiftLayerNPMs m = map (stateTransLiftLayerNPM m) (getLayerNPMs m) ++	where	stateTransLiftLayerNPM :: Monad -> LayerNPM -> LayerNPM+		stateTransLiftLayerNPM m lnpms = case lnpms of+			(Io, [liftIO]) 		  	    -> (Io, [stateTransLiftLiftIO m liftIO])+			(List, [merge, halt]) 		    -> (List, [stateTransLiftMerge m, stateTransLiftHalt m])+			(StateT n t, [get,put]) 	    -> (StateT n t, [stateTransLiftGet m get, stateTransLiftPut m put])+			(EnvT n t, [rdEnv,inEnv])   	    -> (EnvT n t, [stateTransLiftRdEnv m rdEnv, stateTransLiftInEnv inEnv])+			(ErrorT n t, [throw,catch]) 	    -> (ErrorT n t, [stateTransLiftThrow m throw, stateTransLiftCatch catch])+			(WriterT n t, [tell, listen, pass]) -> (WriterT n t, [stateTransLiftTell m tell, stateTransLiftListen m listen, stateTransLiftPass m pass])+			(ContT t, [callcc])		    -> (ContT t, [stateTransLiftCallCC callcc])++stateTransLiftGet :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ+stateTransLiftGet m get = [| $(stateTransLift m) $get |]++stateTransLiftPut :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ+stateTransLiftPut m put = [| $composition $(stateTransLift m) $put |]++stateTransLiftRdEnv :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ +stateTransLiftRdEnv m rdEnv = [| $(stateTransLift m) $rdEnv |]++stateTransLiftInEnv :: NonProperMorphismExpQ -> NonProperMorphismExpQ+stateTransLiftInEnv inEnv = [| \r -> \m -> \s -> $inEnv r (m s) |]++stateTransLiftThrow :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ +stateTransLiftThrow m throw = [| $composition $(stateTransLift m) $throw |]++stateTransLiftCatch :: NonProperMorphismExpQ -> NonProperMorphismExpQ+stateTransLiftCatch catch = [| \x -> \h -> \s -> $catch (x s) (\e -> h e s) |]++stateTransLiftMerge :: Monad -> NonProperMorphismExpQ+stateTransLiftMerge m = let newJoin     = [| \x -> $(stateTransBind m) x (\a -> a) |]+			    newBaseLift = [| $(stateTransLift m) . $(getBaseLift m) |]+			in  [| $composition $newJoin $newBaseLift |]++stateTransLiftHalt :: Monad -> NonProperMorphismExpQ+stateTransLiftHalt m = let newBaseLift = [| $(stateTransLift m) . $(getBaseLift m) |]+		       in  [| $newBaseLift [] |]+++stateTransLiftLiftIO :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ +stateTransLiftLiftIO m liftIO = [| $(stateTransLift m) . $liftIO |]++stateTransLiftTell :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ+stateTransLiftTell m tell = [| $composition $(stateTransLift m) $tell |]++stateTransLiftListen :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ+stateTransLiftListen m listen = let return = getReturn m+				    bind   = getBind m+			        in  [| \m -> \s -> $bind ($listen (m s)) (\((a, s'), w) -> $return ((a, w), s')) |]++stateTransLiftPass :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ+stateTransLiftPass m pass = let return = getReturn m+				bind   = getBind m+			    in  [| \m -> \s -> $pass $ $bind (m s) (\((v, f), s') -> $return ((v, s'), f)) |]++stateTransLiftCallCC :: NonProperMorphismExpQ -> NonProperMorphismExpQ+stateTransLiftCallCC callcc = [| \f -> \s0 -> $callcc (\k -> f (\a -> \s1 -> k (a, s1)) s0) |]+++++++
+ MonadLab/TypeParser.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE TemplateHaskell #-}++module MonadLab.TypeParser (typeParser) where++import Data.List (nub)+import Language.Haskell.TH+import Text.ParserCombinators.Parsec hiding (token)+import Text.ParserCombinators.Parsec.Error++typeParser :: String -> Q Type+typeParser s = case (parse top "" s) of+			Left err  -> error "MonadBuilder Type Parser error"+			Right  r  -> return r ++top :: Parser Type+top = try (do+	     cxt <- context+	     token (string "=>")+	     t   <- htype+	     let ns = nub $ concatMap getVarTNames cxt ++ getVarTNames t+	     return $ ForallT ns cxt t )+  <|> try htype+  <?> "type"++context :: Parser Cxt+context = try (do +	    c <- clas+	    return [c] )+      <|> try (do+      	    token (char '(')+	    cs <- sepBy clas (token (char ','))+	    token (char ')')+	    return cs )+      <?> "context"+	    +clas :: Parser Type+clas = try (do+	      tcl <- token qtycls+	      tv  <- token tyvar+	      let tcl' = ConT (mkName tcl)+	          tv'  = VarT (mkName tv)+	      return $ AppT tcl' tv' )+   <|> try (do+   	      tcl <- token qtycls+	      token (char '(')+	      tv  <- token tyvar+	      ts  <- many1 atype+	      token (char ')')+	      let tcl' = ConT (mkName tcl)+	          tv'  = VarT (mkName tv)+     	      return $ AppT tcl' (foldl1 AppT (tv' : ts)) )+   <?> "type class constraint"++getVarTNames :: Type -> [Name]+getVarTNames (ForallT _ _ _) = error "getVarTNames: Cannot apply getVarTNames to ForallT variant"+getVarTNames (VarT n)	     = [n]+getVarTNames (ConT _)	     = []+getVarTNames (TupleT _)	     = []+getVarTNames ArrowT	     = []+getVarTNames ListT	     = []+getVarTNames (AppT t1 t2)    = nub $ getVarTNames t1 ++ getVarTNames t2+++htype :: Parser Type+htype = do+	ts <- sepBy1 btype (token (string "->"))+	return $ foldr1 arrowT ts+    <?> "type"+		where arrowT t1 t2 = AppT (AppT ArrowT t1) t2++btype :: Parser Type+btype = do+	ts <- many1 atype+	return $ foldl1 AppT ts+    <?> "type"+ ++atype :: Parser Type+atype = try (token gtycon)+    <|> try (do+    		n <- token tyvar+		return $ VarT (mkName n) )+    <|> try (do+    		token (char '(')+    		ts <- sepBy1 htype (token (char ','))+		token (char ')')+		if length ts > 1+			then return $ foldl AppT (TupleT (length ts)) ts+			else return $ head ts )+    <|> try (do+    		token (char '[')+		t <- htype+		token (char ']')+		return $ AppT ListT t )+    <?> "type"		+		+   ++gtycon :: Parser Type+gtycon = try (do+	 	n <- qtycon+		return $ ConT (mkName n) )+     <|> try (do+	 	token (char '(')+		token (char ')')+		return $ ConT ''() )+     <|> try (do+		token (string "[]")+		return ListT )+     <|> try (do+	 	token (char '(')+		token (string "->")+		token (char ')')+		return ArrowT )+     <|> try (do+	 	token (char '(')+		commas <- many1 (token (char ','))+		token (char ')')+		return $ TupleT (length commas + 1) )+     <?> "type constructor"+++modPrefix :: Parser String+modPrefix = do+		m <- modid+		char '.'+		return (m ++ ".")+	<?> ""++qtycon :: Parser String+qtycon = do+	 ms <- many (try modPrefix)+	 tc <- tycon+	 return (concat ms ++ tc)+     <?> ""++qtycls :: Parser String+qtycls = do+	 ms  <- many (try modPrefix)+	 tcl <- tycls+	 return (concat ms ++ tcl)+     <?> ""++token :: Parser a -> Parser a+token p = do+	  a <- p+	  spaces+	  return a+      <?> ""++modid, tycls, tycon, tyvar :: Parser String+modid = conid <?> "module identifier"+tycls = conid <?> "type class"+tycon = conid <?> "type constructor"+tyvar = varid <?> "type variable"++varid :: Parser String+varid = do+	c <- small+	cs <- many (small <|> large <|> digit <|> char '\'')+	return (c:cs)+	<?> "variable identifier"++conid :: Parser String+conid = do+	c <- large+	cs <- many (small <|> large <|> digit <|> char '\'')+	return (c:cs)+	<?> "constructor identifier"+	+small = char '_' <|> lower <?> ""+large = upper <?> ""+++++run x = runQ x >>= putStrLn . pprint
+ MonadLab/Writer.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE TemplateHaskell #-}++module MonadLab.Writer (+   writerT+ ) where++import Prelude hiding (Monad)+import Data.Monoid+import Language.Haskell.TH+import MonadLab.CommonTypes++writerT :: Layer -> MonadTransformer+writerT l@(WriterT name w) = \m -> ( writerTransTypeCon w m+				   , writerTransReturn m+				   , writerTransBind m+				   , writerTransLayerNPM l m : writerTransLiftLayerNPMs m+				   , [| $(writerTransLift m) . $(getBaseLift m) |]+				   )++--------------------------------++writerTransTypeCon :: TypeQ -> Monad -> MonadTypeCon+writerTransTypeCon w m = let tc = getTypeCon m+		         in  \t -> tc (appT (appT (tupleT 2) t) w)++writerTransReturn :: Monad -> ReturnExpQ+writerTransReturn m = let return = getReturn m+		      in  [| \v -> $return (v, mempty) |]++writerTransBind :: Monad -> BindExpQ+writerTransBind m = let return = getReturn m+			bind   = getBind m+		    in  [| \m -> \f -> $bind m (\ (a, w) -> $bind (f a) (\ (b, w') -> $return (b, w `mappend` w'))) |]++writerTransTell :: Monad -> NonProperMorphismExpQ+writerTransTell m = let return = getReturn m+		    in  [| \w -> $return ((), w) |]++writerTransListen :: Monad -> NonProperMorphismExpQ+writerTransListen m = let return = getReturn m+			  bind   = getBind m+		      in  [| \m -> $bind m (\(a, w) -> $return ((a, w), w)) |]++writerTransPass :: Monad -> NonProperMorphismExpQ+writerTransPass m = let return = getReturn m+			bind   = getBind m+		    in  [| \m -> $bind m (\((a, f), w) -> $return (a, f w)) |]++writerTransLift :: Monad -> LiftExpQ+writerTransLift m = let return = getReturn m+		        bind   = getBind m+		    in  [| \m -> $bind m (\a -> $return (a, "")) |]++--------------------------------++writerTransLayerNPM :: Layer -> Monad -> LayerNPM+writerTransLayerNPM l m = (l, [writerTransTell m, writerTransListen m, writerTransPass m])++writerTransLiftLayerNPMs :: Monad -> [LayerNPM]+writerTransLiftLayerNPMs m = map (writerTransLiftLayerNPM m) (getLayerNPMs m) ++	where	writerTransLiftLayerNPM :: Monad -> LayerNPM -> LayerNPM+		writerTransLiftLayerNPM m l = case l of+			(List, [merge, halt]) 		    -> (List, [writerTransLiftMerge m, writerTransLiftHalt m])+			(Io, [liftIO]) 		   	    -> (Io, [writerTransLiftLiftIO m liftIO])+			(StateT n t, [get,put])             -> (StateT n t, [writerTransLiftGet m get, writerTransLiftPut m put])+			(EnvT n t, [rdEnv,inEnv])   	    -> (EnvT n t, [writerTransLiftRdEnv m rdEnv, writerTransLiftInEnv inEnv])+			(ErrorT n t, [throw,catch]) 	    -> (ErrorT n t, [writerTransLiftThrow m throw, writerTransLiftCatch catch])+			(WriterT n t, [tell, listen, pass]) -> (WriterT n t, [writerTransLiftTell m tell, writerTransLiftListen m listen, writerTransLiftPass m pass])+			(ContT t, [callcc])		    -> (ContT t, [writerTransLiftCallCC m callcc])++writerTransLiftGet :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ +writerTransLiftGet m get = [| $(writerTransLift m) $get |]++writerTransLiftPut :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ+writerTransLiftPut m put = [| $composition $(writerTransLift m) $put |]++writerTransLiftRdEnv :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ +writerTransLiftRdEnv m rdEnv = [| $(writerTransLift m) $rdEnv |]++writerTransLiftInEnv :: NonProperMorphismExpQ -> NonProperMorphismExpQ+writerTransLiftInEnv inEnv = inEnv++writerTransLiftThrow :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ +writerTransLiftThrow m throw = [| $composition $(writerTransLift m) $throw |]++writerTransLiftCatch :: NonProperMorphismExpQ -> NonProperMorphismExpQ+writerTransLiftCatch catch = catch++writerTransLiftMerge :: Monad -> NonProperMorphismExpQ+writerTransLiftMerge m = let newJoin     = [| \x -> $(writerTransBind m) x (\a -> a) |]+			     newBaseLift = [| $(writerTransLift m) . $(getBaseLift m) |]+			 in  [| $composition $newJoin $newBaseLift |]++writerTransLiftHalt :: Monad -> NonProperMorphismExpQ+writerTransLiftHalt m = let newBaseLift = [| $(writerTransLift m) . $(getBaseLift m) |]+			in  [| $newBaseLift [] |]++writerTransLiftLiftIO :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ +writerTransLiftLiftIO m liftIO = [| $(writerTransLift m) . $liftIO |]++writerTransLiftTell :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ+writerTransLiftTell m tell = [| $composition $(writerTransLift m) $tell |]++writerTransLiftListen :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ+writerTransLiftListen m listen = let return = getReturn m+				     bind   = getBind m+				 in  [| \m -> $bind ($listen m) (\((v, w'), w) -> $return ((v, w), w')) |]++writerTransLiftPass :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ+writerTransLiftPass m pass = let return = getReturn m+				 bind   = getBind m+			     in  [| \m -> $pass $ $bind m (\((v, f), w') -> $return ((v, w'), f)) |]++writerTransLiftCallCC :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ+writerTransLiftCallCC m callcc = [| \f -> $callcc (\k -> f (\a -> k (a, ""))) |]++++++
+ README view
@@ -0,0 +1,25 @@+Building+--------+Requires GHC 6.8.3.++$ ./Setup.hs configure+$ ./Setup.hs build+$ sudo ./Setup.hs install++Running+-------+$ mlab [filename.mlab]		-- generates "filename.hs"++Documentation+-------------+Better documentation is forthcoming. Have a look at our Haskell Symposium+paper for more information: http://monadgarden.cs.missouri.edu/MonadLab . Some+examples are available in the "examples" directory.++Known bugs+----------+* The parser will fail if a monad specification contains nested parentheses,+  e.g. EnvT([(String,Int)]). You can work around this by declaring a type+  synonym for the type of the environment/state/etc.++* ContT is currently broken due to a bug in Template Haskell's pretty-printer.
+ Setup.hs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++import Distribution.Simple+main = defaultMain
+ examples/InterpA.hs view
@@ -0,0 +1,45 @@+module InterpA where++-- The interpreter monad+-- (Generated by MonadLab)+import InterpMonadA++-- Language syntax+type Name = String+data Term = Var Name | Con Int | Add Term Term+          | Lam Name Term | App Term Term++mkfun :: Name -> M V -> M V+mkfun x phi =+   rdEnvM >>= \ e ->+     return (Fun $ \ arg -> inEnvM ((x,arg):e) phi)++appEnv :: Name -> M V+appEnv x = rdEnvM >>= \ e ->+           case lookup x e of+              Nothing  -> return Wrong+              (Just v) -> return v++apply :: V -> V -> M V+apply (Fun k) a = k a+apply _ _       = return Wrong++-- The interpreter+add :: V -> V -> M V+add (Num i) (Num j) = return (Num (i+j))+add _ _             = return Wrong++interp :: Term -> M V+interp (Var x)   = appEnv x+interp (Con i)   = return (Num i)+interp (Add u v) = interp u >>= \ a ->+                   interp v >>= \ b ->+                      add a b+interp (Lam x v) = mkfun x (interp v)+interp (App t u) = interp t >>= \ f -> +                   interp u >>= \ a -> +                      apply f a+                      +test :: Term -> V+test t = runM (interp t) initEnv+         where initEnv = []
+ examples/InterpB.hs view
@@ -0,0 +1,84 @@+module InterpB where++-- The interpreter monad+-- (Generated by MonadLab)+import InterpMonadB++-- Language syntax+type Name = String+data Term = Var Name | Con Int | Add Term Term+          | Lam Name Term | App Term Term+          | LetRef Name Term Term | Deref Term+          | PutRef Term Term | Seq Term Term++mkfun :: Name -> M V -> M V+mkfun x phi =+   rdEnvM >>= \ e ->+     return (Fun $ \ arg -> inEnvM ((x,arg):e) phi)++appEnv :: Name -> M V+appEnv x = rdEnvM >>= \ e ->+           case lookup x e of+              Nothing  -> return Wrong+              (Just v) -> return v++getLoc :: Loc -> M V+getLoc l = getStoM >>= \s ->+           case lookup l s of+              Nothing  -> return Wrong+              (Just v) -> return v++putLoc :: Loc -> V -> M ()+putLoc l v = getStoM >>= \s -> putStoM $ (l,v):s++findFreeLoc :: M Loc+findFreeLoc = getStoM >>= \s -> return (ffl 0 s)+                  -- This is clearly inefficient, but it gets the idea across.+                  where ffl :: Loc -> Store -> Loc+                        ffl n sto = case lookup n sto of+                                        Nothing -> n+                                        _       -> ffl (n+1) sto++inExtEnvRef :: Name -> V -> M V -> M V+inExtEnvRef x v phi = findFreeLoc >>= \l ->+                      putLoc l v >>+                      rdEnvM >>= \ e ->+                        inEnvM ((x,(Ref l)):e) phi++apply :: V -> V -> M V+apply (Fun k) a = k a+apply _ _       = return Wrong++-- The interpreter+add :: V -> V -> M V+add (Num i) (Num j) = return (Num (i+j))+add _ _             = return Wrong++interp :: Term -> M V+interp (Var x)        = appEnv x+interp (Con i)        = return (Num i)+interp (Add u v)      = interp u >>= \ a ->+                        interp v >>= \ b ->+                           add a b+interp (Lam x v)      = mkfun x (interp v)+interp (App t u)      = interp t >>= \ f -> +                        interp u >>= \ a -> +                           apply f a+interp (LetRef x v t) = interp v >>= \val ->+                        inExtEnvRef x val (interp t)+interp (Deref t)      = interp t >>= \ref ->+                        case ref of+                           (Ref l) -> getLoc l+                           _       -> return Wrong+interp (PutRef r v)   = interp r >>= \ref ->+                        case ref of+                           (Ref l) -> interp v >>=+                                      putLoc l >>+                                         return Unit+                           _       -> return Wrong+interp (Seq t1 t2)    = interp t1 >> interp t2++test :: Term -> V+test t = runM (interp t) initEnv initSto+         where initEnv = []+               initSto = []
+ examples/InterpC.hs view
@@ -0,0 +1,95 @@+module InterpC where++-- The interpreter monad+-- (Generated by MonadLab)+import InterpMonadC++-- Language syntax+type Name = String+data Term = Var Name | Con Int | Add Term Term+          | Lam Name Term | App Term Term+          | LetRef Name Term Term | Deref Term+          | PutRef Term Term | Seq Term Term+          | Print Term++instance Show V where+   show Wrong   = "Wrong"+   show (Num n) = show n+   show (Fun _) = "<function>"+   show (Ref _) = "<reference>"+   show Unit    = "Unit"++mkfun :: Name -> M V -> M V+mkfun x phi =+   rdEnvM >>= \ e ->+     return (Fun $ \ arg -> inEnvM ((x,arg):e) phi)++appEnv :: Name -> M V+appEnv x = rdEnvM >>= \ e ->+           case lookup x e of+              Nothing  -> return Wrong+              (Just v) -> return v++getLoc :: Loc -> M V+getLoc l = getStoM >>= \s ->+           case lookup l s of+              Nothing  -> return Wrong+              (Just v) -> return v++putLoc :: Loc -> V -> M ()+putLoc l v = getStoM >>= \s -> putStoM $ (l,v):s++findFreeLoc :: M Loc+findFreeLoc = getStoM >>= \s -> return (ffl 0 s)+                  -- This is clearly inefficient, but it gets the idea across.+                  where ffl :: Loc -> Store -> Loc+                        ffl n sto = case lookup n sto of+                                        Nothing -> n+                                        _       -> ffl (n+1) sto++inExtEnvRef :: Name -> V -> M V -> M V+inExtEnvRef x v phi = findFreeLoc >>= \l ->+                      putLoc l v >>+                      rdEnvM >>= \ e ->+                        inEnvM ((x,(Ref l)):e) phi++apply :: V -> V -> M V+apply (Fun k) a = k a+apply _ _       = return Wrong++-- The interpreter+add :: V -> V -> M V+add (Num i) (Num j) = return (Num (i+j))+add _ _             = return Wrong++interp :: Term -> M V+interp (Var x)        = appEnv x+interp (Con i)        = return (Num i)+interp (Add u v)      = interp u >>= \ a ->+                        interp v >>= \ b ->+                           add a b+interp (Lam x v)      = mkfun x (interp v)+interp (App t u)      = interp t >>= \ f -> +                        interp u >>= \ a -> +                           apply f a+interp (LetRef x v t) = interp v >>= \val ->+                        inExtEnvRef x val (interp t)+interp (Deref t)      = interp t >>= \ref ->+                        case ref of+                           (Ref l) -> getLoc l+                           _       -> return Wrong+interp (PutRef r v)   = interp r >>= \ref ->+                        case ref of+                           (Ref l) -> interp v >>=+                                      putLoc l >>+                                         return Unit+                           _       -> return Wrong+interp (Seq t1 t2)    = interp t1 >> interp t2+interp (Print t)      = interp t >>= \ v ->+                        tellOutM (show v) >>+                           return Unit++test :: Term -> (V,String)+test t = runM (listenOutM $ interp t) initEnv initSto+         where initEnv = []+               initSto = []
+ examples/InterpD.hs view
@@ -0,0 +1,96 @@+module InterpD where++-- The interpreter monad+-- (Generated by MonadLab)+import InterpMonadD++-- Language syntax+type Name = String+data Term = Var Name | Con Int | Add Term Term+          | Lam Name Term | App Term Term+          | LetRef Name Term Term | Deref Term+          | PutRef Term Term | Seq Term Term+          | Print Term | Amb Term Term++instance Show V where+   show Wrong   = "Wrong"+   show (Num n) = show n+   show (Fun _) = "<function>"+   show (Ref _) = "<reference>"+   show Unit    = "Unit"++mkfun :: Name -> M V -> M V+mkfun x phi =+   rdEnvM >>= \ e ->+     return (Fun $ \ arg -> inEnvM ((x,arg):e) phi)++appEnv :: Name -> M V+appEnv x = rdEnvM >>= \ e ->+           case lookup x e of+              Nothing  -> return Wrong+              (Just v) -> return v++getLoc :: Loc -> M V+getLoc l = getStoM >>= \s ->+           case lookup l s of+              Nothing  -> return Wrong+              (Just v) -> return v++putLoc :: Loc -> V -> M ()+putLoc l v = getStoM >>= \s -> putStoM $ (l,v):s++findFreeLoc :: M Loc+findFreeLoc = getStoM >>= \s -> return (ffl 0 s)+                  -- This is clearly inefficient, but it gets the idea across.+                  where ffl :: Loc -> Store -> Loc+                        ffl n sto = case lookup n sto of+                                        Nothing -> n+                                        _       -> ffl (n+1) sto++inExtEnvRef :: Name -> V -> M V -> M V+inExtEnvRef x v phi = findFreeLoc >>= \l ->+                      putLoc l v >>+                      rdEnvM >>= \ e ->+                        inEnvM ((x,(Ref l)):e) phi++apply :: V -> V -> M V+apply (Fun k) a = k a+apply _ _       = return Wrong++-- The interpreter+add :: V -> V -> M V+add (Num i) (Num j) = return (Num (i+j))+add _ _             = return Wrong++interp :: Term -> M V+interp (Var x)        = appEnv x+interp (Con i)        = return (Num i)+interp (Add u v)      = interp u >>= \ a ->+                        interp v >>= \ b ->+                           add a b+interp (Lam x v)      = mkfun x (interp v)+interp (App t u)      = interp t >>= \ f -> +                        interp u >>= \ a -> +                           apply f a+interp (LetRef x v t) = interp v >>= \val ->+                        inExtEnvRef x val (interp t)+interp (Deref t)      = interp t >>= \ref ->+                        case ref of+                           (Ref l) -> getLoc l+                           _       -> return Wrong+interp (PutRef r v)   = interp r >>= \ref ->+                        case ref of+                           (Ref l) -> interp v >>=+                                      putLoc l >>+                                         return Unit+                           _       -> return Wrong+interp (Seq t1 t2)    = interp t1 >> interp t2+interp (Print t)      = interp t >>= \ v ->+                        tellOutM (show v) >>+                           return Unit+interp (Amb t1 t2)    = mergeM [interp t1,interp t2]++test :: Term -> [(V,String)]+test t = runM (listenOutM $ interp t) initEnv initSto+         where initEnv = []+               initSto = []
+ examples/InterpMonadA.mlab view
@@ -0,0 +1,3 @@+monad M       = EnvT(Environ) Env+data  V       = Wrong | Num Int | Fun (V -> M V)+type  Environ = [(String,V)]
+ examples/InterpMonadB.mlab view
@@ -0,0 +1,5 @@+monad M       = EnvT(Environ) Env + StateT(Store) Sto+data  V       = Wrong | Num Int | Fun (V -> M V) | Ref Loc | Unit+type  Environ = [(String,V)]+type  Store   = [(Loc,V)]+type  Loc     = Int
+ examples/InterpMonadC.mlab view
@@ -0,0 +1,6 @@+monad M       = EnvT(Environ) Env + StateT(Store) Sto + WriterT(String) Out+monad N       = StateT(String)+data  V       = Wrong | Num Int | Fun (V -> M V) | Ref Loc | Unit+type  Environ = [(String,V)]+type  Store   = [(Loc,V)]+type  Loc     = Int
+ examples/InterpMonadD.mlab view
@@ -0,0 +1,5 @@+monad M       = EnvT(Environ) Env + StateT(Store) Sto + WriterT(String) Out + List+data  V       = Wrong | Num Int | Fun (V -> M V) | Ref Loc | Unit+type  Environ = [(String,V)]+type  Store   = [(Loc,V)]+type  Loc     = Int
+ mlab.sh view
@@ -0,0 +1,12 @@+#! /bin/bash++if test $# -lt 2+    then+        echo "You must supply the path to the compile stub and a file name for the monad spec."+	exit 1+fi++COMPILE_STUB="$1"+export MLAB_FILENAME="$2"++runghc "$COMPILE_STUB"