git.iko.soy/rel8
on 01b569f help sign in
rel8/src/Rel8/Table/Maybe.hs
246 lines 7.3 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.Label
34 ( Labelable, HLabelable, hlabeler, hunlabeler
35 )
36import Rel8.Schema.Context.Nullify
37 ( Nullifiable, ConstrainTag
38 , HNullifiable, HConstrainTag
39 , hencodeTag, hdecodeTag
40 , hnullifier, hunnullifier
41 )
42import Rel8.Schema.HTable ( HTable )
43import Rel8.Schema.HTable.Identity ( HIdentity(..) )
44import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
45import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
46import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
47import Rel8.Schema.Name ( Name )
48import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql, nullable )
49import Rel8.Table
50 ( Table, Columns, Context, fromColumns, toColumns
51 , reify, unreify
52 )
53import Rel8.Table.Alternative
54 ( AltTable, (<|>:)
55 , AlternativeTable, emptyTable
56 )
57import Rel8.Table.Bool ( bool )
58import Rel8.Table.Eq ( EqTable, eqTable )
59import Rel8.Table.Ord ( OrdTable, ordTable )
60import Rel8.Table.Recontextualize ( Recontextualize )
61import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
62import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )
63import Rel8.Table.Undefined ( undefined )
64import Rel8.Type ( DBType )
65import Rel8.Type.Tag ( MaybeTag )
67-- semigroupoids
68import Data.Functor.Apply ( Apply, (<.>) )
69import Data.Functor.Bind ( Bind, (>>-) )
72-- | @MaybeTable t@ is the table @t@, but as the result of an outer join. If
73-- the outer join fails to match any rows, this is essentialy @Nothing@, and if
74-- the outer join does match rows, this is like @Just@. Unfortunately, SQL
75-- makes it impossible to distinguish whether or not an outer join matched any
76-- rows based generally on the row contents - if you were to join a row
77-- entirely of nulls, you can't distinguish if you matched an all null row, or
78-- if the match failed. For this reason @MaybeTable@ contains an extra field -
79-- a "nullTag" - to track whether or not the outer join produced any rows.
80type MaybeTable :: Type -> Type
81data MaybeTable a = MaybeTable
82 { tag :: Tag "isJust" (Maybe MaybeTag)
83 , just :: a
84 }
85 deriving stock Functor
88instance Apply MaybeTable where
89 MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f a)
92-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:
93-- 'Rel8.traverseMaybeTable'.
94instance Applicative MaybeTable where
95 (<*>) = (<.>)
96 pure = justTable
99instance Bind MaybeTable where
100 MaybeTable tag a >>- f = case f a of
101 MaybeTable tag' b -> MaybeTable (tag <> tag') b
104-- | Has the same behavior as the @Monad@ instance for @Maybe@. See also:
105-- 'Rel8.bindMaybeTable'.
106instance Monad MaybeTable where
107 (>>=) = (>>-)
110instance AltTable MaybeTable where
111 ma@(MaybeTable tag a) <|>: MaybeTable tag' b = MaybeTable
112 { tag = (tag <> tag')
113 { expr = boolExpr (expr tag) (expr tag') condition
114 }
115 , just = bool a b condition
116 }
117 where
118 condition = isNothingTable ma
121instance AlternativeTable MaybeTable where
122 emptyTable = nothingTable
125instance (Table Expr a, Semigroup a) => Semigroup (MaybeTable a) where
126 ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma
129instance (Table Expr a, Semigroup a) => Monoid (MaybeTable a) where
130 mempty = nothingTable
133instance
134 ( Table context a
135 , Labelable context, Nullifiable context
136 , ConstrainTag context MaybeTag
137 ) => Table context (MaybeTable a)
138 where
139 type Columns (MaybeTable a) = HMaybeTable (Columns a)
140 type Context (MaybeTable a) = Context a
142 toColumns = toColumns1 toColumns
143 fromColumns = fromColumns1 fromColumns
144 reify = fmap fmap reify
145 unreify = fmap fmap unreify
148instance
149 ( Labelable from, Nullifiable from, ConstrainTag from MaybeTag
150 , Labelable to, Nullifiable to, ConstrainTag to MaybeTag
151 , Recontextualize from to a b
152 )
153 => Recontextualize from to (MaybeTable a) (MaybeTable b)
156instance EqTable a => EqTable (MaybeTable a) where
157 eqTable = toColumns1 id (justTable (eqTable @a))
160instance OrdTable a => OrdTable (MaybeTable a) where
161 ordTable = toColumns1 id (justTable (ordTable @a))
164type instance FromExprs (MaybeTable a) = Maybe (FromExprs a)
167instance ToExprs exprs a => ToExprs (MaybeTable exprs) (Maybe a) where
168 fromResult = fmap (fromResult @exprs) . fromColumns
169 toResult = toColumns . fmap (toResult @exprs)
172-- | Check if a @MaybeTable@ is absent of any row. Like 'Data.Maybe.isNothing'.
173isNothingTable :: MaybeTable a -> Expr Bool
174isNothingTable (MaybeTable tag _) = isNull (expr tag)
177-- | Check if a @MaybeTable@ contains a row. Like 'Data.Maybe.isJust'.
178isJustTable :: MaybeTable a -> Expr Bool
179isJustTable (MaybeTable tag _) = isNonNull (expr tag)
182-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.
183maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable a -> b
184maybeTable b f ma@(MaybeTable _ a) = bool (f a) b (isNothingTable ma)
185{-# INLINABLE maybeTable #-}
188-- | The null table. Like 'Nothing'.
189nothingTable :: Table Expr a => MaybeTable a
190nothingTable = MaybeTable (fromExpr null) undefined
193-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use
194-- 'pure'.
195justTable :: a -> MaybeTable a
196justTable = MaybeTable (fromExpr mempty)
199-- | Project a single expression out of a 'MaybeTable'. You can think of this
200-- operator like the '$' operator, but it also has the ability to return
201-- @null@.
202($?) :: forall a b. Sql DBType b
203 => (a -> Expr b) -> MaybeTable a -> Expr (Nullify b)
204f $? ma@(MaybeTable _ a) = case nullable @b of
205 Null -> boolExpr (f a) null (isNothingTable ma)
206 NotNull -> boolExpr (nullify (f a)) null (isNothingTable ma)
207infixl 4 $?
210nameMaybeTable :: Name (Maybe MaybeTag) -> a -> MaybeTable a
211nameMaybeTable = MaybeTable . fromName
214toColumns1 ::
215 ( HTable t
216 , HConstrainTag context MaybeTag
217 , HLabelable context
218 , HNullifiable context
219 )
220 => (a -> t context)
221 -> MaybeTable a
222 -> HMaybeTable t context
223toColumns1 f MaybeTable {tag, just} = HMaybeTable
224 { htag
225 , hjust = hlabel hlabeler $ hnullify (hnullifier tag isNonNull) $ f just
226 }
227 where
228 htag = HIdentity (hencodeTag tag)
231fromColumns1 ::
232 ( HTable t
233 , HConstrainTag context MaybeTag
234 , HLabelable context
235 , HNullifiable context
236 )
237 => (t context -> a)
238 -> HMaybeTable t context
239 -> MaybeTable a
240fromColumns1 f HMaybeTable {htag = HIdentity htag, hjust} = MaybeTable
241 { tag
242 , just = f $ runIdentity $
243 hunnullify (\a -> pure . hunnullifier a) (hunlabel hunlabeler hjust)
244 }
245 where
246 tag = hdecodeTag htag