git.iko.soy/rel8
on 29cdfdb help sign in
rel8/src/Rel8/Table/Maybe.hs
240 lines 7.9 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 ( ($>) )
26import Data.Functor.Identity ( Identity( Identity ) )
27import Data.Kind ( Type )
28import Data.Maybe ( fromMaybe, isJust )
29import Prelude hiding ( null, undefined )
31-- comonad
32import Control.Comonad ( extract )
34-- rel8
35import Rel8.Aggregate ( Aggregate )
36import Rel8.Expr ( 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.Dict ( Dict( Dict ) )
42import qualified Rel8.Schema.Kind as K
43import Rel8.Schema.HTable.Identity ( HIdentity(..) )
44import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
45import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
46import Rel8.Schema.Name ( Name )
47import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
48import qualified Rel8.Schema.Null as N
49import Rel8.Table
50 ( Table, Columns, Context, fromColumns, toColumns
51 , FromExprs, fromResult, toResult
52 , Transpose
53 )
54import Rel8.Table.Alternative
55 ( AltTable, (<|>:)
56 , AlternativeTable, emptyTable
57 )
58import Rel8.Table.Bool ( bool )
59import Rel8.Table.Eq ( EqTable, eqTable )
60import Rel8.Table.Ord ( OrdTable, ordTable )
61import Rel8.Table.Projection ( Projectable, project )
62import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )
63import Rel8.Table.Serialize ( ToExprs )
64import Rel8.Table.Undefined ( undefined )
65import Rel8.Type ( DBType )
66import Rel8.Type.Tag ( MaybeTag( IsJust ) )
68-- semigroupoids
69import Data.Functor.Apply ( Apply, (<.>) )
70import Data.Functor.Bind ( Bind, (>>-) )
73-- | @MaybeTable t@ is the table @t@, but as the result of an outer join. If
74-- the outer join fails to match any rows, this is essentialy @Nothing@, and if
75-- the outer join does match rows, this is like @Just@. Unfortunately, SQL
76-- makes it impossible to distinguish whether or not an outer join matched any
77-- rows based generally on the row contents - if you were to join a row
78-- entirely of nulls, you can't distinguish if you matched an all null row, or
79-- if the match failed. For this reason @MaybeTable@ contains an extra field -
80-- a "nullTag" - to track whether or not the outer join produced any rows.
81type MaybeTable :: K.Context -> Type -> Type
82data MaybeTable context a = MaybeTable
83 { tag :: context (Maybe MaybeTag)
84 , just :: Nullify context a
85 }
86 deriving stock Functor
89instance Projectable (MaybeTable context) where
90 project f (MaybeTable tag a) = MaybeTable tag (project f a)
93instance context ~ Expr => Apply (MaybeTable context) where
94 MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f <.> a)
97-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:
98-- 'Rel8.traverseMaybeTable'.
99instance context ~ Expr => Applicative (MaybeTable context) where
100 (<*>) = (<.>)
101 pure = justTable
104instance context ~ Expr => Bind (MaybeTable context) where
105 MaybeTable tag a >>- f = case f (extract a) of
106 MaybeTable tag' b -> MaybeTable (tag <> tag') b
109-- | Has the same behavior as the @Monad@ instance for @Maybe@.
110instance context ~ Expr => Monad (MaybeTable context) where
111 (>>=) = (>>-)
114instance context ~ Expr => AltTable (MaybeTable context) where
115 ma <|>: mb = bool ma mb (isNothingTable ma)
118instance context ~ Expr => AlternativeTable (MaybeTable context) where
119 emptyTable = nothingTable
122instance (context ~ Expr, Table Expr a, Semigroup a) =>
123 Semigroup (MaybeTable context a)
124 where
125 ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma
128instance (context ~ Expr, Table Expr a, Semigroup a) =>
129 Monoid (MaybeTable context a)
130 where
131 mempty = nothingTable
134instance (Table context a, Reifiable context, context ~ context') =>
135 Table context' (MaybeTable context a)
136 where
137 type Columns (MaybeTable context a) = HMaybeTable (Columns a)
138 type Context (MaybeTable context a) = Context a
139 type FromExprs (MaybeTable context a) = Maybe (FromExprs a)
140 type Transpose to (MaybeTable context a) = MaybeTable to (Transpose to a)
142 toColumns MaybeTable {tag, just} = HMaybeTable
143 { htag = hlabel $ HIdentity tag
144 , hjust = hlabel $ guard tag isJust isNonNull $ toColumns just
145 }
147 fromColumns HMaybeTable {htag, hjust} = MaybeTable
148 { tag = unHIdentity $ hunlabel htag
149 , just = fromColumns $ hunlabel hjust
150 }
152 toResult ma = HMaybeTable
153 { htag = hlabel (HIdentity (Identity (IsJust <$ ma)))
154 , hjust = hlabel (toResult @_ @(Nullify context a) ma)
155 }
157 fromResult HMaybeTable {htag, hjust} = case hunlabel htag of
158 HIdentity (Identity tag) -> tag $>
159 fromMaybe err (fromResult @_ @(Nullify context a) (hunlabel hjust))
160 where
161 err = error "Maybe.fromColumns: mismatch between tag and data"
164instance (EqTable a, context ~ Expr) => EqTable (MaybeTable context a) where
165 eqTable = HMaybeTable
166 { htag = hlabel (HIdentity Dict)
167 , hjust = hlabel (eqTable @(Nullify context a))
168 }
171instance (OrdTable a, context ~ Expr) => OrdTable (MaybeTable context a) where
172 ordTable = HMaybeTable
173 { htag = hlabel (HIdentity Dict)
174 , hjust = hlabel (ordTable @(Nullify context a))
175 }
178instance (ToExprs exprs a, context ~ Expr) =>
179 ToExprs (MaybeTable context exprs) (Maybe a)
182-- | Check if a @MaybeTable@ is absent of any row. Like 'Data.Maybe.isNothing'.
183isNothingTable :: MaybeTable Expr a -> Expr Bool
184isNothingTable (MaybeTable tag _) = isNull tag
187-- | Check if a @MaybeTable@ contains a row. Like 'Data.Maybe.isJust'.
188isJustTable :: MaybeTable Expr a -> Expr Bool
189isJustTable (MaybeTable tag _) = isNonNull tag
192-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.
193maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable Expr a -> b
194maybeTable b f ma@(MaybeTable _ a) = bool (f (extract a)) b (isNothingTable ma)
195{-# INLINABLE maybeTable #-}
198-- | The null table. Like 'Nothing'.
199nothingTable :: Table Expr a => MaybeTable Expr a
200nothingTable = MaybeTable null (pure undefined)
203-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use
204-- 'pure'.
205justTable :: a -> MaybeTable Expr a
206justTable = MaybeTable mempty . pure
209-- | Project a single expression out of a 'MaybeTable'. You can think of this
210-- operator like the '$' operator, but it also has the ability to return
211-- @null@.
212($?) :: forall a b. Sql DBType b
213 => (a -> Expr b) -> MaybeTable Expr a -> Expr (N.Nullify b)
214f $? ma@(MaybeTable _ a) = case nullable @b of
215 Null -> boolExpr (f (extract a)) null (isNothingTable ma)
216 NotNull -> boolExpr (nullify (f (extract a))) null (isNothingTable ma)
217infixl 4 $?
220-- | Lift an aggregating function to operate on a 'MaybeTable'.
221-- @nothingTable@s and @justTable@s are grouped separately.
222aggregateMaybeTable :: ()
223 => (exprs -> aggregates)
224 -> MaybeTable Expr exprs
225 -> MaybeTable Aggregate aggregates
226aggregateMaybeTable f (MaybeTable tag a) =
227 MaybeTable (groupByExpr tag) (aggregateNullify f a)
230-- | Construct a 'MaybeTable' in the 'Name' context. This can be useful if you
231-- have a 'MaybeTable' that you are storing in a table and need to construct a
232-- 'TableSchema'.
233nameMaybeTable
234 :: Name (Maybe MaybeTag)
235 -- ^ The name of the column to track whether a row is a 'justTable' or
236 -- 'nothingTable'.
237 -> a
238 -- ^ Names of the columns in @a@.
239 -> MaybeTable Name a
240nameMaybeTable tag = MaybeTable tag . pure