git.iko.soy/typeable/ether
on master help sign in
Improve TH generator
ac918fcIndex Int
src/Control/Ether/TH.hs+58−21
compare with master
unifiedsplit
@@ -1,44 +1,81 @@
1{-# LANGUAGE TemplateHaskell #-}
1{-# LANGUAGE TemplateHaskell #-}
2module Control.Ether.TH
2module Control.Ether.TH
3− ( etherealReader
3+ ( ethereal
4+ , EtherealConfig (..)
5+ , defaultEtherealReaderConfig
4 ) where
6 ) where
5
7
6import qualified Language.Haskell.TH as TH
8import qualified Language.Haskell.TH as TH
7
9
8import Data.Proxy
10import Data.Proxy
11+import Data.Functor.Identity
9import Control.Ether.Core
12import Control.Ether.Core
10import Control.Monad.Ether.Reader
13import Control.Monad.Ether.Reader
11
14
12emptyDataDecl :: TH.Name -> TH.DecQ
15emptyDataDecl :: TH.Name -> TH.DecQ
13emptyDataDecl name = TH.dataD (return []) name [] [] []
16emptyDataDecl name = TH.dataD (return []) name [] [] []
14
17
15−etherealReader :: String -> String -> String -> TH.Name -> TH.DecsQ
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
16−etherealReader strTagName strRunName strAskName tyname = do
44+ strRunName strAskName) = do
45+ let effName = TH.mkName strEffName
17− let tagName = TH.mkName strTagName
46+ tagName = TH.mkName strTagName
18 tag = TH.conT tagName
47 tag = TH.conT tagName
48+ runTransName = TH.mkName strRunTransName
19 runName = TH.mkName strRunName
49 runName = TH.mkName strRunName
20 askName = TH.mkName strAskName
50 askName = TH.mkName strAskName
51+ effDecl <- TH.tySynD effName [] [t| MonadEtherReader $tag |]
21 tagDecl <- emptyDataDecl tagName
52 tagDecl <- emptyDataDecl tagName
22 [tagInst] <- [d| type instance EtherData $tag = $(TH.conT tyname) |]
53 [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) |]
23 runFunSig <- do
62 runFunSig <- do
24− mName <- TH.newName "m"
63+ (aBndr, a) <- tyVar "a"
25− aName <- TH.newName "a"
64+ TH.sigD runName
26− let m' = TH.varT mName
65+ $ TH.forallT [aBndr] (return [])
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' |]
66+ [t| EtherReaderT $tag Identity $a -> EtherData $tag -> $a |]
30− TH.sigD runName ty
31− runFunBody <-
67+ runFunBody <- funSimple runName
32− let body = [e| runEtherReaderT (Proxy :: Proxy $tag) |]
68+ [e| ((runIdentity.).) $(TH.varE runTransName) |]
33− in TH.funD runName [ TH.clause [] (TH.normalB body) [] ]
34 askFunSig <- do
69 askFunSig <- do
35− mName <- TH.newName "m"
70+ (mBndr, m) <- tyVar "m"
36− let m' = TH.varT mName
71+ TH.sigD askName
37− ty = TH.forallT [TH.PlainTV mName]
72+ $ TH.forallT [mBndr]
38− (sequence [ [t| MonadEtherReader $tag $m' |] ])
73+ (sequence [ [t| MonadEtherReader $tag $m |] ])
39− [t| $m' (EtherData $tag) |]
74+ [t| $m (EtherData $tag) |]
40− TH.sigD askName ty
41 askFunBody <-
75 askFunBody <-
42 let body = [e| etherAsk (Proxy :: Proxy $tag) |]
76 let body = [e| etherAsk (Proxy :: Proxy $tag) |]
43 in TH.funD askName [ TH.clause [] (TH.normalB body) [] ]
77 in TH.funD askName [ TH.clause [] (TH.normalB body) [] ]
78+ return [ effDecl, tagDecl, tagInst
79+ , runTransFunSig, runTransFunBody
44− return [ tagDecl, tagInst, runFunSig, runFunBody, askFunSig, askFunBody ]
80+ , runFunSig, runFunBody
81+ , askFunSig, askFunBody ]
test/Regression.hs+22−16
@@ -9,17 +9,13 @@ import Control.Ether.TH
9import Control.Monad.Ether.Reader
9import Control.Monad.Ether.Reader
10
10
11import Data.Proxy
11import Data.Proxy
12−import Data.Functor.Identity
13
12
14import Test.Tasty
13import Test.Tasty
15import Test.Tasty.QuickCheck
14import Test.Tasty.QuickCheck
16import Test.QuickCheck.Function
15import Test.QuickCheck.Function
17
16
18−etherealReader "AmountTag" "runAmountT" "askAmount" ''Int
17+ethereal (defaultEtherealReaderConfig ''Int "Amount")
19−type MonadAmount = MonadEtherReader AmountTag
18+ethereal (defaultEtherealReaderConfig ''Integer "Count")
20−
21−etherealReader "CountTag" "runCountT" "askCount" ''Integer
22−type MonadCount = MonadEtherReader CountTag
23
19
24main :: IO ()
20main :: IO ()
25main = defaultMain suite
21main = defaultMain suite
@@ -33,28 +29,38 @@ suite = testGroup "Ether"
33 ]
29 ]
34
30
35layeredLocalLeft, layeredLocalRight
31layeredLocalLeft, layeredLocalRight
36− :: Fun (Int, Integer) Integer -> Fun Integer Integer -> Int -> Integer -> Property
32+ :: Fun (Int, Integer) Integer
33+ -> Fun Integer Integer
34+ -> Int -> Integer -> Property
37
35
38−layeredLocalLeft k f a1 a2 = property (direct == indirect)
36+layeredLocalLeft k f a1 a2 = property (direct == run indirect)
39 where
37 where
40− run = runIdentity . flip runAmountT a1 . flip runCountT a2
38+ run = flip runAmount a1 . flip runCountT a2
41− direct = apply k (fromIntegral a1, apply f a2)
42− indirect = run $ layeredLocalCore (apply f) (\n m -> apply k (fromIntegral n, m))
39+ (direct, indirect) = layeredLocalCore' k f a1 a2
43
40
44−layeredLocalRight k f a1 a2 = property (direct == indirect)
41+layeredLocalRight k f a1 a2 = property (direct == run indirect)
45 where
42 where
46− run = runIdentity . flip runCountT a2 . flip runAmountT a1
43+ run = flip runCount a2 . flip runAmountT a1
47− direct = apply k (fromIntegral a1, apply f a2)
48− indirect = run $ layeredLocalCore (apply f) (\n m -> apply k (fromIntegral n, m))
44+ (direct, indirect) = layeredLocalCore' k f a1 a2
49
45
50layeredLocalCore
46layeredLocalCore
51 :: (MonadAmount m, MonadCount m)
47 :: (MonadAmount m, MonadCount m)
52 => (Integer -> Integer) -> (Int -> Integer -> a) -> m a
48 => (Integer -> Integer) -> (Int -> Integer -> a) -> m a
53layeredLocalCore f g = do
49layeredLocalCore f g = do
54 n <- askAmount
50 n <- askAmount
55− m <- etherLocal (Proxy :: Proxy CountTag) f askCount
51+ m <- etherLocal (Proxy :: Proxy TagCount) f askCount
56 return (g n m)
52 return (g n m)
57
53
54+layeredLocalCore'
55+ :: (MonadAmount m, MonadCount m)
56+ => Fun (Int, Integer) Integer
57+ -> Fun Integer Integer
58+ -> Int -> Integer -> (Integer, m Integer)
59+layeredLocalCore' k f a1 a2 = (direct, indirect)
60+ where
61+ direct = apply k (fromIntegral a1, apply f a2)
62+ indirect = layeredLocalCore (apply f) (\n m -> apply k (fromIntegral n, m))
63+
58-- this should not compile
64-- this should not compile
59z :: IO Int
65z :: IO Int
60z = runAmountT (runAmountT (runAmountT askAmount 20) 10) 5
66z = runAmountT (runAmountT (runAmountT askAmount 20) 10) 5