@@ -1,44 +1,81 @@
11{-# LANGUAGE TemplateHaskell #-}
22module Control.Ether.TH
3− ( etherealReader
3+ ( ethereal
4+ , EtherealConfig (..)
5+ , defaultEtherealReaderConfig
46 ) where
57
68import qualified Language.Haskell.TH as TH
79
810import Data.Proxy
11+import Data.Functor.Identity
912import Control.Ether.Core
1013import Control.Monad.Ether.Reader
1114
1215emptyDataDecl :: TH.Name -> TH.DecQ
1316emptyDataDecl name = TH.dataD (return []) name [] [] []
1417
15−etherealReader :: String -> String -> String -> TH.Name -> TH.DecsQ
16−etherealReader strTagName strRunName strAskName tyname = do
17− let tagName = TH.mkName strTagName
18+funSimple :: TH.Name -> TH.ExpQ -> TH.DecQ
19+funSimple name body = TH.funD name [ TH.clause [] (TH.normalB body) [] ]
20+
21+tyVar :: String -> TH.Q (TH.TyVarBndr, TH.TypeQ)
22+tyVar name = do
23+ thName <- TH.newName name
24+ let thType = TH.varT thName
25+ return (TH.PlainTV thName, thType)
26+
27+data EtherealConfig
28+ = EtherealReaderConfig TH.Name String String String String String
29+
30+defaultEtherealReaderConfig :: TH.Name -> String -> EtherealConfig
31+defaultEtherealReaderConfig tyname name = EtherealReaderConfig
32+ tyname
33+ ("Monad" ++ name)
34+ ("Tag" ++ name)
35+ ("run" ++ name ++ "T")
36+ ("run" ++ name)
37+ ("ask" ++ name)
38+
39+ethereal :: EtherealConfig -> TH.DecsQ
40+
41+ethereal (EtherealReaderConfig
42+ tyname strEffName
43+ strTagName strRunTransName
44+ strRunName strAskName) = do
45+ let effName = TH.mkName strEffName
46+ tagName = TH.mkName strTagName
1847 tag = TH.conT tagName
48+ runTransName = TH.mkName strRunTransName
1949 runName = TH.mkName strRunName
2050 askName = TH.mkName strAskName
51+ effDecl <- TH.tySynD effName [] [t| MonadEtherReader $tag |]
2152 tagDecl <- emptyDataDecl tagName
2253 [tagInst] <- [d| type instance EtherData $tag = $(TH.conT tyname) |]
54+ runTransFunSig <- do
55+ (mBndr, m) <- tyVar "m"
56+ (aBndr, a) <- tyVar "a"
57+ TH.sigD runTransName
58+ $ TH.forallT [mBndr, aBndr] (return [])
59+ [t| EtherReaderT $tag $m $a -> EtherData $tag -> $m $a |]
60+ runTransFunBody <- funSimple runTransName
61+ [e| runEtherReaderT (Proxy :: Proxy $tag) |]
2362 runFunSig <- do
24− mName <- TH.newName "m"
25− aName <- TH.newName "a"
26− let m' = TH.varT mName
27− a' = TH.varT aName
28− ty = TH.forallT [TH.PlainTV mName, TH.PlainTV aName] (return [])
29− [t| EtherReaderT $tag $m' $a' -> EtherData $tag -> $m' $a' |]
30− TH.sigD runName ty
31− runFunBody <-
32− let body = [e| runEtherReaderT (Proxy :: Proxy $tag) |]
33− in TH.funD runName [ TH.clause [] (TH.normalB body) [] ]
63+ (aBndr, a) <- tyVar "a"
64+ TH.sigD runName
65+ $ TH.forallT [aBndr] (return [])
66+ [t| EtherReaderT $tag Identity $a -> EtherData $tag -> $a |]
67+ runFunBody <- funSimple runName
68+ [e| ((runIdentity.).) $(TH.varE runTransName) |]
3469 askFunSig <- do
35− mName <- TH.newName "m"
36− let m' = TH.varT mName
37− ty = TH.forallT [TH.PlainTV mName]
38− (sequence [ [t| MonadEtherReader $tag $m' |] ])
39− [t| $m' (EtherData $tag) |]
40− TH.sigD askName ty
70+ (mBndr, m) <- tyVar "m"
71+ TH.sigD askName
72+ $ TH.forallT [mBndr]
73+ (sequence [ [t| MonadEtherReader $tag $m |] ])
74+ [t| $m (EtherData $tag) |]
4175 askFunBody <-
4276 let body = [e| etherAsk (Proxy :: Proxy $tag) |]
4377 in TH.funD askName [ TH.clause [] (TH.normalB body) [] ]
44− return [ tagDecl, tagInst, runFunSig, runFunBody, askFunSig, askFunBody ]
78+ return [ effDecl, tagDecl, tagInst
79+ , runTransFunSig, runTransFunBody
80+ , runFunSig, runFunBody
81+ , askFunSig, askFunBody ]