diff --git a/mu-schema.cabal b/mu-schema.cabal --- a/mu-schema.cabal +++ b/mu-schema.cabal @@ -1,5 +1,5 @@ name: mu-schema -version: 0.3.1.0 +version: 0.3.1.1 synopsis: Format-independent schemas for serialization description: 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. @@ -42,6 +42,7 @@ , base >=4.12 && <5 , bytestring >=0.10 && <0.11 , containers >=0.6 && <0.7 + , first-class-families >=0.8 && <0.9 , sop-core >=0.5 && <0.6 , template-haskell >=2.14 && <2.16 , text >=1.2 && <2 diff --git a/src/Mu/Schema/Class.hs b/src/Mu/Schema/Class.hs --- a/src/Mu/Schema/Class.hs +++ b/src/Mu/Schema/Class.hs @@ -53,6 +53,8 @@ import GHC.Generics import GHC.TypeLits +import Fcf (Eval, Exp, Pure) +import Fcf.Data.List (Snoc) import Mu.Schema.Definition import Mu.Schema.Interpretation @@ -183,29 +185,42 @@ -- Note: it turns out that GHC.Generics generates some weird -- instances for records in the form (x :*: y) :*: z -- and we cover them with the special HereLeft and HereRight -data Where = Here | HereLeft | HereRight | HereRightThenLeft | HereTwoRights | There Where +data Where = Here | There Where +data WhereStep = StepNoMore | StepLeft | StepRight type family Find (xs :: [k]) (x :: k) :: Where where Find '[] y = TypeError ('Text "Could not find " ':<>: 'ShowType y) Find (y ': xs) y = 'Here Find (x ': xs) y = 'There (Find xs y) -type family FindCon (xs :: * -> *) (x :: Symbol) :: Where where - FindCon (C1 ('MetaCons x p s) f) x = 'Here - FindCon (C1 ('MetaCons x p s) f :+: rest) x = 'Here - FindCon (other :+: rest) x = 'There (FindCon rest x) - FindCon nothing x = TypeError ('Text "Could not find constructor " ':<>: 'ShowType x) +type family FindCon (xs :: * -> *) (x :: Symbol) :: [WhereStep] where + FindCon xs x = WhenEmpty + (FindCon' '[] xs x) + (TypeError ('Text "Could not find constructor " ':<>: 'ShowType x)) -type family FindSel (xs :: * -> *) (x :: Symbol) :: Where where - FindSel (S1 ('MetaSel ('Just x) u ss ds) f) x = 'Here - FindSel (S1 ('MetaSel ('Just x) u ss ds) f :*: rest) x = 'Here - FindSel ((S1 ('MetaSel ('Just x) u ss ds) f :*: other) :*: rest) x = 'HereLeft - FindSel ((other :*: S1 ('MetaSel ('Just x) u ss ds) f) :*: rest) x = 'HereRight - FindSel ((other1 :*: (S1 ('MetaSel ('Just x) u ss ds) f :*: other2)) :*: rest) x = 'HereRightThenLeft - FindSel ((other1 :*: (other2 :*: S1 ('MetaSel ('Just x) u ss ds) f)) :*: rest) x = 'HereTwoRights - FindSel (other :*: rest) x = 'There (FindSel rest x) - FindSel nothing x = TypeError ('Text "Could not find selector " ':<>: 'ShowType x) +type family FindCon' (begin :: [WhereStep]) (xs :: * -> *) (x :: Symbol) :: [WhereStep] where + FindCon' acc (C1 ('MetaCons x p s) f) x = Eval (Snoc acc 'StepNoMore) + FindCon' acc (left :+: right) x = WhenEmpty + (FindCon' (Eval (Snoc acc 'StepLeft)) left x) + (Pure (FindCon' (Eval (Snoc acc 'StepRight)) right x)) + FindCon' acc other x = '[] +type family WhenEmpty (left :: [a]) (right :: Exp [a]) :: [a] where + WhenEmpty '[] b = Eval b + WhenEmpty a _ = a + +type family FindSel (xs :: * -> *) (x :: Symbol) :: [WhereStep] where + FindSel xs x = WhenEmpty + (FindSel' '[] xs x) + (TypeError ('Text "Could not find field " ':<>: 'ShowType x)) + +type family FindSel' (begin :: [WhereStep]) (xs :: * -> *) (x :: Symbol) :: [WhereStep] where + FindSel' acc (S1 ('MetaSel ('Just x) u ss ds) f) x = Eval (Snoc acc 'StepNoMore) + FindSel' acc (left :*: right) x = WhenEmpty + (FindSel' (Eval (Snoc acc 'StepLeft)) left x) + (Pure (FindSel' (Eval (Snoc acc 'StepRight)) right x)) + FindSel' acc other x = '[] + type family FindEnumChoice (xs :: [ChoiceDef fs]) (x :: fs) :: Where where FindEnumChoice '[] x = TypeError ('Text "Could not find enum choice " ':<>: 'ShowType x) FindEnumChoice ('ChoiceDef name ': xs) name = 'Here @@ -473,15 +488,14 @@ fromSchemaEnumDecomp _ (Z _) = fromSchemaEnumU1 (Proxy @f) (Proxy @(FindCon f (MappingLeft fmap c))) fromSchemaEnumDecomp p (S x) = fromSchemaEnumDecomp p x -class GFromSchemaEnumU1 (f :: * -> *) (w :: Where) where +class GFromSchemaEnumU1 (f :: * -> *) (w :: [WhereStep]) where fromSchemaEnumU1 :: Proxy f -> Proxy w -> f a -instance GFromSchemaEnumU1 (C1 m U1 :+: rest) 'Here where - fromSchemaEnumU1 _ _ = L1 (M1 U1) -instance GFromSchemaEnumU1 (C1 m U1) 'Here where +instance GFromSchemaEnumU1 (C1 m U1) '[ 'StepNoMore ] where fromSchemaEnumU1 _ _ = M1 U1 -instance forall other rest w. GFromSchemaEnumU1 rest w - => GFromSchemaEnumU1 (other :+: rest) ('There w) where - fromSchemaEnumU1 _ _ = R1 (fromSchemaEnumU1 (Proxy @rest) (Proxy @w)) +instance GFromSchemaEnumU1 left rest => GFromSchemaEnumU1 (left :+: right) ('StepLeft ': rest) where + fromSchemaEnumU1 _ _ = L1 (fromSchemaEnumU1 (Proxy @left) (Proxy @rest)) +instance GFromSchemaEnumU1 right rest => GFromSchemaEnumU1 (left :+: right) ('StepRight ': rest) where + fromSchemaEnumU1 _ _ = R1 (fromSchemaEnumU1 (Proxy @right) (Proxy @rest)) -- ---------- -- RECORDS -- @@ -541,29 +555,18 @@ where this = Field (toSchemaRecordSearch (Proxy @(FindSel f (MappingLeft fmap name))) x) class GToSchemaRecordSearch (sch :: Schema ts fs) - (t :: FieldType ts) (f :: * -> *) (wh :: Where) where + (t :: FieldType ts) (f :: * -> *) (wh :: [WhereStep]) where toSchemaRecordSearch :: Proxy wh -> f a -> FieldValue sch t instance GToSchemaFieldType sch t v - => GToSchemaRecordSearch sch t (S1 m (K1 i v)) 'Here where + => GToSchemaRecordSearch sch t (S1 m (K1 i v)) '[ 'StepNoMore ] where toSchemaRecordSearch _ (M1 (K1 x)) = toSchemaFieldType x -instance GToSchemaFieldType sch t v - => GToSchemaRecordSearch sch t (S1 m (K1 i v) :*: rest) 'Here where - toSchemaRecordSearch _ (M1 (K1 x) :*: _) = toSchemaFieldType x -instance GToSchemaFieldType sch t v - => GToSchemaRecordSearch sch t ((S1 m (K1 i v) :*: other) :*: rest) 'HereLeft where - toSchemaRecordSearch _ ((M1 (K1 x) :*: _) :*: _) = toSchemaFieldType x -instance GToSchemaFieldType sch t v - => GToSchemaRecordSearch sch t ((other :*: S1 m (K1 i v)) :*: rest) 'HereRight where - toSchemaRecordSearch _ ((_ :*: M1 (K1 x)) :*: _) = toSchemaFieldType x -instance GToSchemaFieldType sch t v - => GToSchemaRecordSearch sch t ((other1 :*: (S1 m (K1 i v) :*: other2)) :*: rest) 'HereRightThenLeft where - toSchemaRecordSearch _ ((_ :*: (M1 (K1 x) :*: _)) :*: _) = toSchemaFieldType x -instance GToSchemaFieldType sch t v - => GToSchemaRecordSearch sch t ((other1 :*: (other2 :*: S1 m (K1 i v))) :*: rest) 'HereTwoRights where - toSchemaRecordSearch _ ((_ :*: (_ :*: M1 (K1 x))) :*: _) = toSchemaFieldType x -instance forall sch t other rest n. - GToSchemaRecordSearch sch t rest n - => GToSchemaRecordSearch sch t (other :*: rest) ('There n) where +instance forall sch t left right n. + GToSchemaRecordSearch sch t left n + => GToSchemaRecordSearch sch t (left :*: right) ('StepLeft ': n) where + toSchemaRecordSearch _ (xs :*: _) = toSchemaRecordSearch (Proxy @n) xs +instance forall sch t left right n. + GToSchemaRecordSearch sch t right n + => GToSchemaRecordSearch sch t (left :*: right) ('StepRight ': n) where toSchemaRecordSearch _ (_ :*: xs) = toSchemaRecordSearch (Proxy @n) xs -- 'fromSchema' for records diff --git a/src/Mu/Schema/Examples.hs b/src/Mu/Schema/Examples.hs --- a/src/Mu/Schema/Examples.hs +++ b/src/Mu/Schema/Examples.hs @@ -49,11 +49,36 @@ via (WithSchema ExampleSchema "address" Address) type GenderFieldMapping - = '[ "Male" ':-> "male" - , "Female" ':-> "female" - , "NonBinary" ':-> "nb" ] + = '[ "Male" ':-> "male" + , "Female" ':-> "female" + , "NonBinary" ':-> "nb" + , "Gender0" ':-> "gender0" + , "Gender1" ':-> "gender1" + , "Gender2" ':-> "gender2" + , "Gender3" ':-> "gender3" + , "Gender4" ':-> "gender4" + , "Gender5" ':-> "gender5" + , "Gender6" ':-> "gender6" + , "Gender7" ':-> "gender7" + , "Gender8" ':-> "gender8" + , "Gender9" ':-> "gender9" + , "Unspecified" ':-> "unspecified"] -data Gender = Male | Female | NonBinary +data Gender + = Male + | Female + | NonBinary + | Gender0 + | Gender1 + | Gender2 + | Gender3 + | Gender4 + | Gender5 + | Gender6 + | Gender7 + | Gender8 + | Gender9 + | Unspecified deriving (Eq, Show, Generic) deriving (ToSchema ExampleSchema "gender", FromSchema ExampleSchema "gender") via (CustomFieldMapping "gender" GenderFieldMapping Gender) @@ -65,7 +90,18 @@ = '[ 'DEnum "gender" '[ 'ChoiceDef "male" , 'ChoiceDef "female" - , 'ChoiceDef "nb" ] + , 'ChoiceDef "nb" + , 'ChoiceDef "gender0" + , 'ChoiceDef "gender1" + , 'ChoiceDef "gender2" + , 'ChoiceDef "gender3" + , 'ChoiceDef "gender4" + , 'ChoiceDef "gender5" + , 'ChoiceDef "gender6" + , 'ChoiceDef "gender7" + , 'ChoiceDef "gender8" + , 'ChoiceDef "gender9" + , 'ChoiceDef "unspecified" ] , 'DRecord "address" '[ 'FieldDef "postcode" ('TPrimitive T.Text) , 'FieldDef "country" ('TPrimitive T.Text) ]