@@ -23,13 +23,20 @@ tyVar name = do
23 let thType = TH.varT thName
23 let thType = TH.varT thName
24 return (TH.PlainTV thName, thType)
24 return (TH.PlainTV thName, thType)
26+proxySimple :: TH.Name -> TH.TypeQ -> TH.Q (TH.Dec, TH.Dec)
27+proxySimple name ty = do
28+ sig <- TH.sigD name [t| Proxy $ty |]
29+ val <- funSimple name [e| Proxy |]
26data EtherealConfig
32data EtherealConfig
27− = EtherealReaderConfig String String String String String String
33+ = EtherealReaderConfig String String String String String String String
29defaultEtherealReaderConfig :: String -> EtherealConfig
35defaultEtherealReaderConfig :: String -> EtherealConfig
30defaultEtherealReaderConfig name = EtherealReaderConfig
36defaultEtherealReaderConfig name = EtherealReaderConfig
31 ("Monad" ++ name)
37 ("Monad" ++ name)
32 ("Tag" ++ name)
38 ("Tag" ++ name)
33 ("run" ++ name ++ "T")
40 ("run" ++ name ++ "T")
34 ("run" ++ name)
41 ("run" ++ name)
35 ("ask" ++ name)
42 ("ask" ++ name)
@@ -38,17 +45,20 @@ defaultEtherealReaderConfig name = EtherealReaderConfig
38ethereal :: EtherealConfig -> TH.DecsQ
45ethereal :: EtherealConfig -> TH.DecsQ
40ethereal (EtherealReaderConfig
47ethereal (EtherealReaderConfig
41− strEffName strTagName strRunTransName
48+ strEffName strTagName strTagProxyName
49+ strRunTransName strRunName strAskName
42− strRunName strAskName strLocalName) = do
50+ strLocalName) = do
43 let effName = TH.mkName strEffName
51 let effName = TH.mkName strEffName
44 tagName = TH.mkName strTagName
52 tagName = TH.mkName strTagName
45 tag = TH.conT tagName
53 tag = TH.conT tagName
54+ tagProxyName = TH.mkName strTagProxyName
46 runTransName = TH.mkName strRunTransName
55 runTransName = TH.mkName strRunTransName
47 runName = TH.mkName strRunName
56 runName = TH.mkName strRunName
48 askName = TH.mkName strAskName
57 askName = TH.mkName strAskName
49 localName = TH.mkName strLocalName
58 localName = TH.mkName strLocalName
50 effDecl <- TH.tySynD effName [] [t| MonadEtherReader $tag |]
59 effDecl <- TH.tySynD effName [] [t| MonadEtherReader $tag |]
51 tagDecl <- emptyDataDecl tagName
60 tagDecl <- emptyDataDecl tagName
61+ (tagProxySig, tagProxyVal) <- proxySimple tagProxyName tag
52 runTransFunSig <- do
62 runTransFunSig <- do
53 (mBndr, m) <- tyVar "m"
63 (mBndr, m) <- tyVar "m"
54 (aBndr, a) <- tyVar "a"
64 (aBndr, a) <- tyVar "a"
@@ -84,6 +94,7 @@ ethereal (EtherealReaderConfig
84 [t| ($r -> $r) -> $m $a -> $m $a |]
94 [t| ($r -> $r) -> $m $a -> $m $a |]
85 localFunBody <- funSimple localName [e| etherLocal (Proxy :: Proxy $tag) |]
95 localFunBody <- funSimple localName [e| etherLocal (Proxy :: Proxy $tag) |]
86 return [ effDecl, tagDecl
96 return [ effDecl, tagDecl
97+ , tagProxySig, tagProxyVal
87 , runTransFunSig, runTransFunBody
98 , runTransFunSig, runTransFunBody
88 , runFunSig, runFunBody
99 , runFunSig, runFunBody
89 , askFunSig, askFunBody
100 , askFunSig, askFunBody