{-# LANGUAGE AllowAmbiguousTypes      #-}
{-# LANGUAGE BlockArguments           #-}
{-# LANGUAGE DataKinds                #-}
{-# LANGUAGE FlexibleContexts         #-}
{-# LANGUAGE GADTs                    #-}
{-# LANGUAGE LambdaCase               #-}
{-# LANGUAGE PolyKinds                #-}
{-# LANGUAGE ScopedTypeVariables      #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TemplateHaskell          #-}
{-# LANGUAGE TypeApplications         #-}
{-# LANGUAGE TypeOperators            #-}

-- |
--   Module     : Polysemy.Methodology
--   License    : MIT
--   Stability  : experimental
--
-- Domain modelling algebra for polysemy.
module Polysemy.Methodology
  ( -- * Definition
    Methodology (..),
    process,

    -- * Eliminators
    runMethodologyPure,
    runMethodologySem,

    -- * Decomposition
    cutMethodology,
    cutMethodology',
    cutMethodology3,
    cutMethodology3',
    divideMethodology,
    divideMethodology',
    decideMethodology,
    decideMethodology',
    decomposeMethodology,
    decomposeMethodology',
    decomposeMethodology3,
    separateMethodologyInitial,
    endMethodologyInitial,
    separateMethodologyTerminal,
    endMethodologyTerminal,

    -- * Simplifcation
    fmapMethodology,
    fmapMethodology',
    fmap2Methodology,
    fmap2Methodology',
    pureMethodology,
    pureMethodology',
    bindMethodology,
    bindMethodology',
    traverseMethodology,
    traverseMethodology',
    mconcatMethodology,
    mconcatMethodology',

    -- * Other Effects
    teeMethodologyOutput,
    plugMethodologyInput,
    runMethodologyAsKVStore,
    runMethodologyAsKVStoreWithDefault,
    runMethodologyMappendPure,
    runMethodologyMappendSem,

    -- * Tracing
    traceMethodologyStart,
    traceMethodologyEnd,
    traceMethodologyAround,
  )
where

import           Control.Applicative (liftA2)
import           Control.Arrow       ((>>>))
import           Control.Monad       (join)
import           Data.Foldable       (fold)
import           Data.Functor        ((<&>))
import           Data.Kind           (Type)
import           Polysemy            (Members, Sem, intercept, interpret,
                                      makeSem, raise, raiseUnder, reinterpret2,
                                      reinterpret3)
import           Polysemy.Input      (Input, input)
import           Polysemy.KVStore    (KVStore, lookupKV)
import           Polysemy.Output     (Output, output)
import           Polysemy.Several    (HList (HNil, (:::)))
import           Polysemy.Trace      (Trace, trace)

-- | A `Methodology` generalises a semantic process from `b` to `c`.
type Methodology :: Type -> Type -> (Type -> Type) -> Type -> Type
data Methodology b c m a where
  Process :: b -> Methodology b c m c

makeSem ''Methodology

-- | Run a `Methodology` using a pure function.
--
-- @since 0.1.0.0
runMethodologyPure ::
  forall b c r a.
  -- | A function from b to c.
  (b -> c) ->
  Sem (Methodology b c ': r) a ->
  Sem r a
runMethodologyPure f = interpret \case
  Process b -> return $ f b
{-# INLINE runMethodologyPure #-}

-- | Run a `Methodology' using a monadic function with effects in `r`.
--
-- @since 0.1.0.0
runMethodologySem ::
  forall b c r a.
  -- | A monadic function from b to c using effects in r.
  (b -> Sem r c) ->
  Sem (Methodology b c ': r) a ->
  Sem r a
runMethodologySem f = interpret \case
  Process b -> f b
{-# INLINE runMethodologySem #-}

-- | Cut a `Methodology` into two pieces at a midpoint.
--
-- @since 0.1.0.0
cutMethodology ::
  forall b c d r a.
  Members
    '[ Methodology b c,
       Methodology c d
     ]
    r =>
  -- | Methodology effect to decompose.
  Sem (Methodology b d ': r) a ->
  Sem r a
cutMethodology = interpret \case
  Process b -> process @b @c b >>= process @c @d
{-# INLINE cutMethodology #-}

-- | Reinterpreting version of `cutMethodology`.
--
-- @since 0.1.6.0
cutMethodology' ::
  forall b c d r a.
  -- | Methodology effect to decompose.
  Sem (Methodology b d ': r) a ->
  Sem (Methodology b c ': Methodology c d ': r) a
cutMethodology' = reinterpret2 \case
  Process b -> process @b @c b >>= raise . process @c @d
{-# INLINE cutMethodology' #-}

-- | Cut a `Methodology` into three pieces using two cuts.
--
-- @since 0.1.0.0
cutMethodology3 ::
  forall b c d e r a.
  Members
    '[ Methodology b c,
       Methodology c d,
       Methodology d e
     ]
    r =>
  -- | Methodology effect to decompose.
  Sem (Methodology b e ': r) a ->
  Sem r a
cutMethodology3 = interpret \case
  Process b -> process @b @c b >>= process @c @d >>= process @d @e
{-# INLINE cutMethodology3 #-}

-- | Reinterpreting version of `cutMethodology`.
--
-- @since 0.1.6.0
cutMethodology3' ::
  forall b c d e r a.
  -- | Methodology effect to decompose.
  Sem (Methodology b d ': r) a ->
  Sem (Methodology b c ': Methodology c d ': Methodology d e ': r) a
cutMethodology3' = reinterpret3 \case
  Process b -> process @b @c b >>= raise . process @c @d
{-# INLINE cutMethodology3' #-}

-- | Divide a `Methodology` into two components using a `Methodology` that accepts a pair.`
--
-- @since 0.1.0.0
divideMethodology ::
  forall b c c' d r a.
  Members
    '[ Methodology b c,
       Methodology b c',
       Methodology (c, c') d
     ]
    r =>
  -- | Methodology effect to decompose.
  Sem (Methodology b d ': r) a ->
  Sem r a
divideMethodology = interpret \case
  Process b -> do
    c <- process @b @c b
    c' <- process @b @c' b
    process @(c, c') @d (c, c')
{-# INLINE divideMethodology #-}

-- | Reinterpreting version of `divideMethodology`.
--
-- @since 0.1.6.0
divideMethodology' ::
  forall b c c' d r a.
  Sem (Methodology b d ': r) a ->
  Sem (Methodology b c ': Methodology b c' ': Methodology (c, c') d ': r) a
divideMethodology' = reinterpret3 \case
  Process b -> do
    c <- process @b @c b
    c' <- raise $ process @b @c' b
    raise $ raise $ process @(c, c') @d (c, c')
{-# INLINE divideMethodology' #-}

-- | Decide between two `Methodology`s using a `Methodology` that computes an `Either`.
--
-- @since 0.1.0.0
decideMethodology ::
  forall b c c' d r a.
  Members
    '[ Methodology b (Either c c'),
       Methodology c d,
       Methodology c' d
     ]
    r =>
  -- | `Methodology effect to decompose.
  Sem (Methodology b d ': r) a ->
  Sem r a
decideMethodology = interpret \case
  Process b -> do
    k <- process @b @(Either c c') b
    case k of
      Left c   -> process @c @d c
      Right c' -> process @c' @d c'
{-# INLINE decideMethodology #-}

-- | Reinterpreting version of `decideMethodology`.
--
-- @since 0.1.6.0
decideMethodology' ::
  forall b c c' d r a.
  Sem (Methodology b d ': r) a ->
  Sem (Methodology b (Either c c') ': Methodology c d ': Methodology c' d ': r) a
decideMethodology' = reinterpret3 \case
  Process b -> do
    k <- process @b @(Either c c') b
    case k of
      Left c   -> raise $ process @c @d c
      Right c' -> raise $ raise $ process @c' @d c'
{-# INLINE decideMethodology' #-}

-- | Tee the output of a `Methodology`, introducing a new `Output` effect to be handled.
--
-- @since 0.1.0.0
teeMethodologyOutput ::
  forall b c r a.
  Members
    '[ Output c,
       Methodology b c
     ]
    r =>
  Sem r a ->
  Sem r a
teeMethodologyOutput = intercept @(Methodology b c) \case
  Process b -> do
    k <- process @b @c b
    output @c k
    return k
{-# INLINE teeMethodologyOutput #-}

-- | Make a `Methodology` depend on an additional input, introducing a new `Input` effect to be handled.
--
-- @since 0.1.0.0
plugMethodologyInput ::
  forall b c d r a.
  Members '[Input b, Methodology (b, c) d] r =>
  Sem (Methodology c d ': r) a ->
  Sem r a
plugMethodologyInput = interpret \case
  Process b -> do
    k <- input @b
    process @(b, c) @d (k, b)
{-# INLINE plugMethodologyInput #-}

-- | Run a `Methodology` as a `KVStore`, using the input as a key and the output as the value.
--
-- @since 0.1.0.0
runMethodologyAsKVStore ::
  forall k v r a.
  Members '[KVStore k v] r =>
  Sem (Methodology k (Maybe v) ': r) a ->
  Sem r a
runMethodologyAsKVStore = interpret \case
  Process k -> lookupKV k
{-# INLINE runMethodologyAsKVStore #-}

-- | Run a `Methodology` as a `KVStore`, with a default value for lookup failure.
--
-- @since 0.1.0.0
runMethodologyAsKVStoreWithDefault ::
  forall k v r a.
  Members '[KVStore k v] r =>
  -- | A default value v.
  v ->
  Sem (Methodology k v ': r) a ->
  Sem r a
runMethodologyAsKVStoreWithDefault d = interpret \case
  Process k -> do
    z <- lookupKV k
    case z of
      Just a  -> return a
      Nothing -> return d
{-# INLINE runMethodologyAsKVStoreWithDefault #-}

-- | Run a `Methodology` targetting a `Monoid` without consuming it, pure version. This should probably be considered an
-- anti-pattern, and it's probably better to decompose the inputs fully, but is otherwise sound.
--
-- @since 0.1.8.0
runMethodologyMappendPure ::
  forall b c r a.
  ( Monoid c,
    Members '[Methodology b c] r
  ) =>
  (b -> c) ->
  Sem r a ->
  Sem r a
runMethodologyMappendPure f = intercept @(Methodology b c) \case
  Process b -> (f b <>) <$> process @b @c b
{-# INLINE runMethodologyMappendPure #-}

-- | Run a `Methodology` targetting a `Monoid` without consuming it, `Sem` version. This should probably be considered an
-- anti-pattern, and it's probably better to decompose the inputs fully, but is otherwise sound.
--
-- @since 0.1.8.0
runMethodologyMappendSem ::
  forall b c r a.
  ( Monoid c,
    Members '[Methodology b c] r
  ) =>
  (b -> Sem r c) ->
  Sem r a ->
  Sem r a
runMethodologyMappendSem f = intercept @(Methodology b c) \case
  Process b -> liftA2 (<>) (f b) (process @b @c b)
{-# INLINE runMethodologyMappendSem #-}

-- | Decompose a `Methodology` into several components to be recombined. This is `cutMethodology` specialised to `HList`.
--
-- @since 0.1.0.0
decomposeMethodology ::
  forall b f c r a.
  Members
    '[ Methodology b (HList f),
       Methodology (HList f) c
     ]
    r =>
  Sem (Methodology b c ': r) a ->
  Sem r a
decomposeMethodology = cutMethodology @b @(HList f) @c
{-# INLINE decomposeMethodology #-}

-- | Reinterpreting version of `decomposeMethodology`.
--
-- @since 0.1.6.0
decomposeMethodology' ::
  forall b f c r a.
  Sem (Methodology b c ': r) a ->
  Sem (Methodology b (HList f) ': Methodology (HList f) c ': r) a
decomposeMethodology' = cutMethodology' @b @(HList f) @c
{-# INLINE decomposeMethodology' #-}

-- | Decompose a `Methodology` into several components over three sections with two cuts.
--
-- @since 0.1.0.0
decomposeMethodology3 ::
  forall b f g c r a.
  Members
    '[ Methodology b (HList f),
       Methodology (HList f) (HList g),
       Methodology (HList g) c
     ]
    r =>
  Sem (Methodology b c ': r) a ->
  Sem r a
decomposeMethodology3 = cutMethodology3 @b @(HList f) @(HList g) @c
{-# INLINE decomposeMethodology3 #-}

-- | Factor a `Methodology` decomposed over an `HList` in the result by a `Methodology` to the first variable.
--
-- @since 0.1.0.0
separateMethodologyInitial ::
  forall b x xs r a.
  Members
    '[ Methodology b (HList xs),
       Methodology b x
     ]
    r =>
  Sem (Methodology b (HList (x ': xs)) ': r) a ->
  Sem r a
separateMethodologyInitial = interpret \case
  Process b -> do
    k <- process @b @x b
    k' <- process @b @(HList xs) b
    return $ k ::: k'
{-# INLINE separateMethodologyInitial #-}

-- | Finish an `HList` separated `Methodology` by consuming it for no effect.
--
-- @since 0.1.0.0
endMethodologyInitial ::
  Sem (Methodology b (HList '[]) ': r) a ->
  Sem r a
endMethodologyInitial = interpret \case
  Process _ -> return HNil
{-# INLINE endMethodologyInitial #-}

-- | Factor a `Methodology` decomposed over an `HList` in the source by a
-- `Methodology` from the first variable. Assumes the result is a `Monoid`.
--
-- @since 0.1.0.0
separateMethodologyTerminal ::
  forall x c xs r a.
  ( Monoid c,
    Members
      '[ Methodology (HList xs) c,
         Methodology x c
       ]
      r
  ) =>
  Sem (Methodology (HList (x ': xs)) c ': r) a ->
  Sem r a
separateMethodologyTerminal = interpret \case
  Process (b ::: bs) -> do
    k <- process @x @c b
    k' <- process @(HList xs) @c bs
    return $ k <> k'
{-# INLINE separateMethodologyTerminal #-}

-- | Finalise an `HList` separated `Methodology` in the source by returning the `Monoid` unit.
--
-- @since 0.1.0.0
endMethodologyTerminal ::
  Monoid c =>
  Sem (Methodology (HList '[]) c ': r) a ->
  Sem r a
endMethodologyTerminal = interpret \case
  Process _ -> return mempty
{-# INLINE endMethodologyTerminal #-}

-- | Run a `Methodology` (f b) (f c) by way of a `Methodology` b c. Note that
-- `f` must be `Traversable`.
--
-- @since 0.1.2.0
fmapMethodology ::
  forall f b c r a.
  ( Members '[Methodology b c] r,
    Traversable f
  ) =>
  Sem (Methodology (f b) (f c) ': r) a ->
  Sem r a
fmapMethodology = interpret \case
  Process b -> traverse (process @b @c) b
{-# INLINE fmapMethodology #-}

-- | Reinterpreting version of `fmapMethodology`.
--
-- @since 0.1.6.0
fmapMethodology' ::
  forall f b c r a.
  Traversable f =>
  Sem (Methodology (f b) (f c) ': r) a ->
  Sem (Methodology b c ': r) a
fmapMethodology' = raiseUnder >>> fmapMethodology
{-# INLINE fmapMethodology' #-}

-- | Run a `Methodology` (f (g b)) (f (g c))) by way of a `Methodology` b c. Note that
-- `f` and `g` must be `Traversable`.
--
-- @since 0.1.2.0
fmap2Methodology ::
  forall f g b c r a.
  ( Members '[Methodology b c] r,
    Traversable f,
    Traversable g
  ) =>
  Sem (Methodology (f (g b)) (f (g c)) ': r) a ->
  Sem r a
fmap2Methodology = fmapMethodology' @f @(g b) @(g c) >>> fmapMethodology @g @b @c
{-# INLINE fmap2Methodology #-}

-- | Reinterpreting version of `fmap2Methodology`.
--
-- @since 0.1.6.0
fmap2Methodology' ::
  forall f g b c r a.
  (Traversable f, Traversable g) =>
  Sem (Methodology (f (g b)) (f (g c)) ': r) a ->
  Sem (Methodology b c ': r) a
fmap2Methodology' = raiseUnder >>> fmap2Methodology
{-# INLINE fmap2Methodology' #-}

-- | Run a `Methodology` b (f c) in terms of a `Methodology` b c.
--
-- @since 0.1.7.0
pureMethodology ::
  forall f b c r a.
  (Members '[Methodology b c] r, Applicative f) =>
  Sem (Methodology b (f c) ': r) a ->
  Sem r a
pureMethodology = interpret \case
  Process b -> pure <$> process @b @c b
{-# INLINE pureMethodology #-}

-- | Reinterpreting version of `pureMethodology`.
--
-- @since 0.1.7.0
pureMethodology' ::
  forall f b c r a.
  Applicative f =>
  Sem (Methodology b (f c) ': r) a ->
  Sem (Methodology b c ': r) a
pureMethodology' = raiseUnder >>> pureMethodology
{-# INLINE pureMethodology' #-}

-- | Run a `Methodology` (f b) (f c) by way of a `Methodology` b (f c). Note that
-- `f` must be both `Traversable` and `Monad`.
--
-- @since 0.1.2.0
bindMethodology ::
  forall f b c r a.
  ( Members '[Methodology b (f c)] r,
    Traversable f,
    Monad f
  ) =>
  Sem (Methodology (f b) (f c) ': r) a ->
  Sem r a
bindMethodology = interpret \case
  Process b -> join <$> traverse (process @b @(f c)) b
{-# INLINE bindMethodology #-}

-- | Reinterpreting version of `bindMethodology`.
--
-- @since 0.1.6.0
bindMethodology' ::
  forall f b c r a.
  (Traversable f, Monad f) =>
  Sem (Methodology (f b) (f c) ': r) a ->
  Sem (Methodology b (f c) ': r) a
bindMethodology' = raiseUnder >>> bindMethodology
{-# INLINE bindMethodology' #-}

-- | Run a `Methodology` (t b) (f (t b)) by way of a `Methodology` b (f c). Note that
-- `t` must be `Traversable` and `f` must be `Applicative`.
--
-- @since 0.1.2.0
traverseMethodology ::
  forall t f b c r a.
  ( Members '[Methodology b (f c)] r,
    Traversable t,
    Applicative f
  ) =>
  Sem (Methodology (t b) (f (t c)) ': r) a ->
  Sem r a
traverseMethodology = interpret \case
  Process b -> sequenceA <$> traverse (process @b @(f c)) b
{-# INLINE traverseMethodology #-}

-- | Reinterpreting version of `traverseMethodology`.
--
-- @since 0.1.6.0
traverseMethodology' ::
  forall t f b c r a.
  (Traversable t, Applicative f) =>
  Sem (Methodology (t b) (f (t c)) ': r) a ->
  Sem (Methodology b (f c) ': r) a
traverseMethodology' = raiseUnder >>> traverseMethodology
{-# INLINE traverseMethodology' #-}

-- | Run a `Methodology` concatenating the results as a monoid.
--
-- @since 0.1.5.0
mconcatMethodology ::
  forall f b c r a.
  ( Members '[Methodology b c] r,
    Monoid c,
    Traversable f
  ) =>
  Sem (Methodology (f b) c ': r) a ->
  Sem r a
mconcatMethodology = interpret \case
  Process b -> traverse (process @b @c) b <&> fold 
{-# INLINE mconcatMethodology #-}

-- | Reinterpreting version of `mconcatMethodology`.
--
-- @since 0.1.6.0
mconcatMethodology' ::
  forall f b c r a.
  (Monoid c, Traversable f) =>
  Sem (Methodology (f b) c ': r) a ->
  Sem (Methodology b c ': r) a
mconcatMethodology' = raiseUnder >>> mconcatMethodology
{-# INLINE mconcatMethodology' #-}

-- | `Trace` a `String` based on the input to a `Methodology`.
--
-- @since 0.1.3.0
traceMethodologyStart ::
  forall b c r a.
  Members
    '[ Methodology b c,
       Trace
     ]
    r =>
  -- | A function from the input type b to a `String`.
  (b -> String) ->
  Sem r a ->
  Sem r a
traceMethodologyStart f = intercept @(Methodology b c) \case
  Process b -> trace (f b) >> process @b @c b
{-# INLINE traceMethodologyStart #-}

-- | `Trace` a `String` based on the output to a `Methodology`.
--
-- @since 0.1.3.0
traceMethodologyEnd ::
  forall b c r a.
  Members
    '[ Methodology b c,
       Trace
     ]
    r =>
  -- | A function from the output type c to a `String`.
  (c -> String) ->
  Sem r a ->
  Sem r a
traceMethodologyEnd f = intercept @(Methodology b c) \case
  Process b -> do
    c <- process @b @c b
    trace $ f c
    return c
{-# INLINE traceMethodologyEnd #-}

-- | `Trace` both the start and the end of a `Methodology`.
--
-- @since 0.1.3.0
traceMethodologyAround ::
  forall b c r a.
  Members
    '[ Methodology b c,
       Trace
     ]
    r =>
  -- | A function from the input type b to a `String`.
  (b -> String) ->
  -- | A function from the output type c to a `String`.
  (c -> String) ->
  Sem r a ->
  Sem r a
traceMethodologyAround f g = intercept @(Methodology b c) \case
  Process b -> do
    trace $ f b
    c <- process @b @c b
    trace $ g c
    return c
{-# INLINE traceMethodologyAround #-}