Skip to content

Commit 2f9a6a2

Browse files
odrodr
committed
Upd: Validation for Union
1 parent 7b4ac91 commit 2f9a6a2

File tree

12 files changed

+62
-145
lines changed

12 files changed

+62
-145
lines changed

‎src/Data/Schematic/Compat.hs‎

Lines changed: 20 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -2,22 +2,33 @@
22
{-# LANGUAGE CPP #-}
33
module Data.Schematic.Compat where
44

5-
import Data.Singletons
65
import Data.Singletons.Prelude
7-
import Data.Singletons.TypeLits
6+
import GHC.TypeLits
7+
#if MIN_VERSION_base(4,12,0)
8+
import Data.Vinyl
9+
#else
10+
import Data.Kind
11+
#endif
12+
813

914
type DeNat = Demote Nat
1015
-- ^ Demote Nat is depends on version of singletons
1116

12-
#if !MIN_VERSION_base(4,11,0)
13-
type (:+++) a b = (:++) a b
14-
#else
17+
demote' :: forall a. (SingI a, SingKind (KindOf a)) => Demote (KindOf a)
18+
#if MIN_VERSION_singletons(2,4,0)
1519
type (:+++) a b = (++) a b
20+
demote' = demote @a
21+
#else
22+
type (:+++) a b = (:++) a b
23+
demote' = fromSing (sing :: Sing a)
1624
#endif
1725

18-
demote' :: forall a. (SingI a, SingKind (KindOf a)) => Demote (KindOf a)
19-
#if !MIN_VERSION_base(4,12,0)
20-
demote' = fromSing (sing :: Sing a)
26+
#if MIN_VERSION_vinyl(0,9,0)
27+
type RMapCompat fs = RMap fs
28+
type ReifyConstraintCompat c repr fs = ReifyConstraint c repr fs
29+
type RecordToListCompat fs = RecordToList fs
2130
#else
22-
demote' = demote @a
31+
type RMapCompat fs = (() :: Constraint)
32+
type ReifyConstraintCompat c fs repr = (() :: Constraint)
33+
type RecordToListCompat fs = (() :: Constraint)
2334
#endif

‎src/Data/Schematic/DSL.hs‎

Lines changed: 0 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,4 @@
11
{-# LANGUAGE AllowAmbiguousTypes #-}
2-
{-# LANGUAGE CPP #-}
32

43
module Data.Schematic.DSL where
54

@@ -18,20 +17,12 @@ import Data.Vinyl
1817
import Data.Vinyl.Functor
1918

2019

21-
-- #if MIN_VERSION_base(4,12,0)
2220
type Constructor a
2321
= forall fields b
2422
. ( fields ~ FieldsOf a, FSubset fields b (FImage fields b)
2523
, ReprObjectConstr fields )
2624
=> Rec (Tagged fields :. FieldRepr) b
2725
-> JsonRepr ('SchemaObject fields)
28-
-- #else
29-
-- type Constructor a
30-
-- = forall fields b
31-
-- . (fields ~ FieldsOf a, FSubset fields b (FImage fields b))
32-
-- => Rec (Tagged fields :. FieldRepr) b
33-
-- -> JsonRepr ('SchemaObject fields)
34-
-- #endif
3526

3627
withRepr :: Constructor a
3728
withRepr = ReprObject . rmap (unTagged . getCompose) . fcast
@@ -63,19 +54,6 @@ instance (SingI (h ': tl), ReprUnionConstr tl)
6354
=> Representable ('SchemaUnion (h ': tl)) where
6455
constructField sfn _ u = withKnownSymbol sfn $ FieldRepr $ ReprUnion u
6556

66-
-- construct :: Sing s -> Repr s -> JsonRepr s
67-
-- construct s r = case s of
68-
-- SSchemaObject _ -> ReprObject r
69-
-- SSchemaArray _ _ -> ReprArray r
70-
-- SSchemaText _ -> ReprText r
71-
-- SSchemaNumber _ -> ReprNumber r
72-
-- SSchemaBoolean -> ReprBoolean r
73-
-- SSchemaOptional _ -> ReprOptional r
74-
-- SSchemaNull -> ReprNull
75-
-- SSchemaUnion ss -> case ss of
76-
-- SNil -> error "unconstructable union"
77-
-- SCons _ _ -> ReprUnion r
78-
7957
type family FieldsOf (s :: Schema) :: [(Symbol, Schema)] where
8058
FieldsOf ('SchemaObject fs) = fs
8159

‎src/Data/Schematic/Generator.hs‎

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -7,7 +7,6 @@ import Data.Schematic.Generator.Regex
77
import Data.Schematic.Verifier
88
import Data.Scientific
99
import Data.Text (Text, pack)
10-
-- import qualified Data.Vector as V
1110
import Test.SmallCheck.Series
1211

1312

‎src/Data/Schematic/Instances.hs‎

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,3 @@
1-
{-# LANGUAGE AllowAmbiguousTypes #-}
21
{-# OPTIONS_GHC -fno-warn-orphans #-}
32

43
module Data.Schematic.Instances where

‎src/Data/Schematic/JsonSchema.hs‎

Lines changed: 0 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,3 @@
1-
{-# LANGUAGE AllowAmbiguousTypes #-}
2-
{-# LANGUAGE OverloadedLabels #-}
3-
{-# LANGUAGE RecordWildCards #-}
4-
{-# LANGUAGE TemplateHaskell #-}
5-
61
module Data.Schematic.JsonSchema
72
( toJsonSchema
83
, toJsonSchema'

‎src/Data/Schematic/Lens.hs‎

Lines changed: 0 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,3 @@
1-
{-# LANGUAGE AllowAmbiguousTypes #-}
2-
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3-
{-# LANGUAGE InstanceSigs #-}
4-
{-# LANGUAGE UndecidableSuperClasses #-}
5-
61
module Data.Schematic.Lens
72
( FIndex
83
, FElem(..)

‎src/Data/Schematic/Migration.hs‎

Lines changed: 0 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,4 @@
11
{-# LANGUAGE AllowAmbiguousTypes #-}
2-
{-# LANGUAGE CPP #-}
3-
{-# LANGUAGE TemplateHaskell #-}
42

53
module Data.Schematic.Migration where
64

‎src/Data/Schematic/Path.hs‎

Lines changed: 1 addition & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,15 +1,12 @@
1-
{-# LANGUAGE CPP #-}
21
module Data.Schematic.Path where
32

43
import Data.Foldable as F
4+
import Data.Monoid ((<>))
55
import Data.Schematic.Compat
66
import Data.Singletons.Prelude
77
import Data.Singletons.TH
88
import Data.Singletons.TypeLits
99
import Data.Text as T
10-
#if !MIN_VERSION_base(4,11,0)
11-
import Data.Monoid ((<>))
12-
#endif
1310

1411

1512
singletons [d|

‎src/Data/Schematic/Schema.hs‎

Lines changed: 3 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,5 @@
11
{-# LANGUAGE AllowAmbiguousTypes #-}
22
{-# LANGUAGE CPP #-}
3-
{-# LANGUAGE EmptyCase #-}
4-
-- {-# LANGUAGE PolyKinds #-}
53
{-# OPTIONS_GHC -fprint-explicit-kinds #-}
64

75
module Data.Schematic.Schema where
@@ -29,14 +27,13 @@ import Data.Vector as V
2927
import Data.Vinyl hiding (Dict)
3028
import GHC.Exts
3129
import GHC.Generics (Generic)
30+
import GHC.TypeLits as TL
3231
import Prelude as P
3332
import Test.SmallCheck.Series as S
3433
#if !MIN_VERSION_base(4,12,0)
3534
import qualified Data.Vinyl.TypeLevel as V
3635
#endif
37-
#if !MIN_VERSION_base(4,11,0)
3836
import Data.Monoid ((<>))
39-
#endif
4037

4138

4239
singletons [d|
@@ -310,4 +307,5 @@ instance J.ToJSON (JsonRepr a) where
310307
type family TopLevel (schema :: Schema) :: Constraint where
311308
TopLevel ('SchemaArray acs s) = ()
312309
TopLevel ('SchemaObject o) = ()
313-
TopLevel spec = 'True ~ 'False
310+
TopLevel spec = TypeError ('TL.Text "Only Object or Array"
311+
':$$: 'TL.Text " should be on the top level")

‎src/Data/Schematic/Validation.hs‎

Lines changed: 35 additions & 75 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,3 @@
1-
{-# LANGUAGE CPP #-}
21
module Data.Schematic.Validation where
32

43
import Control.Monad
@@ -7,6 +6,7 @@ import Data.Aeson
76
import Data.Aeson.Types
87
import Data.Foldable
98
import Data.Functor.Identity
9+
import Data.Monoid ((<>))
1010
import Data.Schematic.Constraints
1111
import Data.Schematic.Path
1212
import Data.Schematic.Schema
@@ -17,12 +17,8 @@ import Data.Traversable
1717
import Data.Union
1818
import Data.Vector as V
1919
import Data.Vinyl
20-
import Data.Vinyl.TypeLevel
2120
import Prelude as P
2221
import Text.Regex.TDFA
23-
#if !MIN_VERSION_base(4,11,0)
24-
import Data.Monoid ((<>))
25-
#endif
2622

2723

2824
type Validation a = ValidationT ErrorMap Identity a
@@ -104,41 +100,41 @@ validateArrayConstraint (JSONPath path) v s =
104100
$ vWarning $ mmSingleton path $ pure
105101
$ "length of " <> path <> " should be == " <> T.pack (show n)
106102

103+
class ValidateConstraint t c where
104+
validateConstraint
105+
:: [DemotedPathSegment] -> t -> Sing (a::c) -> Validation ()
106+
107+
instance ValidateConstraint Text TextConstraint where
108+
validateConstraint = validateTextConstraint . demotedPathToText
109+
110+
instance ValidateConstraint Scientific NumberConstraint where
111+
validateConstraint = validateNumberConstraint . demotedPathToText
112+
113+
instance ValidateConstraint (V.Vector a) ArrayConstraint where
114+
validateConstraint = validateArrayConstraint . demotedPathToText
115+
116+
validateConstraints
117+
:: ValidateConstraint t c
118+
=> [DemotedPathSegment] -> t -> Sing (cs :: [c]) -> Validation ()
119+
validateConstraints _ _ SNil = pure ()
120+
validateConstraints dp t (SCons c cs) = do
121+
validateConstraint dp t c >> validateConstraints dp t cs
122+
107123
validateJsonRepr
108124
:: Sing schema
109125
-> [DemotedPathSegment]
110126
-> JsonRepr schema
111127
-> Validation ()
112128
validateJsonRepr sschema dpath jr = case jr of
113129
ReprText t -> case sschema of
114-
SSchemaText scs -> do
115-
let
116-
process :: Sing (cs :: [TextConstraint]) -> Validation ()
117-
process SNil = pure ()
118-
process (SCons c cs) = do
119-
validateTextConstraint (demotedPathToText dpath) t c
120-
process cs
121-
process scs
130+
SSchemaText scs -> validateConstraints dpath t scs
122131
ReprNumber n -> case sschema of
123-
SSchemaNumber scs -> do
124-
let
125-
process :: Sing (cs :: [NumberConstraint]) -> Validation ()
126-
process SNil = pure ()
127-
process (SCons c cs) = do
128-
validateNumberConstraint (demotedPathToText dpath) n c
129-
process cs
130-
process scs
132+
SSchemaNumber scs -> validateConstraints dpath n scs
131133
ReprNull -> pure ()
132134
ReprBoolean _ -> pure ()
133135
ReprArray v -> case sschema of
134136
SSchemaArray acs s -> do
135-
let
136-
process :: Sing (cs :: [ArrayConstraint]) -> Validation ()
137-
process SNil = pure ()
138-
process (SCons c cs) = do
139-
validateArrayConstraint (demotedPathToText dpath) v c
140-
process cs
141-
process acs
137+
validateConstraints dpath v acs
142138
for_ (V.indexed v) $ \(ix, jr') -> do
143139
let newPath = dpath <> pure (Ix $ fromIntegral ix)
144140
validateJsonRepr s newPath jr'
@@ -155,46 +151,17 @@ validateJsonRepr sschema dpath jr = case jr of
155151
let newPath = dpath <> [Key (knownFieldName f)]
156152
validateJsonRepr (knownFieldSchema f) newPath d
157153
go ftl
158-
ReprUnion _ -> pure () -- FIXME
159-
-- case sschema of
160-
-- SSchemaUnion ss -> case ss of
161-
-- SCons s stl -> case umatch' s u of
162-
-- Nothing -> case urestrict u of
163-
-- Nothing ->
164-
-- fail "impossible to produce subUnion, please report this as a bug"
165-
-- Just x -> do
166-
-- let
167-
-- JSONPath path = demotedPathToText dpath
168-
-- case stl of
169-
-- SNil -> void $ vWarning $ mmSingleton path
170-
-- $ pure "union handling error, please report this as bug"
171-
-- SCons s' stl' ->
172-
-- validateJsonRepr (SSchemaUnion (SCons s' stl')) dpath
173-
-- $ toUnion (SCons s' stl') x
174-
-- Just x -> validateJsonRepr s dpath x
175-
176-
-- subUnion
177-
-- :: Sing (s ': stl)
178-
-- -> ( USubset stl (s ': stl) (RImage stl (s ': stl))
179-
-- => Union f (s ': stl)
180-
-- -> Maybe (Union f stl) )
181-
-- subUnion (SCons s stl) = urestrict
182-
183-
-- withUSubset
184-
-- :: Sing (s ': stl)
185-
-- -> (USubset stl (s ': stl) (RImage stl (s ': stl)) => Maybe (Union f stl))
186-
-- -> Maybe (Union f stl)
187-
-- withUSubset (SCons s stl) r = r
188-
189-
toUnion
190-
:: (USubset s' (s ': ss) (RImage s' (s ': ss)), ReprUnionConstr ss)
191-
=> Sing (s ': ss)
192-
-> Union JsonRepr s'
193-
-> JsonRepr ('SchemaUnion (s ': ss))
194-
toUnion _ = ReprUnion . urelax
195-
196-
umatch' :: UElem a as i => Sing a -> Union f as -> Maybe (f a)
197-
umatch' _ u = umatch u
154+
ReprUnion ru -> -- pure () -- FIXME
155+
case sschema of
156+
SSchemaUnion su -> validateUnion su ru
157+
where
158+
validateUnion
159+
:: forall (us :: [Schema])
160+
. Sing us -> Union JsonRepr us -> Validation ()
161+
validateUnion ss r = case (ss,r) of
162+
(SCons (s :: Sing su) _, This v) -> validateJsonRepr s dpath v
163+
(SCons _ stl, That r') -> validateUnion stl r'
164+
(SNil,_) -> fail "Invalid union. Please report this as a bug"
198165

199166
parseAndValidateJson
200167
:: forall schema
@@ -211,10 +178,3 @@ parseAndValidateJson v =
211178
in case res of
212179
Left em -> ValidationError em
213180
Right () -> Valid jsonRepr
214-
215-
-- parseAndValidateJsonBy
216-
-- :: (FromJSON (JsonRepr schema), TopLevel schema, SingI schema)
217-
-- => proxy schema
218-
-- -> Value
219-
-- -> ParseResult (JsonRepr schema)
220-
-- parseAndValidateJsonBy _ = parseAndValidateJson

0 commit comments

Comments
 (0)