@@ -19,22 +19,33 @@ module Data.Schematic
1919 , isDecodingError
2020 , isValidationError
2121 , ParseResult(..)
22+ , withRepr
23+ , field
24+ , (<:&>)
2225 ) where
2326
24−import Control.Monad.Validation
25−import Data.Aeson as J
26−import Data.Aeson.Types as J
27−import Data.ByteString.Lazy as BL
28−import Data.Functor.Identity
29−import Data.Schematic.JsonSchema
30−import Data.Schematic.Helpers
31−import Data.Schematic.Lens
32−import Data.Schematic.Migration
33−import Data.Schematic.Schema
34−import Data.Schematic.Utils
35−import Data.Schematic.Validation
36−import Data.Singletons.Prelude
37−import Data.Text as T
27+import Control.Applicative
28+import Control.Monad.Validation
29+import Data.Aeson as J
30+import Data.Aeson.Types as J
31+import Data.ByteString.Lazy as BL
32+import Data.Functor.Identity
33+import Data.Kind
34+import Data.Schematic.Helpers
35+import Data.Schematic.JsonSchema
36+import Data.Schematic.Lens
37+import Data.Schematic.Migration
38+import Data.Schematic.Schema
39+import Data.Schematic.Utils
40+import Data.Schematic.Validation
41+import Data.Scientific
42+import Data.Singletons.Prelude
43+import Data.Singletons.TypeLits
44+import Data.Tagged
45+import Data.Text as T
46+import Data.Union
47+import qualified Data.Vector as V
48+import Data.Vinyl
3849
3950
4051parseAndValidateJson
@@ -125,3 +136,65 @@ decodeAndValidateVersionedWithPureMList
125136 -> ParseResult (JsonRepr (Head (MapSnd (AllVersions versioned))))
126137decodeAndValidateVersionedWithPureMList a b c =
127138 runIdentity $ decodeAndValidateVersionedWithMList a b c
139+
140+-- convenience helpers
141+
142+type Constructor a
143+ = forall b. FSubset (FieldsOf a) b (FImage (FieldsOf a) b)
144+ => Tagged (FieldsOf a) (Rec FieldRepr b)
145+ -> JsonRepr ('SchemaObject (FieldsOf a))
146+
147+withRepr :: Constructor a
148+withRepr = ReprObject . unTagged . fmap fcast
149+
150+(<:&>)
151+ :: Applicative m
152+ => m (FieldRepr fns)
153+ -> m (Rec FieldRepr b)
154+ -> m (Rec FieldRepr (fns ': b))
155+(<:&>) = liftA2 (:&)
156+
157+infixr 7 <:&>
158+
159+class Representable s where
160+ type Repr s :: Type
161+ construct :: Sing fn -> Proxy s -> Repr s -> FieldRepr '(fn, s)
162+
163+instance SingI so => Representable ('SchemaObject so) where
164+ type Repr ('SchemaObject so) = Rec FieldRepr so
165+ construct sfn _ o = withKnownSymbol sfn $ FieldRepr $ ReprObject o
166+
167+instance (SingI cs, SingI sa) => Representable ('SchemaArray cs sa) where
168+ type Repr ('SchemaArray cs sa) = V.Vector (JsonRepr sa)
169+ construct sfn _ a = withKnownSymbol sfn $ FieldRepr $ ReprArray a
170+
171+instance SingI cs => Representable ('SchemaText cs) where
172+ type Repr ('SchemaText cs) = Text
173+ construct sfn _ t = withKnownSymbol sfn $ FieldRepr $ ReprText t
174+
175+instance SingI cs => Representable ('SchemaNumber cs) where
176+ type Repr ('SchemaNumber cs) = Scientific
177+ construct sfn _ n = withKnownSymbol sfn $ FieldRepr $ ReprNumber n
178+
179+instance Representable 'SchemaBoolean where
180+ type Repr 'SchemaBoolean = Bool
181+ construct sfn _ b = withKnownSymbol sfn $ FieldRepr $ ReprBoolean b
182+
183+instance SingI so => Representable ('SchemaOptional so) where
184+ type Repr ('SchemaOptional so) = Maybe (JsonRepr so)
185+ construct sfn _ o = withKnownSymbol sfn $ FieldRepr $ ReprOptional o
186+
187+instance SingI (h ': tl) => Representable ('SchemaUnion (h ': tl)) where
188+ type Repr ('SchemaUnion (h ': tl)) = Union JsonRepr (h ': tl)
189+ construct sfn _ u = withKnownSymbol sfn $ FieldRepr $ ReprUnion u
190+
191+type family FieldsOf (s :: Schema) :: [(Symbol, Schema)] where
192+ FieldsOf ('SchemaObject fs) = fs
193+
194+type FieldConstructor fn =
195+ forall fs. (Representable (ByField fn fs (FIndex fn fs)))
196+ => Repr (ByField fn fs (FIndex fn fs))
197+ -> Tagged fs (FieldRepr '(fn, (ByField fn fs (FIndex fn fs))))
198+
199+field :: forall fn. KnownSymbol fn => FieldConstructor fn
200+field = Tagged . construct (sing :: Sing fn) Proxy