7312823 · typeable/ether

ether.cabal+2

compare with master

unifiedsplit

@@ -98,6 +98,7 @@ test-suite regression

98 , tasty >=0.10

99 , tasty-quickcheck >=0.8

100 , QuickCheck >=2.8

101+ , ghc-prim >=0.3

101 , ether

102 , ether

102

103

103 main-is: Regression.hs

104 main-is: Regression.hs

@@ -126,4 +127,5 @@ test-suite regression

126 TemplateHaskell

127 TemplateHaskell

127 TypeFamilies

128 TypeFamilies

128 TypeOperators

129 TypeOperators

130+ QuasiQuotes

129 ghc-options: -Wall -fno-warn-missing-signatures

131 ghc-options: -Wall -fno-warn-missing-signatures

src/Control/Ether/TH.hs+9−36

@@ -1,46 +1,19 @@

1{-# LANGUAGE TemplateHaskell #-}

2{-# LANGUAGE MagicHash #-}

3−{-# LANGUAGE CPP #-}

4

3

5-- | Template Haskell utilities.

4-- | Template Haskell utilities.

6

5

7−module Control.Ether.TH

6+module Control.Ether.TH (tag) where

8− ( ethereal

9− ) where

10

7

11import qualified Language.Haskell.TH as TH

8import qualified Language.Haskell.TH as TH

9+import qualified Language.Haskell.TH.Quote as TH

12

10

13import GHC.Prim (Proxy#, proxy#)

11import GHC.Prim (Proxy#, proxy#)

14

12

15−emptyDataDecl :: TH.Name -> TH.DecQ

13+tag :: TH.QuasiQuoter

16−#if __GLASGOW_HASKELL__ < 800

14+tag = TH.QuasiQuoter proxyExpQ undefined undefined undefined

17−emptyDataDecl name = TH.dataD (return []) name [] [] []

15+ where

18−#else

16+ proxyExpQ :: String -> TH.ExpQ

19−emptyDataDecl name = TH.dataD (return []) name [] Nothing [] (return [])

17+ proxyExpQ nameStr =

20−#endif

18+ let ty = TH.conT (TH.mkName nameStr)

21−

19+ in [e| proxy# :: Proxy# $ty |]

22−funSimple :: TH.Name -> TH.ExpQ -> TH.DecQ

23−funSimple name body = TH.funD name [ TH.clause [] (TH.normalB body) [] ]

24−

25−proxySimple :: TH.Name -> TH.TypeQ -> TH.Q (TH.Dec, TH.Dec)

26−proxySimple name ty = do

27− sig <- TH.sigD name [t| Proxy# $ty |]

28− val <- funSimple name [e| proxy# |]

29− return (sig, val)

30−

31−-- |

32−-- Creates a tag and a value-level proxy for it.

33−--

34−-- @'ethereal' \"Foo\" \"foo\"@ generates the following code:

35−--

36−-- > data Foo

37−-- > foo :: Proxy Foo

38−-- > foo = Proxy

39−ethereal :: String -> String -> TH.DecsQ

40−ethereal strTagName strTagProxyName = do

41− let tagName = TH.mkName strTagName

42− tag = TH.conT tagName

43− tagProxyName = TH.mkName strTagProxyName

44− tagDecl <- emptyDataDecl tagName

45− (tagProxySig, tagProxyVal) <- proxySimple tagProxyName tag

46− return [tagDecl, tagProxySig, tagProxyVal]

src/Control/Monad/Ether.hs+1−1

@@ -11,4 +11,4 @@ import Control.Monad.Ether.Writer as X

11import Control.Monad.Ether.State as X

12import Control.Monad.Ether.Except as X

13import Control.Monad.Trans.Ether.Dispatch as X

14−import Control.Ether.TH as X (ethereal)

14+import Control.Ether.TH as X (tag)

src/Control/Monad/Ether/Implicit.hs−1

@@ -11,4 +11,3 @@ import Control.Monad.Ether.Implicit.Writer as X

11import Control.Monad.Ether.Implicit.State as X

12import Control.Monad.Ether.Implicit.Except as X

13import Control.Monad.Trans.Ether.Dispatch as X

14−import Control.Ether.TH as X (ethereal)

test/Regression/T1.hs+9−9

@@ -6,24 +6,24 @@ import Control.Ether.Abbr

6import Test.Tasty

7import Test.Tasty.QuickCheck

8

9−ethereal "Tag1" "tag1"

9+data Tag1

10−ethereal "Tag2" "tag2"

10+data Tag2

11

12testEther

13 :: Ether '[Tag1 --> String, Tag2 --> String] m

14 => m ((String, String), (String, String))

15testEther = do

16− s1 <- ask tag1

16+ s1 <- ask [tag|Tag1|]

17− s2 <- ask tag2

17+ s2 <- ask [tag|Tag2|]

18 let s1s2 = (s1, s2)

19− s1s2' <- local tag2 (map succ) $ do

19+ s1s2' <- local [tag|Tag2|] (map succ) $ do

20− s1' <- ask tag1

20+ s1' <- ask [tag|Tag1|]

21− s2' <- ask tag2

21+ s2' <- ask [tag|Tag2|]

22 return (s1', s2')

23 return (s1s2, s1s2')

24

25−runner1 s1 s2 = flip (runReader tag1) s1 . flip (runReaderT tag2) s2

25+runner1 s1 s2 = flip (runReader [tag|Tag1|]) s1 . flip (runReaderT [tag|Tag2|]) s2

26−runner2 s1 s2 = flip (runReader tag2) s2 . flip (runReaderT tag1) s1

26+runner2 s1 s2 = flip (runReader [tag|Tag2|]) s2 . flip (runReaderT [tag|Tag1|]) s1

27

28test1 :: TestTree

29test1 = testGroup "T1: Reader local environment"

test/Regression/T3.hs+13−13

@@ -9,8 +9,8 @@ import qualified Control.Monad.State as T

9import Test.Tasty

10import Test.Tasty.QuickCheck

11

12−ethereal "RTag" "rTag"

12+data RTag

13−ethereal "STag" "sTag"

13+data STag

14

15testMTL :: (T.MonadReader Int m, T.MonadState Int m) => m Int

16testMTL = do

@@ -22,21 +22,21 @@ testMTL = do

22testEther

23 :: Ether '[STag --> Int, STag <-> Int, RTag --> Int] m

24 => m (Int, Int, Int)

25−testEther = local rTag (*2) $ do

25+testEther = local [tag|RTag|] (*2) $ do

26− a_mul_b <- tagAttach sTag testMTL

26+ a_mul_b <- tagAttach [tag|STag|] testMTL

27− a_add_b <- get sTag

27+ a_add_b <- get [tag|STag|]

28− modify sTag negate

28+ modify [tag|STag|] negate

29− c <- ask rTag

29+ c <- ask [tag|RTag|]

30 return (a_mul_b, a_add_b, c)

31

32runner1 s r

33− = flip (runReader rTag) (negate r)

33+ = flip (runReader [tag|RTag|]) (negate r)

34− . flip (runReaderT sTag) r

34+ . flip (runReaderT [tag|STag|]) r

35− . flip (runStateT sTag) s

35+ . flip (runStateT [tag|STag|]) s

36runner2 s r

37− = flip (runReader rTag) (negate r)

37+ = flip (runReader [tag|RTag|]) (negate r)

38− . flip (runStateT sTag) s

38+ . flip (runStateT [tag|STag|]) s

39− . flip (runReaderT sTag) r

39+ . flip (runReaderT [tag|STag|]) r

40

41test3 :: TestTree

42test3 = testGroup "T3: Tag attachement"

test/Regression/T4.hs+4−4

@@ -6,14 +6,14 @@ import Control.Monad.Ether

6import Test.Tasty

7import Test.Tasty.QuickCheck

8

9−ethereal "RTag" "rTag"

9+data RTag

10

11testEther :: Ether '[RTag --> Int] m => m Int

12−testEther = ask rTag

12+testEther = ask [tag|RTag|]

13

14runner r

15− = flip (runReader rTag) (r' :: Int)

15+ = flip (runReader [tag|RTag|]) (r' :: Int)

16− . flip (runReaderT rTag) (r :: Int)

16+ . flip (runReaderT [tag|RTag|]) (r :: Int)

17 where

18 r' = negate r

19

test/Regression/T7.hs+4−4

@@ -9,7 +9,7 @@ import qualified Control.Monad.Writer as T

9import Test.Tasty

10import Test.Tasty.QuickCheck

11

12−ethereal "WTag" "wTag"

12+data WTag

13

14testEther

15 :: Num a

@@ -19,16 +19,16 @@ testEther

19testEther xs = do

20 forM_ xs $ \x -> do

21 T.tell (Sum x)

22− tell wTag (Sum 1)

22+ tell [tag|WTag|] (Sum 1)

23

24runner1 :: Num a => [a] -> (a, a)

25runner1 xs =

26− let (s, c) = T.runWriter . execWriterT wTag $ testEther xs

26+ let (s, c) = T.runWriter . execWriterT [tag|WTag|] $ testEther xs

27 in (getSum s, getSum c)

28

29runner2 :: Num a => [a] -> (a, a)

30runner2 xs =

31− let (c, s) = runWriter wTag . T.execWriterT $ testEther xs

31+ let (c, s) = runWriter [tag|WTag|] . T.execWriterT $ testEther xs

32 in (getSum s, getSum c)

33

34triangular :: Integral a => a -> a

test/Regression/T8.hs+10−10

@@ -8,8 +8,8 @@ import qualified Control.Monad.State as T

8import Test.Tasty

9import Test.Tasty.QuickCheck

10

11−ethereal "Foo" "foo"

11+data Foo

12−ethereal "Bar" "bar"

12+data Bar

13

14testMTL1 :: T.MonadState Int m => m ()

15testMTL1 = T.modify negate

@@ -21,22 +21,22 @@ testEther

21 :: Ether '[Foo <-> Int, Bar <-> Bool] m

22 => m String

23testEther = do

24− tagAttach foo testMTL1

24+ tagAttach [tag|Foo|] testMTL1

25− tagAttach bar testMTL2

25+ tagAttach [tag|Bar|] testMTL2

26− a <- gets foo show

26+ a <- gets [tag|Foo|] show

27− b <- gets bar show

27+ b <- gets [tag|Bar|] show

28 return (a ++ b)

29

30model :: Int -> Bool -> String

31model a b = show (negate a) ++ show (not b)

32

33runner1 a b

34− = flip (evalState foo) a

34+ = flip (evalState [tag|Foo|]) a

35− . flip (evalStateT bar) b

35+ . flip (evalStateT [tag|Bar|]) b

36

37runner2 a b

38− = flip (evalState bar) b

38+ = flip (evalState [tag|Bar|]) b

39− . flip (evalStateT foo) a

39+ . flip (evalStateT [tag|Foo|]) a

40

41test8 :: TestTree

42test8 = testGroup "T8: Multiple tag attachements"

test/Regression/T9.hs+9−10

@@ -6,17 +6,16 @@ import Control.Monad.Ether

6import Test.Tasty

7import Test.Tasty.QuickCheck

8

9−ethereal "Foo" "foo"

9+data Foo

10−ethereal "Bar" "bar"

10+data Bar

11−

12

11

13testEther1 :: Ether '[Foo <-> Int] m => m String

12testEther1 :: Ether '[Foo <-> Int] m => m String

14testEther1 = do

13testEther1 = do

15− modify foo negate

14+ modify [tag|Foo|] negate

16− gets foo show

15+ gets [tag|Foo|] show

17

16

18testEther2 :: Ether '[Bar <-> Int] m => m String

17testEther2 :: Ether '[Bar <-> Int] m => m String

19−testEther2 = tagReplace foo bar testEther1

18+testEther2 = tagReplace [tag|Foo|] [tag|Bar|] testEther1

20

19

21testEther

20testEther

22 :: Ether '[Foo <-> Int, Bar <-> Int] m

21 :: Ether '[Foo <-> Int, Bar <-> Int] m

@@ -30,12 +29,12 @@ model :: Int -> Int -> String

30model a b = show (negate a) ++ show (negate b)

29model a b = show (negate a) ++ show (negate b)

31

30

32runner1 a b

31runner1 a b

33− = flip (evalState foo) a

32+ = flip (evalState [tag|Foo|]) a

34− . flip (evalStateT bar) b

33+ . flip (evalStateT [tag|Bar|]) b

35

34

36runner2 a b

35runner2 a b

37− = flip (evalState bar) b

36+ = flip (evalState [tag|Bar|]) b

38− . flip (evalStateT foo) a

37+ . flip (evalStateT [tag|Foo|]) a

39

38

40test9 :: TestTree

39test9 :: TestTree

41test9 = testGroup "T9: Tag replacement"

40test9 = testGroup "T9: Tag replacement"