git.iko.soy/rel8
on 8a680c9 help sign in
rel8/src/Rel8/Table/Maybe.hs
256 lines 7.7 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, undefined )
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
36 ( Labelable, HLabelable, hlabeler, hunlabeler
37 )
38import Rel8.Schema.Context.Nullify
39 ( Nullifiable, ConstrainTag
40 , HNullifiable, HConstrainTag
41 , hencodeTag, hdecodeTag
42 , hnullifier, hunnullifier
43 )
44import Rel8.Schema.HTable ( HTable )
45import Rel8.Schema.HTable.Identity ( HIdentity(..) )
46import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
47import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
48import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
49import Rel8.Schema.Name ( Name )
50import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ), Sql, nullable )
51import Rel8.Table
52 ( Table, Columns, Context, fromColumns, toColumns
53 , reify, unreify
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.Recontextualize ( Recontextualize )
63import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
64import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )
65import Rel8.Table.Undefined ( undefined )
66import Rel8.Type ( DBType )
67import Rel8.Type.Tag ( MaybeTag )
69-- semigroupoids
70import Data.Functor.Apply ( Apply, (<.>), liftF2 )
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 :: Type -> Type
83data MaybeTable a = MaybeTable
84 { tag :: Tag "isJust" (Maybe MaybeTag)
85 , just :: a
86 }
87 deriving stock Functor
90instance Apply MaybeTable where
91 MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f a)
94-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:
95-- 'Rel8.traverseMaybeTable'.
96instance Applicative MaybeTable where
97 (<*>) = (<.>)
98 pure = justTable
101instance Bind MaybeTable where
102 MaybeTable tag a >>- f = case f a of
103 MaybeTable tag' b -> MaybeTable (tag <> tag') b
106-- | Has the same behavior as the @Monad@ instance for @Maybe@. See also:
107-- 'Rel8.bindMaybeTable'.
108instance Monad MaybeTable where
109 (>>=) = (>>-)
112instance AltTable MaybeTable where
113 ma@(MaybeTable tag a) <|>: MaybeTable tag' b = MaybeTable
114 { tag = (tag <> tag')
115 { expr = boolExpr (expr tag) (expr tag') condition
116 }
117 , just = bool a b condition
118 }
119 where
120 condition = isNothingTable ma
123instance AlternativeTable MaybeTable where
124 emptyTable = nothingTable
127instance (Table Expr a, Semigroup a) => Semigroup (MaybeTable a) where
128 ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma
131instance (Table Expr a, Semigroup a) => Monoid (MaybeTable a) where
132 mempty = nothingTable
135instance
136 ( Table context a
137 , Labelable context, Nullifiable context
138 , ConstrainTag context MaybeTag
139 ) => Table context (MaybeTable a)
140 where
141 type Columns (MaybeTable a) = HMaybeTable (Columns a)
142 type Context (MaybeTable a) = Context a
144 toColumns = toColumns1 toColumns
145 fromColumns = fromColumns1 fromColumns
146 reify = fmap fmap reify
147 unreify = fmap fmap unreify
150instance
151 ( Labelable from, Nullifiable from, ConstrainTag from MaybeTag
152 , Labelable to, Nullifiable to, ConstrainTag to MaybeTag
153 , Recontextualize from to a b
154 )
155 => Recontextualize from to (MaybeTable a) (MaybeTable b)
158instance EqTable a => EqTable (MaybeTable a) where
159 eqTable = toColumns1 id (justTable (eqTable @a))
162instance OrdTable a => OrdTable (MaybeTable a) where
163 ordTable = toColumns1 id (justTable (ordTable @a))
166type instance FromExprs (MaybeTable a) = Maybe (FromExprs a)
169instance ToExprs exprs a => ToExprs (MaybeTable exprs) (Maybe a) where
170 fromResult = fmap (fromResult @exprs) . fromColumns
171 toResult = toColumns . fmap (toResult @exprs)
174-- | Check if a @MaybeTable@ is absent of any row. Like 'Data.Maybe.isNothing'.
175isNothingTable :: MaybeTable a -> Expr Bool
176isNothingTable (MaybeTable tag _) = isNull (expr tag)
179-- | Check if a @MaybeTable@ contains a row. Like 'Data.Maybe.isJust'.
180isJustTable :: MaybeTable a -> Expr Bool
181isJustTable (MaybeTable tag _) = isNonNull (expr tag)
184-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.
185maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable a -> b
186maybeTable b f ma@(MaybeTable _ a) = bool (f a) b (isNothingTable ma)
187{-# INLINABLE maybeTable #-}
190-- | The null table. Like 'Nothing'.
191nothingTable :: Table Expr a => MaybeTable a
192nothingTable = MaybeTable (fromExpr null) undefined
195-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use
196-- 'pure'.
197justTable :: a -> MaybeTable a
198justTable = MaybeTable (fromExpr mempty)
201-- | Project a single expression out of a 'MaybeTable'. You can think of this
202-- operator like the '$' operator, but it also has the ability to return
203-- @null@.
204($?) :: forall a b. Sql DBType b
205 => (a -> Expr b) -> MaybeTable a -> Expr (Nullify b)
206f $? ma@(MaybeTable _ a) = case nullable @b of
207 Null -> boolExpr (f a) null (isNothingTable ma)
208 NotNull -> boolExpr (nullify (f a)) null (isNothingTable ma)
209infixl 4 $?
212aggregateMaybeTable :: ()
213 => (a -> Aggregate b) -> MaybeTable a -> Aggregate (MaybeTable b)
214aggregateMaybeTable f MaybeTable {tag = tag@Tag {aggregator, expr}, just} =
215 liftF2 MaybeTable (tag <$ aggregate) (f just)
216 where
217 aggregate = unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr
220nameMaybeTable :: Name (Maybe MaybeTag) -> a -> MaybeTable a
221nameMaybeTable = MaybeTable . fromName
224toColumns1 ::
225 ( HTable t
226 , HConstrainTag context MaybeTag
227 , HLabelable context
228 , HNullifiable context
229 )
230 => (a -> t context)
231 -> MaybeTable a
232 -> HMaybeTable t context
233toColumns1 f MaybeTable {tag, just} = HMaybeTable
234 { htag
235 , hjust = hlabel hlabeler $ hnullify (hnullifier tag isNonNull) $ f just
236 }
237 where
238 htag = HIdentity (hencodeTag tag)
241fromColumns1 ::
242 ( HTable t
243 , HConstrainTag context MaybeTag
244 , HLabelable context
245 , HNullifiable context
246 )
247 => (t context -> a)
248 -> HMaybeTable t context
249 -> MaybeTable a
250fromColumns1 f HMaybeTable {htag = HIdentity htag, hjust} = MaybeTable
251 { tag
252 , just = f $ runIdentity $
253 hunnullify (\a -> pure . hunnullifier a) (hunlabel hunlabeler hjust)
254 }
255 where
256 tag = hdecodeTag htag