{-# LANGUAGE CPP, DeriveDataTypeable, GeneralizedNewtypeDeriving, Rank2Types #-}
module Data.Aeson.Types.Internal
(
Value(..)
, Array
, emptyArray, isEmptyArray
, Pair
, Object
, emptyObject
, Parser
, Result(..)
, parse
, parseEither
, parseMaybe
, modifyFailure
, object
, Options(..)
, SumEncoding(..)
, defaultOptions
, defaultTaggedObject
, camelTo
, DotNetTime(..)
) where
import Control.Applicative
import Control.Monad
import Control.DeepSeq (NFData(..))
import Data.Char (toLower, isUpper)
import Data.Scientific (Scientific)
import Data.Hashable (Hashable(..))
import Data.Data (Data)
import Data.HashMap.Strict (HashMap)
import Data.Monoid (Monoid(..))
import Data.String (IsString(..))
import Data.Text (Text, pack)
import Data.Time (UTCTime)
import Data.Time.Format (FormatTime)
import Data.Typeable (Typeable)
import Data.Vector (Vector)
import qualified Data.HashMap.Strict as H
import qualified Data.Vector as V
data Result a = Error String
| Success a
deriving (Eq, Show, Typeable)
instance (NFData a) => NFData (Result a) where
rnf (Success a) = rnf a
rnf (Error err) = rnf err
instance Functor Result where
fmap f (Success a) = Success (f a)
fmap _ (Error err) = Error err
{-# INLINE fmap #-}
instance Monad Result where
return = Success
{-# INLINE return #-}
Success a >>= k = k a
Error err >>= _ = Error err
{-# INLINE (>>=) #-}
instance Applicative Result where
pure = return
{-# INLINE pure #-}
(<*>) = ap
{-# INLINE (<*>) #-}
instance MonadPlus Result where
mzero = fail "mzero"
{-# INLINE mzero #-}
mplus a@(Success _) _ = a
mplus _ b = b
{-# INLINE mplus #-}
instance Alternative Result where
empty = mzero
{-# INLINE empty #-}
(<|>) = mplus
{-# INLINE (<|>) #-}
instance Monoid (Result a) where
mempty = fail "mempty"
{-# INLINE mempty #-}
mappend = mplus
{-# INLINE mappend #-}
type Failure f r = String -> f r
type Success a f r = a -> f r
newtype Parser a = Parser {
runParser :: forall f r.
Failure f r
-> Success a f r
-> f r
}
instance Monad Parser where
m >>= g = Parser $ \kf ks -> let ks' a = runParser (g a) kf ks
in runParser m kf ks'
{-# INLINE (>>=) #-}
return a = Parser $ \_kf ks -> ks a
{-# INLINE return #-}
fail msg = Parser $ \kf _ks -> kf msg
{-# INLINE fail #-}
instance Functor Parser where
fmap f m = Parser $ \kf ks -> let ks' a = ks (f a)
in runParser m kf ks'
{-# INLINE fmap #-}
instance Applicative Parser where
pure = return
{-# INLINE pure #-}
(<*>) = apP
{-# INLINE (<*>) #-}
instance Alternative Parser where
empty = fail "empty"
{-# INLINE empty #-}
(<|>) = mplus
{-# INLINE (<|>) #-}
instance MonadPlus Parser where
mzero = fail "mzero"
{-# INLINE mzero #-}
mplus a b = Parser $ \kf ks -> let kf' _ = runParser b kf ks
in runParser a kf' ks
{-# INLINE mplus #-}
instance Monoid (Parser a) where
mempty = fail "mempty"
{-# INLINE mempty #-}
mappend = mplus
{-# INLINE mappend #-}
apP :: Parser (a -> b) -> Parser a -> Parser b
apP d e = do
b <- d
a <- e
return (b a)
{-# INLINE apP #-}
type Object = HashMap Text Value
type Array = Vector Value
data Value = Object !Object
| Array !Array
| String !Text
| Number !Scientific
| Bool !Bool
| Null
deriving (Eq, Show, Typeable, Data)
newtype DotNetTime = DotNetTime {
fromDotNetTime :: UTCTime
} deriving (Eq, Ord, Read, Show, Typeable, FormatTime)
instance NFData Value where
rnf (Object o) = rnf o
rnf (Array a) = V.foldl' (\x y -> rnf y `seq` x) () a
rnf (String s) = rnf s
rnf (Number n) = rnf n
rnf (Bool b) = rnf b
rnf Null = ()
instance IsString Value where
fromString = String . pack
{-# INLINE fromString #-}
hashValue :: Int -> Value -> Int
hashValue s (Object o) = H.foldl' hashWithSalt
(s `hashWithSalt` (0::Int)) o
hashValue s (Array a) = V.foldl' hashWithSalt
(s `hashWithSalt` (1::Int)) a
hashValue s (String str) = s `hashWithSalt` (2::Int) `hashWithSalt` str
hashValue s (Number n) = s `hashWithSalt` (3::Int) `hashWithSalt` n
hashValue s (Bool b) = s `hashWithSalt` (4::Int) `hashWithSalt` b
hashValue s Null = s `hashWithSalt` (5::Int)
instance Hashable Value where
hashWithSalt = hashValue
emptyArray :: Value
emptyArray = Array V.empty
isEmptyArray :: Value -> Bool
isEmptyArray (Array arr) = V.null arr
isEmptyArray _ = False
emptyObject :: Value
emptyObject = Object H.empty
parse :: (a -> Parser b) -> a -> Result b
parse m v = runParser (m v) Error Success
{-# INLINE parse #-}
parseMaybe :: (a -> Parser b) -> a -> Maybe b
parseMaybe m v = runParser (m v) (const Nothing) Just
{-# INLINE parseMaybe #-}
parseEither :: (a -> Parser b) -> a -> Either String b
parseEither m v = runParser (m v) Left Right
{-# INLINE parseEither #-}
type Pair = (Text, Value)
object :: [Pair] -> Value
object = Object . H.fromList
{-# INLINE object #-}
modifyFailure :: (String -> String) -> Parser a -> Parser a
modifyFailure f (Parser p) = Parser $ \kf -> p (kf . f)
data Options = Options
{ fieldLabelModifier :: String -> String
, constructorTagModifier :: String -> String
, allNullaryToStringTag :: Bool
, omitNothingFields :: Bool
, sumEncoding :: SumEncoding
}
data SumEncoding =
TaggedObject { tagFieldName :: String
, contentsFieldName :: String
}
| ObjectWithSingleField
| TwoElemArray
defaultOptions :: Options
defaultOptions = Options
{ fieldLabelModifier = id
, constructorTagModifier = id
, allNullaryToStringTag = True
, omitNothingFields = False
, sumEncoding = defaultTaggedObject
}
defaultTaggedObject :: SumEncoding
defaultTaggedObject = TaggedObject
{ tagFieldName = "tag"
, contentsFieldName = "contents"
}
camelTo :: Char -> String -> String
camelTo c = lastWasCap True
where
lastWasCap :: Bool
-> String
-> String
lastWasCap _ [] = []
lastWasCap prev (x : xs) = if isUpper x
then if prev
then toLower x : lastWasCap True xs
else c : toLower x : lastWasCap True xs
else x : lastWasCap False xs