git.iko.soy/rel8
on 912ec09 help sign in
rel8/src/Rel8/Table/Maybe.hs
215 lines 6.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 )
20where
22-- base
23import Data.Functor.Identity ( runIdentity )
24import Data.Kind ( Type )
25import Prelude hiding ( null, repeat, undefined, zipWith )
27-- rel8
28import Rel8.Expr ( Expr )
29import Rel8.Expr.Bool ( boolExpr )
30import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )
31import Rel8.Expr.Serialize ( litExpr )
32import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler, hlabeler )
33import Rel8.Schema.Context.Nullify
34 ( Nullifiable, ConstrainTag
35 , hencodeTag, hdecodeTag
36 , hnullifier, hunnullifier
37 )
38import Rel8.Schema.HTable.Identity ( HIdentity(..) )
39import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
40import Rel8.Schema.HTable.Maybe ( HMaybeTable(..), HMaybeNullifiable )
41import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
42import Rel8.Schema.Nullability
43 ( Nullify
44 , Nullability( Nullable, NonNullable )
45 , Sql, nullabilization
46 )
47import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
48import Rel8.Table.Alternative
49 ( AltTable, (<|>:)
50 , AlternativeTable, emptyTable
51 )
52import Rel8.Table.Bool ( bool )
53import Rel8.Table.Eq ( EqTable, eqTable )
54import Rel8.Table.Lifted
55 ( Table1, Columns1, ConstrainHContext1, fromColumns1, toColumns1
56 )
57import Rel8.Table.Ord ( OrdTable, ordTable )
58import Rel8.Table.Recontextualize ( Recontextualize )
59import Rel8.Table.Undefined ( undefined )
60import Rel8.Type ( DBType )
61import Rel8.Type.Tag ( MaybeTag( IsJust ) )
63-- semigroupoids
64import Data.Functor.Apply ( Apply, (<.>) )
65import Data.Functor.Bind ( Bind, (>>-) )
68-- | @MaybeTable t@ is the table @t@, but as the result of an outer join. If
69-- the outer join fails to match any rows, this is essentialy @Nothing@, and if
70-- the outer join does match rows, this is like @Just@. Unfortunately, SQL
71-- makes it impossible to distinguish whether or not an outer join matched any
72-- rows based generally on the row contents - if you were to join a row
73-- entirely of nulls, you can't distinguish if you matched an all null row, or
74-- if the match failed. For this reason @MaybeTable@ contains an extra field -
75-- a "nullTag" - to track whether or not the outer join produced any rows.
76type MaybeTable :: Type -> Type
77data MaybeTable a = MaybeTable
78 { tag :: Expr (Maybe MaybeTag)
79 , just :: a
80 }
81 deriving stock (Show, Functor)
84instance Apply MaybeTable where
85 MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f a)
88-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:
89-- 'traverseMaybeTable'.
90instance Applicative MaybeTable where
91 (<*>) = (<.>)
92 pure = justTable
95instance Bind MaybeTable where
96 MaybeTable tag a >>- f = case f a of
97 MaybeTable tag' b -> MaybeTable (tag <> tag') b
100-- | Has the same behavior as the @Monad@ instance for @Maybe@. See also:
101-- 'bindMaybeTable'.
102instance Monad MaybeTable where
103 (>>=) = (>>-)
106instance AltTable MaybeTable where
107 ma@(MaybeTable tag a) <|>: MaybeTable tag' b = MaybeTable
108 { tag = boolExpr tag tag' condition
109 , just = bool a b condition
110 }
111 where
112 condition = isNothingTable ma
115instance AlternativeTable MaybeTable where
116 emptyTable = nothingTable
119instance (Table Expr a, Semigroup a) => Semigroup (MaybeTable a) where
120 ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma
123instance (Table Expr a, Semigroup a) => Monoid (MaybeTable a) where
124 mempty = nothingTable
127instance Table1 MaybeTable where
128 type Columns1 MaybeTable = HMaybeTable
129 type ConstrainHContext1 MaybeTable = HMaybeNullifiable
131 toColumns1 f MaybeTable {tag, just} = HMaybeTable
132 { htag
133 , hjust = hnullify (hnullifier (isNonNull tag)) $ f just
134 }
135 where
136 htag = HIdentity (hencodeTag tag)
138 fromColumns1 f HMaybeTable {htag = HIdentity htag, hjust} = MaybeTable
139 { tag
140 , just = f $ runIdentity $
141 hunnullify (\a -> pure . hunnullifier (isNonNull tag) a) hjust
142 }
143 where
144 tag = hdecodeTag htag
146 {-# INLINABLE fromColumns1 #-}
147 {-# INLINABLE toColumns1 #-}
150instance
151 ( Table context a
152 , Labelable context, Nullifiable context
153 , ConstrainTag context MaybeTag
154 ) => Table context (MaybeTable a)
155 where
156 type Columns (MaybeTable a) = HMaybeTable (HLabel "Just" (Columns a))
157 type Context (MaybeTable a) = Context a
159 toColumns = toColumns1 (hlabel labeler . toColumns)
160 fromColumns = fromColumns1 (fromColumns . hunlabel unlabeler)
163instance
164 ( Labelable from, Nullifiable from, ConstrainTag from MaybeTag
165 , Labelable to, Nullifiable to, ConstrainTag to MaybeTag
166 , Recontextualize from to a b
167 ) => Recontextualize from to (MaybeTable a) (MaybeTable b)
170instance EqTable a => EqTable (MaybeTable a) where
171 eqTable = toColumns1 (hlabel hlabeler) (justTable (eqTable @a))
174instance OrdTable a => OrdTable (MaybeTable a) where
175 ordTable = toColumns1 (hlabel hlabeler) (justTable (ordTable @a))
178-- | Check if a @MaybeTable@ is absent of any row.. Like 'isNothing'.
179isNothingTable :: MaybeTable a -> Expr Bool
180isNothingTable (MaybeTable tag _) = isNull tag
183-- | Check if a @MaybeTable@ contains a row. Like 'isJust'.
184isJustTable :: MaybeTable a -> Expr Bool
185isJustTable (MaybeTable tag _) = isNonNull tag
188-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.
189maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable a -> b
190maybeTable b f ma@(MaybeTable _ a) = bool (f a) b (isNothingTable ma)
193-- | The null table. Like 'Nothing'.
194nothingTable :: Table Expr a => MaybeTable a
195nothingTable = MaybeTable null undefined
198-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use
199-- 'pure'.
200justTable :: a -> MaybeTable a
201justTable = MaybeTable (nullify (litExpr IsJust))
204-- | Project a single expression out of a 'MaybeTable'. You can think of this
205-- operator like the '$' operator, but it also has the ability to return
206-- @null@.
207--
208-- >>> select c $ fmap (fst $?) (optional (values [lit (True, False)]))
209-- [Just True]
210($?) :: forall a b. Sql DBType b
211 => (a -> Expr b) -> MaybeTable a -> Expr (Nullify b)
212f $? ma@(MaybeTable _ a) = case nullabilization @b of
213 Nullable -> boolExpr (f a) null (isNothingTable ma)
214 NonNullable -> boolExpr (nullify (f a)) null (isNothingTable ma)
215infixl 4 $?