git.iko.soy/rel8
on 707a36a help sign in
rel8/src/Rel8/Table/Maybe.hs
236 lines 7.7 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 Data.Functor.Identity ( runIdentity )
26import Data.Kind ( Type )
27import Prelude hiding ( null, undefined )
29-- rel8
30import Rel8.Aggregate ( Col( A ), Aggregate )
31import Rel8.Expr ( Col( E ), Expr )
32import Rel8.Expr.Aggregate ( groupByExpr )
33import Rel8.Expr.Bool ( boolExpr )
34import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )
35import Rel8.Schema.Context.Nullify ( Nullifiable, nullifier, unnullifier )
36import Rel8.Schema.Dict ( Dict( Dict ) )
37import qualified Rel8.Schema.Kind as K
38import Rel8.Schema.HTable.Identity ( HIdentity(..) )
39import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
40import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
41import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
42import Rel8.Schema.Name ( Col( N ), Name )
43import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql, nullable )
44import Rel8.Schema.Spec ( Spec( Spec ) )
45import Rel8.Table
46 ( Table, Columns, Context, fromColumns, toColumns
47 , reify, unreify
48 )
49import Rel8.Table.Alternative
50 ( AltTable, (<|>:)
51 , AlternativeTable, emptyTable
52 )
53import Rel8.Table.Bool ( bool )
54import Rel8.Table.Eq ( EqTable, eqTable )
55import Rel8.Table.Ord ( OrdTable, ordTable )
56import Rel8.Table.Recontextualize ( Recontextualize )
57import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
58import Rel8.Table.Undefined ( undefined )
59import Rel8.Type ( DBType )
60import Rel8.Type.Tag ( MaybeTag )
62-- semigroupoids
63import Data.Functor.Apply ( Apply, (<.>) )
64import Data.Functor.Bind ( Bind, (>>-) )
67-- | @MaybeTable t@ is the table @t@, but as the result of an outer join. If
68-- the outer join fails to match any rows, this is essentialy @Nothing@, and if
69-- the outer join does match rows, this is like @Just@. Unfortunately, SQL
70-- makes it impossible to distinguish whether or not an outer join matched any
71-- rows based generally on the row contents - if you were to join a row
72-- entirely of nulls, you can't distinguish if you matched an all null row, or
73-- if the match failed. For this reason @MaybeTable@ contains an extra field -
74-- a "nullTag" - to track whether or not the outer join produced any rows.
75type MaybeTable :: K.Context -> Type -> Type
76data MaybeTable context a = MaybeTable
77 { tag :: Col context ('Spec (Maybe MaybeTag))
78 , just :: a
79 }
80 deriving stock Functor
83instance context ~ Expr => Apply (MaybeTable context) where
84 MaybeTable (E tag) f <.> MaybeTable (E tag') a =
85 MaybeTable (E (tag <> tag')) (f a)
88-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:
89-- 'Rel8.traverseMaybeTable'.
90instance context ~ Expr => Applicative (MaybeTable context) where
91 (<*>) = (<.>)
92 pure = justTable
95instance context ~ Expr => Bind (MaybeTable context) where
96 MaybeTable (E tag) a >>- f = case f a of
97 MaybeTable (E tag') b -> MaybeTable (E (tag <> tag')) b
100-- | Has the same behavior as the @Monad@ instance for @Maybe@.
101instance context ~ Expr => Monad (MaybeTable context) where
102 (>>=) = (>>-)
105instance context ~ Expr => AltTable (MaybeTable context) where
106 ma <|>: mb = bool ma mb (isNothingTable ma)
109instance context ~ Expr => AlternativeTable (MaybeTable context) where
110 emptyTable = nothingTable
113instance (context ~ Expr, Table Expr a, Semigroup a) =>
114 Semigroup (MaybeTable context a)
115 where
116 ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma
119instance (context ~ Expr, Table Expr a, Semigroup a) =>
120 Monoid (MaybeTable context a)
121 where
122 mempty = nothingTable
125instance (Table context a, Nullifiable context, context ~ context') =>
126 Table context' (MaybeTable context a)
127 where
128 type Columns (MaybeTable context a) = HMaybeTable (Columns a)
129 type Context (MaybeTable context a) = Context a
131 toColumns MaybeTable {tag, just} = HMaybeTable
132 { htag = hlabel (HIdentity tag)
133 , hjust = hlabel $ hnullify (nullifier tag isNonNull) $ toColumns just
134 }
136 fromColumns HMaybeTable {htag, hjust} = MaybeTable
137 { tag = unHIdentity (hunlabel htag)
138 , just = fromColumns $ runIdentity $
139 hunnullify ((pure .) . unnullifier) (hunlabel hjust)
140 }
142 reify = fmap fmap reify
143 unreify = fmap fmap unreify
146instance
147 ( Nullifiable from, from ~ from'
148 , Nullifiable to, to ~ to'
149 , Recontextualize from to a b
150 )
151 => Recontextualize from to (MaybeTable from' a) (MaybeTable to' b)
154instance (EqTable a, context ~ Expr) => EqTable (MaybeTable context a) where
155 eqTable = HMaybeTable
156 { htag = hlabel (HType Dict)
157 , hjust = hlabel (hnullify (\_ Dict -> Dict) (eqTable @a))
158 }
161instance (OrdTable a, context ~ Expr) => OrdTable (MaybeTable context a) where
162 ordTable = HMaybeTable
163 { htag = hlabel (HType Dict)
164 , hjust = hlabel (hnullify (\_ Dict -> Dict) (ordTable @a))
165 }
168type instance FromExprs (MaybeTable _context a) = Maybe (FromExprs a)
171instance (ToExprs exprs a, context ~ Expr) =>
172 ToExprs (MaybeTable context exprs) (Maybe a)
173 where
174 fromResult = fmap (fromResult @exprs) . fromColumns
175 toResult = toColumns . fmap (toResult @exprs)
178-- | Check if a @MaybeTable@ is absent of any row. Like 'Data.Maybe.isNothing'.
179isNothingTable :: MaybeTable Expr a -> Expr Bool
180isNothingTable (MaybeTable (E tag) _) = isNull tag
183-- | Check if a @MaybeTable@ contains a row. Like 'Data.Maybe.isJust'.
184isJustTable :: MaybeTable Expr a -> Expr Bool
185isJustTable (MaybeTable (E tag) _) = isNonNull tag
188-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.
189maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable Expr a -> b
190maybeTable b f ma@(MaybeTable _ a) = bool (f a) b (isNothingTable ma)
191{-# INLINABLE maybeTable #-}
194-- | The null table. Like 'Nothing'.
195nothingTable :: Table Expr a => MaybeTable Expr a
196nothingTable = MaybeTable (E null) undefined
199-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use
200-- 'pure'.
201justTable :: a -> MaybeTable Expr a
202justTable = MaybeTable (E mempty)
205-- | Project a single expression out of a 'MaybeTable'. You can think of this
206-- operator like the '$' operator, but it also has the ability to return
207-- @null@.
208($?) :: forall a b. Sql DBType b
209 => (a -> Expr b) -> MaybeTable Expr a -> Expr (Nullify b)
210f $? ma@(MaybeTable _ a) = case nullable @b of
211 Null -> boolExpr (f a) null (isNothingTable ma)
212 NotNull -> boolExpr (nullify (f a)) null (isNothingTable ma)
213infixl 4 $?
216-- | Lift an aggregating function to operate on a 'MaybeTable'.
217-- @nothingTable@s and @justTable@s are grouped separately.
218aggregateMaybeTable :: ()
219 => (exprs -> aggregates)
220 -> MaybeTable Expr exprs
221 -> MaybeTable Aggregate aggregates
222aggregateMaybeTable f (MaybeTable (E tag) a) =
223 MaybeTable (A (groupByExpr tag)) (f a)
226-- | Construct a 'MaybeTable' in the 'Name' context. This can be useful if you
227-- have a 'MaybeTable' that you are storing in a table and need to construct a
228-- 'TableSchema'.
229nameMaybeTable
230 :: Name (Maybe MaybeTag)
231 -- ^ The name of the column to track whether a row is a 'justTable' or
232 -- 'nothingTable'.
233 -> a
234 -- ^ Names of the columns in @a@.
235 -> MaybeTable Name a
236nameMaybeTable = MaybeTable . N