{- |
   Module     : Polysemy.Methodology.Composite
   License    : MIT
   Maintainer : dan.firth@homotopic.tech
   Stability  : experimental

Functions for combining polysemy-methodology with composite.
-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments      #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE PolyKinds           #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeOperators       #-}
module Polysemy.Methodology.Composite (
  runMethodologyRmap
, runCoRecMethodologyAsCases
, runCoRecMethodologyAsCases'
, diffractMethodology
, diffractMethodology'
, runInputCase'
, pickCoRecConstructor
, separateRecInitial
, separateRecInitial'
, stripRecInitial
, endRecInitial
, runRecInitialAsInputCompose
, runRecInitialAsInputCompose'
, separateRecTerminal
, separateRecTerminal'
, stripRecTerminal
, endRecTerminal
, fmapCMethodology
, fmapCMethodology'
) where

import Control.Arrow
import Composite.CoRecord
import Data.Vinyl
import Data.Vinyl.Functor
import Polysemy
import Polysemy.Extra
import Polysemy.Input
import Polysemy.Methodology

-- | Run a `Methodology` between two `Rec`s according to a natural transformation
-- between the interpretation functors.
--
-- @since 0.1.4.0
runMethodologyRmap :: forall f g xs r a. RMap xs =>
                      (forall y. f y -> g y)
                   -> Sem (Methodology (Rec f xs) (Rec g xs) ': r) a
                   -> Sem r a
runMethodologyRmap f = runMethodologyPure (rmap f)
{-# INLINE runMethodologyRmap #-}

-- | Run a `Methodology` from a `CoRec` to an `Input` of `Cases'`. You can then use `Polysemy.Vinyl.separateRecInput` and `Polysemy.Vinyl.stripRecInput`
-- to deal with the cases individually.
--
-- @since 0.1.0.0
runCoRecMethodologyAsCases :: forall f zs c x xs r a.
                              (zs ~ (x ': xs), RecApplicative zs, Members '[Input (Cases' f zs c)] r)
                           => Sem (Methodology (CoRec f zs) c ': r) a
                              -- ^ The Methodology to decompose.
                           -> Sem r a
runCoRecMethodologyAsCases = interpret \case
  Process b -> do
    x <- input @(Cases' f zs c)
    return $ foldCoRec x b
{-# INLINE runCoRecMethodologyAsCases #-}

-- | Reinterpreting version of `runCoRecMethodologyAsCases`.
--
--
-- @since 0.1.0.0
runCoRecMethodologyAsCases' :: forall f zs c x xs r a.
                               (zs ~ (x ': xs), RecApplicative zs)
                            => Sem (Methodology (CoRec f zs) c ': r) a
                               -- ^ The Methodology to decompose.
                            -> Sem (Input (Cases' f zs c) ': r) a
runCoRecMethodologyAsCases' = reinterpret \case
  Process b -> do
    x <- input @(Cases' f zs c)
    return $ foldCoRec x b
{-# INLINE runCoRecMethodologyAsCases' #-}

-- | Diffraction is a combination of a `cutMethodology'`, an `mconcatMethodology'` and a `runCoRecMethodologyAsCases`.
--
-- This effectively allows you to make several ad-hoc constructors for d and fully consumes the second half of the cut.
-- This turns out to be quite a good way to start a simple pipeline.
--
-- @since 0.1.0.0
diffractMethodology :: forall b f zs d x xs r a.
                       (Monoid d, zs ~ (x ': xs)
                      , RecApplicative zs
                      , Members '[ Methodology b [CoRec f zs]
                                 , Input (Cases' f zs d)] r)
                    => Sem (Methodology b d ': r) a
                       -- ^ The Methodology to decompose.
                    -> Sem r a
diffractMethodology = cutMethodology' @b @[CoRec f zs] @d
                  >>> reinterpretUnder mconcatMethodology'
                  >>> reinterpretUnder runCoRecMethodologyAsCases'
                  >>> subsume >>> subsume
{-# INLINE diffractMethodology #-}

-- | Reinterpreting version of `diffractMethodology`.
--
-- @since 0.1.0.0
diffractMethodology' :: forall b f zs d x xs r a.
                        (Monoid d, zs ~ (x ': xs), RecApplicative zs)
                     => Sem (Methodology b d ': r) a
                        -- ^ The Methodology to decompose.
                     -> Sem (Methodology b [CoRec f zs] ': Input (Cases' f zs d) ': r) a
diffractMethodology' = cutMethodology' @b @[CoRec f zs] @d
                   >>> reinterpretUnder mconcatMethodology'
                   >>> reinterpretUnder runCoRecMethodologyAsCases'
{-# INLINE diffractMethodology' #-}

-- | Run a `Case'` using `runInputConst` and a function eliminating the `Case'`.
--
-- @since 0.1.1.0
runInputCase' :: forall b f t r a.
                 (f b -> t)
              -> Sem (Input (Case' f t b) ': r) a
              -> Sem r a
runInputCase' f = runInputConst (Case' f)
{-# INLINE runInputCase' #-}

-- | Take a `Methodology` into a `CoRec` and choose a constructor.
--
-- @since 0.1.4.0
pickCoRecConstructor :: forall x f b xs r a. x ∈ xs =>
                        Sem (Methodology b (CoRec f xs) ': r) a
                     -> Sem (Methodology b (f x) ': r) a
pickCoRecConstructor = cutMethodology'
                   >>> rotateEffects2
                   >>> runMethodologyPure CoVal
{-# INLINE pickCoRecConstructor #-}

-- | Factor a `Methodology` with a `Rec` in the result by a `Methodology` to the first variable.
--
-- @since 0.1.3.0
separateRecInitial :: forall b f x xs r a.
                      Members '[Methodology b (f x), Methodology b (Rec f xs)] r
                   => Sem (Methodology b (Rec f (x ': xs)) ': r) a
                      -- ^ The Methodology to decompose.
                   -> Sem r a
separateRecInitial = interpret \case
  Process b -> do
    k   <- process @b @(f x) b
    k'  <- process @b @(Rec f xs) b
    return $ k :& k'
{-# INLINE separateRecInitial #-}

-- | Reinterpreting version of `separateRecInitial`. This assumes you want to handle
-- the separated case first.
--
-- @since 0.1.3.0
separateRecInitial' :: forall b f x xs r a.
                       Sem (Methodology b (Rec f (x ': xs)) ': r) a
                    -> Sem (Methodology b (f x) ': Methodology b (Rec f xs)': r) a
separateRecInitial' = reinterpret2 \case
  Process b -> do
    k   <- process @b @(f x) b
    k'  <- raise $ process @b @(Rec f xs) b
    return $ k :& k'
{-# INLINE separateRecInitial' #-}

-- | Like `separateRecInitial`, but reinterprets the rest of the `Rec` whilst pushing
-- the separated `Methodology` into the stack. Useful for exhausting the `Rec` and
-- dealing with the cases later.
--
-- @since 0.1.3.0
stripRecInitial :: forall b f x xs r a.
                   Members '[Methodology b (f x)] (Methodology b (Rec f xs) ': r)
                => Sem (Methodology b (Rec f (x ': xs)) ': r) a
                -> Sem (Methodology b (Rec f xs)': r) a
stripRecInitial = reinterpret \case
  Process b -> do
    k   <- process @b @(f x) b
    k'  <- process @b @(Rec f xs) b
    return $ k :& k'
{-# INLINE stripRecInitial #-}

-- | Discard a depleted `Methodology` into a `Rec` by returning `RNil`.
--
-- @since 0.1.3.0
endRecInitial :: Sem (Methodology b (Rec f '[]) ': r) a -> Sem r a
endRecInitial = interpret \case
  Process _ -> return RNil
{-# INLINE endRecInitial #-}

-- | Run a `Methodology` into a `Rec` as an `Input` over a `(->)` functor.
--
-- @since 0.1.3.0
runRecInitialAsInputCompose :: forall b f xs r a. (RMap xs,
                               Members '[ Input (Rec (Compose ((->) b) f) xs)] r)
                            => Sem (Methodology b (Rec f xs) ': r) a
                            -> Sem r a
runRecInitialAsInputCompose = interpret \case
  Process b -> do
    z <- input @(Rec (Compose ((->) b) f) xs)
    return $ rmap (($ b) . getCompose) z
{-# INLINE runRecInitialAsInputCompose #-}

-- | Reinterpreting version of `runRecInitialAsInputCompose`.
--
-- @since 0.1.3.0
runRecInitialAsInputCompose' :: forall b f xs r a. (RMap xs)
                             => Sem (Methodology b (Rec f xs) ': r) a
                             -> Sem (Input (Rec (Compose ((->) b) f) xs) ': r) a
runRecInitialAsInputCompose' = reinterpret \case
  Process b -> do
    z <- input @(Rec (Compose ((->) b) f) xs)
    return $ rmap (($ b) . getCompose) z
{-# INLINE runRecInitialAsInputCompose' #-}

-- | Factor a `Methodology` from a `Rec` by a `Methodology` from the first variable.
--
-- since @0.1.3.0
separateRecTerminal :: forall x c f xs r a. (Monoid c,
                       Members '[Methodology (f x) c, Methodology (Rec f xs) c] r)
                    => Sem (Methodology (Rec f (x ': xs)) c ': r) a
                    -> Sem r a
separateRecTerminal = interpret \case
  Process (b :& bs) -> do
    k   <- process @(f x) b
    k'  <- process @(Rec f xs) @c bs
    return $ k <> k'
{-# INLINE separateRecTerminal #-}

-- | Reinterpreted version of `separateRecTerminal`.
--
-- since @0.1.3.0
separateRecTerminal' :: forall x c f xs r a. Monoid c
                     => Sem (Methodology (Rec f (x ': xs)) c ': r) a
                     -> Sem (Methodology (f x) c ': Methodology (Rec f xs) c ': r) a
separateRecTerminal' = reinterpret2 \case
  Process (b :& bs) -> do
    k   <- process @(f x) b
    k'  <- raise $ process @(Rec f xs) @c bs
    return $ k <> k'
{-# INLINE separateRecTerminal' #-}

-- | Like `separateRecTerminal, but reinterprets the rest of the `Rec` whilst pushing
-- the separated `Methodology` into the stack. Useful for exhausting the `Rec` and
-- dealing with the cases later.
--
-- since @0.1.3.0
stripRecTerminal :: forall x c f xs r a. (Monoid c,
                    Members '[Methodology (f x) c] (Methodology (Rec f xs) c ': r))
                 => Sem (Methodology (Rec f (x ': xs)) c ': r) a
                 -> Sem (Methodology (Rec f xs) c ': r) a
stripRecTerminal = reinterpret \case
  Process (b :& bs) -> do
    k   <- process @(f x) b
    k'  <- process @(Rec f xs) @c bs
    return $ k <> k'
{-# INLINE stripRecTerminal #-}

-- | Discard a depleted `Methodology` fom a `Rec` by returning `mempty`.
--
-- @since 0.1.3.0
endRecTerminal :: Monoid b => Sem (Methodology (Rec f '[]) b ': r) a -> Sem r a
endRecTerminal = interpret \case
  Process _ -> return mempty
{-# INLINE endRecTerminal #-}

-- | Like `fmapMethodology`, but used with a `Compose`d functor to strip the top
-- layer from the functor.
--
-- @since 0.1.4.0
fmapCMethodology :: forall f g h b c r a. Traversable f =>
                     Sem (Methodology ((f :. g) b) ((f :. h) c) ': r) a
                  -> Sem (Methodology (g b) (h c) ': r) a
fmapCMethodology = reinterpret \case
  Process b -> Compose <$> traverse (process @(g b) @(h c)) (getCompose b)
{-# INLINE fmapCMethodology #-}

-- | Reinterpreting version of `fmapCMethodology`.
--
-- @since 0.1.4.0
fmapCMethodology' :: forall f g h b c r a. Traversable f =>
                     Sem (Methodology ((f :. g) b) ((f :. h) c) ': r) a
                  -> Sem (Methodology (g b) (h c) ': r) a
fmapCMethodology' = reinterpret \case
  Process b -> Compose <$> traverse (process @(g b) @(h c)) (getCompose b)
{-# INLINE fmapCMethodology' #-}