Skip to content
This repository was archived by the owner on Oct 19, 2024. It is now read-only.

Commit 5d9b01d

Browse files
serrasserras
authored
Use first-class-families to find selectors (#242)
1 parent 7839f32 commit 5d9b01d

File tree

3 files changed

+44
-42
lines changed

3 files changed

+44
-42
lines changed

‎adapter/protobuf/test/ProtoBuf.hs

+11
Original file line numberDiff line numberDiff line change
@@ -42,6 +42,17 @@ type instance AnnotatedSchema ProtoBufAnnotation ExampleSchema
4242
= '[ 'AnnField "gender" "male" ('ProtoBufId 1 '[])
4343
, 'AnnField "gender" "female" ('ProtoBufId 2 '[])
4444
, 'AnnField "gender" "nb" ('ProtoBufId 3 '[])
45+
, 'AnnField "gender" "gender0" ('ProtoBufId 4 '[])
46+
, 'AnnField "gender" "gender1" ('ProtoBufId 5 '[])
47+
, 'AnnField "gender" "gender2" ('ProtoBufId 6 '[])
48+
, 'AnnField "gender" "gender3" ('ProtoBufId 7 '[])
49+
, 'AnnField "gender" "gender4" ('ProtoBufId 8 '[])
50+
, 'AnnField "gender" "gender5" ('ProtoBufId 9 '[])
51+
, 'AnnField "gender" "gender6" ('ProtoBufId 10 '[])
52+
, 'AnnField "gender" "gender7" ('ProtoBufId 11 '[])
53+
, 'AnnField "gender" "gender8" ('ProtoBufId 12 '[])
54+
, 'AnnField "gender" "gender9" ('ProtoBufId 13 '[])
55+
, 'AnnField "gender" "unspecified" ('ProtoBufId 14 '[])
4556
, 'AnnField "address" "postcode" ('ProtoBufId 1 '[])
4657
, 'AnnField "address" "country" ('ProtoBufId 2 '[])
4758
, 'AnnField "person" "firstName" ('ProtoBufId 1 '[])

‎core/schema/mu-schema.cabal

+1-1
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
name: mu-schema
2-
version: 0.3.1.0
2+
version: 0.3.1.1
33
synopsis: Format-independent schemas for serialization
44
description:
55
With @mu-schema@ you can describe schemas using type-level constructs, and derive serializers from those. See @mu-avro@, @mu-protobuf@ for the actual adapters.

‎core/schema/src/Mu/Schema/Class.hs

+32-41
Original file line numberDiff line numberDiff line change
@@ -185,39 +185,41 @@ instance UnderlyingConversion BS.ByteString U.UUID where
185185
-- Note: it turns out that GHC.Generics generates some weird
186186
-- instances for records in the form (x :*: y) :*: z
187187
-- and we cover them with the special HereLeft and HereRight
188-
data Where = Here | HereLeft | HereRight | HereRightThenLeft | HereTwoRights | There Where
188+
data Where = Here | There Where
189+
data WhereStep = StepNoMore | StepLeft | StepRight
189190

190191
type family Find (xs :: [k]) (x :: k) :: Where where
191192
Find '[] y = TypeError ('Text "Could not find " ':<>: 'ShowType y)
192193
Find (y ': xs) y = 'Here
193194
Find (x ': xs) y = 'There (Find xs y)
194195

195-
type family FindCon (xs :: * -> *) (x :: Symbol) :: [Where] where
196+
type family FindCon (xs :: * -> *) (x :: Symbol) :: [WhereStep] where
196197
FindCon xs x = WhenEmpty
197198
(FindCon' '[] xs x)
198199
(TypeError ('Text "Could not find constructor " ':<>: 'ShowType x))
199200

200-
-- TODO: Maybe 'Where' isn't the right thing to use here.
201-
type family FindCon' (begin :: [Where]) (xs :: * -> *) (x :: Symbol) :: [Where] where
202-
FindCon' acc (C1 ('MetaCons x p s) f) x = Eval (Snoc acc 'Here)
201+
type family FindCon' (begin :: [WhereStep]) (xs :: * -> *) (x :: Symbol) :: [WhereStep] where
202+
FindCon' acc (C1 ('MetaCons x p s) f) x = Eval (Snoc acc 'StepNoMore)
203203
FindCon' acc (left :+: right) x = WhenEmpty
204-
(FindCon' (Eval (Snoc acc 'HereLeft)) left x)
205-
(Pure (FindCon' (Eval (Snoc acc 'HereRight)) right x))
204+
(FindCon' (Eval (Snoc acc 'StepLeft)) left x)
205+
(Pure (FindCon' (Eval (Snoc acc 'StepRight)) right x))
206206
FindCon' acc other x = '[]
207207

