diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 -. - -## 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. diff --git a/README.md b/README.md deleted file mode 100644 --- a/README.md +++ /dev/null @@ -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 diff --git a/cornea.cabal b/cornea.cabal --- a/cornea.cabal +++ b/cornea.cabal @@ -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 +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 +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 diff --git a/lib/Control/Monad/DeepError.hs b/lib/Control/Monad/DeepError.hs --- a/lib/Control/Monad/DeepError.hs +++ b/lib/Control/Monad/DeepError.hs @@ -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 diff --git a/lib/Control/Monad/DeepReader.hs b/lib/Control/Monad/DeepReader.hs --- a/lib/Control/Monad/DeepReader.hs +++ b/lib/Control/Monad/DeepReader.hs @@ -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' diff --git a/lib/Control/Monad/DeepState.hs b/lib/Control/Monad/DeepState.hs --- a/lib/Control/Monad/DeepState.hs +++ b/lib/Control/Monad/DeepState.hs @@ -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)) diff --git a/lib/Cornea/Prelude.hs b/lib/Cornea/Prelude.hs new file mode 100644 --- /dev/null +++ b/lib/Cornea/Prelude.hs @@ -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) diff --git a/lib/Data/DeepLenses.hs b/lib/Data/DeepLenses.hs --- a/lib/Data/DeepLenses.hs +++ b/lib/Data/DeepLenses.hs @@ -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), diff --git a/lib/Data/DeepPrisms.hs b/lib/Data/DeepPrisms.hs --- a/lib/Data/DeepPrisms.hs +++ b/lib/Data/DeepPrisms.hs @@ -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), diff --git a/lib/Prelude.hs b/lib/Prelude.hs --- a/lib/Prelude.hs +++ b/lib/Prelude.hs @@ -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 diff --git a/readme.md b/readme.md new file mode 100644 --- /dev/null +++ b/readme.md @@ -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 diff --git a/test/DeepErrorSpec.hs b/test/DeepErrorSpec.hs new file mode 100644 --- /dev/null +++ b/test/DeepErrorSpec.hs @@ -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 diff --git a/test/DeepReaderSpec.hs b/test/DeepReaderSpec.hs new file mode 100644 --- /dev/null +++ b/test/DeepReaderSpec.hs @@ -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 diff --git a/test/DeepStateSpec.hs b/test/DeepStateSpec.hs new file mode 100644 --- /dev/null +++ b/test/DeepStateSpec.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 diff --git a/test/u/DeepErrorSpec.hs b/test/u/DeepErrorSpec.hs deleted file mode 100644 --- a/test/u/DeepErrorSpec.hs +++ /dev/null @@ -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 diff --git a/test/u/DeepReaderSpec.hs b/test/u/DeepReaderSpec.hs deleted file mode 100644 --- a/test/u/DeepReaderSpec.hs +++ /dev/null @@ -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 diff --git a/test/u/DeepStateSpec.hs b/test/u/DeepStateSpec.hs deleted file mode 100644 --- a/test/u/DeepStateSpec.hs +++ /dev/null @@ -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 diff --git a/test/u/Prelude.hs b/test/u/Prelude.hs deleted file mode 100644 --- a/test/u/Prelude.hs +++ /dev/null @@ -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 diff --git a/test/u/SpecMain.hs b/test/u/SpecMain.hs deleted file mode 100644 --- a/test/u/SpecMain.hs +++ /dev/null @@ -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