git.iko.soy/rel8
on fce7213 help sign in
rel8/src/Rel8/Tabulate.hs
232 lines 5.9 kB history raw
1{-# language DeriveFunctor #-}
2{-# language DerivingStrategies #-}
3{-# language FlexibleContexts #-}
4{-# language TupleSections #-}
6module Rel8.Tabulate
7 ( Tabulation
8 , runTabulation
9 , tabulate
10 , tabulateA
11 , fromQuery
12 , liftQuery
13 , prebind
14 , postbind
15 , indexed
16 , ifilter
17 , lookup
18 , align
19 , alignWith
20 , leftAlign
21 , leftAlignWith
22 , zip
23 , zipWith
24 , similarity
25 , difference
26 , aggregateTabulation
27 , optionalTabulation
28 )
29where
31-- base
32import Control.Applicative ( liftA2 )
33import Control.Monad ( join, liftM2 )
34import Data.Bifunctor ( bimap, first )
35import Data.Foldable ( traverse_ )
36import Data.Maybe ( fromMaybe )
37import Prelude hiding ( filter, lookup, undefined, zip, zipWith )
39-- rel8
40import Rel8.Aggregate ( Aggregate )
41import Rel8.Expr ( Expr )
42import Rel8.Expr.Bool ( not_, true )
43import Rel8.Query ( Query )
44import Rel8.Query.Aggregate ( aggregate )
45import Rel8.Query.Exists ( withBy, withoutBy )
46import Rel8.Query.Filter ( filter, where_ )
47import Rel8.Query.Maybe ( optional )
48import Rel8.Query.These ( alignBy )
49import Rel8.Schema.Context ( DB )
50import Rel8.Table ( Table )
51import Rel8.Table.Aggregate ( groupBy )
52import Rel8.Table.Eq ( EqTable, (==:) )
53import Rel8.Table.Maybe ( MaybeTable )
54import Rel8.Table.These ( TheseTable, theseTable )
55import Rel8.Table.Undefined ( undefined )
57-- semigroupoids
58import Data.Functor.Apply ( Apply, liftF2 )
59import Data.Functor.Bind ( Bind )
60import qualified Data.Functor.Bind
61import Data.Semigroup.Traversable.Class ( bitraverse1 )
64newtype Tabulation k a = Tabulation (k -> Query (Maybe k, a))
65 deriving stock Functor
68instance EqTable k => Apply (Tabulation k) where
69 liftF2 = liftA2
72instance EqTable k => Applicative (Tabulation k) where
73 pure = liftQuery . pure
74 liftA2 = liftM2
77instance EqTable k => Bind (Tabulation k) where
78 join = join
81instance EqTable k => Monad (Tabulation k) where
82 Tabulation as >>= f = Tabulation $ \i -> do
83 (mk, a) <- as i
84 case mk of
85 Nothing -> case f a of
86 Tabulation bs -> bs i
87 Just k -> case f a of
88 Tabulation bs -> do
89 (mk', b) <- bs k
90 case mk' of
91 Nothing -> pure (mk, b)
92 Just k' -> do
93 where_ $ k ==: k'
94 pure (mk', b)
97runTabulation :: EqTable k => Tabulation k a -> Query (k, a)
98runTabulation (Tabulation f) = do
99 (mk, a) <- f i
100 case mk of
101 Nothing -> do
102 -- Opaleye tries to be too clever optimising "WHERE FALSE" and generates
103 -- invalid SQL, so we use "WHERE NOT TRUE" instead
104 where_ $ not_ true
105 pure (i, a)
106 Just k -> pure (k, a)
107 where
108 i = undefined
111liftQuery :: Query a -> Tabulation k a
112liftQuery query = Tabulation $ const $ fmap (Nothing,) query
115tabulate :: (a -> k) -> a -> Tabulation k a
116tabulate key a = fromQuery $ pure (key a, a)
119tabulateA :: (a -> Query k) -> a -> Tabulation k a
120tabulateA key a = fromQuery $ (,a) <$> key a
123fromQuery :: Query (k, a) -> Tabulation k a
124fromQuery = Tabulation . const . fmap (first Just)
127indexed :: Tabulation k a -> Tabulation k (k, a)
128indexed (Tabulation query) = Tabulation $ \i ->
129 (\(mk, a) -> (mk, (fromMaybe i mk, a))) <$> query i
132ifilter :: (k -> a -> Expr Bool) -> Tabulation k a -> Tabulation k a
133ifilter f tabulation = snd <$> do
134 filter (uncurry f) `postbind` indexed tabulation
137prebind :: (a -> Tabulation k b) -> Query a -> Tabulation k b
138prebind f as = Tabulation $ \k -> do
139 a <- as
140 case f a of
141 Tabulation query -> query k
142infixr 1 `prebind`
145postbind :: (a -> Query b) -> Tabulation k a -> Tabulation k b
146postbind f (Tabulation as) = Tabulation $ \i -> do
147 (k, a) <- as i
148 case f a of
149 bs -> do
150 b <- bs
151 pure (k, b)
152infixr 1 `postbind`
155lookup :: EqTable k => k -> Tabulation k a -> Query a
156lookup key (Tabulation query) = do
157 (mk, a) <- query key
158 traverse_ (where_ . (key ==:)) mk
159 pure a
162align :: (EqTable k, Table DB a, Table DB b)
163 => Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable a b)
164align = alignWith id
167alignWith :: (EqTable k, Table DB a, Table DB b)
168 => (TheseTable a b -> c)
169 -> Tabulation k a -> Tabulation k b -> Tabulation k c
170alignWith f kas kbs = do
171 as <- toQuery kas
172 bs <- toQuery kbs
173 fromQuery $ do
174 tkab <- alignBy (\(l, _) (m, _) -> l ==: m) as bs
175 let
176 k' = theseTable fst fst (const fst) tkab
177 tab = bimap snd snd tkab
178 pure (k', f tab)
181leftAlign :: EqTable k
182 => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable b)
183leftAlign = leftAlignWith (,)
186leftAlignWith :: EqTable k
187 => (a -> MaybeTable b -> c)
188 -> Tabulation k a -> Tabulation k b -> Tabulation k c
189leftAlignWith f left right = liftA2 f left (optionalTabulation right)
192zip :: EqTable k
193 => Tabulation k a -> Tabulation k b -> Tabulation k (a, b)
194zip = zipWith (,)
197zipWith :: EqTable k
198 => (a -> b -> c) -> Tabulation k a -> Tabulation k b -> Tabulation k c
199zipWith = liftA2
202similarity :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
203similarity kas kbs = do
204 as <- toQuery kas
205 bs <- toQuery kbs
206 fromQuery $ as >>= withBy (\(k, _) (l, _) -> k ==: l) bs
209difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
210difference kas kbs = do
211 as <- toQuery kas
212 bs <- toQuery kbs
213 fromQuery $ as >>= withoutBy (\(k, _) (l, _) -> k ==: l) bs
216aggregateTabulation :: EqTable k
217 => Tabulation k (Aggregate a) -> Tabulation k a
218aggregateTabulation kas = do
219 as <- toQuery kas
220 fromQuery $ aggregate $ bitraverse1 groupBy id <$> as
223optionalTabulation :: EqTable k
224 => Tabulation k a -> Tabulation k (MaybeTable a)
225optionalTabulation as = Tabulation $ \k -> do
226 ma <- optional $ lookup k as
227 pure (Just k, ma)
230toQuery :: Tabulation k a -> Tabulation k (Query (k, a))
231toQuery (Tabulation as) = Tabulation $ \k ->
232 pure (Nothing, first (fromMaybe k) <$> as k)