git.iko.soy/rel8
on 7c5422f help sign in
rel8/src/Rel8/Table/Maybe.hs
244 lines 8.0 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.Kind ( Type )
27import Data.Maybe ( fromMaybe, isJust )
28import Prelude hiding ( null, undefined )
30-- comonad
31import Control.Comonad ( extract )
33-- rel8
34import Rel8.Aggregate ( Col( A ), Aggregate )
35import Rel8.Expr ( Col( E ), Expr )
36import Rel8.Expr.Aggregate ( groupByExpr )
37import Rel8.Expr.Bool ( boolExpr )
38import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )
39import Rel8.Kind.Context ( Reifiable )
40import Rel8.Schema.Dict ( Dict( Dict ) )
41import qualified Rel8.Schema.Kind as K
42import Rel8.Schema.HTable.Identity ( HIdentity(..) )
43import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
44import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
45import Rel8.Schema.Name ( Col( N ), Name )
46import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
47import qualified Rel8.Schema.Null as N
48import Rel8.Schema.Result ( Col( R ) )
49import Rel8.Schema.Spec ( Spec( Spec ) )
50import Rel8.Table
51 ( Table, Columns, Context, fromColumns, toColumns
52 , FromExprs, fromResult, toResult
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.Nullify ( Nullify, aggregateNullify, guard )
62import Rel8.Table.Recontextualize ( Recontextualize )
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 :: Col context ('Spec (Maybe MaybeTag))
84 , just :: Nullify context a
85 }
86 deriving stock Functor
89instance context ~ Expr => Apply (MaybeTable context) where
90 MaybeTable (E tag) f <.> MaybeTable (E tag') a =
91 MaybeTable (E (tag <> tag')) (f <.> a)
94-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:
95-- 'Rel8.traverseMaybeTable'.
96instance context ~ Expr => Applicative (MaybeTable context) where
97 (<*>) = (<.>)
98 pure = justTable
101instance context ~ Expr => Bind (MaybeTable context) where
102 MaybeTable (E tag) a >>- f = case f (extract a) of
103 MaybeTable (E tag') b -> MaybeTable (E (tag <> tag')) b
106-- | Has the same behavior as the @Monad@ instance for @Maybe@.
107instance context ~ Expr => Monad (MaybeTable context) where
108 (>>=) = (>>-)
111instance context ~ Expr => AltTable (MaybeTable context) where
112 ma <|>: mb = bool ma mb (isNothingTable ma)
115instance context ~ Expr => AlternativeTable (MaybeTable context) where
116 emptyTable = nothingTable
119instance (context ~ Expr, Table Expr a, Semigroup a) =>
120 Semigroup (MaybeTable context a)
121 where
122 ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma
125instance (context ~ Expr, Table Expr a, Semigroup a) =>
126 Monoid (MaybeTable context a)
127 where
128 mempty = nothingTable
131instance (Table context a, Reifiable context, context ~ context') =>
132 Table context' (MaybeTable context a)
133 where
134 type Columns (MaybeTable context a) = HMaybeTable (Columns a)
135 type Context (MaybeTable context a) = Context a
136 type FromExprs (MaybeTable context a) = Maybe (FromExprs a)
138 toColumns MaybeTable {tag, just} = HMaybeTable
139 { htag = hlabel $ HIdentity tag
140 , hjust = hlabel $ guard tag isJust isNonNull $ toColumns just
141 }
143 fromColumns HMaybeTable {htag, hjust} = MaybeTable
144 { tag = unHIdentity $ hunlabel htag
145 , just = fromColumns $ hunlabel hjust
146 }
148 toResult ma = HMaybeTable
149 { htag = hlabel (HIdentity (R (IsJust <$ ma)))
150 , hjust = hlabel (toResult @_ @(Nullify context a) ma)
151 }
153 fromResult HMaybeTable {htag, hjust} = case hunlabel htag of
154 HType (R tag) -> tag $>
155 fromMaybe err (fromResult @_ @(Nullify context a) (hunlabel hjust))
156 where
157 err = error "Maybe.fromColumns: mismatch between tag and data"
160instance
161 ( Recontextualize from to a b
162 , Reifiable from, from ~ from'
163 , Reifiable to, to ~ to'
164 )
165 => Recontextualize from to (MaybeTable from' a) (MaybeTable to' b)
168instance (EqTable a, context ~ Expr) => EqTable (MaybeTable context a) where
169 eqTable = HMaybeTable
170 { htag = hlabel (HType Dict)
171 , hjust = hlabel (eqTable @(Nullify context a))
172 }
175instance (OrdTable a, context ~ Expr) => OrdTable (MaybeTable context a) where
176 ordTable = HMaybeTable
177 { htag = hlabel (HType Dict)
178 , hjust = hlabel (ordTable @(Nullify context a))
179 }
182instance (ToExprs exprs a, context ~ Expr) =>
183 ToExprs (MaybeTable context exprs) (Maybe a)
186-- | Check if a @MaybeTable@ is absent of any row. Like 'Data.Maybe.isNothing'.
187isNothingTable :: MaybeTable Expr a -> Expr Bool
188isNothingTable (MaybeTable (E tag) _) = isNull tag
191-- | Check if a @MaybeTable@ contains a row. Like 'Data.Maybe.isJust'.
192isJustTable :: MaybeTable Expr a -> Expr Bool
193isJustTable (MaybeTable (E tag) _) = isNonNull tag
196-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.
197maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable Expr a -> b
198maybeTable b f ma@(MaybeTable _ a) = bool (f (extract a)) b (isNothingTable ma)
199{-# INLINABLE maybeTable #-}
202-- | The null table. Like 'Nothing'.
203nothingTable :: Table Expr a => MaybeTable Expr a
204nothingTable = MaybeTable (E null) (pure undefined)
207-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use
208-- 'pure'.
209justTable :: a -> MaybeTable Expr a
210justTable = MaybeTable (E mempty) . pure
213-- | Project a single expression out of a 'MaybeTable'. You can think of this
214-- operator like the '$' operator, but it also has the ability to return
215-- @null@.
216($?) :: forall a b. Sql DBType b
217 => (a -> Expr b) -> MaybeTable Expr a -> Expr (N.Nullify b)
218f $? ma@(MaybeTable _ a) = case nullable @b of
219 Null -> boolExpr (f (extract a)) null (isNothingTable ma)
220 NotNull -> boolExpr (nullify (f (extract a))) null (isNothingTable ma)
221infixl 4 $?
224-- | Lift an aggregating function to operate on a 'MaybeTable'.
225-- @nothingTable@s and @justTable@s are grouped separately.
226aggregateMaybeTable :: ()
227 => (exprs -> aggregates)
228 -> MaybeTable Expr exprs
229 -> MaybeTable Aggregate aggregates
230aggregateMaybeTable f (MaybeTable (E tag) a) =
231 MaybeTable (A (groupByExpr tag)) (aggregateNullify f a)
234-- | Construct a 'MaybeTable' in the 'Name' context. This can be useful if you
235-- have a 'MaybeTable' that you are storing in a table and need to construct a
236-- 'TableSchema'.
237nameMaybeTable
238 :: Name (Maybe MaybeTag)
239 -- ^ The name of the column to track whether a row is a 'justTable' or
240 -- 'nothingTable'.
241 -> a
242 -- ^ Names of the columns in @a@.
243 -> MaybeTable Name a
244nameMaybeTable tag = MaybeTable (N tag) . pure