a9972c3 · typeable/schematic

git.iko.soy/typeable/schematic

Remove redundant singletons

commita9972c3af550c215618be3cd5c713a9b5079adba authorDenis Redozubov <denis.redozubov@gmail.com> dateWed 2 Aug 2017, 00:39 (9 years ago) parent9c7b752

4 files changed+50−53

compare with master

unifiedsplit

src/Data/Schematic.hs+3−3 src/Data/Schematic/Migration.hs+8−12 src/Data/Schematic/Schema.hs+31−30 src/Data/Schematic/Validation.hs+8−8

src/Data/Schematic.hs+3−3

@@ -109,9 +109,9 @@ parseAndValidateWithMList

109109 -> ParseResult (JsonRepr (Head revisions))

110110parseAndValidateWithMList MNil v = parseAndValidateJson v

111111parseAndValidateWithMList ((:&&) p f tl) v = case parseAndValidateJsonBy p v of

112− Valid a -> Valid a

113− DecodingError _ -> f <$> parseAndValidateWithMList tl v

114− ValidationError _ -> f <$> parseAndValidateWithMList tl v

112+ Valid a -> Valid a

113+ DecodingError _ -> f <$> parseAndValidateWithMList tl v

114+ ValidationError _ -> f <$> parseAndValidateWithMList tl v

115115

116116decodeAndValidateJson

117117 :: forall schema

src/Data/Schematic/Migration.hs+8−12

@@ -16,7 +16,7 @@ data Path

1616 | PTraverse -- traverse into the array

1717

1818data instance Sing (p :: Path) where

