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