{-# language DataKinds #-}
{-# language GADTs #-}
{-# language LambdaCase #-}
{-# language StandaloneKindSignatures #-}
module Rel8.Aggregate.Fold
( Fallback (Empty, Fallback)
, Fold (Semi, Full)
)
where
import Control.Applicative (liftA2)
import Data.Kind (Type)
import Prelude
import Data.Functor.Apply (Apply, liftF2)
type Fold :: Type
data Fold = Semi | Full
type Fallback :: Fold -> Type -> Type
data Fallback fold a where
Fallback :: !a -> Fallback fold a
Empty :: Fallback 'Semi a
instance Functor (Fallback fold) where
fmap :: forall a b. (a -> b) -> Fallback fold a -> Fallback fold b
fmap a -> b
f = \case
Fallback a
a -> b -> Fallback fold b
forall a (fold :: Fold). a -> Fallback fold a
Fallback (a -> b
f a
a)
Fallback fold a
Empty -> Fallback fold b
Fallback 'Semi b
forall a. Fallback 'Semi a
Empty
instance Apply (Fallback fold) where
liftF2 :: forall a b c.
(a -> b -> c)
-> Fallback fold a -> Fallback fold b -> Fallback fold c
liftF2 a -> b -> c
f (Fallback a
a) (Fallback b
b) = c -> Fallback fold c
forall a (fold :: Fold). a -> Fallback fold a
Fallback (a -> b -> c
f a
a b
b)
liftF2 a -> b -> c
_ (Fallback a
_) Fallback fold b
Empty = Fallback fold c
Fallback 'Semi c
forall a. Fallback 'Semi a
Empty
liftF2 a -> b -> c
_ Fallback fold a
Empty (Fallback b
_) = Fallback fold c
Fallback 'Semi c
forall a. Fallback 'Semi a
Empty
liftF2 a -> b -> c
_ Fallback fold a
Empty Fallback fold b
Empty = Fallback fold c
Fallback 'Semi c
forall a. Fallback 'Semi a
Empty
instance Applicative (Fallback fold) where
pure :: forall a. a -> Fallback fold a
pure = a -> Fallback fold a
forall a (fold :: Fold). a -> Fallback fold a
Fallback
liftA2 :: forall a b c.
(a -> b -> c)
-> Fallback fold a -> Fallback fold b -> Fallback fold c
liftA2 = (a -> b -> c)
-> Fallback fold a -> Fallback fold b -> Fallback fold c
forall a b c.
(a -> b -> c)
-> Fallback fold a -> Fallback fold b -> Fallback fold c
forall (f :: * -> *) a b c.
Apply f =>
(a -> b -> c) -> f a -> f b -> f c
liftF2