git.iko.soy/rel8
on master help sign in
Tweak Rel8.Tabulate so that optionalTabulation works with runTabulation
2a63c78Shane O'Brien
src/Rel8/Tabulate.hs+40−12
compare with master
unifiedsplit
@@ -1,7 +1,9 @@
1{-# language DeriveFunctor #-}
1{-# language DeriveFunctor #-}
2{-# language DerivingStrategies #-}
2{-# language DerivingStrategies #-}
3{-# language FlexibleContexts #-}
3{-# language FlexibleContexts #-}
4+{-# language LambdaCase #-}
4{-# language TupleSections #-}
5{-# language TupleSections #-}
6+{-# language UndecidableInstances #-}
5
7
6module Rel8.Tabulate
8module Rel8.Tabulate
7 ( Tabulation
9 ( Tabulation
@@ -54,6 +56,10 @@ import Rel8.Query.Order ( orderBy )
54import Rel8.Query.These ( alignBy )
56import Rel8.Query.These ( alignBy )
55import Rel8.Table ( Table )
57import Rel8.Table ( Table )
56import Rel8.Table.Aggregate ( groupBy, listAgg, nonEmptyAgg )
58import Rel8.Table.Aggregate ( groupBy, listAgg, nonEmptyAgg )
59+import Rel8.Table.Alternative
60+ ( AltTable, (<|>:)
61+ , AlternativeTable, emptyTable
62+ )
57import Rel8.Table.Eq ( EqTable, (==:) )
63import Rel8.Table.Eq ( EqTable, (==:) )
58import Rel8.Table.List ( ListTable )
64import Rel8.Table.List ( ListTable )
59import Rel8.Table.Maybe ( MaybeTable, maybeTable )
65import Rel8.Table.Maybe ( MaybeTable, maybeTable )
@@ -75,7 +81,7 @@ import Data.Semigroup.Traversable.Class ( bitraverse1 )
75-- \"Identity\" 'Tabulation's are created using 'tabulate'. 'Tabulation's can
81-- \"Identity\" 'Tabulation's are created using 'tabulate'. 'Tabulation's can
76-- be composed with 'Query's with 'prebind' or 'postbind' to form new
82-- be composed with 'Query's with 'prebind' or 'postbind' to form new
77-- 'Tabulation's.
83-- 'Tabulation's.
78−newtype Tabulation k a = Tabulation (k -> Query (Maybe k, a))
84+newtype Tabulation k a = Tabulation (Either k k -> Query (Maybe k, a))
79 deriving stock Functor
85 deriving stock Functor
80
86
81
87
@@ -100,7 +106,7 @@ instance EqTable k => Monad (Tabulation k) where
100 Tabulation bs -> bs i
106 Tabulation bs -> bs i
101 Just k -> case f a of
107 Just k -> case f a of
102 Tabulation bs -> do
108 Tabulation bs -> do
103− (mk', b) <- bs k
109+ (mk', b) <- bs (Right k)
104 case mk' of
110 case mk' of
105 Nothing -> pure (mk, b)
111 Nothing -> pure (mk, b)
106 Just k' -> do
112 Just k' -> do
@@ -108,6 +114,27 @@ instance EqTable k => Monad (Tabulation k) where
108 pure (mk', b)
114 pure (mk', b)
109
115
110
116
117+instance EqTable k => AltTable (Tabulation k) where
118+ kas <|>: kbs = do
119+ as <- toQuery kas
120+ bs <- toQuery kbs
121+ fromQuery $ as <|>: bs
122+
123+
124+instance EqTable k => AlternativeTable (Tabulation k) where
125+ emptyTable = fromQuery emptyTable
126+
127+
128+instance (EqTable k, Table Expr a, Semigroup a) => Semigroup (Tabulation k a)
129+ where
130+ (<>) = alignWith (theseTable id id (<>))
131+
132+
133+instance (EqTable k, Table Expr a, Semigroup a) => Monoid (Tabulation k a)
134+ where
135+ mempty = emptyTable
136+
137+
111-- | This "undoes" 'fromQuery'.
138-- | This "undoes" 'fromQuery'.
112--
139--
113-- @
140-- @
@@ -120,16 +147,14 @@ instance EqTable k => Monad (Tabulation k) where
120-- will always produce zero rows.
147-- will always produce zero rows.
121runTabulation :: EqTable k => Tabulation k a -> Query (k, a)
148runTabulation :: EqTable k => Tabulation k a -> Query (k, a)
122runTabulation (Tabulation f) = do
149runTabulation (Tabulation f) = do
123− (mk, a) <- f i
150+ (mk, a) <- f (Left undefined)
124 case mk of
151 case mk of
125 Nothing -> do
152 Nothing -> do
126 -- Opaleye tries to be too clever optimising "WHERE FALSE" and generates
153 -- Opaleye tries to be too clever optimising "WHERE FALSE" and generates
127 -- invalid SQL, so we use "WHERE NOT TRUE" instead
154 -- invalid SQL, so we use "WHERE NOT TRUE" instead
128 where_ $ not_ true
155 where_ $ not_ true
129− pure (i, a)
156+ pure (undefined, a)
130 Just k -> pure (k, a)
157 Just k -> pure (k, a)
131− where
132− i = undefined
133
158
134
159
135liftQuery :: Query a -> Tabulation k a
160liftQuery :: Query a -> Tabulation k a
@@ -177,7 +202,7 @@ fromQuery = Tabulation . const . fmap (first Just)
177
202
178indexed :: Tabulation k a -> Tabulation k (k, a)
203indexed :: Tabulation k a -> Tabulation k (k, a)
179indexed (Tabulation query) = Tabulation $ \i ->
204indexed (Tabulation query) = Tabulation $ \i ->
180− (\(mk, a) -> (mk, (fromMaybe i mk, a))) <$> query i
205+ (\(mk, a) -> (mk, (fromMaybe (either id id i) mk, a))) <$> query i
181
206
182
207
183ifilter :: (k -> a -> Expr Bool) -> Tabulation k a -> Tabulation k a
208ifilter :: (k -> a -> Expr Bool) -> Tabulation k a -> Tabulation k a
@@ -209,7 +234,7 @@ infixr 1 `postbind`
209-- 'lookup' can and often does contain multiple results.
234-- 'lookup' can and often does contain multiple results.
210lookup :: EqTable k => k -> Tabulation k a -> Query a
235lookup :: EqTable k => k -> Tabulation k a -> Query a
211lookup key (Tabulation query) = do
236lookup key (Tabulation query) = do
212− (mk, a) <- query key
237+ (mk, a) <- query (Right key)
213 traverse_ (where_ . (key ==:)) mk
238 traverse_ (where_ . (key ==:)) mk
214 pure a
239 pure a
215
240
@@ -345,9 +370,12 @@ orderTabulation ordering (Tabulation as) =
345
370
346optionalTabulation :: EqTable k
371optionalTabulation :: EqTable k
347 => Tabulation k a -> Tabulation k (MaybeTable a)
372 => Tabulation k a -> Tabulation k (MaybeTable a)
348−optionalTabulation as = Tabulation $ \k -> do
373+optionalTabulation as = Tabulation $ \case
374+ Left k -> case as of
375+ Tabulation f -> fmap pure <$> f (Left k)
376+ Right k -> do
349− ma <- optional $ lookup k as
377+ ma <- optional $ lookup k as
350− pure (Just k, ma)
378+ pure (Just k, ma)
351
379
352
380
353manyTabulation :: (EqTable k, Table Expr a)
381manyTabulation :: (EqTable k, Table Expr a)
@@ -366,4 +394,4 @@ someTabulation = aggregateTabulation . fmap nonEmptyAgg
366
394
367toQuery :: Tabulation k a -> Tabulation k (Query (k, a))
395toQuery :: Tabulation k a -> Tabulation k (Query (k, a))
368toQuery (Tabulation as) = Tabulation $ \k ->
396toQuery (Tabulation as) = Tabulation $ \k ->
369− pure (Nothing, first (fromMaybe k) <$> as k)
397+ pure (Nothing, first (fromMaybe (either id id k)) <$> as k)