{-# language DataKinds #-}
{-# language GADTs #-}
{-# language LambdaCase #-}
{-# language StandaloneKindSignatures #-}

module Rel8.Aggregate.Fold
  ( Fallback (Empty, Fallback)
  , Fold (Semi, Full)
  )
where

-- base
import Control.Applicative (liftA2)
import Data.Kind (Type)
import Prelude

-- semigroupoids
import Data.Functor.Apply (Apply, liftF2)


-- | 'Fold' is a kind that parameterises aggregations. Aggregations
-- parameterised by 'Semi' are analogous to 'Data.Semigroup.Foldable.foldMap1'
-- (i.e, they can only produce results on a non-empty 'Rel8.Query') whereas
-- aggregations parameterised by 'Full' are analagous to 'foldMap' (given a
-- non-empty) query, they return the identity values of the aggregation
-- functions.
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