{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- | This module is not required to use 'Cauldron's, but it provides a 'Builder' monad which lets you
-- define them in a manner which more closely resembles the syntax of wiring things \"manually\" in 'IO' or 'Managed'.
--
-- >>> :{
-- data Foo
--   = EndFoo
--   | FooToBar Bar
--   deriving stock (Show)
-- --
-- data Bar
--   = EndBar
--   | BarToFoo Foo
--   deriving stock (Show)
-- --
-- newtype Serializer a = Serializer {runSerializer :: a -> String}
-- --
-- makeFooSerializer :: Serializer Bar -> Serializer Foo
-- makeFooSerializer Serializer {runSerializer = runBar} =
--   Serializer
--     { runSerializer = \case
--         EndFoo -> ".EndFoo"
--         FooToBar bar -> ".FooToBar" ++ runBar bar
--     }
-- --
-- makeBarSerializer :: Serializer Foo -> Serializer Bar
-- makeBarSerializer Serializer {runSerializer = runFoo} =
--   Serializer
--     { runSerializer = \case
--         EndBar -> ".EndBar"
--         BarToFoo foo -> ".BarToFoo" ++ runFoo foo
--     }
-- --
-- builder :: Builder Identity ()
-- builder = mdo
--   foo <- _val_ $ makeFooSerializer <$> bar
--   bar <- _val_ $ makeBarSerializer <$> foo
--   pure ()
-- --
-- cauldron :: Either DuplicateBeans (Cauldron Identity)
-- cauldron = execBuilder builder
-- :}
--
-- Note that in the 'Builder' monad the values that we bind with @<-@ when using
-- functions like 'add', '_val_', or '_eff_' are really 'Args' values which
-- merely carry type information. We can dispense with them and use 'arg' or
-- 'wire' instead:
--
-- >>> :{
-- builder2 :: Builder Identity ()
-- builder2 = mdo
--   _ <- add $ val_ $ makeFooSerializer <$> arg
--   _ <- _val_ $ wire makeBarSerializer
--   pure ()
-- :}
module Cauldron.Builder
  ( Builder,
    add,
    execBuilder,

    -- * Two beans of the same type are forbidden
    DuplicateBeans (..),
    prettyDuplicateBeans,
    prettyDuplicateBeansLines,

    -- * Being polymorphic on the wiring monad
    MonadWiring (..),
    _ioEff_,
  )
where

import Cauldron
import Cauldron.Args
import Cauldron.Managed
import Control.Exception (Exception (..))
import Control.Monad.Fix
import Control.Monad.IO.Class
import Data.Dynamic
import Data.Foldable qualified
import Data.Function ((&))
import Data.Functor.Identity
import Data.Kind
import Data.List qualified
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Sequence (Seq)
import Data.Sequence qualified
import Data.Typeable
import GHC.Exception (CallStack, prettyCallStackLines)
import GHC.Stack (HasCallStack, callStack, withFrozenCallStack)

data Builder m a = Builder (Cauldron m) (Map TypeRep (Seq CallStack)) a
  deriving stock ((forall a b. (a -> b) -> Builder m a -> Builder m b)
-> (forall a b. a -> Builder m b -> Builder m a)
-> Functor (Builder m)
forall a b. a -> Builder m b -> Builder m a
forall a b. (a -> b) -> Builder m a -> Builder m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (m :: * -> *) a b. a -> Builder m b -> Builder m a
forall (m :: * -> *) a b. (a -> b) -> Builder m a -> Builder m b
$cfmap :: forall (m :: * -> *) a b. (a -> b) -> Builder m a -> Builder m b
fmap :: forall a b. (a -> b) -> Builder m a -> Builder m b
$c<$ :: forall (m :: * -> *) a b. a -> Builder m b -> Builder m a
<$ :: forall a b. a -> Builder m b -> Builder m a
Functor)

combineCallStackMaps :: Map TypeRep (Seq CallStack) -> Map TypeRep (Seq CallStack) -> Map TypeRep (Seq CallStack)
combineCallStackMaps :: Map TypeRep (Seq CallStack)
-> Map TypeRep (Seq CallStack) -> Map TypeRep (Seq CallStack)
combineCallStackMaps = (Seq CallStack -> Seq CallStack -> Seq CallStack)
-> Map TypeRep (Seq CallStack)
-> Map TypeRep (Seq CallStack)
-> Map TypeRep (Seq CallStack)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Seq CallStack -> Seq CallStack -> Seq CallStack
forall a. Seq a -> Seq a -> Seq a
(Data.Sequence.><)

instance Applicative (Builder m) where
  pure :: forall a. a -> Builder m a
pure a
a = Cauldron m -> Map TypeRep (Seq CallStack) -> a -> Builder m a
forall (m :: * -> *) a.
Cauldron m -> Map TypeRep (Seq CallStack) -> a -> Builder m a
Builder Cauldron m
forall (m :: * -> *). Cauldron m
Cauldron.empty Map TypeRep (Seq CallStack)
forall k a. Map k a
Map.empty a
a
  Builder Cauldron m
c1 Map TypeRep (Seq CallStack)
m1 a -> b
f <*> :: forall a b. Builder m (a -> b) -> Builder m a -> Builder m b
<*> Builder Cauldron m
c2 Map TypeRep (Seq CallStack)
m2 a
a2 =
    Cauldron m -> Map TypeRep (Seq CallStack) -> b -> Builder m b
forall (m :: * -> *) a.
Cauldron m -> Map TypeRep (Seq CallStack) -> a -> Builder m a
Builder (Cauldron m
c1 Cauldron m -> Cauldron m -> Cauldron m
forall a. Semigroup a => a -> a -> a
<> Cauldron m
c2) (Map TypeRep (Seq CallStack)
-> Map TypeRep (Seq CallStack) -> Map TypeRep (Seq CallStack)
combineCallStackMaps Map TypeRep (Seq CallStack)
m1 Map TypeRep (Seq CallStack)
m2) (a -> b
f a
a2)

instance Monad (Builder m) where
  (Builder Cauldron m
c1 Map TypeRep (Seq CallStack)
m1 a
a) >>= :: forall a b. Builder m a -> (a -> Builder m b) -> Builder m b
>>= a -> Builder m b
k =
    let Builder Cauldron m
c2 Map TypeRep (Seq CallStack)
m2 b
r = a -> Builder m b
k a
a
     in Cauldron m -> Map TypeRep (Seq CallStack) -> b -> Builder m b
forall (m :: * -> *) a.
Cauldron m -> Map TypeRep (Seq CallStack) -> a -> Builder m a
Builder (Cauldron m
c1 Cauldron m -> Cauldron m -> Cauldron m
forall a. Semigroup a => a -> a -> a
<> Cauldron m
c2) (Map TypeRep (Seq CallStack)
-> Map TypeRep (Seq CallStack) -> Map TypeRep (Seq CallStack)
combineCallStackMaps Map TypeRep (Seq CallStack)
m1 Map TypeRep (Seq CallStack)
m2) b
r

instance MonadFix (Builder m) where
  mfix :: forall a. (a -> Builder m a) -> Builder m a
mfix a -> Builder m a
f =
    let b :: Builder m a
b = a -> Builder m a
f a
a
        ~(Builder Cauldron m
_ Map TypeRep (Seq CallStack)
_ a
a) = Builder m a
b
     in Builder m a
b

execBuilder :: Builder m a -> Either DuplicateBeans (Cauldron m)
execBuilder :: forall (m :: * -> *) a.
Builder m a -> Either DuplicateBeans (Cauldron m)
execBuilder (Builder Cauldron m
c Map TypeRep (Seq CallStack)
m a
_) =
  let beanDefinitions :: Map TypeRep (CallStack, CallStack, [CallStack])
beanDefinitions =
        Map TypeRep (Seq CallStack)
m
          Map TypeRep (Seq CallStack)
-> (Map TypeRep (Seq CallStack)
    -> Map TypeRep (CallStack, CallStack, [CallStack]))
-> Map TypeRep (CallStack, CallStack, [CallStack])
forall a b. a -> (a -> b) -> b
& (Seq CallStack -> Maybe (CallStack, CallStack, [CallStack]))
-> Map TypeRep (Seq CallStack)
-> Map TypeRep (CallStack, CallStack, [CallStack])
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe \case
            CallStack
c1 Data.Sequence.:<| CallStack
c2 Data.Sequence.:<| Seq CallStack
rest -> (CallStack, CallStack, [CallStack])
-> Maybe (CallStack, CallStack, [CallStack])
forall a. a -> Maybe a
Just (CallStack
c1, CallStack
c2, Seq CallStack -> [CallStack]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Data.Foldable.toList Seq CallStack
rest)
            Seq CallStack
_ -> Maybe (CallStack, CallStack, [CallStack])
forall a. Maybe a
Nothing
   in if (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Map TypeRep (CallStack, CallStack, [CallStack]) -> Bool
forall a. Map TypeRep a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
Data.Foldable.null Map TypeRep (CallStack, CallStack, [CallStack])
beanDefinitions)
        then DuplicateBeans -> Either DuplicateBeans (Cauldron m)
forall a b. a -> Either a b
Left (DuplicateBeans -> Either DuplicateBeans (Cauldron m))
-> DuplicateBeans -> Either DuplicateBeans (Cauldron m)
forall a b. (a -> b) -> a -> b
$ Map TypeRep (CallStack, CallStack, [CallStack]) -> DuplicateBeans
DuplicateBeans Map TypeRep (CallStack, CallStack, [CallStack])
beanDefinitions
        else Cauldron m -> Either DuplicateBeans (Cauldron m)
forall a b. b -> Either a b
Right Cauldron m
c

-- | Because cauldron inject dependencies based on their types, a do-notation block which
-- binds two or more values of the same type would be ambiguous.
--
-- >>> :{
-- builderOops :: Builder Identity ()
-- builderOops = do
--   foo1 <- _val_ $ pure (5 :: Int)
--   foo2 <- _val_ $ pure (6 :: Int)
--   pure ()
-- :}
--
-- >>> :{
-- case execBuilder builderOops of
--    Left (DuplicateBeans _) -> "this should be the result"
--    Right _ -> "won't happen"
-- :}
-- "this should be the result"
data DuplicateBeans = DuplicateBeans (Map TypeRep (CallStack, CallStack, [CallStack]))
  deriving stock (Int -> DuplicateBeans -> ShowS
[DuplicateBeans] -> ShowS
DuplicateBeans -> String
(Int -> DuplicateBeans -> ShowS)
-> (DuplicateBeans -> String)
-> ([DuplicateBeans] -> ShowS)
-> Show DuplicateBeans
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DuplicateBeans -> ShowS
showsPrec :: Int -> DuplicateBeans -> ShowS
$cshow :: DuplicateBeans -> String
show :: DuplicateBeans -> String
$cshowList :: [DuplicateBeans] -> ShowS
showList :: [DuplicateBeans] -> ShowS
Show)

instance Exception DuplicateBeans where
  displayException :: DuplicateBeans -> String
displayException = DuplicateBeans -> String
prettyDuplicateBeans

prettyDuplicateBeans :: DuplicateBeans -> String
prettyDuplicateBeans :: DuplicateBeans -> String
prettyDuplicateBeans = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
Data.List.intercalate String
"\n" ([String] -> String)
-> (DuplicateBeans -> [String]) -> DuplicateBeans -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DuplicateBeans -> [String]
prettyDuplicateBeansLines

prettyDuplicateBeansLines :: DuplicateBeans -> [String]
prettyDuplicateBeansLines :: DuplicateBeans -> [String]
prettyDuplicateBeansLines (DuplicateBeans Map TypeRep (CallStack, CallStack, [CallStack])
beanMap) =
  [ String
"Some bean types defined more than once in builder:"
  ]
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ( Map TypeRep (CallStack, CallStack, [CallStack])
beanMap Map TypeRep (CallStack, CallStack, [CallStack])
-> (Map TypeRep (CallStack, CallStack, [CallStack]) -> [String])
-> [String]
forall a b. a -> (a -> b) -> b
& (TypeRep -> (CallStack, CallStack, [CallStack]) -> [String])
-> Map TypeRep (CallStack, CallStack, [CallStack]) -> [String]
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey \TypeRep
rep (CallStack
c1, CallStack
c2, [CallStack]
rest) ->
           ( [ String
"- Bean type " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show TypeRep
rep String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" was defined in these locations:"
             ]
               [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ( (CallStack
c1 CallStack -> [CallStack] -> [CallStack]
forall a. a -> [a] -> [a]
: CallStack
c2 CallStack -> [CallStack] -> [CallStack]
forall a. a -> [a] -> [a]
: [CallStack]
rest) [CallStack] -> ([CallStack] -> [String]) -> [String]
forall a b. a -> (a -> b) -> b
& (CallStack -> [String]) -> [CallStack] -> [String]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap \CallStack
location ->
                      ((String
"\t" String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CallStack -> [String]
prettyCallStackLines CallStack
location)
                  )
           )
       )

-- | Add a 'Recipe' to the 'Cauldron' that is being built.
add ::
  forall {recipelike} {m} (bean :: Type).
  (Typeable bean, ToRecipe recipelike, HasCallStack) =>
  -- | A 'Recipe' or a 'Constructor'.
  recipelike m bean ->
  Builder m (Args bean)
add :: forall {recipelike :: (* -> *) -> * -> *} {m :: * -> *} bean.
(Typeable bean, ToRecipe recipelike, HasCallStack) =>
recipelike m bean -> Builder m (Args bean)
add recipelike m bean
recipelike =
  Cauldron m
-> Map TypeRep (Seq CallStack)
-> Args bean
-> Builder m (Args bean)
forall (m :: * -> *) a.
Cauldron m -> Map TypeRep (Seq CallStack) -> a -> Builder m a
Builder
    (Cauldron m
forall (m :: * -> *). Cauldron m
Cauldron.empty Cauldron m -> (Cauldron m -> Cauldron m) -> Cauldron m
forall a b. a -> (a -> b) -> b
& recipelike m bean -> Cauldron m -> Cauldron m
forall {recipelike :: (* -> *) -> * -> *} {m :: * -> *} bean.
(Typeable bean, ToRecipe recipelike, HasCallStack) =>
recipelike m bean -> Cauldron m -> Cauldron m
Cauldron.insert recipelike m bean
recipelike)
    (TypeRep -> Seq CallStack -> Map TypeRep (Seq CallStack)
forall k a. k -> a -> Map k a
Map.singleton (Proxy bean -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @bean)) (CallStack -> Seq CallStack
forall a. a -> Seq a
Data.Sequence.singleton CallStack
HasCallStack => CallStack
callStack))
    (forall a. Typeable a => Args a
arg @bean)

-- | This class allows you to define polymorphic \"wirings\" which can work in
-- the 'Builder' monad to produce 'Cauldron's, but also wire beans directly in
-- 'IO' or 'Managed'.
--
-- If we limit ourselves exclusively to the methods of this class, it's not
-- possible to define decorators or secondary beans.
--
-- This class can help migrating from \"direct\"-style wirings to 'Cauldron's.
--
-- >>> :{
-- data A = A deriving Show
-- data B = B deriving Show
-- data C = C deriving Show
-- makeA :: A
-- makeA = A
-- makeB :: A -> B
-- makeB = \_ -> B
-- makeC :: A -> B -> IO C
-- makeC = \_ _ -> pure C
-- instantiations :: (Builder IO (Args C), IO (Identity C))
-- instantiations =
--    let polymorphicWiring = do
--           a <- _val_ $ pure makeA
--           b <- _val_ $ makeB <$> a
--           c <- _ioEff_ $ makeC <$> a <*> b
--           pure c
--     in (polymorphicWiring, polymorphicWiring)
-- :}
class (Monad m, Applicative (ArgsApplicative m), Monad (ConstructorMonad m)) => MonadWiring m where
  -- | Wraps every bean type that we bind using methods of this class.
  -- Will be 'Args' for 'Builder', but simply 'Identity' for 'IO' and 'Managed'.
  type ArgsApplicative m :: Type -> Type

  -- | The monad in which constructors have effects.
  type ConstructorMonad m :: Type -> Type

  _val_ :: (Typeable bean, HasCallStack) => ArgsApplicative m bean -> m (ArgsApplicative m bean)
  _eff_ :: (Typeable bean, HasCallStack) => ArgsApplicative m (ConstructorMonad m bean) -> m (ArgsApplicative m bean)

-- | Like '_eff_', but lifts 'IO' constructor effects into a general 'MonadIO'.
_ioEff_ ::
  (MonadWiring m, MonadIO (ConstructorMonad m), Typeable bean, HasCallStack) =>
  ArgsApplicative m (IO bean) ->
  m (ArgsApplicative m bean)
_ioEff_ :: forall (m :: * -> *) bean.
(MonadWiring m, MonadIO (ConstructorMonad m), Typeable bean,
 HasCallStack) =>
ArgsApplicative m (IO bean) -> m (ArgsApplicative m bean)
_ioEff_ ArgsApplicative m (IO bean)
args = (HasCallStack => m (ArgsApplicative m bean))
-> m (ArgsApplicative m bean)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m (ArgsApplicative m bean))
 -> m (ArgsApplicative m bean))
