Merge pull request #868 from haskell/key-type

Data.Aeson.Key

Author: phadej

aeson.cabal

@@ -68,6 +68,7 @@ library
     Data.Aeson.Internal
     Data.Aeson.Internal.Time
     Data.Aeson.Parser.Internal
+    Data.Aeson.Key
     Data.Aeson.KeyMap
 
   -- Deprecated modules

benchmarks/aeson-benchmarks.cabal

@@ -81,6 +81,7 @@ library
     Data.Aeson.Internal
     Data.Aeson.Internal.Functions
     Data.Aeson.Internal.Time
+    Data.Aeson.Key
     Data.Aeson.KeyMap
     Data.Aeson.Parser
     Data.Aeson.Parser.Internal

src/Data/Aeson.hs

@@ -55,6 +55,7 @@ module Data.Aeson
     , fromEncoding
     , Array
     , Object
+    , Key
     -- * Convenience types
     , DotNetTime(..)
     -- * Type conversion

src/Data/Aeson/Encoding/Builder.hs

@@ -41,7 +41,8 @@ module Data.Aeson.Encoding.Builder
 import Prelude.Compat
 
 import Data.Aeson.Internal.Time
-import Data.Aeson.Types.Internal (Value (..))
+import Data.Aeson.Types.Internal (Value (..), Key)
+import qualified Data.Aeson.Key as Key
 import qualified Data.Aeson.KeyMap as KM
 import Data.ByteString.Builder as B
 import Data.ByteString.Builder.Prim as BP
@@ -96,7 +97,11 @@ object m = case KM.toList m of
     _      -> emptyObject_
   where
     withComma a z = B.char8 ',' <> one a <> z
-    one (k,v)     = text k <> B.char8 ':' <> encodeToBuilder v
+    one (k,v)     = key k <> B.char8 ':' <> encodeToBuilder v
+
+-- | Encode a JSON key.
+key :: Key -> Builder
+key = text . Key.toText
 
 -- | Encode a JSON string.
 text :: T.Text -> Builder

src/Data/Aeson/Encoding/Internal.hs

@@ -26,6 +26,7 @@ module Data.Aeson.Encoding.Internal
     , wrapArray
     , null_
     , bool
+    , key
     , text
     , lazyText
     , string
@@ -61,8 +62,9 @@ module Data.Aeson.Encoding.Internal
 
 import Prelude.Compat
 
-import Data.Aeson.Types.Internal (Value)
+import Data.Aeson.Types.Internal (Value, Key)
 import Data.ByteString.Builder (Builder, char7, toLazyByteString)
+import qualified Data.Aeson.Key as Key
 import Data.Int
 import Data.Scientific (Scientific)
 import Data.Text (Text)
