git.iko.soy/rel8
on f47423e help sign in
rel8/src/Rel8/Generic/Table/ADT.hs
223 lines 7.1 kB history raw
1{-# language AllowAmbiguousTypes #-}
2{-# language DataKinds #-}
3{-# language FlexibleInstances #-}
4{-# language LambdaCase #-}
5{-# language MultiParamTypeClasses #-}
6{-# language RankNTypes #-}
7{-# language ScopedTypeVariables #-}
8{-# language StandaloneKindSignatures #-}
9{-# language TypeApplications #-}
10{-# language TypeFamilies #-}
11{-# language TypeOperators #-}
12{-# language UndecidableInstances #-}
14module Rel8.Generic.Table.ADT
15 ( GTableADT, GColumnsADT, gfromResultADT, gtoResultADT
16 , GTableADT', GColumnsADT'
17 )
18where
20-- base
21import Data.Functor.Identity ( Identity( Identity ) )
22import Data.Kind ( Constraint, Type )
23import Data.Proxy ( Proxy( Proxy ) )
24import GHC.Generics
25 ( (:+:)( L1, R1 ), M1( M1 ), U1( U1 )
26 , C, D
27 , Meta( MetaCons )
28 )
29import GHC.TypeLits ( KnownSymbol, symbolVal )
30import Prelude hiding ( null )
32-- rel8
33import Rel8.FCF ( Eval, Exp )
34import Rel8.Generic.Map ( GMap )
35import Rel8.Generic.Table.Record ( GTable, GColumns, gfromResult, gtoResult )
36import Rel8.Schema.HTable ( HTable )
37import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
38import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
39import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify )
40import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )
41import qualified Rel8.Schema.Kind as K
42import Rel8.Schema.Result ( Result, null, nullifier, unnullifier )
43import Rel8.Type.Tag ( Tag( Tag ) )
45-- text
46import Data.Text ( pack )
49type GColumnsADT
50 :: (Type -> Exp K.HTable)
51 -> (Type -> Type) -> K.HTable
52type family GColumnsADT _Columns rep where
53 GColumnsADT _Columns (M1 D _ rep) =
54 GColumnsADT' _Columns (HLabel "tag" (HIdentity Tag)) rep
57type GColumnsADT'
58 :: (Type -> Exp K.HTable)
59 -> K.HTable -> (Type -> Type) -> K.HTable
60type family GColumnsADT' _Columns htable rep where
61 GColumnsADT' _Columns htable (a :+: b) =
62 GColumnsADT' _Columns (GColumnsADT' _Columns htable a) b
63 GColumnsADT' _Columns htable (M1 C ('MetaCons _ _ _) U1) = htable
64 GColumnsADT' _Columns htable (M1 C ('MetaCons label _ _) rep) =
65 HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))
68type GTableADT
69 :: (Type -> Exp Constraint)
70 -> (Type -> Exp K.HTable)
71 -> (Type -> Exp Type)
72 -> (Type -> Type) -> Constraint
73class GTableADT _Table _Columns _FromExprs rep where
74 gfromResultADT :: ()
75 => (forall a proxy. Eval (_Table a)
76 => proxy a -> Eval (_Columns a) Result -> Eval (_FromExprs a))
77 -> GColumnsADT _Columns rep Result
78 -> GMap _FromExprs rep x
80 gtoResultADT :: ()
81 => (forall a proxy. Eval (_Table a)
82 => proxy a -> Eval (_FromExprs a) -> Eval (_Columns a) Result)
83 -> GMap _FromExprs rep x
84 -> GColumnsADT _Columns rep Result
87instance
88 ( htable ~ HLabel "tag" (HIdentity Tag)
89 , GTableADT' _Table _Columns _FromExprs htable rep
90 )
91 => GTableADT _Table _Columns _FromExprs (M1 D meta rep)
92 where
93 gfromResultADT fromResult columns =
94 case gfromResultADT' @_Table @_Columns @_FromExprs @htable @rep fromResult tag columns of
95 Just rep -> M1 rep
96 _ -> error "ADT.fromColumns: mismatch between tag and data"
97 where
98 tag = (\(HIdentity (Identity a)) -> a) . hunlabel @"tag"
100 gtoResultADT toResult (M1 rep) =
101 gtoResultADT' @_Table @_Columns @_FromExprs @htable @rep toResult tag (Just rep)
102 where
103 tag = hlabel @"tag" . HIdentity . Identity
106type GTableADT'
107 :: (Type -> Exp Constraint)
108 -> (Type -> Exp K.HTable)
109 -> (Type -> Exp Type)
110 -> K.HTable -> (Type -> Type) -> Constraint
111class GTableADT' _Table _Columns _FromExprs htable rep where
112 gfromResultADT' :: context ~ Result
113 => (forall a proxy. Eval (_Table a)
114 => proxy a -> Eval (_Columns a) context -> Eval (_FromExprs a))
115 -> (htable Result -> Tag)
116 -> GColumnsADT' _Columns htable rep context
117 -> Maybe (GMap _FromExprs rep x)
119 gtoResultADT' :: context ~ Result
120 => (forall a proxy. Eval (_Table a)
121 => proxy a -> Eval (_FromExprs a) -> Eval (_Columns a) context)
122 -> (Tag -> htable Result)
123 -> Maybe (GMap _FromExprs rep x)
124 -> GColumnsADT' _Columns htable rep context
126 extract :: GColumnsADT' _Columns htable rep context -> htable context
129instance
130 ( htable' ~ GColumnsADT' _Columns htable a
131 , GTableADT' _Table _Columns _FromExprs htable a
132 , GTableADT' _Table _Columns _FromExprs htable' b
133 )
134 => GTableADT' _Table _Columns _FromExprs htable (a :+: b)
135 where
136 gfromResultADT' fromResult f columns =
137 case ma of
138 Just a -> Just (L1 a)
139 Nothing -> R1 <$>
140 gfromResultADT' @_Table @_Columns @_FromExprs @_ @b
141 fromResult
142 (f . extract @_Table @_Columns @_FromExprs @_ @a)
143 columns
144 where
145 ma =
146 gfromResultADT' @_Table @_Columns @_FromExprs @_ @a
147 fromResult
148 f
149 (extract @_Table @_Columns @_FromExprs @_ @b columns)
151 gtoResultADT' toResult tag = \case
152 Just (L1 a) ->
153 gtoResultADT' @_Table @_Columns @_FromExprs @_ @b
154 toResult
155 (\_ -> gtoResultADT' @_Table @_Columns @_FromExprs @_ @a
156 toResult
157 tag
158 (Just a))
159 Nothing
160 Just (R1 b) ->
161 gtoResultADT' @_Table @_Columns @_FromExprs @_ @b
162 toResult
163 (\tag' ->
164 gtoResultADT' @_Table @_Columns @_FromExprs @_ @a
165 toResult
166 (\_ -> tag tag')
167 Nothing)
168 (Just b)
169 Nothing ->
170 gtoResultADT' @_Table @_Columns @_FromExprs @_ @b
171 toResult
172 (\_ -> gtoResultADT' @_Table @_Columns @_FromExprs @_ @a toResult tag Nothing)
173 Nothing
175 extract =
176 extract @_Table @_Columns @_FromExprs @_ @a .
177 extract @_Table @_Columns @_FromExprs @_ @b
180instance (meta ~ 'MetaCons label _fixity _isRecord, KnownSymbol label) =>
181 GTableADT' _Table _Columns _FromExprs htable (M1 C meta U1)
182 where
183 gfromResultADT' _ tag columns
184 | tag columns == tag' = Just (M1 U1)
185 | otherwise = Nothing
186 where
187 tag' = Tag $ pack $ symbolVal (Proxy @label)
189 gtoResultADT' _ tag _ = tag tag'
190 where
191 tag' = Tag $ pack $ symbolVal (Proxy @label)
193 extract = id
196instance {-# OVERLAPPABLE #-}
197 ( HTable (GColumns _Columns rep)
198 , GTable _Table _Columns _FromExprs rep
199 , meta ~ 'MetaCons label _fixity _isRecord
200 , KnownSymbol label
201 , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) rep) ~
202 HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))
203 )
204 => GTableADT' _Table _Columns _FromExprs htable (M1 C meta rep)
205 where
206 gfromResultADT' fromResult tag (HProduct a b)
207 | tag a == tag' =
208 M1 . gfromResult @_Table @_Columns @_FromExprs @rep fromResult <$>
209 hunnullify unnullifier (hunlabel b)
210 | otherwise = Nothing
211 where
212 tag' = Tag $ pack $ symbolVal (Proxy @label)
214 gtoResultADT' toResult tag = \case
215 Nothing -> HProduct (tag tag') (hlabel (hnulls (const null)))
216 Just (M1 rep) -> HProduct (tag tag') $
217 hlabel $
218 hnullify nullifier $
219 gtoResult @_Table @_Columns @_FromExprs @rep toResult rep
220 where
221 tag' = Tag $ pack $ symbolVal (Proxy @label)
223 extract (HProduct a _) = a