diff --git a/ffunctor.cabal b/ffunctor.cabal --- a/ffunctor.cabal +++ b/ffunctor.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: ffunctor -version: 1.1.0 +version: 1.1.99 synopsis: FFunctor typeclass license: BSD-3-Clause license-file: LICENSE @@ -16,11 +16,17 @@ . Useful to map over the type parameter in a record of functions, e.g. https://www.benjamin.pizza/posts/2017-12-15-functor-functors.html + and https://discourse.haskell.org/t/local-capabilities-with-mtl/231 source-repository head type: git location: https://gitlab.com/fommil/ffunctor - + +flag transformers + description: Compile with transformers utilities + manual: True + default: True + common deps build-depends: , base ^>= 4.11.1.0 || ^>= 4.12.0.0 ghc-options: -Wall @@ -31,6 +37,9 @@ import: deps hs-source-dirs: library exposed-modules: Data.FFunctor + if flag(transformers) + build-depends: , transformers + cpp-options: -DHAVE_TRANSFORMERS test-suite tests import: deps @@ -38,10 +47,12 @@ type: exitcode-stdio-1.0 main-is: Driver.hs other-modules: Data.FFunctor.ServantTest + , Data.FFunctor.TracingTest build-depends: , ffunctor , aeson ^>= 1.4.1.0 - , composition ^>= 1.0.2.1 + , exceptions ^>= 0.10.1 , mtl ^>= 2.2.2 + , generic-lens ^>= 1.1.0.0 , http-client ^>= 0.5.12 , servant ^>= 0.14.1 , servant-client ^>= 0.14 @@ -49,5 +60,6 @@ , tasty-hspec ^>= 1.1.5 , tasty-quickcheck ^>= 0.10 , time ^>= 1.8.0.2 + , universum ^>= 1.5.0 build-tool-depends: tasty-discover:tasty-discover ^>= 4.2.1 ghc-options: -threaded diff --git a/library/Data/FFunctor.hs b/library/Data/FFunctor.hs --- a/library/Data/FFunctor.hs +++ b/library/Data/FFunctor.hs @@ -1,11 +1,22 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE Rank2Types #-} -- | Functor of Functors module Data.FFunctor where +#ifdef HAVE_TRANSFORMERS +import Control.Monad.Trans.Class (MonadTrans, lift) +#endif + class FFunctor (f :: (* -> *) -> *) where --ffmap :: (Functor m, Functor n) => (m ~> n) -> f m -> f n ffmap :: (Functor m, Functor n) => (forall a . (m a -> n a)) -> f m -> f n --- TODO is there anything from stdlib that could have an instance? +#ifdef HAVE_TRANSFORMERS +-- | Lifts a record of functions (that has an FFunctor) into a monad transformer. +-- +-- e.g. `luft logger` lifts a `Logger m` into a `Logger (ReaderT m Foo)` +luft :: FFunctor f => Monad m => MonadTrans t => Functor (t m) => f m -> f (t m) +luft = ffmap lift +#endif diff --git a/test/Data/FFunctor/ServantTest.hs b/test/Data/FFunctor/ServantTest.hs --- a/test/Data/FFunctor/ServantTest.hs +++ b/test/Data/FFunctor/ServantTest.hs @@ -5,12 +5,13 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} +-- | Supporting code for https://discourse.haskell.org/t/local-capabilities-with-mtl/231 module Data.FFunctor.ServantTest where import Control.Monad.Error.Class (liftEither) import Control.Monad.Except import Data.Aeson hiding ((.:)) -import Data.Composition +import Universum.VarArg import Data.FFunctor import Data.Functor.Identity import Data.Proxy (Proxy (..)) @@ -93,7 +94,9 @@ -- Note that FFunctor is not the same shape as HFunctor, MFunctor or MonadTrans, -- although they are all related from a category theory point of view. instance FFunctor UserApi where - ffmap nt (UserApi f1 f2 f3) = UserApi (nt f1) (nt . f2) (nt .: f3) + ffmap nt (UserApi f1 f2 f3) = UserApi (nt f1) (nt ... f2) (nt ... f3) + -- or, with Data.Composition +--ffmap nt (UserApi f1 f2 f3) = UserApi (nt f1) (nt . f2) (nt .: f3) -- We need a natural transformation from ClientM into an arbitrary monad stack. -- The bare minimum requirements to do this are: @@ -136,14 +139,14 @@ doStuff http check = hasEmail <$> (runExceptT $ apiGetUsers http) where hasEmail (Left _) = False - hasEmail (Right users) = any (\u -> (email u) == check) users + hasEmail (Right users) = any ((== check) . email) users -- Compare to the version where errors are ignored and must be handled at a -- higher layer. doStuff' :: Applicative m => UserApi m -> String -> m Bool doStuff' http check = hasEmail <$> apiGetUsers http where - hasEmail users = any (\u -> (email u) == check) users + hasEmail users = any ((== check) . email) users -- Creating an instance of UserApiT is easy myApp :: IO Bool diff --git a/test/Data/FFunctor/TracingTest.hs b/test/Data/FFunctor/TracingTest.hs new file mode 100644 --- /dev/null +++ b/test/Data/FFunctor/TracingTest.hs @@ -0,0 +1,307 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} + +-- | Follow on to https://discourse.haskell.org/t/local-capabilities-with-mtl/231 +module Data.FFunctor.TracingTest where + +import Control.Monad.Catch +import Control.Monad.Reader +import Data.FFunctor +import Data.Function ((&)) +import Data.Generics.Product.Typed (HasType, getTyped, setTyped) +import Data.Time (UTCTime) +import Prelude hiding (span) +import Universum ((...)) + +-- In https://discourse.haskell.org/t/local-capabilities-with-mtl/231 we seen +-- how to localise or delegate capabilities such as error handling. This is a +-- follow up to address some of the shortcomings of the approach when a project +-- scales, to explain why people continue to explore alternatives to MTL and why +-- many Haskell developers do not consider application design to be a solved +-- problem. +-- +-- The code is available in https://gitlab.com/fommil/ffunctor/tree/master/test +-- +-- Let's say we have an application that can be modularised into several +-- capabilities: +-- +-- 1. a Logger, for writing out text messages +-- 2. an HTTP client, for talking to a webserver +-- 3. a Database client, for persisting state +-- 4. a Tracer, for distributed performance monitoring +-- +-- We could encode these capabilities as typeclasses but to have fine control over +-- which implementation is used in a given situation we are going to use records +-- of functions. +-- +-- The first 3 are fairly straightforward and may look like: + +data Logger m = Logger + { debug :: String -> m () + , info :: String -> m () + , warning :: String -> m () + } + +data Http m = Http + { getUsers :: m [String] + , postUser :: String -> m () + } + +data Database m = Database + { dbHistory :: m [String] + , dbAdd :: String -> m () + } + +-- The idea behind Tracing is that a server (e.g. Jaeger) receives a message +-- when opt-in computations begin and end across services in a distributed +-- system. Tracing is useful for operations monitoring and performance +-- profiling. +-- +-- A "trace" is a tree of spans that each contain a start time, an end time, and +-- a name. +-- +-- Spans typically have a lot of metadata associated to them but we'll keep it +-- simple for this example: + +data OpenSpan = OpenSpan + { spanStart :: UTCTime -- ^ when the span begins + , spanName :: String -- ^ user provided + , spanId :: Int -- ^ randomly generated + , spanParent :: Maybe Int -- ^ the id of the span that caused this + } + +-- We can implement the Tracer capability with two low-level operations: +-- creating a new span, and sending the current span to the tracing server, i.e. +-- closing the span: +data Tracer m = Tracer + { openSpan :: (Maybe Int) -- ^ id of the parent span + -> String -- ^ the name of this span + -> m OpenSpan -- ^ the new span + , closeSpan :: OpenSpan -> m () + } + +-- Tracer isn't a very practical API to use directly, so we introduce a more +-- convenient function that can handle errors with MonadMask. Before we do that, +-- it is useful to introduce an alias for the ability to read the currently open +-- span, and bracket any errors: +type MonadTraced m = (MonadReader OpenSpan m, MonadMask m) + +-- We can implement tracing very naturally with MonadReader.local and +-- MonadMask.finally, giving a nice API. +-- +-- (tracer & span) "foo" doFoo +span :: MonadTraced m => Tracer m -> String -> m a -> m a +span tracer name ma = do + OpenSpan{spanId} <- ask + child <- (tracer & openSpan) (Just spanId) name + local (const child) $ ma `finally` ((tracer & closeSpan) child) + +-- Aside: we are using the operator & which just flips the order of its two +-- parameters. (tracer & openSpan) is the same as (openSpan tracer) but gives a +-- visual indication that the `openSpan` function comes from the `tracer` record +-- of functions. + +-- Following the pattern from the previous letter, Local Capabilites with MTL, +-- it is useful to be able to declare a requirement with a monad transformer, +-- for situations where we can't change the constraints +type Traced = ReaderT OpenSpan + +-- An immediate usecase is that we need a way to create "root spans" that don't +-- have a parent and therefore do not require a MonadReader, e.g. +-- +-- (tracer & rootSpan) "foo" doFoo +rootSpan :: MonadMask m => Tracer m -> String -> (Traced m) a -> m a +rootSpan tracer name ma = do + child <- (tracer & openSpan) Nothing name + (runReaderT ma child) `finally` ((tracer & closeSpan) child) + +-- So far, this is a great application of MTL. But this letter is about when MTL +-- starts to get in the way so let's see how that can happen... say we have some +-- business logic that grabs the users from the HTTP client and adds everything +-- to the database. +-- +-- Because we are abstracting over m this will work for anything, whether it is +-- traced, untraced, or a dummy implementation for testing. +doStuff :: Monad m => Http m -> Database m -> m () +doStuff http db = do + users <- (http & getUsers) + void $ traverse (db & dbAdd) users + +-- But what if we only have implementations of `Http (Traced m)` and `Database +-- m`? This might be because our implementation of Http must pass a span's id +-- via a header, which is very standard. Our database doesn't have support for +-- tracing ids because the SQL standard doesn't support it. + +data HttpConfig = HttpConfig -- ... +mkUsers :: MonadIO m => MonadTraced m => MonadIO n => HttpConfig -> n (Http m) +mkUsers = undefined + +data DatabaseConfig = DatabaseConfig -- ... +mkDatabase :: MonadIO m => MonadIO n => DatabaseConfig -> n (Database m) +mkDatabase = undefined + +-- This is where things start to get tricky. The monad types must all align or +-- there will be a compilation error. +-- +-- We have three choices: +-- +-- 1. convert `Http (Traced m)` into a `Http m` +-- 2. convert `Database m` into a `Database (Traced m)` +-- 3. pass around all four versions and mix/match when we need them. +-- +-- Carrying around all combinations is not scalable, although we can already use +-- mkDatabase to construct both the Databases that we need. We won't, however, +-- be able to create a `Http m`. +-- +-- If we want to conjure the correct types when we need them, we'll need +-- Data.FFunctor, which allows us to map an (f m) into an (f (t m)). Let's +-- create some instances for our capabilities, using the `...` operator from +-- Universum to reduce the boilerplate + +instance FFunctor Logger where + ffmap nt (Logger p1 p2 p3) = Logger (nt ... p1) (nt ... p2) (nt ... p3) + +instance FFunctor Http where + ffmap nt (Http p1 p2) = Http (nt ... p1) (nt ... p2) + +instance FFunctor Database where + ffmap nt (Database p1 p2) = Database (nt ... p1) (nt ... p2) + +instance FFunctor Tracer where + ffmap nt (Tracer p1 p2) = Tracer (nt ... p1) (nt ... p2) + +-- Now we can convert a `Database m` into a `Database (Traced m)` by calling the +-- `luft` helper method from FFunctor (it is a simple alias for `ffmap lift`). +-- Typically we'd just write this inline as `luft db` +databaseTraced' :: Monad m => Database m -> Database (Traced m) +databaseTraced' = luft + +-- We might also want to opt-in to tracing inside the Database capability and +-- wrap each function call with a span. If we have written one of these we +-- probably always want to use it instead of the `luft`ed one. +-- +-- It's nice that we don't need to touch the underlying implementation to add +-- tracing. +databaseTraced :: MonadMask m => Tracer (Traced m) -> Database m -> Database (Traced m) +databaseTraced tracer db = + let db' = luft db + span' = tracer & span + in Database + (span' "Database.history" $ (db' & dbHistory)) + (\t -> span' "Database.add" $ (db' & dbAdd) t) + +-- Which is polymorphic... +class TracedCapability f where + nachziehen :: MonadMask m => f m -> f (Traced m) + +instance TracedCapability Database where + nachziehen = databaseTraced' + +-- Everything might want to provide a TracedCapability that is just `luft`, to +-- leave open the possibility of tracing in the future... or to document +-- possible cycles. +instance TracedCapability Logger where + nachziehen = luft +instance TracedCapability Tracer where + nachziehen = luft -- do not change this or tracing will be an infinite loop + +-- We can convert a traced capability into a capability that looks like it +-- doesn't do any tracing if we provide a parent span. e.g. convert a `Http +-- (Traced m)` into a `Http m` with `skizzieren ctx http`. +skizzieren :: FFunctor f => Functor m => OpenSpan -> f (Traced m) -> f m +skizzieren ctx = ffmap (flip runReaderT ctx) + +-- We need to know which Trace to use, and we might get that from a MonadReader. +-- Here's a convenience for that, but this would mean that we are in a context +-- where we can trace and we want to create capabilities that don't look like +-- they can trace, which is a bit of a strange situation to be in. +verfolgen :: FFunctor f => Functor m => MonadReader OpenSpan n => f (Traced m) -> n (f m) +verfolgen t = (\ctx -> ffmap (flip runReaderT ctx) t) <$> ask + +-- It is more likely that we don't have access to a MonadReader but we have a +-- Tracer capability, and we want some other capability to run within a new root +-- span. +zeichnen :: FFunctor f => MonadMask m => Tracer m -> String -> f (Traced m) -> f m +zeichnen tracer name = ffmap $ (tracer & rootSpan) name + +-- Let's pause. +-- +-- The fact that luft, nachziehen, skizzieren, verfolgen and zeichnen might be +-- needed at all, should be telling us that we've wandered into the territory of +-- conceptual overhead. We're manually aligning and wiring capabilities instead +-- of writing our business logic. That's not good hackers, that's not good. +-- +-- A lot of people pick one monad stack for their application and stick to that. +-- In the case of Tracer, that would mean everything gets a `(MonadReader (Maybe +-- OpenSpan))` and there is no need to luft... but we can no longer be sure that +-- we're adding a span to an existing tree vs creating a new root span. We end +-- up doing what untyped languages do: asserting behaviours with runtime tests. +-- +-- If we were to use typeclass encodings for Http and Database (i.e. classic +-- MTL) we might be able to write derivation rules that do a lot of the +-- conversions automatically, but it isn't long before we need to write +-- derivations that make use of advanced ghc extensions (e.g. +-- OverlappingInstances, IncoherentInstances, UndecidableInstances, etc)... and +-- we pay for it with boilerplate in our tests with newtypes and DerivingVia. Or +-- we have orphans and lose the ability to reason about what is running in any +-- given test, which is prone to breakages during refactorings. This can also be +-- a touchy subject as some people take the principled approach that all +-- typeclasses should have laws. +-- +-- Furthermore, if our application has a lot of capabilities, our business logic +-- can have long parameter lists of capabilities that we have to pass around. +-- Long parameter lists might be an indicator of a bad abstraction that needs +-- more layers, but there always seem to be a few capabilities (like logging and +-- tracing) that end up being needed everywhere. +-- +-- People create encoding such as +-- [`makeClassy`](https://hackage.haskell.org/package/lens-4.17/docs/Control-Lens-Combinators.html#v:makeClassy) +-- and +-- [`makeTypeclass`](https://github.com/etorreborre/registry/blob/master/doc/boilerplate.md) +-- to reduce the boilerplate of passing capabilities, at the cost of the mental +-- overhead of the encodings, and the quality of compiler error messages. +-- +-- That brings us to another problem with MTL: we can't have multiple +-- MonadReaders. So if we were to use a "classy" encoding (i.e. put capabilities +-- into a MonadReader) we would not be able to use MonadTraced. A workaround to +-- this is MORE LENSES. Here is an example replacement for MonadReader that uses +-- HasType from `generic-lens`: +type HasReader r r' m = (MonadReader r' m, HasType r r') + +ask_ :: HasReader r r' m => m r +ask_ = getTyped <$> ask + +local_ :: HasReader r r' m => (r -> r) -> m a -> m a +local_ f = local (\r' -> setTyped (f . getTyped $ r') r') + +-- We would have to redesign the Tracer to use HasReader, which means redundant +-- type parameters (more conceptual overhead) everywhere: +type MonadTraced_ m r' = (HasReader OpenSpan r' m, MonadMask m) +span_ :: MonadTraced_ m r' => Tracer m -> String -> m a -> m a +span_ tracer name ma = do + OpenSpan{spanId} <- ask_ + child <- (tracer & openSpan) (Just spanId) name + local_ (const child) $ ma `finally` ((tracer & closeSpan) child) + +-- In conclusion, we can use MTL with records of functions to gain a lot of type +-- safety around what our programs are capable of doing, but for non-trivial +-- projects, we will introduce boilerplate, conceptual overhead, and workarounds +-- to deal with the case when the monads don't align. We encounter similar +-- problems as ReaderT / MonadReader with error handling (ExceptT / MonadError) +-- and single-threaded statefulness (StateT / MonadState). +-- +-- "Classic" MTL, with typeclasses to encode capabilities, can reduce the +-- boilerplate in the main code but ends up costing just as much when tests are +-- considered. Ultimately, typeclasses are just records of functions with magic +-- wiring that usually do the right thing and sometimes don't. +-- +-- The emergence of boilerplate is good news, in a way, because when common +-- patterns emerge, it points to something fundamental... and a new solution +-- usually comes along to solve fundamental problems. +-- +-- I plan to follow up this letter with an exploration of the same ideas using +-- [`fused-effects`](https://hackage.haskell.org/package/fused-effects), which +-- is the first practical Free Monad encoding that can bracket errors and is +-- therefore of great interest (although there is no sign of concurrency yet).