git.iko.soy/rel8
on 20ddd83 help sign in
rel8/src/Rel8/Table/These.hs
241 lines 6.7 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 TupleSections #-}
11{-# language TypeApplications #-}
12{-# language TypeFamilies #-}
13{-# language UndecidableInstances #-}
15module Rel8.Table.These
16 ( TheseTable(..)
17 , theseTable, thisTable, thatTable, thoseTable
18 , isThisTable, isThatTable, isThoseTable
19 , hasHereTable, hasThereTable
20 , justHereTable, justThereTable
21 )
22where
24-- base
25import Data.Bifunctor ( Bifunctor, bimap )
26import Data.Functor.Identity ( runIdentity )
27import Data.Kind ( Type )
28import Prelude hiding ( undefined )
30-- rel8
31import Rel8.Expr ( Expr )
32import Rel8.Expr.Bool ( (&&.), not_ )
33import Rel8.Expr.Null ( isNonNull )
34import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler, hlabeler )
35import Rel8.Schema.Context.Nullify
36 ( Nullifiable, ConstrainTag
37 , hencodeTag, hdecodeTag
38 , hnullifier, hunnullifier
39 )
40import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
41import Rel8.Schema.HTable.Identity ( HIdentity(..) )
42import Rel8.Schema.HTable.Maybe ( HMaybeNullifiable )
43import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
44import Rel8.Schema.HTable.These ( HTheseTable(..) )
45import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
46import Rel8.Table.Eq ( EqTable, eqTable )
47import Rel8.Table.Lifted
48 ( Table2, Columns2, ConstrainHContext2, fromColumns2, toColumns2
49 )
50import Rel8.Table.Maybe
51 ( MaybeTable(..)
52 , maybeTable, justTable, nothingTable
53 , isJustTable
54 )
55import Rel8.Table.Ord ( OrdTable, ordTable )
56import Rel8.Table.Recontextualize ( Recontextualize )
57import Rel8.Table.Undefined ( undefined )
58import Rel8.Type.Tag ( MaybeTag )
60-- semigroupoids
61import Data.Functor.Apply ( Apply, (<.>) )
62import Data.Functor.Bind ( Bind, (>>-) )
65type TheseTable :: Type -> Type -> Type
66data TheseTable a b = TheseTable
67 { here :: MaybeTable a
68 , there :: MaybeTable b
69 }
70 deriving stock (Show, Functor)
73instance Bifunctor TheseTable where
74 bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)
77instance (Table Expr a, Semigroup a) => Apply (TheseTable a) where
78 fs <.> as = TheseTable
79 { here = here fs <> here as
80 , there = there fs <.> there as
81 }
84instance (Table Expr a, Semigroup a) => Applicative (TheseTable a)
85 where
86 pure = thatTable
87 (<*>) = (<.>)
90instance (Table Expr a, Semigroup a) => Bind (TheseTable a) where
91 TheseTable here1 ma >>- f = case ma >>- f' of
92 mtb -> TheseTable
93 { here = maybeTable here1 ((here1 <>) . fst) mtb
94 , there = snd <$> mtb
95 }
96 where
97 f' a = case f a of
98 TheseTable here2 mb -> (here2,) <$> mb
101instance (Table Expr a, Semigroup a) => Monad (TheseTable a) where
102 (>>=) = (>>-)
105instance (Table Expr a, Table Expr b, Semigroup a, Semigroup b) =>
106 Semigroup (TheseTable a b)
107 where
108 a <> b = TheseTable
109 { here = here a <> here b
110 , there = there a <> there b
111 }
114instance Table2 TheseTable where
115 type Columns2 TheseTable = HTheseTable
116 type ConstrainHContext2 TheseTable = HMaybeNullifiable
118 toColumns2 f g TheseTable {here, there} = HTheseTable
119 { hhereTag = HIdentity $ hencodeTag (tag here)
120 , hhere = hnullify (hnullifier (isNonNull (tag here))) $ f (just here)
121 , hthereTag = HIdentity $ hencodeTag (tag there)
122 , hthere = hnullify (hnullifier (isNonNull (tag there))) $ g (just there)
123 }
125 fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} =
126 TheseTable
127 { here =
128 let
129 tag = hdecodeTag $ unHIdentity hhereTag
130 in
131 MaybeTable
132 { tag
133 , just = f $
134 runIdentity $
135 hunnullify (\a -> pure . hunnullifier (isNonNull tag) a)
136 hhere
137 }
138 , there =
139 let
140 tag = hdecodeTag $ unHIdentity hthereTag
141 in
142 MaybeTable
143 { tag
144 , just = g $
145 runIdentity $
146 hunnullify (\a -> pure . hunnullifier (isNonNull tag) a)
147 hthere
148 }
149 }
151 {-# INLINABLE fromColumns2 #-}
152 {-# INLINABLE toColumns2 #-}
155instance
156 ( Table context a, Table context b
157 , Labelable context, Nullifiable context, ConstrainTag context MaybeTag
158 ) => Table context (TheseTable a b)
159 where
160 type Columns (TheseTable a b) =
161 HTheseTable (HLabel "Here" (Columns a)) (HLabel "There" (Columns b))
162 type Context (TheseTable a b) = Context a
164 toColumns =
165 toColumns2
166 (hlabel labeler . toColumns)
167 (hlabel labeler . toColumns)
168 fromColumns =
169 fromColumns2
170 (fromColumns . hunlabel unlabeler)
171 (fromColumns . hunlabel unlabeler)
174instance
175 ( Labelable from, Nullifiable from, ConstrainTag from MaybeTag
176 , Labelable to, Nullifiable to, ConstrainTag to MaybeTag
177 , Recontextualize from to a1 b1
178 , Recontextualize from to a2 b2
179 ) =>
180 Recontextualize from to (TheseTable a1 a2) (TheseTable b1 b2)
183instance (EqTable a, EqTable b) => EqTable (TheseTable a b) where
184 eqTable =
185 toColumns2 (hlabel hlabeler) (hlabel hlabeler)
186 (thoseTable (eqTable @a) (eqTable @b))
189instance (OrdTable a, OrdTable b) => OrdTable (TheseTable a b) where
190 ordTable =
191 toColumns2 (hlabel hlabeler) (hlabel hlabeler)
192 (thoseTable (ordTable @a) (ordTable @b))
195isThisTable :: TheseTable a b -> Expr Bool
196isThisTable a = hasHereTable a &&. not_ (hasThereTable a)
199isThatTable :: TheseTable a b -> Expr Bool
200isThatTable a = not_ (hasHereTable a) &&. hasThereTable a
203isThoseTable :: TheseTable a b -> Expr Bool
204isThoseTable a = hasHereTable a &&. hasThereTable a
207hasHereTable :: TheseTable a b -> Expr Bool
208hasHereTable TheseTable {here} = isJustTable here
211hasThereTable :: TheseTable a b -> Expr Bool
212hasThereTable TheseTable {there} = isJustTable there
215justHereTable :: TheseTable a b -> MaybeTable a
216justHereTable = here
219justThereTable :: TheseTable a b -> MaybeTable b
220justThereTable = there
223thisTable :: Table Expr b => a -> TheseTable a b
224thisTable a = TheseTable (justTable a) nothingTable
227thatTable :: Table Expr a => b -> TheseTable a b
228thatTable b = TheseTable nothingTable (justTable b)
231thoseTable :: a -> b -> TheseTable a b
232thoseTable a b = TheseTable (justTable a) (justTable b)
235theseTable :: Table Expr c
236 => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable a b -> c
237theseTable f g h TheseTable {here, there} =
238 maybeTable
239 (maybeTable undefined f here)
240 (\b -> maybeTable (g b) (`h` b) here)
241 there