git.iko.soy/rel8
on f3daaff help sign in
rel8/src/Rel8/Table/These.hs
232 lines 6.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 StandaloneKindSignatures #-}
9{-# language TupleSections #-}
10{-# language TypeFamilies #-}
11{-# language UndecidableInstances #-}
13module Rel8.Table.These
14 ( TheseTable(..)
15 , theseTable, thisTable, thatTable, thoseTable
16 , isThisTable, isThatTable, isThoseTable
17 , hasHereTable, hasThereTable
18 , justHereTable, justThereTable
19 )
20where
22-- base
23import Data.Bifunctor ( Bifunctor, bimap )
24import Data.Functor.Identity ( runIdentity )
25import Data.Kind ( Type )
26import Prelude hiding ( undefined )
28-- rel8
29import Rel8.Expr ( Expr )
30import Rel8.Expr.Bool ( (&&.), not_ )
31import Rel8.Expr.Null ( isNonNull )
32import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
33import Rel8.Schema.Context.Nullify
34 ( Nullifiable, NullifiableEq
35 , encodeTag, decodeTag
36 , nullifier, unnullifier
37 )
38import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
39import Rel8.Schema.HTable.Identity ( HIdentity(..) )
40import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
41import Rel8.Schema.HTable.These ( HTheseTable(..) )
42import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
43import Rel8.Table.Lifted
44 ( Table1, Columns1, ConstrainContext1, fromColumns1, toColumns1
45 , Table2, Columns2, ConstrainContext2, fromColumns2, toColumns2
46 )
47import Rel8.Table.Maybe
48 ( MaybeTable(..)
49 , maybeTable, justTable, nothingTable
50 , isJustTable
51 )
52import Rel8.Table.Recontextualize ( Recontextualize )
53import Rel8.Table.Undefined ( undefined )
55-- semigroupoids
56import Data.Functor.Apply ( Apply, (<.>) )
57import Data.Functor.Bind ( Bind, (>>-) )
60type TheseTable :: Type -> Type -> Type
61data TheseTable a b = TheseTable
62 { here :: MaybeTable a
63 , there :: MaybeTable b
64 }
65 deriving stock (Show, Functor)
68instance Bifunctor TheseTable where
69 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)
72instance (Table Expr a, Semigroup a) => Apply (TheseTable a) where
73 fs <.> as = TheseTable
74 { here = here fs <> here as
75 , there = there fs <.> there as
76 }
79instance (Table Expr a, Semigroup a) => Applicative (TheseTable a)
80 where
81 pure = thatTable
82 (<*>) = (<.>)
85instance (Table Expr a, Semigroup a) => Bind (TheseTable a) where
86 TheseTable here1 ma >>- f = case ma >>- f' of
87 mtb -> TheseTable
88 { here = maybeTable here1 ((here1 <>) . fst) mtb
89 , there = snd <$> mtb
90 }
91 where
92 f' a = case f a of
93 TheseTable here2 mb -> (here2,) <$> mb
96instance (Table Expr a, Semigroup a) => Monad (TheseTable a) where
97 (>>=) = (>>-)
100instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
101 Semigroup (TheseTable a b)
102 where
103 a <> b = TheseTable
104 { here = here a <> here b
105 , there = there a <> there b
106 }
109instance Table2 TheseTable where
110 type Columns2 TheseTable = HTheseTable
111 type ConstrainContext2 TheseTable = Nullifiable
113 toColumns2 f g TheseTable {here, there} = HTheseTable
114 { hhereTag = HIdentity $ encodeTag (tag here)
115 , hhere = hnullify (nullifier (isNonNull (tag here))) $ f (just here)
116 , hthereTag = HIdentity $ encodeTag (tag there)
117 , hthere = hnullify (nullifier (isNonNull (tag there))) $ g (just there)
118 }
120 fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} =
121 TheseTable
122 { here =
123 let
124 tag = decodeTag $ unHIdentity hhereTag
125 in
126 MaybeTable
127 { tag
128 , just = f $
129 runIdentity $
130 hunnullify (\a -> pure . unnullifier (isNonNull tag) a)
131 hhere
132 }
133 , there =
134 let
135 tag = decodeTag $ unHIdentity hthereTag
136 in
137 MaybeTable
138 { tag
139 , just = g $
140 runIdentity $
141 hunnullify (\a -> pure . unnullifier (isNonNull tag) a)
142 hthere
143 }
144 }
146 {-# INLINABLE fromColumns2 #-}
147 {-# INLINABLE toColumns2 #-}
150instance Table context a => Table1 (TheseTable a) where
151 type Columns1 (TheseTable a) = HTheseTable (Columns a)
152 type ConstrainContext1 (TheseTable a) = NullifiableEq (Context a)
154 toColumns1 = toColumns2 toColumns
155 fromColumns1 = fromColumns2 fromColumns
158instance
159 ( Table context a, Table context b
160 , Labelable context, Nullifiable context
161 ) => Table context (TheseTable a b)
162 where
163 type Columns (TheseTable a b) =
164 HTheseTable (HLabel "Here" (Columns a)) (HLabel "There" (Columns b))
165 type Context (TheseTable a b) = Context a
167 toColumns =
168 toColumns2
169 (hlabel labeler . toColumns)
170 (hlabel labeler . toColumns)
171 fromColumns =
172 fromColumns2
173 (fromColumns . hunlabel unlabeler)
174 (fromColumns . hunlabel unlabeler)
177instance
178 ( Labelable from, Nullifiable from
179 , Labelable to, Nullifiable to
180 , Recontextualize from to a1 b1
181 , Recontextualize from to a2 b2
182 ) =>
183 Recontextualize from to (TheseTable a1 a2) (TheseTable b1 b2)
186isThisTable :: TheseTable a b -> Expr Bool
187isThisTable a = hasHereTable a &&. not_ (hasThereTable a)
190isThatTable :: TheseTable a b -> Expr Bool
191isThatTable a = not_ (hasHereTable a) &&. hasThereTable a
194isThoseTable :: TheseTable a b -> Expr Bool
195isThoseTable a = hasHereTable a &&. hasThereTable a
198hasHereTable :: TheseTable a b -> Expr Bool
199hasHereTable TheseTable {here} = isJustTable here
202hasThereTable :: TheseTable a b -> Expr Bool
203hasThereTable TheseTable {there} = isJustTable there
206justHereTable :: TheseTable a b -> MaybeTable a
207justHereTable = here
210justThereTable :: TheseTable a b -> MaybeTable b
211justThereTable = there
214thisTable :: Table Expr b => a -> TheseTable a b
215thisTable a = TheseTable (justTable a) nothingTable
218thatTable :: Table Expr a => b -> TheseTable a b
219thatTable b = TheseTable nothingTable (justTable b)
222thoseTable :: a -> b -> TheseTable a b
223thoseTable a b = TheseTable (justTable a) (justTable b)
226theseTable :: Table Expr c
227 => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable a b -> c
228theseTable f g h TheseTable {here, there} =
229 maybeTable
230 (maybeTable undefined f here)
231 (\b -> maybeTable (g b) (`h` b) here)
232 there