git.iko.soy/rel8
on c776efd help sign in
rel8/src/Rel8/Table/Maybe.hs
249 lines 7.4 kB history raw
1{-# language DataKinds #-}
2{-# language DeriveFunctor #-}
3{-# language DerivingStrategies #-}
4{-# language FlexibleContexts #-}
5{-# language FlexibleInstances #-}
6{-# language LambdaCase #-}
7{-# language MultiParamTypeClasses #-}
8{-# language NamedFieldPuns #-}
9{-# language ScopedTypeVariables #-}
10{-# language StandaloneKindSignatures #-}
11{-# language TypeApplications #-}
12{-# language TypeFamilies #-}
13{-# language UndecidableInstances #-}
15module Rel8.Table.Maybe
16 ( MaybeTable(..)
17 , maybeTable, nothingTable, justTable
18 , isNothingTable, isJustTable
19 , ($?)
20 , nameMaybeTable
21 )
22where
24-- base
25import Data.Functor.Identity ( runIdentity )
26import Data.Kind ( Type )
27import Prelude hiding ( null, undefined )
29-- rel8
30import Rel8.Expr ( Expr )
31import Rel8.Expr.Bool ( boolExpr )
32import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )
33import Rel8.Schema.Context.Nullify
34 ( Nullifiable, ConstrainTag
35 , HNullifiable, HConstrainTag
36 , hencodeTag, hdecodeTag
37 , hnullifier, hunnullifier
38 )
39import Rel8.Schema.HTable ( HTable )
40import Rel8.Schema.HTable.Identity ( HIdentity(..) )
41import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
42import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
43import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
44import Rel8.Schema.Name ( Name )
45import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql, nullable )
46import Rel8.Table
47 ( Table, Columns, Context, fromColumns, toColumns
48 , reify, unreify
49 )
50import Rel8.Table.Alternative
51 ( AltTable, (<|>:)
52 , AlternativeTable, emptyTable
53 )
54import Rel8.Table.Bool ( bool )
55import Rel8.Table.Eq ( EqTable, eqTable )
56import Rel8.Table.Ord ( OrdTable, ordTable )
57import Rel8.Table.Recontextualize ( Recontextualize )
58import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
59import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )
60import Rel8.Table.Undefined ( undefined )
61import Rel8.Type ( DBType )
62import Rel8.Type.Tag ( MaybeTag )
64-- semigroupoids
65import Data.Functor.Apply ( Apply, (<.>) )
66import Data.Functor.Bind ( Bind, (>>-) )
69-- | @MaybeTable t@ is the table @t@, but as the result of an outer join. If
70-- the outer join fails to match any rows, this is essentialy @Nothing@, and if
71-- the outer join does match rows, this is like @Just@. Unfortunately, SQL
72-- makes it impossible to distinguish whether or not an outer join matched any
73-- rows based generally on the row contents - if you were to join a row
74-- entirely of nulls, you can't distinguish if you matched an all null row, or
75-- if the match failed. For this reason @MaybeTable@ contains an extra field -
76-- a "nullTag" - to track whether or not the outer join produced any rows.
77type MaybeTable :: Type -> Type
78data MaybeTable a = MaybeTable
79 { tag :: Tag "isJust" (Maybe MaybeTag)
80 , just :: a
81 }
82 deriving stock Functor
85instance Apply MaybeTable where
86 MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f a)
89-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:
90-- 'Rel8.traverseMaybeTable'.
91instance Applicative MaybeTable where
92 (<*>) = (<.>)
93 pure = justTable
96instance Bind MaybeTable where
97 MaybeTable tag a >>- f = case f a of
98 MaybeTable tag' b -> MaybeTable (tag <> tag') b
101-- | Has the same behavior as the @Monad@ instance for @Maybe@.
102instance Monad MaybeTable where
103 (>>=) = (>>-)
106instance AltTable MaybeTable where
107 ma@(MaybeTable tag a) <|>: MaybeTable tag' b = MaybeTable
108 { tag = (tag <> tag')
109 { expr = boolExpr (expr tag) (expr tag') condition
110 }
111 , just = bool a b condition
112 }
113 where
114 condition = isNothingTable ma
117instance AlternativeTable MaybeTable where
118 emptyTable = nothingTable
121instance (Table Expr a, Semigroup a) => Semigroup (MaybeTable a) where
122 ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma
125instance (Table Expr a, Semigroup a) => Monoid (MaybeTable a) where
126 mempty = nothingTable
129instance
130 ( Table context a
131 , Nullifiable context
132 , ConstrainTag context MaybeTag
133 ) => Table context (MaybeTable a)
134 where
135 type Columns (MaybeTable a) = HMaybeTable (Columns a)
136 type Context (MaybeTable a) = Context a
138 toColumns = toColumns1 toColumns
139 fromColumns = fromColumns1 fromColumns
140 reify = fmap fmap reify
141 unreify = fmap fmap unreify
144instance
145 ( Nullifiable from, ConstrainTag from MaybeTag
146 , Nullifiable to, ConstrainTag to MaybeTag
147 , Recontextualize from to a b
148 )
149 => Recontextualize from to (MaybeTable a) (MaybeTable b)
152instance EqTable a => EqTable (MaybeTable a) where
153 eqTable = toColumns1 id (justTable (eqTable @a))
156instance OrdTable a => OrdTable (MaybeTable a) where
157 ordTable = toColumns1 id (justTable (ordTable @a))
160type instance FromExprs (MaybeTable a) = Maybe (FromExprs a)
163instance ToExprs exprs a => ToExprs (MaybeTable exprs) (Maybe a) where
164 fromResult = fmap (fromResult @exprs) . fromColumns
165 toResult = toColumns . fmap (toResult @exprs)
168-- | Check if a @MaybeTable@ is absent of any row. Like 'Data.Maybe.isNothing'.
169isNothingTable :: MaybeTable a -> Expr Bool
170isNothingTable (MaybeTable tag _) = isNull (expr tag)
173-- | Check if a @MaybeTable@ contains a row. Like 'Data.Maybe.isJust'.
174isJustTable :: MaybeTable a -> Expr Bool
175isJustTable (MaybeTable tag _) = isNonNull (expr tag)
178-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.
179maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable a -> b
180maybeTable b f ma@(MaybeTable _ a) = bool (f a) b (isNothingTable ma)
181{-# INLINABLE maybeTable #-}
184-- | The null table. Like 'Nothing'.
185nothingTable :: Table Expr a => MaybeTable a
186nothingTable = MaybeTable (fromExpr null) undefined
189-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use
190-- 'pure'.
191justTable :: a -> MaybeTable a
192justTable = MaybeTable (fromExpr mempty)
195-- | Project a single expression out of a 'MaybeTable'. You can think of this
196-- operator like the '$' operator, but it also has the ability to return
197-- @null@.
198($?) :: forall a b. Sql DBType b
199 => (a -> Expr b) -> MaybeTable a -> Expr (Nullify b)
200f $? ma@(MaybeTable _ a) = case nullable @b of
201 Null -> boolExpr (f a) null (isNothingTable ma)
202 NotNull -> boolExpr (nullify (f a)) null (isNothingTable ma)
203infixl 4 $?
206-- | Construct a 'MaybeTable' in the 'Name' context. This can be useful if you
207-- have a 'MaybeTable' that you are storing in a table and need to construct a
208-- 'TableSchema'.
209nameMaybeTable
210 :: Name (Maybe MaybeTag)
211 -- ^ The name of the column to track whether a row is a 'justTable' or
212 -- 'nothingTable'.
213 -> a
214 -- ^ Names of the columns in @a@.
215 -> MaybeTable a
216nameMaybeTable = MaybeTable . fromName
219toColumns1 ::
220 ( HTable t
221 , HConstrainTag context MaybeTag
222 , HNullifiable context
223 )
224 => (a -> t context)
225 -> MaybeTable a
226 -> HMaybeTable t context
227toColumns1 f MaybeTable {tag, just} = HMaybeTable
228 { htag
229 , hjust = hlabel $ hnullify (hnullifier tag isNonNull) $ f just
230 }
231 where
232 htag = hlabel (HType (hencodeTag tag))
235fromColumns1 ::
236 ( HTable t
237 , HConstrainTag context MaybeTag
238 , HNullifiable context
239 )
240 => (t context -> a)
241 -> HMaybeTable t context
242 -> MaybeTable a
243fromColumns1 f HMaybeTable {htag, hjust} = MaybeTable
244 { tag
245 , just = f $ runIdentity $
246 hunnullify (\a -> pure . hunnullifier a) (hunlabel hjust)
247 }
248 where
249 tag = hdecodeTag (unHIdentity (hunlabel htag))