git.iko.soy/rel8
on da76712 help sign in
rel8/src/Rel8/Table/Maybe.hs
246 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 , fromMaybeTable
19 , ($?)
20 , aggregateMaybeTable
21 , nameMaybeTable
22 )
23where
25-- base
26import Data.Functor ( ($>) )
27import Data.Functor.Identity ( Identity( Identity ) )
28import Data.Kind ( Type )
29import Data.Maybe ( fromMaybe, isJust )
30import Prelude hiding ( null, undefined )
32-- comonad
33import Control.Comonad ( extract )
35-- rel8
36import Rel8.Aggregate ( Aggregate )
37import Rel8.Expr ( Expr )
38import Rel8.Expr.Aggregate ( groupByExpr )
39import Rel8.Expr.Bool ( boolExpr )
40import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )
41import Rel8.Kind.Context ( Reifiable )
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 ( Name )
48import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
49import qualified Rel8.Schema.Null as N
50import Rel8.Table
51 ( Table, Columns, Context, fromColumns, toColumns
52 , FromExprs, fromResult, toResult
53 , Transpose
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.Projection ( Projectable, project )
63import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )
64import Rel8.Table.Serialize ( ToExprs )
65import Rel8.Table.Undefined ( undefined )
66import Rel8.Type ( DBType )
67import Rel8.Type.Tag ( MaybeTag( IsJust ) )
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 :: context (Maybe MaybeTag)
85 , just :: Nullify context a
86 }
87 deriving stock Functor
90instance Projectable (MaybeTable context) where
91 project f (MaybeTable tag a) = MaybeTable tag (project f a)
94instance context ~ Expr => Apply (MaybeTable context) where
95 MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f <.> a)
98-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:
99-- 'Rel8.traverseMaybeTable'.
100instance context ~ Expr => Applicative (MaybeTable context) where
101 (<*>) = (<.>)
102 pure = justTable
105instance context ~ Expr => Bind (MaybeTable context) where
106 MaybeTable tag a >>- f = case f (extract a) of
107 MaybeTable tag' b -> MaybeTable (tag <> tag') b
110-- | Has the same behavior as the @Monad@ instance for @Maybe@.
111instance context ~ Expr => Monad (MaybeTable context) where
112 (>>=) = (>>-)
115instance context ~ Expr => AltTable (MaybeTable context) where
116 ma <|>: mb = bool ma mb (isNothingTable ma)
119instance context ~ Expr => AlternativeTable (MaybeTable context) where
120 emptyTable = nothingTable
123instance (context ~ Expr, Table Expr a, Semigroup a) =>
124 Semigroup (MaybeTable context a)
125 where
126 ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma
129instance (context ~ Expr, Table Expr a, Semigroup a) =>
130 Monoid (MaybeTable context a)
131 where
132 mempty = nothingTable
135instance (Table context a, Reifiable context, context ~ context') =>
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
140 type FromExprs (MaybeTable context a) = Maybe (FromExprs a)
141 type Transpose to (MaybeTable context a) = MaybeTable to (Transpose to a)
143 toColumns MaybeTable {tag, just} = HMaybeTable
144 { htag = hlabel $ HIdentity tag
145 , hjust = hlabel $ toColumns just
146 }
148 fromColumns HMaybeTable {htag, hjust} = MaybeTable
149 { tag = unHIdentity $ hunlabel htag
150 , just = fromColumns $ hunlabel hjust
151 }
153 toResult ma = HMaybeTable
154 { htag = hlabel (HIdentity (Identity (IsJust <$ ma)))
155 , hjust = hlabel (toResult @_ @(Nullify context a) ma)
156 }
158 fromResult HMaybeTable {htag, hjust} = case hunlabel htag of
159 HIdentity (Identity tag) -> tag $>
160 fromMaybe err (fromResult @_ @(Nullify context a) (hunlabel hjust))
161 where
162 err = error "Maybe.fromColumns: mismatch between tag and data"
165instance (EqTable a, context ~ Expr) => EqTable (MaybeTable context a) where
166 eqTable = HMaybeTable
167 { htag = hlabel (HIdentity 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 (HIdentity Dict)
175 , hjust = hlabel (ordTable @(Nullify context a))
176 }
179instance (ToExprs exprs a, context ~ Expr) =>
180 ToExprs (MaybeTable context exprs) (Maybe a)
183-- | Check if a @MaybeTable@ is absent of any row. Like 'Data.Maybe.isNothing'.
184isNothingTable :: MaybeTable Expr a -> Expr Bool
185isNothingTable (MaybeTable tag _) = isNull tag
188-- | Check if a @MaybeTable@ contains a row. Like 'Data.Maybe.isJust'.
189isJustTable :: MaybeTable Expr a -> Expr Bool
190isJustTable (MaybeTable tag _) = isNonNull tag
193-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.
194maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable Expr a -> b
195maybeTable b f ma@(MaybeTable _ a) = bool (f (extract a)) b (isNothingTable ma)
196{-# INLINABLE maybeTable #-}
199-- | The null table. Like 'Nothing'.
200nothingTable :: Table Expr a => MaybeTable Expr a
201nothingTable = MaybeTable null (pure undefined)
204-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use
205-- 'pure'.
206justTable :: a -> MaybeTable Expr a
207justTable = MaybeTable mempty . pure
210-- | 'Data.Maybe.fromMaybe' for 'MaybeTable's.
211fromMaybeTable :: Table Expr a => a -> MaybeTable Expr a -> a
212fromMaybeTable fallback = maybeTable fallback id
215-- | Project a single expression out of a 'MaybeTable'. You can think of this
216-- operator like the '$' operator, but it also has the ability to return
217-- @null@.
218($?) :: forall a b. Sql DBType b
219 => (a -> Expr b) -> MaybeTable Expr a -> Expr (N.Nullify b)
220f $? ma@(MaybeTable _ a) = case nullable @b of
221 Null -> boolExpr (f (extract a)) null (isNothingTable ma)
222 NotNull -> boolExpr (nullify (f (extract a))) null (isNothingTable ma)
223infixl 4 $?
226-- | Lift an aggregating function to operate on a 'MaybeTable'.
227-- @nothingTable@s and @justTable@s are grouped separately.
228aggregateMaybeTable :: ()
229 => (exprs -> aggregates)
230 -> MaybeTable Expr exprs
231 -> MaybeTable Aggregate aggregates
232aggregateMaybeTable f (MaybeTable tag a) =
233 MaybeTable (groupByExpr tag) (aggregateNullify f a)
236-- | Construct a 'MaybeTable' in the 'Name' context. This can be useful if you
237-- have a 'MaybeTable' that you are storing in a table and need to construct a
238-- 'TableSchema'.
239nameMaybeTable
240 :: Name (Maybe MaybeTag)
241 -- ^ The name of the column to track whether a row is a 'justTable' or
242 -- 'nothingTable'.
243 -> a
244 -- ^ Names of the columns in @a@.
245 -> MaybeTable Name a
246nameMaybeTable tag = MaybeTable tag . pure