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