diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,14 @@ # Revision history for dep-t-advice +## 0.4.4.0 + +* Added 'adviseRecord' and 'deceiveRecord' that manipulate entire + records-of-functions (also work on newtypes) instead of a single bare + function. + + Useful when the components to put on the environment come in their own record + types. + ## 0.4.0.0 * Added 'deceive' function. diff --git a/dep-t-advice.cabal b/dep-t-advice.cabal --- a/dep-t-advice.cabal +++ b/dep-t-advice.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: dep-t-advice -version: 0.4.0.1 +version: 0.4.4.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. diff --git a/lib/Control/Monad/Dep/Advice.hs b/lib/Control/Monad/Dep/Advice.hs --- a/lib/Control/Monad/Dep/Advice.hs +++ b/lib/Control/Monad/Dep/Advice.hs @@ -96,6 +96,11 @@ -- * Making functions see a different environment deceive, + -- * Advising and deceiving entire records + -- $records + adviseRecord, + deceiveRecord, + -- * "sop-core" re-exports -- $sop Top, @@ -109,11 +114,15 @@ where import Control.Monad.Dep -import Control.Monad.Trans.Reader (ReaderT(..),withReaderT) +import Control.Monad.Trans.Reader (ReaderT (..), withReaderT) import Data.Kind 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.TypeLits -- $setup -- @@ -130,6 +139,8 @@ -- >>> :set -XGeneralizedNewtypeDeriving -- >>> :set -XDataKinds -- >>> :set -XScopedTypeVariables +-- >>> :set -XDeriveGeneric +-- >>> :set -XImportQualifiedPost -- >>> import Control.Monad -- >>> import Control.Monad.Dep -- >>> import Control.Monad.Dep.Advice @@ -141,6 +152,8 @@ -- >>> import Data.Monoid -- >>> import System.IO -- >>> import Data.IORef +-- >>> import GHC.Generics (Generic) +-- >>> 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@, @@ -356,7 +369,7 @@ -- of that as well. type Ensure :: ((Type -> Type) -> Type -> Constraint) -> ((Type -> Type) -> Type) -> (Type -> Type) -> Constraint -type Ensure c e_ m = c (DepT e_ m) (e_ (DepT e_ m)) +type Ensure c e_ m = c (DepT e_ m) (e_ (DepT e_ m)) -- | Apply an 'Advice' to some compatible function. The function must have its -- effects in 'DepT', and all of its arguments must satisfy the @ca@ constraint. @@ -595,27 +608,27 @@ -- logger = _logger1 -- instance HasIntermediate m (Env m) where -- intermediate = _intermediate --- newtype Switcheroo m = Switcheroo (Env m) +-- newtype Switcheroo m = Switcheroo (Env m) -- deriving newtype (HasIntermediate m) -- instance HasLogger m (Switcheroo m) where -- logger (Switcheroo e) = _logger2 e -- env :: Env (DepT Env (Writer [String])) --- env = --- let mkController :: forall d e m. MonadDep [HasLogger, HasIntermediate] d e m => Int -> m () +-- env = +-- let mkController :: forall d e m. MonadDep [HasLogger, HasIntermediate] d e m => Int -> m () -- mkController _ = do e <- ask; liftD $ logger e "foo" ; liftD $ intermediate e "foo" --- mkIntermediate :: forall d e m. MonadDep '[HasLogger] d e m => String -> m () --- mkIntermediate _ = do e <- ask ; liftD $ logger e "foo" --- in Env +-- mkIntermediate :: forall d e m. MonadDep '[HasLogger] d e m => String -> m () +-- mkIntermediate _ = do e <- ask ; liftD $ logger e "foo" +-- in Env -- { --- _logger1 = +-- _logger1 = -- \_ -> tell ["logger 1"], --- _logger2 = +-- _logger2 = -- \_ -> tell ["logger 2"], -- _intermediate = --- mkIntermediate, --- _controllerA = +-- mkIntermediate, +-- _controllerA = -- mkController, --- _controllerB = +-- _controllerB = -- deceive Switcheroo $ -- mkController -- } @@ -634,7 +647,6 @@ -- Note that the function that is \"deceived\" must be polymorphic over -- 'Control.Monad.Dep.MonadDep'. Passing a function whose effect monad has -- already \"collapsed\" into 'DepT' won't work. Therefore, 'deceive' must be applied before any 'Advice'. --- deceive :: forall as e e_ m r curried. Gullible as e e_ m r curried => @@ -645,6 +657,232 @@ -- | The deceived function, that has effects in 'DepT'. curried deceive = _deceive + +-- deceving *all* fields of a record +-- +-- +type GullibleRecord :: Type -> ((Type -> Type) -> Type) -> (Type -> Type) -> ((Type -> Type) -> Type) -> Constraint +class GullibleRecord e e_ m gullible where + _deceiveRecord :: (e_ (DepT e_ m) -> e) -> gullible (ReaderT e m) -> gullible (DepT e_ m) + +-- https://gitlab.haskell.org/ghc/ghc/-/issues/13952 +type GullibleProduct :: Type -> ((Type -> Type) -> Type) -> (Type -> Type) -> (k -> Type) -> (k -> Type) -> Constraint +class GullibleProduct e e_ m gullible_ deceived_ | e e_ m deceived_ -> gullible_ where + _deceiveProduct :: (e_ (DepT e_ m) -> e) -> gullible_ k -> deceived_ k + +instance + ( GullibleProduct e e_ m gullible_left deceived_left, + GullibleProduct e e_ m gullible_right deceived_right + ) => + GullibleProduct e e_ m (gullible_left G.:*: gullible_right) (deceived_left G.:*: deceived_right) + 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 + = Terminal + | IWrapped + | Recurse + +type DiscriminateGullibleComponent :: Type -> RecordComponent +type family DiscriminateGullibleComponent c where + DiscriminateGullibleComponent (a -> b) = Terminal + DiscriminateGullibleComponent (ReaderT e m x) = Terminal + DiscriminateGullibleComponent (I _) = IWrapped + DiscriminateGullibleComponent _ = Recurse + +type GullibleComponent :: RecordComponent -> Type -> ((Type -> Type) -> Type) -> (Type -> Type) -> Type -> Type -> Constraint +class GullibleComponent component_type e e_ m gullible deceived | e e_ m deceived -> gullible where + _deceiveComponent :: (e_ (DepT e_ m) -> e) -> gullible -> deceived + +instance + (Gullible as e e_ m r deceived, NewtypedEnv as e e_ m r deceived ~ gullible) => + GullibleComponent Terminal e e_ m gullible deceived + where + _deceiveComponent f gullible = deceive @as @e @_ @m @r 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) + +instance + GullibleRecord e e_ m gullible => + GullibleComponent Recurse e e_ m (gullible (ReaderT e m)) (gullible (DepT e_ m)) + 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)) + where + _deceiveProduct f (G.M1 (G.K1 gullible)) = G.M1 (G.K1 (_deceiveComponent @(DiscriminateGullibleComponent gullible) @e @e_ @m f gullible)) + +instance + ( G.Generic (gullible (ReaderT e m)), + G.Generic (gullible (DepT e_ m)), + G.Rep (gullible (ReaderT e m)) ~ G.D1 x (G.C1 y gullible_), + G.Rep (gullible (DepT e_ m)) ~ G.D1 x (G.C1 y deceived_), + GullibleProduct e e_ m gullible_ deceived_ + ) => + GullibleRecord e e_ m gullible + where + _deceiveRecord f gullible = + let G.M1 (G.M1 gullible_) = G.from gullible + deceived_ = _deceiveProduct @_ @e @e_ @m f gullible_ + in G.to (G.M1 (G.M1 deceived_)) + +-- | Makes an entire record-of-functions see a different version of the glooal environment record, a version that might have different @HasX@ instances. +-- +-- 'deceiveRecord' must be applied before 'adviseRecord'. +deceiveRecord :: + forall e e_ m gullible. + GullibleRecord e e_ m gullible => + -- | The newtype constructor that masks the \"true\" environment. + (e_ (DepT e_ m) -> e) -> + -- | The record to deceive recursively. The monad parameter must be left polymorphic over @MonadDep@, so that it can unify with `ReaderT`. + gullible (ReaderT e m) -> + -- | The deceived record. + gullible (DepT e_ m) +deceiveRecord = _deceiveRecord @e @e_ @m @gullible + +-- advising *all* fields of a record +-- +-- +type AdvisedRecord :: (Type -> Constraint) -> ((Type -> Type) -> Type) -> (Type -> Type) -> (Type -> Constraint) -> ((Type -> Type) -> Type) -> Constraint +class AdvisedRecord ca e_ m cr advised where + _adviseRecord :: [(TypeRep, String)] -> (forall r. cr r => [(TypeRep, String)] -> Advice ca e_ m r) -> advised (DepT e_ m) -> advised (DepT e_ m) + +type AdvisedProduct :: (Type -> Constraint) -> ((Type -> Type) -> Type) -> (Type -> Type) -> (Type -> Constraint) -> (k -> Type) -> Constraint +class AdvisedProduct ca e_ m cr advised_ where + _adviseProduct :: TypeRep -> [(TypeRep, String)] -> (forall r. cr r => [(TypeRep, String)] -> Advice ca e_ m r) -> advised_ k -> advised_ k + +instance + ( G.Generic (advised (DepT e_ m)), + -- G.Rep (advised (DepT e_ m)) ~ G.D1 ('G.MetaData name mod p nt) (G.C1 y advised_), + G.Rep (advised (DepT e_ m)) ~ G.D1 x (G.C1 y advised_), + Typeable advised, + AdvisedProduct ca e_ m cr advised_ + ) => + AdvisedRecord ca e_ m cr advised + where + _adviseRecord acc f unadvised = + let G.M1 (G.M1 unadvised_) = G.from unadvised + advised_ = _adviseProduct @_ @ca @e_ @m @cr (typeRep (Proxy @advised)) acc f unadvised_ + in G.to (G.M1 (G.M1 advised_)) + +instance + ( AdvisedProduct ca e_ m cr advised_left, + AdvisedProduct ca e_ m cr advised_right + ) => + AdvisedProduct ca e_ m cr (advised_left G.:*: advised_right) + where + _adviseProduct tr acc f (unadvised_left G.:*: unadvised_right) = _adviseProduct @_ @ca @e_ @m @cr tr acc f unadvised_left G.:*: _adviseProduct @_ @ca @e_ @m @cr tr acc f unadvised_right + +type DiscriminateAdvisedComponent :: Type -> RecordComponent +type family DiscriminateAdvisedComponent c where + DiscriminateAdvisedComponent (a -> b) = Terminal + DiscriminateAdvisedComponent (DepT e_ m x) = Terminal + DiscriminateAdvisedComponent (I _) = IWrapped + DiscriminateAdvisedComponent _ = Recurse + +type AdvisedComponent :: RecordComponent -> (Type -> Constraint) -> ((Type -> Type) -> Type) -> (Type -> Type) -> (Type -> Constraint) -> Type -> Constraint +class AdvisedComponent component_type ca e_ m cr advised where + _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)) + where + _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 + AdvisedRecord ca e_ m cr advisable => + AdvisedComponent Recurse ca e_ m cr (advisable (DepT e_ m)) + where + _adviseComponent acc f advised = _adviseRecord @ca @e_ @m @cr acc f advised + +instance + (Multicurryable as e_ m r advised, All ca as, cr r, Monad m) => + AdvisedComponent Terminal ca e_ m cr advised + where + _adviseComponent acc f advised = advise @ca @e_ @m (f acc) 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)@ +-- 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 = _adviseRecord @ca @e_ @m @cr [] + + +-- $records +-- +-- Versions of 'advise' and 'deceive' that, instead of working on bare +-- functions, transform entire records-of-functions in one go. They also work +-- with newtypes containing a single function. The records must derive 'GHC.Generics.Generic'. +-- +-- Useful with the \"wrapped\" style of components facilitated by @Control.Monad.Dep.Has@. +-- +-- >>> :{ +-- type Logger :: (Type -> Type) -> Type +-- newtype Logger d = Logger {log :: String -> d ()} deriving Generic +-- type Repository :: (Type -> Type) -> Type +-- data Repository d = Repository +-- { select :: String -> d [Int], +-- insert :: [Int] -> d () +-- } deriving Generic +-- type Controller :: (Type -> Type) -> Type +-- newtype Controller d = Controller {serve :: Int -> d String} deriving Generic +-- type Env :: (Type -> Type) -> Type +-- data Env m = Env +-- { logger :: Logger m, +-- repository :: Repository m, +-- controller :: Controller m +-- } +-- newtype Wraps x = Wraps x +-- env :: Env (DepT Env (Writer ())) +-- env = +-- let logger = Logger \_ -> pure () +-- repository = +-- adviseRecord @Top @Top mempty $ +-- deceiveRecord Wraps $ +-- Repository {select = \_ -> pure [], insert = \_ -> pure ()} +-- controller = +-- 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. diff --git a/test/weird-advice-tests.hs b/test/weird-advice-tests.hs --- a/test/weird-advice-tests.hs +++ b/test/weird-advice-tests.hs @@ -1,46 +1,129 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveGeneric #-} module Main (main) where import Control.Monad.Dep import Control.Monad.Dep.Advice -import Control.Monad.Dep.Advice.Basic import Control.Monad.Reader import Control.Monad.Writer -import Control.Monad.RWS +import Data.Coerce import Data.Kind -import Data.List (intercalate,lookup) +import Data.List (intercalate) +import Data.SOP +import GHC.Generics import Rank2 qualified import Rank2.TH qualified import Test.Tasty import Test.Tasty.HUnit import Prelude hiding (log) -import Data.Proxy +-- 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 +type Repository :: (Type -> Type) -> Type +data Repository d = Repository + { select :: String -> d [Int], + insert :: [Int] -> d () + } deriving Generic + +type Controller :: (Type -> Type) -> Type +newtype Controller d = Controller {serve :: Int -> d String} deriving Generic + +type Env :: (Type -> Type) -> Type +data Env m = Env + { logger :: Logger m, + repository :: Repository m, + controller :: Controller m + } + +-- dumb wrapper newtype +newtype Wraps x = Wraps x + +env :: Env (DepT Env (Writer ())) +env = + let logger = Logger \_ -> pure () + repository = + adviseRecord @Top @Top mempty $ + deceiveRecord Wraps $ + Repository {select = \_ -> pure [], insert = \_ -> pure ()} + controller = + adviseRecord @Top @Top mempty $ + deceiveRecord Wraps $ + Controller \_ -> pure "view" + in Env {logger, repository, controller} + -- +-- to test the coercible in the definition of Has +type EnvHKD :: (Type -> Type) -> (Type -> Type) -> Type +data EnvHKD h m = EnvHKD + { logger :: h (Logger m), + repository :: h (Repository m), + controller :: h (Controller m) + } deriving Generic + +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 ()} + controller = + I $ + adviseRecord @Top @Top mempty $ + deceiveRecord Wraps $ + Controller \_ -> pure "view" + in adviseRecord @Top @Top mempty $ EnvHKD {logger, repository, controller} + + +envHKD' :: EnvHKD I (DepT Env (Writer ())) +envHKD' = + let logger = + I $ Logger \_ -> pure () + repository = + I $ + Repository {select = \_ -> pure [], insert = \_ -> pure ()} + controller = + I $ + Controller \_ -> pure "view" + in adviseRecord @Top @Top mempty $ + deceiveRecord Wraps $ + EnvHKD {logger, repository, controller} + + -- -- - tests :: TestTree tests = testGroup "All" - [ - ] + [] main :: IO () main = defaultMain tests