-- |Module containing the sum formulation companion to 'Composite.Record's product formulation. Values of type @'CoRec' f rs@ represent a single value
-- @f r@ for one of the @r@s in @rs@. Heavily based on the great work by Anthony Cowley in Frames.
{-# LANGUAGE UndecidableInstances #-} -- for FoldRec
module Composite.CoRecord where

import Prelude
import Composite.Record (AllHave, HasInstances, (:->)(getVal, Val), reifyDicts, reifyVal, val, zipRecsWith)
import Control.Lens (Prism', Wrapped, Unwrapped, prism', review, view, _Wrapped')
import Control.Monad.Except (ExceptT, throwError, withExceptT)
import Data.Functor.Contravariant (Contravariant(contramap))
import Data.Functor.Identity (Identity(Identity), runIdentity)
import Data.Kind (Constraint, Type)
import Data.Maybe (fromMaybe)
import Data.Profunctor (dimap)
import Data.Proxy (Proxy(Proxy))
import Data.Text (Text, pack)
import Data.Vinyl.Core (Dict(Dict), Rec((:&), RNil), RMap, RecApplicative, RecordToList, ReifyConstraint, recordToList, reifyConstraint, rmap, rpure)
import Data.Vinyl.Functor (Compose(Compose, getCompose), Const(Const), (:.))
import Data.Vinyl.Lens (RElem, type (∈), type (⊆), rget, rput, rreplace)
import Data.Vinyl.TypeLevel (RecAll, RIndex)
import GHC.TypeLits (KnownSymbol, symbolVal)

-- FIXME? replace with int-index/union or at least lift ideas from there. This encoding is awkward to work with and not compositional.

-- |@CoRef f rs@ represents a single value of type @f r@ for some @r@ in @rs@.
data CoRec :: (u -> Type) -> [u] -> Type where
  -- |Witness that @r@ is an element of @rs@ using '∈' ('RElem' with 'RIndex') from Vinyl.
  CoVal :: r ∈ rs => !(f r) -> CoRec f rs

instance forall rs. (AllHave '[Show] rs, RecApplicative rs) => Show (CoRec Identity rs) where
  show :: CoRec Identity rs -> String
show (CoVal (Identity r
x)) = String
"(CoVal " forall a. [a] -> [a] -> [a]
++ r -> String
show' r
x forall a. [a] -> [a] -> [a]
++ String
")"
    where
      shower :: Rec (Op String) rs
      shower :: Rec (Op String) rs
shower = forall u (cs :: [u -> Constraint]) (f :: u -> *) (rs :: [u])
       (proxy :: [u -> Constraint] -> *).
(AllHave cs rs, RecApplicative rs) =>
proxy cs
-> (forall (proxy' :: u -> *) (a :: u).
    HasInstances a cs =>
    proxy' a -> f a)
-> Rec f rs
reifyDicts (forall {k} (t :: k). Proxy t
Proxy @'[Show]) (\ proxy' a
_ -> forall b a. (a -> b) -> Op b a
Op forall a. Show a => a -> String
show)
      show' :: r -> String
show' = forall b a. Op b a -> a -> b
runOp (forall {k} (r :: k) (rs :: [k]) (f :: k -> *)
       (record :: (k -> *) -> [k] -> *).
(RecElem record r r rs rs (RIndex r rs), RecElemFCtx record f) =>
record f rs -> f r
rget Rec (Op String) rs
shower)

instance forall rs. (RMap rs, RecAll Maybe rs Eq, RecApplicative rs, RecordToList rs, ReifyConstraint Eq Maybe rs) => Eq (CoRec Identity rs) where
  CoRec Identity rs
crA == :: CoRec Identity rs -> CoRec Identity rs -> Bool
== CoRec Identity rs
crB = forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {u} (rs :: [u]) a.
RecordToList rs =>
Rec (Const a) rs -> [a]
recordToList forall a b. (a -> b) -> a -> b
$ forall {u} (f :: u -> *) (g :: u -> *) (h :: u -> *) (as :: [u]).
(forall (a :: u). f a -> g a -> h a)
-> Rec f as -> Rec g as -> Rec h as
zipRecsWith forall a. (:.) (Dict Eq) Maybe a -> Maybe a -> Const Bool a
f (CoRec Identity rs -> Rec (Dict Eq :. Maybe) rs
toRec CoRec Identity rs
crA) (forall (rs :: [*]).
(RMap rs, RecApplicative rs) =>
Field rs -> Rec Maybe rs
fieldToRec CoRec Identity rs
crB)
    where
      f :: forall a. (Dict Eq :. Maybe) a -> Maybe a -> Const Bool a
      f :: forall a. (:.) (Dict Eq) Maybe a -> Maybe a -> Const Bool a
f (Compose (Dict Maybe a
a)) Maybe a
b = forall k a (b :: k). a -> Const a b
Const forall a b. (a -> b) -> a -> b
$ Maybe a
a forall a. Eq a => a -> a -> Bool
== Maybe a
b
      toRec :: CoRec Identity rs -> Rec (Dict Eq :. Maybe) rs
toRec = forall {u} (c :: * -> Constraint) (f :: u -> *) (rs :: [u]).
ReifyConstraint c f rs =>
Rec f rs -> Rec (Dict c :. f) rs
reifyConstraint forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rs :: [*]).
(RMap rs, RecApplicative rs) =>
Field rs -> Rec Maybe rs
fieldToRec

-- |The common case of a 'CoRec' with @f ~ 'Identity'@, i.e. a regular value.
type Field = CoRec Identity

-- |Inject a value @f r@ into a @'CoRec' f rs@ given that @r@ is one of the valid @rs@.
--
-- Equivalent to 'CoVal' the constructor, but exists to parallel 'field'.
coRec :: r ∈ rs => f r -> CoRec f rs
coRec :: forall {u} (r :: u) (rs :: [u]) (f :: u -> *).
(r ∈ rs) =>
f r -> CoRec f rs
coRec = forall {u} (r :: u) (rs :: [u]) (f :: u -> *).
(r ∈ rs) =>
f r -> CoRec f rs
CoVal

-- |Produce a prism for the given alternative of a 'CoRec'.
coRecPrism :: (RecApplicative rs, r ∈ rs) => Prism' (CoRec f rs) (f r)
coRecPrism :: forall {u} (rs :: [u]) (r :: u) (f :: u -> *).
(RecApplicative rs, r ∈ rs) =>
Prism' (CoRec f rs) (f r)
coRecPrism = forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' forall {u} (r :: u) (rs :: [u]) (f :: u -> *).
(r ∈ rs) =>
f r -> CoRec f rs
CoVal (forall l k (f :: l -> *) (g :: k -> l) (x :: k).
Compose f g x -> f (g x)
getCompose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (r :: k) (rs :: [k]) (f :: k -> *)
       (record :: (k -> *) -> [k] -> *).
(RecElem record r r rs rs (RIndex r rs), RecElemFCtx record f) =>
record f rs -> f r
rget forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {u} (rs :: [u]) (f :: u -> *).
RecApplicative rs =>
CoRec f rs -> Rec (Maybe :. f) rs
coRecToRec)

-- |Inject a value @r@ into a @'Field' rs@ given that @r@ is one of the valid @rs@.
--
-- Equivalent to @'CoVal' . 'Identity'@.
field :: r ∈ rs => r -> Field rs
field :: forall r (rs :: [*]). (r ∈ rs) => r -> Field rs
field = forall {u} (r :: u) (rs :: [u]) (f :: u -> *).
(r ∈ rs) =>
f r -> CoRec f rs
CoVal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Identity a
Identity

-- |Inject a value @a@ into a @'Field' rs@ given that @s :-> a@ is one of the valid @rs@.
--
-- Equivalent to @'CoVal' . 'Identity' . 'Val'@.
fieldVal :: forall s a rs proxy. s :-> a ∈ rs => proxy (s :-> a) -> a -> Field rs
fieldVal :: forall (s :: Symbol) a (rs :: [*]) (proxy :: * -> *).
((s :-> a) ∈ rs) =>
proxy (s :-> a) -> a -> Field rs
fieldVal proxy (s :-> a)
_ = forall {u} (r :: u) (rs :: [u]) (f :: u -> *).
(r ∈ rs) =>
f r -> CoRec f rs
CoVal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Symbol) a. a -> Identity (s :-> a)
val @s

-- |Produce a prism for the given alternative of a 'Field'.
fieldPrism :: (RecApplicative rs, r ∈ rs) => Prism' (Field rs) r
fieldPrism :: forall (rs :: [*]) r.
(RecApplicative rs, r ∈ rs) =>
Prism' (Field rs) r
fieldPrism = forall {u} (rs :: [u]) (r :: u) (f :: u -> *).
(RecApplicative rs, r ∈ rs) =>
Prism' (CoRec f rs) (f r)
coRecPrism forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap forall a. Identity a -> a
runIdentity (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Identity a
Identity)

-- |Produce a prism for the given @:->@ alternative of a 'Field', given a proxy to identify which @s :-> a@ you meant.
fieldValPrism :: (RecApplicative rs, s :-> a ∈ rs) => proxy (s :-> a) -> Prism' (Field rs) a
fieldValPrism :: forall (rs :: [*]) (s :: Symbol) a (proxy :: * -> *).
(RecApplicative rs, (s :-> a) ∈ rs) =>
proxy (s :-> a) -> Prism' (Field rs) a
fieldValPrism proxy (s :-> a)
proxy = forall {u} (rs :: [u]) (r :: u) (f :: u -> *).
(RecApplicative rs, r ∈ rs) =>
Prism' (CoRec f rs) (f r)
coRecPrism forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap (forall (s :: Symbol) a. (s :-> a) -> a
getVal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (proxy :: * -> *) (s :: Symbol) a.
proxy (s :-> a) -> (s :-> a) -> s :-> a
reifyVal proxy (s :-> a)
proxy forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
runIdentity) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Symbol) a. a -> s :-> a
Val))

