dep-t-advice 0.4.6.1 → 0.4.7.0

raw patch · 5 files changed

+371/−6 lines, 5 filesdep +aesondep +containersdep +textdep ~dep-tPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: aeson, containers, text

Dependency ranges changed: dep-t

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• README.md +49/−0
• dep-t-advice.cabal +10/−3
• lib/Control/Monad/Dep/Advice.hs +96/−3
• test/tests-has-conversion.hs +212/−0

@@ -1,5 +1,9 @@ # Revision history for dep-t-advice
 
+## 0.4.7.0 
+
+* Added 'distributeDepT' and 'component'.
+
 ## 0.4.6.1 
 
 * Modified a signature to make it compile with GHC 9.0.1.

@@ -118,6 +118,45 @@ works on functions that end on a `DepT` action. Also, advice might depend on
 the full gamut of functionality stored in the environment.
 
+## Historical aside
+
+According to Wikipedia, the term "advice" in the sense of aspect-oriented
+programming goes back to 1966. Quoting from [PILOT: A Step Toward Man-Computer
+Symbiosis](http://publications.csail.mit.edu/ai/browse/0200browse.shtml):
+
+> There are two ways a user can modify programs in this subjective model of
+> programming: he can modify the interface between procedures, or he can modify
+> the procedure itself. (Since procedures are themselves made up of procedures,
+> modifying a procedure at one level may correspond to modifying the interface
+> between procedures at a lower level.) Modifying the interface between
+> procedures is called advising. Modifying a procedure itself is editing.
+
+> Advising is the basic innovation in the model, and in the PILOT system.
+> Advising consists of inserting new procedures at any or all of the entry or
+> exit points to a particular procedure (or class of procedures). The
+> procedures inserted are called "advice procedures" or simply "advice".
+
+> Since each piece of advice is itself a procedure, it has its own entries and
+> exits. In particular, this means that the execution of advice can cause the
+> procedure that it modifies to be bypassed completely, e.g., by specifying as
+> an exit from the advice one of the exits from the original procedure; or the
+> advice may change essential variables and continue with the computation so
+> that the original procedure is executed, but with modified variables.
+> Finally, the advice may not alter the execution or affect the original
+> procedure at all, e.g., it may merely perform some additional computation
+> such as printing a message or recording history. Since advice can be
+> conditional, the decision as to what is to be done can depend on the results
+> of the computation up to that point.
+
+> The principal advantage of advising is that the user need not be concerned
+> about the details of the actual changes in his program, nor the internal
+> representation of advice. He can treat the procedure to be advised *as a
+> unit*, a single block, and make changes to it without concern for the
+> particulars of this block. This may be contrasted with editing in which the
+> programmer must be cognizant of the internal structure of the procedure.
+
+[tweet](https://twitter.com/DiazCarrete/status/1446783366678949891).
+
 ## Links
 
 - [Aspect Oriented Programming with
@@ -132,4 +171,14 @@   Patterns](https://www.goodreads.com/book/show/44416307-dependency-injection-principles-practices-and-patterns)
   This is a good book on the general princples of DI. 
 
+- [variadic-function](https://hackage.haskell.org/package/variadic-function) a
+  Hackage library which also deals with functions of any number of elements.
+  [Reddit
+  thread](https://www.reddit.com/r/haskell/comments/oeyaz2/ann_typeablemock_mocks_that_can_fit_into_any/).
+
+- [Inferring the arity of zipWith, with lots of type-level hackery](https://www.youtube.com/watch?v=iGSKqcebhfs&t=957s). YouTube video.
+
+- [Functional Pearl: The Decorator Pattern in Haskell](https://twitter.com/DiazCarrete/status/1403985337513394178)
+
+  > An arity-generic decorator needs to solve two problems: intercept recursive calls and handle functions of any arity uniformly
 

@@ -1,7 +1,7 @@ cabal-version:       3.0
 
 name:                dep-t-advice
-version:             0.4.6.1
+version:             0.4.7.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.
@@ -24,7 +24,7 @@   build-depends:       base >=4.10.0.0 && < 5,
                        sop-core ^>= 0.5.0.0,
                        transformers ^>= 0.5.0.0,
-                       dep-t ^>= 0.4.4.0,
+                       dep-t ^>= 0.4.6.0,
   default-language:    Haskell2010
 
 common common-tests
@@ -35,7 +35,7 @@                        transformers       ^>= 0.5.0.0,
                        mtl                ^>= 2.2,
                        template-haskell,
-
+                       text,
 
 common common-tasty
   import:              common-tests
@@ -61,6 +61,13 @@   main-is:             weird-advice-tests.hs
   build-depends:       
                        barbies            ^>= 2.0.2.0
+
+test-suite tests-has-conversion
+  import:              common-tasty
+  type:                exitcode-stdio-1.0
+  main-is:             tests-has-conversion.hs
+  build-depends:       aeson,
+                       containers
 
 -- VERY IMPORTANT for doctests to work: https://stackoverflow.com/a/58027909/1364288
 -- http://hackage.haskell.org/package/cabal-doctest

@@ -93,7 +93,7 @@     runFinalDepT,
     runFromEnv,
     runFromDep,
-
+    -- askFinalDepT,
     -- * Making functions see a different environment
     deceive,
 
@@ -101,6 +101,9 @@     -- $records
     adviseRecord,
     deceiveRecord,
+    -- * Plugging Has-based constructors
+    distributeDepT,
+    component,
 
     -- * "sop-core" re-exports
     -- $sop
@@ -116,6 +119,7 @@ 
 import Control.Monad.Dep
 import Control.Monad.Dep.Has
+import Control.Monad.Dep.Env
 import Control.Monad.Trans.Reader (ReaderT (..), withReaderT)
 import Data.Functor.Identity
 import Data.Kind
@@ -126,6 +130,7 @@ import Data.Typeable
 import GHC.Generics qualified as G
 import GHC.TypeLits
+import Data.Coerce
 
 -- $setup
 --
@@ -419,6 +424,7 @@   multiuncurry :: curried -> NP I as -> DepT e_ m r
   multicurry :: (NP I as -> DepT e_ m r) -> curried
   _runFromEnv :: m (e_ (DepT e_ m)) -> (e_ (DepT e_ m) -> curried) -> DownToBaseMonad as e_ m r curried
+  _askFinalDepT :: (e_ (DepT e_ m) -> m curried) -> curried
 
 instance Monad m => Multicurryable '[] e_ m r (DepT e_ m r) where
   type DownToBaseMonad '[] e_ m r (DepT e_ m r) = m r
@@ -427,12 +433,19 @@   _runFromEnv producer extractor = do
     e <- producer
     runDepT (extractor e) e
+  _askFinalDepT f = do
+    env <- ask
+    r <- lift (f env)
+    r
 
-instance Multicurryable as e_ m r curried => Multicurryable (a ': as) e_ m r (a -> curried) where
+instance (Functor m, Multicurryable as e_ m r curried) => Multicurryable (a ': as) e_ m r (a -> curried) where
   type DownToBaseMonad (a ': as) e_ m r (a -> curried) = a -> DownToBaseMonad as e_ m r curried
   multiuncurry f (I a :* as) = multiuncurry @as @e_ @m @r @curried (f a) as
   multicurry f a = multicurry @as @e_ @m @r @curried (f . (:*) (I a))
   _runFromEnv producer extractor a = _runFromEnv @as @e_ @m @r @curried producer (\f -> extractor f a)
+  _askFinalDepT f = 
+    let switcheroo action a = fmap ($ a) action
+     in _askFinalDepT @as @e_ @m @r . flip (fmap switcheroo f)
 
 -- | Given a base monad @m@ action that gets hold of the 'DepT' environment, run
 -- the 'DepT' transformer at the tip of a curried function.
@@ -454,6 +467,12 @@   DownToBaseMonad as e_ m r curried
 runFinalDepT producer extractor = _runFromEnv producer (const extractor)
 
+askFinalDepT ::
+  forall as e_ m r curried. 
+  Multicurryable as e_ m r curried =>
+  (e_ (DepT e_ m) -> m curried) -> curried
+askFinalDepT = _askFinalDepT @as @e_ @m @r
+
 -- | Given a base monad @m@ action that gets hold of the 'DepT' environment,
 -- and a function capable of extracting a curried function from the
 -- environment, run the 'DepT' transformer at the tip of the resulting curried
@@ -595,7 +614,7 @@   type NewtypedEnv '[] e e_ m r (DepT e_ m r) = ReaderT e m r
   _deceive f action = DepT (withReaderT f action)
 
-instance Gullible as e e_ m r curried => Gullible (a ': as) e e_ m r (a -> curried) where
+instance (Functor m, Gullible as e e_ m r curried) => Gullible (a ': as) e e_ m r (a -> curried) where
   type NewtypedEnv (a ': as) e e_ m r (a -> curried) = a -> NewtypedEnv as e e_ m r curried
   _deceive f g a = deceive @as @e @e_ @m @r f (g a)
 
@@ -769,6 +788,80 @@   -- | The deceived record.
   gullible (DepT e_ m)
 deceiveRecord = _deceiveRecord @e @e_ @m @gullible
+
+
+-- | Having a 'DepT' action that returns a record-of-functions with effects in
+-- 'DepT' is the same as having the record itself, because we can obtain the initial
+-- environment by 'ask'ing for it in each member function.
+distributeDepT 
+    :: forall e_ m record . DistributiveRecord e_ m record => 
+    -- | 'DepT' action that returns the component
+    DepT e_ m (record (DepT e_ m)) ->
+    -- | component whose methods get the environment by 'ask'ing.
+    record (DepT e_ m)
+distributeDepT (DepT (ReaderT action)) = _distribute @e_ @m @record action
+
+-- | Given a constructor that returns a record-of-functions with effects in 'DepT',
+-- produce a record in which the member functions 'ask' for the environment themselves.
+--
+-- You must have a sufficiently polymorphic constructor—both in the monad and
+-- in the environment—to invoke this function.
+--
+-- 'component' lets you plug simple component constructors 
+-- into a 'DepT'-based environment.
+--
+-- Compare with 'Control.Monad.Dep.Env.constructor' from "Control.Monad.Dep.Env", which 
+-- is intended to be used with 'Control.Monad.Dep.Env.fixEnv'-based environments.
+component 
+    :: forall e_ m record . (Applicative m, DistributiveRecord e_ m record) => 
+    -- | constructor which takes the environment as a positional parameter.
+    (e_ (DepT e_ m) -> record (DepT e_ m)) ->
+    -- | component whose methods get the environment by 'ask'ing.
+    record (DepT e_ m)
+component f = _distribute @e_ @m (pure . f)
+
+
+
+type DistributiveRecord :: ((Type -> Type) -> Type) -> (Type -> Type) -> ((Type -> Type) -> Type) -> Constraint
+class DistributiveRecord e_ m record where
+    _distribute :: (e_ (DepT e_ m) -> m (record (DepT e_ m))) -> record (DepT e_ m)
+
+type DistributiveProduct :: ((Type -> Type) -> Type) -> (Type -> Type) -> (k -> Type) -> Constraint
+class DistributiveProduct e_ m product where
+    _distributeProduct :: (e_ (DepT e_ m) -> m (product k)) -> product k
+
+instance
+  ( G.Generic (advised (DepT e_ m)),
+    G.Rep (advised (DepT e_ m)) ~ G.D1 x (G.C1 y advised_),
+    DistributiveProduct e_ m advised_,
+    Functor m
+  ) =>
+  DistributiveRecord e_ m advised
+  where
+  _distribute f =
+    let advised_ = _distributeProduct @_ @e_ @m (fmap (fmap (G.unM1 . G.unM1 . G.from)) f)
+     in G.to (G.M1 (G.M1 advised_))
+
+instance
+  ( DistributiveProduct e_ m advised_left,
+    DistributiveProduct e_ m advised_right,
+    Functor m
+  ) =>
+  DistributiveProduct e_ m (advised_left G.:*: advised_right)
+  where
+  _distributeProduct f  = 
+      _distributeProduct @_ @e_ @m (fmap (fmap (\(l G.:*: _) -> l)) f) 
+      G.:*: 
+      _distributeProduct @_ @e_ @m (fmap (fmap (\(_ G.:*: r) -> r)) f) 
+
+instance
+  ( 
+    Functor m, 
+    Multicurryable as e_ m r advised
+  ) =>
+  DistributiveProduct e_ m (G.S1 ( 'G.MetaSel msymbol su ss ds) (G.Rec0 advised))
+  where
+  _distributeProduct f = G.M1 . G.K1 $ askFinalDepT @as @e_ @m @r (fmap (fmap (G.unK1 . G.unM1))  f)
 
 -- advising *all* fields of a record
 --

@@ -0,0 +1,212 @@+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+
+module Main (main) where
+
+import Control.Monad.Dep
+import Control.Monad.Dep.Has
+import Control.Monad.Dep.Env
+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.Kind
+import Data.List (intercalate,lookup)
+import Rank2 qualified
+import Rank2.TH qualified
+import Test.Tasty
+import Test.Tasty.HUnit
+import Prelude hiding (log)
+import Data.Proxy
+import System.IO
+import GHC.Generics (Generic)
+import Data.Functor.Identity
+import qualified GHC.Generics as G
+import System.IO
+import Control.Exception
+import Control.Arrow (Kleisli (..))
+import Data.Text qualified as Text
+import Data.Function ((&))
+import Data.Functor ((<&>), ($>))
+import Data.String
+import Data.Aeson
+import Data.Aeson.Types
+import Control.Monad.Trans.Cont
+import Data.Functor.Compose
+import Data.IORef
+import Data.Map.Strict (Map)
+import Data.Map.Strict qualified as Map
+
+
+--
+--
+--
+
+type Logger :: (Type -> Type) -> Type
+newtype Logger d = Logger {
+    info :: String -> d ()
+  } deriving stock Generic
+
+data Repository d = Repository
+  { findById :: Int -> d (Maybe String)
+  , putById :: Int -> String -> d ()
+  , insert :: String -> d Int
+  } deriving stock Generic
+
+data Controller d = Controller 
+  { create :: d Int
+  , append :: Int -> String -> d Bool 
+  , inspect :: Int -> d (Maybe String)
+  } deriving stock Generic
+
+type MessagePrefix = Text.Text
+
+data LoggerConfiguration = LoggerConfiguration { 
+        messagePrefix :: MessagePrefix
+    } deriving stock (Show, Generic)
+      deriving anyclass FromJSON
+
+makeStdoutLogger :: MonadIO m => MessagePrefix -> env -> Logger m
+makeStdoutLogger prefix _ = Logger (\msg -> liftIO (putStrLn (Text.unpack prefix ++ msg)))
+
+makeInMemoryRepository 
+    :: (Has Logger m env, MonadIO m) 
+    => IORef (Map Int String) 
+    -> env 
+    -> Repository m
+makeInMemoryRepository ref (asCall -> call) = do
+    Repository {
+         findById = \key -> do
+            call info "I'm going to do a lookup in the map!"
+            theMap <- liftIO $ readIORef ref
+            pure (Map.lookup key theMap)
+       , putById = \key content -> do
+            theMap <- liftIO $ readIORef ref
+            liftIO $ writeIORef ref $ Map.insert key content theMap 
+       , insert = \content -> do 
+            call info "I'm going to insert in the map!"
+            theMap <- liftIO $ readIORef ref
+            let next = Map.size theMap
+            liftIO $ writeIORef ref $ Map.insert next content theMap 
+            pure next
+    }
+
+makeController :: forall m env . (Has Logger m env, Has Repository m env, Monad m) => env -> Controller m
+makeController (asCall -> call) = Controller {
+      create = do
+          call info "Creating a new empty resource."
+          key <- call insert ""
+          pure key
+    , append = \key extra -> do
+          call info "Appending to a resource"
+          mresource <- call findById key
+          case mresource of
+            Nothing -> do
+                pure False
+            Just resource -> do
+                call putById key (resource ++ extra) 
+                pure True
+    , inspect = \key -> do
+          call findById key 
+    }
+
+-- from purely Has-using to MonadDep-using
+-- this is very verbose, how to automate it?
+-- makeController'' :: forall e_ m . (Has Logger (DepT e_ m) (e_ (DepT e_ m)), Has Repository (DepT e_ m) (e_ (DepT e_ m)), Monad m) => Controller (DepT e_ m)
+-- makeController'' = Controller {
+--         create = askFinalDepT $ fmap create makeController
+--       , append = askFinalDepT $ fmap append makeController
+--       , inspect = askFinalDepT $ fmap inspect makeController
+--     }
+
+allocateMap :: ContT () IO (IORef (Map Int String))
+allocateMap = ContT $ bracket (newIORef Map.empty) pure
+
+makeController''' :: forall e_ m . (Has Logger (DepT e_ m) (e_ (DepT e_ m)), Has Repository (DepT e_ m) (e_ (DepT e_ m)), Monad m) => Controller (DepT e_ m)
+makeController''' = component makeController
+
+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 stock Generic
+    deriving anyclass (Phased, DemotableFieldNames, FieldsFindableByType)
+
+deriving via Autowired (EnvHKD Identity m) instance Autowireable r_ m (EnvHKD Identity m) => Has r_ m (EnvHKD Identity m)
+
+parseConf :: FromJSON a => Configurator a
+parseConf = Kleisli parseJSON
+
+type Configurator = Kleisli Parser Value 
+
+type Allocator = ContT () IO
+
+type Phases = Configurator `Compose` Allocator `Compose` Identity
+
+env :: EnvHKD Phases (DepT (EnvHKD Identity) IO)
+env = EnvHKD {
+      logger = 
+        parseConf `bindPhase` \(LoggerConfiguration {messagePrefix}) -> 
+        skipPhase @Allocator $
+        pure $ component (makeStdoutLogger messagePrefix)
+    , repository = 
+        skipPhase @Configurator $
+        allocateMap `bindPhase` \ref -> 
+        pure $ component (makeInMemoryRepository ref)
+    , controller = 
+        skipPhase @Configurator $
+        skipPhase @Allocator $ 
+        pure $ component makeController
+}
+
+testEnvConstruction :: Assertion
+testEnvConstruction = do
+    let parseResult = eitherDecode' (fromString "{ \"logger\" : { \"messagePrefix\" : \"[foo]\" }, \"repository\" : null, \"controller\" : null }")
+    print parseResult 
+    let Right value = parseResult 
+        Kleisli (withObject "configuration" -> parser) = 
+              pullPhase @(Kleisli Parser Object) 
+            $ mapPhaseWithFieldNames 
+                (\fieldName (Kleisli f) -> Kleisli \o -> explicitParseField f o (fromString fieldName)) 
+            $ env
+        Right allocators = parseEither parser value 
+    runContT (pullPhase @Allocator allocators) \(pure -> deppie) -> do
+        resourceId <- runFromDep deppie create
+        runFromDep deppie append resourceId "foo"
+        runFromDep deppie append resourceId "bar"
+        Just result <- runFromDep deppie inspect resourceId
+        assertEqual "" "foobar" $ result
+
+tests :: TestTree
+tests =
+  testGroup
+    "All"
+    [
+     testCase "environmentConstruction" testEnvConstruction
+    ]
+
+main :: IO ()
+main = defaultMain tests