packages feed

cornea 0.2.2.0 → 0.4.0.1

raw patch · 19 files changed

Files

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,78 +0,0 @@-# Intro--Classes for accessing and mutating nested data types with corresponding adapter classes for `MonadState` 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 Control.Monad.DeepError (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 Control.Monad.DeepState (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))))-```--[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,81 +1,205 @@-cabal-version: 1.12-name: cornea-version: 0.2.2.0-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>-category: Lens-build-type: Simple+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.34.6.+--+-- see: https://github.com/sol/hpack++name:           cornea+version:        0.4.0.1+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+    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.DeepState-        Data.DeepLenses-        Data.DeepPrisms-    hs-source-dirs: lib-    other-modules:-        Paths_cornea-    default-language: Haskell2010-    default-extensions: 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-                        TupleSections TypeApplications TypeFamilies TypeSynonymInstances-                        UnicodeSyntax ViewPatterns-    build-depends:-        base >=4.7 && <5,-        lens >=4.16.1 && <4.17,-        mtl >=2.2.2 && <2.3,-        template-haskell >=2.13.0.0 && <2.14,-        th-abstraction >=0.2.10.0 && <0.3,-        transformers >=0.5.5.0 && <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+    , lens >=4+    , lifted-base <0.3+    , monad-control >=1.0+    , mtl+    , relude >=0.7+    , template-haskell+    , th-abstraction >=0.3+    , 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-        DeepStateSpec-        Paths_cornea-    default-language: Haskell2010-    default-extensions: 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-                        TupleSections TypeApplications TypeFamilies TypeSynonymInstances-                        UnicodeSyntax ViewPatterns-    ghc-options: -threaded -rtsopts -with-rtsopts=-N-    build-depends:-        HTF >=0.13.2.5 && <0.14,-        base >=4.7 && <5,-        cornea -any,-        lens >=4.16.1 && <4.17,-        mtl >=2.2.2 && <2.3,-        template-haskell >=2.13.0.0 && <2.14,-        th-abstraction >=0.2.10.0 && <0.3,-        transformers >=0.5.5.0 && <0.6+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      DeepErrorSpec+      DeepReaderSpec+      DeepStateSpec+      Paths_cornea+  autogen-modules:+      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+    , hedgehog+    , lens >=4+    , lifted-base <0.3+    , monad-control >=1.0+    , mtl+    , relude >=0.7+    , tasty+    , tasty-hedgehog+    , template-haskell+    , th-abstraction >=0.3+    , transformers+  mixins:+      base hiding (Prelude)+    , cornea (Cornea.Prelude as Prelude)+    , cornea hiding (Cornea.Prelude)+  default-language: Haskell2010
lib/Control/Monad/DeepError.hs view
@@ -1,9 +1,13 @@ module Control.Monad.DeepError where -import Control.Monad.Error.Class (MonadError(throwError, catchError))- 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)+ class (MonadError e m, DeepPrisms e e') => MonadDeepError e e' m where   throwHoist :: e' -> m a @@ -11,18 +15,120 @@   throwHoist =     throwError . hoist -catchAt :: (MonadError e m, DeepPrisms e e') => (e' -> m a) -> m a -> m a+catchAt ::+  ∀ e' e m a .+  MonadDeepError e e' m =>+  (e' -> m a) ->+  m a ->+  m a catchAt handle ma =   catchError ma f   where     f e = maybe (throwError e) handle (retrieve e) -hoistEither :: MonadDeepError e e' m => Either e' a -> m a+catchAs ::+  ∀ e' e m a .+  MonadDeepError e e' m =>+  a ->+  m a ->+  m a+catchAs =+  catchAt @e' . const . return++ignoreError ::+  ∀ e' e m .+  MonadDeepError e e' m =>+  m () ->+  m ()+ignoreError =+  catchAs @e' ()++hoistEither ::+  MonadDeepError e e' m =>+  Either e' a ->+  m a hoistEither =   either throwHoist return -hoistMaybe :: MonadDeepError e e' m => e' -> Maybe a -> m a+hoistEitherWith ::+  MonadDeepError e e'' m =>+  (e' -> e'') ->+  Either e' a ->+  m a+hoistEitherWith f =+  hoistEither . mapLeft f++hoistEitherAs ::+  MonadDeepError e e'' m =>+  e'' ->+  Either e' a ->+  m a+hoistEitherAs =+  hoistEitherWith . const++hoistMaybe ::+  MonadDeepError e e' m =>+  e' ->+  Maybe a ->+  m a hoistMaybe e' =   maybe (throwHoist e') return++tryHoist ::+  MonadBaseControl IO m =>+  MonadDeepError e e' m =>+  Exception ex =>+  (ex -> e') ->+  m a ->+  m a+tryHoist f =+  hoistEitherWith f <=< try++tryHoistAs ::+  ∀ ex e e' m a .+  MonadBaseControl IO m =>+  MonadDeepError e e' m =>+  Exception ex =>+  e' ->+  m a ->+  m a+tryHoistAs e =+  hoistEitherAs e <=< try @m @ex++tryHoistIO ::+  MonadBaseControl IO m =>+  MonadDeepError e e' m =>+  (IOException -> e') ->+  m a ->+  m a+tryHoistIO =+  tryHoist++tryHoistIOAs ::+  MonadBaseControl IO m =>+  MonadDeepError e e' m =>+  e' ->+  m a ->+  m a+tryHoistIOAs =+  tryHoistAs @IOException++tryHoistAny ::+  MonadBaseControl IO m =>+  MonadDeepError e e' m =>+  (SomeException -> e') ->+  m a ->+  m a+tryHoistAny =+  tryHoist++tryHoistAnyAs ::+  MonadBaseControl IO m =>+  MonadDeepError e e' m =>+  e' ->+  m a ->+  m a+tryHoistAnyAs =+  tryHoistAs @SomeException  -- TODO derive multiple errors with HList + Generic
+ lib/Control/Monad/DeepReader.hs view
@@ -0,0 +1,20 @@+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))++class Monad m => MonadDeepReader (r :: *) (r' :: *) (m :: * -> *) | m -> r where+  ask :: m r'+  local :: (r' -> r') -> m a -> m a+  asks :: (r' -> a) -> m a++instance (Monad m, DeepLenses r r') => MonadDeepReader r r' (ReaderT r m) where+  ask =+    Lens.view deepLens <$> MR.ask+  local f m =+    ReaderT $ runReaderT m . over deepLens f+  asks =+    (<$> ask)
lib/Control/Monad/DeepState.hs view
@@ -1,36 +1,107 @@ module Control.Monad.DeepState where -import qualified Control.Lens as Lens (set, view)-import Control.Monad.State.Class (MonadState)+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 qualified Control.Monad.Trans.State.Lazy as Lazy (StateT)  import Data.DeepLenses (DeepLenses(deepLens)) -class (MonadState s m, DeepLenses s s') => MonadDeepState s s' m where+class Monad m => MonadDeepState (s :: *) (s' :: *) (m :: * -> *) | m -> s where   get :: m s'   put :: s' -> m ()   stateM :: (s' -> m (a, s')) -> m a+  stateM f = do+    ~(a, s'') <- f =<< get+    a <$ put s''+  state :: (s' -> (a, s')) -> m a+  state f =+    stateM (pure . f)+  modifyM' :: (s' -> m s') -> m s'+  modifyM' f = do+    s' <- f =<< get+    s' <$ put s'+  modify :: (s' -> s') -> m ()+  modify f =+    modifyM (pure . f) -instance (MonadState s m, DeepLenses s s') => MonadDeepState s s' m where+instance {-# OVERLAPPING #-} (Monad m, DeepLenses s s') => MonadDeepState s s' (Lazy.StateT s m) where   get = Lens.view deepLens <$> MS.get   put = MS.modify . Lens.set deepLens-  stateM f = do-    s' <- get-    ~(a, s'') <- f s'-    put s''-    return a -state :: MonadDeepState s s' m => (s' -> (a, s')) -> m a-state f = stateM (pure . f)+instance {-# OVERLAPPING #-} (Monad m, DeepLenses s s') => MonadDeepState s s' (StateT s m) where+  get = Lens.view deepLens <$> MS.get+  put = MS.modify . Lens.set deepLens -gets :: MonadDeepState s s' m => (s' -> a) -> m a+instance {-# OVERLAPPABLE #-} (Monad (t m), MonadTrans t, MonadDeepState s s' m) => MonadDeepState s s' (t m) where+  get = lift get+  put = lift . put+  state = lift . state++gets ::+  ∀ s' s m a .+  MonadDeepState s s' m =>+  (s' -> a) ->+  m a gets =   (<$> get) -modifyM :: MonadDeepState s s' m => (s' -> m s') -> m ()-modifyM f =-  stateM (fmap ((),) . f)+modifyM ::+  MonadDeepState s s' m =>+  (s' -> m s') ->+  m ()+modifyM =+  void . modifyM' -modify :: MonadDeepState s s' m => (s' -> s') -> m ()-modify f =-  modifyM (pure . f)+modifyL ::+  ∀ s' s a m.+  MonadDeepState s s' m =>+  Lens' s' a ->+  (a -> a) ->+  m ()+modifyL lens f =+  modify $ Lens.over lens f++modifyML' ::+  ∀ s' s a m.+  MonadDeepState s s' m =>+  Lens' s' a ->+  (a -> m a) ->+  m a+modifyML' lens f =+  Lens.view lens <$> modifyM' (Lens.mapMOf lens f)++modifyML ::+  ∀ s' s a m.+  MonadDeepState s s' m =>+  Lens' s' a ->+  (a -> m a) ->+  m ()+modifyML lens f =+  modifyM $ Lens.mapMOf lens f++getL ::+  ∀ s' s m a.+  MonadDeepState s s' m =>+  Lens' s' a ->+  m a+getL l =+  gets (Lens.view l)++getsL ::+  ∀ s' s m a b.+  MonadDeepState s s' m =>+  Lens' s' a ->+  (a -> b) ->+  m b+getsL lens =+  gets . Lens.views lens++setL ::+  ∀ s' s m a.+  MonadDeepState s s' m =>+  Lens' s' a ->+  a ->+  m ()+setL lens =+  modify . Lens.set lens
+ lib/Cornea.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Cornea (+  module Control.Monad.DeepError,+  module Control.Monad.DeepState,+  module Control.Monad.DeepReader,+  module Data.DeepLenses,+  module Data.DeepPrisms,+  modify,+) where++import Control.Monad.DeepError+import Control.Monad.DeepReader+import qualified Control.Monad.DeepState as DeepState (modify)+import Control.Monad.DeepState hiding (modify)+import Data.DeepLenses (deepLenses)+import Data.DeepPrisms (deepPrisms)++modify ::+  ∀ s' s m .+  MonadDeepState s s' m =>+  (s' -> s') ->+  m ()+modify =+  DeepState.modify
+ 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,10 +1,6 @@-{-# LANGUAGE TemplateHaskell #-}- 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),@@ -14,8 +10,8 @@   ) import Language.Haskell.TH.Syntax (ModName(..), Name(Name), NameFlavour(NameQ, NameS, NameG), OccName(..)) -class DeepLenses e e' where-  deepLens :: Lens' e e'+class DeepLenses s s' where+  deepLens :: Lens' s s'  data Field =   Field {@@ -47,8 +43,8 @@   funD name [clause [] body []]  deepLensesInstance :: TypeQ -> TypeQ -> BodyQ -> DecQ-deepLensesInstance top local body =-  instanceD (cxt []) (appT (appT [t|DeepLenses|] top) local) [mkHoist top local body]+deepLensesInstance top local' body =+  instanceD (cxt []) (appT (appT [t|DeepLenses|] top) local') [mkHoist top local' body]  idLenses :: Name -> DecQ idLenses name =@@ -78,11 +74,11 @@  lensName :: Name -> Name -> ExpQ lensName (Name _ topFlavour) (Name (OccName n) lensFlavour) =-  varE (Name (OccName (lensName' n)) flavour)+  varE (Name (OccName (lensNams' n)) flavour)   where-    lensName' ('_' : t) = t-    lensName' [] = []-    lensName' a = a+    lensNams' ('_' : t) = t+    lensNams' [] = []+    lensNams' a = a     flavour       | sameModule topFlavour lensFlavour = NameS       | otherwise = lensFlavour@@ -99,14 +95,14 @@   return []  dataLenses :: Name -> [Name] -> Name -> DecsQ-dataLenses top intermediate local = do-  (DT _ fields) <- dataType local+dataLenses top intermediate local' = do+  (DT _ fields) <- dataType local'   join <$> traverse (fieldLenses top intermediate) fields  dataLensesIfEligible :: Name -> [Name] -> Name -> DecsQ-dataLensesIfEligible top intermediate local = do-  eligible <- eligibleForDeepError local-  if eligible then dataLenses top intermediate local else return []+dataLensesIfEligible top intermediate local' = do+  eligible <- eligibleForDeepError local'+  if eligible then dataLenses top intermediate local' else return []  lensesForMainData :: Name -> DecsQ lensesForMainData name = do
lib/Data/DeepPrisms.hs view
@@ -1,15 +1,11 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TemplateHaskell #-}- module Data.DeepPrisms where  import Control.Lens (Prism', makeClassyPrisms) import qualified Control.Lens as Lens (preview, review)-import Control.Monad (join, (<=<)) import Language.Haskell.TH import Language.Haskell.TH.Datatype (   ConstructorInfo(constructorName, constructorFields),-  DatatypeInfo(datatypeCons, datatypeName),+  DatatypeInfo(datatypeCons),   reifyDatatype,   ) import Language.Haskell.TH.Syntax (@@ -34,37 +30,45 @@ data Ctor =   Ctor {     ctorName :: Name,-    ctorTypes :: [Type]+    ctorType :: Name   }+  deriving (Eq, Show)  data SubError =   SubError {     seCtor :: Name,     seWrapped :: Name   }--ctor :: ConstructorInfo -> Ctor-ctor info = Ctor (constructorName info) (constructorFields info)+  deriving (Eq, Show) -data DT =-  DT {-    dtName :: Name,-    dtCons :: [Ctor]+data PrismsInstance =+  PrismsInstance {+    prismInstanceName :: Name,+    prismInstanceDec :: Dec   }+  deriving (Eq, Show) -dataType :: Name -> Q DT-dataType name = do-  info <- reifyDatatype name-  return $ DT (datatypeName info) (ctor <$> datatypeCons info)+ctor :: ConstructorInfo -> Maybe Ctor+ctor info =+  cons (constructorFields info)+  where+    cons [ConT tpe] =+      Just $ Ctor (constructorName info) tpe+    cons _ =+      Nothing +dataType :: Name -> Q [Ctor]+dataType =+  fmap (mapMaybe ctor . datatypeCons) . reifyDatatype+ mkHoist :: TypeQ -> TypeQ -> BodyQ -> DecQ mkHoist _ _ body = do   (VarE name) <- [|prism|]   funD name [clause [] body []]  deepPrismsInstance :: TypeQ -> TypeQ -> BodyQ -> DecQ-deepPrismsInstance top local body =-  instanceD (cxt []) (appT (appT [t|DeepPrisms|] top) local) [mkHoist top local body]+deepPrismsInstance top local' body =+  instanceD (cxt []) (appT (appT [t|DeepPrisms|] top) local') [mkHoist top local' body]  idInstance :: Name -> DecQ idInstance name =@@ -73,16 +77,11 @@     nt = conT name     body = normalB [|id|] -eligibleForDeepError :: Name -> Q Bool-eligibleForDeepError tpe = do+typeHasDeepPrisms :: Ctor -> Q Bool+typeHasDeepPrisms (Ctor _ tpe) = do   (ConT name) <- [t|DeepPrisms|]   isInstance name [ConT tpe, ConT tpe] -subInstances :: Name -> [Name] -> Name -> DecsQ-subInstances top intermediate local = do-  (DT _ subCons) <- dataType local-  join <$> traverse (deepInstancesIfEligible top intermediate) subCons- modName :: NameFlavour -> Maybe ModName modName (NameQ mod') =   Just mod'@@ -114,34 +113,44 @@       | sameModule topFlavour localFlavour = NameS       | otherwise = prismFlavour localFlavour -deepInstances :: Name -> [Name] -> Name -> Name -> DecsQ-deepInstances top intermediate name tpe = do-  current <- deepPrismsInstance (conT top) (conT tpe) (normalB body)-  sub <- subInstances top (name : intermediate) tpe-  return (current : sub)+constructorPrism :: Name -> [Name] -> Ctor -> Q PrismsInstance+constructorPrism top intermediate (Ctor name tpe) = do+  inst <- deepPrismsInstance (conT top) (conT tpe) (normalB body)+  return (PrismsInstance tpe inst)   where     compose = appE . appE [|(.)|] . prismName top     body = foldr compose (prismName top name) (reverse intermediate) -deepInstancesIfEligible :: Name -> [Name] -> Ctor -> DecsQ-deepInstancesIfEligible top intermediate (Ctor name [ConT tpe]) = do-  eligible <- eligibleForDeepError tpe-  if eligible then deepInstances top intermediate name tpe else return []-deepInstancesIfEligible _ _ _ =-  return []+filterDuplicates :: [Ctor] -> [PrismsInstance] -> [PrismsInstance]+filterDuplicates created =+  filter (not . (`elem` (ctorType <$> created)) . prismInstanceName) -errorInstances :: DT -> DecsQ-errorInstances (DT name cons) = do-  idInst <- idInstance name-  deepInsts <- traverse (deepInstancesIfEligible name []) cons-  return (idInst : join deepInsts)+deepPrismCtors :: Name -> Q [Ctor]+deepPrismCtors =+  filterM typeHasDeepPrisms <=< dataType -deepPrisms' :: Name -> DecsQ-deepPrisms' =-  errorInstances <=< dataType+basicPrisms :: Name -> DecsQ+basicPrisms name = do+  ctors <- dataType name+  if length ctors > 1 then makeClassyPrisms name else return [] +prismsForData :: Name -> [Name] -> Name -> Q [PrismsInstance]+prismsForData top intermediate local' = do+  cons <- deepPrismCtors local'+  localInstances <- traverse (constructorPrism top intermediate) cons+  deepInstances <- traverse recurse cons+  return (localInstances ++ (deepInstances >>= filterDuplicates cons))+  where+    recurse (Ctor name tpe) = prismsForData top (name : intermediate) tpe++prismsForMainData :: Name -> DecsQ+prismsForMainData name = do+  idInst <- idInstance name+  insts <- prismsForData name [] name+  return (idInst : (prismInstanceDec <$> insts))+ deepPrisms :: Name -> DecsQ deepPrisms name = do-  prisms <- makeClassyPrisms name-  err <- deepPrisms' name-  return $ prisms ++ err+  basic <- basicPrisms name+  deep <- prismsForMainData name+  return $ basic ++ deep
+ lib/Prelude.hs view
@@ -0,0 +1,5 @@+module Prelude (+  module Cornea.Prelude,+) where++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,70 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}-{-# LANGUAGE TemplateHaskell #-}--module DeepErrorSpec(-  htf_thisModulesTests,-) where--import Control.Monad.Trans.Except (runExceptT)-import Test.Framework--import Control.Monad.DeepError (MonadDeepError(throwHoist))-import Data.DeepPrisms (deepPrisms)--newtype Err1 =-  Err1 Int-  deriving (Eq, Show)--newtype Err2 =-  Err2 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))--test_hoist :: IO ()-test_hoist = do-  -- traverse_ putStrLn $ lines $(stringE . pprint =<< deepPrisms ''MainErr)-  a <- runExceptT throwDeep-  assertEqual (Left (MainErrC (MiddleErrC (BotC (ErrC (Err1 5)))))) a
− test/u/DeepStateSpec.hs 
@@ -1,62 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}-{-# LANGUAGE TemplateHaskell #-}--module DeepStateSpec(-  htf_thisModulesTests,-) where--import Control.Monad.Trans.State (execStateT)-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/SpecMain.hs 
@@ -1,11 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}--module Main where--import Test.Framework-import Test.Framework.BlackBoxTest ()-import {-@ HTF_TESTS @-} DeepErrorSpec-import {-@ HTF_TESTS @-} DeepStateSpec--main :: IO ()-main = htfMain htf_importedTests