cornea 0.3.1.2 → 0.4.0.0
raw patch · 20 files changed
+531/−457 lines, 20 filesdep +basedep +hedgehogdep +tastydep −HTFdep −base-nopreludedep ~eitherdep ~lensdep ~lifted-base
Dependencies added: base, hedgehog, tasty, tasty-hedgehog
Dependencies removed: HTF, base-noprelude
Dependency ranges changed: either, lens, lifted-base, monad-control, mtl, relude, template-haskell, th-abstraction, transformers
Files
- LICENSE +27/−48
- README.md +0/−83
- cornea.cabal +196/−93
- lib/Control/Monad/DeepError.hs +4/−4
- lib/Control/Monad/DeepReader.hs +2/−3
- lib/Control/Monad/DeepState.hs +0/−3
- lib/Cornea/Prelude.hs +9/−0
- lib/Data/DeepLenses.hs +0/−2
- lib/Data/DeepPrisms.hs +0/−2
- lib/Prelude.hs +2/−4
- readme.md +83/−0
- test/DeepErrorSpec.hs +71/−0
- test/DeepReaderSpec.hs +55/−0
- test/DeepStateSpec.hs +55/−0
- test/Main.hs +27/−0
- test/u/DeepErrorSpec.hs +0/−77
- test/u/DeepReaderSpec.hs +0/−58
- test/u/DeepStateSpec.hs +0/−58
- test/u/Prelude.hs +0/−10
- test/u/SpecMain.hs +0/−12
LICENSE view
@@ -1,55 +1,34 @@-# Blue Oak Model License--Version 1.0.0--## Purpose--This license gives everyone as much permission to work with-this software as possible, while protecting contributors-from liability.--## Acceptance--In order to receive this license, you must agree to its-rules. The rules of this license are both obligations-under that agreement and conditions to your license.-You must not do anything with this software that triggers-a rule that you cannot or will not follow.--## Copyright--Each contributor licenses you to do everything with this-software that would otherwise infringe that contributor's-copyright in it.--## Notices--You must ensure that everyone who gets a copy of-any part of this software from you, with or without-changes, also gets the text of this license or a link to-<https://blueoakcouncil.org/license/1.0.0>.--## Excuse+Copyright (c) 2020 Torsten Schmits -If anyone notifies you in writing that you have not-complied with [Notices](#notices), you can keep your-license by taking all practical steps to comply within 30-days after the notice. If you do not do so, your license-ends immediately.+Redistribution and use in source and binary forms, with or without modification, are permitted provided that the+following conditions are met: -## Patent+ 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following+ disclaimer.+ 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided with the distribution. -Each contributor licenses you to do everything with this-software that would otherwise infringe any patent claims-they can license or become able to license.+Subject to the terms and conditions of this license, each copyright holder and contributor hereby grants to those+receiving rights under this license a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except+for failure to satisfy the conditions of this license) patent license to make, have made, use, offer to sell, sell,+import, and otherwise transfer this software, where such license applies only to those patent claims, already acquired+or hereafter acquired, licensable by such copyright holder or contributor that are necessarily infringed by: -## Reliability+ (a) their Contribution(s) (the licensed copyrights of copyright holders and non-copyrightable additions of+ contributors, in source or binary form) alone; or+ (b) combination of their Contribution(s) with the work of authorship to which such Contribution(s) was added by such+ copyright holder or contributor, if, at the time the Contribution is added, such addition causes such combination to+ be necessarily infringed. The patent license shall not apply to any other combinations which include the Contribution. -No contributor can revoke this license.+Except as expressly stated above, no rights or licenses from any copyright holder or contributor is granted under this+license, whether expressly, by implication, estoppel or otherwise. -## No Liability+DISCLAIMER -***As far as the law allows, this software comes as is,-without any warranty or condition, and no contributor-will be liable to anyone for any damages related to this-software or this license, under any kind of legal claim.***+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF+THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
− README.md
@@ -1,83 +0,0 @@-# Intro--Classes for accessing and mutating nested data types with corresponding adapter-classes for `MonadState`, `MonadReader` and `MonadError`. Inspired by the-[next level mtl with classy optics] talk.--[Hackage]--# Internals--Lenses and Prisms from [lens] are autogenerated with [TH] by splicing with-`deepPrisms` and `deepLenses`.-The generator recurses into single-field constructors and record fields if-there are instances of `DeepPrisms` or `DeepLenses` for their parameter types.--# Example--For `MonadError`:--```haskell-{-# LANGUAGE TemplateHaskell #-}--import Cornea (MonadDeepError(throwHoist))-import Control.Monad.Trans.Except (runExceptT)-import Data.DeepPrisms (deepPrisms)--newtype Error = Error String--newtype Inner = Inner Error-deepPrisms ''Inner--data Mid = Mid Inner-deepPrisms ''Mid--newtype Outer = Outer Mid-deepPrisms ''Outer--throwDeep :: MonadDeepError e Inner m => m ()-throwDeep = throwHoist (Inner (Error "boom"))--main :: IO (Either Outer ())-main = runExceptT throwDeep-```--In `main`, `MonadError Outer IO` and `DeepPrisms Outer Inner` are summoned.--Analogously for `MonadState`:--```haskell-{-# LANGUAGE TemplateHaskell #-}--import Cornea (MonadDeepState(get, gets, put))-import Control.Monad.Trans.State (execStateT)-import Data.DeepLenses (deepLenses)--newtype S = S Int--newtype Inner = Inner { _innerS :: S }-deepLenses ''Inner--data Mid = Mid { _midInner :: Inner }-deepLenses ''Mid--newtype Outer = Outer { _outerMid :: Mid }-deepLenses ''Outer--stateDeep :: MonadDeepState s Inner m => m ()-stateDeep = do- (Inner (S a)) <- get- b <- gets $ \(Inner (S b)) -> b- put (Inner (S (a + b + 3)))--main :: IO Outer-main = do- execStateT stateDeep (Outer (Mid (Inner (S 5))))-```--`MonadReader` works basically the same as `MonadState`.--[lens]: https://hackage.haskell.org/package/lens-[TH]: https://hackage.haskell.org/package/template-haskell-[next level mtl with classy optics]: https://github.com/gwils/next-level-mtl-with-classy-optics-[Hackage]: https://hackage.haskell.org/package/cornea
cornea.cabal view
@@ -1,100 +1,203 @@-cabal-version: 1.12-name: cornea-version: 0.3.1.2-license: OtherLicense-license-file: LICENSE-copyright: 2019 Torsten Schmits-maintainer: tek@tryp.io-author: Torsten Schmits-homepage: https://github.com/tek/cornea#readme-bug-reports: https://github.com/tek/cornea/issues-synopsis: classy optical monadic state-description:- Please see the README on GitHub at <https://github.com/tek/cornea>+cabal-version: 2.2 -category: Lens-build-type: Simple-extra-source-files: README.md+-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack +name: cornea+version: 0.4.0.0+synopsis: classy optical monadic state+description: Please see the README on GitHub at <https://github.com/tek/cornea>+category: Lens+homepage: https://github.com/tek/cornea#readme+bug-reports: https://github.com/tek/cornea/issues+author: Torsten Schmits+maintainer: tek@tryp.io+copyright: 2021 Torsten Schmits+license: BSD-2-Clause-Patent+license-file: LICENSE+build-type: Simple+extra-source-files:+ readme.md+ source-repository head- type: git- location: https://github.com/tek/cornea+ type: git+ location: https://github.com/tek/cornea library- exposed-modules:- Control.Monad.DeepError- Control.Monad.DeepReader- Control.Monad.DeepState- Cornea- Data.DeepLenses- Data.DeepPrisms-- hs-source-dirs: lib- other-modules: Prelude- default-language: Haskell2010- default-extensions:- AllowAmbiguousTypes AutoDeriveTypeable BangPatterns BinaryLiterals- ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable- DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable- DoAndIfThenElse EmptyDataDecls ExistentialQuantification- FlexibleContexts FlexibleInstances FunctionalDependencies GADTs- GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase- MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns- OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds- RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving- TemplateHaskell TupleSections TypeApplications TypeFamilies- TypeSynonymInstances UndecidableInstances UnicodeSyntax- ViewPatterns-- build-depends:- base-noprelude >=4.7 && <5,- either >=5.0.1.1 && <5.1,- lens >=4.18.1 && <4.19,- lifted-base >=0.2.3.12 && <0.3,- monad-control >=1.0.2.3 && <1.1,- mtl >=2.2.2 && <2.3,- relude >=0.7.0.0 && <0.8,- template-haskell >=2.15.0.0 && <2.16,- th-abstraction >=0.3.2.0 && <0.4,- transformers >=0.5.6.2 && <0.6+ exposed-modules:+ Control.Monad.DeepError+ Control.Monad.DeepReader+ Control.Monad.DeepState+ Cornea+ Cornea.Prelude+ Data.DeepLenses+ Data.DeepPrisms+ other-modules:+ Prelude+ Paths_cornea+ autogen-modules:+ Paths_cornea+ hs-source-dirs:+ lib+ default-extensions:+ AllowAmbiguousTypes+ ApplicativeDo+ BangPatterns+ BinaryLiterals+ BlockArguments+ ConstraintKinds+ DataKinds+ DefaultSignatures+ DeriveAnyClass+ DeriveDataTypeable+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveTraversable+ DerivingStrategies+ DisambiguateRecordFields+ DoAndIfThenElse+ DuplicateRecordFields+ EmptyDataDecls+ ExistentialQuantification+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ GeneralizedNewtypeDeriving+ InstanceSigs+ KindSignatures+ LambdaCase+ LiberalTypeSynonyms+ MultiParamTypeClasses+ MultiWayIf+ NamedFieldPuns+ OverloadedStrings+ OverloadedLists+ PackageImports+ PartialTypeSignatures+ PatternGuards+ PatternSynonyms+ PolyKinds+ QuantifiedConstraints+ QuasiQuotes+ RankNTypes+ RecordWildCards+ RecursiveDo+ ScopedTypeVariables+ StandaloneDeriving+ TemplateHaskell+ TupleSections+ TypeApplications+ TypeFamilies+ TypeFamilyDependencies+ TypeOperators+ TypeSynonymInstances+ UndecidableInstances+ UnicodeSyntax+ ViewPatterns+ ghc-options: -Wall -Wredundant-constraints -Wsimplifiable-class-constraints+ build-depends:+ base ==4.*+ , either >=5.0.1 && <5.1+ , lens ==4.*+ , lifted-base <0.3+ , monad-control ==1.0.*+ , mtl+ , relude >=0.7 && <1.2+ , template-haskell+ , th-abstraction >=0.3 && <0.5+ , transformers+ mixins:+ base hiding (Prelude)+ default-language: Haskell2010 test-suite cornea-unit- type: exitcode-stdio-1.0- main-is: SpecMain.hs- hs-source-dirs: test/u- other-modules:- DeepErrorSpec- DeepReaderSpec- DeepStateSpec- Prelude- Paths_cornea-- default-language: Haskell2010- default-extensions:- AllowAmbiguousTypes AutoDeriveTypeable BangPatterns BinaryLiterals- ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable- DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable- DoAndIfThenElse EmptyDataDecls ExistentialQuantification- FlexibleContexts FlexibleInstances FunctionalDependencies GADTs- GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase- MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns- OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds- RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving- TemplateHaskell TupleSections TypeApplications TypeFamilies- TypeSynonymInstances UndecidableInstances UnicodeSyntax- ViewPatterns-- ghc-options: -threaded -rtsopts -with-rtsopts=-N- build-depends:- HTF >=0.14.0.3 && <0.15,- base-noprelude >=4.7 && <5,- cornea -any,- either >=5.0.1.1 && <5.1,- lens >=4.18.1 && <4.19,- lifted-base >=0.2.3.12 && <0.3,- monad-control >=1.0.2.3 && <1.1,- mtl >=2.2.2 && <2.3,- relude >=0.7.0.0 && <0.8,- template-haskell >=2.15.0.0 && <2.16,- th-abstraction >=0.3.2.0 && <0.4,- transformers >=0.5.6.2 && <0.6+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ DeepErrorSpec+ DeepReaderSpec+ DeepStateSpec+ Paths_cornea+ hs-source-dirs:+ test+ default-extensions:+ AllowAmbiguousTypes+ ApplicativeDo+ BangPatterns+ BinaryLiterals+ BlockArguments+ ConstraintKinds+ DataKinds+ DefaultSignatures+ DeriveAnyClass+ DeriveDataTypeable+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveTraversable+ DerivingStrategies+ DisambiguateRecordFields+ DoAndIfThenElse+ DuplicateRecordFields+ EmptyDataDecls+ ExistentialQuantification+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ GeneralizedNewtypeDeriving+ InstanceSigs+ KindSignatures+ LambdaCase+ LiberalTypeSynonyms+ MultiParamTypeClasses+ MultiWayIf+ NamedFieldPuns+ OverloadedStrings+ OverloadedLists+ PackageImports+ PartialTypeSignatures+ PatternGuards+ PatternSynonyms+ PolyKinds+ QuantifiedConstraints+ QuasiQuotes+ RankNTypes+ RecordWildCards+ RecursiveDo+ ScopedTypeVariables+ StandaloneDeriving+ TemplateHaskell+ TupleSections+ TypeApplications+ TypeFamilies+ TypeFamilyDependencies+ TypeOperators+ TypeSynonymInstances+ UndecidableInstances+ UnicodeSyntax+ ViewPatterns+ ghc-options: -Wall -Wredundant-constraints -Wsimplifiable-class-constraints -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base ==4.*+ , cornea+ , either >=5.0.1 && <5.1+ , hedgehog+ , lens ==4.*+ , lifted-base <0.3+ , monad-control ==1.0.*+ , mtl+ , relude >=0.7 && <1.2+ , tasty+ , tasty-hedgehog+ , template-haskell+ , th-abstraction >=0.3 && <0.5+ , transformers+ mixins:+ base hiding (Prelude)+ , cornea (Cornea.Prelude as Prelude)+ , cornea hiding (Cornea.Prelude)+ default-language: Haskell2010
lib/Control/Monad/DeepError.hs view
@@ -1,12 +1,12 @@ module Control.Monad.DeepError where -import Control.Exception (Exception, IOException, SomeException)+import Data.DeepPrisms (DeepPrisms, hoist, retrieve)+import Data.Either.Combinators (mapLeft)++import Control.Exception (IOException) import Control.Exception.Lifted (try) import Control.Monad.Error.Class (MonadError(throwError, catchError)) import Control.Monad.Trans.Control (MonadBaseControl)--import Data.DeepPrisms (DeepPrisms, hoist, retrieve)-import Data.Either.Combinators (mapLeft) class (MonadError e m, DeepPrisms e e') => MonadDeepError e e' m where throwHoist :: e' -> m a
lib/Control/Monad/DeepReader.hs view
@@ -1,11 +1,10 @@ module Control.Monad.DeepReader where +import Data.DeepLenses (DeepLenses(deepLens))+ import Control.Lens (over) import qualified Control.Lens as Lens (view) import qualified Control.Monad.Reader.Class as MR (MonadReader(ask))-import Control.Monad.Trans.Reader (ReaderT)--import Data.DeepLenses (DeepLenses(deepLens)) class Monad m => MonadDeepReader (r :: *) (r' :: *) (m :: * -> *) | m -> r where ask :: m r'
lib/Control/Monad/DeepState.hs view
@@ -3,10 +3,7 @@ import Control.Lens (Lens') import qualified Control.Lens as Lens (mapMOf, over, set, view, views) import qualified Control.Monad.State.Class as MS (MonadState(get), modify)-import Control.Monad.Trans.Class (MonadTrans(lift)) import qualified Control.Monad.Trans.State.Lazy as Lazy (StateT)-import Control.Monad.Trans.State.Strict (StateT)-import Data.Functor (void) import Data.DeepLenses (DeepLenses(deepLens))
+ lib/Cornea/Prelude.hs view
@@ -0,0 +1,9 @@+{-# language NoImplicitPrelude #-}++module Cornea.Prelude (+ module Relude,+ undefined,+) where++import GHC.Err (undefined)+import Relude hiding (Type, ask, asks, get, gets, hoistEither, local, modify, put, state, undefined)
lib/Data/DeepLenses.hs view
@@ -1,8 +1,6 @@ module Data.DeepLenses where import Control.Lens (Lens', makeClassy)-import Control.Monad (join)-import Data.List (zipWith) import Language.Haskell.TH import Language.Haskell.TH.Datatype ( ConstructorInfo(ConstructorInfo),
lib/Data/DeepPrisms.hs view
@@ -2,8 +2,6 @@ import Control.Lens (Prism', makeClassyPrisms) import qualified Control.Lens as Lens (preview, review)-import Control.Monad (filterM, (<=<))-import Data.Maybe (mapMaybe) import Language.Haskell.TH import Language.Haskell.TH.Datatype ( ConstructorInfo(constructorName, constructorFields),
lib/Prelude.hs view
@@ -1,7 +1,5 @@ module Prelude (- module Relude,- undefined,+ module Cornea.Prelude, ) where -import GHC.Err (undefined)-import Relude hiding (Type, ask, asks, get, gets, hoistEither, local, modify, put, state, undefined)+import Cornea.Prelude
+ readme.md view
@@ -0,0 +1,83 @@+# Intro++Classes for accessing and mutating nested data types with corresponding adapter+classes for `MonadState`, `MonadReader` and `MonadError`. Inspired by the+[next level mtl with classy optics] talk.++[Hackage]++# Internals++Lenses and Prisms from [lens] are autogenerated with [TH] by splicing with+`deepPrisms` and `deepLenses`.+The generator recurses into single-field constructors and record fields if+there are instances of `DeepPrisms` or `DeepLenses` for their parameter types.++# Example++For `MonadError`:++```haskell+{-# LANGUAGE TemplateHaskell #-}++import Cornea (MonadDeepError(throwHoist))+import Control.Monad.Trans.Except (runExceptT)+import Data.DeepPrisms (deepPrisms)++newtype Error = Error String++newtype Inner = Inner Error+deepPrisms ''Inner++data Mid = Mid Inner+deepPrisms ''Mid++newtype Outer = Outer Mid+deepPrisms ''Outer++throwDeep :: MonadDeepError e Inner m => m ()+throwDeep = throwHoist (Inner (Error "boom"))++main :: IO (Either Outer ())+main = runExceptT throwDeep+```++In `main`, `MonadError Outer IO` and `DeepPrisms Outer Inner` are summoned.++Analogously for `MonadState`:++```haskell+{-# LANGUAGE TemplateHaskell #-}++import Cornea (MonadDeepState(get, gets, put))+import Control.Monad.Trans.State (execStateT)+import Data.DeepLenses (deepLenses)++newtype S = S Int++newtype Inner = Inner { _innerS :: S }+deepLenses ''Inner++data Mid = Mid { _midInner :: Inner }+deepLenses ''Mid++newtype Outer = Outer { _outerMid :: Mid }+deepLenses ''Outer++stateDeep :: MonadDeepState s Inner m => m ()+stateDeep = do+ (Inner (S a)) <- get+ b <- gets $ \(Inner (S b)) -> b+ put (Inner (S (a + b + 3)))++main :: IO Outer+main = do+ execStateT stateDeep (Outer (Mid (Inner (S 5))))+```++`MonadReader` works basically the same as `MonadState`.++[lens]: https://hackage.haskell.org/package/lens+[TH]: https://hackage.haskell.org/package/template-haskell+[next level mtl with classy optics]: https://github.com/gwils/next-level-mtl-with-classy-optics+[Hackage]: https://hackage.haskell.org/package/cornea
+ test/DeepErrorSpec.hs view
@@ -0,0 +1,71 @@+module DeepErrorSpec where++import Control.Monad.DeepError (MonadDeepError(throwHoist))+import Data.DeepPrisms (deepPrisms)+import qualified Data.String as String (lines)+import Hedgehog (TestT, (===))+import Language.Haskell.TH++newtype Err1 =+ Err1 Int+ deriving (Eq, Show)++newtype Err2 =+ Err2C Int+ deriving (Eq, Show)++data Err =+ ErrC Err1+ |+ ErrC1 Err2+ deriving (Eq, Show)++deepPrisms ''Err++data Bot =+ BotC Err+ |+ BotOther Err2+ deriving (Eq, Show)++deepPrisms ''Bot++newtype MiddleOther =+ MiddleOther Int+ deriving (Eq, Show)++data MiddleErr =+ MiddleErrC Bot+ |+ MiddleErrOther MiddleOther+ deriving (Eq, Show)++deepPrisms ''MiddleErr++newtype MainOther =+ MainOther Int+ deriving (Eq, Show)++data MainErr =+ MainErrC MiddleErr+ |+ MainErrOther MainOther+ deriving (Eq, Show)++deepPrisms ''MainErr++throwDeep :: MonadDeepError e Err m => m ()+throwDeep =+ throwHoist (ErrC (Err1 5))++debugPrint :: IO ()+debugPrint =+ traverse_ putStrLn . String.lines $ $(stringE . pprint =<< deepPrisms ''Err2)++test_hoist :: TestT IO ()+test_hoist = do+ liftIO (when debug debugPrint)+ a <- runExceptT throwDeep+ Left (MainErrC (MiddleErrC (BotC (ErrC (Err1 5))))) === a+ where+ debug = False
+ test/DeepReaderSpec.hs view
@@ -0,0 +1,55 @@+module DeepReaderSpec where++import Control.Monad.DeepReader (MonadDeepReader(ask), asks)+import Data.DeepLenses (deepLenses)+import Hedgehog (TestT, (===))++newtype S1 =+ S1 Int+ deriving (Eq, Show)++newtype S2 =+ S2 Int+ deriving (Eq, Show)++newtype S =+ SC { _sS1 :: S1 }+ deriving (Eq, Show)++deepLenses ''S++newtype Bot =+ BotC { _botS :: S }+ deriving (Eq, Show)++deepLenses ''Bot++newtype MiddleOther =+ MiddleOther Int+ deriving (Eq, Show)++data MiddleS =+ MiddleSC {+ _middleBot :: Bot,+ _middleS2 :: S2+ }+ deriving (Eq, Show)++deepLenses ''MiddleS++newtype MainS =+ MainSC { _mainMiddle :: MiddleS }+ deriving (Eq, Show)++deepLenses ''MainS++stateDeep :: MonadDeepReader r S m => m S+stateDeep = do+ (SC (S1 a)) <- ask+ b <- asks $ \(SC (S1 b)) -> b+ pure (SC (S1 (a + b + 3)))++test_reader :: TestT IO ()+test_reader = do+ a <- runReaderT stateDeep (MainSC (MiddleSC (BotC (SC (S1 5))) (S2 1)))+ SC (S1 13) === a
+ test/DeepStateSpec.hs view
@@ -0,0 +1,55 @@+module DeepStateSpec where++import Control.Monad.DeepState (MonadDeepState(get, put), gets)+import Data.DeepLenses (deepLenses)+import Hedgehog (TestT, (===))++newtype S1 =+ S1 Int+ deriving (Eq, Show)++newtype S2 =+ S2 Int+ deriving (Eq, Show)++newtype S =+ SC { _sS1 :: S1 }+ deriving (Eq, Show)++deepLenses ''S++newtype Bot =+ BotC { _botS :: S }+ deriving (Eq, Show)++deepLenses ''Bot++newtype MiddleOther =+ MiddleOther Int+ deriving (Eq, Show)++data MiddleS =+ MiddleSC {+ _middleBot :: Bot,+ _middleS2 :: S2+ }+ deriving (Eq, Show)++deepLenses ''MiddleS++newtype MainS =+ MainSC { _mainMiddle :: MiddleS }+ deriving (Eq, Show)++deepLenses ''MainS++stateDeep :: MonadDeepState s S m => m ()+stateDeep = do+ (SC (S1 a)) <- get+ b <- gets $ \(SC (S1 b)) -> b+ put (SC (S1 (a + b + 3)))++test_lens :: TestT IO ()+test_lens = do+ a <- execStateT stateDeep (MainSC (MiddleSC (BotC (SC (S1 5))) (S2 1)))+ MainSC (MiddleSC (BotC (SC (S1 13))) (S2 1)) === a
+ test/Main.hs view
@@ -0,0 +1,27 @@+module Main where++import DeepErrorSpec (test_hoist)+import DeepReaderSpec (test_reader)+import DeepStateSpec (test_lens)+import Hedgehog (TestT, property, test, withTests)+import Test.Tasty (TestName, TestTree, defaultMain, testGroup)+import Test.Tasty.Hedgehog (testProperty)++unitTest ::+ TestName ->+ TestT IO () ->+ TestTree+unitTest desc =+ testProperty desc . withTests 1 . property . test++tests :: TestTree+tests =+ testGroup "all" [+ unitTest "throw a nested error" test_hoist,+ unitTest "read a nested value" test_reader,+ unitTest "access nested state" test_lens+ ]++main :: IO ()+main =+ defaultMain tests
− test/u/DeepErrorSpec.hs
@@ -1,77 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}--module DeepErrorSpec (htf_thisModulesTests) where--import qualified Data.String as String (lines)-import Control.Monad (when)-import Control.Monad.Trans.Except (runExceptT)-import Data.Foldable (traverse_)-import Language.Haskell.TH-import Test.Framework--import Control.Monad.DeepError (MonadDeepError(throwHoist))-import Data.DeepPrisms (deepPrisms)--newtype Err1 =- Err1 Int- deriving (Eq, Show)--newtype Err2 =- Err2C Int- deriving (Eq, Show)--data Err =- ErrC Err1- |- ErrC1 Err2- deriving (Eq, Show)--deepPrisms ''Err--data Bot =- BotC Err- |- BotOther Err2- deriving (Eq, Show)--deepPrisms ''Bot--newtype MiddleOther =- MiddleOther Int- deriving (Eq, Show)--data MiddleErr =- MiddleErrC Bot- |- MiddleErrOther MiddleOther- deriving (Eq, Show)--deepPrisms ''MiddleErr--newtype MainOther =- MainOther Int- deriving (Eq, Show)--data MainErr =- MainErrC MiddleErr- |- MainErrOther MainOther- deriving (Eq, Show)--deepPrisms ''MainErr--throwDeep :: MonadDeepError e Err m => m ()-throwDeep =- throwHoist (ErrC (Err1 5))--debugPrint :: IO ()-debugPrint =- traverse_ putStrLn . String.lines $ $(stringE . pprint =<< deepPrisms ''Err2)--test_hoist :: IO ()-test_hoist = do- when debug debugPrint- a <- runExceptT throwDeep- assertEqual (Left (MainErrC (MiddleErrC (BotC (ErrC (Err1 5)))))) a- where- debug = False
− test/u/DeepReaderSpec.hs
@@ -1,58 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}--module DeepReaderSpec (htf_thisModulesTests) where--import Test.Framework--import Control.Monad.DeepReader (MonadDeepReader(ask), asks)-import Data.DeepLenses (deepLenses)--newtype S1 =- S1 Int- deriving (Eq, Show)--newtype S2 =- S2 Int- deriving (Eq, Show)--newtype S =- SC { _sS1 :: S1 }- deriving (Eq, Show)--deepLenses ''S--newtype Bot =- BotC { _botS :: S }- deriving (Eq, Show)--deepLenses ''Bot--newtype MiddleOther =- MiddleOther Int- deriving (Eq, Show)--data MiddleS =- MiddleSC {- _middleBot :: Bot,- _middleS2 :: S2- }- deriving (Eq, Show)--deepLenses ''MiddleS--newtype MainS =- MainSC { _mainMiddle :: MiddleS }- deriving (Eq, Show)--deepLenses ''MainS--stateDeep :: MonadDeepReader r S m => m S-stateDeep = do- (SC (S1 a)) <- ask- b <- asks $ \(SC (S1 b)) -> b- pure (SC (S1 (a + b + 3)))--test_reader :: IO ()-test_reader = do- a <- runReaderT stateDeep (MainSC (MiddleSC (BotC (SC (S1 5))) (S2 1)))- assertEqual (SC (S1 13)) a
− test/u/DeepStateSpec.hs
@@ -1,58 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}--module DeepStateSpec (htf_thisModulesTests) where--import Test.Framework--import Control.Monad.DeepState (MonadDeepState(get, put), gets)-import Data.DeepLenses (deepLenses)--newtype S1 =- S1 Int- deriving (Eq, Show)--newtype S2 =- S2 Int- deriving (Eq, Show)--newtype S =- SC { _sS1 :: S1 }- deriving (Eq, Show)--deepLenses ''S--newtype Bot =- BotC { _botS :: S }- deriving (Eq, Show)--deepLenses ''Bot--newtype MiddleOther =- MiddleOther Int- deriving (Eq, Show)--data MiddleS =- MiddleSC {- _middleBot :: Bot,- _middleS2 :: S2- }- deriving (Eq, Show)--deepLenses ''MiddleS--newtype MainS =- MainSC { _mainMiddle :: MiddleS }- deriving (Eq, Show)--deepLenses ''MainS--stateDeep :: MonadDeepState s S m => m ()-stateDeep = do- (SC (S1 a)) <- get- b <- gets $ \(SC (S1 b)) -> b- put (SC (S1 (a + b + 3)))--test_lens :: IO ()-test_lens = do- a <- execStateT stateDeep (MainSC (MiddleSC (BotC (SC (S1 5))) (S2 1)))- assertEqual (MainSC (MiddleSC (BotC (SC (S1 13))) (S2 1))) a
− test/u/Prelude.hs
@@ -1,10 +0,0 @@-module Prelude (- module Cornea,- module Relude,- undefined,-) where--import GHC.Err (undefined)-import Relude hiding (Type, ask, asks, get, gets, hoistEither, hoistMaybe, local, modify, put, state, undefined)--import Cornea
− test/u/SpecMain.hs
@@ -1,12 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}--module Main where--import Test.Framework-import Test.Framework.BlackBoxTest ()-import {-@ HTF_TESTS @-} DeepErrorSpec-import {-@ HTF_TESTS @-} DeepReaderSpec-import {-@ HTF_TESTS @-} DeepStateSpec--main :: IO ()-main = htfMain htf_importedTests