git.iko.soy/schematic
on master help sign in
Remove redundant singletons
a9972c3Denis Redozubov
src/Data/Schematic.hs+3−3
compare with master
unifiedsplit
@@ -109,9 +109,9 @@ parseAndValidateWithMList
109 -> ParseResult (JsonRepr (Head revisions))
109 -> ParseResult (JsonRepr (Head revisions))
110parseAndValidateWithMList MNil v = parseAndValidateJson v
110parseAndValidateWithMList MNil v = parseAndValidateJson v
111parseAndValidateWithMList ((:&&) p f tl) v = case parseAndValidateJsonBy p v of
111parseAndValidateWithMList ((:&&) p f tl) v = case parseAndValidateJsonBy p v of
112− Valid a -> Valid a
112+ Valid a -> Valid a
113− DecodingError _ -> f <$> parseAndValidateWithMList tl v
113+ DecodingError _ -> f <$> parseAndValidateWithMList tl v
114− ValidationError _ -> f <$> parseAndValidateWithMList tl v
114+ ValidationError _ -> f <$> parseAndValidateWithMList tl v
115
115
116decodeAndValidateJson
116decodeAndValidateJson
117 :: forall schema
117 :: forall schema
src/Data/Schematic/Migration.hs+8−12
@@ -16,7 +16,7 @@ data Path
16 | PTraverse -- traverse into the array
16 | PTraverse -- traverse into the array
17
17
18data instance Sing (p :: Path) where
18data instance Sing (p :: Path) where
19− SPKey :: KnownSymbol s => Sing s -> Sing ('PKey s)
19+ SPKey :: Sing s -> Sing ('PKey s)
20 SPTraverse :: Sing 'PTraverse
20 SPTraverse :: Sing 'PTraverse
21
21
22instance KnownSymbol s => SingI ('PKey s) where
22instance KnownSymbol s => SingI ('PKey s) where
@@ -107,12 +107,11 @@ data Action = AddKey Symbol Schema | Update Schema | DeleteKey Symbol
107
107
108data instance Sing (a :: Action) where
108data instance Sing (a :: Action) where
109 SAddKey
109 SAddKey
110− :: (SingI n, SingI s)
111− => Sing n
110+ :: Sing n
112 -> Sing s
111 -> Sing s
113 -> Sing ('AddKey n s)
112 -> Sing ('AddKey n s)
114− SUpdate :: (SingI s) => Sing s -> Sing ('Update s)
113+ SUpdate :: Sing s -> Sing ('Update s)
115− SDeleteKey :: KnownSymbol s => Sing s -> Sing ('DeleteKey s)
114+ SDeleteKey :: Sing s -> Sing ('DeleteKey s)
116
115
117-- | User-supplied atomic difference between schemas.
116-- | User-supplied atomic difference between schemas.
118-- Migrations can consists of many differences.
117-- Migrations can consists of many differences.
@@ -120,8 +119,7 @@ data Diff = Diff [Path] Action
120
119
121data instance Sing (diff :: Diff) where
120data instance Sing (diff :: Diff) where
122 SDiff
121 SDiff
123− :: (SingI jp, SingI a)
124− => Sing (jp :: [Path])
122+ :: Sing (jp :: [Path])
125 -> Sing (a :: Action)
123 -> Sing (a :: Action)
126 -> Sing ('Diff jp a)
124 -> Sing ('Diff jp a)
127
125
@@ -132,8 +130,7 @@ data Migration = Migration Revision [Diff]
132
130
133data instance Sing (m :: Migration) where
131data instance Sing (m :: Migration) where
134 SMigration
132 SMigration
135− :: (KnownSymbol r, SingI ds)
136− => Sing r
133+ :: Sing r
137 -> Sing ds
134 -> Sing ds
138 -> Sing ('Migration r ds)
135 -> Sing ('Migration r ds)
139
136
@@ -141,15 +138,14 @@ data Versioned = Versioned Schema [Migration]
141
138
142data instance Sing (v :: Versioned) where
139data instance Sing (v :: Versioned) where
143 SVersioned
140 SVersioned
144− :: (SingI s, SingI ms)
145− => Sing (s :: Schema) -- base version
141+ :: Sing (s :: Schema) -- base version
146 -> Sing (ms :: [Migration]) -- a bunch of migrations
142 -> Sing (ms :: [Migration]) -- a bunch of migrations
147 -> Sing ('Versioned s ms)
143 -> Sing ('Versioned s ms)
148
144
149data MList :: [Schema] -> Type where
145data MList :: [Schema] -> Type where
150 MNil :: (SingI s, TopLevel s) => MList '[s]
146 MNil :: (SingI s, TopLevel s) => MList '[s]
151 (:&&)
147 (:&&)
152− :: (SingI s, TopLevel s)
148+ :: (TopLevel s, SingI s)
153 => proxy s
149 => proxy s
154 -> (JsonRepr h -> JsonRepr s)
150 -> (JsonRepr h -> JsonRepr s)
155 -> MList (h ': tl)
151 -> MList (h ': tl)
src/Data/Schematic/Schema.hs+31−30
@@ -46,11 +46,11 @@ data TextConstraint
46 deriving (Generic)
46 deriving (Generic)
47
47
48data instance Sing (tc :: TextConstraint) where
48data instance Sing (tc :: TextConstraint) where
49− STEq :: (KnownNat n) => Sing n -> Sing ('TEq n)
49+ STEq :: Sing n -> Sing ('TEq n)
50− STLe :: (KnownNat n) => Sing n -> Sing ('TLe n)
50+ STLe :: Sing n -> Sing ('TLe n)
51− STGt :: (KnownNat n) => Sing n -> Sing ('TGt n)
51+ STGt :: Sing n -> Sing ('TGt n)
52− STRegex :: (KnownSymbol s, SingI s) => Sing s -> Sing ('TRegex s)
52+ STRegex :: Sing s -> Sing ('TRegex s)
53− STEnum :: (All KnownSymbol ss, SingI ss) => Sing ss -> Sing ('TEnum ss)
53+ STEnum :: All KnownSymbol ss => Sing ss -> Sing ('TEnum ss)
54
54
55instance (KnownNat n) => SingI ('TEq n) where sing = STEq sing
55instance (KnownNat n) => SingI ('TEq n) where sing = STEq sing
56instance (KnownNat n) => SingI ('TGt n) where sing = STGt sing
56instance (KnownNat n) => SingI ('TGt n) where sing = STGt sing
@@ -71,9 +71,9 @@ data NumberConstraint
71 deriving (Generic)
71 deriving (Generic)
72
72
73data instance Sing (nc :: NumberConstraint) where
73data instance Sing (nc :: NumberConstraint) where
74− SNEq :: KnownNat n => Sing n -> Sing ('NEq n)
74+ SNEq :: Sing n -> Sing ('NEq n)
75− SNGt :: KnownNat n => Sing n -> Sing ('NGt n)
75+ SNGt :: Sing n -> Sing ('NGt n)
76− SNLe :: KnownNat n => Sing n -> Sing ('NLe n)
76+ SNLe :: Sing n -> Sing ('NLe n)
77
77
78instance KnownNat n => SingI ('NEq n) where sing = SNEq sing
78instance KnownNat n => SingI ('NEq n) where sing = SNEq sing
79instance KnownNat n => SingI ('NGt n) where sing = SNGt sing
79instance KnownNat n => SingI ('NGt n) where sing = SNGt sing
@@ -88,7 +88,7 @@ data ArrayConstraint
88 deriving (Generic)
88 deriving (Generic)
89
89
90data instance Sing (ac :: ArrayConstraint) where
90data instance Sing (ac :: ArrayConstraint) where
91− SAEq :: KnownNat n => Sing n -> Sing ('AEq n)
91+ SAEq :: Sing n -> Sing ('AEq n)
92
92
93instance KnownNat n => SingI ('AEq n) where sing = SAEq sing
93instance KnownNat n => SingI ('AEq n) where sing = SAEq sing
94
94
@@ -104,11 +104,11 @@ data Schema
104 deriving (Generic)
104 deriving (Generic)
105
105
106data instance Sing (schema :: Schema) where
106data instance Sing (schema :: Schema) where
107− SSchemaText :: SingI tcs => Sing tcs -> Sing ('SchemaText tcs)
107+ SSchemaText :: Sing tcs -> Sing ('SchemaText tcs)
108− SSchemaNumber :: SingI ncs => Sing ncs -> Sing ('SchemaNumber ncs)
108+ SSchemaNumber :: Sing ncs -> Sing ('SchemaNumber ncs)
109− SSchemaArray :: (SingI acs, SingI schema) => Sing acs -> Sing schema -> Sing ('SchemaArray acs schema)
109+ SSchemaArray :: Sing acs -> Sing schema -> Sing ('SchemaArray acs schema)
110− SSchemaObject :: SingI fields => Sing fields -> Sing ('SchemaObject fields)
110+ SSchemaObject :: Sing fields -> Sing ('SchemaObject fields)
111− SSchemaOptional :: SingI s => Sing s -> Sing ('SchemaOptional s)
111+ SSchemaOptional :: Sing s -> Sing ('SchemaOptional s)
112 SSchemaNull :: Sing 'SchemaNull
112 SSchemaNull :: Sing 'SchemaNull
113
113
114instance SingI sl => SingI ('SchemaText sl) where
114instance SingI sl => SingI ('SchemaText sl) where
@@ -238,37 +238,38 @@ fromOptional _ = parseJSON
238
238
239instance SingI schema => J.FromJSON (JsonRepr schema) where
239instance SingI schema => J.FromJSON (JsonRepr schema) where
240 parseJSON value = case sing :: Sing schema of
240 parseJSON value = case sing :: Sing schema of
241− SSchemaText _ -> withText "String" (pure . ReprText) value
241+ SSchemaText _ -> withText "String" (pure . ReprText) value
242− SSchemaNumber _ -> withScientific "Number" (pure . ReprNumber) value
242+ SSchemaNumber _ -> withScientific "Number" (pure . ReprNumber) value
243− SSchemaNull -> case value of
243+ SSchemaNull -> case value of
244 J.Null -> pure ReprNull
244 J.Null -> pure ReprNull
245 _ -> typeMismatch "Null" value
245 _ -> typeMismatch "Null" value
246− so@(SSchemaOptional _) -> ReprOptional <$> fromOptional so value
246+ so@(SSchemaOptional s) -> withSingI s $ ReprOptional <$> fromOptional so value
247+ SSchemaArray sa sb -> withSingI sa $ withSingI sb
247− SSchemaArray _ _ -> withArray "Array" (fmap ReprArray . traverse parseJSON) value
248+ $ withArray "Array" (fmap ReprArray . traverse parseJSON) value
248− SSchemaObject fs -> do
249+ SSchemaObject fs -> do
249 let
250 let
250 demoteFields :: SList s -> H.HashMap Text J.Value -> Parser (Rec FieldRepr s)
251 demoteFields :: SList s -> H.HashMap Text J.Value -> Parser (Rec FieldRepr s)
251 demoteFields SNil _ = pure RNil
252 demoteFields SNil _ = pure RNil
252 demoteFields (SCons (STuple2 (n :: Sing fn) s) tl) h = withKnownSymbol n $ do
253 demoteFields (SCons (STuple2 (n :: Sing fn) s) tl) h = withKnownSymbol n $ do
253 let fieldName = T.pack $ symbolVal (Proxy @fn)
254 let fieldName = T.pack $ symbolVal (Proxy @fn)
254 fieldRepr <- case s of
255 fieldRepr <- case s of
255− SSchemaText _ -> case H.lookup fieldName h of
256+ SSchemaText so -> case H.lookup fieldName h of
256− Just v -> FieldRepr <$> parseJSON v
257+ Just v -> withSingI so $ FieldRepr <$> parseJSON v
257 Nothing -> fail "schematext"
258 Nothing -> fail "schematext"
258− SSchemaNumber _ -> case H.lookup fieldName h of
259+ SSchemaNumber so -> case H.lookup fieldName h of
259− Just v -> FieldRepr <$> parseJSON v
260+ Just v -> withSingI so $ FieldRepr <$> parseJSON v
260 Nothing -> fail "schemanumber"
261 Nothing -> fail "schemanumber"
261 SSchemaNull -> case H.lookup fieldName h of
262 SSchemaNull -> case H.lookup fieldName h of
262 Just v -> FieldRepr <$> parseJSON v
263 Just v -> FieldRepr <$> parseJSON v
263 Nothing -> fail "schemanull"
264 Nothing -> fail "schemanull"
264− SSchemaArray _ _ -> case H.lookup fieldName h of
265+ SSchemaArray sa sb -> case H.lookup fieldName h of
265− Just v -> FieldRepr <$> parseJSON v
266+ Just v -> withSingI sa $ withSingI sb $ FieldRepr <$> parseJSON v
266 Nothing -> fail "schemaarray"
267 Nothing -> fail "schemaarray"
267− SSchemaObject _ -> case H.lookup fieldName h of
268+ SSchemaObject so -> case H.lookup fieldName h of
268− Just v -> FieldRepr <$> parseJSON v
269+ Just v -> withSingI so $ FieldRepr <$> parseJSON v
269 Nothing -> fail "schemaobject"
270 Nothing -> fail "schemaobject"
270− SSchemaOptional _ -> case H.lookup fieldName h of
271+ SSchemaOptional so -> case H.lookup fieldName h of
271− Just v -> FieldRepr <$> parseJSON v
272+ Just v -> withSingI so $ FieldRepr <$> parseJSON v
272 Nothing -> fail "schemaoptional"
273 Nothing -> fail "schemaoptional"
273 (fieldRepr :&) <$> demoteFields tl h
274 (fieldRepr :&) <$> demoteFields tl h
274 ReprObject <$> withObject "Object" (demoteFields fs) value
275 ReprObject <$> withObject "Object" (demoteFields fs) value
src/Data/Schematic/Validation.hs+8−8
@@ -48,28 +48,28 @@ validateTextConstraint
48validateTextConstraint (JSONPath path) t = \case
48validateTextConstraint (JSONPath path) t = \case
49 STEq n -> do
49 STEq n -> do
50 let
50 let
51− nlen = natVal n
51+ nlen = withKnownNat n $ natVal n
52 predicate = nlen == (fromIntegral $ T.length t)
52 predicate = nlen == (fromIntegral $ T.length t)
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 STLe n -> do
56 STLe n -> do
57 let
57 let
58− nlen = natVal n
58+ nlen = withKnownNat n $ natVal n
59 predicate = nlen <= (fromIntegral $ T.length t)
59 predicate = nlen <= (fromIntegral $ T.length t)
60 errMsg = "length of " <> path <> " should be <= " <> T.pack (show nlen)
60 errMsg = "length of " <> path <> " should be <= " <> T.pack (show nlen)
61 warn = vWarning $ mmSingleton path (pure errMsg)
61 warn = vWarning $ mmSingleton path (pure errMsg)
62 unless predicate warn
62 unless predicate warn
63 STGt n -> do
63 STGt n -> do
64 let
64 let
65− nlen = natVal n
65+ nlen = withKnownNat n $ natVal n
66 predicate = nlen > (fromIntegral $ T.length t)
66 predicate = nlen > (fromIntegral $ T.length t)
67 errMsg = "length of " <> path <> " should be > " <> T.pack (show nlen)
67 errMsg = "length of " <> path <> " should be > " <> T.pack (show nlen)
68 warn = vWarning $ mmSingleton path (pure errMsg)
68 warn = vWarning $ mmSingleton path (pure errMsg)
69 unless predicate warn
69 unless predicate warn
70 STRegex r -> do
70 STRegex r -> do
71 let
71 let
72− regex = symbolVal r
72+ regex = withKnownSymbol r $ symbolVal r
73 predicate = maybe False (const True) $ matchRegex (mkRegex regex) (T.unpack t)
73 predicate = maybe False (const True) $ matchRegex (mkRegex regex) (T.unpack t)
74 errMsg = path <> " must match " <> T.pack (show regex)
74 errMsg = path <> " must match " <> T.pack (show regex)
75 warn = vWarning $ mmSingleton path (pure errMsg)
75 warn = vWarning $ mmSingleton path (pure errMsg)
@@ -91,21 +91,21 @@ validateNumberConstraint
91validateNumberConstraint (JSONPath path) num = \case
91validateNumberConstraint (JSONPath path) num = \case
92 SNEq n -> do
92 SNEq n -> do
93 let
93 let
94− nlen = natVal n
94+ nlen = withKnownNat n $ natVal n
95 predicate = fromIntegral nlen == num
95 predicate = fromIntegral nlen == num
96 errMsg = path <> " should be == " <> T.pack (show nlen)
96 errMsg = path <> " should be == " <> T.pack (show nlen)
97 warn = vWarning $ mmSingleton path (pure errMsg)
97 warn = vWarning $ mmSingleton path (pure errMsg)
98 unless predicate warn
98 unless predicate warn
99 SNGt n -> do
99 SNGt n -> do
100 let
100 let
101− nlen = natVal n
101+ nlen = withKnownNat n $ natVal n
102 predicate = num > fromIntegral nlen
102 predicate = num > fromIntegral nlen
103 errMsg = path <> " should be > " <> T.pack (show nlen)
103 errMsg = path <> " should be > " <> T.pack (show nlen)
104 warn = vWarning $ mmSingleton path (pure errMsg)
104 warn = vWarning $ mmSingleton path (pure errMsg)
105 unless predicate warn
105 unless predicate warn
106 SNLe n -> do
106 SNLe n -> do
107 let
107 let
108− nlen = natVal n
108+ nlen = withKnownNat n $ natVal n
109 predicate = fromIntegral nlen <= num
109 predicate = fromIntegral nlen <= num
110 errMsg = path <> " should be <= " <> T.pack (show nlen)
110 errMsg = path <> " should be <= " <> T.pack (show nlen)
111 warn = vWarning $ mmSingleton path (pure errMsg)
111 warn = vWarning $ mmSingleton path (pure errMsg)
@@ -119,7 +119,7 @@ validateArrayConstraint
119validateArrayConstraint (JSONPath path) v = \case
119validateArrayConstraint (JSONPath path) v = \case
120 SAEq n -> do
120 SAEq n -> do
121 let
121 let
122− nlen = natVal n
122+ nlen = withKnownNat n $ natVal n
123 predicate = nlen == fromIntegral (V.length v)
123 predicate = nlen == fromIntegral (V.length v)
124 errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen)
124 errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen)
125 warn = vWarning $ mmSingleton path (pure errMsg)
125 warn = vWarning $ mmSingleton path (pure errMsg)