-> (HasCallStack => m (ArgsApplicative m bean))
-> m (ArgsApplicative m bean)
forall a b. (a -> b) -> a -> b
$ ArgsApplicative m (ConstructorMonad m bean)
-> m (ArgsApplicative m bean)
forall bean.
(Typeable bean, HasCallStack) =>
ArgsApplicative m (ConstructorMonad m bean)
-> m (ArgsApplicative m bean)
forall (m :: * -> *) bean.
(MonadWiring m, Typeable bean, HasCallStack) =>
ArgsApplicative m (ConstructorMonad m bean)
-> m (ArgsApplicative m bean)
_eff_ (ArgsApplicative m (ConstructorMonad m bean)
 -> m (ArgsApplicative m bean))
-> ArgsApplicative m (ConstructorMonad m bean)
-> m (ArgsApplicative m bean)
forall a b. (a -> b) -> a -> b
$ IO bean -> ConstructorMonad m bean
forall a. IO a -> ConstructorMonad m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO bean -> ConstructorMonad m bean)
-> ArgsApplicative m (IO bean)
-> ArgsApplicative m (ConstructorMonad m bean)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgsApplicative m (IO bean)
args

instance (Monad m) => MonadWiring (Builder m) where
  type ArgsApplicative (Builder m) = Args
  type ConstructorMonad (Builder m) = m
  _val_ :: (Typeable bean, HasCallStack) => Args bean -> Builder m (Args bean)
  _val_ :: forall bean.
