git.iko.soy/rel8
on 88e6ea5 help sign in
rel8/src/Rel8/Table/These.hs
233 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 ( DB )
33import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
34import Rel8.Schema.Context.Nullify
35 ( Nullifiable, NullifiableEq
36 , encodeTag, decodeTag
37 , nullifier, unnullifier
38 )
39import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
40import Rel8.Schema.HTable.Identity ( HIdentity(..) )
41import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
42import Rel8.Schema.HTable.These ( HTheseTable(..) )
43import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
44import Rel8.Table.Lifted
45 ( Table1, Columns1, ConstrainContext1, fromColumns1, toColumns1
46 , Table2, Columns2, ConstrainContext2, fromColumns2, toColumns2
47 )
48import Rel8.Table.Maybe
49 ( MaybeTable(..)
50 , maybeTable, justTable, nothingTable
51 , isJustTable
52 )
53import Rel8.Table.Recontextualize ( Recontextualize )
54import Rel8.Table.Undefined ( undefined )
56-- semigroupoids
57import Data.Functor.Apply ( Apply, (<.>) )
58import Data.Functor.Bind ( Bind, (>>-) )
61type TheseTable :: Type -> Type -> Type
62data TheseTable a b = TheseTable
63 { here :: MaybeTable a
64 , there :: MaybeTable b
65 }
66 deriving stock (Show, Functor)
69instance Bifunctor TheseTable where
70 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)
73instance (Table DB a, Semigroup a) => Apply (TheseTable a) where
74 fs <.> as = TheseTable
75 { here = here fs <> here as
76 , there = there fs <.> there as
77 }
80instance (Table DB a, Semigroup a) => Applicative (TheseTable a)
81 where
82 pure = thatTable
83 (<*>) = (<.>)
86instance (Table DB a, Semigroup a) => Bind (TheseTable a) where
87 TheseTable here1 ma >>- f = case ma >>- f' of
88 mtb -> TheseTable
89 { here = maybeTable here1 ((here1 <>) . fst) mtb
90 , there = snd <$> mtb
91 }
92 where
93 f' a = case f a of
94 TheseTable here2 mb -> (here2,) <$> mb
97instance (Table DB a, Semigroup a) => Monad (TheseTable a) where
98 (>>=) = (>>-)
101instance (Table DB a, Table DB b, Semigroup a, Semigroup b) =>
102 Semigroup (TheseTable a b)
103 where
104 a <> b = TheseTable
105 { here = here a <> here b
106 , there = there a <> there b
107 }
110instance Table2 TheseTable where
111 type Columns2 TheseTable = HTheseTable
112 type ConstrainContext2 TheseTable = Nullifiable
114 toColumns2 f g TheseTable {here, there} = HTheseTable
115 { hhereTag = HIdentity $ encodeTag (tag here)
116 , hhere = hnullify (nullifier (isNonNull (tag here))) $ f (just here)
117 , hthereTag = HIdentity $ encodeTag (tag there)
118 , hthere = hnullify (nullifier (isNonNull (tag there))) $ g (just there)
119 }
121 fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} =
122 TheseTable
123 { here =
124 let
125 tag = decodeTag $ unHIdentity hhereTag
126 in
127 MaybeTable
128 { tag
129 , just = f $
130 runIdentity $
131 hunnullify (\a -> pure . unnullifier (isNonNull tag) a)
132 hhere
133 }
134 , there =
135 let
136 tag = decodeTag $ unHIdentity hthereTag
137 in
138 MaybeTable
139 { tag
140 , just = g $
141 runIdentity $
142 hunnullify (\a -> pure . unnullifier (isNonNull tag) a)
143 hthere
144 }
145 }
147 {-# INLINABLE fromColumns2 #-}
148 {-# INLINABLE toColumns2 #-}
151instance Table context a => Table1 (TheseTable a) where
152 type Columns1 (TheseTable a) = HTheseTable (Columns a)
153 type ConstrainContext1 (TheseTable a) = NullifiableEq (Context a)
155 toColumns1 = toColumns2 toColumns
156 fromColumns1 = fromColumns2 fromColumns
159instance
160 ( Table context a, Table context b
161 , Labelable context, Nullifiable context
162 ) => Table context (TheseTable a b)
163 where
164 type Columns (TheseTable a b) =
165 HTheseTable (HLabel "Here" (Columns a)) (HLabel "There" (Columns b))
166 type Context (TheseTable a b) = Context a
168 toColumns =
169 toColumns2
170 (hlabel labeler . toColumns)
171 (hlabel labeler . toColumns)
172 fromColumns =
173 fromColumns2
174 (fromColumns . hunlabel unlabeler)
175 (fromColumns . hunlabel unlabeler)
178instance
179 ( Labelable from, Nullifiable from
180 , Labelable to, Nullifiable to
181 , Recontextualize from to a1 b1
182 , Recontextualize from to a2 b2
183 ) =>
184 Recontextualize from to (TheseTable a1 a2) (TheseTable b1 b2)
187isThisTable :: TheseTable a b -> Expr Bool
188isThisTable a = hasHereTable a &&. not_ (hasThereTable a)
191isThatTable :: TheseTable a b -> Expr Bool
192isThatTable a = not_ (hasHereTable a) &&. hasThereTable a
195isThoseTable :: TheseTable a b -> Expr Bool
196isThoseTable a = hasHereTable a &&. hasThereTable a
199hasHereTable :: TheseTable a b -> Expr Bool
200hasHereTable TheseTable {here} = isJustTable here
203hasThereTable :: TheseTable a b -> Expr Bool
204hasThereTable TheseTable {there} = isJustTable there
207justHereTable :: TheseTable a b -> MaybeTable a
208justHereTable = here
211justThereTable :: TheseTable a b -> MaybeTable b
212justThereTable = there
215thisTable :: Table DB b => a -> TheseTable a b
216thisTable a = TheseTable (justTable a) nothingTable
219thatTable :: Table DB a => b -> TheseTable a b
220thatTable b = TheseTable nothingTable (justTable b)
223thoseTable :: a -> b -> TheseTable a b
224thoseTable a b = TheseTable (justTable a) (justTable b)
227theseTable :: Table DB c
228 => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable a b -> c
229theseTable f g h TheseTable {here, there} =
230 maybeTable
231 (maybeTable undefined f here)
232 (\b -> maybeTable (g b) (`h` b) here)
233 there