These.hs

{-# language DataKinds #-}
{-# language DeriveFunctor #-}
{-# language DerivingStrategies #-}
{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language MultiParamTypeClasses #-}
{-# language NamedFieldPuns #-}
{-# language ScopedTypeVariables #-}
{-# language StandaloneKindSignatures #-}
{-# language TupleSections #-}
{-# language TypeApplications #-}
{-# language TypeFamilies #-}
{-# language TypeOperators #-}
{-# language UndecidableInstances #-}

{-# options_ghc -fno-warn-orphans #-}

module Rel8.Table.These
  ( TheseTable(..)
  , theseTable, thisTable, thatTable, thoseTable
  , isThisTable, isThatTable, isThoseTable
  , hasHereTable, hasThereTable
  , justHereTable, justThereTable
  , alignMaybeTable
  , aggregateThisTable, aggregateThisTable1
  , aggregateThatTable, aggregateThatTable1
  , aggregateThoseTable, aggregateThoseTable1
  , aggregateHereTable, aggregateHereTable1
  , aggregateThereTable, aggregateThereTable1
  , aggregateTheseTable
  , nameTheseTable
  )
where

-- base
import Control.Arrow ((&&&))
import Data.Bifunctor ( Bifunctor, bimap )
import Data.Kind ( Type )
import Data.Maybe ( isJust )
import Prelude hiding ( null, undefined )

-- profunctors
import Data.Profunctor (lmap)

-- rel8
import Rel8.Aggregate (Aggregator, Aggregator', Aggregator1)
import Rel8.Expr ( Expr )
import Rel8.Expr.Bool ( (&&.), (||.), boolExpr, not_ )
import Rel8.Expr.Null ( null, isNonNull )
import Rel8.Kind.Context ( Reifiable )
import Rel8.Schema.Context.Nullify ( Nullifiable )
import Rel8.Schema.Dict ( Dict( Dict ) )
import Rel8.Schema.HTable.Label ( hlabel, hrelabel, hunlabel )
import Rel8.Schema.HTable.Identity ( HIdentity(..) )
import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
import Rel8.Schema.HTable.These ( HTheseTable(..) )
import qualified Rel8.Schema.Kind as K
import Rel8.Schema.Name ( Name )
import Rel8.Table
  ( Table, Columns, Context, fromColumns, toColumns
  , FromExprs, fromResult, toResult
  , Transpose
  )
import Rel8.Table.Aggregate (filterWhere)
import Rel8.Table.Aggregate.Maybe
  ( aggregateJustTable, aggregateJustTable1
  , aggregateMaybeTable
  , filterWhereOptional
  )
import Rel8.Table.Eq ( EqTable, eqTable )
import Rel8.Table.Maybe
  ( MaybeTable(..)
  , maybeTable, justTable, nothingTable
  , isJustTable
  , nameMaybeTable
  , unsafeFromJustTable
  )
import Rel8.Table.Nullify ( Nullify, guard )
import Rel8.Table.Ord ( OrdTable, ordTable )
import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project )
import Rel8.Table.Serialize ( ToExprs )
import Rel8.Table.Undefined ( undefined )
import Rel8.Type.Tag ( MaybeTag )

-- semigroupoids
import Data.Functor.Apply ( Apply, (<.>) )
import Data.Functor.Bind ( Bind, (>>-) )

-- these
import Data.These ( These( This, That, These ) )
import Data.These.Combinators ( justHere, justThere )


-- | @TheseTable a b@ is a Rel8 table that contains either the table @a@, the
-- table @b@, or both tables @a@ and @b@. You can construct @TheseTable@s using
-- 'thisTable', 'thatTable' and 'thoseTable'. @TheseTable@s can be
-- eliminated/pattern matched using 'theseTable'.
--
-- @TheseTable@ is operationally the same as Haskell's 'These' type, but
-- adapted to work with Rel8.
type TheseTable :: K.Context -> Type -> Type -> Type
data TheseTable context a b = TheseTable
  { here :: MaybeTable context a
  , there :: MaybeTable context b
  }
  deriving stock Functor


instance Biprojectable (TheseTable context) where
  biproject f g (TheseTable a b) = TheseTable (project f a) (project g b)


instance Nullifiable context => Bifunctor (TheseTable context) where
  bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)


instance Projectable (TheseTable context a) where
  project f (TheseTable a b) = TheseTable a (project f b)


instance (context ~ Expr, Table Expr a, Semigroup a) =>
  Apply (TheseTable context a)
 where
  fs <.> as = TheseTable
    { here = here fs <> here as
    , there = there fs <.> there as
    }


instance (context ~ Expr, Table Expr a, Semigroup a) =>
  Applicative (TheseTable context a)
 where
  pure = thatTable
  (<*>) = (<.>)


instance (context ~ Expr, Table Expr a, Semigroup a) =>
  Bind (TheseTable context a)
 where
  TheseTable here1 ma >>- f = case ma >>- f' of
    mtb -> TheseTable
      { here = maybeTable here1 ((here1 <>) . fst) mtb
      , there = snd <$> mtb
      }
    where
      f' a = case f a of
        TheseTable here2 mb -> (here2,) <$> mb


instance (context ~ Expr, Table Expr a, Semigroup a) =>
  Monad (TheseTable context a)
 where
  (>>=) = (>>-)


instance (context ~ Expr, Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
  Semigroup (TheseTable context a b)
 where
  a <> b = TheseTable
    { here = here a <> here b
    , there = there a <> there b
    }


instance
  ( Table context a, Table context b
  , Reifiable context, context ~ context'
  )
  => Table context' (TheseTable context a b)
 where
  type Columns (TheseTable context a b) = HTheseTable (Columns a) (Columns b)
  type Context (TheseTable context a b) = Context a
  type FromExprs (TheseTable context a b) =
    These (FromExprs a) (FromExprs b)
  type Transpose to (TheseTable context a b) =
    TheseTable to (Transpose to a) (Transpose to b)

  toColumns TheseTable {here, there} = HTheseTable
    { hhereTag = hlabel $ HIdentity $ tag here
    , hhere =
        hlabel $ guard (tag here) isJust isNonNull $ toColumns $ just here
    , hthereTag = hlabel $ HIdentity $ tag there
    , hthere =
        hlabel $ guard (tag there) isJust isNonNull $ toColumns $ just there
    }

  fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable
    { here = MaybeTable
        { tag = unHIdentity $ hunlabel hhereTag
        , just = fromColumns $ hunlabel hhere
        }
    , there = MaybeTable
        { tag = unHIdentity $ hunlabel hthereTag
        , just = fromColumns $ hunlabel hthere
        }
    }

  toResult tables = HTheseTable
    { hhereTag = hrelabel hhereTag
    , hhere = hrelabel hhere
    , hthereTag = hrelabel hthereTag
    , hthere = hrelabel hthere
    }
    where
      HMaybeTable
        { htag = hhereTag
        , hjust = hhere
        } = toResult @_ @(MaybeTable context a) (justHere tables)
      HMaybeTable
        { htag = hthereTag
        , hjust = hthere
        } = toResult @_ @(MaybeTable context b) (justThere tables)

  fromResult HTheseTable {hhereTag, hhere, hthereTag, hthere} =
    case (here, there) of
      (Just a, Nothing) -> This a
      (Nothing, Just b) -> That b
      (Just a, Just b) -> These a b
      _ -> error "These.fromColumns: mismatch between tags and data"
    where
      here = fromResult @_ @(MaybeTable context a) mhere
      there = fromResult @_ @(MaybeTable context b) mthere
      mhere = HMaybeTable
        { htag = hrelabel hhereTag
        , hjust = hrelabel hhere
        }
      mthere = HMaybeTable
        { htag = hrelabel hthereTag
        , hjust = hrelabel hthere
        }


instance (EqTable a, EqTable b, context ~ Expr) =>
  EqTable (TheseTable context a b)
 where
  eqTable = HTheseTable
    { hhereTag = hlabel (HIdentity Dict)
    , hhere = hlabel (eqTable @(Nullify context a))
    , hthereTag = hlabel (HIdentity Dict)
    , hthere = hlabel (eqTable @(Nullify context b))
    }


instance (OrdTable a, OrdTable b, context ~ Expr) =>
  OrdTable (TheseTable context a b)
 where
  ordTable = HTheseTable
    { hhereTag = hlabel (HIdentity Dict)
    , hhere = hlabel (ordTable @(Nullify context a))
    , hthereTag = hlabel (HIdentity Dict)
    , hthere = hlabel (ordTable @(Nullify context b))
    }


instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable Expr exprs1 exprs2) =>
  ToExprs x (These a b)


-- | Test if a 'TheseTable' was constructed with 'thisTable'.
--
-- Corresponds to 'Data.These.Combinators.isThis'.
isThisTable :: TheseTable Expr a b -> Expr Bool
isThisTable a = hasHereTable a &&. not_ (hasThereTable a)


-- | Test if a 'TheseTable' was constructed with 'thatTable'.
--
-- Corresponds to 'Data.These.Combinators.isThat'.
isThatTable :: TheseTable Expr a b -> Expr Bool
isThatTable a = not_ (hasHereTable a) &&. hasThereTable a


-- | Test if a 'TheseTable' was constructed with 'thoseTable'.
--
-- Corresponds to 'Data.These.Combinators.isThese'.
isThoseTable :: TheseTable Expr a b -> Expr Bool
isThoseTable a = hasHereTable a &&. hasThereTable a


-- | Test if the @a@ side of @TheseTable a b@ is present.
--
-- Corresponds to 'Data.These.Combinators.hasHere'.
hasHereTable :: TheseTable Expr a b -> Expr Bool
hasHereTable TheseTable {here} = isJustTable here


-- | Test if the @b@ table of @TheseTable a b@ is present.
--
-- Corresponds to 'Data.These.Combinators.hasThere'.
hasThereTable :: TheseTable Expr a b -> Expr Bool
hasThereTable TheseTable {there} = isJustTable there


-- | Attempt to project out the @a@ table of a @TheseTable a b@.
--
-- Corresponds to 'Data.These.Combinators.justHere'.
justHereTable :: TheseTable context a b -> MaybeTable context a
justHereTable = here


-- | Attempt to project out the @b@ table of a @TheseTable a b@.
--
-- Corresponds to 'Data.These.Combinators.justThere'.
justThereTable :: TheseTable context a b -> MaybeTable context b
justThereTable = there


-- | Construct a @TheseTable@ from two 'MaybeTable's.
alignMaybeTable :: ()
  => MaybeTable Expr a
  -> MaybeTable Expr b
  -> MaybeTable Expr (TheseTable Expr a b)
alignMaybeTable a b = MaybeTable tag (pure (TheseTable a b))
  where
    tag = boolExpr null mempty (isJustTable a ||. isJustTable b)


-- | Construct a @TheseTable@. Corresponds to 'This'.
thisTable :: Table Expr b => a -> TheseTable Expr a b
thisTable a = TheseTable (justTable a) nothingTable


-- | Construct a @TheseTable@. Corresponds to 'That'.
thatTable :: Table Expr a => b -> TheseTable Expr a b
thatTable b = TheseTable nothingTable (justTable b)


-- | Construct a @TheseTable@. Corresponds to 'These'.
thoseTable :: a -> b -> TheseTable Expr a b
thoseTable a b = TheseTable (justTable a) (justTable b)


-- | Pattern match on a 'TheseTable'. Corresponds to 'these'.
theseTable :: Table Expr c
  => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable Expr a b -> c
theseTable f g h TheseTable {here, there} =
  maybeTable
    (maybeTable undefined f here)
    (\b -> maybeTable (g b) (`h` b) here)
    there


-- | Lift an 'Aggregator' to operate on a 'TheseTable'. If the input query has
-- @'thisTable' a@s, they are folded into a single @c@ by the given aggregator
-- — in the case where the input query is all 'thatTable's or 'thoseTable's,
-- the 'Aggregator'\'s fallback @c@ is returned.
aggregateThisTable :: Table Expr c
  => Aggregator a c
  -> Aggregator' fold (TheseTable Expr a b) c
aggregateThisTable =
  filterWhere isThisTable . lmap (unsafeFromJustTable . here)


-- | Lift an 'Aggregator1' to operate on a 'TheseTable'. If the input query
-- has @'thisTable' a@s, they are folded into a single @'Rel8.justTable' c@
-- by the given aggregator — in the case where the input query is all
-- 'thatTable's or 'thoseTable's, a single 'nothingTable' row is returned.
aggregateThisTable1 :: Table Expr c
  => Aggregator' fold a c
  -> Aggregator' fold' (TheseTable Expr a b) (MaybeTable Expr c)
aggregateThisTable1 =
  filterWhereOptional isThisTable . lmap (unsafeFromJustTable . here)


-- | Lift an 'Aggregator' to operate on a 'TheseTable'. If the input query has
-- @'thatTable' b@s, they are folded into a single @c@ by the given aggregator
-- — in the case where the input query is all 'thisTable's or 'thoseTable's,
-- the 'Aggregator'\'s fallback @c@ is returned.
aggregateThatTable :: Table Expr c
  => Aggregator b c
  -> Aggregator' fold (TheseTable Expr a b) c
aggregateThatTable =
  filterWhere isThatTable . lmap (unsafeFromJustTable . there)


-- | Lift an 'Aggregator1' to operate on a 'TheseTable'. If the input query
-- has @'thatTable' b@s, they are folded into a single @'Rel8.justTable' c@
-- by the given aggregator — in the case where the input query is all
-- 'thisTable's or 'thoseTable's, a single 'nothingTable' row is returned.
aggregateThatTable1 :: Table Expr c
  => Aggregator' fold b c
  -> Aggregator' fold' (TheseTable Expr a b) (MaybeTable Expr c)
aggregateThatTable1 =
  filterWhereOptional isThatTable . lmap (unsafeFromJustTable . there)


-- | Lift an 'Aggregator' to operate on a 'ThoseTable'. If the input query has
-- @'thoseTable' a b@s, they are folded into a single @c@ by the given
-- aggregator — in the case where the input query is all 'thisTable's or
-- 'thatTable's, the 'Aggregator'\'s fallback @c@ is returned.
aggregateThoseTable :: Table Expr c
  => Aggregator (a, b) c
  -> Aggregator' fold (TheseTable Expr a b) c
aggregateThoseTable =
  filterWhere isThoseTable
    . lmap (unsafeFromJustTable . here &&& unsafeFromJustTable . there)


-- | Lift an 'Aggregator1' to operate on a 'TheseTable'. If the input query
-- has @'thoseTable' a b@s, they are folded into a single @'Rel8.justTable' c@
-- by the given aggregator — in the case where the input query is all
-- 'thisTable's or 'thatTable's, a single 'nothingTable' row is returned.
aggregateThoseTable1 :: Table Expr c
  => Aggregator' fold (a, b) c
  -> Aggregator' fold' (TheseTable Expr a b) (MaybeTable Expr c)
aggregateThoseTable1 =
  filterWhereOptional isThoseTable
    . lmap (unsafeFromJustTable . here &&& unsafeFromJustTable . there)


-- | Lift an 'Aggregator' to operate on a 'TheseTable'. If the input query has
-- @'thisTable' a@s or @'thoseTable' a _@s, the @a@s are folded into a single
-- @c@ by the given aggregator — in the case where the input query is all
-- 'thatTable's, the 'Aggregator'\'s fallback @c@ is returned.
aggregateHereTable :: Table Expr c
  => Aggregator a c
  -> Aggregator' fold (TheseTable Expr a b) c
aggregateHereTable = lmap here . aggregateJustTable


-- | Lift an 'Aggregator1' to operate on an 'TheseTable'. If the input query
-- has @'thisTable' a@s or @'thoseTable' a _@s, the @a@s are folded into a
-- single @'Rel8.justTable' c@ by the given aggregator — in the case where
-- the input query is all 'thatTable's, a single 'nothingTable' row is
-- returned.
aggregateHereTable1 :: Table Expr c
  => Aggregator' fold a c
  -> Aggregator' fold' (TheseTable Expr a b) (MaybeTable Expr c)
aggregateHereTable1 = lmap here . aggregateJustTable1


-- | Lift an 'Aggregator' to operate on a 'TheseTable'. If the input query has
-- @'thatTable' b@s or @'thoseTable' _ b@s, the @b@s are folded into a single
-- @c@ by the given aggregator — in the case where the input query is all
-- 'thisTable's, the 'Aggregator'\'s fallback @c@ is returned.
aggregateThereTable :: Table Expr c
  => Aggregator b c
  -> Aggregator' fold (TheseTable Expr a b) c
aggregateThereTable = lmap there . aggregateJustTable


-- | Lift an 'Aggregator1' to operate on an 'TheseTable'. If the input query
-- has @'thatTable' b@s or @'thoseTable' _ b@s, the @b@s are folded into a
-- single @'Rel8.justTable' c@ by the given aggregator — in the case where
-- the input query is all 'thisTable's, a single 'nothingTable' row is
-- returned.
aggregateThereTable1 :: Table Expr c
  => Aggregator' fold b c
  -> Aggregator' fold' (TheseTable Expr a b) (MaybeTable Expr c)
aggregateThereTable1 = lmap there . aggregateJustTable1


-- | Lift a pair aggregators to operate on a 'TheseTable'. 'thisTable's,
-- 'thatTable's are 'thoseTable's are grouped separately.
aggregateTheseTable :: ()
  => Aggregator' fold i a
  -> Aggregator' fold' i' b
  -> Aggregator1 (TheseTable Expr i i') (TheseTable Expr a b)
aggregateTheseTable a b =
  TheseTable
    <$> lmap here (aggregateMaybeTable a)
    <*> lmap there (aggregateMaybeTable b)


-- | Construct a 'TheseTable' in the 'Name' context. This can be useful if you
-- have a 'TheseTable' that you are storing in a table and need to construct a
-- 'TableSchema'.
nameTheseTable :: ()
  => Name (Maybe MaybeTag)
     -- ^ The name of the column to track the presence of the @a@ table.
  -> Name (Maybe MaybeTag)
     -- ^ The name of the column to track the presence of the @b@ table.
  -> a
     -- ^ Names of the columns in the @a@ table.
  -> b
     -- ^ Names of the columns in the @b@ table.
  -> TheseTable Name a b
nameTheseTable here there a b =
  TheseTable
    { here = nameMaybeTable here a
    , there = nameMaybeTable there b
    }