git.iko.soy/rel8
on 28aaa76 help sign in
rel8/src/Rel8/Table/These.hs
279 lines 7.6 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 #-}
16module Rel8.Table.These
17 ( TheseTable(..)
18 , theseTable, thisTable, thatTable, thoseTable
19 , isThisTable, isThatTable, isThoseTable
20 , hasHereTable, hasThereTable
21 , justHereTable, justThereTable
22 , aggregateTheseTable, nameTheseTable
23 )
24where
26-- base
27import Data.Bifunctor ( Bifunctor, bimap )
28import Data.Functor.Identity ( runIdentity )
29import Data.Kind ( Type )
30import Prelude hiding ( undefined )
32-- rel8
33import Rel8.Aggregate ( Aggregate )
34import Rel8.Expr ( Expr )
35import Rel8.Expr.Bool ( (&&.), not_ )
36import Rel8.Expr.Null ( isNonNull )
37import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler, hlabeler )
38import Rel8.Schema.Context.Nullify
39 ( Nullifiable, ConstrainTag
40 , hencodeTag, hdecodeTag
41 , hnullifier, hunnullifier
42 )
43import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
44import Rel8.Schema.HTable.Identity ( HIdentity(..) )
45import Rel8.Schema.HTable.Maybe ( HMaybeNullifiable )
46import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
47import Rel8.Schema.HTable.These ( HTheseTable(..) )
48import Rel8.Schema.Name ( Name )
49import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
50import Rel8.Table.Eq ( EqTable, eqTable )
51import Rel8.Table.Lifted
52 ( Table2, Columns2, ConstrainHContext2, fromColumns2, toColumns2
53 )
54import Rel8.Table.Maybe
55 ( MaybeTable(..)
56 , maybeTable, justTable, nothingTable
57 , isJustTable
58 , aggregateMaybeTable, nameMaybeTable
59 )
60import Rel8.Table.Ord ( OrdTable, ordTable )
61import Rel8.Table.Recontextualize ( Recontextualize )
62import Rel8.Table.Tag ( Tag(..) )
63import Rel8.Table.Undefined ( undefined )
64import Rel8.Type.Tag ( MaybeTag )
66-- semigroupoids
67import Data.Functor.Apply ( Apply, (<.>), liftF2 )
68import Data.Functor.Bind ( Bind, (>>-) )
71type TheseTable :: Type -> Type -> Type
72data TheseTable a b = TheseTable
73 { here :: MaybeTable a
74 , there :: MaybeTable b
75 }
76 deriving stock Functor
79instance Bifunctor TheseTable where
80 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)
83instance (Table Expr a, Semigroup a) => Apply (TheseTable a) where
84 fs <.> as = TheseTable
85 { here = here fs <> here as
86 , there = there fs <.> there as
87 }
90instance (Table Expr a, Semigroup a) => Applicative (TheseTable a)
91 where
92 pure = thatTable
93 (<*>) = (<.>)
96instance (Table Expr a, Semigroup a) => Bind (TheseTable a) where
97 TheseTable here1 ma >>- f = case ma >>- f' of
98 mtb -> TheseTable
99 { here = maybeTable here1 ((here1 <>) . fst) mtb
100 , there = snd <$> mtb
101 }
102 where
103 f' a = case f a of
104 TheseTable here2 mb -> (here2,) <$> mb
107instance (Table Expr a, Semigroup a) => Monad (TheseTable a) where
108 (>>=) = (>>-)
111instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
112 Semigroup (TheseTable a b)
113 where
114 a <> b = TheseTable
115 { here = here a <> here b
116 , there = there a <> there b
117 }
120instance Table2 TheseTable where
121 type Columns2 TheseTable = HTheseTable
122 type ConstrainHContext2 TheseTable = HMaybeNullifiable
124 toColumns2 f g TheseTable {here, there} = HTheseTable
125 { hhereTag = HIdentity $ hencodeTag (toHereTag (tag here))
126 , hhere =
127 hnullify (hnullifier (tag here) isNonNull) $ f (just here)
128 , hthereTag = HIdentity $ hencodeTag (toThereTag (tag there))
129 , hthere =
130 hnullify (hnullifier (tag there) isNonNull) $ g (just there)
131 }
133 fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} =
134 TheseTable
135 { here =
136 let
137 tag = hdecodeTag $ unHIdentity hhereTag
138 in
139 MaybeTable
140 { tag
141 , just = f $
142 runIdentity $
143 hunnullify (\a -> pure . hunnullifier a)
144 hhere
145 }
146 , there =
147 let
148 tag = hdecodeTag $ unHIdentity hthereTag
149 in
150 MaybeTable
151 { tag
152 , just = g $
153 runIdentity $
154 hunnullify (\a -> pure . hunnullifier a)
155 hthere
156 }
157 }
159 {-# INLINABLE fromColumns2 #-}
160 {-# INLINABLE toColumns2 #-}
163instance
164 ( Table context a, Table context b
165 , Labelable context, Nullifiable context, ConstrainTag context MaybeTag
166 ) => Table context (TheseTable a b)
167 where
168 type Columns (TheseTable a b) =
169 HTheseTable (HLabel "Here" (Columns a)) (HLabel "There" (Columns b))
170 type Context (TheseTable a b) = Context a
172 toColumns =
173 toColumns2
174 (hlabel labeler . toColumns)
175 (hlabel labeler . toColumns)
176 fromColumns =
177 fromColumns2
178 (fromColumns . hunlabel unlabeler)
179 (fromColumns . hunlabel unlabeler)
182instance
183 ( Labelable from, Nullifiable from, ConstrainTag from MaybeTag
184 , Labelable to, Nullifiable to, ConstrainTag to MaybeTag
185 , Recontextualize from to a1 b1
186 , Recontextualize from to a2 b2
187 ) =>
188 Recontextualize from to (TheseTable a1 a2) (TheseTable b1 b2)
191instance (EqTable a, EqTable b) => EqTable (TheseTable a b) where
192 eqTable =
193 toColumns2 (hlabel hlabeler) (hlabel hlabeler)
194 (thoseTable (eqTable @a) (eqTable @b))
197instance (OrdTable a, OrdTable b) => OrdTable (TheseTable a b) where
198 ordTable =
199 toColumns2 (hlabel hlabeler) (hlabel hlabeler)
200 (thoseTable (ordTable @a) (ordTable @b))
203toHereTag :: Tag "isJust" a -> Tag "hasHere" a
204toHereTag Tag {..} = Tag {..}
207toThereTag :: Tag "isJust" a -> Tag "hasThere" a
208toThereTag Tag {..} = Tag {..}
211isThisTable :: TheseTable a b -> Expr Bool
212isThisTable a = hasHereTable a &&. not_ (hasThereTable a)
215isThatTable :: TheseTable a b -> Expr Bool
216isThatTable a = not_ (hasHereTable a) &&. hasThereTable a
219isThoseTable :: TheseTable a b -> Expr Bool
220isThoseTable a = hasHereTable a &&. hasThereTable a
223hasHereTable :: TheseTable a b -> Expr Bool
224hasHereTable TheseTable {here} = isJustTable here
227hasThereTable :: TheseTable a b -> Expr Bool
228hasThereTable TheseTable {there} = isJustTable there
231justHereTable :: TheseTable a b -> MaybeTable a
232justHereTable = here
235justThereTable :: TheseTable a b -> MaybeTable b
236justThereTable = there
239thisTable :: Table Expr b => a -> TheseTable a b
240thisTable a = TheseTable (justTable a) nothingTable
243thatTable :: Table Expr a => b -> TheseTable a b
244thatTable b = TheseTable nothingTable (justTable b)
247thoseTable :: a -> b -> TheseTable a b
248thoseTable a b = TheseTable (justTable a) (justTable b)
251theseTable :: Table Expr c
252 => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable a b -> c
253theseTable f g h TheseTable {here, there} =
254 maybeTable
255 (maybeTable undefined f here)
256 (\b -> maybeTable (g b) (`h` b) here)
257 there
260aggregateTheseTable :: ()
261 => (a -> Aggregate c)
262 -> (b -> Aggregate d)
263 -> TheseTable a b
264 -> Aggregate (TheseTable c d)
265aggregateTheseTable f g TheseTable {here, there} =
266 liftF2 TheseTable (aggregateMaybeTable f here) (aggregateMaybeTable g there)
269nameTheseTable :: ()
270 => Name (Maybe MaybeTag)
271 -> Name (Maybe MaybeTag)
272 -> a
273 -> b
274 -> TheseTable a b
275nameTheseTable here there a b =
276 TheseTable
277 { here = nameMaybeTable here a
278 , there = nameMaybeTable there b
279 }