192fb9f · typeable/ether

git.iko.soy/typeable/ether

Ether-zoom prototype (#26)

commit192fb9f285b215eac420a028fc74426b64acbc7f authorIndex Int <vlad.z.4096@gmail.com> dateTue 3 May 2016, 22:40 (10 years ago) parent805db1b

26 files changed+227−65

compare with master

unifiedsplit

.travis.yml+3−3

@@ -16,12 +16,12 @@ install:

1616 - stack install --only-dependencies --no-terminal

1717

1818script:

19− - stack test ether:regression --coverage --no-terminal --ghc-options -Werror

20− - stack bench ether-flatten:bench --no-terminal --ghc-options -Werror

19+ - stack test ether-suite:regression --coverage --no-terminal --ghc-options -Werror

20+ - stack bench ether-suite:bench --no-terminal --ghc-options -Werror

2121

2222after_script:

2323 - curl -L https://github.com/rubik/stack-hpc-coveralls/releases/download/v0.0.3.0/shc-linux-x64-7.10.2.tar.bz2 | tar -xvj

24− - ./shc ether regression

24+ - ./shc ether-suite regression

2525

2626addons:

2727 apt:

ether-flatten/ether-flatten.cabal−19

@@ -40,22 +40,3 @@ library

4040

4141 hs-source-dirs: src

4242 ghc-options: -Wall

43−

44−

45−benchmark bench

46−

47− build-depends: base >=4.9 && <4.10

48− , mtl >=2.2.1

49− , transformers >=0.4.2

50− , criterion >=1.1

51− , lens >=4.14

52− , ether

53− , ether-flatten

54−

55− main-is: Bench.hs

56−

57− type: exitcode-stdio-1.0

58− hs-source-dirs: bench

59− default-language: Haskell2010

60− ghc-options: -Wall -O2

61− ghc-prof-options: -fprof-auto

ether-suite/Setup.hsnew file+2

@@ -0,0 +1,2 @@

1+import Distribution.Simple

2+main = defaultMain

ether-flatten/bench/Bench.hs → ether-suite/bench/Bench.hsrenamed

The content is the same.

ether-suite/ether-suite.cabalnew file+70

@@ -0,0 +1,70 @@

1+name: ether-suite

2+version: 0.1.0.0

3+build-type: Simple

4+cabal-version: >=1.18

6+library

7+ -- Dummy section.

8+ default-language: Haskell2010

10+test-suite regression

11+

12+ build-depends: base >=4.9 && <4.10

13+ , transformers >=0.4.2

14+ , mtl >=2.2.1

15+ , tasty >=0.10

16+ , tasty-quickcheck >=0.8

17+ , QuickCheck >=2.8

18+ , ghc-prim >=0.3

19+ , lens >=4.14

20+ , ether

21+ , ether-zoom

22+

23+ main-is: Regression.hs

24+ other-modules: Regression.T1

25+ Regression.T2

26+ Regression.T3

27+ Regression.T4

28+ Regression.T5

29+ Regression.T6

30+ Regression.T7

31+ Regression.T8

32+ Regression.T9

33+ Regression.T10

34+ Regression.T11

35+ Regression.T12

36+

37+ type: exitcode-stdio-1.0

38+ hs-source-dirs: test

39+ default-language: Haskell2010

40+ default-extensions: ConstraintKinds

41+ DataKinds

42+ EmptyDataDecls

43+ FlexibleContexts

44+ GeneralizedNewtypeDeriving

45+ LambdaCase

46+ PolyKinds

47+ ScopedTypeVariables

48+ TypeApplications

49+ TypeFamilies

50+ TypeOperators

51+ ghc-options: -Wall -fno-warn-missing-signatures

52+

53+

54+benchmark bench

55+

56+ build-depends: base >=4.9 && <4.10

57+ , mtl >=2.2.1

58+ , transformers >=0.4.2

59+ , criterion >=1.1

60+ , lens >=4.14

61+ , ether

62+ , ether-flatten

63+

64+ main-is: Bench.hs

65+

66+ type: exitcode-stdio-1.0

67+ hs-source-dirs: bench

68+ default-language: Haskell2010

69+ ghc-options: -Wall -O2

70+ ghc-prof-options: -fprof-auto

ether/test/Regression.hs → ether-suite/test/Regression.hsrenamed+2

@@ -13,6 +13,7 @@ import Regression.T8

1313import Regression.T9

1414import Regression.T10

1515import Regression.T11

16+import Regression.T12

1617

1718main :: IO ()

1819main = defaultMain suite

@@ -30,4 +31,5 @@ suite = testGroup "Ether"

3031 , test9

3132 , test10

3233 , test11

34+ , test12

3335 ]

ether/test/Regression/T1.hs → ether-suite/test/Regression/T1.hsrenamed

The content is the same.

ether/test/Regression/T10.hs → ether-suite/test/Regression/T10.hsrenamed

The content is the same.

