diff --git a/FrontEnd.hs b/FrontEnd.hs
new file mode 100644
--- /dev/null
+++ b/FrontEnd.hs
@@ -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 ()
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/MLabCompileStub.hs b/MLabCompileStub.hs
new file mode 100644
--- /dev/null
+++ b/MLabCompileStub.hs
@@ -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 ()
diff --git a/MonadLab.cabal b/MonadLab.cabal
new file mode 100644
--- /dev/null
+++ b/MonadLab.cabal
@@ -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
+}
diff --git a/MonadLab/CommonTypes.hs b/MonadLab/CommonTypes.hs
new file mode 100644
--- /dev/null
+++ b/MonadLab/CommonTypes.hs
@@ -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
+
+
diff --git a/MonadLab/Cont.hs b/MonadLab/Cont.hs
new file mode 100644
--- /dev/null
+++ b/MonadLab/Cont.hs
@@ -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"
+
+
+
+
diff --git a/MonadLab/Declarations.hs b/MonadLab/Declarations.hs
new file mode 100644
--- /dev/null
+++ b/MonadLab/Declarations.hs
@@ -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))) |]
+
+
diff --git a/MonadLab/Env.hs b/MonadLab/Env.hs
new file mode 100644
--- /dev/null
+++ b/MonadLab/Env.hs
@@ -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) |]
+
diff --git a/MonadLab/Error.hs b/MonadLab/Error.hs
new file mode 100644
--- /dev/null
+++ b/MonadLab/Error.hs
@@ -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))) |]
+
diff --git a/MonadLab/Identity.hs b/MonadLab/Identity.hs
new file mode 100644
--- /dev/null
+++ b/MonadLab/Identity.hs
@@ -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 |]
diff --git a/MonadLab/Io.hs b/MonadLab/Io.hs
new file mode 100644
--- /dev/null
+++ b/MonadLab/Io.hs
@@ -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 |]
diff --git a/MonadLab/IoList.hs b/MonadLab/IoList.hs
new file mode 100644
--- /dev/null
+++ b/MonadLab/IoList.hs
@@ -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 |]
diff --git a/MonadLab/List.hs b/MonadLab/List.hs
new file mode 100644
--- /dev/null
+++ b/MonadLab/List.hs
@@ -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 |]
+
diff --git a/MonadLab/ListIo.hs b/MonadLab/ListIo.hs
new file mode 100644
--- /dev/null
+++ b/MonadLab/ListIo.hs
@@ -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 |]
diff --git a/MonadLab/MLabParser.hs b/MonadLab/MLabParser.hs
new file mode 100644
--- /dev/null
+++ b/MonadLab/MLabParser.hs
@@ -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)
+                  }
diff --git a/MonadLab/MonadLab.hs b/MonadLab/MonadLab.hs
new file mode 100644
--- /dev/null
+++ b/MonadLab/MonadLab.hs
@@ -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
+				
+----------------------------------------------------------
+
+
+
+
+
diff --git a/MonadLab/Reduction.hs b/MonadLab/Reduction.hs
new file mode 100644
--- /dev/null
+++ b/MonadLab/Reduction.hs
@@ -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"]]
+
+
+
+
+
+
diff --git a/MonadLab/Run.hs b/MonadLab/Run.hs
new file mode 100644
--- /dev/null
+++ b/MonadLab/Run.hs
@@ -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
+
diff --git a/MonadLab/State.hs b/MonadLab/State.hs
new file mode 100644
--- /dev/null
+++ b/MonadLab/State.hs
@@ -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) |]
+
+
+
+
+
+
+
diff --git a/MonadLab/TypeParser.hs b/MonadLab/TypeParser.hs
new file mode 100644
--- /dev/null
+++ b/MonadLab/TypeParser.hs
@@ -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
diff --git a/MonadLab/Writer.hs b/MonadLab/Writer.hs
new file mode 100644
--- /dev/null
+++ b/MonadLab/Writer.hs
@@ -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, ""))) |]
+
+
+
+
+
+
diff --git a/README b/README
new file mode 100644
--- /dev/null
+++ b/README
@@ -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.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,4 @@
+#! /usr/bin/env runhaskell
+
+import Distribution.Simple
+main = defaultMain
diff --git a/examples/InterpA.hs b/examples/InterpA.hs
new file mode 100644
--- /dev/null
+++ b/examples/InterpA.hs
@@ -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 = []
diff --git a/examples/InterpB.hs b/examples/InterpB.hs
new file mode 100644
--- /dev/null
+++ b/examples/InterpB.hs
@@ -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 = []
diff --git a/examples/InterpC.hs b/examples/InterpC.hs
new file mode 100644
--- /dev/null
+++ b/examples/InterpC.hs
@@ -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 = []
diff --git a/examples/InterpD.hs b/examples/InterpD.hs
new file mode 100644
--- /dev/null
+++ b/examples/InterpD.hs
@@ -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 = []
diff --git a/examples/InterpMonadA.mlab b/examples/InterpMonadA.mlab
new file mode 100644
--- /dev/null
+++ b/examples/InterpMonadA.mlab
@@ -0,0 +1,3 @@
+monad M       = EnvT(Environ) Env
+data  V       = Wrong | Num Int | Fun (V -> M V)
+type  Environ = [(String,V)]
diff --git a/examples/InterpMonadB.mlab b/examples/InterpMonadB.mlab
new file mode 100644
--- /dev/null
+++ b/examples/InterpMonadB.mlab
@@ -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
diff --git a/examples/InterpMonadC.mlab b/examples/InterpMonadC.mlab
new file mode 100644
--- /dev/null
+++ b/examples/InterpMonadC.mlab
@@ -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
diff --git a/examples/InterpMonadD.mlab b/examples/InterpMonadD.mlab
new file mode 100644
--- /dev/null
+++ b/examples/InterpMonadD.mlab
@@ -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
diff --git a/mlab.sh b/mlab.sh
new file mode 100644
--- /dev/null
+++ b/mlab.sh
@@ -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"