{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- Module      : Polysemy.Vinyl
-- License     : MIT
-- Maintainer  : dan.firth@homotopic.tech
-- Stability   : experimental
--
-- Extra functions for using vinyl records with polysemy.
module Polysemy.Vinyl
  ( rContramapInput,
    rContramapInput',
    rMapOutput,
    rMapOutput',
    separateRecInput,
    separateRecInput',
    stripRecInput,
    endRecInput,
    runInputConstFC,
    runSeveral,
  )
where

import Control.Applicative
import Control.Arrow
import Data.Kind
import Data.Vinyl
import Data.Vinyl.Functor
import Polysemy
import Polysemy.Extra
import Polysemy.Input
import Polysemy.Output
import Polysemy.Several hiding (runSeveral)

-- | Map an `Input` containing a `Rec` contravariantly via a natural transformation.
-- Uses `rmap`.
--
-- @since 0.1.0.0
rContramapInput ::
  (RMap xs, Members '[Input (Rec f xs)] r) =>
  -- | A natural transformation from f to g.
  (forall y. f y -> g y) ->
  Sem (Input (Rec g xs) ': r) a ->
  Sem r a
rContramapInput :: (forall (y :: u). f y -> g y)
-> Sem (Input (Rec g xs) : r) a -> Sem r a
rContramapInput forall (y :: u). f y -> g y
k = (Rec f xs -> Rec g xs) -> Sem (Input (Rec g xs) : r) a -> Sem r a
forall i i' (r :: [(* -> *) -> * -> *]) a.
Members '[Input i'] r =>
(i' -> i) -> Sem (Input i : r) a -> Sem r a
contramapInput ((forall (y :: u). f y -> g y) -> Rec f xs -> Rec g xs
forall u (rs :: [u]) (f :: u -> *) (g :: u -> *).
RMap rs =>
(forall (x :: u). f x -> g x) -> Rec f rs -> Rec g rs
rmap forall (y :: u). f y -> g y
k)
{-# INLINE rContramapInput #-}

-- | Reinterpreting version of `rContramapInput`.
--
-- @since 0.1.0.0
rContramapInput' ::
  RMap xs =>
  -- | A natural transformation from f to g.
  (forall y. f y -> g y) ->
  Sem (Input (Rec g xs) ': r) a ->
  Sem (Input (Rec f xs) ': r) a
rContramapInput' :: (forall (y :: u). f y -> g y)
-> Sem (Input (Rec g xs) : r) a -> Sem (Input (Rec f xs) : r) a
rContramapInput' forall (y :: u). f y -> g y
k = Sem (Input (Rec g xs) : r) a
-> Sem (Input (Rec g xs) : Input (Rec f xs) : r) a
forall (e2 :: (* -> *) -> * -> *) (e1 :: (* -> *) -> * -> *)
       (r :: [(* -> *) -> * -> *]) a.
Sem (e1 : r) a -> Sem (e1 : e2 : r) a
raiseUnder (Sem (Input (Rec g xs) : r) a
 -> Sem (Input (Rec g xs) : Input (Rec f xs) : r) a)
-> (Sem (Input (Rec g xs) : Input (Rec f xs) : r) a
    -> Sem (Input (Rec f xs) : r) a)
-> Sem (Input (Rec g xs) : r) a
-> Sem (Input (Rec f xs) : r) a
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (forall (y :: u). f y -> g y)
-> Sem (Input (Rec g xs) : Input (Rec f xs) : r) a
-> Sem (Input (Rec f xs) : r) a
forall u (xs :: [u]) (f :: u -> *) (r :: [(* -> *) -> * -> *])
       (g :: u -> *) a.
(RMap xs, Members '[Input (Rec f xs)] r) =>
(forall (y :: u). f y -> g y)
-> Sem (Input (Rec g xs) : r) a -> Sem r a
rContramapInput forall (y :: u). f y -> g y
k
{-# INLINE rContramapInput' #-}

-- | Map an `Output` containing a `Rec` covariantly via a natural transformation.
-- Uses `rmap`.
--
-- @since 0.1.0.0
rMapOutput ::
  (RMap xs, Members '[Output (Rec g xs)] r) =>
  -- | A natural transformation from f to g.
  (forall y. f y -> g y) ->
  Sem (Output (Rec f xs) ': r) a ->
  Sem r a
rMapOutput :: (forall (y :: u). f y -> g y)
-> Sem (Output (Rec f xs) : r) a -> Sem r a
rMapOutput forall (y :: u). f y -> g y
k = (Rec f xs -> Rec g xs) -> Sem (Output (Rec f xs) : r) a -> Sem r a
forall o' (r :: [(* -> *) -> * -> *]) o a.
Members '[Output o'] r =>
(o -> o') -> Sem (Output o : r) a -> Sem r a
mapOutput ((forall (y :: u). f y -> g y) -> Rec f xs -> Rec g xs
forall u (rs :: [u]) (f :: u -> *) (g :: u -> *).
RMap rs =>
(forall (x :: u). f x -> g x) -> Rec f rs -> Rec g rs
rmap forall (y :: u). f y -> g y
k)
{-# INLINE rMapOutput #-}

-- | Reinterpreting version of `rMapOutput`.
--
-- @since 0.1.0.0
rMapOutput' ::
  RMap xs =>
  -- | A natural transformation from f to g.
  (forall y. f y -> g y) ->
  Sem (Output (Rec f xs) ': r) a ->
  Sem (Output (Rec g xs) ': r) a
rMapOutput' :: (forall (y :: u). f y -> g y)
-> Sem (Output (Rec f xs) : r) a -> Sem (Output (Rec g xs) : r) a
rMapOutput' forall (y :: u). f y -> g y
k = Sem (Output (Rec f xs) : r) a
-> Sem (Output (Rec f xs) : Output (Rec g xs) : r) a
forall (e2 :: (* -> *) -> * -> *) (e1 :: (* -> *) -> * -> *)
       (r :: [(* -> *) -> * -> *]) a.
Sem (e1 : r) a -> Sem (e1 : e2 : r) a
raiseUnder (Sem (Output (Rec f xs) : r) a
 -> Sem (Output (Rec f xs) : Output (Rec g xs) : r) a)
-> (Sem (Output (Rec f xs) : Output (Rec g xs) : r) a
    -> Sem (Output (Rec g xs) : r) a)
-> Sem (Output (Rec f xs) : r) a
-> Sem (Output (Rec g xs) : r) a
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (forall (y :: u). f y -> g y)
-> Sem (Output (Rec f xs) : Output (Rec g xs) : r) a
-> Sem (Output (Rec g xs) : r) a
forall u (xs :: [u]) (g :: u -> *) (r :: [(* -> *) -> * -> *])
       (f :: u -> *) a.
(RMap xs, Members '[Output (Rec g xs)] r) =>
(forall (y :: u). f y -> g y)
-> Sem (Output (Rec f xs) : r) a -> Sem r a
rMapOutput forall (y :: u). f y -> g y
k
{-# INLINE rMapOutput' #-}

-- | Separate one of the fields of an `Input` `Rec` into its own `Input`.
--
-- @since 0.1.2.0
separateRecInput ::
  forall f x xs r a.
  Members
    '[ Input (Rec f xs),
       Input (f x)
     ]
    r =>
  Sem (Input (Rec f (x ': xs)) ': r) a ->
  Sem r a
separateRecInput :: Sem (Input (Rec f (x : xs)) : r) a -> Sem r a
separateRecInput = (forall (rInitial :: [(* -> *) -> * -> *]) x.
 Input (Rec f (x : xs)) (Sem rInitial) x -> Sem r x)
-> Sem (Input (Rec f (x : xs)) : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall (rInitial :: [(* -> *) -> * -> *]) x.
 e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret \case
  Input (Rec f (x : xs)) (Sem rInitial) x
Input -> (f x -> Rec f xs -> Rec f (x : xs))
-> Sem r (f x) -> Sem r (Rec f xs) -> Sem r (Rec f (x : xs))
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 f x -> Rec f xs -> Rec f (x : xs)
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
(:&) (forall (r :: [(* -> *) -> * -> *]).
MemberWithError (Input (f x)) r =>
Sem r (f x)
forall i (r :: [(* -> *) -> * -> *]).
MemberWithError (Input i) r =>
Sem r i
input @(f x)) (forall (r :: [(* -> *) -> * -> *]).
MemberWithError (Input (Rec f xs)) r =>
Sem r (Rec f xs)
forall i (r :: [(* -> *) -> * -> *]).
MemberWithError (Input i) r =>
Sem r i
input @(Rec f xs))
{-# INLINE separateRecInput #-}

-- | Reinterpreting version of `separateRecInput`. This assumes you want to handle
-- the separated case first.
--
-- @since 0.1.2.0
separateRecInput' ::
  forall f x xs r a.
  Sem (Input (Rec f (x ': xs)) ': r) a ->
  Sem (Input (f x) ': Input (Rec f xs) ': r) a
separateRecInput' :: Sem (Input (Rec f (x : xs)) : r) a
-> Sem (Input (f x) : Input (Rec f xs) : r) a
separateRecInput' = (forall (rInitial :: [(* -> *) -> * -> *]) x.
 Input (Rec f (x : xs)) (Sem rInitial) x
 -> Sem (Input (f x) : Input (Rec f xs) : r) x)
-> Sem (Input (Rec f (x : xs)) : r) a
-> Sem (Input (f x) : Input (Rec f xs) : r) a
forall (e1 :: (* -> *) -> * -> *) (e2 :: (* -> *) -> * -> *)
       (e3 :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e1 "reinterpret2" =>
(forall (rInitial :: [(* -> *) -> * -> *]) x.
 e1 (Sem rInitial) x -> Sem (e2 : e3 : r) x)
-> Sem (e1 : r) a -> Sem (e2 : e3 : r) a
reinterpret2 \case
  Input (Rec f (x : xs)) (Sem rInitial) x
Input -> (f x -> Rec f xs -> Rec f (x : xs))
-> Sem (Input (f x) : Input (Rec f xs) : r) (f x)
-> Sem (Input (f x) : Input (Rec f xs) : r) (Rec f xs)
-> Sem (Input (f x) : Input (Rec f xs) : r) (Rec f (x : xs))
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 f x -> Rec f xs -> Rec f (x : xs)
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
(:&) (forall (r :: [(* -> *) -> * -> *]).
MemberWithError (Input (f x)) r =>
Sem r (f x)
forall i (r :: [(* -> *) -> * -> *]).
MemberWithError (Input i) r =>
Sem r i
input @(f x)) (Sem (Input (Rec f xs) : r) (Rec f xs)
-> Sem (Input (f x) : Input (Rec f xs) : r) (Rec f xs)
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
Sem r a -> Sem (e : r) a
raise (Sem (Input (Rec f xs) : r) (Rec f xs)
 -> Sem (Input (f x) : Input (Rec f xs) : r) (Rec f xs))
-> Sem (Input (Rec f xs) : r) (Rec f xs)
-> Sem (Input (f x) : Input (Rec f xs) : r) (Rec f xs)
forall a b. (a -> b) -> a -> b
$ forall (r :: [(* -> *) -> * -> *]).
MemberWithError (Input (Rec f xs)) r =>
Sem r (Rec f xs)
forall i (r :: [(* -> *) -> * -> *]).
MemberWithError (Input i) r =>
Sem r i
input @(Rec f xs))
{-# INLINE separateRecInput' #-}

-- | Like `separateRecInput`, but places the remainer of the `Rec` at the head
-- of the list while pushing the case into the stack. This is useful when you
-- want to eliminate the record first by repeated applications of `stripRecInput`.
--
-- @since 0.1.2.0
stripRecInput ::
  forall f x xs r a.
  Members '[Input (f x)] (Input (Rec f xs) ': r) =>
  Sem (Input (Rec f (x ': xs)) ': r) a ->
  Sem (Input (Rec f xs) ': r) a
stripRecInput :: Sem (Input (Rec f (x : xs)) : r) a -> Sem (Input (Rec f xs) : r) a
stripRecInput = (forall (rInitial :: [(* -> *) -> * -> *]) x.
 Input (Rec f (x : xs)) (Sem rInitial) x
 -> Sem (Input (Rec f xs) : r) x)
-> Sem (Input (Rec f (x : xs)) : r) a
-> Sem (Input (Rec f xs) : r) a
forall (e1 :: (* -> *) -> * -> *) (e2 :: (* -> *) -> * -> *)
       (r :: [(* -> *) -> * -> *]) a.
FirstOrder e1 "reinterpret" =>
(forall (rInitial :: [(* -> *) -> * -> *]) x.
 e1 (Sem rInitial) x -> Sem (e2 : r) x)
-> Sem (e1 : r) a -> Sem (e2 : r) a
reinterpret \case
  Input (Rec f (x : xs)) (Sem rInitial) x
Input -> (f x -> Rec f xs -> Rec f (x : xs))
-> Sem (Input (Rec f xs) : r) (f x)
-> Sem (Input (Rec f xs) : r) (Rec f xs)
-> Sem (Input (Rec f xs) : r) (Rec f (x : xs))
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 f x -> Rec f xs -> Rec f (x : xs)
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
(:&) (forall (r :: [(* -> *) -> * -> *]).
MemberWithError (Input (f x)) r =>
Sem r (f x)
forall i (r :: [(* -> *) -> * -> *]).
MemberWithError (Input i) r =>
Sem r i
input @(f x)) (forall (r :: [(* -> *) -> * -> *]).
MemberWithError (Input (Rec f xs)) r =>
Sem r (Rec f xs)
forall i (r :: [(* -> *) -> * -> *]).
MemberWithError (Input i) r =>
Sem r i
input @(Rec f xs))
{-# INLINE stripRecInput #-}

-- | Discard a depleted `Rec` `Input` by returning `RNil`.
--
-- @since 0.1.2.0
endRecInput :: Sem (Input (Rec f '[]) ': r) a -> Sem r a
endRecInput :: Sem (Input (Rec f '[]) : r) a -> Sem r a
endRecInput = (forall (rInitial :: [(* -> *) -> * -> *]) x.
 Input (Rec f '[]) (Sem rInitial) x -> Sem r x)
-> Sem (Input (Rec f '[]) : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall (rInitial :: [(* -> *) -> * -> *]) x.
 e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret \case
  Input (Rec f '[]) (Sem rInitial) x
Input -> Rec f '[] -> Sem r (Rec f '[])
forall (m :: * -> *) a. Monad m => a -> m a
return Rec f '[]
forall u (a :: u -> *). Rec a '[]
RNil
{-# INLINE endRecInput #-}

-- | Like `runInputConstF` but for vinyl composed functors.
--
-- @since 0.1.3.0
runInputConstFC ::
  forall b f g r a.
  f (g b) ->
  Sem (Input ((f :. g) b) ': r) a ->
  Sem r a
runInputConstFC :: f (g b) -> Sem (Input ((:.) f g b) : r) a -> Sem r a
runInputConstFC f (g b)
f = (:.) f g b -> Sem (Input ((:.) f g b) : r) a -> Sem r a
forall k (b :: k) (f :: k -> *) (r :: [(* -> *) -> * -> *]) a.
f b -> Sem (Input (f b) : r) a -> Sem r a
runInputConstF @b @(f :. g) (f (g b) -> (:.) f g b
forall l k (f :: l -> *) (g :: k -> l) (x :: k).
f (g x) -> Compose f g x
Compose f (g b)
f)
{-# INLINE runInputConstFC #-}

-- | Like `Polysemy.Several.runSeveral` but for a vinyl `Rec`.
--
-- @since 0.1.5.0
runSeveral ::
  forall (e :: Type -> Effect) f (r :: [Effect]) xs a.
  (forall r' k x. k -> Sem (e k ': r') x -> Sem r' x) ->
  Rec f xs ->
  Sem (Append (TypeMap e (TypeMap f xs)) r) a ->
  Sem r a
runSeveral :: (forall (r' :: [(* -> *) -> * -> *]) k x.
 k -> Sem (e k : r') x -> Sem r' x)
-> Rec f xs
-> Sem (Append (TypeMap e (TypeMap f xs)) r) a
-> Sem r a
runSeveral forall (r' :: [(* -> *) -> * -> *]) k x.
k -> Sem (e k : r') x -> Sem r' x
f (f r
a :& Rec f rs
as) = (forall (r' :: [(* -> *) -> * -> *]) k x.
 k -> Sem (e k : r') x -> Sem r' x)
-> Rec f rs
-> Sem (Append (TypeMap e (TypeMap f rs)) r) a
-> Sem r a
forall a (e :: * -> (* -> *) -> * -> *) (f :: a -> *)
       (r :: [(* -> *) -> * -> *]) (xs :: [a]) a.
(forall (r' :: [(* -> *) -> * -> *]) k x.
 k -> Sem (e k : r') x -> Sem r' x)
-> Rec f xs
-> Sem (Append (TypeMap e (TypeMap f xs)) r) a
-> Sem r a
runSeveral forall (r' :: [(* -> *) -> * -> *]) k x.
k -> Sem (e k : r') x -> Sem r' x
f Rec f rs
as (Sem (Append (TypeMap e (TypeMap f rs)) r) a -> Sem r a)
-> (Sem (e (f r) : Append (TypeMap e (TypeMap f rs)) r) a
    -> Sem (Append (TypeMap e (TypeMap f rs)) r) a)
-> Sem (e (f r) : Append (TypeMap e (TypeMap f rs)) r) a
-> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f r
-> Sem (e (f r) : Append (TypeMap e (TypeMap f rs)) r) a
-> Sem (Append (TypeMap e (TypeMap f rs)) r) a
forall (r' :: [(* -> *) -> * -> *]) k x.
k -> Sem (e k : r') x -> Sem r' x
f f r
a
runSeveral forall (r' :: [(* -> *) -> * -> *]) k x.
k -> Sem (e k : r') x -> Sem r' x
_ Rec f xs
RNil = Sem (Append (TypeMap e (TypeMap f xs)) r) a -> Sem r a
forall a. a -> a
id
{-# INLINE runSeveral #-}