208208
type family WhenEmpty (left :: [a]) (right :: Exp [a]) :: [a] where
209209
WhenEmpty '[] b = Eval b
210210
WhenEmpty a _ = a
211211

212-
type family FindSel (xs :: * -> *) (x :: Symbol) :: Where where
213-
FindSel (S1 ('MetaSel ('Just x) u ss ds) f) x = 'Here
214-
FindSel (S1 ('MetaSel ('Just x) u ss ds) f :*: rest) x = 'Here
215-
FindSel ((S1 ('MetaSel ('Just x) u ss ds) f :*: other) :*: rest) x = 'HereLeft
216-
FindSel ((other :*: S1 ('MetaSel ('Just x) u ss ds) f) :*: rest) x = 'HereRight
217-
FindSel ((other1 :*: (S1 ('MetaSel ('Just x) u ss ds) f :*: other2)) :*: rest) x = 'HereRightThenLeft
218-
FindSel ((other1 :*: (other2 :*: S1 ('MetaSel ('Just x) u ss ds) f)) :*: rest) x = 'HereTwoRights
219-
FindSel (other :*: rest) x = 'There (FindSel rest x)
220-
FindSel nothing x = TypeError ('Text "Could not find selector " ':<>: 'ShowType x)
212+
type family FindSel (xs :: * -> *) (x :: Symbol) :: [WhereStep] where
213+
FindSel xs x = WhenEmpty
214+
(FindSel' '[] xs x)
215+
(TypeError ('Text "Could not find field " ':<>: 'ShowType x))
216+
217+
type family FindSel' (begin :: [WhereStep]) (xs :: * -> *) (x :: Symbol) :: [WhereStep] where
218+
FindSel' acc (S1 ('MetaSel ('Just x) u ss ds) f) x = Eval (Snoc acc 'StepNoMore)
219+
FindSel' acc (left :*: right) x = WhenEmpty
220+
(FindSel' (Eval (Snoc acc 'StepLeft)) left x)
221+
(Pure (FindSel' (Eval (Snoc acc 'StepRight)) right x))
222+
FindSel' acc other x = '[]
221223

222224
type family FindEnumChoice (xs :: [ChoiceDef fs]) (x :: fs) :: Where where
223225
FindEnumChoice '[] x = TypeError ('Text "Could not find enum choice " ':<>: 'ShowType x)
@@ -486,13 +488,13 @@ instance (GFromSchemaEnumU1 f (FindCon f (MappingLeft fmap c)), GFromSchemaEnumD
486488
fromSchemaEnumDecomp _ (Z _) = fromSchemaEnumU1 (Proxy @f) (Proxy @(FindCon f (MappingLeft fmap c)))
487489
fromSchemaEnumDecomp p (S x) = fromSchemaEnumDecomp p x
488490

489-
class GFromSchemaEnumU1 (f :: * -> *) (w :: [Where]) where
491+
class GFromSchemaEnumU1 (f :: * -> *) (w :: [WhereStep]) where
490492
fromSchemaEnumU1 :: Proxy f -> Proxy w -> f a
491-
instance GFromSchemaEnumU1 (C1 m U1) '[ 'Here] where
492-
fromSchemaEnumU1 _ _ = (M1 U1)
493-
instance GFromSchemaEnumU1 left rest => GFromSchemaEnumU1 (left :+: right) ('HereLeft ': rest) where
493+
instance GFromSchemaEnumU1 (C1 m U1) '[ 'StepNoMore ] where
494+
fromSchemaEnumU1 _ _ = M1 U1
495+
instance GFromSchemaEnumU1 left rest => GFromSchemaEnumU1 (left :+: right) ('StepLeft ': rest) where
494496
fromSchemaEnumU1 _ _ = L1 (fromSchemaEnumU1 (Proxy @left) (Proxy @rest))
495-
instance GFromSchemaEnumU1 right rest => GFromSchemaEnumU1 (left :+: right) ('HereRight ': rest) where
497+
instance GFromSchemaEnumU1 right rest => GFromSchemaEnumU1 (left :+: right) ('StepRight ': rest) where
496498
fromSchemaEnumU1 _ _ = R1 (fromSchemaEnumU1 (Proxy @right) (Proxy @rest))
497499

