git.iko.soy/schematic
on 83ff5c8 help sign in
schematic/src/Data/Schematic/Schema.hs
300 lines 11 kB history raw
1{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE OverloadedLists #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# OPTIONS_GHC -fprint-explicit-kinds #-}
6module Data.Schematic.Schema where
8import Control.Applicative
9import Control.Monad
10import Data.Aeson as J
11import Data.Aeson.Types as J
12import Data.HashMap.Strict as H
13import Data.Kind
14import Data.Maybe
15import Data.Schematic.Instances ()
16import Data.Schematic.Utils
17import Data.Scientific
18import Data.Singletons.Prelude.List hiding (All)
19import Data.Singletons.TH
20import Data.Singletons.TypeLits
21import Data.Text as T
22import Data.Vector as V
23import Data.Vinyl hiding (Dict)
24import Data.Vinyl.TypeLevel hiding (Nat)
25import GHC.Generics (Generic)
26import Prelude as P
27import Test.SmallCheck.Series
30type family All (c :: k -> Constraint) (s :: [k]) :: Constraint where
31 All c '[] = ()
32 All c (a ': as) = (c a, All c as)
34type family CRepr (s :: Schema) :: Type where
35 CRepr ('SchemaText cs) = TextConstraint
36 CRepr ('SchemaNumber cs) = NumberConstraint
37 CRepr ('SchemaObject fs) = (String, Schema)
38 CRepr ('SchemaArray ar s) = ArrayConstraint
40data TextConstraint
41 = TEq Nat
42 | TLe Nat
43 | TGt Nat
44 | TRegex Symbol
45 | TEnum [Symbol]
46 deriving (Generic)
48data instance Sing (tc :: TextConstraint) where
49 STEq :: (KnownNat n) => Sing n -> Sing ('TEq n)
50 STLe :: (KnownNat n) => Sing n -> Sing ('TLe n)
51 STGt :: (KnownNat n) => Sing n -> Sing ('TGt n)
52 STRegex :: (KnownSymbol s, Known (Sing s)) => Sing s -> Sing ('TRegex s)
53 STEnum :: (All KnownSymbol ss, Known (Sing ss)) => Sing ss -> Sing ('TEnum ss)
55instance (KnownNat n) => Known (Sing ('TEq n)) where known = STEq known
56instance (KnownNat n) => Known (Sing ('TGt n)) where known = STGt known
57instance (KnownNat n) => Known (Sing ('TLe n)) where known = STLe known
58instance (KnownSymbol s, Known (Sing s)) => Known (Sing ('TRegex s)) where known = STRegex known
59instance (All KnownSymbol ss, Known (Sing ss)) => Known (Sing ('TEnum ss)) where known = STEnum known
61instance Eq (Sing ('TEq n)) where _ == _ = True
62instance Eq (Sing ('TLe n)) where _ == _ = True
63instance Eq (Sing ('TGt n)) where _ == _ = True
64instance Eq (Sing ('TRegex t)) where _ == _ = True
65instance Eq (Sing ('TEnum ss)) where _ == _ = True
67data NumberConstraint
68 = NLe Nat
69 | NGt Nat
70 | NEq Nat
71 deriving (Generic)
73data instance Sing (nc :: NumberConstraint) where
74 SNEq :: KnownNat n => Sing n -> Sing ('NEq n)
75 SNGt :: KnownNat n => Sing n -> Sing ('NGt n)
76 SNLe :: KnownNat n => Sing n -> Sing ('NLe n)
78instance KnownNat n => Known (Sing ('NEq n)) where known = SNEq known
79instance KnownNat n => Known (Sing ('NGt n)) where known = SNGt known
80instance KnownNat n => Known (Sing ('NLe n)) where known = SNLe known
82instance Eq (Sing ('NEq n)) where _ == _ = True
83instance Eq (Sing ('NLe n)) where _ == _ = True
84instance Eq (Sing ('NGt n)) where _ == _ = True
86data ArrayConstraint
87 = AEq Nat
88 deriving (Generic)
90data instance Sing (ac :: ArrayConstraint) where
91 SAEq :: KnownNat n => Sing n -> Sing ('AEq n)
93instance KnownNat n => Known (Sing ('AEq n)) where known = SAEq known
95instance Eq (Sing ('AEq n)) where _ == _ = True
97data Schema
98 = SchemaText [TextConstraint]
99 | SchemaNumber [NumberConstraint]
100 | SchemaObject [(Symbol, Schema)]
101 | SchemaArray [ArrayConstraint] Schema
102 | SchemaNull
103 | SchemaOptional Schema
104 deriving (Generic)
106data instance Sing (schema :: Schema) where
107 SSchemaText :: Known (Sing tcs) => Sing tcs -> Sing ('SchemaText tcs)
108 SSchemaNumber :: Known (Sing ncs) => Sing ncs -> Sing ('SchemaNumber ncs)
109 SSchemaArray :: (Known (Sing acs), Known (Sing schema)) => Sing acs -> Sing schema -> Sing ('SchemaArray acs schema)
110 SSchemaObject :: Known (Sing fields) => Sing fields -> Sing ('SchemaObject fields)
111 SSchemaOptional :: Known (Sing s) => Sing s -> Sing ('SchemaOptional s)
112 SSchemaNull :: Sing 'SchemaNull
114instance Known (Sing sl) => Known (Sing ('SchemaText sl)) where
115 known = SSchemaText known
116instance Known (Sing sl) => Known (Sing ('SchemaNumber sl)) where
117 known = SSchemaNumber known
118instance Known (Sing 'SchemaNull) where
119 known = SSchemaNull
120instance (Known (Sing ac), Known (Sing s)) => Known (Sing ('SchemaArray ac s)) where
121 known = SSchemaArray known known
122instance Known (Sing stl) => Known (Sing ('SchemaObject stl)) where
123 known = SSchemaObject known
124instance Known (Sing s) => Known (Sing ('SchemaOptional s)) where
125 known = SSchemaOptional known
127instance Eq (Sing ('SchemaText cs)) where _ == _ = True
128instance Eq (Sing ('SchemaNumber cs)) where _ == _ = True
129instance Eq (Sing 'SchemaNull) where _ == _ = True
130instance Eq (Sing ('SchemaArray as s)) where _ == _ = True
131instance Eq (Sing ('SchemaObject cs)) where _ == _ = True
132instance Eq (Sing ('SchemaOptional s)) where _ == _ = True
134data FieldRepr :: (Symbol, Schema) -> Type where
135 FieldRepr
136 :: (Known (Sing schema), KnownSymbol name)
137 => JsonRepr schema
138 -> FieldRepr '(name, schema)
140knownFieldName
141 :: forall proxy (fieldName :: Symbol) schema
142 . KnownSymbol fieldName
143 => proxy '(fieldName, schema)
144 -> Text
145knownFieldName _ = T.pack $ symbolVal (Proxy @fieldName)
147knownFieldSchema
148 :: forall proxy fieldName schema
149 . Known (Sing schema)
150 => proxy '(fieldName, schema)
151 -> Sing schema
152knownFieldSchema _ = known
154deriving instance Show (JsonRepr schema) => Show (FieldRepr '(name, schema))
156instance Eq (JsonRepr schema) => Eq (FieldRepr '(name, schema)) where
157 FieldRepr a == FieldRepr b = a == b
159instance
160 ( KnownSymbol name
161 , Known (Sing schema)
162 , Serial m (JsonRepr schema) )
163 => Serial m (FieldRepr '(name, schema)) where
164 series = FieldRepr <$> series
166data JsonRepr :: Schema -> Type where
167 ReprText :: Text -> JsonRepr ('SchemaText cs)
168 ReprNumber :: Scientific -> JsonRepr ('SchemaNumber cs)
169 ReprNull :: JsonRepr 'SchemaNull
170 ReprArray :: V.Vector (JsonRepr s) -> JsonRepr ('SchemaArray cs s)
171 ReprObject :: Rec FieldRepr fs -> JsonRepr ('SchemaObject fs)
172 ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s)
174instance Show (JsonRepr ('SchemaText cs)) where
175 show (ReprText t) = "ReprText " P.++ show t
177instance Show (JsonRepr ('SchemaNumber cs)) where
178 show (ReprNumber n) = "ReprNumber " P.++ show n
180instance Show (JsonRepr 'SchemaNull) where show _ = "ReprNull"
182instance Show (JsonRepr s) => Show (JsonRepr ('SchemaArray acs s)) where
183 show (ReprArray v) = "ReprArray " P.++ show v
185instance RecAll FieldRepr fs Show => Show (JsonRepr ('SchemaObject fs)) where
186 show (ReprObject fs) = "ReprObject " P.++ show fs
188instance Show (JsonRepr s) => Show (JsonRepr ('SchemaOptional s)) where
189 show (ReprOptional s) = "ReprOptional " P.++ show s
191instance (Monad m, Serial m Text)
192 => Serial m (JsonRepr ('SchemaText cs)) where
193 series = cons1 ReprText
195instance (Monad m, Serial m Scientific)
196 => Serial m (JsonRepr ('SchemaNumber cs)) where
197 series = cons1 ReprNumber
199instance Monad m => Serial m (JsonRepr 'SchemaNull) where
200 series = cons0 ReprNull
202instance (Serial m (V.Vector (JsonRepr s)))
203 => Serial m (JsonRepr ('SchemaArray cs s)) where
204 series = cons1 ReprArray
206instance (Serial m (JsonRepr s))
207 => Serial m (JsonRepr ('SchemaOptional s)) where
208 series = cons1 ReprOptional
210instance (Monad m, Serial m (Rec FieldRepr fs))
211 => Serial m (JsonRepr ('SchemaObject fs)) where
212 series = cons1 ReprObject
214instance Eq (Rec FieldRepr fs) => Eq (JsonRepr ('SchemaObject fs)) where
215 ReprObject a == ReprObject b = a == b
217instance Eq (JsonRepr ('SchemaText cs)) where
218 ReprText a == ReprText b = a == b
220instance Eq (JsonRepr ('SchemaNumber cs)) where
221 ReprNumber a == ReprNumber b = a == b
223instance Eq (JsonRepr 'SchemaNull) where
224 ReprNull == ReprNull = True
226instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaArray as s)) where
227 ReprArray a == ReprArray b = a == b
229instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaOptional s)) where
230 ReprOptional a == ReprOptional b = a == b
232fromOptional
233 :: (Known (Sing s))
234 => Sing ('SchemaOptional s)
235 -> J.Value
236 -> Parser (Maybe (JsonRepr s))
237fromOptional _ = parseJSON
239instance Known (Sing schema) => J.FromJSON (JsonRepr schema) where
240 parseJSON value = case known :: Sing schema of
241 SSchemaText _ -> withText "String" (pure . ReprText) value
242 SSchemaNumber _ -> withScientific "Number" (pure . ReprNumber) value
243 SSchemaNull -> case value of
244 J.Null -> pure ReprNull
245 _ -> typeMismatch "Null" value
246 so@(SSchemaOptional _) -> ReprOptional <$> fromOptional so value
247 SSchemaArray _ _ -> withArray "Array" (fmap ReprArray . traverse parseJSON) value
248 SSchemaObject fs -> do
249 let
250 demoteFields :: SList s -> H.HashMap Text J.Value -> Parser (Rec FieldRepr s)
251 demoteFields SNil _ = pure RNil
252 demoteFields (SCons (STuple2 (n :: Sing fn) s) tl) h = withKnownSymbol n $ do
253 let fieldName = T.pack $ symbolVal (Proxy @fn)
254 fieldRepr <- case s of
255 SSchemaText _ -> case H.lookup fieldName h of
256 Just v -> FieldRepr <$> parseJSON v
257 Nothing -> fail "schematext"
258 SSchemaNumber _ -> case H.lookup fieldName h of
259 Just v -> FieldRepr <$> parseJSON v
260 Nothing -> fail "schemanumber"
261 SSchemaNull -> case H.lookup fieldName h of
262 Just v -> FieldRepr <$> parseJSON v
263 Nothing -> fail "schemanull"
264 SSchemaArray _ _ -> case H.lookup fieldName h of
265 Just v -> FieldRepr <$> parseJSON v
266 Nothing -> fail "schemaarray"
267 SSchemaObject _ -> case H.lookup fieldName h of
268 Just v -> FieldRepr <$> parseJSON v
269 Nothing -> fail "schemaobject"
270 SSchemaOptional _ -> case H.lookup fieldName h of
271 Just v -> FieldRepr <$> parseJSON v
272 Nothing -> fail "schemaoptional"
273 (fieldRepr :&) <$> demoteFields tl h
274 ReprObject <$> withObject "Object" (demoteFields fs) value
276instance J.ToJSON (JsonRepr a) where
277 toJSON ReprNull = J.Null
278 toJSON (ReprText t) = J.String t
279 toJSON (ReprNumber n) = J.Number n
280 toJSON (ReprOptional s) = case s of
281 Just v -> toJSON v
282 Nothing -> J.Null
283 toJSON (ReprArray v) = J.Array $ toJSON <$> v
284 toJSON (ReprObject r) = J.Object . H.fromList . fold $ r
285 where
286 extract :: forall name s . (KnownSymbol name)
287 => FieldRepr '(name, s)
288 -> (Text, Value)
289 extract (FieldRepr s) = (T.pack $ symbolVal $ Proxy @name, toJSON s)
290 fold :: Rec FieldRepr fs -> [(Text, J.Value)]
291 fold = \case
292 RNil -> []
293 fr@(FieldRepr _) :& tl -> (extract fr) : fold tl
295class FalseConstraint a
297type family TopLevel (schema :: Schema) :: Constraint where
298 TopLevel ('SchemaArray acs s) = ()
299 TopLevel ('SchemaObject o) = ()
300 TopLevel spec = FalseConstraint spec