git.iko.soy/rel8
on 5a47018 help sign in
rel8/src/Rel8/Table/Maybe.hs
247 lines 8.1 kB history raw
1{-# language DataKinds #-}
2{-# language DeriveFunctor #-}
3{-# language DerivingStrategies #-}
4{-# language FlexibleContexts #-}
5{-# language FlexibleInstances #-}
6{-# language MultiParamTypeClasses #-}
7{-# language NamedFieldPuns #-}
8{-# language ScopedTypeVariables #-}
9{-# language StandaloneKindSignatures #-}
10{-# language TypeApplications #-}
11{-# language TypeFamilies #-}
12{-# language UndecidableInstances #-}
14module Rel8.Table.Maybe
15 ( MaybeTable(..)
16 , maybeTable, nothingTable, justTable
17 , isNothingTable, isJustTable
18 , ($?)
19 , aggregateMaybeTable
20 , nameMaybeTable
21 )
22where
24-- base
25import Control.Category ( id )
26import Data.Kind ( Type )
27import Data.Maybe ( isJust )
28import Data.Type.Equality ( apply )
29import Prelude hiding ( id, null, undefined )
31-- comonad
32import Control.Comonad ( extract )
34-- rel8
35import Rel8.Aggregate ( Col( A ), Aggregate )
36import Rel8.Expr ( Col( E ), Expr )
37import Rel8.Expr.Aggregate ( groupByExpr )
38import Rel8.Expr.Bool ( boolExpr )
39import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )
40import Rel8.Kind.Context ( Reifiable )
41import Rel8.Schema.Context.Abstract ( Abstract )
42import Rel8.Schema.Dict ( Dict( Dict ) )
43import qualified Rel8.Schema.Kind as K
44import Rel8.Schema.HTable.Identity ( HIdentity(..) )
45import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
46import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
47import Rel8.Schema.Name ( Col( N ), Name )
48import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
49import qualified Rel8.Schema.Null as N
50import Rel8.Schema.Spec ( Spec( Spec ) )
51import Rel8.Table
52 ( Table, Columns, Context, fromColumns, toColumns
53 , coherence, congruence, reify, unreify
54 )
55import Rel8.Table.Alternative
56 ( AltTable, (<|>:)
57 , AlternativeTable, emptyTable
58 )
59import Rel8.Table.Bool ( bool )
60import Rel8.Table.Eq ( EqTable, eqTable )
61import Rel8.Table.Ord ( OrdTable, ordTable )
62import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )
63import Rel8.Table.Recontextualize ( Recontextualize )
64import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
65import Rel8.Table.Undefined ( undefined )
66import Rel8.Type ( DBType )
67import Rel8.Type.Tag ( MaybeTag )
69-- semigroupoids
70import Data.Functor.Apply ( Apply, (<.>) )
71import Data.Functor.Bind ( Bind, (>>-) )
74-- | @MaybeTable t@ is the table @t@, but as the result of an outer join. If
75-- the outer join fails to match any rows, this is essentialy @Nothing@, and if
76-- the outer join does match rows, this is like @Just@. Unfortunately, SQL
77-- makes it impossible to distinguish whether or not an outer join matched any
78-- rows based generally on the row contents - if you were to join a row
79-- entirely of nulls, you can't distinguish if you matched an all null row, or
80-- if the match failed. For this reason @MaybeTable@ contains an extra field -
81-- a "nullTag" - to track whether or not the outer join produced any rows.
82type MaybeTable :: K.Context -> Type -> Type
83data MaybeTable context a = MaybeTable
84 { tag :: Col context ('Spec (Maybe MaybeTag))
85 , just :: Nullify context a
86 }
87 deriving stock Functor
90instance context ~ Expr => Apply (MaybeTable context) where
91 MaybeTable (E tag) f <.> MaybeTable (E tag') a =
92 MaybeTable (E (tag <> tag')) (f <.> a)
95-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:
96-- 'Rel8.traverseMaybeTable'.
97instance context ~ Expr => Applicative (MaybeTable context) where
98 (<*>) = (<.>)
99 pure = justTable
102instance context ~ Expr => Bind (MaybeTable context) where
103 MaybeTable (E tag) a >>- f = case f (extract a) of
104 MaybeTable (E tag') b -> MaybeTable (E (tag <> tag')) b
107-- | Has the same behavior as the @Monad@ instance for @Maybe@.
108instance context ~ Expr => Monad (MaybeTable context) where
109 (>>=) = (>>-)
112instance context ~ Expr => AltTable (MaybeTable context) where
113 ma <|>: mb = bool ma mb (isNothingTable ma)
116instance context ~ Expr => AlternativeTable (MaybeTable context) where
117 emptyTable = nothingTable
120instance (context ~ Expr, Table Expr a, Semigroup a) =>
121 Semigroup (MaybeTable context a)
122 where
123 ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma
126instance (context ~ Expr, Table Expr a, Semigroup a) =>
127 Monoid (MaybeTable context a)
128 where
129 mempty = nothingTable
132instance
133 ( Table context a
134 , Reifiable context, Abstract context, context ~ context'
135 )
136 => Table context' (MaybeTable context a)
137 where
138 type Columns (MaybeTable context a) = HMaybeTable (Columns a)
139 type Context (MaybeTable context a) = Context a
141 toColumns MaybeTable {tag, just} = HMaybeTable
142 { htag = hlabel $ HIdentity tag
143 , hjust = hlabel $ guard tag isJust isNonNull $ toColumns just
144 }
146 fromColumns HMaybeTable {htag, hjust} = MaybeTable
147 { tag = unHIdentity $ hunlabel htag
148 , just = fromColumns $ hunlabel hjust
149 }
151 reify proof (MaybeTable tag a) = MaybeTable tag (reify proof a)
152 unreify proof (MaybeTable tag a) = MaybeTable tag (unreify proof a)
153 coherence = coherence @context @a
154 congruence proof abstract = id `apply` congruence @context @a proof abstract
157instance
158 ( Recontextualize from to a b
159 , Reifiable from, Abstract from, from ~ from'
160 , Reifiable to, Abstract to, to ~ to'
161 )
162 => Recontextualize from to (MaybeTable from' a) (MaybeTable to' b)
165instance (EqTable a, context ~ Expr) => EqTable (MaybeTable context a) where
166 eqTable = HMaybeTable
167 { htag = hlabel (HType Dict)
168 , hjust = hlabel (eqTable @(Nullify context a))
169 }
172instance (OrdTable a, context ~ Expr) => OrdTable (MaybeTable context a) where
173 ordTable = HMaybeTable
174 { htag = hlabel (HType Dict)
175 , hjust = hlabel (ordTable @(Nullify context a))
176 }
179type instance FromExprs (MaybeTable _context a) = Maybe (FromExprs a)
182instance (ToExprs exprs a, context ~ Expr) =>
183 ToExprs (MaybeTable context exprs) (Maybe a)
184 where
185 fromResult = fmap (fromResult @exprs) . fromColumns
186 toResult = toColumns . fmap (toResult @exprs)
189-- | Check if a @MaybeTable@ is absent of any row. Like 'Data.Maybe.isNothing'.
190isNothingTable :: MaybeTable Expr a -> Expr Bool
191isNothingTable (MaybeTable (E tag) _) = isNull tag
194-- | Check if a @MaybeTable@ contains a row. Like 'Data.Maybe.isJust'.
195isJustTable :: MaybeTable Expr a -> Expr Bool
196isJustTable (MaybeTable (E tag) _) = isNonNull tag
199-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.
200maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable Expr a -> b
201maybeTable b f ma@(MaybeTable _ a) = bool (f (extract a)) b (isNothingTable ma)
202{-# INLINABLE maybeTable #-}
205-- | The null table. Like 'Nothing'.
206nothingTable :: Table Expr a => MaybeTable Expr a
207nothingTable = MaybeTable (E null) (pure undefined)
210-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use
211-- 'pure'.
212justTable :: a -> MaybeTable Expr a
213justTable = MaybeTable (E mempty) . pure
216-- | Project a single expression out of a 'MaybeTable'. You can think of this
217-- operator like the '$' operator, but it also has the ability to return
218-- @null@.
219($?) :: forall a b. Sql DBType b
220 => (a -> Expr b) -> MaybeTable Expr a -> Expr (N.Nullify b)
221f $? ma@(MaybeTable _ a) = case nullable @b of
222 Null -> boolExpr (f (extract a)) null (isNothingTable ma)
223 NotNull -> boolExpr (nullify (f (extract a))) null (isNothingTable ma)
224infixl 4 $?
227-- | Lift an aggregating function to operate on a 'MaybeTable'.
228-- @nothingTable@s and @justTable@s are grouped separately.
229aggregateMaybeTable :: ()
230 => (exprs -> aggregates)
231 -> MaybeTable Expr exprs
232 -> MaybeTable Aggregate aggregates
233aggregateMaybeTable f (MaybeTable (E tag) a) =
234 MaybeTable (A (groupByExpr tag)) (aggregateNullify f a)
237-- | Construct a 'MaybeTable' in the 'Name' context. This can be useful if you
238-- have a 'MaybeTable' that you are storing in a table and need to construct a
239-- 'TableSchema'.
240nameMaybeTable
241 :: Name (Maybe MaybeTag)
242 -- ^ The name of the column to track whether a row is a 'justTable' or
243 -- 'nothingTable'.
244 -> a
245 -- ^ Names of the columns in @a@.
246 -> MaybeTable Name a
247nameMaybeTable tag = MaybeTable (N tag) . pure