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