498500
-- ----------
@@ -553,29 +555,18 @@ instance ( GToSchemaRecord sch fmap cs f
553555
where this = Field (toSchemaRecordSearch (Proxy @(FindSel f (MappingLeft fmap name))) x)
554556

555557
class GToSchemaRecordSearch (sch :: Schema ts fs)
556-
(t :: FieldType ts) (f :: * -> *) (wh :: Where) where
558+
(t :: FieldType ts) (f :: * -> *) (wh :: [WhereStep]) where
557559
toSchemaRecordSearch :: Proxy wh -> f a -> FieldValue sch t
558560
instance GToSchemaFieldType sch t v
559-
=> GToSchemaRecordSearch sch t (S1 m (K1 i v)) 'Here where
561+
=> GToSchemaRecordSearch sch t (S1 m (K1 i v)) '[ 'StepNoMore ] where
560562
toSchemaRecordSearch _ (M1 (K1 x)) = toSchemaFieldType x
561-
instance GToSchemaFieldType sch t v
562-
=> GToSchemaRecordSearch sch t (S1 m (K1 i v) :*: rest) 'Here where
563-
toSchemaRecordSearch _ (M1 (K1 x) :*: _) = toSchemaFieldType x
564-
instance GToSchemaFieldType sch t v
565-
=> GToSchemaRecordSearch sch t ((S1 m (K1 i v) :*: other) :*: rest) 'HereLeft where
566-
toSchemaRecordSearch _ ((M1 (K1 x) :*: _) :*: _) = toSchemaFieldType x
567-
instance GToSchemaFieldType sch t v
568-
=> GToSchemaRecordSearch sch t ((other :*: S1 m (K1 i v)) :*: rest) 'HereRight where
569-
toSchemaRecordSearch _ ((_ :*: M1 (K1 x)) :*: _) = toSchemaFieldType x
570-
instance GToSchemaFieldType sch t v
571-
=> GToSchemaRecordSearch sch t ((other1 :*: (S1 m (K1 i v) :*: other2)) :*: rest) 'HereRightThenLeft where
572-
toSchemaRecordSearch _ ((_ :*: (M1 (K1 x) :*: _)) :*: _) = toSchemaFieldType x
573-
instance GToSchemaFieldType sch t v
574-
=> GToSchemaRecordSearch sch t ((other1 :*: (other2 :*: S1 m (K1 i v))) :*: rest) 'HereTwoRights where
575-
toSchemaRecordSearch _ ((_ :*: (_ :*: M1 (K1 x))) :*: _) = toSchemaFieldType x
576-
instance forall sch t other rest n.
577-
GToSchemaRecordSearch sch t rest n
578-
=> GToSchemaRecordSearch sch t (other :*: rest) ('There n) where
563+
instance forall sch t left right n.
564+
GToSchemaRecordSearch sch t left n
565+
=> GToSchemaRecordSearch sch t (left :*: right) ('StepLeft ': n) where
566+
toSchemaRecordSearch _ (xs :*: _) = toSchemaRecordSearch (Proxy @n) xs
567+
instance forall sch t left right n.
568+
GToSchemaRecordSearch sch t right n
569+
=> GToSchemaRecordSearch sch t (left :*: right) ('StepRight ': n) where
579570
toSchemaRecordSearch _ (_ :*: xs) = toSchemaRecordSearch (Proxy @n) xs
580571

581572
-- 'fromSchema' for records

0 commit comments

Comments
 (0)