dep-t-advice 0.4.5.0 → 0.4.6.0

raw patch · 4 files changed

+135/−60 lines, 4 filesdep +barbiesPVP ok

version bump matches the API change (PVP)

Dependencies added: barbies

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• dep-t-advice.cabal +3/−1
• lib/Control/Monad/Dep/Advice.hs +41/−31
• test/weird-advice-tests.hs +86/−28

@@ -1,5 +1,10 @@ # Revision history for dep-t-advice
 
+## 0.4.6.0 
+
+* `adviseRecord` and `deceiveRecord` now work with records having fields wrapped in `Identity`.
+
+  This is for better compatibility with the [barbies](http://hackage.haskell.org/package/barbies) package.
 
 ## 0.4.5.0 
 

@@ -1,7 +1,7 @@ cabal-version:       3.0
 
 name:                dep-t-advice
-version:             0.4.5.0
+version:             0.4.6.0
 synopsis:            Giving good advice to functions in a DepT environment.
 description:         Companion to the dep-t package. Easily add behaviour to functions living in a DepT environment, 
                      whatever the number of arguments they might have.
@@ -59,6 +59,8 @@   import:              common-tasty
   type:                exitcode-stdio-1.0
   main-is:             weird-advice-tests.hs
+  build-depends:       
+                       barbies            ^>= 2.0.2.0
 
 -- VERY IMPORTANT for doctests to work: https://stackoverflow.com/a/58027909/1364288
 -- http://hackage.haskell.org/package/cabal-doctest

@@ -117,13 +117,14 @@ import Control.Monad.Dep
 import Control.Monad.Dep.Has
 import Control.Monad.Trans.Reader (ReaderT (..), withReaderT)
+import Data.Functor.Identity
 import Data.Kind
+import Data.List.NonEmpty qualified as N
 import Data.SOP
 import Data.SOP.Dict
 import Data.SOP.NP
-import GHC.Generics qualified as G
-import Data.List.NonEmpty qualified as N
 import Data.Typeable
+import GHC.Generics qualified as G
 import GHC.TypeLits
 
 -- $setup
@@ -155,7 +156,7 @@ -- >>> import System.IO
 -- >>> import Data.IORef
 -- >>> import GHC.Generics (Generic)
--- >>> import GHC.Generics qualified 
+-- >>> import GHC.Generics qualified
 
 -- | A generic transformation of 'DepT'-effectful functions with environment
 -- @e_@ of kind @(Type -> Type) -> Type@, base monad @m@ and return type @r@,
@@ -694,7 +695,7 @@   where
   _deceiveProduct f (gullible_left G.:*: gullible_right) = _deceiveProduct @_ @e @e_ @m f gullible_left G.:*: _deceiveProduct @_ @e @e_ @m f gullible_right
 
-data RecordComponent 
+data RecordComponent
   = Terminal
   | IWrapped
   | Recurse
@@ -703,6 +704,7 @@ type family DiscriminateGullibleComponent c where
   DiscriminateGullibleComponent (a -> b) = Terminal
   DiscriminateGullibleComponent (ReaderT e m x) = Terminal
+  DiscriminateGullibleComponent (Identity _) = IWrapped
   DiscriminateGullibleComponent (I _) = IWrapped
   DiscriminateGullibleComponent _ = Recurse
 
@@ -717,8 +719,13 @@   _deceiveComponent f gullible = deceive @as @e @_ @m @r f gullible
 
 instance
-  GullibleComponent (DiscriminateGullibleComponent gullible) e e_ m gullible deceived
-  =>
+  GullibleComponent (DiscriminateGullibleComponent gullible) e e_ m gullible deceived =>
+  GullibleComponent IWrapped e e_ m (Identity gullible) (Identity deceived)
+  where
+  _deceiveComponent f (Identity gullible) = Identity (_deceiveComponent @(DiscriminateGullibleComponent gullible) @e @e_ @m f gullible)
+
+instance
+  GullibleComponent (DiscriminateGullibleComponent gullible) e e_ m gullible deceived =>
   GullibleComponent IWrapped e e_ m (I gullible) (I deceived)
   where
   _deceiveComponent f (I gullible) = I (_deceiveComponent @(DiscriminateGullibleComponent gullible) @e @e_ @m f gullible)
@@ -729,7 +736,6 @@   where
   _deceiveComponent f gullible = _deceiveRecord @e @e_ @m f gullible
 
-
 instance
   GullibleComponent (DiscriminateGullibleComponent gullible) e e_ m gullible deceived =>
   GullibleProduct e e_ m (G.S1 x (G.Rec0 gullible)) (G.S1 x (G.Rec0 deceived))
@@ -801,6 +807,7 @@ type family DiscriminateAdvisedComponent c where
   DiscriminateAdvisedComponent (a -> b) = Terminal
   DiscriminateAdvisedComponent (DepT e_ m x) = Terminal
+  DiscriminateAdvisedComponent (Identity _) = IWrapped
   DiscriminateAdvisedComponent (I _) = IWrapped
   DiscriminateAdvisedComponent _ = Recurse
 
@@ -809,13 +816,13 @@   _adviseComponent :: [(TypeRep, String)] -> (forall r. cr r => [(TypeRep, String)] -> Advice ca e_ m r) -> advised -> advised
 
 instance
-  (AdvisedComponent (DiscriminateAdvisedComponent advised) ca e_ m cr advised,
-   KnownSymbol fieldName
-   ) =>
-  AdvisedProduct ca e_ m cr (G.S1 ('G.MetaSel ('Just fieldName) su ss ds) (G.Rec0 advised))
+  ( AdvisedComponent (DiscriminateAdvisedComponent advised) ca e_ m cr advised,
+    KnownSymbol fieldName
+  ) =>
+  AdvisedProduct ca e_ m cr (G.S1 ( 'G.MetaSel ( 'Just fieldName) su ss ds) (G.Rec0 advised))
   where
