git.iko.soy/rel8
on master help sign in
Add Rel8.Generic.Table.ADT
6c20afaShane O'Brien
rel8.cabal+1
compare with master
unifiedsplit
@@ -70,6 +70,7 @@ library
70 Rel8.Generic.Map
70 Rel8.Generic.Map
71 Rel8.Generic.Record
71 Rel8.Generic.Record
72 Rel8.Generic.Table
72 Rel8.Generic.Table
73+ Rel8.Generic.Table.ADT
73
74
74 Rel8.Order
75 Rel8.Order
75
76
src/Rel8.hs+1−1
@@ -294,7 +294,7 @@ import Rel8.Statement.Returning
294import Rel8.Statement.Select
294import Rel8.Statement.Select
295import Rel8.Statement.Update
295import Rel8.Statement.Update
296import Rel8.Statement.View
296import Rel8.Statement.View
297−import Rel8.Table
297+import Rel8.Table hiding ( null )
298import Rel8.Table.Aggregate
298import Rel8.Table.Aggregate
299import Rel8.Table.Alternative
299import Rel8.Table.Alternative
300import Rel8.Table.Bool
300import Rel8.Table.Bool
src/Rel8/Generic/Table/ADT.hsnew file+215
@@ -0,0 +1,215 @@
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 #-}
13+
14+module Rel8.Generic.Table.ADT
15+ ( GADTTable (fromGADTColumns, toGADTColumns)
16+ , GADTColumns
17+ )
18+where
19+
20+-- base
21+import Data.Kind ( Constraint, Type )
22+import Data.Proxy ( Proxy( Proxy ) )
23+import GHC.Generics
24+ ( (:+:)( L1, R1 ), M1( M1 ), U1( U1 )
25+ , C, D
26+ , Meta( MetaCons )
27+ )
28+import GHC.TypeLits ( KnownSymbol, symbolVal )
29+import Prelude hiding ( null )
30+
31+-- rel8
32+import Rel8.FCF ( Eval, Exp )
33+import Rel8.Generic.Table ( GTable, GColumns, fromGColumns, toGColumns )
34+import Rel8.Schema.Context ( Col( Result ) )
35+import Rel8.Schema.Context.Label ( labeler, unlabeler )
36+import Rel8.Schema.HTable ( HTable )
37+import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
38+import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify )
39+import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )
40+import Rel8.Schema.HTable.Type ( HType( HType ) )
41+import qualified Rel8.Schema.Kind as K
42+import Rel8.Schema.Result ( Result )
43+import Rel8.Table ( null, nullifier, unnullifier )
44+import Rel8.Type.Tag ( Tag( Tag ) )
45+
46+-- text
47+import Data.Text ( pack )
48+
49+
50+type GADTColumns
51+ :: (Type -> Exp K.HTable)
52+ -> (Type -> Type) -> K.HTable
53+type family GADTColumns _Columns rep where
54+ GADTColumns _Columns (M1 D _ rep) =
55+ GADTColumns' _Columns (HLabel "tag" (HType Tag)) rep
56+
57+
58+type GADTColumns'
59+ :: (Type -> Exp K.HTable)
60+ -> K.HTable -> (Type -> Type) -> K.HTable
61+type family GADTColumns' _Columns htable rep where
62+ GADTColumns' _Columns htable (a :+: b) =
63+ GADTColumns' _Columns (GADTColumns' _Columns htable a) b
64+ GADTColumns' _Columns htable (M1 C ('MetaCons _ _ _) U1) = htable
65+ GADTColumns' _Columns htable (M1 C ('MetaCons label _ _) rep) =
66+ HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))
67+
68+
69+type GADTTable
70+ :: (Type -> Exp Constraint)
71+ -> (Type -> Exp K.HTable)
72+ -> (Type -> Type) -> Constraint
73+class GADTTable _Table _Columns rep where
74+ fromGADTColumns :: ()
75+ => (forall a. Eval (_Table a) => Eval (_Columns a) (Col Result) -> a)
76+ -> GADTColumns _Columns rep (Col Result)
77+ -> rep x
78+
79+ toGADTColumns :: ()
80+ => (forall a. Eval (_Table a) => a -> Eval (_Columns a) (Col Result))
81+ -> rep x
82+ -> GADTColumns _Columns rep (Col Result)
83+
84+
85+instance
86+ ( htable ~ HLabel "tag" (HType Tag)
87+ , GADTTable' _Table _Columns htable rep
88+ )
89+ => GADTTable _Table _Columns (M1 D meta rep)
90+ where
91+ fromGADTColumns fromColumns columns =
92+ case fromGADTColumns' @_Table @_Columns fromColumns tag columns of
93+ Just rep -> M1 rep
94+ _ -> error "ADT.fromColumns: mismatch between tag and data"
95+ where
96+ tag = (\(HType (Result a)) -> a) . hunlabel @_ @"tag" unlabeler
97+
98+ toGADTColumns toColumns (M1 rep) =
99+ toGADTColumns' @_Table @_Columns toColumns tag (Just rep)
100+ where
101+ tag = hlabel @_ @"tag" labeler . HType . Result
102+
103+
104+type GADTTable'
105+ :: (Type -> Exp Constraint)
106+ -> (Type -> Exp K.HTable)
107+ -> K.HTable -> (Type -> Type) -> Constraint
108+class GADTTable' _Table _Columns htable rep where
109+ fromGADTColumns' :: ()
110+ => (forall a. Eval (_Table a) => Eval (_Columns a) (Col Result) -> a)
111+ -> (htable (Col Result) -> Tag)
112+ -> GADTColumns' _Columns htable rep (Col Result)
113+ -> Maybe (rep x)
114+
115+ toGADTColumns' :: ()
116+ => (forall a. Eval (_Table a) => a -> Eval (_Columns a) (Col Result))
117+ -> (Tag -> htable (Col Result))
118+ -> Maybe (rep x)
119+ -> GADTColumns' _Columns htable rep (Col Result)
120+
121+ extract :: GADTColumns' _Columns htable rep context -> htable context
122+
123+
124+instance
125+ ( htable' ~ GADTColumns' _Columns htable a
126+ , GADTTable' _Table _Columns htable a
127+ , GADTTable' _Table _Columns htable' b
128+ )
129+ => GADTTable' _Table _Columns htable (a :+: b)
130+ where
131+ fromGADTColumns' fromColumns f columns =
132+ case ma of
133+ Just a -> Just (L1 a)
134+ Nothing -> R1 <$>
135+ fromGADTColumns' @_Table @_Columns @_ @b
136+ fromColumns
137+ (f . extract @_Table @_Columns @_ @a)
138+ columns
139+ where
140+ ma =
141+ fromGADTColumns' @_Table @_Columns @_ @a
142+ fromColumns
143+ f
144+ (extract @_Table @_Columns @_ @b columns)
145+
146+ toGADTColumns' toColumns tag = \case
147+ Just (L1 a) ->
148+ toGADTColumns' @_Table @_Columns @_ @b
149+ toColumns
150+ (\_ -> toGADTColumns' @_Table @_Columns @_ @a
151+ toColumns
152+ tag
153+ (Just a))
154+ Nothing
155+ Just (R1 b) ->
156+ toGADTColumns' @_Table @_Columns @_ @b
157+ toColumns
158+ (\tag' ->
159+ toGADTColumns' @_Table @_Columns @_ @a
160+ toColumns
161+ (\_ -> tag tag')
162+ Nothing)
163+ (Just b)
164+ Nothing ->
165+ toGADTColumns' @_Table @_Columns @_ @b
166+ toColumns
167+ (\_ -> toGADTColumns' @_Table @_Columns @_ @a toColumns tag Nothing)
168+ Nothing
169+
170+ extract = extract @_Table @_Columns @_ @a . extract @_Table @_Columns @_ @b
171+
172+
173+instance KnownSymbol label =>
174+ GADTTable' _Table _Columns htable (M1 C ('MetaCons label _fixity _isRecord) U1)
175+ where
176+ fromGADTColumns' _ tag columns
177+ | tag columns == tag' = Just (M1 U1)
178+ | otherwise = Nothing
179+ where
180+ tag' = Tag $ pack $ symbolVal (Proxy @label)
181+
182+ toGADTColumns' _ tag _ = tag tag'
183+ where
184+ tag' = Tag $ pack $ symbolVal (Proxy @label)
185+
186+ extract = id
187+
188+
189+instance {-# OVERLAPPABLE #-}
190+ ( HTable (GColumns _Columns rep)
191+ , GTable _Table _Columns (Col Result) rep
192+ , KnownSymbol label
193+ , GADTColumns' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) rep) ~
194+ HProduct htable (HLabel label (HNullify (GColumns _Columns rep)))
195+ )
196+ => GADTTable' _Table _Columns htable (M1 C ('MetaCons label _fixity _isRecord) rep)
197+ where
198+ fromGADTColumns' fromColumns tag (HProduct a b)
199+ | tag a == tag' =
200+ M1 . fromGColumns @_Table @_Columns fromColumns <$>
201+ hunnullify unnullifier (hunlabel unlabeler b)
202+ | otherwise = Nothing
203+ where
204+ tag' = Tag $ pack $ symbolVal (Proxy @label)
205+
206+ toGADTColumns' toColumns tag = \case
207+ Nothing -> HProduct (tag tag') (hlabel labeler (hnulls null))
208+ Just (M1 rep) -> HProduct (tag tag') $
209+ hlabel labeler $
210+ hnullify nullifier $
211+ toGColumns @_Table @_Columns toColumns rep
212+ where
213+ tag' = Tag $ pack $ symbolVal (Proxy @label)
214+
215+ extract (HProduct a _) = a
src/Rel8/Schema/Generic.hs+2−2
@@ -69,7 +69,7 @@ instance (Rel8able t, Labelable context, Reifiable context) =>
69
69
70
70
71type KRel8able :: Type
71type KRel8able :: Type
72−type KRel8able = K.Table
72+type KRel8able = K.Rel8able
73
73
74
74
75-- | This type class allows you to define custom 'Table's using higher-kinded
75-- | This type class allows you to define custom 'Table's using higher-kinded
@@ -114,7 +114,7 @@ type KRel8able = K.Table
114-- data MyType f = MyType { fieldA :: Column f T }
114-- data MyType f = MyType { fieldA :: Column f T }
115-- deriving ( GHC.Generics.Generic, Rel8able )
115-- deriving ( GHC.Generics.Generic, Rel8able )
116-- @
116-- @
117−type Rel8able :: KRel8able -> Constraint
117+type Rel8able :: K.Rel8able -> Constraint
118class HTable (GRep t) => Rel8able t where
118class HTable (GRep t) => Rel8able t where
119 type GRep t :: K.HTable
119 type GRep t :: K.HTable
120
120
src/Rel8/Schema/Kind.hs+3−3
@@ -1,7 +1,7 @@
1{-# language StandaloneKindSignatures #-}
1{-# language StandaloneKindSignatures #-}
2
2
3module Rel8.Schema.Kind
3module Rel8.Schema.Kind
4− ( Context, Table
4+ ( Context, Rel8able
5 , HContext, HTable
5 , HContext, HTable
6 )
6 )
7where
7where
@@ -29,5 +29,5 @@ type Context :: Type
29type Context = X -> Type
29type Context = X -> Type
30
30
31
31
32−type Table :: Type
32+type Rel8able :: Type
33−type Table = Context -> Type
33+type Rel8able = Context -> Type
src/Rel8/Table.hs+1
@@ -18,6 +18,7 @@ module Rel8.Table
18 ( Table (Columns, Context, Unreify, toColumns, fromColumns, reify, unreify)
18 ( Table (Columns, Context, Unreify, toColumns, fromColumns, reify, unreify)
19 , Congruent
19 , Congruent
20 , TTable, TColumns, TContext, TUnreify
20 , TTable, TColumns, TContext, TUnreify
21+ , null, nullifier, unnullifier
21 )
22 )
22where
23where
23
24
src/Rel8/Type/Tag.hs+12
@@ -1,11 +1,13 @@
1{-# language DataKinds #-}
1{-# language DataKinds #-}
2{-# language DeriveAnyClass #-}
2{-# language DeriveAnyClass #-}
3{-# language DerivingVia #-}
3{-# language DerivingVia #-}
4+{-# language GeneralizedNewtypeDeriving #-}
4{-# language StandaloneKindSignatures #-}
5{-# language StandaloneKindSignatures #-}
5
6
6module Rel8.Type.Tag
7module Rel8.Type.Tag
7 ( EitherTag( IsLeft, IsRight ), isLeft, isRight
8 ( EitherTag( IsLeft, IsRight ), isLeft, isRight
8 , MaybeTag( IsJust )
9 , MaybeTag( IsJust )
10+ , Tag( Tag )
9 )
11 )
10where
12where
11
13
@@ -30,6 +32,9 @@ import Rel8.Type.Monoid ( DBMonoid, memptyExpr )
30import Rel8.Type.Ord ( DBOrd )
32import Rel8.Type.Ord ( DBOrd )
31import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )
33import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )
32
34
35+-- text
36+import Data.Text ( Text )
37+
33
38
34type EitherTag :: Type
39type EitherTag :: Type
35data EitherTag = IsLeft | IsRight
40data EitherTag = IsLeft | IsRight
@@ -83,3 +88,10 @@ instance DBSemigroup MaybeTag where
83
88
84instance DBMonoid MaybeTag where
89instance DBMonoid MaybeTag where
85 memptyExpr = litExpr mempty
90 memptyExpr = litExpr mempty
91+
92+
93+newtype Tag = Tag Text
94+ deriving newtype
95+ ( Eq, Ord, Read, Show
96+ , DBType, DBEq, DBOrd
97+ )