@@ -127,15 +129,15 @@ data Series = Empty
             | Value (Encoding' Series)
             deriving (Typeable)
 
-pair :: Text -> Encoding -> Series
-pair name val = pair' (text name) val
+pair :: Key -> Encoding -> Series
+pair name val = pair' (key name) val
 {-# INLINE pair #-}
 
 pairStr :: String -> Encoding -> Series
 pairStr name val = pair' (string name) val
 {-# INLINE pairStr #-}
 
-pair' :: Encoding' Text -> Encoding -> Series
+pair' :: Encoding' Key -> Encoding -> Series
 pair' name val = Value $ retagEncoding $ retagEncoding name >< colon >< val
 
 instance Semigroup Series where
@@ -184,7 +186,7 @@ list to' (x:xs) = openBracket >< to' x >< commas xs >< closeBracket
 
 -- | Encode as JSON object
 dict
-    :: (k -> Encoding' Text)                     -- ^ key encoding
+    :: (k -> Encoding' Key)                           -- ^ key encoding
     -> (v -> Encoding)                                -- ^ value encoding
     -> (forall a. (k -> v -> a -> a) -> a -> m -> a)  -- ^ @foldrWithKey@ - indexed fold
     -> m                                              -- ^ container
@@ -226,6 +228,9 @@ tuple :: Encoding' InArray -> Encoding
 tuple b = retagEncoding $ openBracket >< b >< closeBracket
 {-# INLINE tuple #-}
 
+key :: Key -> Encoding' a
+key = text . Key.toText
+
 text :: Text -> Encoding' a
 text = Encoding . EB.text
 

src/Data/Aeson/Internal/Functions.hs

@@ -17,13 +17,13 @@ module Data.Aeson.Internal.Functions
 import Prelude.Compat
 
 import Data.Hashable (Hashable)
+import Data.Aeson.Key (Key)
 import qualified Data.Aeson.KeyMap as KM
 import qualified Data.HashMap.Strict as H
 import qualified Data.Map as M
-import qualified Data.Text as T
 
 -- | Transform a 'M.Map' into a 'KM.KeyMap' while transforming the keys.
-mapTextKeyVal :: (k -> T.Text) -> (v1 -> v2)
+mapTextKeyVal :: (k -> Key) -> (v1 -> v2)
               -> M.Map k v1 -> KM.KeyMap v2
 mapTextKeyVal fk kv = M.foldrWithKey (\k v -> KM.insert (fk k) (kv v)) KM.empty
 {-# INLINE mapTextKeyVal #-}

src/Data/Aeson/Key.hs

@@ -0,0 +1,89 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+#if __GLASGOW_HASKELL__ >= 800
+-- a) THQ works on cross-compilers and unregisterised GHCs
+-- b) may make compilation faster as no dynamic loading is ever needed (not sure about this)
+-- c) removes one hindrance to have code inferred as SafeHaskell safe
+{-# LANGUAGE TemplateHaskellQuotes #-}
+#else
+{-# LANGUAGE TemplateHaskell #-}
+#endif
+
+module Data.Aeson.Key (
+    Key,
+    fromString,
+    toString,
+    toText,
+    fromText,
+) where
+
+import Prelude (Eq, Ord, (.), Show (..), String)
+
+import Control.Applicative ((<$>))
+import Control.DeepSeq (NFData(..))
+import Data.Data (Data)
+import Data.Hashable (Hashable(..))
+import Data.Monoid (Monoid(mempty, mappend))
+import Data.Semigroup (Semigroup((<>)))
+import Data.Text (Text)
+import Data.Typeable (Typeable)
+import Text.Read (Read (..))
+
+import qualified Data.String
+import qualified Data.Text as T
+import qualified Language.Haskell.TH.Syntax as TH
+
+newtype Key = Key { unKey :: Text }
+  deriving (Eq, Ord, Typeable, Data)
+
+fromString :: String -> Key
+fromString = Key . T.pack
+
+toString :: Key -> String
+toString (Key k) = T.unpack k
+
+fromText :: Text -> Key
+fromText = Key
+
+toText :: Key -> Text
+toText = unKey
+
+-------------------------------------------------------------------------------
+-- instances
+-------------------------------------------------------------------------------
+
+instance Read Key where
+    readPrec = fromString <$> readPrec
+
+instance Show Key where
+    showsPrec d (Key k) = showsPrec d k 
+
+instance Data.String.IsString Key where
+    fromString = fromString
+
+instance Hashable Key where
+    hashWithSalt salt (Key k) = hashWithSalt salt k
+
+instance NFData Key where
+    rnf (Key k) = rnf k
+
+instance Semigroup Key where
+    Key x <> Key y = Key (x <> y)
+
+instance Monoid Key where
+    mempty = Key mempty
+    mappend = (<>)
+
+instance TH.Lift Key where
+#if MIN_VERSION_text(1,2,4)
+    lift (Key k) = [| Key k |]
+#else
+    lift k = [| fromString k' |] where k' = toString k
+#endif
+
+#if MIN_VERSION_template_haskell(2,17,0)
+    liftTyped = TH.unsafeCodeCoerce . TH.lift
+#elif MIN_VERSION_template_haskell(2,16,0)
+    liftTyped = TH.unsafeTExpCoerce . TH.lift
+#endif