-  _adviseProduct tr acc f (G.M1 (G.K1 advised)) = 
-     let acc' = acc ++ [(tr, symbolVal (Proxy @fieldName))]
+  _adviseProduct tr acc f (G.M1 (G.K1 advised)) =
+    let acc' = acc ++ [(tr, symbolVal (Proxy @fieldName))]
      in G.M1 (G.K1 (_adviseComponent @(DiscriminateAdvisedComponent advised) @ca @e_ @m @cr acc' f advised))
 
 instance
@@ -831,33 +838,39 @@   _adviseComponent acc f advised = advise @ca @e_ @m (f acc) advised
 
 instance
-  AdvisedComponent (DiscriminateAdvisedComponent advised) ca e_ m cr advised
-  =>
+  AdvisedComponent (DiscriminateAdvisedComponent advised) ca e_ m cr advised =>
+  AdvisedComponent IWrapped ca e_ m cr (Identity advised)
+  where
+  _adviseComponent acc f (Identity advised) = Identity (_adviseComponent @(DiscriminateAdvisedComponent advised) @ca @e_ @m @cr acc f advised)
+
+instance
+  AdvisedComponent (DiscriminateAdvisedComponent advised) ca e_ m cr advised =>
   AdvisedComponent IWrapped ca e_ m cr (I advised)
   where
   _adviseComponent acc f (I advised) = I (_adviseComponent @(DiscriminateAdvisedComponent advised) @ca @e_ @m @cr acc f advised)
 
 -- | Gives 'Advice' to all the functions in a record-of-functions.
 --
--- The function that builds the advice receives a list of tuples @(TypeRep, String)@ 
+-- The function that builds the advice receives a list of tuples @(TypeRep, String)@
 -- which represent the record types and fields names we have
 -- traversed until arriving at the advised function. This info can be useful for
 -- logging advices. It's a list instead of a single tuple because
 -- 'adviseRecord' works recursively.
--- 
+--
 -- __/TYPE APPLICATION REQUIRED!/__ The @ca@ constraint on function arguments
 -- and the @cr@ constraint on the result type must be supplied by means of a
 -- type application. Supply 'Top' if no constraint is required.
-adviseRecord :: forall ca cr e_ m advised. AdvisedRecord ca e_ m cr advised => 
-    -- | The advice to apply.
-    (forall r f . (cr r, Foldable f) => f (TypeRep, String) -> Advice ca e_ m r) -> 
-    -- | The record to advise recursively.
-    advised (DepT e_ m) -> 
-    -- | The advised record.
-    advised (DepT e_ m)
+adviseRecord ::
+  forall ca cr e_ m advised.
+  AdvisedRecord ca e_ m cr advised =>
+  -- | The advice to apply.
+  (forall r f. (cr r, Foldable f) => f (TypeRep, String) -> Advice ca e_ m r) ->
+  -- | The record to advise recursively.
+  advised (DepT e_ m) ->
+  -- | The advised record.
+  advised (DepT e_ m)
 adviseRecord = _adviseRecord @ca @e_ @m @cr []
 
-
 -- $records
 --
 -- 'adviseRecord' and 'deceiveRecord' are versions of 'advise' and 'deceive' that, instead of working on bare
@@ -887,18 +900,15 @@ --   env =
 --     let logger = Logger \_ -> pure ()
 --         repository =
---           adviseRecord @Top @Top mempty $ 
+--           adviseRecord @Top @Top mempty $
 --           deceiveRecord Wraps $
 --           Repository {select = \_ -> pure [], insert = \_ -> pure ()}
 --         controller =
---           adviseRecord @Top @Top mempty $ 
---           deceiveRecord Wraps $ 
+--           adviseRecord @Top @Top mempty $
+--           deceiveRecord Wraps $
 --           Controller \_ -> pure "view"
 --      in Env {logger, repository, controller}
 -- :}
---
---
-
 
 -- $sop
 -- Some useful definitions re-exported the from \"sop-core\" package.

@@ -20,16 +20,17 @@ {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE DeriveGeneric #-}
 
 module Main (main) where
 
+import Barbies
 import Control.Monad.Dep
-import Control.Monad.Dep.Has
 import Control.Monad.Dep.Advice
+import Control.Monad.Dep.Has
 import Control.Monad.Reader
 import Control.Monad.Writer
 import Data.Coerce
+import Data.Functor.Identity
 import Data.Kind
 import Data.List (intercalate)
 import Data.SOP
@@ -43,22 +44,32 @@ -- https://stackoverflow.com/questions/53498707/cant-derive-generic-for-this-type/53499091#53499091
 -- There are indeed some higher kinded types for which GHC can currently derive Generic1 instances, but the feature is so limited it's hardly worth mentioning. This is mostly an artifact of taking the original implementation of Generic1 intended for * -> * (which already has serious limitations), turning on PolyKinds, and keeping whatever sticks, which is not much.
 type Logger :: (Type -> Type) -> Type
-newtype Logger d = Logger {log :: String -> d ()} deriving Generic
+newtype Logger d = Logger {log :: String -> d ()} deriving (Generic)
+
+instance FunctorB Logger
+
 instance Dep Logger where
-    type DefaultFieldName Logger = "logger"
+  type DefaultFieldName Logger = "logger"
 
 type Repository :: (Type -> Type) -> Type
 data Repository d = Repository
   { select :: String -> d [Int],
     insert :: [Int] -> d ()
-  } deriving Generic
+  }
+  deriving (Generic)
+
+instance FunctorB Repository
+
 instance Dep Repository where
-    type DefaultFieldName Repository = "repository"
+  type DefaultFieldName Repository = "repository"
 
 type Controller :: (Type -> Type) -> Type
-newtype Controller d = Controller {serve :: Int -> d String} deriving Generic
+newtype Controller d = Controller {serve :: Int -> d String} deriving (Generic)
+
+instance FunctorB Controller
+
 instance Dep Controller where
-    type DefaultFieldName Controller = "controller"
+  type DefaultFieldName Controller = "controller"
 
 type Env :: (Type -> Type) -> Type
 data Env m = Env
@@ -66,8 +77,11 @@     repository :: Repository m,
     controller :: Controller m
   }
