git.iko.soy/rel8
on 00a36f5 help sign in
rel8/src/Rel8/Schema/Context/Identity.hs
198 lines 6.2 kB history raw
1{-# language DataKinds #-}
2{-# language DisambiguateRecordFields #-}
3{-# language NamedFieldPuns #-}
4{-# language TypeFamilies #-}
6module Rel8.Schema.Context.Identity
7 ( fromHEitherTable, toHEitherTable
8 , fromHListTable, toHListTable
9 , fromHMaybeTable, toHMaybeTable
10 , fromHNonEmptyTable, toHNonEmptyTable
11 , fromHTheseTable, toHTheseTable
12 )
13where
15-- base
16import Data.Functor ( ($>) )
17import Data.Functor.Identity ( Identity )
18import Data.List.NonEmpty ( NonEmpty )
19import Prelude hiding ( null )
21-- rel8
22import Rel8.Schema.Context ( Col, Col'( Result ) )
23import Rel8.Schema.HTable ( HTable )
24import Rel8.Schema.HTable.Either ( HEitherTable(..) )
25import Rel8.Schema.HTable.Identity ( HIdentity(..) )
26import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
27import Rel8.Schema.HTable.List ( HListTable )
28import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
29import Rel8.Schema.HTable.Nullify ( hnulls, hnullify, hunnullify )
30import Rel8.Schema.HTable.These ( HTheseTable(..) )
31import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize )
32import Rel8.Schema.Nullability
33 ( Nullability( Nullable, NonNullable )
34 )
35import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
36import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) )
38-- these
39import Data.These ( These( This, That, These ) )
40import Data.These.Combinators ( justHere, justThere )
43toHEitherTable :: (HTable t, HTable u)
44 => Either (t (Col Identity)) (u (Col Identity))
45 -> HEitherTable t u (Col Identity)
46toHEitherTable = either hleft hright
47 where
48 hleft table = HEitherTable
49 { htag = HIdentity (Result IsLeft)
50 , hleft = hnullify nullifier table
51 , hright = hnulls null
52 }
53 hright table = HEitherTable
54 { htag = HIdentity (Result IsRight)
55 , hleft = hnulls null
56 , hright = hnullify nullifier table
57 }
58{-# INLINABLE toHEitherTable #-}
61fromHEitherTable :: (HTable t, HTable u)
62 => HEitherTable t u (Col Identity)
63 -> Either (t (Col Identity)) (u (Col Identity))
64fromHEitherTable HEitherTable {htag, hleft, hright} = case htag of
65 HIdentity (Result tag) -> case tag of
66 IsLeft -> maybe err Left $ hunnullify unnullifier hleft
67 IsRight -> maybe err Right $ hunnullify unnullifier hright
68 where
69 err = error "fromHEitherTable: mismatch between tag and data"
70{-# INLINABLE fromHEitherTable #-}
73toHListTable :: HTable t => [t (Col Identity)] -> HListTable t (Col Identity)
74toHListTable = hvectorize vectorizer
75{-# INLINABLE toHListTable #-}
78fromHListTable :: HTable t => HListTable t (Col Identity) -> [t (Col Identity)]
79fromHListTable = hunvectorize unvectorizer
80{-# INLINABLE fromHListTable #-}
83toHMaybeTable :: HTable t => Maybe (t (Col Identity)) -> HMaybeTable t (Col Identity)
84toHMaybeTable = maybe hnothing hjust
85 where
86 hnothing = HMaybeTable
87 { htag = HIdentity (Result Nothing)
88 , hjust = hnulls null
89 }
90 hjust table = HMaybeTable
91 { htag = HIdentity (Result (Just IsJust))
92 , hjust = hnullify nullifier table
93 }
94{-# INLINABLE toHMaybeTable #-}
97fromHMaybeTable :: HTable t => HMaybeTable t (Col Identity) -> Maybe (t (Col Identity))
98fromHMaybeTable HMaybeTable {htag, hjust} = case htag of
99 HIdentity (Result tag) -> tag $>
100 case hunnullify unnullifier hjust of
101 Nothing -> error "fromHMaybeTable: mismatch between tag and data"
102 Just just -> just
103{-# INLINABLE fromHMaybeTable #-}
106toHNonEmptyTable :: HTable t => NonEmpty (t (Col Identity)) -> HNonEmptyTable t (Col Identity)
107toHNonEmptyTable = hvectorize vectorizer
108{-# INLINABLE toHNonEmptyTable #-}
111fromHNonEmptyTable :: HTable t => HNonEmptyTable t (Col Identity) -> NonEmpty (t (Col Identity))
112fromHNonEmptyTable = hunvectorize unvectorizer
113{-# INLINABLE fromHNonEmptyTable #-}
116toHTheseTable :: (HTable t, HTable u)
117 => These (t (Col Identity)) (u (Col Identity))
118 -> HTheseTable t u (Col Identity)
119toHTheseTable tables = HTheseTable
120 { hhereTag = relabel hhereTag
121 , hhere
122 , hthereTag = relabel hthereTag
123 , hthere
124 }
125 where
126 HMaybeTable
127 { htag = hhereTag
128 , hjust = hhere
129 } = toHMaybeTable (justHere tables)
130 HMaybeTable
131 { htag = hthereTag
132 , hjust = hthere
133 } = toHMaybeTable (justThere tables)
134{-# INLINABLE toHTheseTable #-}
137fromHTheseTable :: (HTable t, HTable u)
138 => HTheseTable t u (Col Identity)
139 -> These (t (Col Identity)) (u (Col Identity))
140fromHTheseTable HTheseTable {hhereTag, hhere, hthereTag, hthere} =
141 case (fromHMaybeTable mhere, fromHMaybeTable mthere) of
142 (Just a, Nothing) -> This a
143 (Nothing, Just b) -> That b
144 (Just a, Just b) -> These a b
145 _ -> error "fromHTheseTable: mismatch between tags and data"
146 where
147 mhere = HMaybeTable
148 { htag = relabel hhereTag
149 , hjust = hhere
150 }
151 mthere = HMaybeTable
152 { htag = relabel hthereTag
153 , hjust = hthere
154 }
155{-# INLINABLE fromHTheseTable #-}
158null :: Col Identity ('Spec labels necessity db (Maybe db))
159null = Result Nothing
162nullifier :: ()
163 => SSpec ('Spec labels necessity db a)
164 -> Col Identity ('Spec labels necessity db a)
165 -> Col Identity ('Spec labels necessity db (Maybe db))
166nullifier SSpec {nullability} (Result a) = Result $ case nullability of
167 Nullable -> a
168 NonNullable -> Just a
171unnullifier :: ()
172 => SSpec ('Spec labels necessity db a)
173 -> Col Identity ('Spec labels necessity db (Maybe db))
174 -> Maybe (Col Identity ('Spec labels necessity db a))
175unnullifier SSpec {nullability} (Result a) =
176 case nullability of
177 Nullable -> pure $ Result a
178 NonNullable -> Result <$> a
181vectorizer :: Functor f
182 => SSpec ('Spec labels necessity db a)
183 -> f (Col Identity ('Spec labels necessity db a))
184 -> Col Identity ('Spec labels necessity (f a) (f a))
185vectorizer _ = Result . fmap (\(Result a) -> a)
188unvectorizer :: Functor f
189 => SSpec ('Spec labels necessity db a)
190 -> Col Identity ('Spec labels necessity (f a) (f a))
191 -> f (Col Identity ('Spec labels necessity db a))
192unvectorizer _ (Result results) = Result <$> results
195relabel :: ()
196 => HIdentity ('Spec labels necessity db a) (Col Identity)
197 -> HIdentity ('Spec relabels necessity db a) (Col Identity)
198relabel (HIdentity (Result a)) = HIdentity (Result a)