git.iko.soy/rel8
on fadfc3e help sign in
rel8/src/Rel8/Table/Maybe.hs
180 lines 4.9 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 ( DB )
33import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
34import Rel8.Schema.Context.Nullify
35 ( Nullifiable
36 , encodeTag, decodeTag
37 , nullifier, unnullifier
38 )
39import Rel8.Schema.HTable.Identity ( HIdentity(..) )
40import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
41import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
42import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
43import Rel8.Schema.Nullability
44 ( Nullability( Nullable, NonNullable )
45 , Nullabilizes, 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.Lifted
54 ( Table1, Columns1, ConstrainContext1, fromColumns1, toColumns1
55 )
56import Rel8.Table.Recontextualize ( Recontextualize )
57import Rel8.Table.Undefined ( undefined )
58import Rel8.Type ( DBType )
59import Rel8.Type.Tag ( MaybeTag( IsJust ) )
61-- semigroupoids
62import Data.Functor.Apply ( Apply, (<.>) )
63import Data.Functor.Bind ( Bind, (>>-) )
66type MaybeTable :: Type -> Type
67data MaybeTable a = MaybeTable
68 { tag :: Expr (Maybe MaybeTag)
69 , just :: a
70 }
71 deriving stock (Show, Functor)
74instance Apply MaybeTable where
75 MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f a)
78instance Applicative MaybeTable where
79 (<*>) = (<.>)
80 pure = justTable
83instance Bind MaybeTable where
84 MaybeTable tag a >>- f = case f a of
85 MaybeTable tag' b -> MaybeTable (tag <> tag') b
88instance Monad MaybeTable where
89 (>>=) = (>>-)
92instance AltTable MaybeTable where
93 ma@(MaybeTable tag a) <|>: MaybeTable tag' b = MaybeTable
94 { tag = boolExpr tag tag' condition
95 , just = bool a b condition
96 }
97 where
98 condition = isNothingTable ma
101instance AlternativeTable MaybeTable where
102 emptyTable = nothingTable
105instance (Table DB a, Semigroup a) => Semigroup (MaybeTable a) where
106 ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma
109instance (Table DB a, Semigroup a) => Monoid (MaybeTable a) where
110 mempty = nothingTable
113instance Table1 MaybeTable where
114 type Columns1 MaybeTable = HMaybeTable
115 type ConstrainContext1 MaybeTable = Nullifiable
117 toColumns1 f MaybeTable {tag, just} = HMaybeTable
118 { htag
119 , hjust = hnullify (nullifier (isNonNull tag)) $ f just
120 }
121 where
122 htag = HIdentity (encodeTag tag)
124 fromColumns1 f HMaybeTable {htag = HIdentity htag, hjust} = MaybeTable
125 { tag
126 , just = f $ runIdentity $
127 hunnullify (\a -> pure . unnullifier (isNonNull tag) a) hjust
128 }
129 where
130 tag = decodeTag htag
132 {-# INLINABLE fromColumns1 #-}
133 {-# INLINABLE toColumns1 #-}
136instance
137 ( Table context a
138 , Labelable context, Nullifiable context
139 ) => Table context (MaybeTable a)
140 where
141 type Columns (MaybeTable a) = HMaybeTable (HLabel "Just" (Columns a))
142 type Context (MaybeTable a) = Context a
144 toColumns = toColumns1 (hlabel labeler . toColumns)
145 fromColumns = fromColumns1 (fromColumns . hunlabel unlabeler)
148instance
149 ( Labelable from, Nullifiable from
150 , Labelable to, Nullifiable to
151 , Recontextualize from to a b
152 ) => Recontextualize from to (MaybeTable a) (MaybeTable b)
155isNothingTable :: MaybeTable a -> Expr Bool
156isNothingTable (MaybeTable tag _) = isNull tag
159isJustTable :: MaybeTable a -> Expr Bool
160isJustTable (MaybeTable tag _) = isNonNull tag
163maybeTable :: Table DB b => b -> (a -> b) -> MaybeTable a -> b
164maybeTable b f ma@(MaybeTable _ a) = bool (f a) b (isNothingTable ma)
167nothingTable :: Table DB a => MaybeTable a
168nothingTable = MaybeTable null undefined
171justTable :: a -> MaybeTable a
172justTable = MaybeTable (nullify (litExpr IsJust))
175($?) :: forall a b db. (DBType db, Nullabilizes db b)
176 => (a -> Expr b) -> MaybeTable a -> Expr (Maybe db)
177f $? ma@(MaybeTable _ a) = case nullabilization @b of
178 Nullable -> boolExpr (f a) null (isNothingTable ma)
179 NonNullable -> boolExpr (nullify (f a)) null (isNothingTable ma)
180infixl 4 $?