@@ -1,12 +1,15 @@
11{-# LANGUAGE AllowAmbiguousTypes #-}
22{-# LANGUAGE OverloadedLists #-}
33{-# LANGUAGE OverloadedStrings #-}
4+{-# OPTIONS_GHC -fprint-explicit-kinds #-}
45
56module Data.Schematic.Validation where
67
78import Control.Applicative
89import Control.Category ((<<<), (>>>))
10+import Control.Monad
911import Data.Aeson as J
12+import Data.Aeson.Types as J
1013import Data.Eq.Deriving (deriveEq1)
1114import Data.Foldable as F
1215import Data.Functor.Classes
@@ -96,10 +99,6 @@ data instance Sing (schema :: Schema) where
9699 SSchemaObject :: Sing fields -> Sing (SchemaObject fields)
97100 SSchemaNull :: Sing SchemaNull
98101
99−type family MapSnd (l :: [(k, Schema)]) :: [Schema] where
100− MapSnd '[] = '[]
101− MapSnd ( '(f,s) ': tl) = s ': MapSnd tl
102−
103102data FieldRepr :: (Symbol, Schema) -> Type where
104103 FieldRepr :: KnownSymbol name => JsonRepr schema -> FieldRepr '(name, schema)
105104
@@ -110,12 +109,39 @@ data JsonRepr :: Schema -> Type where
110109 ReprArray :: V.Vector (JsonRepr s) -> JsonRepr (SchemaArray cs s)
111110 ReprObject :: Rec FieldRepr fs -> JsonRepr (SchemaObject fs)
112111
112+instance (SingI schema) => J.FromJSON (JsonRepr schema) where
113+ parseJSON value = case sing :: Sing schema of
114+ SSchemaText _ -> withText "String" (pure . ReprText) value
115+ SSchemaNumber _ -> withScientific "Number" (pure . ReprNumber) value
116+ SSchemaNull -> pure ReprNull
117+ SSchemaArray c s -> withArray "Array" f value
118+ where
119+ f v = do
120+ values <- withSingI s $ traverse parseJSON v
121+ pure $ ReprArray values
122+ SSchemaObject fs -> ReprObject <$> withObject "Object" (demoteFields fs) value
123+
124+demoteFields
125+ :: SList s
126+ -> H.HashMap Text J.Value
127+ -> Parser (Rec FieldRepr s)
128+demoteFields SNil h
129+ | H.null h = pure RNil
130+ | otherwise = mzero
131+demoteFields (SCons (STuple2 (n :: Sing fn) s) tl) h = withKnownSymbol n $ do
132+ let fieldName = T.pack $ symbolVal (Proxy @fn)
133+ fieldRepr <- case H.lookup fieldName h of
134+ Just v -> FieldRepr <$> (withSingI s $ parseJSON v)
135+ Nothing -> mzero
136+ (fieldRepr :&) <$> demoteFields tl h
137+
113138instance J.ToJSON (JsonRepr a) where
114− toJSON (ReprText t) = J.String t
115− toJSON ReprNull = J.Null
139+ toJSON ReprNull = J.Null
140+ toJSON (ReprText t) = J.String t
116141 toJSON (ReprNumber n) = J.Number n
117− toJSON (ReprArray v) = J.Array $ toJSON <$> v
118− toJSON (ReprObject r) = let
142+ toJSON (ReprArray v) = J.Array $ toJSON <$> v
143+ toJSON (ReprObject r) = J.Object . H.fromList . fold $ r
144+ where
119145 extract
120146 :: forall name s
121147 . (KnownSymbol name)
@@ -126,7 +152,6 @@ instance J.ToJSON (JsonRepr a) where
126152 fold = \case
127153 RNil -> []
128154 fr@(FieldRepr s) :& tl -> (extract fr) : fold tl
129− in J.Object . H.fromList . fold $ r
130155
131156type Spec
132157 = SchemaObject