module Data.Aeson.Types.Generic ( ) where
import Control.Applicative ((<*>), (<$>), (<|>), pure)
import Control.Monad ((<=<))
import Control.Monad.ST (ST)
import Data.Aeson.Types.Instances
import Data.Aeson.Types.Internal
import Data.Bits
import Data.DList (DList, toList, empty)
import Data.Maybe (fromMaybe)
import Data.Monoid (mappend)
import Data.Text (Text, pack, unpack)
import GHC.Generics
import qualified Data.HashMap.Strict as H
import qualified Data.Vector as V
import qualified Data.Vector.Mutable as VM
instance (GToJSON a) => GToJSON (M1 i c a) where
gToJSON opts = gToJSON opts . unM1
instance (ToJSON a) => GToJSON (K1 i a) where
gToJSON _opts = toJSON . unK1
instance GToJSON U1 where
gToJSON _opts _ = emptyArray
instance (ConsToJSON a) => GToJSON (C1 c a) where
gToJSON opts = consToJSON opts . unM1
instance ( WriteProduct a, WriteProduct b
, ProductSize a, ProductSize b ) => GToJSON (a :*: b) where
gToJSON opts p =
Array $ V.create $ do
mv <- VM.unsafeNew lenProduct
writeProduct opts mv 0 lenProduct p
return mv
where
lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)
productSize
instance ( AllNullary (a :+: b) allNullary
, SumToJSON (a :+: b) allNullary ) => GToJSON (a :+: b) where
gToJSON opts = (unTagged :: Tagged allNullary Value -> Value)
. sumToJSON opts
class SumToJSON f allNullary where
sumToJSON :: Options -> f a -> Tagged allNullary Value
instance ( GetConName f
, TaggedObject f
, ObjectWithSingleField f
, TwoElemArray f ) => SumToJSON f True where
sumToJSON opts
| allNullaryToStringTag opts = Tagged . String . pack
. constructorTagModifier opts . getConName
| otherwise = Tagged . nonAllNullarySumToJSON opts
instance ( TwoElemArray f
, TaggedObject f
, ObjectWithSingleField f ) => SumToJSON f False where
sumToJSON opts = Tagged . nonAllNullarySumToJSON opts
nonAllNullarySumToJSON :: ( TwoElemArray f
, TaggedObject f
, ObjectWithSingleField f
) => Options -> f a -> Value
nonAllNullarySumToJSON opts =
case sumEncoding opts of
TaggedObject{..} -> object . taggedObject opts tagFieldName
contentsFieldName
ObjectWithSingleField -> Object . objectWithSingleField opts
TwoElemArray -> Array . twoElemArray opts
class TaggedObject f where
taggedObject :: Options -> String -> String -> f a -> [Pair]
instance ( TaggedObject a
, TaggedObject b ) => TaggedObject (a :+: b) where
taggedObject opts tagFieldName contentsFieldName (L1 x) =
taggedObject opts tagFieldName contentsFieldName x
taggedObject opts tagFieldName contentsFieldName (R1 x) =
taggedObject opts tagFieldName contentsFieldName x
instance ( IsRecord a isRecord
, TaggedObject' a isRecord
, Constructor c ) => TaggedObject (C1 c a) where
taggedObject opts tagFieldName contentsFieldName =
(pack tagFieldName .= constructorTagModifier opts
(conName (undefined :: t c a p)) :) .
(unTagged :: Tagged isRecord [Pair] -> [Pair]) .
taggedObject' opts contentsFieldName . unM1
class TaggedObject' f isRecord where
taggedObject' :: Options -> String -> f a -> Tagged isRecord [Pair]
instance (RecordToPairs f) => TaggedObject' f True where
taggedObject' opts _ = Tagged . toList . recordToPairs opts
instance (GToJSON f) => TaggedObject' f False where
taggedObject' opts contentsFieldName =
Tagged . (:[]) . (pack contentsFieldName .=) . gToJSON opts
class GetConName f where
getConName :: f a -> String
instance (GetConName a, GetConName b) => GetConName (a :+: b) where
getConName (L1 x) = getConName x
getConName (R1 x) = getConName x
instance (Constructor c, GToJSON a, ConsToJSON a) => GetConName (C1 c a) where
getConName = conName
class TwoElemArray f where
twoElemArray :: Options -> f a -> V.Vector Value
instance (TwoElemArray a, TwoElemArray b) => TwoElemArray (a :+: b) where
twoElemArray opts (L1 x) = twoElemArray opts x
twoElemArray opts (R1 x) = twoElemArray opts x
instance ( GToJSON a, ConsToJSON a
, Constructor c ) => TwoElemArray (C1 c a) where
twoElemArray opts x = V.create $ do
mv <- VM.unsafeNew 2
VM.unsafeWrite mv 0 $ String $ pack $ constructorTagModifier opts
$ conName (undefined :: t c a p)
VM.unsafeWrite mv 1 $ gToJSON opts x
return mv
class ConsToJSON f where
consToJSON :: Options -> f a -> Value
class ConsToJSON' f isRecord where
consToJSON' :: Options -> f a -> Tagged isRecord Value
instance ( IsRecord f isRecord
, ConsToJSON' f isRecord ) => ConsToJSON f where
consToJSON opts = (unTagged :: Tagged isRecord Value -> Value)
. consToJSON' opts
instance (RecordToPairs f) => ConsToJSON' f True where
consToJSON' opts = Tagged . object . toList . recordToPairs opts
instance GToJSON f => ConsToJSON' f False where
consToJSON' opts = Tagged . gToJSON opts
class RecordToPairs f where
recordToPairs :: Options -> f a -> DList Pair
instance (RecordToPairs a, RecordToPairs b) => RecordToPairs (a :*: b) where
recordToPairs opts (a :*: b) = recordToPairs opts a `mappend`
recordToPairs opts b
instance (Selector s, GToJSON a) => RecordToPairs (S1 s a) where
recordToPairs = fieldToPair
instance (Selector s, ToJSON a) => RecordToPairs (S1 s (K1 i (Maybe a))) where
recordToPairs opts (M1 k1) | omitNothingFields opts
, K1 Nothing <- k1 = empty
recordToPairs opts m1 = fieldToPair opts m1
fieldToPair :: (Selector s, GToJSON a) => Options -> S1 s a p -> DList Pair
fieldToPair opts m1 = pure ( pack $ fieldLabelModifier opts $ selName m1
, gToJSON opts (unM1 m1)
)
class WriteProduct f where
writeProduct :: Options
-> VM.MVector s Value
-> Int
-> Int
-> f a
-> ST s ()
instance ( WriteProduct a
, WriteProduct b ) => WriteProduct (a :*: b) where
writeProduct opts mv ix len (a :*: b) = do
writeProduct opts mv ix lenL a
writeProduct opts mv ixR lenR b
where
#if MIN_VERSION_base(4,5,0)
lenL = len `unsafeShiftR` 1
#else
lenL = len `shiftR` 1
#endif
lenR = len lenL
ixR = ix + lenL
instance (GToJSON a) => WriteProduct a where
writeProduct opts mv ix _ = VM.unsafeWrite mv ix . gToJSON opts
class ObjectWithSingleField f where
objectWithSingleField :: Options -> f a -> Object
instance ( ObjectWithSingleField a
, ObjectWithSingleField b ) => ObjectWithSingleField (a :+: b) where
objectWithSingleField opts (L1 x) = objectWithSingleField opts x
objectWithSingleField opts (R1 x) = objectWithSingleField opts x
instance ( GToJSON a, ConsToJSON a
, Constructor c ) => ObjectWithSingleField (C1 c a) where
objectWithSingleField opts = H.singleton typ . gToJSON opts
where
typ = pack $ constructorTagModifier opts $
conName (undefined :: t c a p)
instance (GFromJSON a) => GFromJSON (M1 i c a) where
gParseJSON opts = fmap M1 . gParseJSON opts
instance (FromJSON a) => GFromJSON (K1 i a) where
gParseJSON _opts = fmap K1 . parseJSON
instance GFromJSON U1 where
gParseJSON _opts v
| isEmptyArray v = pure U1
| otherwise = typeMismatch "unit constructor (U1)" v
instance (ConsFromJSON a) => GFromJSON (C1 c a) where
gParseJSON opts = fmap M1 . consParseJSON opts
instance ( FromProduct a, FromProduct b
, ProductSize a, ProductSize b ) => GFromJSON (a :*: b) where
gParseJSON opts = withArray "product (:*:)" $ \arr ->
let lenArray = V.length arr
lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)
productSize in
if lenArray == lenProduct
then parseProduct opts arr 0 lenProduct
else fail $ "When expecting a product of " ++ show lenProduct ++
" values, encountered an Array of " ++ show lenArray ++
" elements instead"
instance ( AllNullary (a :+: b) allNullary
, ParseSum (a :+: b) allNullary ) => GFromJSON (a :+: b) where
gParseJSON opts = (unTagged :: Tagged allNullary (Parser ((a :+: b) d)) ->
(Parser ((a :+: b) d)))
. parseSum opts
class ParseSum f allNullary where
parseSum :: Options -> Value -> Tagged allNullary (Parser (f a))
instance ( SumFromString (a :+: b)
, FromPair (a :+: b)
, FromTaggedObject (a :+: b) ) => ParseSum (a :+: b) True where
parseSum opts
| allNullaryToStringTag opts = Tagged . parseAllNullarySum opts
| otherwise = Tagged . parseNonAllNullarySum opts
instance ( FromPair (a :+: b)
, FromTaggedObject (a :+: b) ) => ParseSum (a :+: b) False where
parseSum opts = Tagged . parseNonAllNullarySum opts
parseAllNullarySum :: SumFromString f => Options -> Value -> Parser (f a)
parseAllNullarySum opts = withText "Text" $ \key ->
maybe (notFound $ unpack key) return $
parseSumFromString opts key
class SumFromString f where
parseSumFromString :: Options -> Text -> Maybe (f a)
instance (SumFromString a, SumFromString b) => SumFromString (a :+: b) where
parseSumFromString opts key = (L1 <$> parseSumFromString opts key) <|>
(R1 <$> parseSumFromString opts key)
instance (Constructor c) => SumFromString (C1 c U1) where
parseSumFromString opts key | key == name = Just $ M1 U1
| otherwise = Nothing
where
name = pack $ constructorTagModifier opts $
conName (undefined :: t c U1 p)
parseNonAllNullarySum :: ( FromPair (a :+: b)
, FromTaggedObject (a :+: b)
) => Options -> Value -> Parser ((a :+: b) c)
parseNonAllNullarySum opts =
case sumEncoding opts of
TaggedObject{..} ->
withObject "Object" $ \obj -> do
tag <- obj .: pack tagFieldName
fromMaybe (notFound $ unpack tag) $
parseFromTaggedObject opts contentsFieldName obj tag
ObjectWithSingleField ->
withObject "Object" $ \obj ->
case H.toList obj of
[pair@(tag, _)] -> fromMaybe (notFound $ unpack tag) $
parsePair opts pair
_ -> fail "Object doesn't have a single field"
TwoElemArray ->
withArray "Array" $ \arr ->
if V.length arr == 2
then case V.unsafeIndex arr 0 of
String tag -> fromMaybe (notFound $ unpack tag) $
parsePair opts (tag, V.unsafeIndex arr 1)
_ -> fail "First element is not a String"
else fail "Array doesn't have 2 elements"
class FromTaggedObject f where
parseFromTaggedObject :: Options -> String -> Object -> Text
-> Maybe (Parser (f a))
instance (FromTaggedObject a, FromTaggedObject b) =>
FromTaggedObject (a :+: b) where
parseFromTaggedObject opts contentsFieldName obj tag =
(fmap L1 <$> parseFromTaggedObject opts contentsFieldName obj tag) <|>
(fmap R1 <$> parseFromTaggedObject opts contentsFieldName obj tag)
instance ( FromTaggedObject' f
, Constructor c ) => FromTaggedObject (C1 c f) where
parseFromTaggedObject opts contentsFieldName obj tag
| tag == name = Just $ M1 <$> parseFromTaggedObject'
opts contentsFieldName obj
| otherwise = Nothing
where
name = pack $ constructorTagModifier opts $
conName (undefined :: t c f p)
class FromTaggedObject' f where
parseFromTaggedObject' :: Options -> String -> Object -> Parser (f a)
class FromTaggedObject'' f isRecord where
parseFromTaggedObject'' :: Options -> String -> Object
-> Tagged isRecord (Parser (f a))
instance ( IsRecord f isRecord
, FromTaggedObject'' f isRecord
) => FromTaggedObject' f where
parseFromTaggedObject' opts contentsFieldName =
(unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a)) .
parseFromTaggedObject'' opts contentsFieldName
instance (FromRecord f) => FromTaggedObject'' f True where
parseFromTaggedObject'' opts _ = Tagged . parseRecord opts
instance (GFromJSON f) => FromTaggedObject'' f False where
parseFromTaggedObject'' opts contentsFieldName = Tagged .
(gParseJSON opts <=< (.: pack contentsFieldName))
class ConsFromJSON f where
consParseJSON :: Options -> Value -> Parser (f a)
class ConsFromJSON' f isRecord where
consParseJSON' :: Options -> Value -> Tagged isRecord (Parser (f a))
instance ( IsRecord f isRecord
, ConsFromJSON' f isRecord
) => ConsFromJSON f where
consParseJSON opts = (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))
. consParseJSON' opts
instance (FromRecord f) => ConsFromJSON' f True where
consParseJSON' opts = Tagged . (withObject "record (:*:)" $ parseRecord opts)
instance (GFromJSON f) => ConsFromJSON' f False where
consParseJSON' opts = Tagged . gParseJSON opts
class FromRecord f where
parseRecord :: Options -> Object -> Parser (f a)
instance (FromRecord a, FromRecord b) => FromRecord (a :*: b) where
parseRecord opts obj = (:*:) <$> parseRecord opts obj
<*> parseRecord opts obj
instance (Selector s, GFromJSON a) => FromRecord (S1 s a) where
parseRecord opts = maybe (notFound label) (gParseJSON opts)
. H.lookup (pack label)
where
label = fieldLabelModifier opts $ selName (undefined :: t s a p)
instance (Selector s, FromJSON a) => FromRecord (S1 s (K1 i (Maybe a))) where
parseRecord opts obj = (M1 . K1) <$> obj .:? pack label
where
label = fieldLabelModifier opts $
selName (undefined :: t s (K1 i (Maybe a)) p)
class ProductSize f where
productSize :: Tagged2 f Int
instance (ProductSize a, ProductSize b) => ProductSize (a :*: b) where
productSize = Tagged2 $ unTagged2 (productSize :: Tagged2 a Int) +
unTagged2 (productSize :: Tagged2 b Int)
instance ProductSize (S1 s a) where
productSize = Tagged2 1
class FromProduct f where
parseProduct :: Options -> Array -> Int -> Int -> Parser (f a)
instance (FromProduct a, FromProduct b) => FromProduct (a :*: b) where
parseProduct opts arr ix len =
(:*:) <$> parseProduct opts arr ix lenL
<*> parseProduct opts arr ixR lenR
where
#if MIN_VERSION_base(4,5,0)
lenL = len `unsafeShiftR` 1
#else
lenL = len `shiftR` 1
#endif
ixR = ix + lenL
lenR = len lenL
instance (GFromJSON a) => FromProduct (S1 s a) where
parseProduct opts arr ix _ = gParseJSON opts $ V.unsafeIndex arr ix
class FromPair f where
parsePair :: Options -> Pair -> Maybe (Parser (f a))
instance (FromPair a, FromPair b) => FromPair (a :+: b) where
parsePair opts pair = (fmap L1 <$> parsePair opts pair) <|>
(fmap R1 <$> parsePair opts pair)
instance (Constructor c, GFromJSON a, ConsFromJSON a) => FromPair (C1 c a) where
parsePair opts (tag, value)
| tag == tag' = Just $ gParseJSON opts value
| otherwise = Nothing
where
tag' = pack $ constructorTagModifier opts $
conName (undefined :: t c a p)
class IsRecord (f :: * -> *) isRecord | f -> isRecord
instance (IsRecord f isRecord) => IsRecord (f :*: g) isRecord
instance IsRecord (M1 S NoSelector f) False
instance (IsRecord f isRecord) => IsRecord (M1 S c f) isRecord
instance IsRecord (K1 i c) True
instance IsRecord U1 False
class AllNullary (f :: * -> *) allNullary | f -> allNullary
instance ( AllNullary a allNullaryL
, AllNullary b allNullaryR
, And allNullaryL allNullaryR allNullary
) => AllNullary (a :+: b) allNullary
instance AllNullary a allNullary => AllNullary (M1 i c a) allNullary
instance AllNullary (a :*: b) False
instance AllNullary (K1 i c) False
instance AllNullary U1 True
data True
data False
class And bool1 bool2 bool3 | bool1 bool2 -> bool3
instance And True True True
instance And False False False
instance And False True False
instance And True False False
newtype Tagged s b = Tagged {unTagged :: b}
newtype Tagged2 (s :: * -> *) b = Tagged2 {unTagged2 :: b}
notFound :: String -> Parser a
notFound key = fail $ "The key \"" ++ key ++ "\" was not found"