mirror of
https://github.com/circuithub/rel8.git
synced 2024-09-11 16:05:41 +03:00
wip
This commit is contained in:
parent
504b7e5c2f
commit
7b993cf79b
@ -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
|
||||
|
401
src/Rel8/Tabulate.hs
Normal file
401
src/Rel8/Tabulate.hs
Normal file
@ -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
|
Loading…
Reference in New Issue
Block a user