(Typeable bean, HasCallStack) =>
Args bean -> Builder m (Args bean)
_val_ Args bean
v = (HasCallStack => Builder m (Args bean)) -> Builder m (Args bean)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Builder m (Args bean)) -> Builder m (Args bean))
-> (HasCallStack => Builder m (Args bean)) -> Builder m (Args bean)
forall a b. (a -> b) -> a -> b
$ Constructor m bean -> Builder m (Args bean)
forall {recipelike :: (* -> *) -> * -> *} {m :: * -> *} bean.
(Typeable bean, ToRecipe recipelike, HasCallStack) =>
recipelike m bean -> Builder m (Args bean)
add (Args bean -> Constructor m bean
forall bean (m :: * -> *).
(Applicative m, HasCallStack) =>
Args bean -> Constructor m bean
val_ Args bean
v)
  _eff_ :: (Typeable bean, HasCallStack) => Args (m bean) -> Builder m (Args bean)
  _eff_ :: forall bean.
(Typeable bean, HasCallStack) =>
Args (m bean) -> Builder m (Args bean)
_eff_ Args (m bean)
action = (HasCallStack => Builder m (Args bean)) -> Builder m (Args bean)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Builder m (Args bean)) -> Builder m (Args bean))
-> (HasCallStack => Builder m (Args bean)) -> Builder m (Args bean)
forall a b. (a -> b) -> a -> b
$ Constructor m bean -> Builder m (Args bean)
forall {recipelike :: (* -> *) -> * -> *} {m :: * -> *} bean.
(Typeable bean, ToRecipe recipelike, HasCallStack) =>
recipelike m bean -> Builder m (Args bean)
add (Args (m bean) -> Constructor m bean
forall bean (m :: * -> *).
(Functor m, HasCallStack) =>
Args (m bean) -> Constructor m bean
eff_ Args (m bean)
action)

