{-# LANGUAGE TemplateHaskell #-}

module MonadLab.Res (
   createResDecls
 ) where

import Prelude hiding (Monad)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import MonadLab.CommonTypes


createResDecls :: MonadName -> MonadName -> Q [Dec]
createResDecls resName baseName = sequenceQ [createResDataDecl resName baseName,
                                             createResMonadInstance resName baseName,
                                             createResStep resName
                                            ] >>= return . concat

--
-- FIXME: Surely there's got to be a way to use quasi-quoting here!
--

createResDataDecl :: MonadName -> MonadName -> Q [Dec]
createResDataDecl resName baseName = qNewName "a" >>= \ nameA ->
                                     dataD (cxt []) (mkName resName) [nameA]
                                           [normalC (mkName $ "Done" ++ resName)  [strictType notStrict (varT nameA)],
                                            normalC (mkName $ "Pause" ++ resName) [strictType notStrict (appT (conT (mkName baseName)) 
                                                                                                              (appT (conT (mkName resName)) 
                                                                                                                    (varT nameA)
                                                                                                              )
                                                                                                        )
                                                                                  ]
                                           ]
                                           []
                                        >>= \dec -> return [dec]

createResMonadInstance :: MonadName -> MonadName -> Q [Dec]
createResMonadInstance resName baseName = instanceD (cxt []) (appT (conT (mkName "Prelude.Monad")) (conT (mkName resName)))
                                          [funD (mkName "(>>=)") [qNewName "f" >>= \ nameF ->
                                                                  qNewName "v" >>= \ nameV ->
                                                                  clause [conP (mkName $ "Done" ++ resName) [varP nameV],
                                                                          varP nameF
                                                                         ]
                                                                         (normalB (appE (varE nameF) (varE nameV))) 
                                                                         [],
                                                                  
                                                                  qNewName "r" >>= \ nameR ->
                                                                  qNewName "f" >>= \ nameF ->
                                                                  qNewName "k" >>= \ nameK ->
                                                                  clause [conP (mkName $ "Pause" ++ resName) [varP nameR],
                                                                          varP nameF
                                                                         ]
                                                                         (normalB (appE (conE (mkName $ "Pause" ++ resName))
                                                                                        (infixApp
                                                                                            (varE nameR)
                                                                                            (varE (mkName ">>="))
                                                                                            (lamE [varP nameK]
                                                                                                  (appE (varE (mkName "return"))
                                                                                                        (infixApp (varE nameK)
                                                                                                                  (varE (mkName ">>="))
                                                                                                                  (varE nameF)
                                                                                                        )
                                                                                                  )
                                                                                             )
                                                                                        )
                                                                                   )
                                                                         )
                                                                         []
                                                                  ],
                                           funD (mkName "return") [clause [] 
                                                                          (normalB (conE (mkName $ "Done" ++ resName)))
                                                                          []
                                                                  ]
                                          ]
                                            >>= \ dec -> return [dec]

createResStep :: MonadName -> Q [Dec]
createResStep resName = qNewName "x" >>= \ nameX ->
                        funD (mkName $ "step" ++ resName)
                              [clause [varP nameX]
                                      (normalB (appE (conE (mkName $ "Pause" ++ resName))
                                                     (infixApp (varE nameX)
                                                               (varE (mkName ">>="))
                                                               (infixApp (varE (mkName "return"))
                                                                         (varE (mkName "."))
                                                                         (conE (mkName $ "Done" ++ resName))
                                                               )
                                                     )
                                               )
                                      )
                                      []
                              ]
                             >>= \ dec -> return [dec]

{-
resT :: Layer -> MonadTransformer
resT l@(ResT _) = \m -> ( resTransTypeCon m
		        , resTransReturn m
		        , resTransBind m
		        , resTransLayerNPM l : resTransLiftLayerNPMs m
		        , [| $(resTransLift m) . $(getBaseLift m) |]
		        )

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

resTransTypeCon :: Monad -> MonadTypeCon
resTransTypeCon m = getTypeCon m

resTransReturn :: Monad -> ReturnExpQ
resTransReturn m = getReturn m

resTransBind :: Monad -> BindExpQ
resTransBind m = getBind m

resTransLift :: Monad -> LiftExpQ
resTransLift _ = [| id |]

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

resTransLayerNPM :: Layer -> LayerNPM
resTransLayerNPM l = (l, [])


resTransLiftLayerNPMs :: Monad -> [LayerNPM]
resTransLiftLayerNPMs m = map (resTransLiftLayerNPM m) (getLayerNPMs m) 

	where	resTransLiftLayerNPM :: Monad -> LayerNPM -> LayerNPM
		resTransLiftLayerNPM m l = case l of
			(Io, [liftIO]) 		 	    -> (Io, [resTransLiftLiftIO m liftIO])
			(List, [merge, halt]) 		    -> (List, [resTransLiftMerge m, resTransLiftHalt m])
			(StateT n t, [get,put]) 	    -> (StateT n t, [resTransLiftGet m get, resTransLiftPut m put])
			(EnvT n t, [rdEnv,inEnv])   	    -> (EnvT n t, [resTransLiftRdEnv m rdEnv, resTransLiftInEnv m inEnv])
			(ErrorT n t, [throw,catch]) 	    -> (ErrorT n t, [resTransLiftThrow m throw, resTransLiftCatch catch])
			(WriterT n t, [tell, listen, pass]) -> (WriterT n t, [resTransLiftTell m tell, resTransLiftListen m listen, resTransLiftPass m pass])
			(ContT t, [callcc])		    -> (ContT t, [resTransLiftCallCC m callcc])

resTransLiftGet :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ 
resTransLiftGet _ get = get

resTransLiftPut :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ
resTransLiftPut _ put = put

resTransLiftRdEnv :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ 
resTransLiftRdEnv _ rdEnv = rdEnv

resTransLiftInEnv :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ
resTransLiftInEnv _ inEnv = inEnv

resTransLiftThrow :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ 
resTransLiftThrow _ throw = throw

resTransLiftCatch :: NonProperMorphismExpQ -> NonProperMorphismExpQ
resTransLiftCatch catch = catch

resTransLiftMerge :: Monad -> NonProperMorphismExpQ
resTransLiftMerge _ = error "resTransLiftMerge: Cannot lift 'merge' through res transformer"

resTransLiftHalt :: Monad -> NonProperMorphismExpQ
resTransLiftHalt _ = error "resTransLiftHalt: Cannot lift 'halt' through res transformer"

resTransLiftLiftIO :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ 
resTransLiftLiftIO m liftIO = [| $(resTransLift m) . $liftIO |]

resTransLiftTell :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ
resTransLiftTell _ tell = tell

resTransLiftListen :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ
resTransLiftListen _ listen = listen

resTransLiftPass :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ
resTransLiftPass _ pass = pass

resTransLiftCallCC :: Monad -> NonProperMorphismExpQ -> NonProperMorphismExpQ
resTransLiftCallCC _ callcc = callcc


-}