@@ -27,36 +27,41 @@ withRepr :: Constructor a
27withRepr = ReprObject . rmap (unTagged . getCompose) . fcast
27withRepr = ReprObject . rmap (unTagged . getCompose) . fcast
29class Representable s where
29class Representable s where
31− construct :: Sing fn -> Proxy s -> Repr s -> FieldRepr '(fn, s)
30+ constructField :: Sing fn -> Proxy s -> Repr s -> FieldRepr '(fn, s)
33instance SingI so => Representable ('SchemaObject so) where
32instance SingI so => Representable ('SchemaObject so) where
34− type Repr ('SchemaObject so) = Rec FieldRepr so
35− construct sfn _ o = withKnownSymbol sfn $ FieldRepr $ ReprObject o
33+ constructField sfn _ o = withKnownSymbol sfn $ FieldRepr $ ReprObject o
37instance (SingI cs, SingI sa) => Representable ('SchemaArray cs sa) where
35instance (SingI cs, SingI sa) => Representable ('SchemaArray cs sa) where
38− type Repr ('SchemaArray cs sa) = V.Vector (JsonRepr sa)
39− construct sfn _ a = withKnownSymbol sfn $ FieldRepr $ ReprArray a
36+ constructField sfn _ a = withKnownSymbol sfn $ FieldRepr $ ReprArray a
41instance SingI cs => Representable ('SchemaText cs) where
38instance SingI cs => Representable ('SchemaText cs) where
42− type Repr ('SchemaText cs) = Text
43− construct sfn _ t = withKnownSymbol sfn $ FieldRepr $ ReprText t
39+ constructField sfn _ t = withKnownSymbol sfn $ FieldRepr $ ReprText t
45instance SingI cs => Representable ('SchemaNumber cs) where
41instance SingI cs => Representable ('SchemaNumber cs) where
46− type Repr ('SchemaNumber cs) = Scientific
47− construct sfn _ n = withKnownSymbol sfn $ FieldRepr $ ReprNumber n
42+ constructField sfn _ n = withKnownSymbol sfn $ FieldRepr $ ReprNumber n
49instance Representable 'SchemaBoolean where
44instance Representable 'SchemaBoolean where
50− type Repr 'SchemaBoolean = Bool
51− construct sfn _ b = withKnownSymbol sfn $ FieldRepr $ ReprBoolean b
45+ constructField sfn _ b = withKnownSymbol sfn $ FieldRepr $ ReprBoolean b
53instance SingI so => Representable ('SchemaOptional so) where
47instance SingI so => Representable ('SchemaOptional so) where
54− type Repr ('SchemaOptional so) = Maybe (JsonRepr so)
55− construct sfn _ o = withKnownSymbol sfn $ FieldRepr $ ReprOptional o
48+ constructField sfn _ o = withKnownSymbol sfn $ FieldRepr $ ReprOptional o
57instance SingI (h ': tl) => Representable ('SchemaUnion (h ': tl)) where
50instance SingI (h ': tl) => Representable ('SchemaUnion (h ': tl)) where
58− type Repr ('SchemaUnion (h ': tl)) = Union JsonRepr (h ': tl)
51+ constructField sfn _ u = withKnownSymbol sfn $ FieldRepr $ ReprUnion u
59− construct sfn _ u = withKnownSymbol sfn $ FieldRepr $ ReprUnion u
52+
53+construct :: Sing s -> Repr s -> JsonRepr s
54+construct s r = case s of
55+ SSchemaObject _ -> ReprObject r
56+ SSchemaArray _ _ -> ReprArray r
57+ SSchemaText _ -> ReprText r
58+ SSchemaNumber _ -> ReprNumber r
59+ SSchemaBoolean -> ReprBoolean r
60+ SSchemaOptional _ -> ReprOptional r
61+ SSchemaNull -> ReprNull
62+ SSchemaUnion ss -> case ss of
63+ SNil -> error "unconstructable union"
64+ SCons _ _ -> ReprUnion r
61type family FieldsOf (s :: Schema) :: [(Symbol, Schema)] where
66type family FieldsOf (s :: Schema) :: [(Symbol, Schema)] where
62 FieldsOf ('SchemaObject fs) = fs
67 FieldsOf ('SchemaObject fs) = fs
@@ -67,4 +72,13 @@ type FieldConstructor fn =
67 -> (Tagged fs :. FieldRepr) '(fn, (ByField fn fs (FIndex fn fs)))
72 -> (Tagged fs :. FieldRepr) '(fn, (ByField fn fs (FIndex fn fs)))
69field :: forall fn. KnownSymbol fn => FieldConstructor fn
74field :: forall fn. KnownSymbol fn => FieldConstructor fn
70−field = Compose . Tagged . construct (sing :: Sing fn) Proxy
75+field = Compose . Tagged . constructField (sing :: Sing fn) Proxy
77+type family Repr (s :: Schema) = (ty :: Type) where
78+ Repr ('SchemaObject so) = Rec FieldRepr so
79+ Repr ('SchemaArray cs sa) = V.Vector (JsonRepr sa)
80+ Repr ('SchemaText cs) = Text
81+ Repr ('SchemaNumber cs) = Scientific
82+ Repr 'SchemaBoolean = Bool
83+ Repr ('SchemaOptional so) = Maybe (JsonRepr so)
84+ Repr ('SchemaUnion (h ': tl)) = Union JsonRepr (h ': tl)