@@ -5,25 +5,24 @@
55
66module Data.Schematic.Schema where
77
8−import Control.Applicative ()
9−import Control.Monad
10−import Data.Aeson as J
11−import Data.Aeson.Types as J
12−import Data.HashMap.Strict as H
13−import Data.Kind
14−import Data.Maybe
15−import Data.Schematic.Instances ()
16−import Data.Scientific
17−import Data.Singletons.Prelude.List hiding (All)
18−import Data.Singletons.TH
19−import Data.Singletons.TypeLits
20−import Data.Text as T
21−import Data.Vector as V
22−import Data.Vinyl hiding (Dict)
23−import qualified Data.Vinyl.TypeLevel as V
24−import GHC.Generics (Generic)
25−import Prelude as P
26−import Test.SmallCheck.Series
8+import Control.Applicative ()
9+import Control.Monad
10+import Data.Aeson as J
11+import Data.Aeson.Types as J
12+import Data.HashMap.Strict as H
13+import Data.Kind
14+import Data.Maybe
15+import Data.Schematic.Instances ()
16+import Data.Scientific
17+import Data.Singletons.Prelude.List hiding (All)
18+import Data.Singletons.TH
19+import Data.Singletons.TypeLits
20+import Data.Text as T
21+import Data.Vector as V
22+import GHC.Generics (Generic)
23+import Prelude as P
24+import SuperRecord
25+import Test.SmallCheck.Series
2726
2827
2928type family All (c :: k -> Constraint) (s :: [k]) :: Constraint where
@@ -166,12 +165,18 @@ instance
166165 => Serial m (FieldRepr '(name, schema)) where
167166 series = FieldRepr <$> series
168167
168+type family Fields (ts :: [u]) :: [] where
169+ Fields '[] = '[]
170+ Fields (t ': ts) = (FieldRepr t ': Fields ts)
171+
172+type JObject ts = Rec (Fields ts)
173+
169174data JsonRepr :: Schema -> Type where
170175 ReprText :: Text -> JsonRepr ('SchemaText cs)
171176 ReprNumber :: Scientific -> JsonRepr ('SchemaNumber cs)
172177 ReprNull :: JsonRepr 'SchemaNull
173178 ReprArray :: V.Vector (JsonRepr s) -> JsonRepr ('SchemaArray cs s)
174− ReprObject :: Rec FieldRepr fs -> JsonRepr ('SchemaObject fs)
179+ ReprObject :: JObject fs -> JsonRepr ('SchemaObject fs)
175180 ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s)
176181
177182instance Show (JsonRepr ('SchemaText cs)) where
@@ -185,7 +190,12 @@ instance Show (JsonRepr 'SchemaNull) where show _ = "ReprNull"
185190instance Show (JsonRepr s) => Show (JsonRepr ('SchemaArray acs s)) where
186191 show (ReprArray v) = "ReprArray " P.++ show v
187192
188−instance V.RecAll FieldRepr fs Show => Show (JsonRepr ('SchemaObject fs)) where
193+-- There's a PR in the superrecord library, remove it if gets merged.
194+type family RecAll (c :: u -> Constraint) (rs :: [u]) :: Constraint where
195+ RecAll c '[] = ()
196+ RecAll c (r ': rs) = (c r, RecAll c rs)
197+
198+instance RecAll Show fs => Show (JsonRepr ('SchemaObject fs)) where
189199 show (ReprObject fs) = "ReprObject " P.++ show fs
190200
191201instance Show (JsonRepr s) => Show (JsonRepr ('SchemaOptional s)) where
@@ -210,11 +220,11 @@ instance (Serial m (JsonRepr s))
210220 => Serial m (JsonRepr ('SchemaOptional s)) where
211221 series = cons1 ReprOptional
212222
213−instance (Monad m, Serial m (Rec FieldRepr fs))
223+instance (Monad m, Serial m (JObject fs))
214224 => Serial m (JsonRepr ('SchemaObject fs)) where
215225 series = cons1 ReprObject
216226
217−instance Eq (Rec FieldRepr fs) => Eq (JsonRepr ('SchemaObject fs)) where
227+instance Eq (JObject fs) => Eq (JsonRepr ('SchemaObject fs)) where
218228 ReprObject a == ReprObject b = a == b
219229
220230instance Eq (JsonRepr ('SchemaText cs)) where
@@ -251,7 +261,7 @@ instance SingI schema => J.FromJSON (JsonRepr schema) where
251261 $ withArray "Array" (fmap ReprArray . traverse parseJSON) value
252262 SSchemaObject fs -> do
253263 let
254− demoteFields :: SList s -> H.HashMap Text J.Value -> Parser (Rec FieldRepr s)
264+ demoteFields :: SList s -> H.HashMap Text J.Value -> Parser (JObject s)
255265 demoteFields SNil _ = pure RNil
256266 demoteFields (SCons (STuple2 (n :: Sing fn) s) tl) h = withKnownSymbol n $ do
257267 let fieldName = T.pack $ symbolVal (Proxy @fn)
@@ -287,11 +297,12 @@ instance J.ToJSON (JsonRepr a) where
287297 toJSON (ReprArray v) = J.Array $ toJSON <$> v
288298 toJSON (ReprObject r) = J.Object . H.fromList . fold $ r
289299 where
290− extract :: forall name s . (KnownSymbol name)
300+ extract
301+ :: forall name s . (KnownSymbol name)
291302 => FieldRepr '(name, s)
292303 -> (Text, Value)
293304 extract (FieldRepr s) = (T.pack $ symbolVal $ Proxy @name, toJSON s)
294− fold :: Rec FieldRepr fs -> [(Text, J.Value)]
305+ fold :: JObject fs -> [(Text, J.Value)]
295306 fold = \case
296307 RNil -> []
297308 fr@(FieldRepr _) :& tl -> (extract fr) : fold tl