git.iko.soy/rel8
on 11bcbbb help sign in
rel8/src/Rel8/Schema/Context/Identity.hs
199 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( 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 ( Nullify
34 , Nullability( Nullable, NonNullable )
35 )
36import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
37import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) )
39-- these
40import Data.These ( These( This, That, These ) )
41import Data.These.Combinators ( justHere, justThere )
44toHEitherTable :: (HTable t, HTable u)
45 => Either (t (Col Identity)) (u (Col Identity))
46 -> HEitherTable t u (Col Identity)
47toHEitherTable = either hleft hright
48 where
49 hleft table = HEitherTable
50 { htag = HIdentity (Result IsLeft)
51 , hleft = hnullify nullifier table
52 , hright = hnulls null
53 }
54 hright table = HEitherTable
55 { htag = HIdentity (Result IsRight)
56 , hleft = hnulls null
57 , hright = hnullify nullifier table
58 }
59{-# INLINABLE toHEitherTable #-}
62fromHEitherTable :: (HTable t, HTable u)
63 => HEitherTable t u (Col Identity)
64 -> Either (t (Col Identity)) (u (Col Identity))
65fromHEitherTable HEitherTable {htag, hleft, hright} = case htag of
66 HIdentity (Result tag) -> case tag of
67 IsLeft -> maybe err Left $ hunnullify unnullifier hleft
68 IsRight -> maybe err Right $ hunnullify unnullifier hright
69 where
70 err = error "fromHEitherTable: mismatch between tag and data"
71{-# INLINABLE fromHEitherTable #-}
74toHListTable :: HTable t => [t (Col Identity)] -> HListTable t (Col Identity)
75toHListTable = hvectorize vectorizer
76{-# INLINABLE toHListTable #-}
79fromHListTable :: HTable t => HListTable t (Col Identity) -> [t (Col Identity)]
80fromHListTable = hunvectorize unvectorizer
81{-# INLINABLE fromHListTable #-}
84toHMaybeTable :: HTable t => Maybe (t (Col Identity)) -> HMaybeTable t (Col Identity)
85toHMaybeTable = maybe hnothing hjust
86 where
87 hnothing = HMaybeTable
88 { htag = HIdentity (Result Nothing)
89 , hjust = hnulls null
90 }
91 hjust table = HMaybeTable
92 { htag = HIdentity (Result (Just IsJust))
93 , hjust = hnullify nullifier table
94 }
95{-# INLINABLE toHMaybeTable #-}
98fromHMaybeTable :: HTable t => HMaybeTable t (Col Identity) -> Maybe (t (Col Identity))
99fromHMaybeTable HMaybeTable {htag, hjust} = case htag of
100 HIdentity (Result tag) -> tag $>
101 case hunnullify unnullifier hjust of
102 Nothing -> error "fromHMaybeTable: mismatch between tag and data"
103 Just just -> just
104{-# INLINABLE fromHMaybeTable #-}
107toHNonEmptyTable :: HTable t => NonEmpty (t (Col Identity)) -> HNonEmptyTable t (Col Identity)
108toHNonEmptyTable = hvectorize vectorizer
109{-# INLINABLE toHNonEmptyTable #-}
112fromHNonEmptyTable :: HTable t => HNonEmptyTable t (Col Identity) -> NonEmpty (t (Col Identity))
113fromHNonEmptyTable = hunvectorize unvectorizer
114{-# INLINABLE fromHNonEmptyTable #-}
117toHTheseTable :: (HTable t, HTable u)
118 => These (t (Col Identity)) (u (Col Identity))
119 -> HTheseTable t u (Col Identity)
120toHTheseTable tables = HTheseTable
121 { hhereTag = relabel hhereTag
122 , hhere
123 , hthereTag = relabel hthereTag
124 , hthere
125 }
126 where
127 HMaybeTable
128 { htag = hhereTag
129 , hjust = hhere
130 } = toHMaybeTable (justHere tables)
131 HMaybeTable
132 { htag = hthereTag
133 , hjust = hthere
134 } = toHMaybeTable (justThere tables)
135{-# INLINABLE toHTheseTable #-}
138fromHTheseTable :: (HTable t, HTable u)
139 => HTheseTable t u (Col Identity)
140 -> These (t (Col Identity)) (u (Col Identity))
141fromHTheseTable HTheseTable {hhereTag, hhere, hthereTag, hthere} =
142 case (fromHMaybeTable mhere, fromHMaybeTable mthere) of
143 (Just a, Nothing) -> This a
144 (Nothing, Just b) -> That b
145 (Just a, Just b) -> These a b
146 _ -> error "fromHTheseTable: mismatch between tags and data"
147 where
148 mhere = HMaybeTable
149 { htag = relabel hhereTag
150 , hjust = hhere
151 }
152 mthere = HMaybeTable
153 { htag = relabel hthereTag
154 , hjust = hthere
155 }
156{-# INLINABLE fromHTheseTable #-}
159null :: Col Identity ('Spec labels necessity (Maybe a))
160null = Result Nothing
163nullifier :: ()
164 => SSpec ('Spec labels necessity a)
165 -> Col Identity ('Spec labels necessity a)
166 -> Col Identity ('Spec labels necessity (Nullify a))
167nullifier SSpec {nullability} (Result a) = Result $ case nullability of
168 Nullable -> a
169 NonNullable -> Just a
172unnullifier :: ()
173 => SSpec ('Spec labels necessity a)
174 -> Col Identity ('Spec labels necessity (Nullify a))
175 -> Maybe (Col Identity ('Spec labels necessity a))
176unnullifier SSpec {nullability} (Result a) =
177 case nullability of
178 Nullable -> pure $ Result a
179 NonNullable -> Result <$> a
182vectorizer :: Functor f
183 => SSpec ('Spec labels necessity a)
184 -> f (Col Identity ('Spec labels necessity a))
185 -> Col Identity ('Spec labels necessity (f a))
186vectorizer _ = Result . fmap (\(Result a) -> a)
189unvectorizer :: Functor f
190 => SSpec ('Spec labels necessity a)
191 -> Col Identity ('Spec labels necessity (f a))
192 -> f (Col Identity ('Spec labels necessity a))
193unvectorizer _ (Result results) = Result <$> results
196relabel :: ()
197 => HIdentity ('Spec labels necessity a) (Col Identity)
198 -> HIdentity ('Spec relabels necessity a) (Col Identity)
199relabel (HIdentity (Result a)) = HIdentity (Result a)