git.iko.soy/typeable/ether
on master help sign in
TH generation for MonadEtherReader
commiteaa963510524e4b00c5b4982f64e6510ca68e765 authorIndex Int <vlad.z.4096@gmail.com> dateSat 6 Jun 2015, 02:04 (11 years ago) parent760a756
3 files changed+59−23
compare with master
unifiedsplit
ether.cabal+2 src/Control/Ether/TH.hs+44 test/Regression.hs+13−23
ether.cabal+2
@@ -15,12 +15,14 @@ cabal-version: >=1.22
1515library
1616
1717 exposed-modules: Control.Ether.Core
18+ Control.Ether.TH
1819 Control.Monad.Trans.Ether.Reader
1920 Control.Monad.Ether.Reader
2021
2122 build-depends: base >=4.8 && <4.9
2223 , transformers >=0.4.0.3
2324 , mtl >=2.2.1
25+ , template-haskell >=2.10
2426
2527 hs-source-dirs: src
2628 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 @@
11{-# LANGUAGE TypeFamilies #-}
22{-# LANGUAGE FlexibleContexts #-}
33{-# LANGUAGE EmptyDataDecls #-}
4+{-# LANGUAGE TemplateHaskell #-}
5+{-# LANGUAGE ConstraintKinds #-}
46module Main where
57
8+import Control.Ether.TH
69import Control.Monad.Ether.Reader
710
811import Data.Proxy
912import Data.Functor.Identity
10−import Control.Ether.Core
1113
1214import Test.Tasty
1315import Test.Tasty.QuickCheck
1416import Test.QuickCheck.Function
1517
18+etherealReader "AmountTag" "runAmountT" "askAmount" ''Int
19+type MonadAmount = MonadEtherReader AmountTag
20+
21+etherealReader "CountTag" "runCountT" "askCount" ''Integer
22+type MonadCount = MonadEtherReader CountTag
23+
1624main :: IO ()
1725main = defaultMain suite
1826
@@ -29,42 +37,24 @@ layeredLocalLeft, layeredLocalRight
2937
3038layeredLocalLeft k f a1 a2 = property (direct == indirect)
3139 where
32− run = runIdentity . flip runAmountT a1 . flip runAmount2T a2
40+ run = runIdentity . flip runAmountT a1 . flip runCountT a2
3341 direct = apply k (fromIntegral a1, apply f a2)
3442 indirect = run $ layeredLocalCore (apply f) (\n m -> apply k (fromIntegral n, m))
3543
3644layeredLocalRight k f a1 a2 = property (direct == indirect)
3745 where
38− run = runIdentity . flip runAmount2T a2 . flip runAmountT a1
46+ run = runIdentity . flip runCountT a2 . flip runAmountT a1
3947 direct = apply k (fromIntegral a1, apply f a2)
4048 indirect = run $ layeredLocalCore (apply f) (\n m -> apply k (fromIntegral n, m))
4149
4250layeredLocalCore
43− :: (MonadEtherReader AmountTag m, MonadEtherReader Amount2Tag m)
51+ :: (MonadAmount m, MonadCount m)
4452 => (Integer -> Integer) -> (Int -> Integer -> a) -> m a
4553layeredLocalCore f g = do
4654 n <- askAmount
47− m <- etherLocal (Proxy :: Proxy Amount2Tag) f askAmount2
55+ m <- etherLocal (Proxy :: Proxy CountTag) f askCount
4856 return (g n m)
4957
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−
6858-- this should not compile
6959z :: IO Int
7060z = runAmountT (runAmountT (runAmountT askAmount 20) 10) 5