wip

rel8.cabal

@@ -21,12 +21,14 @@ library
   build-depends:
       aeson
     , base ^>= 4.14 || ^>=4.15
+    , bifunctors
     , bytestring
     , case-insensitive
     , contravariant
     , hasql ^>= 1.4.5.1
     , opaleye ^>= 0.7.2.0
     , profunctors
+    , product-profunctors
     , scientific
     , semialign
     , semigroupoids
@@ -49,6 +51,7 @@ library
     Rel8.Expr.Num
     Rel8.Expr.Text
     Rel8.Expr.Time
+    Rel8.Tabulate
 
   other-modules:
     Rel8.Aggregate

src/Rel8/Tabulate.hs

@@ -0,0 +1,401 @@
+{-# language FlexibleContexts #-}
+{-# language MonoLocalBinds #-}
+{-# language ScopedTypeVariables #-}
+{-# language StandaloneKindSignatures #-}
+{-# language TypeApplications #-}
+{-# language TupleSections #-}
+{-# language UndecidableInstances #-}
+
+module Rel8.Tabulate
+  ( Tabulation
+
+  , fromQuery
+  , toQuery
+  , liftQuery
+  , prebind
+  , postbind
+  , lookup
+
+  , aggregateTabulation
+  , distinctTabulation
+  , orderTabulation
+  , countTabulation
+
+  , optionalTabulation
+  , manyTabulation
+  , someTabulation
+
+  , existsTabulation
+  , presentTabulation
+  , absentTabulation
+
+  , align
+  , alignWith
+  , leftAlign
+  , leftAlignWith
+  , rightAlign
+  , rightAlignWith
+  , zip
+  , zipWith
+
+  , similarity
+  , difference
+  )
+where
+
+-- base
+import Control.Applicative ( (<|>), empty, liftA2 )
+import Control.Monad ( liftM2 )
+import Data.Bifunctor ( Bifunctor, bimap, first, second )
+import Data.Foldable ( traverse_ )
+import Data.Function ( on )
+import Data.Functor.Contravariant ( Contravariant, (>$<), contramap )
+import Data.Int ( Int64 )
+import Data.Kind ( Type )
+import Data.Maybe ( fromMaybe )
+import Prelude hiding ( lookup, zip, zipWith )
+
+-- bifunctors
+import Data.Bifunctor.Clown ( Clown( Clown ), runClown )
+
+-- opaleye
+import qualified Opaleye.Aggregate as Opaleye
+import qualified Opaleye.Internal.Order as Opaleye
+import qualified Opaleye.Internal.QueryArr as Opaleye
+import qualified Opaleye.Order as Opaleye ( orderBy )
+
+-- profunctors
+import Data.Profunctor ( dimap, lmap )
+
+-- product-profunctors
+import Data.Profunctor.Product
+  ( ProductProfunctor, (***!)
+  , SumProfunctor, (+++!)
+  )
+import qualified Data.Profunctor.Product as PP
+
+-- rel8
+import Rel8.Aggregate ( Aggregates )
+import Rel8.Expr ( Expr )
+import Rel8.Expr.Aggregate ( countStar )
+import Rel8.Expr.Bool ( true )
+import Rel8.Order ( Order( Order ) )
+import Rel8.Query ( Query )
+import Rel8.Query.Exists ( exists, present, absent )
+import Rel8.Query.Filter ( where_ )
+import Rel8.Query.List ( catNonEmptyTable )
+import Rel8.Query.Maybe ( optional )
+import Rel8.Query.Opaleye ( mapOpaleye )
+import Rel8.Query.These ( alignBy )
+import Rel8.Table ( Table, fromColumns, toColumns )
+import Rel8.Table.Aggregate ( hgroupBy, listAgg, nonEmptyAgg )
+import Rel8.Table.Alternative
+  ( AltTable, (<|>:)
+  , AlternativeTable, emptyTable
+  )
+import Rel8.Table.Eq ( EqTable, (==:), eqTable )
+import Rel8.Table.List ( ListTable( ListTable ) )
+import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), maybeTable )
+import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )
+import Rel8.Table.Opaleye ( aggregator, unpackspec )
+import Rel8.Table.Ord ( OrdTable )
+import Rel8.Table.Order ( ascTable )
+import Rel8.Table.These ( TheseTable( TheseTable ), theseTable )
+
+-- semigroupoids
+import Data.Functor.Apply ( Apply, liftF2 )
+import Data.Functor.Bind ( Bind, (>>-) )
+
+
+type Key :: Type -> Type
+type Key = Maybe
+
+
+cat :: Table Expr k => Key k -> Query k
+cat = maybe emptyTable pure
+
+
+key :: (ProductProfunctor p, SumProfunctor p)
+  => p a b -> p (Key a) (Key b)
+key a = dimap from to (PP.empty +++! a)
+  where
+    from = maybe (Left ()) Right
+    to = either (const Nothing) Just
+
+
+keyed :: (ProductProfunctor p, SumProfunctor p)
+  => p k l -> p a b -> p (Key k, a) (Key l, b)
+keyed k a = key k ***! a
+
+
+type Predicate :: Type -> Type
+newtype Predicate a = Predicate (Maybe (a -> Expr Bool))
+
+
+instance Contravariant Predicate where
+  contramap f (Predicate a) = Predicate (lmap f <$> a)
+
+
+instance Semigroup (Predicate k) where
+  Predicate ma <> Predicate mb = Predicate $ ma <|> mb
+
+
+instance Monoid (Predicate k) where
+  mempty = Predicate Nothing
+
+
+match :: EqTable k => Key k -> Predicate k
+match = Predicate . fmap (==:)
+
+
+ensure :: Predicate k -> Key k -> Query ()
+ensure (Predicate mp) = traverse_ (\k -> traverse_ (\p -> where_ (p k)) mp)
+
+
+type Tabulation :: Type -> Type -> Type
+newtype Tabulation k a = Tabulation (Predicate k -> Query (Key k, a))
+
+
+instance Bifunctor Tabulation where
+  bimap f g (Tabulation a) = Tabulation $ \p ->
+    bimap (fmap f) g <$> a (f >$< p)
+
+
+instance Functor (Tabulation k) where
+  fmap = second
+
+
+instance EqTable k => Apply (Tabulation k) where
+  liftF2 = liftA2
+
+
+instance EqTable k => Applicative (Tabulation k) where
+  pure = liftQuery . pure
+  liftA2 = liftM2
+
+
+instance EqTable k => Bind (Tabulation k) where
+  Tabulation as >>- f = Tabulation $ \p -> do
+    (k, a) <- as p
+    case f a of
+      Tabulation bs -> do
+        let p' = match k
+        (k', b) <- bs (p' <> p)
+        ensure p' k'
+        pure (k' <|> k, b)
+
+
+instance EqTable k => Monad (Tabulation k) where
+  (>>=) = (>>-)
+
+
+instance EqTable k => AltTable (Tabulation k) where
+  as <|>: bs = catNonEmptyTable `postbind` ((<>) `on` someTabulation) as bs
+
+
+instance EqTable k => AlternativeTable (Tabulation k) where
+  emptyTable = Tabulation $ const $ fmap (empty,) emptyTable
+
+
+instance (EqTable k, Table Expr a, Semigroup a) => Semigroup (Tabulation k a)
+ where
+  (<>) = alignWith (theseTable id id (<>))
+
+
+instance (EqTable k, Table Expr a, Semigroup a) => Monoid (Tabulation k a)
+ where
+  mempty = emptyTable
+
+
+fromQuery :: Query (k, a) -> Tabulation k a
+fromQuery = Tabulation . const . fmap (first pure)
+
+
+toQuery :: Table Expr k => Tabulation k a -> Query (k, a)
+toQuery (Tabulation f) = do
+  (mk, a) <- f mempty
+  k <- cat mk
+  pure (k, a)
+
+
+liftQuery :: Query a -> Tabulation k a
+liftQuery = Tabulation . const . fmap (empty,)
+
+
+prebind :: (a -> Tabulation k b) -> Query a -> Tabulation k b
+prebind f as = Tabulation $ \p -> do
+  a <- as
+  case f a of
+    Tabulation query -> query p
+infixr 1 `prebind`
+
+
+postbind :: (a -> Query b) -> Tabulation k a -> Tabulation k b
+postbind f (Tabulation as) = Tabulation $ \p -> do
+  (k, a) <- as p
+  b <- f a
+  pure (k, b)
+infixr 1 `postbind`
+
+
+lookup :: EqTable k => k -> Tabulation k a -> Query a
+lookup k (Tabulation f) = do
+  (k', a) <- f p
+  ensure p k'
+  pure a
+  where
+    p = match (pure k)
+
+
+aggregateTabulation :: forall k aggregates exprs.
+  ( EqTable k
+  , Aggregates aggregates exprs
+  )
+  => Tabulation k aggregates -> Tabulation k exprs
+aggregateTabulation (Tabulation f) = Tabulation $
+  fmap (first (fmap fromColumns)) .
+  mapOpaleye (Opaleye.aggregate (keyed aggregator aggregator)) .
+  fmap (first (fmap (hgroupBy (eqTable @k) . toColumns))) .
+  f
+
+
+distinctTabulation :: EqTable k => Tabulation k a -> Tabulation k a
+distinctTabulation (Tabulation f) = Tabulation $
+  mapOpaleye
+    (\q ->
+      Opaleye.productQueryArr
+        ( Opaleye.distinctOn (key unpackspec) fst
+        . Opaleye.runSimpleQueryArr q
+        )
+    ) .
+  f
+
+
+orderTabulation :: OrdTable k => Order a -> Tabulation k a -> Tabulation k a
+orderTabulation ordering (Tabulation f) =
+  Tabulation $ mapOpaleye (Opaleye.orderBy ordering') . f
+  where
+    Order ordering' = runClown (keyed (Clown ascTable) (Clown ordering))
+
+
+countTabulation :: EqTable k => Tabulation k a -> Tabulation k (Expr Int64)
+countTabulation =
+  fmap (maybeTable 0 id) .
+  optionalTabulation .
+  aggregateTabulation .
+  fmap (const countStar)
+
+
+optionalTabulation :: Tabulation k a -> Tabulation k (MaybeTable a)
+optionalTabulation (Tabulation f) = Tabulation $ \p -> case p of
+  Predicate Nothing -> fmap pure <$> f p
+  _ -> fmap (\m -> (empty, snd <$> m)) $ optional $ do
+    (k, a) <- f p
+    ensure p k
+    pure (k, a)
+
+
+manyTabulation :: (EqTable k, Table Expr a)
+  => Tabulation k a -> Tabulation k (ListTable a)
+manyTabulation =
+  fmap (maybeTable mempty (\(ListTable a) -> ListTable a)) .
+  optionalTabulation .
+  aggregateTabulation .
+  fmap (listAgg . toColumns)
+
+
+someTabulation :: (EqTable k, Table Expr a)
+  => Tabulation k a -> Tabulation k (NonEmptyTable a)
+someTabulation =
+  fmap (\(NonEmptyTable a) -> NonEmptyTable a) .
+  aggregateTabulation .
+  fmap (nonEmptyAgg . toColumns)
+
+
+existsTabulation :: Tabulation k a -> Tabulation k (Expr Bool)
+existsTabulation (Tabulation f) = Tabulation $ \p -> case p of
+  Predicate Nothing -> (true <$) <$> f p
+  _ -> fmap (empty,) $ exists $ do
+    (k, _) <- f p
+    ensure p k
+
+
+presentTabulation :: Tabulation k a -> Tabulation k ()
+presentTabulation (Tabulation f) = Tabulation $ \p -> do
+  present $ do
+    (k, _) <- f p
+    ensure p k
+  pure (empty, ())
+
+
+absentTabulation :: Tabulation k a -> Tabulation k ()
+absentTabulation (Tabulation f) = Tabulation $ \p -> do
+  absent $ do
+    (k, _) <- f p
+    ensure p k
+  pure (empty, ())
+
+
+align :: EqTable k
+  => Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable a b)
+align = alignWith id
+
+
+alignWith :: EqTable k
+  => (TheseTable a b -> c)
+  -> Tabulation k a -> Tabulation k b -> Tabulation k c
+alignWith f (Tabulation as) (Tabulation bs) = Tabulation $ \p -> do
+  tkab <- liftF2 (alignBy condition) as bs p
+  let
+    k = recover $ bimap fst fst tkab
+    tab = bimap snd snd tkab
+  pure (k, f tab)
+  where
+    condition (k, _) (k', _) = fromMaybe true (liftA2 (==:) k k')
+    recover (TheseTable mma@(MaybeTable _ ma) mmb@(MaybeTable _ mb)) =
+      case ma of
+        Nothing -> mb
+        Just a -> case mb of
+          Nothing -> ma
+          Just b -> case a <$ mma <|>: b <$ mmb of
+            MaybeTable _ c -> pure c
+
+
+leftAlign :: EqTable k
+  => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable b)
+leftAlign = leftAlignWith (,)
+
+
+leftAlignWith :: EqTable k
+  => (a -> MaybeTable b -> c)
+  -> Tabulation k a -> Tabulation k b -> Tabulation k c
+leftAlignWith f left right = liftA2 f left (optionalTabulation right)
+
+
+rightAlign :: EqTable k
+  => Tabulation k a -> Tabulation k b -> Tabulation k (MaybeTable a, b)
+rightAlign = rightAlignWith (,)
+
+
+rightAlignWith :: EqTable k
+  => (MaybeTable a -> b -> c)
+  -> Tabulation k a -> Tabulation k b -> Tabulation k c
+rightAlignWith f left right = liftA2 (flip f) right (optionalTabulation left)
+
+
+zip :: EqTable k
+  => Tabulation k a -> Tabulation k b -> Tabulation k (a, b)
+zip = zipWith (,)
+
+
+zipWith :: EqTable k
+  => (a -> b -> c) -> Tabulation k a -> Tabulation k b -> Tabulation k c
+zipWith = liftA2
+
+
+similarity :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
+similarity a b = a <* presentTabulation b
+
+
+difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
+difference a b = a <* absentTabulation b