{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
module Frames.Folds
(
EndoFold
, FoldEndo(..)
, FoldFieldEndo(..)
, FoldRecord(..)
, toFoldRecord
, recFieldF
, fieldToFieldFold
, sequenceRecFold
, sequenceEndoFolds
, foldAll
, ConstrainedFoldable
, foldAllConstrained
, foldAllMonoid
, monoidWrapperToFold
, MonoidalField
)
where
import qualified Control.Foldl as FL
import qualified Control.Newtype as N
#if MIN_VERSION_base(4,11,0)
#else
import Data.Monoid ( (<>) )
import Data.Monoid ( Monoid(..))
#endif
import qualified Data.Profunctor as P
import qualified Data.Vinyl as V
import qualified Data.Vinyl.TypeLevel as V
import qualified Data.Vinyl.Functor as V
import qualified Frames as F
import qualified Frames.Melt as F
type EndoFold a = FL.Fold a a
fieldFold
:: (V.KnownField t, a ~ V.Snd t) => EndoFold a -> EndoFold (F.ElField t)
fieldFold :: forall (t :: (Symbol, *)) a.
(KnownField t, a ~ Snd t) =>
EndoFold a -> EndoFold (ElField t)
fieldFold = forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
P.dimap (\(V.Field Snd t
x) -> Snd t
x) forall (t :: (Symbol, *)). Snd t -> ElField t
V.Field
{-# INLINABLE fieldFold #-}
newtype FoldEndo t = FoldEndo { forall {k1} (t :: (k1, *)). FoldEndo t -> EndoFold (Snd t)
unFoldEndo :: EndoFold (V.Snd t) }
newtype FoldFieldEndo f a = FoldFieldEndo { forall {k} (f :: k -> *) (a :: k).
FoldFieldEndo f a -> EndoFold (f a)
unFoldFieldEndo :: EndoFold (f a) }
newtype FoldRecord f rs a = FoldRecord { forall {k} (f :: k -> *) (rs :: [(Symbol, *)]) (a :: k).
FoldRecord f rs a -> Fold (Record rs) (f a)
unFoldRecord :: FL.Fold (F.Record rs) (f a) }
toFoldRecord
:: V.KnownField t
=> FL.Fold (F.Record rs) (V.Snd t)
-> FoldRecord F.ElField rs t
toFoldRecord :: forall (t :: (Symbol, *)) (rs :: [(Symbol, *)]).
KnownField t =>
Fold (Record rs) (Snd t) -> FoldRecord ElField rs t
toFoldRecord = forall {k} (f :: k -> *) (rs :: [(Symbol, *)]) (a :: k).
Fold (Record rs) (f a) -> FoldRecord f rs a
FoldRecord forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: (Symbol, *)). Snd t -> ElField t
V.Field
{-# INLINABLE toFoldRecord #-}
recFieldF
:: forall t rs a
. V.KnownField t
=> FL.Fold a (V.Snd t)
-> (F.Record rs -> a)
-> FoldRecord V.ElField rs t
recFieldF :: forall (t :: (Symbol, *)) (rs :: [(Symbol, *)]) a.
KnownField t =>
Fold a (Snd t) -> (Record rs -> a) -> FoldRecord ElField rs t
recFieldF Fold a (Snd t)
fld Record rs -> a
fromRec = forall {k} (f :: k -> *) (rs :: [(Symbol, *)]) (a :: k).
Fold (Record rs) (f a) -> FoldRecord f rs a
FoldRecord forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
P.dimap Record rs -> a
fromRec forall (t :: (Symbol, *)). Snd t -> ElField t
V.Field Fold a (Snd t)
fld
{-# INLINABLE recFieldF #-}
fieldToFieldFold
:: forall x y rs
. (V.KnownField x, V.KnownField y, F.ElemOf rs x)
=> FL.Fold (V.Snd x) (V.Snd y)
-> FoldRecord F.ElField rs y
fieldToFieldFold :: forall (x :: (Symbol, *)) (y :: (Symbol, *)) (rs :: [(Symbol, *)]).
(KnownField x, KnownField y, ElemOf rs x) =>
Fold (Snd x) (Snd y) -> FoldRecord ElField rs y
fieldToFieldFold Fold (Snd x) (Snd y)
fld = forall (t :: (Symbol, *)) (rs :: [(Symbol, *)]) a.
KnownField t =>
Fold a (Snd t) -> (Record rs -> a) -> FoldRecord ElField rs t
recFieldF Fold (Snd x) (Snd y)
fld (forall (t :: (Symbol, *)) (s :: Symbol) a (rs :: [(Symbol, *)]).
(t ~ '(s, a), t ∈ rs) =>
Record rs -> a
F.rgetField @x)
{-# INLINABLE fieldToFieldFold #-}
expandFoldInRecord
:: forall rs as
. (as F.⊆ rs, V.RMap as)
=> F.Rec (FoldRecord F.ElField as) as
-> F.Rec (FoldRecord F.ElField rs) as
expandFoldInRecord :: forall (rs :: [(Symbol, *)]) (as :: [(Symbol, *)]).
(as ⊆ rs, RMap as) =>
Rec (FoldRecord ElField as) as -> Rec (FoldRecord ElField rs) as
expandFoldInRecord = forall {u} (rs :: [u]) (f :: u -> *) (g :: u -> *).
RMap rs =>
(forall (x :: u). f x -> g x) -> Rec f rs -> Rec g rs
V.rmap (forall {k} (f :: k -> *) (rs :: [(Symbol, *)]) (a :: k).
Fold (Record rs) (f a) -> FoldRecord f rs a
FoldRecord forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b r. (a -> b) -> Fold b r -> Fold a r
FL.premap forall {k1} {k2} (rs :: [k1]) (ss :: [k1]) (f :: k2 -> *)
(record :: (k2 -> *) -> [k1] -> *) (is :: [Nat]).
(RecSubset record rs ss is, RecSubsetFCtx record f) =>
record f ss -> record f rs
F.rcast forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: k -> *) (rs :: [(Symbol, *)]) (a :: k).
FoldRecord f rs a -> Fold (Record rs) (f a)
unFoldRecord)
{-# INLINABLE expandFoldInRecord #-}
class EndoFieldFoldsToRecordFolds rs where
endoFieldFoldsToRecordFolds :: F.Rec (FoldFieldEndo F.ElField) rs -> F.Rec (FoldRecord F.ElField rs) rs
instance EndoFieldFoldsToRecordFolds '[] where
endoFieldFoldsToRecordFolds :: Rec (FoldFieldEndo ElField) '[] -> Rec (FoldRecord ElField '[]) '[]
endoFieldFoldsToRecordFolds Rec (FoldFieldEndo ElField) '[]
_ = forall {u} (a :: u -> *). Rec a '[]
V.RNil
{-# INLINABLE endoFieldFoldsToRecordFolds #-}
instance (EndoFieldFoldsToRecordFolds rs, rs F.⊆ (r ': rs), V.RMap rs) => EndoFieldFoldsToRecordFolds (r ': rs) where
endoFieldFoldsToRecordFolds :: Rec (FoldFieldEndo ElField) (r : rs)
-> Rec (FoldRecord ElField (r : rs)) (r : rs)
endoFieldFoldsToRecordFolds (FoldFieldEndo ElField r
fe V.:& Rec (FoldFieldEndo ElField) rs
fes) = forall {k} (f :: k -> *) (rs :: [(Symbol, *)]) (a :: k).
Fold (Record rs) (f a) -> FoldRecord f rs a
FoldRecord (forall a b r. (a -> b) -> Fold b r -> Fold a r
FL.premap (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
V.rget @r) (forall {k} (f :: k -> *) (a :: k).
FoldFieldEndo f a -> EndoFold (f a)
unFoldFieldEndo FoldFieldEndo ElField r
fe)) forall {u} (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
V.:& forall (rs :: [(Symbol, *)]) (as :: [(Symbol, *)]).
(as ⊆ rs, RMap as) =>
Rec (FoldRecord ElField as) as -> Rec (FoldRecord ElField rs) as
expandFoldInRecord @(r ': rs) (forall (rs :: [(Symbol, *)]).
EndoFieldFoldsToRecordFolds rs =>
Rec (FoldFieldEndo ElField) rs -> Rec (FoldRecord ElField rs) rs
endoFieldFoldsToRecordFolds Rec (FoldFieldEndo ElField) rs
fes)
{-# INLINABLE endoFieldFoldsToRecordFolds #-}
sequenceRecFold
:: forall as rs
. F.Rec (FoldRecord F.ElField as) rs
-> FL.Fold (F.Record as) (F.Record rs)
sequenceRecFold :: forall (as :: [(Symbol, *)]) (rs :: [(Symbol, *)]).
Rec (FoldRecord ElField as) rs -> Fold (Record as) (Record rs)
sequenceRecFold = forall {u} (h :: * -> *) (f :: u -> *) (g :: u -> *) (rs :: [u]).
Applicative h =>
(forall (x :: u). f x -> h (g x)) -> Rec f rs -> h (Rec g rs)
V.rtraverse forall {k} (f :: k -> *) (rs :: [(Symbol, *)]) (a :: k).
FoldRecord f rs a -> Fold (Record rs) (f a)
unFoldRecord
{-# INLINABLE sequenceRecFold #-}
sequenceFieldEndoFolds
:: EndoFieldFoldsToRecordFolds rs
=> F.Rec (FoldFieldEndo F.ElField) rs
-> FL.Fold (F.Record rs) (F.Record rs)
sequenceFieldEndoFolds :: forall (rs :: [(Symbol, *)]).
EndoFieldFoldsToRecordFolds rs =>
Rec (FoldFieldEndo ElField) rs -> Fold (Record rs) (Record rs)
sequenceFieldEndoFolds = forall (as :: [(Symbol, *)]) (rs :: [(Symbol, *)]).
Rec (FoldRecord ElField as) rs -> Fold (Record as) (Record rs)
sequenceRecFold forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rs :: [(Symbol, *)]).
EndoFieldFoldsToRecordFolds rs =>
Rec (FoldFieldEndo ElField) rs -> Rec (FoldRecord ElField rs) rs
endoFieldFoldsToRecordFolds
{-# INLINABLE sequenceFieldEndoFolds #-}
liftFoldEndo :: V.KnownField t => FoldEndo t -> FoldFieldEndo F.ElField t
liftFoldEndo :: forall (t :: (Symbol, *)).
KnownField t =>
FoldEndo t -> FoldFieldEndo ElField t
liftFoldEndo = forall {k} (f :: k -> *) (a :: k).
EndoFold (f a) -> FoldFieldEndo f a
FoldFieldEndo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (Symbol, *)) a.
(KnownField t, a ~ Snd t) =>
EndoFold a -> EndoFold (ElField t)
fieldFold forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k1} (t :: (k1, *)). FoldEndo t -> EndoFold (Snd t)
unFoldEndo
{-# INLINABLE liftFoldEndo #-}
liftFolds
:: (V.RPureConstrained V.KnownField rs, V.RApply rs)
=> F.Rec FoldEndo rs
-> F.Rec (FoldFieldEndo F.ElField) rs
liftFolds :: forall (rs :: [(Symbol, *)]).
(RPureConstrained KnownField rs, RApply rs) =>
Rec FoldEndo rs -> Rec (FoldFieldEndo ElField) rs
liftFolds = forall {u} (rs :: [u]) (f :: u -> *) (g :: u -> *).
RApply rs =>
Rec (Lift (->) f g) rs -> Rec f rs -> Rec g rs
V.rapply Rec (Lift (->) FoldEndo (FoldFieldEndo ElField)) rs
liftedFs
where liftedFs :: Rec (Lift (->) FoldEndo (FoldFieldEndo ElField)) rs
liftedFs = forall {k} (c :: k -> Constraint) (ts :: [k]) (f :: k -> *).
RPureConstrained c ts =>
(forall (a :: k). c a => f a) -> Rec f ts
V.rpureConstrained @V.KnownField forall a b. (a -> b) -> a -> b
$ forall l l' k (op :: l -> l' -> *) (f :: k -> l) (g :: k -> l')
(x :: k).
op (f x) (g x) -> Lift op f g x
V.Lift forall (t :: (Symbol, *)).
KnownField t =>
FoldEndo t -> FoldFieldEndo ElField t
liftFoldEndo
{-# INLINABLE liftFolds #-}
sequenceEndoFolds
:: forall rs
. ( V.RApply rs
, V.RPureConstrained V.KnownField rs
, EndoFieldFoldsToRecordFolds rs
)
=> F.Rec FoldEndo rs
-> FL.Fold (F.Record rs) (F.Record rs)
sequenceEndoFolds :: forall (rs :: [(Symbol, *)]).
(RApply rs, RPureConstrained KnownField rs,
EndoFieldFoldsToRecordFolds rs) =>
Rec FoldEndo rs -> Fold (Record rs) (Record rs)
sequenceEndoFolds = forall (rs :: [(Symbol, *)]).
EndoFieldFoldsToRecordFolds rs =>
Rec (FoldFieldEndo ElField) rs -> Fold (Record rs) (Record rs)
sequenceFieldEndoFolds forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rs :: [(Symbol, *)]).
(RPureConstrained KnownField rs, RApply rs) =>
Rec FoldEndo rs -> Rec (FoldFieldEndo ElField) rs
liftFolds
{-# INLINABLE sequenceEndoFolds #-}
foldAll
:: ( V.RPureConstrained V.KnownField rs
, V.RApply rs
, EndoFieldFoldsToRecordFolds rs
)
=> (forall a . FL.Fold a a)
-> FL.Fold (F.Record rs) (F.Record rs)
foldAll :: forall (rs :: [(Symbol, *)]).
(RPureConstrained KnownField rs, RApply rs,
EndoFieldFoldsToRecordFolds rs) =>
(forall a. Fold a a) -> Fold (Record rs) (Record rs)
foldAll forall a. Fold a a
f = forall (rs :: [(Symbol, *)]).
(RApply rs, RPureConstrained KnownField rs,
EndoFieldFoldsToRecordFolds rs) =>
Rec FoldEndo rs -> Fold (Record rs) (Record rs)
sequenceEndoFolds forall a b. (a -> b) -> a -> b
$ forall {k} (c :: k -> Constraint) (ts :: [k]) (f :: k -> *).
RPureConstrained c ts =>
(forall (a :: k). c a => f a) -> Rec f ts
V.rpureConstrained @V.KnownField (forall {k1} (t :: (k1, *)). EndoFold (Snd t) -> FoldEndo t
FoldEndo forall a. Fold a a
f)
{-# INLINABLE foldAll #-}
class (c (V.Snd t)) => ConstrainedField c t
instance (c (V.Snd t)) => ConstrainedField c t
type ConstrainedFoldable c rs = (V.RPureConstrained (ConstrainedField c) rs
, V.RPureConstrained V.KnownField rs
, V.RApply rs
, EndoFieldFoldsToRecordFolds rs
)
foldAllConstrained
:: forall c rs. ConstrainedFoldable c rs
=> (forall a . c a => FL.Fold a a)
-> FL.Fold (F.Record rs) (F.Record rs)
foldAllConstrained :: forall (c :: * -> Constraint) (rs :: [(Symbol, *)]).
ConstrainedFoldable c rs =>
(forall a. c a => Fold a a) -> Fold (Record rs) (Record rs)
foldAllConstrained forall a. c a => Fold a a
f =
forall (rs :: [(Symbol, *)]).
(RApply rs, RPureConstrained KnownField rs,
EndoFieldFoldsToRecordFolds rs) =>
Rec FoldEndo rs -> Fold (Record rs) (Record rs)
sequenceEndoFolds forall a b. (a -> b) -> a -> b
$ forall {k} (c :: k -> Constraint) (ts :: [k]) (f :: k -> *).
RPureConstrained c ts =>
(forall (a :: k). c a => f a) -> Rec f ts
V.rpureConstrained @(ConstrainedField c) (forall {k1} (t :: (k1, *)). EndoFold (Snd t) -> FoldEndo t
FoldEndo forall a. c a => Fold a a
f)
{-# INLINABLE foldAllConstrained #-}
monoidWrapperToFold
:: forall f a . (N.Newtype (f a) a, Monoid (f a)) => FL.Fold a a
monoidWrapperToFold :: forall (f :: * -> *) a. (Newtype (f a) a, Monoid (f a)) => Fold a a
monoidWrapperToFold = forall a b x. (x -> a -> x) -> x -> (x -> b) -> Fold a b
FL.Fold (\f a
w a
a -> forall n o. Newtype n o => o -> n
N.pack a
a forall a. Semigroup a => a -> a -> a
<> f a
w) (forall a. Monoid a => a
mempty @(f a)) forall n o. Newtype n o => n -> o
N.unpack
{-# INLINABLE monoidWrapperToFold #-}
class (N.Newtype (f a) a, Monoid (f a)) => MonoidalField f a
instance (N.Newtype (f a) a, Monoid (f a)) => MonoidalField f a
foldAllMonoid
:: forall f rs
. ( V.RPureConstrained (ConstrainedField (MonoidalField f)) rs
, V.RPureConstrained V.KnownField rs
, V.RApply rs
, EndoFieldFoldsToRecordFolds rs
)
=> FL.Fold (F.Record rs) (F.Record rs)
foldAllMonoid :: forall (f :: * -> *) (rs :: [(Symbol, *)]).
(RPureConstrained (ConstrainedField (MonoidalField f)) rs,
RPureConstrained KnownField rs, RApply rs,
EndoFieldFoldsToRecordFolds rs) =>
Fold (Record rs) (Record rs)
foldAllMonoid = forall (c :: * -> Constraint) (rs :: [(Symbol, *)]).
ConstrainedFoldable c rs =>
(forall a. c a => Fold a a) -> Fold (Record rs) (Record rs)
foldAllConstrained @(MonoidalField f) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. (Newtype (f a) a, Monoid (f a)) => Fold a a
monoidWrapperToFold @f
{-# INLINABLE foldAllMonoid #-}