git.iko.soy/typeable/ether
on master help sign in
Improve TH generator
2e73b26Index Int
src/Control/Ether/TH.hs+17−7
compare with master
unifiedsplit
@@ -24,7 +24,7 @@ tyVar name = do
24 return (TH.PlainTV thName, thType)
24 return (TH.PlainTV thName, thType)
25
25
26data EtherealConfig
26data EtherealConfig
27− = EtherealReaderConfig String String String String String
27+ = EtherealReaderConfig String String String String String String
28
28
29defaultEtherealReaderConfig :: String -> EtherealConfig
29defaultEtherealReaderConfig :: String -> EtherealConfig
30defaultEtherealReaderConfig name = EtherealReaderConfig
30defaultEtherealReaderConfig name = EtherealReaderConfig
@@ -33,18 +33,20 @@ defaultEtherealReaderConfig name = EtherealReaderConfig
33 ("run" ++ name ++ "T")
33 ("run" ++ name ++ "T")
34 ("run" ++ name)
34 ("run" ++ name)
35 ("ask" ++ name)
35 ("ask" ++ name)
36+ ("local" ++ name)
36
37
37ethereal :: EtherealConfig -> TH.DecsQ
38ethereal :: EtherealConfig -> TH.DecsQ
38
39
39ethereal (EtherealReaderConfig
40ethereal (EtherealReaderConfig
40 strEffName strTagName strRunTransName
41 strEffName strTagName strRunTransName
41− strRunName strAskName) = do
42+ strRunName strAskName strLocalName) = do
42 let effName = TH.mkName strEffName
43 let effName = TH.mkName strEffName
43 tagName = TH.mkName strTagName
44 tagName = TH.mkName strTagName
44 tag = TH.conT tagName
45 tag = TH.conT tagName
45 runTransName = TH.mkName strRunTransName
46 runTransName = TH.mkName strRunTransName
46 runName = TH.mkName strRunName
47 runName = TH.mkName strRunName
47 askName = TH.mkName strAskName
48 askName = TH.mkName strAskName
49+ localName = TH.mkName strLocalName
48 effDecl <- TH.tySynD effName [] [t| MonadEtherReader $tag |]
50 effDecl <- TH.tySynD effName [] [t| MonadEtherReader $tag |]
49 tagDecl <- emptyDataDecl tagName
51 tagDecl <- emptyDataDecl tagName
50 runTransFunSig <- do
52 runTransFunSig <- do
@@ -66,15 +68,23 @@ ethereal (EtherealReaderConfig
66 [e| ((runIdentity.).) $(TH.varE runTransName) |]
68 [e| ((runIdentity.).) $(TH.varE runTransName) |]
67 askFunSig <- do
69 askFunSig <- do
68 (mBndr, m) <- tyVar "m"
70 (mBndr, m) <- tyVar "m"
69− (rBndr, r) <- tyVar "m"
71+ (rBndr, r) <- tyVar "r"
70 TH.sigD askName
72 TH.sigD askName
71 $ TH.forallT [mBndr, rBndr]
73 $ TH.forallT [mBndr, rBndr]
72 (sequence [ [t| MonadEtherReader $tag $r $m |] ])
74 (sequence [ [t| MonadEtherReader $tag $r $m |] ])
73 [t| $m $r |]
75 [t| $m $r |]
74− askFunBody <-
76+ askFunBody <- funSimple askName [e| etherAsk (Proxy :: Proxy $tag) |]
75− let body = [e| etherAsk (Proxy :: Proxy $tag) |]
77+ localFunSig <- do
76− in TH.funD askName [ TH.clause [] (TH.normalB body) [] ]
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) |]
77 return [ effDecl, tagDecl
86 return [ effDecl, tagDecl
78 , runTransFunSig, runTransFunBody
87 , runTransFunSig, runTransFunBody
79 , runFunSig, runFunBody
88 , runFunSig, runFunBody
80− , askFunSig, askFunBody ]
89+ , askFunSig, askFunBody
90+ , localFunSig, localFunBody ]
src/Control/Monad/Ether/Reader.hs+2−1
@@ -5,6 +5,7 @@
5{-# LANGUAGE UndecidableInstances #-}
5{-# LANGUAGE UndecidableInstances #-}
6{-# LANGUAGE DataKinds #-}
6{-# LANGUAGE DataKinds #-}
7{-# LANGUAGE TypeOperators #-}
7{-# LANGUAGE TypeOperators #-}
8+{-# LANGUAGE FunctionalDependencies #-}
8{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9module Control.Monad.Ether.Reader
10module Control.Monad.Ether.Reader
10 ( module Control.Monad.Ether.Reader
11 ( module Control.Monad.Ether.Reader
@@ -28,7 +29,7 @@ import qualified Control.Monad.Trans.State.Strict as Trans.Strict (StateT , m
28import qualified Control.Monad.Trans.Writer.Lazy as Trans.Lazy (WriterT , mapWriterT)
29import qualified Control.Monad.Trans.Writer.Lazy as Trans.Lazy (WriterT , mapWriterT)
29import qualified Control.Monad.Trans.Writer.Strict as Trans.Strict (WriterT , mapWriterT)
30import qualified Control.Monad.Trans.Writer.Strict as Trans.Strict (WriterT , mapWriterT)
30
31
31−class MonadEther m => MonadEtherReader tag r m where
32+class MonadEther m => MonadEtherReader tag r m | m tag -> r where
32
33
33 etherLocal :: proxy tag -> (r -> r) -> m a -> m a
34 etherLocal :: proxy tag -> (r -> r) -> m a -> m a
34
35
test/Regression.hs+9−12
@@ -6,16 +6,13 @@
6module Main where
6module Main where
7
7
8import Control.Ether.TH
8import Control.Ether.TH
9−import Control.Monad.Ether.Reader
10−
11−import Data.Proxy
12
9
13import Test.Tasty
10import Test.Tasty
14import Test.Tasty.QuickCheck
11import Test.Tasty.QuickCheck
15import Test.QuickCheck.Function
12import Test.QuickCheck.Function
16
13
17−ethereal (defaultEtherealReaderConfig "Amount")
14+ethereal (defaultEtherealReaderConfig "Reader1")
18−ethereal (defaultEtherealReaderConfig "Count")
15+ethereal (defaultEtherealReaderConfig "Reader2")
19
16
20main :: IO ()
17main :: IO ()
21main = defaultMain suite
18main = defaultMain suite
@@ -35,24 +32,24 @@ layeredLocalLeft, layeredLocalRight
35
32
36layeredLocalLeft k f a1 a2 = property (direct == run indirect)
33layeredLocalLeft k f a1 a2 = property (direct == run indirect)
37 where
34 where
38− run = flip runAmount a1 . flip runCountT a2
35+ run = flip runReader1 a1 . flip runReader2T a2
39 (direct, indirect) = layeredLocalCore' k f a1 a2
36 (direct, indirect) = layeredLocalCore' k f a1 a2
40
37
41layeredLocalRight k f a1 a2 = property (direct == run indirect)
38layeredLocalRight k f a1 a2 = property (direct == run indirect)
42 where
39 where
43− run = flip runCount a2 . flip runAmountT a1
40+ run = flip runReader2 a2 . flip runReader1T a1
44 (direct, indirect) = layeredLocalCore' k f a1 a2
41 (direct, indirect) = layeredLocalCore' k f a1 a2
45
42
46layeredLocalCore
43layeredLocalCore
47− :: (MonadAmount Int m, MonadCount Integer m)
44+ :: (MonadReader1 r1 m, MonadReader2 r2 m)
48− => (Integer -> Integer) -> (Int -> Integer -> a) -> m a
45+ => (r2 -> r2) -> (r1 -> r2 -> a) -> m a
49layeredLocalCore f g = do
46layeredLocalCore f g = do
50− n <- askAmount
47+ n <- askReader1
51− m <- etherLocal (Proxy :: Proxy TagCount) f askCount
48+ m <- localReader2 f askReader2
52 return (g n m)
49 return (g n m)
53
50
54layeredLocalCore'
51layeredLocalCore'
55− :: (MonadAmount Int m, MonadCount Integer m)
52+ :: (MonadReader1 Int m, MonadReader2 Integer m)
56 => Fun (Int, Integer) Integer
53 => Fun (Int, Integer) Integer
57 -> Fun Integer Integer
54 -> Fun Integer Integer
58 -> Int -> Integer -> (Integer, m Integer)
55 -> Int -> Integer -> (Integer, m Integer)