git.iko.soy/typeable/ether
on master help sign in
TH generation for MonadEtherReader
eaa9635Index Int
ether.cabal+2
compare with master
unifiedsplit
@@ -15,12 +15,14 @@ cabal-version: >=1.22
15library
15library
16
16
17 exposed-modules: Control.Ether.Core
17 exposed-modules: Control.Ether.Core
18+ Control.Ether.TH
18 Control.Monad.Trans.Ether.Reader
19 Control.Monad.Trans.Ether.Reader
19 Control.Monad.Ether.Reader
20 Control.Monad.Ether.Reader
20
21
21 build-depends: base >=4.8 && <4.9
22 build-depends: base >=4.8 && <4.9
22 , transformers >=0.4.0.3
23 , transformers >=0.4.0.3
23 , mtl >=2.2.1
24 , mtl >=2.2.1
25+ , template-haskell >=2.10
24
26
25 hs-source-dirs: src
27 hs-source-dirs: src
26 default-language: Haskell2010
28 default-language: Haskell2010
src/Control/Ether/TH.hsnew file+44
@@ -0,0 +1,44 @@
1+{-# LANGUAGE TemplateHaskell #-}
2+module Control.Ether.TH
3+ ( etherealReader
4+ ) where
5+
6+import qualified Language.Haskell.TH as TH
7+
8+import Data.Proxy
9+import Control.Ether.Core
10+import Control.Monad.Ether.Reader
11+
12+emptyDataDecl :: TH.Name -> TH.DecQ
13+emptyDataDecl name = TH.dataD (return []) name [] [] []
14+
15+etherealReader :: String -> String -> String -> TH.Name -> TH.DecsQ
16+etherealReader strTagName strRunName strAskName tyname = do
17+ let tagName = TH.mkName strTagName
18+ tag = TH.conT tagName
19+ runName = TH.mkName strRunName
20+ askName = TH.mkName strAskName
21+ tagDecl <- emptyDataDecl tagName
22+ [tagInst] <- [d| type instance EtherData $tag = $(TH.conT tyname) |]
23+ runFunSig <- do
24+ mName <- TH.newName "m"
25+ aName <- TH.newName "a"
26+ let m' = TH.varT mName
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' |]
30+ TH.sigD runName ty
31+ runFunBody <-
32+ let body = [e| runEtherReaderT (Proxy :: Proxy $tag) |]
33+ in TH.funD runName [ TH.clause [] (TH.normalB body) [] ]
34+ askFunSig <- do
35+ mName <- TH.newName "m"
36+ let m' = TH.varT mName
37+ ty = TH.forallT [TH.PlainTV mName]
38+ (sequence [ [t| MonadEtherReader $tag $m' |] ])
39+ [t| $m' (EtherData $tag) |]
40+ TH.sigD askName ty
41+ askFunBody <-
42+ let body = [e| etherAsk (Proxy :: Proxy $tag) |]
43+ in TH.funD askName [ TH.clause [] (TH.normalB body) [] ]
44+ return [ tagDecl, tagInst, runFunSig, runFunBody, askFunSig, askFunBody ]
test/Regression.hs+13−23
@@ -1,18 +1,26 @@
1{-# LANGUAGE TypeFamilies #-}
1{-# LANGUAGE TypeFamilies #-}
2{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE EmptyDataDecls #-}
3{-# LANGUAGE EmptyDataDecls #-}
4+{-# LANGUAGE TemplateHaskell #-}
5+{-# LANGUAGE ConstraintKinds #-}
4module Main where
6module Main where
5
7
8+import Control.Ether.TH
6import Control.Monad.Ether.Reader
9import Control.Monad.Ether.Reader
7
10
8import Data.Proxy
11import Data.Proxy
9import Data.Functor.Identity
12import Data.Functor.Identity
10−import Control.Ether.Core
11
13
12import Test.Tasty
14import Test.Tasty
13import Test.Tasty.QuickCheck
15import Test.Tasty.QuickCheck
14import Test.QuickCheck.Function
16import Test.QuickCheck.Function
15
17
18+etherealReader "AmountTag" "runAmountT" "askAmount" ''Int
19+type MonadAmount = MonadEtherReader AmountTag
20+
21+etherealReader "CountTag" "runCountT" "askCount" ''Integer
22+type MonadCount = MonadEtherReader CountTag
23+
16main :: IO ()
24main :: IO ()
17main = defaultMain suite
25main = defaultMain suite
18
26
@@ -29,42 +37,24 @@ layeredLocalLeft, layeredLocalRight
29
37
30layeredLocalLeft k f a1 a2 = property (direct == indirect)
38layeredLocalLeft k f a1 a2 = property (direct == indirect)
31 where
39 where
32− run = runIdentity . flip runAmountT a1 . flip runAmount2T a2
40+ run = runIdentity . flip runAmountT a1 . flip runCountT a2
33 direct = apply k (fromIntegral a1, apply f a2)
41 direct = apply k (fromIntegral a1, apply f a2)
34 indirect = run $ layeredLocalCore (apply f) (\n m -> apply k (fromIntegral n, m))
42 indirect = run $ layeredLocalCore (apply f) (\n m -> apply k (fromIntegral n, m))
35
43
36layeredLocalRight k f a1 a2 = property (direct == indirect)
44layeredLocalRight k f a1 a2 = property (direct == indirect)
37 where
45 where
38− run = runIdentity . flip runAmount2T a2 . flip runAmountT a1
46+ run = runIdentity . flip runCountT a2 . flip runAmountT a1
39 direct = apply k (fromIntegral a1, apply f a2)
47 direct = apply k (fromIntegral a1, apply f a2)
40 indirect = run $ layeredLocalCore (apply f) (\n m -> apply k (fromIntegral n, m))
48 indirect = run $ layeredLocalCore (apply f) (\n m -> apply k (fromIntegral n, m))
41
49
42layeredLocalCore
50layeredLocalCore
43− :: (MonadEtherReader AmountTag m, MonadEtherReader Amount2Tag m)
51+ :: (MonadAmount m, MonadCount m)
44 => (Integer -> Integer) -> (Int -> Integer -> a) -> m a
52 => (Integer -> Integer) -> (Int -> Integer -> a) -> m a
45layeredLocalCore f g = do
53layeredLocalCore f g = do
46 n <- askAmount
54 n <- askAmount
47− m <- etherLocal (Proxy :: Proxy Amount2Tag) f askAmount2
55+ m <- etherLocal (Proxy :: Proxy CountTag) f askCount
48 return (g n m)
56 return (g n m)
49
57
50−data AmountTag
51−type instance EtherData AmountTag = Int
52−
53−runAmountT :: EtherReaderT AmountTag m a -> EtherData AmountTag -> m a
54−runAmountT = runEtherReaderT (Proxy :: Proxy AmountTag)
55−
56−askAmount :: MonadEtherReader AmountTag m => m (EtherData AmountTag)
57−askAmount = etherAsk (Proxy :: Proxy AmountTag)
58−
59−data Amount2Tag
60−type instance EtherData Amount2Tag = Integer
61−
62−runAmount2T :: EtherReaderT Amount2Tag m a -> EtherData Amount2Tag -> m a
63−runAmount2T = runEtherReaderT (Proxy :: Proxy Amount2Tag)
64−
65−askAmount2 :: MonadEtherReader Amount2Tag m => m (EtherData Amount2Tag)
66−askAmount2 = etherAsk (Proxy :: Proxy Amount2Tag)
67−
68-- this should not compile
58-- this should not compile
69z :: IO Int
59z :: IO Int
70z = runAmountT (runAmountT (runAmountT askAmount 20) 10) 5
60z = runAmountT (runAmountT (runAmountT askAmount 20) 10) 5