{-# 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.Res
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'
		              if isResumptive ls
		                 then do
		                      let (ResT resName):ls'' =  ls'
		     	              monadDecls              <- createMonadDecls resName (createMonad ls'')
			              runDecl                 <- createRunDecl ls'' resName (createRun ls'')
			              resDecls                <- createResDecls monadName resName
			              return $ monadDecls ++ [runDecl] ++ resDecls
		                 else do
		                      monadDecls <- createMonadDecls monadName (createMonad ls')
			              runDecl    <- createRunDecl ls' monadName (createRun ls')
			              return $ monadDecls ++ [runDecl]
	where rightAlignCont, leftAlignErrors :: [Layer] -> [Layer]
	      rightAlignCont  ls = filter (not . hasLayerType ContLayerType) ls ++ filter (hasLayerType ContLayerType) ls
	      leftAlignErrors ls = filter (hasLayerType ErrorLayerType) ls      ++ filter (not . hasLayerType ErrorLayerType) ls
	      isResumptive       = any (hasLayerType ResLayerType)


{-
mkResumption :: String -> String -> Q [Dec]
mkResumption resName innerName = do baseDecls <- recover createResBaseDecls (reify (mkName "Done") >> return [])
				    resDecl   <- createResDecl resName innerName
				    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 = [checkResT, checkIoList, checkIoRepeats, checkListRepeats, checkContRepeats, checkNameRepeats]

checkResT :: InsanityCheck
checkResT (l:ls) = if (any (hasLayerType ResLayerType) ls)
                        then error "ResT is only allowed as the leftmost layer"
                        else return ()
checkResT _      = return ()

checkIoList :: InsanityCheck
checkIoList ls = if (any (hasLayerType IoLayerType) ls) && (any (hasLayerType ListLayerType) ls) 
			then error "The Io and List Layers cannot be used together"
			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
				ResT _          -> ns
				
----------------------------------------------------------