fb-util-0.1.0.1: Util/Aeson.hs

{-
  Copyright (c) Meta Platforms, Inc. and affiliates.
  All rights reserved.

  This source code is licensed under the BSD-style license found in the
  LICENSE file in the root directory of this source tree.
-}

-- FromJSON instance below is an orphan (deliberately)
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE CPP #-}

module Util.Aeson
  ( toJSONText
  , toJSONByteString
  , cStringToObject
  , unsafeCStringToObject
  , unsafeCStringLenToObject
  , prettyJSON
  , parseValueStrict'
  , parseValueStrict
    -- * Backwards compatibility
  , ObjectKey
  , KeyMap
  , keyToText
  , keysToTexts
  , keyFromText
  , objectToList
  , objectFromList
  , objectKeys
  , objectToHashMap
  , objectFromHashMap
  , objectToHashMapText
  , objectFromHashMapText
  , emptyKeyMap
  , insertKeyMap
  , unionKeyMap
  , keyMapSize
  , lookupKeyMap
  ) where

import Data.Aeson
import Data.Aeson.Parser (value, value')
#if MIN_VERSION_aeson(2,0,0)
import Data.Aeson.Key
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KeyMap
import Data.Coerce
import Data.Type.Coercion
#endif
import Data.Aeson.Types (typeMismatch)
import Data.ByteString (ByteString)
import qualified Data.Attoparsec.ByteString as A
import qualified Data.Attoparsec.ByteString.Char8 as A
import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as B
import qualified Data.ByteString.Lazy as LB
import Data.HashMap.Strict (HashMap)
import Data.Text (Text)
import Foreign.C

import Text.PrettyPrint
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Vector as Vector
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text

-- | Converts a value to JSON, and returns it as a 'Text'
toJSONText :: ToJSON x => x -> Text.Text
toJSONText = Text.decodeUtf8 . toJSONByteString

-- | Converts a value to JSON, and returns it as a 'ByteString'
toJSONByteString :: ToJSON x => x -> ByteString
toJSONByteString = LB.toStrict . encode

-- | Since Aeson is lazily parsed, this assumes that that the memory
-- pointed to in the 'CString' will live throughout the liftime of the
-- returned object. If not, this potentially references freed memory. If
-- you cannot guarantee the lifetime, use 'cStringToObject'.
unsafeCStringToObject :: CString -> IO (Maybe Object)
unsafeCStringToObject s = decodeStrict <$> B.unsafePackCString s

-- | like 'unsafeCStringToObject' but takes a length too
unsafeCStringLenToObject :: CString -> Int -> IO (Maybe Object)
unsafeCStringLenToObject s l = decodeStrict <$> B.unsafePackCStringLen (s,l)

-- | Copies the 'CString' contents into Haskell, and then creates a
-- lazily parsed Aeson 'Object'.
cStringToObject :: CString -> IO (Maybe Object)
cStringToObject s = decodeStrict <$> B.packCString s

-- | Convert a JSON value to a 'String' with indentation to make it
-- easier to read.
prettyJSON :: Value -> String
prettyJSON val = show (pp val)
 where
  pp :: Value -> Doc
  pp Null = text "null"
  pp (Bool b) = text $ if b then "true" else "false"
  pp (String txt) =
    text (Text.unpack $ Text.decodeUtf8 $ LB.toStrict $ encode (String txt))
  pp (Number i) = text (show i)
  pp (Object hm) =
    braces $ sep $
      punctuate (char ',')
        [ sep [ pp (String (keyToText key)) <+> char ':', nest 2 (pp v) ]
        | (key, v) <- HashMap.toList (objectToHashMap hm) ]
  pp (Array arr) =
    brackets $ sep $ punctuate (char ',') $ map pp $ Vector.toList arr

-- eitherDecode family of function  strictly requires that the Value is
-- either an object or an array.
-- This relaxes that restriction and allows other kinds of Values.
-- NOTE: this is fixed in latest aeson
parseValueStrict :: ByteString -> Either String Value
parseValueStrict = A.parseOnly
  (A.skipSpace *> value <* A.skipSpace <* A.endOfInput)

parseValueStrict' :: ByteString -> Either String Value
parseValueStrict' = A.parseOnly
  (A.skipSpace *> value' <* A.skipSpace <* A.endOfInput)

-- Orphan instance to make from/toJSON O(1) when converting from/to an Object
-- (aka HashMap Text Value).  Otherwise the default instances provided
-- by Aeson will rebuild the HashMap.
--
-- This needs to be not just OVERLAPPABLE, but INCOHERENT, because
-- otherwise a constraint "FromJSON (HashMap Text a)" doesn't have a
-- single most-specific instance to resolve to.  INCOHERENT is ok;
-- the worst that can happen is that we lose the optimisation.
instance {-# INCOHERENT #-} FromJSON Object where
  parseJSON (Object obj) = return obj
  parseJSON other = typeMismatch "object" other

-- Having same optimization for 'ToJSON' is still valuable when we cannot use
-- 'Object' directly, e.g., when we are calling a polymorphic function with
-- a @ToJSON a@ constraint.
instance {-# INCOHERENT #-} ToJSON Object where
  toJSON = Object

keyToText :: ObjectKey -> Text
keysToTexts :: [ObjectKey] -> [Text]  -- zero-cost coercion
keyFromText :: Text -> ObjectKey
objectToList :: KeyMap v -> [(ObjectKey, v)]
objectFromList :: [(ObjectKey, v)] -> KeyMap v
objectKeys :: KeyMap v -> [ObjectKey]
objectToHashMap :: KeyMap v -> HashMap ObjectKey v
objectFromHashMap :: HashMap ObjectKey Value -> Object
objectToHashMapText :: KeyMap v -> HashMap Text v
objectFromHashMapText :: HashMap Text v -> KeyMap v
emptyKeyMap :: KeyMap v
insertKeyMap :: ObjectKey -> v -> KeyMap v -> KeyMap v
unionKeyMap :: KeyMap v -> KeyMap v -> KeyMap v
keyMapSize :: KeyMap v -> Int
lookupKeyMap :: ObjectKey -> KeyMap v -> Maybe v

#if MIN_VERSION_aeson(2,0,0)
type ObjectKey = Key
type KeyMap = KeyMap.KeyMap
keyToText = toText
keysToTexts = case Key.coercionToText of
  Just Coercion -> coerce
  _ -> map keyToText
keyFromText = fromText
objectToList = KeyMap.toList
objectFromList = KeyMap.fromList
objectKeys = KeyMap.keys
objectToHashMap = KeyMap.toHashMap
objectFromHashMap = KeyMap.fromHashMap
objectToHashMapText = KeyMap.toHashMapText
objectFromHashMapText = KeyMap.fromHashMapText
emptyKeyMap = KeyMap.empty
insertKeyMap = KeyMap.insert
unionKeyMap = KeyMap.union
keyMapSize = KeyMap.size
lookupKeyMap = KeyMap.lookup
#else
type ObjectKey = Text
type KeyMap v = HashMap Text v
keyToText = id
keysToTexts = id
keyFromText = id
objectToList = HashMap.toList
objectFromList = HashMap.fromList
objectKeys = HashMap.keys
objectToHashMap = id
objectFromHashMap = id
objectToHashMapText = id
objectFromHashMapText = id
emptyKeyMap = HashMap.empty
insertKeyMap = HashMap.insert
unionKeyMap = HashMap.union
keyMapSize = HashMap.size
lookupKeyMap = HashMap.lookup
#endif