git.iko.soy/typeable/schematic
on master help sign in
More runtime validation options
commit224573c0715a18045a92522abdd057e1e3e053b7 authorDenis Redozubov <denis.redozubov@gmail.com> dateFri 25 Aug 2017, 13:34 (9 years ago) parent48ee69d
2 files changed+44
compare with master
unifiedsplit
src/Data/Schematic/Schema.hs+16 src/Data/Schematic/Validation.hs+28
src/Data/Schematic/Schema.hs+16
@@ -38,49 +38,65 @@ type family CRepr (s :: Schema) :: Type where
3838
3939data TextConstraint
4040 = TEq Nat
41+ | TLt Nat
4142 | TLe Nat
4243 | TGt Nat
44+ | TGe Nat
4345 | TRegex Symbol
4446 | TEnum [Symbol]
4547 deriving (Generic)
4648
4749data instance Sing (tc :: TextConstraint) where
4850 STEq :: Sing n -> Sing ('TEq n)
51+ STLt :: Sing n -> Sing ('TLt n)
4952 STLe :: Sing n -> Sing ('TLe n)
5053 STGt :: Sing n -> Sing ('TGt n)
54+ STGe :: Sing n -> Sing ('TGe n)
5155 STRegex :: Sing s -> Sing ('TRegex s)
5256 STEnum :: All KnownSymbol ss => Sing ss -> Sing ('TEnum ss)
5357
5458instance (KnownNat n) => SingI ('TEq n) where sing = STEq sing
5559instance (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
5662instance (KnownNat n) => SingI ('TLe n) where sing = STLe sing
5763instance (KnownSymbol s, SingI s) => SingI ('TRegex s) where sing = STRegex sing
5864instance (All KnownSymbol ss, SingI ss) => SingI ('TEnum ss) where sing = STEnum sing
5965
6066instance Eq (Sing ('TEq n)) where _ == _ = True
67+instance Eq (Sing ('TLt n)) where _ == _ = True
6168instance Eq (Sing ('TLe n)) where _ == _ = True
6269instance Eq (Sing ('TGt n)) where _ == _ = True
70+instance Eq (Sing ('TGe n)) where _ == _ = True
6371instance Eq (Sing ('TRegex t)) where _ == _ = True
6472instance Eq (Sing ('TEnum ss)) where _ == _ = True
6573
6674data NumberConstraint
6775 = NLe Nat
76+ | NLt Nat
6877 | NGt Nat
78+ | NGe Nat
6979 | NEq Nat
7080 deriving (Generic)
7181
7282data instance Sing (nc :: NumberConstraint) where
7383 SNEq :: Sing n -> Sing ('NEq n)
7484 SNGt :: Sing n -> Sing ('NGt n)
85+ SNGe :: Sing n -> Sing ('NGe n)
86+ SNLt :: Sing n -> Sing ('NLt n)
7587 SNLe :: Sing n -> Sing ('NLe n)
7688
7789instance KnownNat n => SingI ('NEq n) where sing = SNEq sing
7890instance 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
7993instance KnownNat n => SingI ('NLe n) where sing = SNLe sing
8094
8195instance Eq (Sing ('NEq n)) where _ == _ = True
96+instance Eq (Sing ('NLt n)) where _ == _ = True
8297instance Eq (Sing ('NLe n)) where _ == _ = True
8398instance Eq (Sing ('NGt n)) where _ == _ = True
99+instance Eq (Sing ('NGe n)) where _ == _ = True
84100
85101data ArrayConstraint
86102 = AEq Nat
src/Data/Schematic/Validation.hs+28
@@ -53,6 +53,13 @@ validateTextConstraint (JSONPath path) t = \case
5353 errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen)
5454 warn = vWarning $ mmSingleton path (pure errMsg)
5555 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
5663 STLe n -> do
5764 let
5865 nlen = withKnownNat n $ natVal n
@@ -67,6 +74,13 @@ validateTextConstraint (JSONPath path) t = \case
6774 errMsg = "length of " <> path <> " should be > " <> T.pack (show nlen)
6875 warn = vWarning $ mmSingleton path (pure errMsg)
6976 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
7084 STRegex r -> do
7185 let
7286 regex = withKnownSymbol r $ symbolVal r
@@ -103,6 +117,20 @@ validateNumberConstraint (JSONPath path) num = \case
103117 errMsg = path <> " should be > " <> T.pack (show nlen)
104118 warn = vWarning $ mmSingleton path (pure errMsg)
105119 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
106134 SNLe n -> do
107135 let
108136 nlen = withKnownNat n $ natVal n