git.iko.soy/rel8
on 716d9f1 help sign in
rel8/src/Rel8/Table/These.hs
325 lines 9.3 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 RecordWildCards #-}
9{-# language ScopedTypeVariables #-}
10{-# language StandaloneKindSignatures #-}
11{-# language TupleSections #-}
12{-# language TypeApplications #-}
13{-# language TypeFamilies #-}
14{-# language UndecidableInstances #-}
16{-# options_ghc -fno-warn-orphans #-}
18module Rel8.Table.These
19 ( TheseTable(..)
20 , theseTable, thisTable, thatTable, thoseTable
21 , isThisTable, isThatTable, isThoseTable
22 , hasHereTable, hasThereTable
23 , justHereTable, justThereTable
24 , nameTheseTable
25 )
26where
28-- base
29import Control.Applicative ( liftA2 )
30import Data.Bifunctor ( Bifunctor, bimap )
31import Data.Functor.Identity ( runIdentity )
32import Data.Kind ( Type )
33import Prelude hiding ( undefined )
35-- rel8
36import Rel8.Expr ( Expr )
37import Rel8.Expr.Bool ( (&&.), not_ )
38import Rel8.Expr.Null ( isNonNull )
39import Rel8.Schema.Context.Nullify
40 ( Nullifiable
41 , encodeTag, decodeTag
42 , nullifier, unnullifier
43 )
44import Rel8.Schema.Dict ( Dict( Dict ) )
45import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
46import Rel8.Schema.HTable.Identity ( HIdentity(..) )
47import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
48import Rel8.Schema.HTable.These ( HTheseTable(..) )
49import Rel8.Schema.Name ( Name )
50import Rel8.Table
51 ( Table, Columns, Context, fromColumns, toColumns
52 , reify, unreify
53 )
54import Rel8.Table.Eq ( EqTable, eqTable )
55import Rel8.Table.Maybe
56 ( MaybeTable(..)
57 , maybeTable, justTable, nothingTable
58 , isJustTable
59 , nameMaybeTable
60 )
61import Rel8.Table.Ord ( OrdTable, ordTable )
62import Rel8.Table.Recontextualize ( Recontextualize )
63import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
64import Rel8.Table.Tag ( Tag(..) )
65import Rel8.Table.Undefined ( undefined )
66import Rel8.Type.Tag ( MaybeTag )
68-- semigroupoids
69import Data.Functor.Apply ( Apply, (<.>) )
70import Data.Functor.Bind ( Bind, (>>-) )
72-- these
73import Data.These ( These )
76-- | @TheseTable a b@ is a Rel8 table that contains either the table @a@, the
77-- table @b@, or both tables @a@ and @b@. You can construct @TheseTable@s using
78-- 'thisTable', 'thatTable' and 'thoseTable'. @TheseTable@s can be
79-- eliminated/pattern matched using 'theseTable'.
80--
81-- @TheseTable@ is operationally the same as Haskell's 'These' type, but
82-- adapted to work with Rel8.
83type TheseTable :: Type -> Type -> Type
84data TheseTable a b = TheseTable
85 { here :: MaybeTable a
86 , there :: MaybeTable b
87 }
88 deriving stock Functor
91instance Bifunctor TheseTable where
92 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)
95instance (Table Expr a, Semigroup a) => Apply (TheseTable a) where
96 fs <.> as = TheseTable
97 { here = here fs <> here as
98 , there = there fs <.> there as
99 }
102instance (Table Expr a, Semigroup a) => Applicative (TheseTable a)
103 where
104 pure = thatTable
105 (<*>) = (<.>)
108instance (Table Expr a, Semigroup a) => Bind (TheseTable a) where
109 TheseTable here1 ma >>- f = case ma >>- f' of
110 mtb -> TheseTable
111 { here = maybeTable here1 ((here1 <>) . fst) mtb
112 , there = snd <$> mtb
113 }
114 where
115 f' a = case f a of
116 TheseTable here2 mb -> (here2,) <$> mb
119instance (Table Expr a, Semigroup a) => Monad (TheseTable a) where
120 (>>=) = (>>-)
123instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
124 Semigroup (TheseTable a b)
125 where
126 a <> b = TheseTable
127 { here = here a <> here b
128 , there = there a <> there b
129 }
132instance
133 ( Table context a, Table context b
134 , Nullifiable context
135 )
136 => Table context (TheseTable a b)
137 where
138 type Columns (TheseTable a b) = HTheseTable (Columns a) (Columns b)
139 type Context (TheseTable a b) = Context a
141 toColumns TheseTable {here, there} = HTheseTable
142 { hhereTag = hlabel $ HType $ encodeTag (toHereTag (tag here))
143 , hhere =
144 hlabel $ hnullify (nullifier (tag here) isNonNull) $ toColumns $
145 just here
146 , hthereTag = hlabel $ HType $ encodeTag (toThereTag (tag there))
147 , hthere =
148 hlabel $ hnullify (nullifier (tag there) isNonNull) $ toColumns $
149 just there
150 }
152 fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable
153 { here =
154 let
155 tag = decodeTag $ unHIdentity $ hunlabel hhereTag
156 in
157 MaybeTable
158 { tag
159 , just =
160 fromColumns $
161 runIdentity $
162 hunnullify (\a -> pure . unnullifier a) $
163 hunlabel
164 hhere
165 }
166 , there =
167 let
168 tag = decodeTag $ unHIdentity $ hunlabel hthereTag
169 in
170 MaybeTable
171 { tag
172 , just =
173 fromColumns $
174 runIdentity $
175 hunnullify (\a -> pure . unnullifier a) $
176 hunlabel
177 hthere
178 }
179 }
182 reify = liftA2 bimap reify reify
183 unreify = liftA2 bimap unreify unreify
186instance
187 ( Nullifiable from, Nullifiable to
188 , Recontextualize from to a1 b1
189 , Recontextualize from to a2 b2
190 )
191 => Recontextualize from to (TheseTable a1 a2) (TheseTable b1 b2)
194instance (EqTable a, EqTable b) => EqTable (TheseTable a b) where
195 eqTable = HTheseTable
196 { hhereTag = hlabel (HType Dict)
197 , hhere = hlabel (hnullify (\_ Dict -> Dict) (eqTable @a))
198 , hthereTag = hlabel (HType Dict)
199 , hthere = hlabel (hnullify (\_ Dict -> Dict) (eqTable @b))
200 }
203instance (OrdTable a, OrdTable b) => OrdTable (TheseTable a b) where
204 ordTable = HTheseTable
205 { hhereTag = hlabel (HType Dict)
206 , hhere = hlabel (hnullify (\_ Dict -> Dict) (ordTable @a))
207 , hthereTag = hlabel (HType Dict)
208 , hthere = hlabel (hnullify (\_ Dict -> Dict) (ordTable @b))
209 }
212type instance FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)
215instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable exprs1 exprs2) =>
216 ToExprs x (These a b)
217 where
218 fromResult =
219 bimap (fromResult @exprs1) (fromResult @exprs2) .
220 fromColumns
221 toResult =
222 toColumns .
223 bimap (toResult @exprs1) (toResult @exprs2)
226toHereTag :: Tag "isJust" a -> Tag "hasHere" a
227toHereTag Tag {..} = Tag {..}
230toThereTag :: Tag "isJust" a -> Tag "hasThere" a
231toThereTag Tag {..} = Tag {..}
234-- | Test if a 'TheseTable' was constructed with 'thisTable'.
235--
236-- Corresponds to 'Data.These.Combinators.isThis'.
237isThisTable :: TheseTable a b -> Expr Bool
238isThisTable a = hasHereTable a &&. not_ (hasThereTable a)
241-- | Test if a 'TheseTable' was constructed with 'thatTable'.
242--
243-- Corresponds to 'Data.These.Combinators.isThat'.
244isThatTable :: TheseTable a b -> Expr Bool
245isThatTable a = not_ (hasHereTable a) &&. hasThereTable a
248-- | Test if a 'TheseTable' was constructed with 'thoseTable'.
249--
250-- Corresponds to 'Data.These.Combinators.isThese'.
251isThoseTable :: TheseTable a b -> Expr Bool
252isThoseTable a = hasHereTable a &&. hasThereTable a
255-- | Test if the @a@ side of @TheseTable a b@ is present.
256--
257-- Corresponds to 'Data.These.Combinators.hasHere'.
258hasHereTable :: TheseTable a b -> Expr Bool
259hasHereTable TheseTable {here} = isJustTable here
262-- | Test if the @b@ table of @TheseTable a b@ is present.
263--
264-- Corresponds to 'Data.These.Combinators.hasThere'.
265hasThereTable :: TheseTable a b -> Expr Bool
266hasThereTable TheseTable {there} = isJustTable there
269-- | Attempt to project out the @a@ table of a @TheseTable a b@.
270--
271-- Corresponds to 'Data.These.Combinators.justHere'.
272justHereTable :: TheseTable a b -> MaybeTable a
273justHereTable = here
276-- | Attempt to project out the @b@ table of a @TheseTable a b@.
277--
278-- Corresponds to 'Data.These.Combinators.justThere'.
279justThereTable :: TheseTable a b -> MaybeTable b
280justThereTable = there
283-- | Construct a @TheseTable@. Corresponds to 'This'.
284thisTable :: Table Expr b => a -> TheseTable a b
285thisTable a = TheseTable (justTable a) nothingTable
288-- | Construct a @TheseTable@. Corresponds to 'That'.
289thatTable :: Table Expr a => b -> TheseTable a b
290thatTable b = TheseTable nothingTable (justTable b)
293-- | Construct a @TheseTable@. Corresponds to 'These'.
294thoseTable :: a -> b -> TheseTable a b
295thoseTable a b = TheseTable (justTable a) (justTable b)
298-- | Pattern match on a 'TheseTable'. Corresponds to 'these'.
299theseTable :: Table Expr c
300 => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable a b -> c
301theseTable f g h TheseTable {here, there} =
302 maybeTable
303 (maybeTable undefined f here)
304 (\b -> maybeTable (g b) (`h` b) here)
305 there
308-- | Construct a 'TheseTable' in the 'Name' context. This can be useful if you
309-- have a 'TheseTable' that you are storing in a table and need to construct a
310-- 'TableSchema'.
311nameTheseTable :: ()
312 => Name (Maybe MaybeTag)
313 -- ^ The name of the column to track the presence of the @a@ table.
314 -> Name (Maybe MaybeTag)
315 -- ^ The name of the column to track the presence of the @b@ table.
316 -> a
317 -- ^ Names of the columns in the @a@ table.
318 -> b
319 -- ^ Names of the columns in the @b@ table.
320 -> TheseTable a b
321nameTheseTable here there a b =
322 TheseTable
323 { here = nameMaybeTable here a
324 , there = nameMaybeTable there b
325 }