@@ -16,6 +16,7 @@ import Data.Functor.Classes
1616import Data.HashMap.Strict as H
1717import Data.Kind
1818import Data.Maybe
19+import Data.Schematic.Instances
1920import Data.Schematic.Utils
2021import Data.Scientific
2122import Data.Singletons.Decide
@@ -26,7 +27,9 @@ import Data.Text as T
2627import Data.Vector as V
2728import Data.Vinyl hiding (Dict)
2829import Data.Vinyl.Functor
30+import Data.Vinyl.TypeLevel hiding (Nat)
2931import GHC.Generics (Generic)
32+import Prelude as P
3033import Test.SmallCheck.Series
3134import Text.Show.Deriving (deriveShow1)
3235
@@ -98,10 +101,10 @@ data Schema
98101 deriving (Generic)
99102
100103data instance Sing (schema :: Schema) where
101− SSchemaText :: Sing tcs -> Sing (SchemaText tcs)
102− SSchemaNumber :: Sing ncs -> Sing (SchemaNumber ncs)
103− SSchemaArray :: Sing acs -> Sing schema -> Sing (SchemaArray acs schema)
104− SSchemaObject :: Sing fields -> Sing (SchemaObject fields)
104+ SSchemaText :: Known (Sing tcs) => Sing tcs -> Sing (SchemaText tcs)
105+ SSchemaNumber :: Known (Sing ncs) => Sing ncs -> Sing (SchemaNumber ncs)
106+ SSchemaArray :: (Known (Sing acs), Known (Sing schema)) => Sing acs -> Sing schema -> Sing (SchemaArray acs schema)
107+ SSchemaObject :: Known (Sing fields) => Sing fields -> Sing (SchemaObject fields)
105108 SSchemaNull :: Sing SchemaNull
106109
107110instance Known (Sing sl) => Known (Sing (SchemaText sl)) where
@@ -124,6 +127,12 @@ instance Eq (Sing (SchemaObject cs)) where a == b = True
124127data FieldRepr :: (Symbol, Schema) -> Type where
125128 FieldRepr :: KnownSymbol name => JsonRepr schema -> FieldRepr '(name, schema)
126129
130+type family MapSnd (cs :: [(Symbol, Schema)]) :: [Schema] where
131+ MapSnd '[] = '[]
132+ MapSnd ( '(fn, schema) ': as) = schema ': MapSnd as
133+
134+deriving instance Show (JsonRepr schema) => Show (FieldRepr '(name, schema))
135+
127136instance Eq (JsonRepr schema) => Eq (FieldRepr '(name, schema)) where
128137 FieldRepr a == FieldRepr b = a == b
129138
@@ -140,6 +149,39 @@ data JsonRepr :: Schema -> Type where
140149 ReprArray :: V.Vector (JsonRepr s) -> JsonRepr (SchemaArray cs s)
141150 ReprObject :: Rec FieldRepr fs -> JsonRepr (SchemaObject fs)
142151
152+instance Show (JsonRepr (SchemaText cs)) where
153+ show (ReprText t) = "ReprText " P.++ show t
154+
155+instance Show (JsonRepr (SchemaNumber cs)) where
156+ show (ReprNumber n) = "ReprNumber " P.++ show n
157+
158+instance Show (JsonRepr SchemaNull) where show _ = "ReprNull"
159+
160+instance Show (JsonRepr s) => Show (JsonRepr (SchemaArray acs s)) where
161+ show (ReprArray v) = "ReprArray " P.++ show v
162+
163+instance RecAll FieldRepr fs Show => Show (JsonRepr (SchemaObject fs)) where
164+ show (ReprObject fs) = "ReprObject " P.++ show fs
165+
166+instance (Monad m, Serial m Text)
167+ => Serial m (JsonRepr (SchemaText cs)) where
168+ series = cons1 ReprText
169+
170+instance (Monad m, Serial m Scientific)
171+ => Serial m (JsonRepr (SchemaNumber cs)) where
172+ series = cons1 ReprNumber
173+
174+instance Monad m => Serial m (JsonRepr SchemaNull) where
175+ series = cons0 ReprNull
176+
177+instance (Serial m (V.Vector (JsonRepr s)))
178+ => Serial m (JsonRepr (SchemaArray cs s)) where
179+ series = cons1 ReprArray
180+
181+instance (Monad m, Serial m (Rec FieldRepr fs))
182+ => Serial m (JsonRepr (SchemaObject fs)) where
183+ series = cons1 ReprObject
184+
143185instance Eq (Rec FieldRepr fs) => Eq (JsonRepr (SchemaObject fs)) where
144186 ReprObject a == ReprObject b = a == b
145187
@@ -159,27 +201,34 @@ instance Known (Sing schema) => J.FromJSON (JsonRepr schema) where
159201 parseJSON value = case known :: Sing schema of
160202 SSchemaText _ -> withText "String" (pure . ReprText) value
161203 SSchemaNumber _ -> withScientific "Number" (pure . ReprNumber) value
162− SSchemaNull -> pure ReprNull
163− SSchemaArray c s -> do
204+ SSchemaNull -> case value of
205+ J.Null -> pure ReprNull
206+ _ -> typeMismatch "Null" value
207+ SSchemaArray c s -> withArray "Array" (fmap ReprArray . traverse parseJSON) value
208+ SSchemaObject fs -> do
164209 let
165− f :: Sing cs -> Sing s -> V.Vector J.Value -> Parser (JsonRepr (SchemaArray cs s))
166− f _ _ = fmap ReprArray . traverse parseJSON
167− withArray "Array" (f c s) value
168− SSchemaObject fs -> ReprObject <$> withObject "Object" (demoteFields fs) value
169−
170−demoteFields
171− :: SList s
172− -> H.HashMap Text J.Value
173− -> Parser (Rec FieldRepr s)
174−demoteFields SNil h
175− | H.null h = pure RNil
176− | otherwise = mzero
177−demoteFields (SCons (STuple2 (n :: Sing fn) s) tl) h = withKnownSymbol n $ do
178− let fieldName = T.pack $ symbolVal (Proxy @fn)
179− fieldRepr <- case H.lookup fieldName h of
180− Just v -> FieldRepr <$> (withSingI s $ parseJSON v)
181− Nothing -> mzero
182− (fieldRepr :&) <$> demoteFields tl h
210+ demoteFields :: SList s -> H.HashMap Text J.Value -> Parser (Rec FieldRepr s)
211+ demoteFields SNil h = pure RNil
212+ demoteFields (SCons (STuple2 (n :: Sing fn) s) tl) h = withKnownSymbol n $ do
213+ let fieldName = T.pack $ symbolVal (Proxy @fn)
214+ fieldRepr <- case s of
215+ SSchemaText _ -> case H.lookup fieldName h of
216+ Just v -> FieldRepr <$> parseJSON v
217+ Nothing -> fail "schematext"
218+ SSchemaNumber _ -> case H.lookup fieldName h of
219+ Just v -> FieldRepr <$> parseJSON v
220+ Nothing -> fail "schemanumber"
221+ SSchemaNull -> case H.lookup fieldName h of
222+ Just v -> FieldRepr <$> parseJSON v
223+ Nothing -> fail "schemanull"
224+ SSchemaArray _ _ -> case H.lookup fieldName h of
225+ Just v -> FieldRepr <$> parseJSON v
226+ Nothing -> fail "schemaarray"
227+ SSchemaObject _ -> case H.lookup fieldName h of
228+ Just v -> FieldRepr <$> parseJSON v
229+ Nothing -> fail "schemaobject"
230+ (fieldRepr :&) <$> demoteFields tl h
231+ ReprObject <$> withObject "Object" (demoteFields fs) value
183232
184233instance J.ToJSON (JsonRepr a) where
185234 toJSON ReprNull = J.Null