19− SPKey :: KnownSymbol s => Sing s -> Sing ('PKey s)

19+ SPKey :: Sing s -> Sing ('PKey s)

2020 SPTraverse :: Sing 'PTraverse

2121

2222instance KnownSymbol s => SingI ('PKey s) where

@@ -107,12 +107,11 @@ data Action = AddKey Symbol Schema | Update Schema | DeleteKey Symbol

107107

108108data instance Sing (a :: Action) where

109109 SAddKey

110− :: (SingI n, SingI s)

111− => Sing n

110+ :: Sing n

112111 -> Sing s

113112 -> Sing ('AddKey n s)

114− SUpdate :: (SingI s) => Sing s -> Sing ('Update s)

115− SDeleteKey :: KnownSymbol s => Sing s -> Sing ('DeleteKey s)

113+ SUpdate :: Sing s -> Sing ('Update s)

114+ SDeleteKey :: Sing s -> Sing ('DeleteKey s)

116115

117116-- | User-supplied atomic difference between schemas.

118117-- Migrations can consists of many differences.

@@ -120,8 +119,7 @@ data Diff = Diff [Path] Action

120119

121120data instance Sing (diff :: Diff) where

122121 SDiff

123− :: (SingI jp, SingI a)

124− => Sing (jp :: [Path])

122+ :: Sing (jp :: [Path])

125123 -> Sing (a :: Action)

126124 -> Sing ('Diff jp a)

127125

@@ -132,8 +130,7 @@ data Migration = Migration Revision [Diff]

132130

133131data instance Sing (m :: Migration) where

134132 SMigration

135− :: (KnownSymbol r, SingI ds)

136− => Sing r

133+ :: Sing r

137134 -> Sing ds

138135 -> Sing ('Migration r ds)

139136

@@ -141,15 +138,14 @@ data Versioned = Versioned Schema [Migration]

141138

142139data instance Sing (v :: Versioned) where

143140 SVersioned

144− :: (SingI s, SingI ms)

145− => Sing (s :: Schema) -- base version

141+ :: Sing (s :: Schema) -- base version

146142 -> Sing (ms :: [Migration]) -- a bunch of migrations

147143 -> Sing ('Versioned s ms)

148144

149145data MList :: [Schema] -> Type where

150146 MNil :: (SingI s, TopLevel s) => MList '[s]

151147 (:&&)

152− :: (SingI s, TopLevel s)

148+ :: (TopLevel s, SingI s)

153149 => proxy s

154150 -> (JsonRepr h -> JsonRepr s)

155151 -> MList (h ': tl)

src/Data/Schematic/Schema.hs+31−30

@@ -46,11 +46,11 @@ data TextConstraint

4646 deriving (Generic)

4747

4848data instance Sing (tc :: TextConstraint) where

49− STEq :: (KnownNat n) => Sing n -> Sing ('TEq n)

50− STLe :: (KnownNat n) => Sing n -> Sing ('TLe n)

51− STGt :: (KnownNat n) => Sing n -> Sing ('TGt n)

52− STRegex :: (KnownSymbol s, SingI s) => Sing s -> Sing ('TRegex s)

53− STEnum :: (All KnownSymbol ss, SingI ss) => Sing ss -> Sing ('TEnum ss)

49+ STEq :: Sing n -> Sing ('TEq n)

50+ STLe :: Sing n -> Sing ('TLe n)

51+ STGt :: Sing n -> Sing ('TGt n)

52+ STRegex :: Sing s -> Sing ('TRegex s)

53+ STEnum :: All KnownSymbol ss => Sing ss -> Sing ('TEnum ss)

5454

5555instance (KnownNat n) => SingI ('TEq n) where sing = STEq sing

5656instance (KnownNat n) => SingI ('TGt n) where sing = STGt sing

@@ -71,9 +71,9 @@ data NumberConstraint

7171 deriving (Generic)

7272

7373data instance Sing (nc :: NumberConstraint) where

74− SNEq :: KnownNat n => Sing n -> Sing ('NEq n)

75− SNGt :: KnownNat n => Sing n -> Sing ('NGt n)

76− SNLe :: KnownNat n => Sing n -> Sing ('NLe n)

74+ SNEq :: Sing n -> Sing ('NEq n)

75+ SNGt :: Sing n -> Sing ('NGt n)

76+ SNLe :: Sing n -> Sing ('NLe n)

7777

7878instance KnownNat n => SingI ('NEq n) where sing = SNEq sing

7979instance KnownNat n => SingI ('NGt n) where sing = SNGt sing

@@ -88,7 +88,7 @@ data ArrayConstraint

8888 deriving (Generic)

8989

9090data instance Sing (ac :: ArrayConstraint) where

91− SAEq :: KnownNat n => Sing n -> Sing ('AEq n)

91+ SAEq :: Sing n -> Sing ('AEq n)

9292

9393instance KnownNat n => SingI ('AEq n) where sing = SAEq sing

9494

@@ -104,11 +104,11 @@ data Schema

104104 deriving (Generic)

105105

106106data instance Sing (schema :: Schema) where

107− SSchemaText :: SingI tcs => Sing tcs -> Sing ('SchemaText tcs)

108− SSchemaNumber :: SingI ncs => Sing ncs -> Sing ('SchemaNumber ncs)

109− SSchemaArray :: (SingI acs, SingI schema) => Sing acs -> Sing schema -> Sing ('SchemaArray acs schema)

110− SSchemaObject :: SingI fields => Sing fields -> Sing ('SchemaObject fields)

111− SSchemaOptional :: SingI s => Sing s -> Sing ('SchemaOptional s)

107+ SSchemaText :: Sing tcs -> Sing ('SchemaText tcs)

108+ SSchemaNumber :: Sing ncs -> Sing ('SchemaNumber ncs)

109+ SSchemaArray :: Sing acs -> Sing schema -> Sing ('SchemaArray acs schema)

110+ SSchemaObject :: Sing fields -> Sing ('SchemaObject fields)

111+ SSchemaOptional :: Sing s -> Sing ('SchemaOptional s)

112112 SSchemaNull :: Sing 'SchemaNull

113113

114114instance SingI sl => SingI ('SchemaText sl) where

@@ -238,37 +238,38 @@ fromOptional _ = parseJSON

238238

239239instance SingI schema => J.FromJSON (JsonRepr schema) where

240240 parseJSON value = case sing :: Sing schema of

241− SSchemaText _ -> withText "String" (pure . ReprText) value

242− SSchemaNumber _ -> withScientific "Number" (pure . ReprNumber) value

243− SSchemaNull -> case value of

241+ SSchemaText _ -> withText "String" (pure . ReprText) value

242+ SSchemaNumber _ -> withScientific "Number" (pure . ReprNumber) value

243+ SSchemaNull -> case value of

244244 J.Null -> pure ReprNull

245245 _ -> typeMismatch "Null" value

246− so@(SSchemaOptional _) -> ReprOptional <$> fromOptional so value

247− SSchemaArray _ _ -> withArray "Array" (fmap ReprArray . traverse parseJSON) value

248− SSchemaObject fs -> do

246+ so@(SSchemaOptional s) -> withSingI s $ ReprOptional <$> fromOptional so value

247+ SSchemaArray sa sb -> withSingI sa $ withSingI sb

248+ $ withArray "Array" (fmap ReprArray . traverse parseJSON) value

249+ SSchemaObject fs -> do

249250 let

250251 demoteFields :: SList s -> H.HashMap Text J.Value -> Parser (Rec FieldRepr s)

251252 demoteFields SNil _ = pure RNil

252253 demoteFields (SCons (STuple2 (n :: Sing fn) s) tl) h = withKnownSymbol n $ do

253254 let fieldName = T.pack $ symbolVal (Proxy @fn)

254255 fieldRepr <- case s of

255− SSchemaText _ -> case H.lookup fieldName h of

256− Just v -> FieldRepr <$> parseJSON v

256+ SSchemaText so -> case H.lookup fieldName h of

257+ Just v -> withSingI so $ FieldRepr <$> parseJSON v

257258 Nothing -> fail "schematext"

258− SSchemaNumber _ -> case H.lookup fieldName h of

259− Just v -> FieldRepr <$> parseJSON v

259+ SSchemaNumber so -> case H.lookup fieldName h of

260+ Just v -> withSingI so $ FieldRepr <$> parseJSON v

260261 Nothing -> fail "schemanumber"

261262 SSchemaNull -> case H.lookup fieldName h of

262263 Just v -> FieldRepr <$> parseJSON v

263264 Nothing -> fail "schemanull"

264− SSchemaArray _ _ -> case H.lookup fieldName h of

265− Just v -> FieldRepr <$> parseJSON v

265+ SSchemaArray sa sb -> case H.lookup fieldName h of

266+ Just v -> withSingI sa $ withSingI sb $ FieldRepr <$> parseJSON v

266267 Nothing -> fail "schemaarray"

267− SSchemaObject _ -> case H.lookup fieldName h of

268− Just v -> FieldRepr <$> parseJSON v

268+ SSchemaObject so -> case H.lookup fieldName h of

269+ Just v -> withSingI so $ FieldRepr <$> parseJSON v

269270 Nothing -> fail "schemaobject"

270− SSchemaOptional _ -> case H.lookup fieldName h of

271− Just v -> FieldRepr <$> parseJSON v

271+ SSchemaOptional so -> case H.lookup fieldName h of

272+ Just v -> withSingI so $ FieldRepr <$> parseJSON v

272273 Nothing -> fail "schemaoptional"

273274 (fieldRepr :&) <$> demoteFields tl h

274275 ReprObject <$> withObject "Object" (demoteFields fs) value

src/Data/Schematic/Validation.hs+8−8

@@ -48,28 +48,28 @@ validateTextConstraint

4848validateTextConstraint (JSONPath path) t = \case

4949 STEq n -> do

5050 let

51− nlen = natVal n

51+ nlen = withKnownNat n $ natVal n

5252 predicate = nlen == (fromIntegral $ T.length t)

5353 errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen)

5454 warn = vWarning $ mmSingleton path (pure errMsg)

5555 unless predicate warn

5656 STLe n -> do

5757 let

58− nlen = natVal n

58+ nlen = withKnownNat n $ natVal n

5959 predicate = nlen <= (fromIntegral $ T.length t)

6060 errMsg = "length of " <> path <> " should be <= " <> T.pack (show nlen)

6161 warn = vWarning $ mmSingleton path (pure errMsg)

6262 unless predicate warn

6363 STGt n -> do

6464 let

65− nlen = natVal n

65+ nlen = withKnownNat n $ natVal n

6666 predicate = nlen > (fromIntegral $ T.length t)

6767 errMsg = "length of " <> path <> " should be > " <> T.pack (show nlen)

6868 warn = vWarning $ mmSingleton path (pure errMsg)

6969 unless predicate warn

7070 STRegex r -> do

7171 let

72− regex = symbolVal r

72+ regex = withKnownSymbol r $ symbolVal r

7373 predicate = maybe False (const True) $ matchRegex (mkRegex regex) (T.unpack t)

7474 errMsg = path <> " must match " <> T.pack (show regex)

7575 warn = vWarning $ mmSingleton path (pure errMsg)

@@ -91,21 +91,21 @@ validateNumberConstraint

9191validateNumberConstraint (JSONPath path) num = \case

9292 SNEq n -> do

9393 let

94− nlen = natVal n

94+ nlen = withKnownNat n $ natVal n

9595 predicate = fromIntegral nlen == num

9696 errMsg = path <> " should be == " <> T.pack (show nlen)

9797 warn = vWarning $ mmSingleton path (pure errMsg)

9898 unless predicate warn

9999 SNGt n -> do

100100 let

101− nlen = natVal n

101+ nlen = withKnownNat n $ natVal n

102102 predicate = num > fromIntegral nlen

103103 errMsg = path <> " should be > " <> T.pack (show nlen)

104104 warn = vWarning $ mmSingleton path (pure errMsg)

105105 unless predicate warn

106106 SNLe n -> do

107107 let

108− nlen = natVal n

108+ nlen = withKnownNat n $ natVal n

109109 predicate = fromIntegral nlen <= num

110110 errMsg = path <> " should be <= " <> T.pack (show nlen)

111111 warn = vWarning $ mmSingleton path (pure errMsg)

@@ -119,7 +119,7 @@ validateArrayConstraint

119119validateArrayConstraint (JSONPath path) v = \case

120120 SAEq n -> do

121121 let

122− nlen = natVal n

122+ nlen = withKnownNat n $ natVal n

123123 predicate = nlen == fromIntegral (V.length v)

124124 errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen)

125125 warn = vWarning $ mmSingleton path (pure errMsg)