ether/test/Regression/T11.hs → ether-suite/test/Regression/T11.hsrenamed

The content is the same.

ether-suite/test/Regression/T12.hsnew file+31

@@ -0,0 +1,31 @@

1+module Regression.T12 (test12) where

3+import Control.Monad.Ether.State

4+import Control.Monad.Ether.State.Zoom

5+import Control.Lens

7+import Test.Tasty

8+import Test.Tasty.QuickCheck

10+data Foo

11+

12+succState :: Enum a => MonadState Foo a m => m ()

13+succState = modify @Foo succ

14+

15+testEther :: (Enum a, MonadState Foo (a, a) m) => m (a, a)

16+testEther = do

17+ tagZoom @Foo _1 succState

18+ tagZoom @Foo _2 $ modify @Foo pred

19+ get @Foo

20+

21+model :: Enum a => (a, a) -> (a, a)

22+model (a1, a2) = (succ a1, pred a2)

23+

24+runner = evalState @Foo

25+

26+test12 :: TestTree

27+test12 = testGroup "T12: State zooming"

28+ [ testProperty "runner works"

29+ $ \(a1 :: Integer, a2 :: Integer) -> property

30+ $ runner testEther (a1, a2) == model (a1, a2)

31+ ]

ether/test/Regression/T2.hs → ether-suite/test/Regression/T2.hsrenamed

The content is the same.

ether/test/Regression/T3.hs → ether-suite/test/Regression/T3.hsrenamed

The content is the same.

ether/test/Regression/T4.hs → ether-suite/test/Regression/T4.hsrenamed

The content is the same.

ether/test/Regression/T5.hs → ether-suite/test/Regression/T5.hsrenamed

The content is the same.

ether/test/Regression/T6.hs → ether-suite/test/Regression/T6.hsrenamed

The content is the same.

ether/test/Regression/T7.hs → ether-suite/test/Regression/T7.hsrenamed

The content is the same.

ether/test/Regression/T8.hs → ether-suite/test/Regression/T8.hsrenamed

The content is the same.

ether/test/Regression/T9.hs → ether-suite/test/Regression/T9.hsrenamed

The content is the same.

ether-zoom/CHANGELOG.mdnew file

No changes to the content.

ether-zoom/LICENSEnew file+30

@@ -0,0 +1,30 @@

5+Redistribution and use in source and binary forms, with or without

6+modification, are permitted provided that the following conditions are met:

8+ * Redistributions of source code must retain the above copyright

9+ notice, this list of conditions and the following disclaimer.

10+

11+ * Redistributions in binary form must reproduce the above

12+ copyright notice, this list of conditions and the following

13+ disclaimer in the documentation and/or other materials provided

14+ with the distribution.

15+

16+ * Neither the name of Index Int nor the names of other

17+ contributors may be used to endorse or promote products derived

18+ from this software without specific prior written permission.

19+

20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

ether-zoom/Setup.hsnew file+2

@@ -0,0 +1,2 @@

1+import Distribution.Simple

2+main = defaultMain

ether-zoom/ether-zoom.cabalnew file+39

@@ -0,0 +1,39 @@

1+name: ether-zoom

2+version: 0.1.0.0

3+synopsis: Zoom for the state monad

4+description:

5+ Zoom into parts of a state using a lens.

7+category: Control

8+license: BSD3

9+license-file: LICENSE

10+author: Index Int

11+maintainer: Index Int <vlad.z.4096@gmail.com>

12+homepage: https://int-index.github.io/ether/

13+bug-reports: https://github.com/int-index/ether/issues

14+build-type: Simple

15+cabal-version: >=1.18

16+extra-source-files: CHANGELOG.md

17+

18+source-repository head

19+

20+ type: git

21+ location: git@github.com:int-index/ether.git

22+

23+

24+library

25+

26+ exposed-modules: Control.Monad.Ether.State.Zoom

27+ build-depends: base >=4.9 && <4.10

28+ , ether >=0.5 && <0.6

29+ , lens >=4.14

30+ , reflection >=2.1

31+

32+ default-language: Haskell2010

33+ default-extensions: PolyKinds

34+ ScopedTypeVariables

35+ FunctionalDependencies

36+ TypeApplications

37+

38+ hs-source-dirs: src

39+ ghc-options: -Wall

ether-zoom/src/Control/Monad/Ether/State/Zoom.hsnew file+39

@@ -0,0 +1,39 @@

1+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE RankNTypes #-}

