git.iko.soy/typeable/schematic
on master help sign in
More runtime validation options
224573cDenis Redozubov
src/Data/Schematic/Schema.hs+16
compare with master
unifiedsplit
@@ -38,49 +38,65 @@ type family CRepr (s :: Schema) :: Type where
38
38
39data TextConstraint
39data TextConstraint
40 = TEq Nat
40 = TEq Nat
41+ | TLt Nat
41 | TLe Nat
42 | TLe Nat
42 | TGt Nat
43 | TGt Nat
44+ | TGe Nat
43 | TRegex Symbol
45 | TRegex Symbol
44 | TEnum [Symbol]
46 | TEnum [Symbol]
45 deriving (Generic)
47 deriving (Generic)
46
48
47data instance Sing (tc :: TextConstraint) where
49data instance Sing (tc :: TextConstraint) where
48 STEq :: Sing n -> Sing ('TEq n)
50 STEq :: Sing n -> Sing ('TEq n)
51+ STLt :: Sing n -> Sing ('TLt n)
49 STLe :: Sing n -> Sing ('TLe n)
52 STLe :: Sing n -> Sing ('TLe n)
50 STGt :: Sing n -> Sing ('TGt n)
53 STGt :: Sing n -> Sing ('TGt n)
54+ STGe :: Sing n -> Sing ('TGe n)
51 STRegex :: Sing s -> Sing ('TRegex s)
55 STRegex :: Sing s -> Sing ('TRegex s)
52 STEnum :: All KnownSymbol ss => Sing ss -> Sing ('TEnum ss)
56 STEnum :: All KnownSymbol ss => Sing ss -> Sing ('TEnum ss)
53
57
54instance (KnownNat n) => SingI ('TEq n) where sing = STEq sing
58instance (KnownNat n) => SingI ('TEq n) where sing = STEq sing
55instance (KnownNat n) => SingI ('TGt n) where sing = STGt sing
59instance (KnownNat n) => SingI ('TGt n) where sing = STGt sing
60+instance (KnownNat n) => SingI ('TGe n) where sing = STGe sing
61+instance (KnownNat n) => SingI ('TLt n) where sing = STLt sing
56instance (KnownNat n) => SingI ('TLe n) where sing = STLe sing
62instance (KnownNat n) => SingI ('TLe n) where sing = STLe sing
57instance (KnownSymbol s, SingI s) => SingI ('TRegex s) where sing = STRegex sing
63instance (KnownSymbol s, SingI s) => SingI ('TRegex s) where sing = STRegex sing
58instance (All KnownSymbol ss, SingI ss) => SingI ('TEnum ss) where sing = STEnum sing
64instance (All KnownSymbol ss, SingI ss) => SingI ('TEnum ss) where sing = STEnum sing
59
65
60instance Eq (Sing ('TEq n)) where _ == _ = True
66instance Eq (Sing ('TEq n)) where _ == _ = True
67+instance Eq (Sing ('TLt n)) where _ == _ = True
61instance Eq (Sing ('TLe n)) where _ == _ = True
68instance Eq (Sing ('TLe n)) where _ == _ = True
62instance Eq (Sing ('TGt n)) where _ == _ = True
69instance Eq (Sing ('TGt n)) where _ == _ = True
70+instance Eq (Sing ('TGe n)) where _ == _ = True
63instance Eq (Sing ('TRegex t)) where _ == _ = True
71instance Eq (Sing ('TRegex t)) where _ == _ = True
64instance Eq (Sing ('TEnum ss)) where _ == _ = True
72instance Eq (Sing ('TEnum ss)) where _ == _ = True
65
73
66data NumberConstraint
74data NumberConstraint
67 = NLe Nat
75 = NLe Nat
76+ | NLt Nat
68 | NGt Nat
77 | NGt Nat
78+ | NGe Nat
69 | NEq Nat
79 | NEq Nat
70 deriving (Generic)
80 deriving (Generic)
71
81
72data instance Sing (nc :: NumberConstraint) where
82data instance Sing (nc :: NumberConstraint) where
73 SNEq :: Sing n -> Sing ('NEq n)
83 SNEq :: Sing n -> Sing ('NEq n)
74 SNGt :: Sing n -> Sing ('NGt n)
84 SNGt :: Sing n -> Sing ('NGt n)
85+ SNGe :: Sing n -> Sing ('NGe n)
86+ SNLt :: Sing n -> Sing ('NLt n)
75 SNLe :: Sing n -> Sing ('NLe n)
87 SNLe :: Sing n -> Sing ('NLe n)
76
88
77instance KnownNat n => SingI ('NEq n) where sing = SNEq sing
89instance KnownNat n => SingI ('NEq n) where sing = SNEq sing
78instance KnownNat n => SingI ('NGt n) where sing = SNGt sing
90instance KnownNat n => SingI ('NGt n) where sing = SNGt sing
91+instance KnownNat n => SingI ('NGe n) where sing = SNGe sing
92+instance KnownNat n => SingI ('NLt n) where sing = SNLt sing
79instance KnownNat n => SingI ('NLe n) where sing = SNLe sing
93instance KnownNat n => SingI ('NLe n) where sing = SNLe sing
80
94
81instance Eq (Sing ('NEq n)) where _ == _ = True
95instance Eq (Sing ('NEq n)) where _ == _ = True
96+instance Eq (Sing ('NLt n)) where _ == _ = True
82instance Eq (Sing ('NLe n)) where _ == _ = True
97instance Eq (Sing ('NLe n)) where _ == _ = True
83instance Eq (Sing ('NGt n)) where _ == _ = True
98instance Eq (Sing ('NGt n)) where _ == _ = True
99+instance Eq (Sing ('NGe n)) where _ == _ = True
84
100
85data ArrayConstraint
101data ArrayConstraint
86 = AEq Nat
102 = AEq Nat
src/Data/Schematic/Validation.hs+28
@@ -53,6 +53,13 @@ validateTextConstraint (JSONPath path) t = \case
53 errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen)
53 errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen)
54 warn = vWarning $ mmSingleton path (pure errMsg)
54 warn = vWarning $ mmSingleton path (pure errMsg)
55 unless predicate warn
55 unless predicate warn
56+ STLt n -> do
57+ let
58+ nlen = withKnownNat n $ natVal n
59+ predicate = nlen < (fromIntegral $ T.length t)
60+ errMsg = "length of " <> path <> " should be < " <> T.pack (show nlen)
61+ warn = vWarning $ mmSingleton path (pure errMsg)
62+ unless predicate warn
56 STLe n -> do
63 STLe n -> do
57 let
64 let
58 nlen = withKnownNat n $ natVal n
65 nlen = withKnownNat n $ natVal n
@@ -67,6 +74,13 @@ validateTextConstraint (JSONPath path) t = \case
67 errMsg = "length of " <> path <> " should be > " <> T.pack (show nlen)
74 errMsg = "length of " <> path <> " should be > " <> T.pack (show nlen)
68 warn = vWarning $ mmSingleton path (pure errMsg)
75 warn = vWarning $ mmSingleton path (pure errMsg)
69 unless predicate warn
76 unless predicate warn
77+ STGe n -> do
78+ let
79+ nlen = withKnownNat n $ natVal n
80+ predicate = nlen >= (fromIntegral $ T.length t)
81+ errMsg = "length of " <> path <> " should be >= " <> T.pack (show nlen)
82+ warn = vWarning $ mmSingleton path (pure errMsg)
83+ unless predicate warn
70 STRegex r -> do
84 STRegex r -> do
71 let
85 let
72 regex = withKnownSymbol r $ symbolVal r
86 regex = withKnownSymbol r $ symbolVal r
@@ -103,6 +117,20 @@ validateNumberConstraint (JSONPath path) num = \case
103 errMsg = path <> " should be > " <> T.pack (show nlen)
117 errMsg = path <> " should be > " <> T.pack (show nlen)
104 warn = vWarning $ mmSingleton path (pure errMsg)
118 warn = vWarning $ mmSingleton path (pure errMsg)
105 unless predicate warn
119 unless predicate warn
120+ SNGe n -> do
121+ let
122+ nlen = withKnownNat n $ natVal n
123+ predicate = num >= fromIntegral nlen
124+ errMsg = path <> " should be >= " <> T.pack (show nlen)
125+ warn = vWarning $ mmSingleton path (pure errMsg)
126+ unless predicate warn
127+ SNLt n -> do
128+ let
129+ nlen = withKnownNat n $ natVal n
130+ predicate = fromIntegral nlen < num
131+ errMsg = path <> " should be < " <> T.pack (show nlen)
132+ warn = vWarning $ mmSingleton path (pure errMsg)
133+ unless predicate warn
106 SNLe n -> do
134 SNLe n -> do
107 let
135 let
108 nlen = withKnownNat n $ natVal n
136 nlen = withKnownNat n $ natVal n