@@ -1,13 +1,11 @@
1{-# language DeriveFunctor #-}
1{-# language DeriveFunctor #-}
2{-# language DerivingStrategies #-}
2{-# language DerivingStrategies #-}
3{-# language FlexibleContexts #-}
3{-# language FlexibleContexts #-}
4−{-# language LambdaCase #-}
5{-# language TupleSections #-}
4{-# language TupleSections #-}
6{-# language UndecidableInstances #-}
5{-# language UndecidableInstances #-}
8module Rel8.Tabulate
7module Rel8.Tabulate
9 ( Tabulation
8 ( Tabulation
11 , tabulate
9 , tabulate
12 , tabulateA
10 , tabulateA
13 , fromQuery
11 , fromQuery
@@ -41,12 +39,11 @@ import Data.Bifunctor ( bimap, first )
41import Data.Foldable ( traverse_ )
39import Data.Foldable ( traverse_ )
42import Data.Functor.Contravariant ( (>$<) )
40import Data.Functor.Contravariant ( (>$<) )
43import Data.Maybe ( fromMaybe )
41import Data.Maybe ( fromMaybe )
44−import Prelude hiding ( filter, lookup, undefined, zip, zipWith )
42+import Prelude hiding ( filter, lookup, zip, zipWith )
47import Rel8.Aggregate ( Aggregate )
45import Rel8.Aggregate ( Aggregate )
48import Rel8.Expr ( Expr )
46import Rel8.Expr ( Expr )
49−import Rel8.Expr.Bool ( not_, true )
50import Rel8.Order ( Order )
47import Rel8.Order ( Order )
51import Rel8.Query ( Query )
48import Rel8.Query ( Query )
52import Rel8.Query.Aggregate ( aggregate )
49import Rel8.Query.Aggregate ( aggregate )
@@ -66,7 +63,6 @@ import Rel8.Table.List ( ListTable )
66import Rel8.Table.Maybe ( MaybeTable, maybeTable )
63import Rel8.Table.Maybe ( MaybeTable, maybeTable )
67import Rel8.Table.NonEmpty ( NonEmptyTable )
64import Rel8.Table.NonEmpty ( NonEmptyTable )
68import Rel8.Table.These ( TheseTable, theseTable )
65import Rel8.Table.These ( TheseTable, theseTable )
69−import Rel8.Table.Undefined ( undefined )
71-- semigroupoids
67-- semigroupoids
72import Data.Functor.Apply ( Apply, liftF2 )
68import Data.Functor.Apply ( Apply, liftF2 )
@@ -82,7 +78,7 @@ import Data.Semigroup.Traversable.Class ( bitraverse1 )
82-- \"Identity\" 'Tabulation's are created using 'tabulate'. 'Tabulation's can
78-- \"Identity\" 'Tabulation's are created using 'tabulate'. 'Tabulation's can
83-- be composed with 'Query's with 'prebind' or 'postbind' to form new
79-- be composed with 'Query's with 'prebind' or 'postbind' to form new
84-- 'Tabulation's.
80-- 'Tabulation's.
85−newtype Tabulation k a = Tabulation (Either k k -> Query (Maybe k, a))
81+newtype Tabulation k a = Tabulation (k -> Query (Maybe k, a))
86 deriving stock Functor
82 deriving stock Functor
@@ -107,7 +103,7 @@ instance EqTable k => Monad (Tabulation k) where
107 Tabulation bs -> bs i
103 Tabulation bs -> bs i
108 Just k -> case f a of
104 Just k -> case f a of
109 Tabulation bs -> do
105 Tabulation bs -> do
110− (mk', b) <- bs (Right k)
106+ (mk', b) <- bs k
111 case mk' of
107 case mk' of
112 Nothing -> pure (mk, b)
108 Nothing -> pure (mk, b)
113 Just k' -> do
109 Just k' -> do
@@ -136,28 +132,6 @@ instance (EqTable k, Table Expr a, Semigroup a) => Monoid (Tabulation k a)
136 mempty = emptyTable
132 mempty = emptyTable
139−-- | This "undoes" 'fromQuery'.
142−-- 'runTabulation' . 'fromQuery' = id
143−-- 'fromQuery' . 'runTabulation' = id
146−-- Note however that it produces nonsense when passed a 'Tabulation' that was
147−-- made with from 'liftQuery' or 'pure'. In such cases the returned 'Query'
148−-- will always produce zero rows.
149−runTabulation :: EqTable k => Tabulation k a -> Query (k, a)
150−runTabulation (Tabulation f) = do
151− (mk, a) <- f (Left undefined)
154− -- Opaleye tries to be too clever optimising "WHERE FALSE" and generates
155− -- invalid SQL, so we use "WHERE NOT TRUE" instead
158− Just k -> pure (k, a)
161liftQuery :: Query a -> Tabulation k a
135liftQuery :: Query a -> Tabulation k a
162liftQuery query = Tabulation $ const $ fmap (Nothing,) query
136liftQuery query = Tabulation $ const $ fmap (Nothing,) query
@@ -203,7 +177,7 @@ fromQuery = Tabulation . const . fmap (first Just)
204indexed :: Tabulation k a -> Tabulation k (k, a)
178indexed :: Tabulation k a -> Tabulation k (k, a)
205indexed (Tabulation query) = Tabulation $ \i ->
179indexed (Tabulation query) = Tabulation $ \i ->
206− (\(mk, a) -> (mk, (fromMaybe (either id id i) mk, a))) <$> query i
180+ (\(mk, a) -> (mk, (fromMaybe i mk, a))) <$> query i
209ifilter :: (k -> a -> Expr Bool) -> Tabulation k a -> Tabulation k a
183ifilter :: (k -> a -> Expr Bool) -> Tabulation k a -> Tabulation k a
@@ -235,7 +209,7 @@ infixr 1 `postbind`
235-- 'lookup' can and often does contain multiple results.
209-- 'lookup' can and often does contain multiple results.
236lookup :: EqTable k => k -> Tabulation k a -> Query a
210lookup :: EqTable k => k -> Tabulation k a -> Query a
237lookup key (Tabulation query) = do
211lookup key (Tabulation query) = do
238− (mk, a) <- query (Right key)
212+ (mk, a) <- query key
239 traverse_ (where_ . (key ==:)) mk
213 traverse_ (where_ . (key ==:)) mk
@@ -379,12 +353,9 @@ singularize = aggregateTabulation . fmap headAgg
380optionalTabulation :: EqTable k
354optionalTabulation :: EqTable k
381 => Tabulation k a -> Tabulation k (MaybeTable a)
355 => Tabulation k a -> Tabulation k (MaybeTable a)
382−optionalTabulation as = Tabulation $ \case
356+optionalTabulation as = Tabulation $ \k -> do
383− Left k -> case as of
384− Tabulation f -> fmap pure <$> f (Left k)
386− ma <- optional $ lookup k as
357+ ma <- optional $ lookup k as
387− pure (Just k, ma)
358+ pure (Just k, ma)
390manyTabulation :: (EqTable k, Table Expr a)
361manyTabulation :: (EqTable k, Table Expr a)
@@ -403,4 +374,4 @@ someTabulation = aggregateTabulation . fmap nonEmptyAgg
404toQuery :: Tabulation k a -> Tabulation k (Query (k, a))
375toQuery :: Tabulation k a -> Tabulation k (Query (k, a))
405toQuery (Tabulation as) = Tabulation $ \k ->
376toQuery (Tabulation as) = Tabulation $ \k ->
406− pure (Nothing, first (fromMaybe (either id id k)) <$> as k)
377+ pure (Nothing, first (fromMaybe k) <$> as k)