git.iko.soy/typeable/schematic
on master help sign in
jsonizers
a6ec669Denis Redozubov
src/Data/Schematic/Validation.hs+34−9
compare with master
unifiedsplit
@@ -1,12 +1,15 @@
1{-# LANGUAGE AllowAmbiguousTypes #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE OverloadedLists #-}
2{-# LANGUAGE OverloadedLists #-}
3{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
4+{-# OPTIONS_GHC -fprint-explicit-kinds #-}
4
5
5module Data.Schematic.Validation where
6module Data.Schematic.Validation where
6
7
7import Control.Applicative
8import Control.Applicative
8import Control.Category ((<<<), (>>>))
9import Control.Category ((<<<), (>>>))
10+import Control.Monad
9import Data.Aeson as J
11import Data.Aeson as J
12+import Data.Aeson.Types as J
10import Data.Eq.Deriving (deriveEq1)
13import Data.Eq.Deriving (deriveEq1)
11import Data.Foldable as F
14import Data.Foldable as F
12import Data.Functor.Classes
15import Data.Functor.Classes
@@ -96,10 +99,6 @@ data instance Sing (schema :: Schema) where
96 SSchemaObject :: Sing fields -> Sing (SchemaObject fields)
99 SSchemaObject :: Sing fields -> Sing (SchemaObject fields)
97 SSchemaNull :: Sing SchemaNull
100 SSchemaNull :: Sing SchemaNull
98
101
99−type family MapSnd (l :: [(k, Schema)]) :: [Schema] where
100− MapSnd '[] = '[]
101− MapSnd ( '(f,s) ': tl) = s ': MapSnd tl
102−
103data FieldRepr :: (Symbol, Schema) -> Type where
102data FieldRepr :: (Symbol, Schema) -> Type where
104 FieldRepr :: KnownSymbol name => JsonRepr schema -> FieldRepr '(name, schema)
103 FieldRepr :: KnownSymbol name => JsonRepr schema -> FieldRepr '(name, schema)
105
104
@@ -110,12 +109,39 @@ data JsonRepr :: Schema -> Type where
110 ReprArray :: V.Vector (JsonRepr s) -> JsonRepr (SchemaArray cs s)
109 ReprArray :: V.Vector (JsonRepr s) -> JsonRepr (SchemaArray cs s)
111 ReprObject :: Rec FieldRepr fs -> JsonRepr (SchemaObject fs)
110 ReprObject :: Rec FieldRepr fs -> JsonRepr (SchemaObject fs)
112
111
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+
113instance J.ToJSON (JsonRepr a) where
138instance J.ToJSON (JsonRepr a) where
139+ toJSON ReprNull = J.Null
114− toJSON (ReprText t) = J.String t
140+ toJSON (ReprText t) = J.String t
115− toJSON ReprNull = J.Null
116 toJSON (ReprNumber n) = J.Number n
141 toJSON (ReprNumber n) = J.Number n
117− toJSON (ReprArray v) = J.Array $ toJSON <$> v
142+ toJSON (ReprArray v) = J.Array $ toJSON <$> v
118− toJSON (ReprObject r) = let
143+ toJSON (ReprObject r) = J.Object . H.fromList . fold $ r
144+ where
119 extract
145 extract
120 :: forall name s
146 :: forall name s
121 . (KnownSymbol name)
147 . (KnownSymbol name)
@@ -126,7 +152,6 @@ instance J.ToJSON (JsonRepr a) where
126 fold = \case
152 fold = \case
127 RNil -> []
153 RNil -> []
128 fr@(FieldRepr s) :& tl -> (extract fr) : fold tl
154 fr@(FieldRepr s) :& tl -> (extract fr) : fold tl
129− in J.Object . H.fromList . fold $ r
130
155
131type Spec
156type Spec
132 = SchemaObject
157 = SchemaObject