packages feed

cornea 0.2.2.0 → 0.3.0.0

raw patch · 14 files changed

+468/−135 lines, 14 filesdep +base-nopreludedep +eitherdep +lifted-basedep −basedep ~lensdep ~template-haskelldep ~th-abstraction

Dependencies added: base-noprelude, either, lifted-base, monad-control, relude

Dependencies removed: base

Dependency ranges changed: lens, template-haskell, th-abstraction, transformers

Files

README.md view
@@ -1,14 +1,17 @@ # 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.+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.+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 @@ -17,7 +20,7 @@ ```haskell {-# LANGUAGE TemplateHaskell #-} -import Control.Monad.DeepError (MonadDeepError(throwHoist))+import Cornea (MonadDeepError(throwHoist)) import Control.Monad.Trans.Except (runExceptT) import Data.DeepPrisms (deepPrisms) @@ -46,7 +49,7 @@ ```haskell {-# LANGUAGE TemplateHaskell #-} -import Control.Monad.DeepState (MonadDeepState(get, gets, put))+import Cornea (MonadDeepState(get, gets, put)) import Control.Monad.Trans.State (execStateT) import Data.DeepLenses (deepLenses) @@ -71,6 +74,8 @@ 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
cornea.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.12 name: cornea-version: 0.2.2.0+version: 0.3.0.0 license: OtherLicense license-file: LICENSE copyright: 2019 Torsten Schmits@@ -23,31 +23,39 @@ library     exposed-modules:         Control.Monad.DeepError+        Control.Monad.DeepReader         Control.Monad.DeepState+        Cornea         Data.DeepLenses         Data.DeepPrisms     hs-source-dirs: lib     other-modules:-        Paths_cornea+        Prelude     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+    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 >=4.7 && <5,-        lens >=4.16.1 && <4.17,+        base-noprelude >=4.7 && <5,+        either >=5.0.1.1 && <5.1,+        lens >=4.17.1 && <4.18,+        lifted-base >=0.2.3.12 && <0.3,+        monad-control >=1.0.2.3 && <1.1,         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+        relude >=0.4.0 && <0.5,+        template-haskell >=2.14.0.0 && <2.15,+        th-abstraction >=0.2.11.0 && <0.3,+        transformers >=0.5.6.2 && <0.6  test-suite cornea-unit     type: exitcode-stdio-1.0@@ -55,27 +63,35 @@     hs-source-dirs: test/u     other-modules:         DeepErrorSpec+        DeepReaderSpec         DeepStateSpec+        Prelude         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+    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.13.2.5 && <0.14,-        base >=4.7 && <5,+        base-noprelude >=4.7 && <5,         cornea -any,-        lens >=4.16.1 && <4.17,+        either >=5.0.1.1 && <5.1,+        lens >=4.17.1 && <4.18,+        lifted-base >=0.2.3.12 && <0.3,+        monad-control >=1.0.2.3 && <1.1,         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+        relude >=0.4.0 && <0.5,+        template-haskell >=2.14.0.0 && <2.15,+        th-abstraction >=0.2.11.0 && <0.3,+        transformers >=0.5.6.2 && <0.6
lib/Control/Monad/DeepError.hs view
@@ -1,8 +1,12 @@ module Control.Monad.DeepError where +import Control.Exception (Exception, IOException, SomeException)+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@@ -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,21 @@+module Control.Monad.DeepReader where++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'+  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,110 @@ 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 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)) -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 =+  gets . Lens.view++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,23 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Cornea (+  module Control.Monad.DeepError,+  module Control.Monad.DeepState,+  module Data.DeepLenses,+  module Data.DeepPrisms,+  modify,+) where++import Control.Monad.DeepError+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/Data/DeepLenses.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE TemplateHaskell #-}- module Data.DeepLenses where  import Control.Lens (Lens', makeClassy)@@ -14,8 +12,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 +45,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 +76,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 +97,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,13 @@-{-# 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 Control.Monad (filterM, (<=<))+import Data.Maybe (mapMaybe) 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 +32,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 +79,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 +115,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,7 @@+module Prelude (+  module Relude,+  undefined,+) where++import GHC.Err (undefined)+import Relude hiding (Type, ask, asks, get, gets, hoistEither, local, modify, put, state, undefined)
test/u/DeepErrorSpec.hs view
@@ -1,11 +1,12 @@ {-# OPTIONS_GHC -F -pgmF htfpp #-}-{-# LANGUAGE TemplateHaskell #-} -module DeepErrorSpec(-  htf_thisModulesTests,-) where+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))@@ -16,7 +17,7 @@   deriving (Eq, Show)  newtype Err2 =-  Err2 Int+  Err2C Int   deriving (Eq, Show)  data Err =@@ -63,8 +64,14 @@ throwDeep =   throwHoist (ErrC (Err1 5)) +debugPrint :: IO ()+debugPrint =+  traverse_ putStrLn . String.lines $ $(stringE . pprint =<< deepPrisms ''Err2)+ test_hoist :: IO () test_hoist = do-  -- traverse_ putStrLn $ lines $(stringE . pprint =<< deepPrisms ''MainErr)+  when debug debugPrint   a <- runExceptT throwDeep   assertEqual (Left (MainErrC (MiddleErrC (BotC (ErrC (Err1 5)))))) a+  where+    debug = False
+ test/u/DeepReaderSpec.hs view
@@ -0,0 +1,58 @@+{-# 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 view
@@ -1,11 +1,7 @@ {-# OPTIONS_GHC -F -pgmF htfpp #-}-{-# LANGUAGE TemplateHaskell #-} -module DeepStateSpec(-  htf_thisModulesTests,-) where+module DeepStateSpec (htf_thisModulesTests) where -import Control.Monad.Trans.State (execStateT) import Test.Framework  import Control.Monad.DeepState (MonadDeepState(get, put), gets)
+ test/u/Prelude.hs view
@@ -0,0 +1,10 @@+module Prelude (+  module Cornea,+  module Relude,+  undefined,+) where++import GHC.Err (undefined)+import Relude hiding (Type, ask, asks, get, gets, hoistEither, hoistMaybe, modify, put, state, undefined)++import Cornea
test/u/SpecMain.hs view
@@ -5,6 +5,7 @@ import Test.Framework import Test.Framework.BlackBoxTest () import {-@ HTF_TESTS @-} DeepErrorSpec+import {-@ HTF_TESTS @-} DeepReaderSpec import {-@ HTF_TESTS @-} DeepStateSpec  main :: IO ()