instance MonadWiring IO where
  type ArgsApplicative IO = Identity
  type ConstructorMonad IO = IO
  _val_ :: Identity bean -> IO (Identity bean)
  _val_ :: forall bean. Identity bean -> IO (Identity bean)
_val_ = Identity bean -> IO (Identity bean)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  _eff_ :: Identity (IO bean) -> IO (Identity bean)
  _eff_ :: forall bean. Identity (IO bean) -> IO (Identity bean)
_eff_ = Identity (IO bean) -> IO (Identity bean)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => Identity (m a) -> m (Identity a)
sequence

instance MonadWiring Managed where
  type ArgsApplicative Managed = Identity
  type ConstructorMonad Managed = Managed
  _val_ :: Identity a -> Managed (Identity a)
  _val_ :: forall a. Identity a -> Managed (Identity a)
_val_ = Identity a -> Managed (Identity a)
forall a. a -> Managed a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  _eff_ :: Identity (Managed a) -> Managed (Identity a)
  _eff_ :: forall a. Identity (Managed a) -> Managed (Identity a)
_eff_ = Identity (Managed a) -> Managed (Identity a)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => Identity (m a) -> m (Identity a)
sequence

-- $setup
-- >>> :set -XBlockArguments
-- >>> :set -XOverloadedLists
-- >>> :set -XLambdaCase
-- >>> :set -XRecursiveDo
-- >>> :set -XDerivingStrategies
-- >>> :set -Wno-incomplete-uni-patterns
-- >>> import Data.Functor.Identity
-- >>> import Data.Function ((&))
-- >>> import Data.Monoid
-- >>> import Data.Either (either)
-- >>> import Control.Exception (throwIO)