git.iko.soy/typeable/ether
on 0cff774 help sign in
typeable/ether/src/Control/Ether/TH.hs
90 lines 3.1 kB history raw
1{-# LANGUAGE TemplateHaskell #-}
2module Control.Ether.TH
3 ( ethereal
4 , EtherealConfig (..)
5 , defaultEtherealReaderConfig
6 ) where
8import qualified Language.Haskell.TH as TH
10import Data.Proxy
11import Data.Functor.Identity
12import Control.Monad.Ether.Reader
14emptyDataDecl :: TH.Name -> TH.DecQ
15emptyDataDecl name = TH.dataD (return []) name [] [] []
17funSimple :: TH.Name -> TH.ExpQ -> TH.DecQ
18funSimple name body = TH.funD name [ TH.clause [] (TH.normalB body) [] ]
20tyVar :: String -> TH.Q (TH.TyVarBndr, TH.TypeQ)
21tyVar name = do
22 thName <- TH.newName name
23 let thType = TH.varT thName
24 return (TH.PlainTV thName, thType)
26data EtherealConfig
27 = EtherealReaderConfig String String String String String String
29defaultEtherealReaderConfig :: String -> EtherealConfig
30defaultEtherealReaderConfig name = EtherealReaderConfig
31 ("Monad" ++ name)
32 ("Tag" ++ name)
33 ("run" ++ name ++ "T")
34 ("run" ++ name)
35 ("ask" ++ name)
36 ("local" ++ name)
38ethereal :: EtherealConfig -> TH.DecsQ
40ethereal (EtherealReaderConfig
41 strEffName strTagName strRunTransName
42 strRunName strAskName strLocalName) = do
43 let effName = TH.mkName strEffName
44 tagName = TH.mkName strTagName
45 tag = TH.conT tagName
46 runTransName = TH.mkName strRunTransName
47 runName = TH.mkName strRunName
48 askName = TH.mkName strAskName
49 localName = TH.mkName strLocalName
50 effDecl <- TH.tySynD effName [] [t| MonadEtherReader $tag |]
51 tagDecl <- emptyDataDecl tagName
52 runTransFunSig <- do
53 (mBndr, m) <- tyVar "m"
54 (aBndr, a) <- tyVar "a"
55 (rBndr, r) <- tyVar "r"
56 TH.sigD runTransName
57 $ TH.forallT [mBndr, aBndr, rBndr] (return [])
58 [t| EtherReaderT $tag $r $m $a -> $r -> $m $a |]
59 runTransFunBody <- funSimple runTransName
60 [e| runEtherReaderT (Proxy :: Proxy $tag) |]
61 runFunSig <- do
62 (aBndr, a) <- tyVar "a"
63 (rBndr, r) <- tyVar "r"
64 TH.sigD runName
65 $ TH.forallT [aBndr, rBndr] (return [])
66 [t| EtherReaderT $tag $r Identity $a -> $r -> $a |]
67 runFunBody <- funSimple runName
68 [e| ((runIdentity.).) $(TH.varE runTransName) |]
69 askFunSig <- do
70 (mBndr, m) <- tyVar "m"
71 (rBndr, r) <- tyVar "r"
72 TH.sigD askName
73 $ TH.forallT [mBndr, rBndr]
74 (sequence [ [t| MonadEtherReader $tag $r $m |] ])
75 [t| $m $r |]
76 askFunBody <- funSimple askName [e| etherAsk (Proxy :: Proxy $tag) |]
77 localFunSig <- do
78 (mBndr, m) <- tyVar "m"
79 (aBndr, a) <- tyVar "a"
80 (rBndr, r) <- tyVar "r"
81 TH.sigD localName
82 $ TH.forallT [mBndr, aBndr, rBndr]
83 (sequence [ [t| MonadEtherReader $tag $r $m |] ])
84 [t| ($r -> $r) -> $m $a -> $m $a |]
85 localFunBody <- funSimple localName [e| etherLocal (Proxy :: Proxy $tag) |]
86 return [ effDecl, tagDecl
87 , runTransFunSig, runTransFunBody
88 , runFunSig, runFunBody
89 , askFunSig, askFunBody
90 , localFunSig, localFunBody ]