-- |Apply an extraction to whatever @f r@ is contained in the given 'CoRec'.
--
-- For example @foldCoVal getConst :: CoRec (Const a) rs -> a@.
foldCoVal :: (forall (r :: u). RElem r rs (RIndex r rs) => f r -> b) -> CoRec f rs -> b
foldCoVal :: forall u (rs :: [u]) (f :: u -> *) b.
(forall (r :: u). RElem r rs (RIndex r rs) => f r -> b)
-> CoRec f rs -> b
foldCoVal forall (r :: u). RElem r rs (RIndex r rs) => f r -> b
f (CoVal f r
x) = forall (r :: u). RElem r rs (RIndex r rs) => f r -> b
f f r
x
{-# INLINE foldCoVal #-}

-- |Map a @'CoRec' f@ to a @'CoRec' g@ using a natural transform from @f@ to @g@ (@forall x. f x -> g x@).
mapCoRec :: (forall x. f x -> g x) -> CoRec f rs -> CoRec g rs
mapCoRec :: forall {u} (f :: u -> *) (g :: u -> *) (rs :: [u]).
(forall (x :: u). f x -> g x) -> CoRec f rs -> CoRec g rs
mapCoRec forall (x :: u). f x -> g x
f (CoVal f r
x) = forall {u} (r :: u) (rs :: [u]) (f :: u -> *).
(r ∈ rs) =>
f r -> CoRec f rs
CoVal (forall (x :: u). f x -> g x
f f r
x)
{-# INLINE mapCoRec #-}

-- |Apply some kleisli on @h@ to the @f x@ contained in a @'CoRec' f@ and yank the @h@ outside. Like 'traverse' but for 'CoRec'.
traverseCoRec :: Functor h => (forall x. f x -> h (g x)) -> CoRec f rs -> h (CoRec g rs)
traverseCoRec :: forall {u} (h :: * -> *) (f :: u -> *) (g :: u -> *) (rs :: [u]).
Functor h =>
(forall (x :: u). f x -> h (g x)) -> CoRec f rs -> h (CoRec g rs)
traverseCoRec forall (x :: u). f x -> h (g x)
f (CoVal f r
x) = forall {u} (r :: u) (rs :: [u]) (f :: u -> *).
(r ∈ rs) =>
f r -> CoRec f rs
CoVal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (x :: u). f x -> h (g x)
f f r
x
{-# INLINE traverseCoRec #-}

-- |Project a @'CoRec' f@ into a @'Rec' ('Maybe' ':.' f)@ where only the single @r@ held by the 'CoRec' is 'Just' in the resulting record, and all other
-- fields are 'Nothing'.
coRecToRec :: RecApplicative rs => CoRec f rs -> Rec (Maybe :. f) rs
coRecToRec :: forall {u} (rs :: [u]) (f :: u -> *).
RecApplicative rs =>
CoRec f rs -> Rec (Maybe :. f) rs
coRecToRec (CoVal f r
a) = forall k (r :: k) (rs :: [k]) (record :: (k -> *) -> [k] -> *)
       (f :: k -> *).
(RecElem record r r rs rs (RIndex r rs), RecElemFCtx record f) =>
f r -> record f rs -> record f rs
rput (forall l k (f :: l -> *) (g :: k -> l) (x :: k).
f (g x) -> Compose f g x
Compose (forall a. a -> Maybe a
Just f r
a)) (forall {u} (rs :: [u]) (f :: u -> *).
RecApplicative rs =>
(forall (x :: u). f x) -> Rec f rs
rpure (forall l k (f :: l -> *) (g :: k -> l) (x :: k).
f (g x) -> Compose f g x
Compose forall a. Maybe a
Nothing))
{-# INLINE coRecToRec #-}

-- |Project a 'Field' into a @'Rec' 'Maybe'@ where only the single @r@ held by the 'Field' is 'Just' in the resulting record, and all other
-- fields are 'Nothing'.
fieldToRec :: (RMap rs, RecApplicative rs) => Field rs -> Rec Maybe rs
fieldToRec :: forall (rs :: [*]).
(RMap rs, RecApplicative rs) =>
Field rs -> Rec Maybe rs
fieldToRec = 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l k (f :: l -> *) (g :: k -> l) (x :: k).
Compose f g x -> f (g x)
getCompose) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {u} (rs :: [u]) (f :: u -> *).
RecApplicative rs =>
CoRec f rs -> Rec (Maybe :. f) rs
coRecToRec
{-# INLINE fieldToRec #-}

-- |Typeclass which allows folding ala 'foldMap' over a 'Rec', using a 'CoRec' as the accumulator.
class FoldRec ss ts where
  -- |Given some combining function, an initial value, and a record, visit each field of the record using the combining function to accumulate the
  -- initial value or previous accumulation with the field of the record.
  foldRec
    :: (CoRec f ss -> CoRec f ss -> CoRec f ss)
    -> CoRec f ss
    -> Rec f ts
    -> CoRec f ss

instance FoldRec ss '[] where
  foldRec :: forall (f :: u -> *).
(CoRec f ss -> CoRec f ss -> CoRec f ss)
-> CoRec f ss -> Rec f '[] -> CoRec f ss
foldRec CoRec f ss -> CoRec f ss -> CoRec f ss
_ CoRec f ss
z Rec f '[]
_ = CoRec f ss
z
  {-# INLINE foldRec #-}

instance (t ∈ ss, FoldRec ss ts) => FoldRec ss (t ': ts) where
  foldRec :: forall (f :: a -> *).
(CoRec f ss -> CoRec f ss -> CoRec f ss)
-> CoRec f ss -> Rec f (t : ts) -> CoRec f ss
foldRec CoRec f ss -> CoRec f ss -> CoRec f ss
f CoRec f ss
z (f r
x :& Rec f rs
xs) = forall {u} (ss :: [u]) (ts :: [u]) (f :: u -> *).
FoldRec ss ts =>
(CoRec f ss -> CoRec f ss -> CoRec f ss)
-> CoRec f ss -> Rec f ts -> CoRec f ss
foldRec CoRec f ss -> CoRec f ss -> CoRec f ss
f (CoRec f ss
z CoRec f ss -> CoRec f ss -> CoRec f ss
`f` forall {u} (r :: u) (rs :: [u]) (f :: u -> *).
(r ∈ rs) =>
f r -> CoRec f rs
CoVal f r
x) Rec f rs
xs
  {-# INLINE foldRec #-}

-- |'foldRec' for records with at least one field that doesn't require an initial value.
foldRec1
  :: FoldRec (r ': rs) rs
  => (CoRec f (r ': rs) -> CoRec f (r ': rs) -> CoRec f (r ': rs))
  -> Rec f (r ': rs)
  -> CoRec f (r ': rs)
foldRec1 :: forall {a} (r :: a) (rs :: [a]) (f :: a -> *).
FoldRec (r : rs) rs =>
(CoRec f (r : rs) -> CoRec f (r : rs) -> CoRec f (r : rs))
-> Rec f (r : rs) -> CoRec f (r : rs)
foldRec1 CoRec f (r : rs) -> CoRec f (r : rs) -> CoRec f (r : rs)
f (f r
x :& Rec f rs
xs) = forall {u} (ss :: [u]) (ts :: [u]) (f :: u -> *).
FoldRec ss ts =>
(CoRec f ss -> CoRec f ss -> CoRec f ss)
-> CoRec f ss -> Rec f ts -> CoRec f ss
foldRec CoRec f (r : rs) -> CoRec f (r : rs) -> CoRec f (r : rs)
f (forall {u} (r :: u) (rs :: [u]) (f :: u -> *).
(r ∈ rs) =>
f r -> CoRec f rs
CoVal f r
x) Rec f rs
xs
{-# INLINE foldRec1 #-}

-- |Given a @'Rec' ('Maybe' ':.' f) rs@, yield a @Just coRec@ for the first field which is @Just@, or @Nothing@ if there are no @Just@ fields in the record.
firstCoRec :: FoldRec rs rs => Rec (Maybe :. f) rs -> Maybe (CoRec f rs)
firstCoRec :: forall {u} (rs :: [u]) (f :: u -> *).
FoldRec rs rs =>
Rec (Maybe :. f) rs -> Maybe (CoRec f rs)
firstCoRec Rec (Maybe :. f) rs
RNil       = forall a. Maybe a
Nothing
firstCoRec v :: Rec (Maybe :. f) rs
v@((:.) Maybe f r
x :& Rec (Maybe :. f) rs
_) = forall {u} (h :: * -> *) (f :: u -> *) (g :: u -> *) (rs :: [u]).
Functor h =>
(forall (x :: u). f x -> h (g x)) -> CoRec f rs -> h (CoRec g rs)
traverseCoRec forall l k (f :: l -> *) (g :: k -> l) (x :: k).
Compose f g x -> f (g x)
getCompose forall a b. (a -> b) -> a -> b
$ forall {u} (ss :: [u]) (ts :: [u]) (f :: u -> *).
FoldRec ss ts =>
(CoRec f ss -> CoRec f ss -> CoRec f ss)
-> CoRec f ss -> Rec f ts -> CoRec f ss
foldRec forall {u} {g :: u -> *} {b :: [u]}.
CoRec (Compose Maybe g) b
-> CoRec (Compose Maybe g) b -> CoRec (Compose Maybe g) b
f (forall {u} (r :: u) (rs :: [u]) (f :: u -> *).
(r ∈ rs) =>
f r -> CoRec f rs
CoVal (:.) Maybe f r
x) Rec (Maybe :. f) rs
v
  where
    f :: CoRec (Compose Maybe g) b
-> CoRec (Compose Maybe g) b -> CoRec (Compose Maybe g) b
f c :: CoRec (Compose Maybe g) b
c@(CoVal (Compose (Just g r
_))) CoRec (Compose Maybe g) b
_ = CoRec (Compose Maybe g) b
c
    f CoRec (Compose Maybe g) b
_                            CoRec (Compose Maybe g) b
c = CoRec (Compose Maybe g) b
c
{-# INLINE firstCoRec #-}

-- |Given a @'Rec' 'Maybe' rs@, yield a @Just field@ for the first field which is @Just@, or @Nothing@ if there are no @Just@ fields in the record.
firstField :: (FoldRec rs rs, RMap rs) => Rec Maybe rs -> Maybe (Field rs)
firstField :: forall (rs :: [*]).
(FoldRec rs rs, RMap rs) =>
Rec Maybe rs -> Maybe (Field rs)
firstField = forall {u} (rs :: [u]) (f :: u -> *).
FoldRec rs rs =>
Rec (Maybe :. f) rs -> Maybe (CoRec f rs)
firstCoRec forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 l k (f :: l -> *) (g :: k -> l) (x :: k).
f (g x) -> Compose f g x
Compose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Identity a
Identity)
{-# INLINE firstField #-}

-- |Given a @'Rec' ('Maybe' ':.' f) rs@, yield a @Just coRec@ for the last field which is @Just@, or @Nothing@ if there are no @Just@ fields in the record.
lastCoRec :: FoldRec rs rs => Rec (Maybe :. f) rs -> Maybe (CoRec f rs)
lastCoRec :: forall {u} (rs :: [u]) (f :: u -> *).
FoldRec rs rs =>
Rec (Maybe :. f) rs -> Maybe (CoRec f rs)
lastCoRec Rec (Maybe :. f) rs
RNil       = forall a. Maybe a
Nothing
lastCoRec v :: Rec (Maybe :. f) rs
v@((:.) Maybe f r
x :& Rec (Maybe :. f) rs
_) = forall {u} (h :: * -> *) (f :: u -> *) (g :: u -> *) (rs :: [u]).
Functor h =>
(forall (x :: u). f x -> h (g x)) -> CoRec f rs -> h (CoRec g rs)
traverseCoRec forall l k (f :: l -> *) (g :: k -> l) (x :: k).
Compose f g x -> f (g x)
getCompose forall a b. (a -> b) -> a -> b
$ forall {u} (ss :: [u]) (ts :: [u]) (f :: u -> *).
FoldRec ss ts =>
(CoRec f ss -> CoRec f ss -> CoRec f ss)
-> CoRec f ss -> Rec f ts -> CoRec f ss
foldRec forall {u} {g :: u -> *} {b :: [u]}.
CoRec (Compose Maybe g) b
-> CoRec (Compose Maybe g) b -> CoRec (Compose Maybe g) b
f (forall {u} (r :: u) (rs :: [u]) (f :: u -> *).
(r ∈ rs) =>
f r -> CoRec f rs
CoVal (:.) Maybe f r
x) Rec (Maybe :. f) rs
v
  where
    f :: CoRec (Compose Maybe g) b
-> CoRec (Compose Maybe g) b -> CoRec (Compose Maybe g) b
f CoRec (Compose Maybe g) b
_ c :: CoRec (Compose Maybe g) b
c@(CoVal (Compose (Just g r
_))) = CoRec (Compose Maybe g) b
c
    f CoRec (Compose Maybe g) b
c                            CoRec (Compose Maybe g) b
_ = CoRec (Compose Maybe g) b
c
{-# INLINE lastCoRec #-}

-- |Given a @'Rec' 'Maybe' rs@, yield a @Just field@ for the last field which is @Just@, or @Nothing@ if there are no @Just@ fields in the record.
lastField :: (RMap rs, FoldRec rs rs) => Rec Maybe rs -> Maybe (Field rs)
lastField :: forall (rs :: [*]).
(RMap rs, FoldRec rs rs) =>
Rec Maybe rs -> Maybe (Field rs)
lastField = forall {u} (rs :: [u]) (f :: u -> *).
FoldRec rs rs =>
Rec (Maybe :. f) rs -> Maybe (CoRec f rs)
lastCoRec forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 l k (f :: l -> *) (g :: k -> l) (x :: k).
f (g x) -> Compose f g x
Compose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Identity a
Identity)
{-# INLINE lastField #-}

-- |Helper newtype containing a function @a -> b@ but with the type parameters flipped so @Op b@ has a consistent codomain for a varying domain.
newtype Op b a = Op { forall b a. Op b a -> a -> b
runOp :: a -> b }

-- |Given a list of constraints @cs@ required to apply some function, apply the function to whatever value @r@ (not @f r@) which the 'CoRec' contains.
onCoRec
  :: forall (cs :: [Type -> Constraint]) (f :: Type -> Type) (rs :: [Type]) (b :: Type) (proxy :: [Type -> Constraint] -> Type).
     (AllHave cs rs, Functor f, RecApplicative rs)
  => proxy cs
  -> (forall (a :: Type). HasInstances a cs => a -> b)
  -> CoRec f rs
  -> f b
onCoRec :: forall (cs :: [* -> Constraint]) (f :: * -> *) (rs :: [*]) b
       (proxy :: [* -> Constraint] -> *).
(AllHave cs rs, Functor f, RecApplicative rs) =>
proxy cs
-> (forall a. HasInstances a cs => a -> b) -> CoRec f rs -> f b
onCoRec proxy cs
p forall a. HasInstances a cs => a -> b
f (CoVal f r
x) = r -> b
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f r
x
  where
    go :: r -> b
go = forall b a. Op b a -> a -> b
runOp forall a b. (a -> b) -> a -> b
$ forall {k} (r :: k) (rs :: [k]) (f :: k -> *)
       (record :: (k -> *) -> [k] -> *).
(RecElem record r r rs rs (RIndex r rs), RecElemFCtx record f) =>
record f rs -> f r
rget (forall u (cs :: [u -> Constraint]) (f :: u -> *) (rs :: [u])
       (proxy :: [u -> Constraint] -> *).
(AllHave cs rs, RecApplicative rs) =>
proxy cs
-> (forall (proxy' :: u -> *) (a :: u).
    HasInstances a cs =>
    proxy' a -> f a)
-> Rec f rs
reifyDicts proxy cs
p (\ proxy' a
_ -> forall b a. (a -> b) -> Op b a
Op forall a. HasInstances a cs => a -> b
f) :: Rec (Op b) rs)
{-# INLINE onCoRec #-}

-- |Given a list of constraints @cs@ required to apply some function, apply the function to whatever value @r@ which the 'Field' contains.
onField
  :: forall (cs :: [Type -> Constraint]) (rs :: [Type]) (b :: Type) (proxy :: [Type -> Constraint] -> Type).
     (AllHave cs rs, RecApplicative rs)
  => proxy cs
  -> (forall (a :: Type). HasInstances a cs => a -> b)
  -> Field rs
  -> b
onField :: forall (cs :: [* -> Constraint]) (rs :: [*]) b
       (proxy :: [* -> Constraint] -> *).
(AllHave cs rs, RecApplicative rs) =>
proxy cs
-> (forall a. HasInstances a cs => a -> b) -> Field rs -> b
onField proxy cs
p forall a. HasInstances a cs => a -> b
f Field rs
x = forall a. Identity a -> a
runIdentity (forall (cs :: [* -> Constraint]) (f :: * -> *) (rs :: [*]) b
       (proxy :: [* -> Constraint] -> *).
(AllHave cs rs, Functor f, RecApplicative rs) =>
proxy cs
-> (forall a. HasInstances a cs => a -> b) -> CoRec f rs -> f b
onCoRec proxy cs
p forall a. HasInstances a cs => a -> b
f Field rs
x)
{-# INLINE onField #-}

-- |Given some target type @r@ that's a possible value of @'Field' rs@, yield @Just@ if that is indeed the value being stored by the 'Field', or @Nothing@ if
-- not.
asA :: (r ∈ rs, RMap rs, RecApplicative rs) => Field rs -> Maybe r
asA :: forall r (rs :: [*]).
(r ∈ rs, RMap rs, RecApplicative rs) =>
Field rs -> Maybe r
asA = forall {k} (r :: k) (rs :: [k]) (f :: k -> *)
       (record :: (k -> *) -> [k] -> *).
(RecElem record r r rs rs (RIndex r rs), RecElemFCtx record f) =>
record f rs -> f r
rget forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rs :: [*]).
(RMap rs, RecApplicative rs) =>
Field rs -> Rec Maybe rs
fieldToRec
{-# INLINE asA #-}

-- |An extractor function @f a -> b@ which can be passed to 'foldCoRec' to eliminate one possible alternative of a 'CoRec'.
newtype Case' f b a = Case' { forall {k} (f :: k -> *) b (a :: k). Case' f b a -> f a -> b
unCase' :: f a -> b }

instance Functor f => Contravariant (Case' f b) where
  contramap :: forall a' a. (a' -> a) -> Case' f b a -> Case' f b a'
contramap a' -> a
f (Case' f a -> b
r) = forall {k} (f :: k -> *) b (a :: k). (f a -> b) -> Case' f b a
Case' forall a b. (a -> b) -> a -> b
$ \f a'
x -> f a -> b
r (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a' -> a
f f a'
x) 

-- |A record of @Case'@ eliminators for each @r@ in @rs@ representing the pieces of a total function from @'CoRec' f@ to @b@.
type Cases' f rs b = Rec (Case' f b) rs

-- |Fold a @'CoRec' f@ using @Cases'@ which eliminate each possible value held by the 'CoRec', yielding the @b@ produced by whichever case matches.
foldCoRec :: RecApplicative (r ': rs) => Cases' f (r ': rs) b -> CoRec f (r ': rs) -> b
foldCoRec :: forall {a} (r :: a) (rs :: [a]) (f :: a -> *) b.
RecApplicative (r : rs) =>
Cases' f (r : rs) b -> CoRec f (r : rs) -> b
foldCoRec Cases' f (r : rs) b
hs = forall {u} (f :: u -> *) (rs :: [u]) b.
Cases' f rs b -> Rec (Maybe :. f) rs -> b
go Cases' f (r : rs) b
hs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {u} (rs :: [u]) (f :: u -> *).
RecApplicative rs =>
CoRec f rs -> Rec (Maybe :. f) rs
coRecToRec
  where
    go :: Cases' f rs b -> Rec (Maybe :. f) rs -> b
    go :: forall {u} (f :: u -> *) (rs :: [u]) b.
Cases' f rs b -> Rec (Maybe :. f) rs -> b
go (Case' f r -> b
f :&  Rec (Case' f b) rs
_) (Compose (Just f r
x) :& Rec (Maybe :. f) rs
_) = f r -> b
f f r
x
    go (Case' f r -> b
_ :& Rec (Case' f b) rs
fs) (Compose Maybe (f r)
Nothing  :& Rec (Maybe :. f) rs
t) = forall {u} (f :: u -> *) (rs :: [u]) b.
Cases' f rs b -> Rec (Maybe :. f) rs -> b
go Rec (Case' f b) rs
fs Rec (Maybe :. f) rs
t
    go Rec (Case' f b) rs
RNil            Rec (Maybe :. f) rs
RNil                    = forall a. HasCallStack => String -> a
error String
"foldCoRec should be provably total, isn't"
    {-# INLINE go #-}
{-# INLINE foldCoRec #-}

-- |Fold a @'CoRec' f@ using @Cases'@ which eliminate each possible value held by the 'CoRec', yielding the @b@ produced by whichever case matches.
--
-- Equivalent to 'foldCoRec' but with its arguments flipped so it can be written @matchCoRec coRec $ cases@.
matchCoRec :: RecApplicative (r ': rs) => CoRec f (r ': rs) -> Cases' f (r ': rs) b -> b
matchCoRec :: forall {a} (r :: a) (rs :: [a]) (f :: a -> *) b.
RecApplicative (r : rs) =>
CoRec f (r : rs) -> Cases' f (r : rs) b -> b
matchCoRec = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall {a} (r :: a) (rs :: [a]) (f :: a -> *) b.
RecApplicative (r : rs) =>
Cases' f (r : rs) b -> CoRec f (r : rs) -> b
foldCoRec
{-# INLINE matchCoRec #-}

newtype Case b a = Case { forall b a. Case b a -> a -> b
unCase :: a -> b }

instance Contravariant (Case b) where
  contramap :: forall a' a. (a' -> a) -> Case b a -> Case b a'
contramap a' -> a
f (Case a -> b
r) = forall b a. (a -> b) -> Case b a
Case forall a b. (a -> b) -> a -> b
$ a -> b
r forall b c a. (b -> c) -> (a -> b) -> a -> c
. a' -> a
f

type Cases rs b = Rec (Case b) rs

-- |Fold a 'Field' using 'Cases' which eliminate each possible value held by the 'Field', yielding the @b@ produced by whichever case matches.
foldField :: (RMap rs, RecApplicative (r ': rs)) => Cases (r ': rs) b -> Field (r ': rs) -> b
foldField :: forall (rs :: [*]) r b.
(RMap rs, RecApplicative (r : rs)) =>
Cases (r : rs) b -> Field (r : rs) -> b
foldField Cases (r : rs) b
hs = forall {a} (r :: a) (rs :: [a]) (f :: a -> *) b.
RecApplicative (r : rs) =>
Cases' f (r : rs) b -> CoRec f (r : rs) -> b
foldCoRec (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 {k} (f :: k -> *) b (a :: k). (f a -> b) -> Case' f b a
Case' forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
runIdentity) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Case b a -> a -> b
unCase) Cases (r : rs) b
hs)
{-# INLINE foldField #-}

-- |Fold a 'Field' using 'Cases' which eliminate each possible value held by the 'Field', yielding the @b@ produced by whichever case matches.
--
-- Equivalent to 'foldCoRec' but with its arguments flipped so it can be written @matchCoRec coRec $ cases@.
matchField :: (RMap rs, RecApplicative (r ': rs)) => Field (r ': rs) -> Cases (r ': rs) b -> b
matchField :: forall (rs :: [*]) r b.
(RMap rs, RecApplicative (r : rs)) =>
Field (r : rs) -> Cases (r : rs) b -> b
matchField = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (rs :: [*]) r b.
(RMap rs, RecApplicative (r : rs)) =>
Cases (r : rs) b -> Field (r : rs) -> b
foldField
{-# INLINE matchField #-}

-- |Widen a @'CoRec' f rs@ to a @'CoRec' f ss@ given that @rs ⊆ ss@.
widenCoRec :: (FoldRec ss ss, RecApplicative rs, RecApplicative ss, rs ⊆ ss) => CoRec f rs -> CoRec f ss
widenCoRec :: forall {u} (ss :: [u]) (rs :: [u]) (f :: u -> *).
(FoldRec ss ss, RecApplicative rs, RecApplicative ss, rs ⊆ ss) =>
CoRec f rs -> CoRec f ss
widenCoRec CoRec f rs
r =
  forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"widenCoRec should be provably total, isn't") forall a b. (a -> b) -> a -> b
$
    forall {u} (rs :: [u]) (f :: u -> *).
FoldRec rs rs =>
Rec (Maybe :. f) rs -> Maybe (CoRec f rs)
firstCoRec (forall {k1} {k2} (rs :: [k1]) (ss :: [k1]) (f :: k2 -> *)
       (record :: (k2 -> *) -> [k1] -> *) (is :: [Nat]).
(RecSubset record rs ss is, RecSubsetFCtx record f) =>
record f rs -> record f ss -> record f ss
rreplace (forall {u} (rs :: [u]) (f :: u -> *).
RecApplicative rs =>
CoRec f rs -> Rec (Maybe :. f) rs
coRecToRec CoRec f rs
r) (forall {u} (rs :: [u]) (f :: u -> *).
RecApplicative rs =>
(forall (x :: u). f x) -> Rec f rs
rpure forall a b. (a -> b) -> a -> b
$ forall l k (f :: l -> *) (g :: k -> l) (x :: k).
f (g x) -> Compose f g x
Compose forall a. Maybe a
Nothing))

-- |Widen a @'Field' rs@ to a @'Field' ss@ given that @rs ⊆ ss@.
widenField :: (FoldRec ss ss, RMap rs, RMap ss, RecApplicative rs, RecApplicative ss, rs ⊆ ss) => Field rs -> Field ss
widenField :: forall (ss :: [*]) (rs :: [*]).
(FoldRec ss ss, RMap rs, RMap ss, RecApplicative rs,
 RecApplicative ss, rs ⊆ ss) =>
Field rs -> Field ss
widenField Field rs
r =
  forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"widenField should be provably total, isn't") forall a b. (a -> b) -> a -> b
$
    forall (rs :: [*]).
(FoldRec rs rs, RMap rs) =>
Rec Maybe rs -> Maybe (Field rs)
firstField (forall {k1} {k2} (rs :: [k1]) (ss :: [k1]) (f :: k2 -> *)
       (record :: (k2 -> *) -> [k1] -> *) (is :: [Nat]).
(RecSubset record rs ss is, RecSubsetFCtx record f) =>
record f rs -> record f ss -> record f ss
rreplace (forall (rs :: [*]).
(RMap rs, RecApplicative rs) =>
Field rs -> Rec Maybe rs
fieldToRec Field rs
r) (forall {u} (rs :: [u]) (f :: u -> *).
RecApplicative rs =>
(forall (x :: u). f x) -> Rec f rs
rpure forall a. Maybe a
Nothing))

-- |Constraint showing that @rs ⊆ ss@ and giving enough power to widen a @'CoRec' f rs@ to @'CoRec' f ss@.
type WiderCoRec rs ss = (FoldRec ss ss, RecApplicative rs, RecApplicative ss, rs ⊆ ss)

-- |Constraint on a pair of types @r@ and @s@ which are 'Wrapped' around @'CoRec' f rs@ and @'CoRec' f ss@ respectively and observes that those types can be unwrapped and the former can be widened to the latter.
type WrappedWiderCoRec f r rs s ss = (Wrapped r, Unwrapped r ~ CoRec f rs, Wrapped s, Unwrapped s ~ CoRec f ss, WiderCoRec rs ss)

-- |'WrappedWiderCoRec' specialized to 'CoRec' 'Identity', i.e. 'Field'.
type WrappedWiderField r rs s ss = WrappedWiderCoRec Identity r rs s ss

-- |Widen a @'CoRec' f rs@ wrapped in @r@ to a @'CoRec' f ss@ wrapped in @s@.
widenWrappedCoRec :: WrappedWiderCoRec f r rs s ss => r -> s
widenWrappedCoRec :: forall {k} (f :: k -> *) r (rs :: [k]) s (ss :: [k]).
WrappedWiderCoRec f r rs s ss =>
r -> s
widenWrappedCoRec = forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review forall s. Wrapped s => Iso' s (Unwrapped s)
_Wrapped' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {u} (ss :: [u]) (rs :: [u]) (f :: u -> *).
(FoldRec ss ss, RecApplicative rs, RecApplicative ss, rs ⊆ ss) =>
CoRec f rs -> CoRec f ss
widenCoRec forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s. Wrapped s => Iso' s (Unwrapped s)
_Wrapped'

-- |Widen a @'Field' rs@ wrapped in @r@ to a @'Field' ss@ wrapped in @s@.
widenWrappedField :: WrappedWiderField r rs s ss => r -> s
widenWrappedField :: forall r (rs :: [*]) s (ss :: [*]).
WrappedWiderField r rs s ss =>
r -> s
widenWrappedField = forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review forall s. Wrapped s => Iso' s (Unwrapped s)
_Wrapped' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {u} (ss :: [u]) (rs :: [u]) (f :: u -> *).
(FoldRec ss ss, RecApplicative rs, RecApplicative ss, rs ⊆ ss) =>
CoRec f rs -> CoRec f ss
widenCoRec forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s. Wrapped s => Iso' s (Unwrapped s)
_Wrapped'

-- |Widen a wrapped 'CoRec' using 'widenWrappedCoRec' and then throw it as an 'ExceptT' error, as a convenience when using 'CoRec' / 'Field' for building up error types by set union.
throwWidened :: (Monad m, WrappedWiderCoRec f e er e' er') => e -> ExceptT e' m a
throwWidened :: forall {k} (m :: * -> *) (f :: k -> *) e (er :: [k]) e'
       (er' :: [k]) a.
(Monad m, WrappedWiderCoRec f e er e' er') =>
e -> ExceptT e' m a
throwWidened = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: k -> *) r (rs :: [k]) s (ss :: [k]).
WrappedWiderCoRec f r rs s ss =>
r -> s
widenWrappedCoRec

-- |Catch a wrapped 'CoRec' thrown by an 'ExceptT' and widen it using 'widenWrappedCoRec' then rethrow it, as a convenience when using 'CoRec' / 'Field' for building up error types by set union.
rethrowWidened :: (Functor m, WrappedWiderCoRec f e er e' er') => ExceptT e m a -> ExceptT e' m a
rethrowWidened :: forall {k} (m :: * -> *) (f :: k -> *) e (er :: [k]) e'
       (er' :: [k]) a.
(Functor m, WrappedWiderCoRec f e er e' er') =>
ExceptT e m a -> ExceptT e' m a
rethrowWidened = forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT forall {k} (f :: k -> *) r (rs :: [k]) s (ss :: [k]).
WrappedWiderCoRec f r rs s ss =>
r -> s
widenWrappedCoRec

-- |Specialized type of 'Case' for 'Val', with the type parameters in a convenient order for type application, e.g.:
--
-- @
--   valCase @"foo" (\ a -> ...)
--     :& valCase @"bar" (\ b -> ...)
--     :& RNil
-- @
valCase :: forall s a b. (a -> b) -> Case b (s :-> a)
valCase :: forall (s :: Symbol) a b. (a -> b) -> Case b (s :-> a)
valCase a -> b
f = forall b a. (a -> b) -> Case b a
Case forall a b. (a -> b) -> a -> b
$ \(Val a
a) -> a -> b
f a
a

-- |Specialized type of 'Case'' for 'Val', with the type parameters in a convenient order for type application, e.g.:
--
-- @
--   valCase' @"foo" (\ fa -> ...)
--     :& valCase' @"bar" (\ fb -> ...)
--     :& RNil
-- @
valCase' :: forall s f a b. Functor f => (f a -> b) -> Case' f b (s :-> a)
valCase' :: forall (s :: Symbol) (f :: * -> *) a b.
Functor f =>
(f a -> b) -> Case' f b (s :-> a)
valCase' f a -> b
f = forall {k} (f :: k -> *) b (a :: k). (f a -> b) -> Case' f b a
Case' forall a b. (a -> b) -> a -> b
$ \f (s :-> a)
fva -> f a -> b
f (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (s :: Symbol) a. (s :-> a) -> a
getVal f (s :-> a)
fva)

-- |Make a 'Case' which yields the symbol text for a field @s :-> ()@. E.g.:
--
-- @
--   keywordCase @"foo" (Identity (Val ())) == "foo"
-- @
keywordCase :: KnownSymbol s => Case Text (s :-> ())
keywordCase :: forall (s :: Symbol). KnownSymbol s => Case Text (s :-> ())
keywordCase = forall (s :: Symbol) a.
KnownSymbol s =>
(Text -> a) -> Case a (s :-> ())
keywordCase' forall a. a -> a
id

-- |Make a 'Case'' which yields the symbol text for a field @s :-> ()@ as projected through the given function. E.g.:
--
-- @
--   keywordCase @"foo" (<> "bar") (Identity (Val ())) == "foobar"
-- @
keywordCase' :: KnownSymbol s => (Text -> a) -> Case a (s :-> ())
keywordCase' :: forall (s :: Symbol) a.
KnownSymbol s =>
(Text -> a) -> Case a (s :-> ())
keywordCase' Text -> a
f = forall b a. (a -> b) -> Case b a
Case forall a b. (a -> b) -> a -> b
$ \(Val () :: s :-> ()) -> Text -> a
f (String -> Text
pack (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @s)))