cornea 0.2.0.0 → 0.2.1.0

raw patch · 6 files changed

+53/−15 lines, 6 files

Files

• README.md +15/−2
• cornea.cabal +1/−1
• lib/Control/Monad/DeepState.hs +13/−2
• lib/Data/DeepPrisms.hs +1/−1
• test/u/DeepErrorSpec.hs +10/−2
• test/u/DeepStateSpec.hs +13/−7

@@ -1,7 +1,15 @@ # 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`:@@ -31,7 +39,7 @@ main = runExceptT throwDeep ``` -In `main`, `MonadError Outer IO` and `DeepPrisms Outer Inner` is summoned.+In `main`, `MonadError Outer IO` and `DeepPrisms Outer Inner` are summoned.  Analogously for `MonadState`: @@ -44,7 +52,7 @@  newtype S = S Int -newtype Inner = Inner { innerS :: S }+newtype Inner = Inner { _innerS :: S } deepLenses ''Inner  data Mid = Mid { _midInner :: Inner }@@ -63,3 +71,8 @@ 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

@@ -1,6 +1,6 @@ cabal-version: 1.12 name: cornea-version: 0.2.0.0+version: 0.2.1.0 license: OtherLicense license-file: LICENSE copyright: 2019 Torsten Schmits

@@ -9,17 +9,28 @@ class (MonadState s m, DeepLenses s s') => MonadDeepState s s' m where   get :: m s'   put :: s' -> m ()-  state :: (s' -> m (a, s')) -> m a+  stateM :: (s' -> m (a, s')) -> m a  instance (MonadState s m, DeepLenses s s') => MonadDeepState s s' m where   get = Lens.view deepLens <$> MS.get   put = MS.modify . Lens.set deepLens-  state f = do+  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)+ gets :: MonadDeepState s s' m => (s' -> a) -> m a gets =   (<$> get)++modifyM :: MonadDeepState s s' m => (s' -> m s') -> m ()+modifyM f =+  stateM (fmap ((),) . f)++modify :: MonadDeepState s s' m => (s' -> s') -> m ()+modify f =+  modifyM (pure . f)

@@ -106,7 +106,7 @@   return (current : sub)   where     compose = appE . appE [|(.)|] . prismName top-    body = foldr compose (prismName top name) intermediate+    body = foldr compose (prismName top name) (reverse intermediate)  deepInstancesIfEligible :: Name -> [Name] -> Ctor -> DecsQ deepInstancesIfEligible top intermediate (Ctor name [ConT tpe]) = do

@@ -27,12 +27,20 @@  deepPrisms ''Err +data Bot =+  BotC Err+  |+  BotOther Err2+  deriving (Eq, Show)++deepPrisms ''Bot+ newtype MiddleOther =   MiddleOther Int   deriving (Eq, Show)  data MiddleErr =-  MiddleErrC Err+  MiddleErrC Bot   |   MiddleErrOther MiddleOther   deriving (Eq, Show)@@ -59,4 +67,4 @@ test_hoist = do   -- traverse_ putStrLn $ lines $(stringE . pprint =<< deepPrisms ''MainErr)   a <- runExceptT throwDeep-  assertEqual (Left (MainErrC (MiddleErrC (ErrC (Err1 5))))) a+  assertEqual (Left (MainErrC (MiddleErrC (BotC (ErrC (Err1 5)))))) a

@@ -19,8 +19,14 @@   S2 Int   deriving (Eq, Show) +newtype S =+  SC { _sS1 :: S1 }+  deriving (Eq, Show)++deepLenses ''S+ newtype Bot =-  BotC { _botS1 :: S1 }+  BotC { _botS :: S }   deriving (Eq, Show)  deepLenses ''Bot@@ -44,13 +50,13 @@  deepLenses ''MainS -stateDeep :: MonadDeepState s Bot m => m ()+stateDeep :: MonadDeepState s S m => m () stateDeep = do-  (BotC (S1 a)) <- get-  b <- gets $ \(BotC (S1 b)) -> b-  put (BotC (S1 (a + b + 3)))+  (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 (S1 5)) (S2 1)))-  assertEqual (MainSC (MiddleSC (BotC (S1 13)) (S2 1))) a+  a <- execStateT stateDeep (MainSC (MiddleSC (BotC (SC (S1 5))) (S2 1)))+  assertEqual (MainSC (MiddleSC (BotC (SC (S1 13))) (S2 1))) a