@@ -1,37 +1,35 @@
11{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE CPP #-}
3−{-# LANGUAGE OverloadedLists #-}
4−{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE OverloadedLists #-}
3+{-# LANGUAGE OverloadedStrings #-}
54{-# OPTIONS_GHC -fprint-explicit-kinds #-}
65
76module Data.Schematic.Schema where
87
9−import Control.Applicative ((<|>))
8+import Control.Applicative ()
109import Control.Monad
1110import Data.Aeson as J
1211import Data.Aeson.Types as J
1312import Data.HashMap.Strict as H
1413import Data.Kind
1514import Data.Maybe
16−import Data.Schematic.Generator
1715import Data.Schematic.Instances ()
1816import Data.Scientific
19−import Data.Singletons.Prelude.List hiding (All, Union)
17+import Data.Singletons.Prelude.List hiding (All)
2018import Data.Singletons.TH
2119import Data.Singletons.TypeLits
2220import Data.Text as T
23−import Data.Union
2421import Data.Vector as V
2522import Data.Vinyl hiding (Dict)
2623import qualified Data.Vinyl.TypeLevel as V
27−import GHC.Exts
2824import GHC.Generics (Generic)
29−import GHC.TypeLits
30− (SomeNat(..), SomeSymbol(..), someNatVal, someSymbolVal)
3125import Prelude as P
3226import Test.SmallCheck.Series
3327
3428
29+type family All (c :: k -> Constraint) (s :: [k]) :: Constraint where
30+ All c '[] = ()
31+ All c (a ': as) = (c a, All c as)
32+
3533type family CRepr (s :: Schema) :: Type where
3634 CRepr ('SchemaText cs) = TextConstraint
3735 CRepr ('SchemaNumber cs) = NumberConstraint
@@ -40,235 +38,77 @@ type family CRepr (s :: Schema) :: Type where
4038
4139data TextConstraint
4240 = TEq Nat
43− | TLt Nat
4441 | TLe Nat
4542 | TGt Nat
46− | TGe Nat
4743 | TRegex Symbol
4844 | TEnum [Symbol]
4945 deriving (Generic)
5046
51−instance SingKind TextConstraint where
52− type Demote TextConstraint = DemotedTextConstraint
53− fromSing = \case
54− STEq n -> withKnownNat n (DTEq . fromIntegral $ natVal n)
55− STLt n -> withKnownNat n (DTLt . fromIntegral $ natVal n)
56− STLe n -> withKnownNat n (DTLe . fromIntegral $ natVal n)
57− STGt n -> withKnownNat n (DTGt . fromIntegral $ natVal n)
58− STGe n -> withKnownNat n (DTGe . fromIntegral $ natVal n)
59− STRegex s -> withKnownSymbol s (DTRegex $ T.pack $ symbolVal s)
60− STEnum s -> let
61− d :: Sing (s :: [Symbol]) -> [Text]
62− d SNil = []
63− d (SCons ss@SSym fs) = T.pack (symbolVal ss) : d fs
64− in DTEnum $ d s
65− toSing = \case
66− DTEq n -> case someNatVal n of
67− Just (SomeNat (_ :: Proxy n)) -> SomeSing (STEq (SNat :: Sing n))
68− Nothing -> error "Negative singleton nat"
69− DTLt n -> case someNatVal n of
70− Just (SomeNat (_ :: Proxy n)) -> SomeSing (STLt (SNat :: Sing n))
71− Nothing -> error "Negative singleton nat"
72− DTLe n -> case someNatVal n of
73− Just (SomeNat (_ :: Proxy n)) -> SomeSing (STLe (SNat :: Sing n))
74− Nothing -> error "Negative singleton nat"
75− DTGt n -> case someNatVal n of
76− Just (SomeNat (_ :: Proxy n)) -> SomeSing (STGt (SNat :: Sing n))
77− Nothing -> error "Negative singleton nat"
78− DTGe n -> case someNatVal n of
79− Just (SomeNat (_ :: Proxy n)) -> SomeSing (STGe (SNat :: Sing n))
80− Nothing -> error "Negative singleton nat"
81− DTRegex s -> case someSymbolVal (T.unpack s) of
82− SomeSymbol (_ :: Proxy n) -> SomeSing (STRegex (SSym :: Sing n))
83− DTEnum ss -> case toSing ss of
84− SomeSing l -> SomeSing (STEnum l)
85−
86−data DemotedTextConstraint
87− = DTEq Integer
88− | DTLt Integer
89− | DTLe Integer
90− | DTGt Integer
91− | DTGe Integer
92− | DTRegex Text
93− | DTEnum [Text]
94− deriving (Generic, Eq, Show)
95−
9647data instance Sing (tc :: TextConstraint) where
9748 STEq :: Sing n -> Sing ('TEq n)
98− STLt :: Sing n -> Sing ('TLt n)
9949 STLe :: Sing n -> Sing ('TLe n)
10050 STGt :: Sing n -> Sing ('TGt n)
101− STGe :: Sing n -> Sing ('TGe n)
10251 STRegex :: Sing s -> Sing ('TRegex s)
103− STEnum :: Sing ss -> Sing ('TEnum ss)
52+ STEnum :: All KnownSymbol ss => Sing ss -> Sing ('TEnum ss)
10453
10554instance (KnownNat n) => SingI ('TEq n) where sing = STEq sing
10655instance (KnownNat n) => SingI ('TGt n) where sing = STGt sing
107−instance (KnownNat n) => SingI ('TGe n) where sing = STGe sing
108−instance (KnownNat n) => SingI ('TLt n) where sing = STLt sing
10956instance (KnownNat n) => SingI ('TLe n) where sing = STLe sing
11057instance (KnownSymbol s, SingI s) => SingI ('TRegex s) where sing = STRegex sing
111−instance (SingI ss) => SingI ('TEnum ss) where sing = STEnum sing
58+instance (All KnownSymbol ss, SingI ss) => SingI ('TEnum ss) where sing = STEnum sing
11259
11360instance Eq (Sing ('TEq n)) where _ == _ = True
114−instance Eq (Sing ('TLt n)) where _ == _ = True
11561instance Eq (Sing ('TLe n)) where _ == _ = True
11662instance Eq (Sing ('TGt n)) where _ == _ = True
117−instance Eq (Sing ('TGe n)) where _ == _ = True
11863instance Eq (Sing ('TRegex t)) where _ == _ = True
11964instance Eq (Sing ('TEnum ss)) where _ == _ = True
12065
12166data NumberConstraint
12267 = NLe Nat
123− | NLt Nat
12468 | NGt Nat
125− | NGe Nat
12669 | NEq Nat
12770 deriving (Generic)
12871
129−data DemotedNumberConstraint
130− = DNLe Integer
131− | DNLt Integer
132− | DNGt Integer
133− | DNGe Integer
134− | DNEq Integer
135− deriving (Generic, Eq, Show)
136−
13772data instance Sing (nc :: NumberConstraint) where
13873 SNEq :: Sing n -> Sing ('NEq n)
13974 SNGt :: Sing n -> Sing ('NGt n)
140− SNGe :: Sing n -> Sing ('NGe n)
141− SNLt :: Sing n -> Sing ('NLt n)
14275 SNLe :: Sing n -> Sing ('NLe n)
14376
14477instance KnownNat n => SingI ('NEq n) where sing = SNEq sing
14578instance KnownNat n => SingI ('NGt n) where sing = SNGt sing
146−instance KnownNat n => SingI ('NGe n) where sing = SNGe sing
147−instance KnownNat n => SingI ('NLt n) where sing = SNLt sing
14879instance KnownNat n => SingI ('NLe n) where sing = SNLe sing
14980
15081instance Eq (Sing ('NEq n)) where _ == _ = True
151−instance Eq (Sing ('NLt n)) where _ == _ = True
15282instance Eq (Sing ('NLe n)) where _ == _ = True
15383instance Eq (Sing ('NGt n)) where _ == _ = True
154−instance Eq (Sing ('NGe n)) where _ == _ = True
155−
156−instance SingKind NumberConstraint where
157− type Demote NumberConstraint = DemotedNumberConstraint
158− fromSing = \case
159− SNEq n -> withKnownNat n (DNEq . fromIntegral $ natVal n)
160− SNGt n -> withKnownNat n (DNGt . fromIntegral $ natVal n)
161− SNGe n -> withKnownNat n (DNGe . fromIntegral $ natVal n)
162− SNLt n -> withKnownNat n (DNLt . fromIntegral $ natVal n)
163− SNLe n -> withKnownNat n (DNLe . fromIntegral $ natVal n)
164− toSing = \case
165− DNEq n -> case someNatVal n of
166− Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNEq (SNat :: Sing n))
167− Nothing -> error "Negative singleton nat"
168− DNGt n -> case someNatVal n of
169− Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNGt (SNat :: Sing n))
170− Nothing -> error "Negative singleton nat"
171− DNGe n -> case someNatVal n of
172− Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNGe (SNat :: Sing n))
173− Nothing -> error "Negative singleton nat"
174− DNLt n -> case someNatVal n of
175− Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNLt (SNat :: Sing n))
176− Nothing -> error "Negative singleton nat"
177− DNLe n -> case someNatVal n of
178− Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNLe (SNat :: Sing n))
179− Nothing -> error "Negative singleton nat"
18084
18185data ArrayConstraint
18286 = AEq Nat
183− | AGt Nat
184− | AGe Nat
185− | ALt Nat
186− | ALe Nat
18787 deriving (Generic)
18888
189−data DemotedArrayConstraint
190− = DAEq Integer
191− | DAGt Integer
192− | DAGe Integer
193− | DALt Integer
194− | DALe Integer
195− deriving (Generic, Eq, Show)
196−
19789data instance Sing (ac :: ArrayConstraint) where
19890 SAEq :: Sing n -> Sing ('AEq n)
199− SAGt :: Sing n -> Sing ('AGt n)
200− SAGe :: Sing n -> Sing ('AGe n)
201− SALt :: Sing n -> Sing ('ALt n)
202− SALe :: Sing n -> Sing ('ALe n)
20391
20492instance KnownNat n => SingI ('AEq n) where sing = SAEq sing
205−instance KnownNat n => SingI ('AGt n) where sing = SAGt sing
206−instance KnownNat n => SingI ('AGe n) where sing = SAGe sing
207−instance KnownNat n => SingI ('ALt n) where sing = SALt sing
208−instance KnownNat n => SingI ('ALe n) where sing = SALe sing
20993
21094instance Eq (Sing ('AEq n)) where _ == _ = True
211−instance Eq (Sing ('AGt n)) where _ == _ = True
212−instance Eq (Sing ('AGe n)) where _ == _ = True
213−instance Eq (Sing ('ALt n)) where _ == _ = True
214−instance Eq (Sing ('ALe n)) where _ == _ = True
215−
216−instance SingKind ArrayConstraint where
217− type Demote ArrayConstraint = DemotedArrayConstraint
218− fromSing = \case
219− SAEq n -> withKnownNat n (DAEq . fromIntegral $ natVal n)
220− SAGt n -> withKnownNat n (DAGt . fromIntegral $ natVal n)
221− SAGe n -> withKnownNat n (DAGe . fromIntegral $ natVal n)
222− SALt n -> withKnownNat n (DALt . fromIntegral $ natVal n)
223− SALe n -> withKnownNat n (DALe . fromIntegral $ natVal n)
224− toSing = \case
225− DAEq n -> case someNatVal n of
226− Just (SomeNat (_ :: Proxy n)) -> SomeSing (SAEq (SNat :: Sing n))
227− Nothing -> error "Negative singleton nat"
228− DAGt n -> case someNatVal n of
229− Just (SomeNat (_ :: Proxy n)) -> SomeSing (SAGt (SNat :: Sing n))
230− Nothing -> error "Negative singleton nat"
231− DAGe n -> case someNatVal n of
232− Just (SomeNat (_ :: Proxy n)) -> SomeSing (SAGe (SNat :: Sing n))
233− Nothing -> error "Negative singleton nat"
234− DALt n -> case someNatVal n of
235− Just (SomeNat (_ :: Proxy n)) -> SomeSing (SALt (SNat :: Sing n))
236− Nothing -> error "Negative singleton nat"
237− DALe n -> case someNatVal n of
238− Just (SomeNat (_ :: Proxy n)) -> SomeSing (SALe (SNat :: Sing n))
239− Nothing -> error "Negative singleton nat"
24095
24196data Schema
24297 = SchemaText [TextConstraint]
243− | SchemaBoolean
24498 | SchemaNumber [NumberConstraint]
24599 | SchemaObject [(Symbol, Schema)]
246100 | SchemaArray [ArrayConstraint] Schema
247101 | SchemaNull
248102 | SchemaOptional Schema
249− | SchemaUnion [Schema]
250103 deriving (Generic)
251104
252−data DemotedSchema
253− = DSchemaText [DemotedTextConstraint]
254− | DSchemaNumber [DemotedNumberConstraint]
255− | DSchemaBoolean
256− | DSchemaObject [(Text, DemotedSchema)]
257− | DSchemaArray [DemotedArrayConstraint] DemotedSchema
258− | DSchemaNull
259− | DSchemaOptional DemotedSchema
260− | DSchemaUnion [DemotedSchema]
261− deriving (Generic, Eq, Show)
262−
263105data instance Sing (schema :: Schema) where
264106 SSchemaText :: Sing tcs -> Sing ('SchemaText tcs)
265107 SSchemaNumber :: Sing ncs -> Sing ('SchemaNumber ncs)
266− SSchemaBoolean :: Sing 'SchemaBoolean
267108 SSchemaArray :: Sing acs -> Sing schema -> Sing ('SchemaArray acs schema)
268109 SSchemaObject :: Sing fields -> Sing ('SchemaObject fields)
269110 SSchemaOptional :: Sing s -> Sing ('SchemaOptional s)
270111 SSchemaNull :: Sing 'SchemaNull
271− SSchemaUnion :: Sing ss -> Sing ('SchemaUnion ss)
272112
273113instance SingI sl => SingI ('SchemaText sl) where
274114 sing = SSchemaText sing
@@ -276,52 +116,19 @@ instance SingI sl => SingI ('SchemaNumber sl) where
276116 sing = SSchemaNumber sing
277117instance SingI 'SchemaNull where
278118 sing = SSchemaNull
279−instance SingI 'SchemaBoolean where
280− sing = SSchemaBoolean
281119instance (SingI ac, SingI s) => SingI ('SchemaArray ac s) where
282120 sing = SSchemaArray sing sing
283121instance SingI stl => SingI ('SchemaObject stl) where
284122 sing = SSchemaObject sing
285123instance SingI s => SingI ('SchemaOptional s) where
286124 sing = SSchemaOptional sing
287−instance SingI s => SingI ('SchemaUnion s) where
288− sing = SSchemaUnion sing
289125
290126instance Eq (Sing ('SchemaText cs)) where _ == _ = True
291127instance Eq (Sing ('SchemaNumber cs)) where _ == _ = True
292128instance Eq (Sing 'SchemaNull) where _ == _ = True
293−instance Eq (Sing 'SchemaBoolean) where _ == _ = True
294129instance Eq (Sing ('SchemaArray as s)) where _ == _ = True
295130instance Eq (Sing ('SchemaObject cs)) where _ == _ = True
296131instance Eq (Sing ('SchemaOptional s)) where _ == _ = True
297−instance Eq (Sing ('SchemaUnion s)) where _ == _ = True
298−
299−instance SingKind Schema where
300− type Demote Schema = DemotedSchema
301− fromSing = \case
302− SSchemaText cs -> DSchemaText $ fromSing cs
303− SSchemaNumber cs -> DSchemaNumber $ fromSing cs
304− SSchemaBoolean -> DSchemaBoolean
305− SSchemaArray cs s -> DSchemaArray (fromSing cs) (fromSing s)
306− SSchemaOptional s -> DSchemaOptional $ fromSing s
307− SSchemaNull -> DSchemaNull
308− SSchemaObject cs -> DSchemaObject $ fromSing cs
309− SSchemaUnion ss -> DSchemaUnion $ fromSing ss
310− toSing = \case
311− DSchemaText cs -> case toSing cs of
312− SomeSing scs -> SomeSing $ SSchemaText scs
313− DSchemaNumber cs -> case toSing cs of
314− SomeSing scs -> SomeSing $ SSchemaNumber scs
315− DSchemaBoolean -> SomeSing $ SSchemaBoolean
316− DSchemaArray cs sch -> case (toSing cs, toSing sch) of
317− (SomeSing scs, SomeSing ssch) -> SomeSing $ SSchemaArray scs ssch
318− DSchemaOptional sch -> case toSing sch of
319− SomeSing ssch -> SomeSing $ SSchemaOptional ssch
320− DSchemaNull -> SomeSing SSchemaNull
321− DSchemaObject cs -> case toSing cs of
322− SomeSing scs -> SomeSing $ SSchemaObject scs
323− DSchemaUnion ss -> case toSing ss of
324− SomeSing sss -> SomeSing $ SSchemaUnion sss
325132
326133data FieldRepr :: (Symbol, Schema) -> Type where
327134 FieldRepr
@@ -359,77 +166,53 @@ instance
359166 => Serial m (FieldRepr '(name, schema)) where
360167 series = FieldRepr <$> series
361168
362−type family USubsets (u :: [k]) :: Constraint where
363− USubsets '[] = ()
364− USubsets (h ': tl) = (USubset tl (h ': tl) (V.RImage tl (h ': tl)), USubsets tl)
365−
366169data JsonRepr :: Schema -> Type where
367170 ReprText :: Text -> JsonRepr ('SchemaText cs)
368171 ReprNumber :: Scientific -> JsonRepr ('SchemaNumber cs)
369− ReprBoolean :: Bool -> JsonRepr 'SchemaBoolean
370172 ReprNull :: JsonRepr 'SchemaNull
371173 ReprArray :: V.Vector (JsonRepr s) -> JsonRepr ('SchemaArray cs s)
372174 ReprObject :: Rec FieldRepr fs -> JsonRepr ('SchemaObject fs)
373175 ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s)
374− ReprUnion :: Union JsonRepr (h ': tl) -> JsonRepr ('SchemaUnion (h ': tl))
375−
376−instance (Monad m, Serial m Text, SingI cs)
377− => Serial m (JsonRepr ('SchemaText cs)) where
378− series = decDepth $ fmap ReprText $ textSeries $ fromSing (sing :: Sing cs)
379−
380−instance (Monad m, Serial m Scientific, SingI cs)
381− => Serial m (JsonRepr ('SchemaNumber cs)) where
382− series = decDepth $ fmap ReprNumber
383− $ numberSeries $ fromSing (sing :: Sing cs)
384−
385−instance Monad m => Serial m (JsonRepr 'SchemaNull) where
386− series = cons0 ReprNull
387−
388−instance (Serial m (JsonRepr s), Serial m (V.Vector (JsonRepr s)), SingI cs)
389− => Serial m (JsonRepr ('SchemaArray cs s)) where
390− series = decDepth $ fmap ReprArray
391− $ arraySeries $ fromSing (sing :: Sing cs)
392176
393−instance (Serial m (JsonRepr s))
394− => Serial m (JsonRepr ('SchemaOptional s)) where
395− series = cons1 ReprOptional
396−
397−instance (Monad m, Serial m (Rec FieldRepr fs))
398− => Serial m (JsonRepr ('SchemaObject fs)) where
399− series = cons1 ReprObject
400−
401−-- | Move to the union package
402177instance Show (JsonRepr ('SchemaText cs)) where
403178 show (ReprText t) = "ReprText " P.++ show t
404179
405180instance Show (JsonRepr ('SchemaNumber cs)) where
406181 show (ReprNumber n) = "ReprNumber " P.++ show n
407182
408−instance Show (JsonRepr 'SchemaBoolean) where
409− show (ReprBoolean n) = "ReprBoolean " P.++ show n
410−
411183instance Show (JsonRepr 'SchemaNull) where show _ = "ReprNull"
412184
413185instance Show (JsonRepr s) => Show (JsonRepr ('SchemaArray acs s)) where
414186 show (ReprArray v) = "ReprArray " P.++ show v
415187
416−#if MIN_VERSION_base(4,12,0)
417−instance
418− ( V.RecAll FieldRepr fs Show, RMap fs, ReifyConstraint Show FieldRepr fs
419− , RecordToList fs )
420− => Show (JsonRepr ('SchemaObject fs)) where
421− show (ReprObject fs) = "ReprObject " P.++ show fs
422−#else
423188instance V.RecAll FieldRepr fs Show => Show (JsonRepr ('SchemaObject fs)) where
424189 show (ReprObject fs) = "ReprObject " P.++ show fs
425−#endif
426190
427191instance Show (JsonRepr s) => Show (JsonRepr ('SchemaOptional s)) where
428192 show (ReprOptional s) = "ReprOptional " P.++ show s
429193
430−instance Show (Union JsonRepr (h ': tl))
431− => Show (JsonRepr ('SchemaUnion (h ': tl))) where
432− show (ReprUnion s) = "ReprUnion " P.++ show s
194+instance (Monad m, Serial m Text)
195+ => Serial m (JsonRepr ('SchemaText cs)) where
196+ series = cons1 ReprText
197+
198+instance (Monad m, Serial m Scientific)
199+ => Serial m (JsonRepr ('SchemaNumber cs)) where
200+ series = cons1 ReprNumber
201+
202+instance Monad m => Serial m (JsonRepr 'SchemaNull) where
203+ series = cons0 ReprNull
204+
205+instance (Serial m (V.Vector (JsonRepr s)))
206+ => Serial m (JsonRepr ('SchemaArray cs s)) where
207+ series = cons1 ReprArray
208+
209+instance (Serial m (JsonRepr s))
210+ => Serial m (JsonRepr ('SchemaOptional s)) where
211+ series = cons1 ReprOptional
212+
213+instance (Monad m, Serial m (Rec FieldRepr fs))
214+ => Serial m (JsonRepr ('SchemaObject fs)) where
215+ series = cons1 ReprObject
433216
434217instance Eq (Rec FieldRepr fs) => Eq (JsonRepr ('SchemaObject fs)) where
435218 ReprObject a == ReprObject b = a == b
@@ -440,9 +223,6 @@ instance Eq (JsonRepr ('SchemaText cs)) where
440223instance Eq (JsonRepr ('SchemaNumber cs)) where
441224 ReprNumber a == ReprNumber b = a == b
442225
443−instance Eq (JsonRepr 'SchemaBoolean) where
444− ReprBoolean a == ReprBoolean b = a == b
445−
446226instance Eq (JsonRepr 'SchemaNull) where
447227 ReprNull == ReprNull = True
448228
@@ -452,51 +232,6 @@ instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaArray as s)) where
452232instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaOptional s)) where
453233 ReprOptional a == ReprOptional b = a == b
454234
455−instance Eq (Union JsonRepr (h ': tl))
456− => Eq (JsonRepr ('SchemaUnion (h ': tl))) where
457− ReprUnion a == ReprUnion b = a == b
458−
459−instance Ord (Rec FieldRepr fs) => Ord (JsonRepr ('SchemaObject fs)) where
460− ReprObject a `compare` ReprObject b = a `compare` b
461−
462−instance Ord (JsonRepr ('SchemaText cs)) where
463− ReprText a `compare` ReprText b = a `compare` b
464−
465−instance Ord (JsonRepr ('SchemaNumber cs)) where
466− ReprNumber a `compare` ReprNumber b = a `compare` b
467−
468−instance Ord (JsonRepr 'SchemaBoolean) where
469− ReprBoolean a `compare` ReprBoolean b = a `compare` b
470−
471−instance Ord (JsonRepr 'SchemaNull) where
472− compare _ _ = EQ
473−
474−instance Ord (JsonRepr s) => Ord (JsonRepr ('SchemaArray as s)) where
475− ReprArray a `compare` ReprArray b = a `compare` b
476−
477−instance Ord (JsonRepr s) => Ord (JsonRepr ('SchemaOptional s)) where
478− ReprOptional a `compare` ReprOptional b = a `compare` b
479−
480−instance Ord (Union JsonRepr (h ': tl))
481− => Ord (JsonRepr ('SchemaUnion (h ': tl))) where
482− ReprUnion a `compare` ReprUnion b = a `compare` b
483−
484−instance IsList (JsonRepr ('SchemaArray cs s)) where
485− type Item (JsonRepr ('SchemaArray cs s)) = JsonRepr s
486− fromList = ReprArray . GHC.Exts.fromList
487− toList (ReprArray v) = GHC.Exts.toList v
488−
489−instance Num (JsonRepr ('SchemaNumber cs)) where
490− ReprNumber a + ReprNumber b = ReprNumber $ a + b
491− ReprNumber a - ReprNumber b = ReprNumber $ a - b
492− ReprNumber a * ReprNumber b = ReprNumber $ a * b
493− abs (ReprNumber a) = ReprNumber $ abs a
494− signum (ReprNumber a) = ReprNumber $ signum a
495− fromInteger = ReprNumber . fromIntegral
496−
497−instance IsString (JsonRepr ('SchemaText cs)) where
498− fromString = ReprText . fromString
499−
500235fromOptional
501236 :: SingI s
502237 => Sing ('SchemaOptional s)
@@ -504,29 +239,10 @@ fromOptional
504239 -> Parser (Maybe (JsonRepr s))
505240fromOptional _ = parseJSON
506241
507−parseUnion
508− :: FromJSON (JsonRepr ('SchemaUnion ss))
509− => sing (ss :: [Schema])
510− -> Value
511− -> Parser (JsonRepr ('SchemaUnion ss))
512−parseUnion _ val = parseJSON val
513−
514−instance FromJSON (Union JsonRepr '[]) where
515− parseJSON = fail "empty union"
516−
517−instance (SingI a, FromJSON (Union JsonRepr as)) => FromJSON (Union JsonRepr (a ': as)) where
518− parseJSON val = (This <$> parseJSON val)
519− <|> (That <$> (parseJSON val :: Parser (Union JsonRepr as)))
520−
521−instance ToJSON (Union JsonRepr as) where
522− toJSON (This fa) = toJSON fa
523− toJSON (That u) = toJSON u
524−
525242instance SingI schema => J.FromJSON (JsonRepr schema) where
526243 parseJSON value = case sing :: Sing schema of
527244 SSchemaText _ -> withText "String" (pure . ReprText) value
528245 SSchemaNumber _ -> withScientific "Number" (pure . ReprNumber) value
529− SSchemaBoolean -> ReprBoolean <$> parseJSON value
530246 SSchemaNull -> case value of
531247 J.Null -> pure ReprNull
532248 _ -> typeMismatch "Null" value
@@ -542,37 +258,31 @@ instance SingI schema => J.FromJSON (JsonRepr schema) where
542258 fieldRepr <- case s of
543259 SSchemaText so -> case H.lookup fieldName h of
544260 Just v -> withSingI so $ FieldRepr <$> parseJSON v
545− Nothing -> fail $ "No text field: " P.++ show fieldName
261+ Nothing -> fail "schematext"
546262 SSchemaNumber so -> case H.lookup fieldName h of
547263 Just v -> withSingI so $ FieldRepr <$> parseJSON v
548− Nothing -> fail $ "No number field: " P.++ show fieldName
549− SSchemaBoolean -> case H.lookup fieldName h of
550− Just v -> FieldRepr <$> parseJSON v
551− Nothing -> fail $ "No boolean field: " P.++ show fieldName
264+ Nothing -> fail "schemanumber"
552265 SSchemaNull -> case H.lookup fieldName h of
553266 Just v -> FieldRepr <$> parseJSON v
554− Nothing -> fail $ "No null field: " P.++ show fieldName
267+ Nothing -> fail "schemanull"
555268 SSchemaArray sa sb -> case H.lookup fieldName h of
556269 Just v -> withSingI sa $ withSingI sb $ FieldRepr <$> parseJSON v
557− Nothing -> fail $ "No array field: " P.++ show fieldName
270+ Nothing -> fail "schemaarray"
558271 SSchemaObject so -> case H.lookup fieldName h of
559272 Just v -> withSingI so $ FieldRepr <$> parseJSON v
560− Nothing -> fail $ "No object field" P.++ show fieldName
273+ Nothing -> fail "schemaobject"
561274 SSchemaOptional so -> case H.lookup fieldName h of
562275 Just v -> withSingI so $ FieldRepr <$> parseJSON v
563− Nothing -> withSingI so $ pure $ FieldRepr $ ReprOptional Nothing
564− SSchemaUnion ss -> withSingI ss $ FieldRepr <$> parseUnion ss value
276+ Nothing -> fail "schemaoptional"
565277 (fieldRepr :&) <$> demoteFields tl h
566278 ReprObject <$> withObject "Object" (demoteFields fs) value
567− SSchemaUnion ss -> parseUnion ss value
568279
569280instance J.ToJSON (JsonRepr a) where
570281 toJSON ReprNull = J.Null
571− toJSON (ReprBoolean b) = J.Bool b
572282 toJSON (ReprText t) = J.String t
573283 toJSON (ReprNumber n) = J.Number n
574284 toJSON (ReprOptional s) = case s of
575− Just v -> toJSON v
285+ Just v -> toJSON v
576286 Nothing -> J.Null
577287 toJSON (ReprArray v) = J.Array $ toJSON <$> v
578288 toJSON (ReprObject r) = J.Object . H.fromList . fold $ r
@@ -585,7 +295,6 @@ instance J.ToJSON (JsonRepr a) where
585295 fold = \case
586296 RNil -> []
587297 fr@(FieldRepr _) :& tl -> (extract fr) : fold tl
588− toJSON (ReprUnion u) = toJSON u
589298
590299class FalseConstraint a
591300