{-# 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
	{- | The Resumption layer.
	-}
	| ResT MonadName

type ErrorName		= String
type StateName		= String
type EnvName		= String
type WriterName		= String


data LayerType	= IoLayerType
		| ListLayerType
		| StateLayerType
		| EnvLayerType
		| ErrorLayerType
		| WriterLayerType
		| ContLayerType
		| ResLayerType
		deriving Eq

layerType :: Layer -> LayerType
layerType Io		= IoLayerType
layerType List		= ListLayerType
layerType (StateT _ _)	= StateLayerType
layerType (EnvT _ _)	= EnvLayerType
layerType (ErrorT _ _)	= ErrorLayerType
layerType (WriterT _ _)	= WriterLayerType
layerType (ContT _)	= ContLayerType
layerType (ResT _)      = ResLayerType

hasLayerType :: LayerType -> Layer -> Bool
hasLayerType lt l = layerType l == lt

----------------------------------------------

-- | The monad type.  Each component contains abstract
-- syntax of the Haskell code to implement the monad. 
-- Components are (code for the data type, code for the return, code for the
-- bind, code for the non-proper morphisms, code for the monad lifting)
type Monad = (MonadTypeCon, ReturnExpQ, BindExpQ, [LayerNPM], LiftExpQ)

-- | 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

-- | Code for a monad return
type ReturnExpQ			= ExpQ

-- | Code for a monad bind
type BindExpQ			= ExpQ

-- | Code for a monad lifting
type LiftExpQ			= ExpQ

-- | Code for a monad join
type JoinExpQ			= ExpQ

-- | Code for a monad run (evaluation)
type RunExpQ			= ExpQ

-- | Code for a monad non-proper morphism
type NonProperMorphismExpQ	= ExpQ

-- | 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 (conT $ mkName "(->)") t1) t2
              -- Note the weird use of prefix notation here; this is to
              -- work around a bug in TH's pretty printer