5+{-# LANGUAGE TypeSynonymInstances #-}

6+{-# LANGUAGE FlexibleInstances #-}

7+{-# LANGUAGE FlexibleContexts #-}

8+{-# LANGUAGE UndecidableInstances #-}

10+module Control.Monad.Ether.State.Zoom

11+ ( K_TagZoom(..)

12+ , tagZoom

13+ ) where

14+

15+import Control.Lens

16+import Data.Reflection

17+import Control.Monad.Trans.Ether.Dispatch

18+import Control.Monad.Ether.State.Class

19+import Data.Proxy

20+

21+-- | Encode type-level information for 'tagZoom'.

22+data K_TagZoom t z = TagZoom t z

23+

24+type DispatchTagZoomT t (z :: *) = DispatchT (TagZoom t z)

25+

26+-- | Zoom into a part of a state using a lens.

27+tagZoom

28+ :: forall tag sOuter sInner m a

29+ . Lens' sOuter sInner

30+ -> (forall z . Reifies z (ReifiedLens' sOuter sInner) => DispatchTagZoomT tag z m a)

31+ -> m a

32+tagZoom l m = reify (Lens l) (\(_ :: Proxy z) -> runDispatchT (m @z))

33+

34+instance ( MonadState tag sOuter m

35+ , Reifies z (ReifiedLens' sOuter sInner)

36+ ) => MonadState tag sInner (DispatchTagZoomT tag z m) where

37+ state t = dispatchT . state t . l

38+ where

39+ Lens l = reflect (Proxy :: Proxy z)

ether/ether.cabal−41

@@ -85,44 +85,3 @@ library

8585

8686 hs-source-dirs: src

8787 ghc-options: -Wall

88−

89−

90−test-suite regression

91−

92− build-depends: base >=4.9 && <4.10

93− , transformers >=0.4.2

94− , mtl >=2.2.1

95− , tasty >=0.10

96− , tasty-quickcheck >=0.8

97− , QuickCheck >=2.8

98− , ghc-prim >=0.3

99− , ether

100−

101− main-is: Regression.hs

102− other-modules: Regression.T1

103− Regression.T2

104− Regression.T3

105− Regression.T4

106− Regression.T5

107− Regression.T6

108− Regression.T7

109− Regression.T8

110− Regression.T9

111− Regression.T10

112− Regression.T11

113−

114− type: exitcode-stdio-1.0

115− hs-source-dirs: test

116− default-language: Haskell2010

117− default-extensions: ConstraintKinds

118− DataKinds

119− EmptyDataDecls

120− FlexibleContexts

121− GeneralizedNewtypeDeriving

122− LambdaCase

123− PolyKinds

124− ScopedTypeVariables

125− TypeApplications

126− TypeFamilies

127− TypeOperators

128− ghc-options: -Wall -fno-warn-missing-signatures

ether/src/Control/Monad/Trans/Ether/Dispatch.hs+7−2

@@ -103,22 +103,27 @@ newtype DispatchT dp m a = DispatchT (Trans.IdentityT m a)

103103-- | Type-restricted 'coerce'.

104104pack :: forall dp m a . Trans.IdentityT m a -> DispatchT dp m a

105105pack = coerce

106+{-# INLINE pack #-}

106107

107108-- | Type-restricted 'coerce'.

108109unpack :: forall dp m a . DispatchT dp m a -> Trans.IdentityT m a

109110unpack = coerce

111+{-# INLINE unpack #-}

110112

111113-- | Type-restricted 'coerce'.

112114dispatchT :: forall dp m a . m a -> DispatchT dp m a

113115dispatchT = coerce

116+{-# INLINE dispatchT #-}

114117

115118-- | Type-restricted 'coerce'.

116119runDispatchT :: forall dp m a . DispatchT dp m a -> m a

117120runDispatchT = coerce

121+{-# INLINE runDispatchT #-}

118122

119123-- | Type-restricted 'coerce'.

120124redispatch :: forall dp dp' m a . DispatchT dp m a -> DispatchT dp' m a

121125redispatch = coerce

126+{-# INLINE redispatch #-}

122127

123128instance MB.MonadBase b m => MB.MonadBase b (DispatchT dp m) where

124129 liftBase = MB.liftBaseDefault

@@ -206,7 +211,7 @@ type DispatchTagAttachT t = DispatchT (TagAttach t)

206211

207212-- | Attach a tag to untagged transformers.

208213tagAttach :: forall tag m a . DispatchTagAttachT tag m a -> m a

209−tagAttach = coerce

214+tagAttach = runDispatchT

210215

211216instance MonadReader tag r m

212217 => Class.MonadReader r (DispatchTagAttachT tag m) where

@@ -240,7 +245,7 @@ type DispatchTagReplaceT tOld tNew = DispatchT (TagReplace tOld tNew)

240245

241246-- | Replace a tag with another tag.

242247tagReplace :: forall tOld tNew m a . DispatchTagReplaceT tOld tNew m a -> m a

243−tagReplace = coerce

248+tagReplace = runDispatchT

244249

245250instance MonadReader tNew r m

246251 => MonadReader tOld r (DispatchTagReplaceT tOld tNew m) where

stack.yaml+2

@@ -9,6 +9,8 @@ setup-info:

99packages:

1010- 'ether'

1111- 'ether-flatten'

12+- 'ether-zoom'

13+- 'ether-suite'

1214

1315extra-deps:

1416- Glob-0.7.5