+
 instance Has Logger m (Env m)
+
 instance Has Repository m (Env m)
+
 instance Has Controller m (Env m)
 
 -- dumb wrapper newtype
@@ -77,18 +91,15 @@ env =
   let logger = Logger \_ -> pure ()
       repository =
-        adviseRecord @Top @Top mempty $ 
-        deceiveRecord Wraps $
-        Repository {select = \_ -> pure [], insert = \_ -> pure ()}
+        adviseRecord @Top @Top mempty $
+          deceiveRecord Wraps $
+            Repository {select = \_ -> pure [], insert = \_ -> pure ()}
       controller =
-        adviseRecord @Top @Top mempty $ 
-        deceiveRecord Wraps $ 
-        Controller \_ -> pure "view"
+        adviseRecord @Top @Top mempty $
+          deceiveRecord Wraps $
+            Controller \_ -> pure "view"
    in Env {logger, repository, controller}
 
-
-
-
 ran :: Writer () String
 ran = runFromDep (pure env) serve 7
 
@@ -99,25 +110,42 @@   { logger :: h (Logger m),
     repository :: h (Repository m),
     controller :: h (Controller m)
-  } deriving Generic
+  }
+  deriving (Generic)
 
+instance Functor h => FunctorB (EnvHKD h)
+
+instance FunctorT EnvHKD
+
+instance TraversableT EnvHKD
+
+instance Has Logger m (EnvHKD I m)
+
+instance Has Repository m (EnvHKD I m)
+
+instance Has Controller m (EnvHKD I m)
+
+instance Has Repository m (EnvHKD Identity m)
+
+instance Has Controller m (EnvHKD Identity m)
+
 envHKD :: EnvHKD I (DepT Env (Writer ()))
 envHKD =
   let logger =
         I $ Logger \_ -> pure ()
       repository =
         I $
