5ef5530 · typeable/aeson

git.iko.soy/typeable/aeson

Make FromJSONKeyCoerce safer

commit5ef5530700f1f44a72cbac959070d5a0ffe1ada4 authorOleg Grenrus <oleg.grenrus@iki.fi> dateThu 26 May 2016, 15:33 (10 years ago) parent470308a

4 files changed+66−13

compare with master

unifiedsplit

Data/Aeson/Types.hs+2 Data/Aeson/Types/Class.hs+55−3 Data/Aeson/Types/Instances.hs+7−8 benchmarks/AesonMap.hs+2−2

Data/Aeson/Types.hs+2

@@ -42,6 +42,8 @@ module Data.Aeson.Types

4242 , ToJSONKeyFunction(..)

4343 , FromJSONKey(..)

4444 , FromJSONKeyFunction(..)

45+ , fromJSONKeyCoerce

46+ , coerceFromJSONKeyFunction

4547

4648 -- ** Generic JSON classes

4749 , GFromJSON(..)

Data/Aeson/Types/Class.hs+55−3

@@ -1,4 +1,5 @@

1−{-# LANGUAGE CPP, DefaultSignatures, FlexibleContexts, DeriveFunctor #-}

1+{-# LANGUAGE CPP, GADTs, DefaultSignatures, FlexibleContexts, DeriveFunctor,

2+ ScopedTypeVariables #-}

34-- |

45-- Module: Data.Aeson.Types.Class

@@ -26,6 +27,8 @@ module Data.Aeson.Types.Class

2627 -- * Classes and types for map keys

2728 , ToJSONKeyFunction(..)

2829 , FromJSONKeyFunction(..)

30+ , fromJSONKeyCoerce

31+ , coerceFromJSONKeyFunction

2932 -- * Object key-value pairs

3033 , KeyValue(..)

3134 -- * Functions needed for documentation

@@ -41,6 +44,18 @@ import qualified Data.ByteString.Builder as B

4144import qualified Data.Aeson.Encode.Builder as E

4245import qualified Data.Vector as V

4346

47+#define HAS_COERCIBLE MIN_VERSION_base(4,7,0)

48+

49+#if HAS_COERCIBLE

50+import Data.Coerce (Coercible, coerce)

51+coerce' :: Coercible a b => a -> b

52+coerce' = coerce

53+#else

54+import Unsafe.Coerce (unsafeCoerce)

55+coerce' :: a -> b

56+coerce' = unsafeCoerce

57+#endif

58+

4459-- | Class of generic representation types ('Rep') that can be converted to

4560-- JSON.

4661class GToJSON f where

@@ -261,13 +276,50 @@ data ToJSONKeyFunction a

261276 = ToJSONKeyText (a -> Text, a -> Encoding)

262277 | ToJSONKeyValue (a -> Value, a -> Encoding)

263278

279+-- | With GHC 7.8 + we carry around 'Coercible Text a' dictionary,

280+-- to have even some amount of safety net.

281+-- Unfortunately we cannot enforce that 'Hashable' instance agree on the type level

282+--

283+-- ATM this type is intentionally not exported. FromJSONKeyFunction can be inspected,

284+-- but cannot be constructed.

285+data CoerceText a where

286+#if HAS_COERCIBLE

287+ CoerceText :: Coercible Text a => CoerceText a

288+#else

289+ CoerceText :: CoerceText a

290+#endif

291+

264292data FromJSONKeyFunction a

265− = FromJSONKeyCoerce

293+ = FromJSONKeyCoerce (CoerceText a)

266294 | FromJSONKeyText (Text -> a)

267295 | FromJSONKeyTextParser (Text -> Parser a)

268296 | FromJSONKeyValue (Value -> Parser a)

269− deriving (Functor)

270297

298+instance Functor FromJSONKeyFunction where

299+ fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce')

300+ fmap h (FromJSONKeyText f) = FromJSONKeyText (h . f)

301+ fmap h (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap h . f)

302+ fmap h (FromJSONKeyValue f) = FromJSONKeyValue (fmap h . f)

303+

304+-- | Construct 'FromJSONKeyFunction' for types coercible from 'Text'. This

305+-- conversion is still unsafe, as 'Hashable' and 'Eq' instances of @a@ should be

306+-- compatible with 'Text' i.e. hash values be equal for wrapped values as well.

307+fromJSONKeyCoerce ::

308+#if HAS_COERCIBLE

309+ Coercible Text a =>

310+#endif

311+ FromJSONKeyFunction a

312+fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText

313+

314+coerceFromJSONKeyFunction ::

315+#if HAS_COERCIBLE

316+ Coercible a b =>

317+#endif

318+ FromJSONKeyFunction a -> FromJSONKeyFunction b

319+coerceFromJSONKeyFunction (FromJSONKeyCoerce CoerceText) = FromJSONKeyCoerce CoerceText

320+coerceFromJSONKeyFunction (FromJSONKeyText f) = FromJSONKeyText (coerce' . f)

321+coerceFromJSONKeyFunction (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap coerce' . f)

322+coerceFromJSONKeyFunction (FromJSONKeyValue f) = FromJSONKeyValue (fmap coerce' . f)

271323

272324-- | Fail parsing due to a type mismatch, with a descriptive message.

273325--

Data/Aeson/Types/Instances.hs+7−8

@@ -40,6 +40,8 @@ module Data.Aeson.Types.Instances

4040 , ToJSONKeyFunction(..)

4141 , FromJSONKey(..)

4242 , FromJSONKeyFunction(..)

43+ , fromJSONKeyCoerce

44+ , coerceFromJSONKeyFunction

4345 -- ** Generic JSON classes

4446 , GFromJSON(..)

4547 , GToJSON(..)

@@ -722,7 +724,7 @@ instance (ToJSON v, ToJSONKey k) => ToJSON (M.Map k v) where

722724

723725instance (FromJSON v, FromJSONKey k, Ord k) => FromJSON (M.Map k v) where

724726 parseJSON = case fromJSONKey of

725− FromJSONKeyCoerce -> withObject "Map k v" $

727+ FromJSONKeyCoerce _-> withObject "Map k v" $

726728 fmap (H.foldrWithKey (M.insert . unsafeCoerce) M.empty) . H.traverseWithKey (\k v -> parseJSON v <?> Key k)

727729 FromJSONKeyText f -> withObject "Map k v" $

728730 fmap (H.foldrWithKey (M.insert . f) M.empty) . H.traverseWithKey (\k v -> parseJSON v <?> Key k)

@@ -748,7 +750,7 @@ instance (ToJSON v, ToJSONKey k) => ToJSON (H.HashMap k v) where

748750

749751instance (FromJSON v, FromJSONKey k, Eq k, Hashable k) => FromJSON (H.HashMap k v) where

750752 parseJSON = case fromJSONKey of

751− FromJSONKeyCoerce -> withObject "HashMap ~Text v" $

753+ FromJSONKeyCoerce _ -> withObject "HashMap ~Text v" $

752754 uc . H.traverseWithKey (\k v -> parseJSON v <?> Key k)

753755 FromJSONKeyText f -> withObject "HashMap k v" $

754756 fmap (mapKey f) . H.traverseWithKey (\k v -> parseJSON v <?> Key k)

@@ -1629,11 +1631,11 @@ instance ToJSONKey Text where

16291631 toJSONKey = ToJSONKeyText (id,toEncoding)

16301632

16311633instance FromJSONKey Text where

1632− fromJSONKey = FromJSONKeyCoerce

1634+ fromJSONKey = fromJSONKeyCoerce

16331635

16341636-- | TODO: where ToJSONKey instance

16351637instance FromJSONKey b => FromJSONKey (Tagged a b) where

1636− fromJSONKey = fmap Tagged fromJSONKey

1638+ fromJSONKey = coerceFromJSONKeyFunction (fromJSONKey :: FromJSONKeyFunction b)

16371639 fromJSONKeyList = (fmap . fmap) Tagged fromJSONKeyList

16381640

16391641instance ToJSONKey Bool where

@@ -1694,10 +1696,7 @@ contramapToJSONKeyFunction h x = case x of

16941696 ToJSONKeyValue (f,g) -> ToJSONKeyValue (f . h, g . h)

16951697

16961698mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b

1697−mapFromJSONKeyFunction h x = case x of

1698− FromJSONKeyText f -> FromJSONKeyText (h . f)

1699− FromJSONKeyTextParser f -> FromJSONKeyTextParser (fmap h . f)

1700− FromJSONKeyValue f -> FromJSONKeyValue (fmap h . f)

1699+mapFromJSONKeyFunction = fmap

17011700

17021701-- | @withObject expected f value@ applies @f@ to the 'Object' when @value@ is an @Object@

17031702-- and fails using @'typeMismatch' expected@ otherwise.

benchmarks/AesonMap.hs+2−2

@@ -3,7 +3,7 @@

33import Control.DeepSeq

44import Criterion.Main

55import Data.Aeson

6−-- import Data.Aeson.Types (Parser)

6+import Data.Aeson.Types (fromJSONKeyCoerce)

77import Data.Hashable

88import Data.Proxy (Proxy (..))

99import Data.Tagged (Tagged (..))

@@ -54,7 +54,7 @@ instance Hashable T2 where

5454instance FromJSON T2 where

5555 parseJSON = withText "T2" $ pure . T2

5656instance FromJSONKey T2 where

57− fromJSONKey = FromJSONKeyCoerce

57+ fromJSONKey = fromJSONKeyCoerce

5858

5959-------------------------------------------------------------------------------

6060-- TextParser