git.iko.soy/rel8
on 28aaa76 help sign in
rel8/src/Rel8/Table/Maybe.hs
235 lines 7.4 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, repeat, undefined, zipWith )
29-- rel8
30import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )
31import Rel8.Expr ( Expr )
32import Rel8.Expr.Bool ( boolExpr )
33import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )
34import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
35import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler, hlabeler )
36import Rel8.Schema.Context.Nullify
37 ( Nullifiable, ConstrainTag
38 , hencodeTag, hdecodeTag
39 , hnullifier, hunnullifier
40 )
41import Rel8.Schema.HTable.Identity ( HIdentity(..) )
42import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
43import Rel8.Schema.HTable.Maybe ( HMaybeTable(..), HMaybeNullifiable )
44import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
45import Rel8.Schema.Name ( Name )
46import Rel8.Schema.Nullability
47 ( Nullify
48 , Nullability( Nullable, NonNullable )
49 , Sql, nullabilization
50 )
51import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
52import Rel8.Table.Alternative
53 ( AltTable, (<|>:)
54 , AlternativeTable, emptyTable
55 )
56import Rel8.Table.Bool ( bool )
57import Rel8.Table.Eq ( EqTable, eqTable )
58import Rel8.Table.Lifted
59 ( Table1, Columns1, ConstrainHContext1, fromColumns1, toColumns1
60 )
61import Rel8.Table.Ord ( OrdTable, ordTable )
62import Rel8.Table.Recontextualize ( Recontextualize )
63import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )
64import Rel8.Table.Undefined ( undefined )
65import Rel8.Type ( DBType )
66import Rel8.Type.Tag ( MaybeTag )
68-- semigroupoids
69import Data.Functor.Apply ( Apply, (<.>), liftF2 )
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 :: Type -> Type
82data MaybeTable a = MaybeTable
83 { tag :: Tag "isJust" (Maybe MaybeTag)
84 , just :: a
85 }
86 deriving stock Functor
89instance Apply MaybeTable where
90 MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f a)
93-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:
94-- 'traverseMaybeTable'.
95instance Applicative MaybeTable where
96 (<*>) = (<.>)
97 pure = justTable
100instance Bind MaybeTable where
101 MaybeTable tag a >>- f = case f a of
102 MaybeTable tag' b -> MaybeTable (tag <> tag') b
105-- | Has the same behavior as the @Monad@ instance for @Maybe@. See also:
106-- 'bindMaybeTable'.
107instance Monad MaybeTable where
108 (>>=) = (>>-)
111instance AltTable MaybeTable where
112 ma@(MaybeTable tag a) <|>: MaybeTable tag' b = MaybeTable
113 { tag = (tag <> tag')
114 { expr = boolExpr (expr tag) (expr tag') condition
115 }
116 , just = bool a b condition
117 }
118 where
119 condition = isNothingTable ma
122instance AlternativeTable MaybeTable where
123 emptyTable = nothingTable
126instance (Table Expr a, Semigroup a) => Semigroup (MaybeTable a) where
127 ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma
130instance (Table Expr a, Semigroup a) => Monoid (MaybeTable a) where
131 mempty = nothingTable
134instance Table1 MaybeTable where
135 type Columns1 MaybeTable = HMaybeTable
136 type ConstrainHContext1 MaybeTable = HMaybeNullifiable
138 toColumns1 f MaybeTable {tag, just} = HMaybeTable
139 { htag
140 , hjust = hnullify (hnullifier tag isNonNull) $ f just
141 }
142 where
143 htag = HIdentity (hencodeTag tag)
145 fromColumns1 f HMaybeTable {htag = HIdentity htag, hjust} = MaybeTable
146 { tag
147 , just = f $ runIdentity $
148 hunnullify (\a -> pure . hunnullifier a) hjust
149 }
150 where
151 tag = hdecodeTag htag
153 {-# INLINABLE fromColumns1 #-}
154 {-# INLINABLE toColumns1 #-}
157instance
158 ( Table context a
159 , Labelable context, Nullifiable context
160 , ConstrainTag context MaybeTag
161 ) => Table context (MaybeTable a)
162 where
163 type Columns (MaybeTable a) = HMaybeTable (HLabel "Just" (Columns a))
164 type Context (MaybeTable a) = Context a
166 toColumns = toColumns1 (hlabel labeler . toColumns)
167 fromColumns = fromColumns1 (fromColumns . hunlabel unlabeler)
170instance
171 ( Labelable from, Nullifiable from, ConstrainTag from MaybeTag
172 , Labelable to, Nullifiable to, ConstrainTag to MaybeTag
173 , Recontextualize from to a b
174 ) => Recontextualize from to (MaybeTable a) (MaybeTable b)
177instance EqTable a => EqTable (MaybeTable a) where
178 eqTable = toColumns1 (hlabel hlabeler) (justTable (eqTable @a))
181instance OrdTable a => OrdTable (MaybeTable a) where
182 ordTable = toColumns1 (hlabel hlabeler) (justTable (ordTable @a))
185-- | Check if a @MaybeTable@ is absent of any row.. Like 'isNothing'.
186isNothingTable :: MaybeTable a -> Expr Bool
187isNothingTable (MaybeTable tag _) = isNull (expr tag)
190-- | Check if a @MaybeTable@ contains a row. Like 'isJust'.
191isJustTable :: MaybeTable a -> Expr Bool
192isJustTable (MaybeTable tag _) = isNonNull (expr tag)
195-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.
196maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable a -> b
197maybeTable b f ma@(MaybeTable _ a) = bool (f a) b (isNothingTable ma)
198{-# INLINABLE maybeTable #-}
201-- | The null table. Like 'Nothing'.
202nothingTable :: Table Expr a => MaybeTable a
203nothingTable = MaybeTable (fromExpr null) undefined
206-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use
207-- 'pure'.
208justTable :: a -> MaybeTable a
209justTable = MaybeTable (fromExpr mempty)
212-- | Project a single expression out of a 'MaybeTable'. You can think of this
213-- operator like the '$' operator, but it also has the ability to return
214-- @null@.
215--
216-- >>> select c $ fmap (fst $?) (optional (values [lit (True, False)]))
217-- [Just True]
218($?) :: forall a b. Sql DBType b
219 => (a -> Expr b) -> MaybeTable a -> Expr (Nullify b)
220f $? ma@(MaybeTable _ a) = case nullabilization @b of
221 Nullable -> boolExpr (f a) null (isNothingTable ma)
222 NonNullable -> boolExpr (nullify (f a)) null (isNothingTable ma)
223infixl 4 $?
226aggregateMaybeTable :: ()
227 => (a -> Aggregate b) -> MaybeTable a -> Aggregate (MaybeTable b)
228aggregateMaybeTable f MaybeTable {tag = tag@Tag {aggregator, expr}, just} =
229 liftF2 MaybeTable (tag <$ aggregate) (f just)
230 where
231 aggregate = unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr
234nameMaybeTable :: Name (Maybe MaybeTag) -> a -> MaybeTable a
235nameMaybeTable = MaybeTable . fromName