-          adviseRecord @Top @Top mempty $ 
-          deceiveRecord Wraps $
-          Repository {select = \_ -> pure [], insert = \_ -> pure ()}
+          adviseRecord @Top @Top mempty $
+            deceiveRecord Wraps $
+              Repository {select = \_ -> pure [], insert = \_ -> pure ()}
       controller =
         I $
-          adviseRecord @Top @Top mempty $ 
-          deceiveRecord Wraps $
-          Controller \_ -> pure "view"
+          adviseRecord @Top @Top mempty $
+            deceiveRecord Wraps $
+              Controller \_ -> pure "view"
    in adviseRecord @Top @Top mempty $ EnvHKD {logger, repository, controller}
 
-
+-- modified as a whole
 envHKD' :: EnvHKD I (DepT Env (Writer ()))
 envHKD' =
   let logger =
@@ -128,10 +156,40 @@       controller =
         I $
           Controller \_ -> pure "view"
-   in adviseRecord @Top @Top mempty $ 
-      deceiveRecord Wraps $
-      EnvHKD {logger, repository, controller}
+   in adviseRecord @Top @Top mempty $
+        deceiveRecord Wraps $
+          EnvHKD {logger, repository, controller}
 
+envHKDIdentity :: EnvHKD Identity (DepT Env (Writer ()))
+envHKDIdentity =
+  let logger =
+        Identity $ Logger \_ -> pure ()
+      repository =
+        Identity $
+          adviseRecord @Top @Top mempty $
+            deceiveRecord Wraps $
+              Repository {select = \_ -> pure [], insert = \_ -> pure ()}
+      controller =
+        Identity $
+          adviseRecord @Top @Top mempty $
+            deceiveRecord Wraps $
+              Controller \_ -> pure "view"
+   in adviseRecord @Top @Top mempty $ EnvHKD {logger, repository, controller}
+
+-- modified as a whole
+envHKDIdentity' :: EnvHKD Identity (DepT Env (Writer ()))
+envHKDIdentity' =
+  let logger =
+        Identity $ Logger \_ -> pure ()
+      repository =
+        Identity $
+          Repository {select = \_ -> pure [], insert = \_ -> pure ()}
+      controller =
+        Identity $
+          Controller \_ -> pure "view"
+   in adviseRecord @Top @Top mempty $
+        deceiveRecord Wraps $
+          EnvHKD {logger, repository, controller}
 
 --
 --