{-# 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).