git.iko.soy/typeable/ether
on master help sign in
Improve TH generator
commit2e73b267b4d74bb3d0ec3fd05e2bbbd43f53083a authorIndex Int <vlad.z.4096@gmail.com> dateSat 6 Jun 2015, 19:30 (11 years ago) parent67f2cbf
3 files changed+28−20
compare with master
unifiedsplit
src/Control/Ether/TH.hs+17−7 src/Control/Monad/Ether/Reader.hs+2−1 test/Regression.hs+9−12
src/Control/Ether/TH.hs+17−7
@@ -24,7 +24,7 @@ tyVar name = do
2424 return (TH.PlainTV thName, thType)
2525
2626data EtherealConfig
27− = EtherealReaderConfig String String String String String
27+ = EtherealReaderConfig String String String String String String
2828
2929defaultEtherealReaderConfig :: String -> EtherealConfig
3030defaultEtherealReaderConfig name = EtherealReaderConfig
@@ -33,18 +33,20 @@ defaultEtherealReaderConfig name = EtherealReaderConfig
3333 ("run" ++ name ++ "T")
3434 ("run" ++ name)
3535 ("ask" ++ name)
36+ ("local" ++ name)
3637
3738ethereal :: EtherealConfig -> TH.DecsQ
3839
3940ethereal (EtherealReaderConfig
4041 strEffName strTagName strRunTransName
41− strRunName strAskName) = do
42+ strRunName strAskName strLocalName) = do
4243 let effName = TH.mkName strEffName
4344 tagName = TH.mkName strTagName
4445 tag = TH.conT tagName
4546 runTransName = TH.mkName strRunTransName
4647 runName = TH.mkName strRunName
4748 askName = TH.mkName strAskName
49+ localName = TH.mkName strLocalName
4850 effDecl <- TH.tySynD effName [] [t| MonadEtherReader $tag |]
4951 tagDecl <- emptyDataDecl tagName
5052 runTransFunSig <- do
@@ -66,15 +68,23 @@ ethereal (EtherealReaderConfig
6668 [e| ((runIdentity.).) $(TH.varE runTransName) |]
6769 askFunSig <- do
6870 (mBndr, m) <- tyVar "m"
69− (rBndr, r) <- tyVar "m"
71+ (rBndr, r) <- tyVar "r"
7072 TH.sigD askName
7173 $ TH.forallT [mBndr, rBndr]
7274 (sequence [ [t| MonadEtherReader $tag $r $m |] ])
7375 [t| $m $r |]
74− askFunBody <-
75− let body = [e| etherAsk (Proxy :: Proxy $tag) |]
76− in TH.funD askName [ TH.clause [] (TH.normalB body) [] ]
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) |]
7786 return [ effDecl, tagDecl
7887 , runTransFunSig, runTransFunBody
7988 , runFunSig, runFunBody
80− , askFunSig, askFunBody ]
89+ , askFunSig, askFunBody
90+ , localFunSig, localFunBody ]
src/Control/Monad/Ether/Reader.hs+2−1
@@ -5,6 +5,7 @@
55{-# LANGUAGE UndecidableInstances #-}
66{-# LANGUAGE DataKinds #-}
77{-# LANGUAGE TypeOperators #-}
8+{-# LANGUAGE FunctionalDependencies #-}
89{-# LANGUAGE GeneralizedNewtypeDeriving #-}
910module Control.Monad.Ether.Reader
1011 ( module Control.Monad.Ether.Reader
@@ -28,7 +29,7 @@ import qualified Control.Monad.Trans.State.Strict as Trans.Strict (StateT , m
2829import qualified Control.Monad.Trans.Writer.Lazy as Trans.Lazy (WriterT , mapWriterT)
2930import qualified Control.Monad.Trans.Writer.Strict as Trans.Strict (WriterT , mapWriterT)
3031
31−class MonadEther m => MonadEtherReader tag r m where
32+class MonadEther m => MonadEtherReader tag r m | m tag -> r where
3233
3334 etherLocal :: proxy tag -> (r -> r) -> m a -> m a
3435
test/Regression.hs+9−12
@@ -6,16 +6,13 @@
66module Main where
77
88import Control.Ether.TH
9−import Control.Monad.Ether.Reader
10−
11−import Data.Proxy
129
1310import Test.Tasty
1411import Test.Tasty.QuickCheck
1512import Test.QuickCheck.Function
1613
17−ethereal (defaultEtherealReaderConfig "Amount")
18−ethereal (defaultEtherealReaderConfig "Count")
14+ethereal (defaultEtherealReaderConfig "Reader1")
15+ethereal (defaultEtherealReaderConfig "Reader2")
1916
2017main :: IO ()
2118main = defaultMain suite
@@ -35,24 +32,24 @@ layeredLocalLeft, layeredLocalRight
3532
3633layeredLocalLeft k f a1 a2 = property (direct == run indirect)
3734 where
38− run = flip runAmount a1 . flip runCountT a2
35+ run = flip runReader1 a1 . flip runReader2T a2
3936 (direct, indirect) = layeredLocalCore' k f a1 a2
4037
4138layeredLocalRight k f a1 a2 = property (direct == run indirect)
4239 where
43− run = flip runCount a2 . flip runAmountT a1
40+ run = flip runReader2 a2 . flip runReader1T a1
4441 (direct, indirect) = layeredLocalCore' k f a1 a2
4542
4643layeredLocalCore
47− :: (MonadAmount Int m, MonadCount Integer m)
48− => (Integer -> Integer) -> (Int -> Integer -> a) -> m a
44+ :: (MonadReader1 r1 m, MonadReader2 r2 m)
45+ => (r2 -> r2) -> (r1 -> r2 -> a) -> m a
4946layeredLocalCore f g = do
50− n <- askAmount
51− m <- etherLocal (Proxy :: Proxy TagCount) f askCount
47+ n <- askReader1
48+ m <- localReader2 f askReader2
5249 return (g n m)
5350
5451layeredLocalCore'
55− :: (MonadAmount Int m, MonadCount Integer m)
52+ :: (MonadReader1 Int m, MonadReader2 Integer m)
5653 => Fun (Int, Integer) Integer
5754 -> Fun Integer Integer
5855 -> Int -> Integer -> (Integer, m Integer)