-- |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', prism')
import Data.Functor.Contravariant (Contravariant(contramap))
import Data.Functor.Identity (Identity(Identity), runIdentity)
import Data.Kind (Constraint)
import Data.Maybe (fromMaybe)
import Data.Profunctor (dimap)
import Data.Proxy (Proxy(Proxy))
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)

-- 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 -> *) -> [u] -> * 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 :: [* -> 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 :: 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 :: [* -> Constraint]) (rs :: [*]) (b :: *) (proxy :: [* -> Constraint] -> *).
     (AllHave cs rs, RecApplicative rs)
  => proxy cs
  -> (forall (a :: *). 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))