module Data.Aeson.Generic
(
fromJSON
, toJSON
) where
import Control.Applicative ((<$>))
import Control.Arrow (first)
import Control.Monad.State.Strict
import Data.Aeson.Functions (transformMap)
import Data.Aeson.Types hiding (FromJSON(..), ToJSON(..), fromJSON)
import Data.Attoparsec.Number (Number)
import Data.Generics
import Data.Int (Int8, Int16, Int32, Int64)
import Data.IntSet (IntSet)
import Data.Text (Text, pack, unpack)
import Data.Time.Clock (UTCTime)
import Data.Word (Word, Word8, Word16, Word32, Word64)
import qualified Data.Aeson.Types as T
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.Map as Map
import qualified Data.Traversable as T
import qualified Data.Set as Set
import qualified Data.Text.Lazy as L
import qualified Data.Vector as V
type T a = a -> Value
toJSON :: (Data a) => a -> Value
toJSON = toJSON_generic
`ext1Q` list
`ext1Q` vector
`ext1Q` set
`ext1Q` mapText
`ext1Q` mapLazyText
`ext1Q` mapString
`extQ` (T.toJSON :: T Integer)
`extQ` (T.toJSON :: T Int)
`extQ` (T.toJSON :: T Int8)
`extQ` (T.toJSON :: T Int16)
`extQ` (T.toJSON :: T Int32)
`extQ` (T.toJSON :: T Int64)
`extQ` (T.toJSON :: T Word)
`extQ` (T.toJSON :: T Word8)
`extQ` (T.toJSON :: T Word16)
`extQ` (T.toJSON :: T Word32)
`extQ` (T.toJSON :: T Word64)
`extQ` (T.toJSON :: T Double)
`extQ` (T.toJSON :: T Number)
`extQ` (T.toJSON :: T Float)
`extQ` (T.toJSON :: T Rational)
`extQ` (T.toJSON :: T Char)
`extQ` (T.toJSON :: T Text)
`extQ` (T.toJSON :: T L.Text)
`extQ` (T.toJSON :: T String)
`extQ` (T.toJSON :: T B.ByteString)
`extQ` (T.toJSON :: T L.ByteString)
`extQ` (T.toJSON :: T T.Value)
`extQ` (T.toJSON :: T DotNetTime)
`extQ` (T.toJSON :: T UTCTime)
`extQ` (T.toJSON :: T IntSet)
`extQ` (T.toJSON :: T Bool)
`extQ` (T.toJSON :: T ())
where
list xs = Array . V.fromList . map toJSON $ xs
vector v = Array . V.map toJSON $ v
set s = Array . V.fromList . map toJSON . Set.toList $ s
mapText m = Object . Map.map toJSON $ m
mapLazyText m = Object . transformMap L.toStrict toJSON $ m
mapString m = Object . transformMap pack toJSON $ m
toJSON_generic :: (Data a) => a -> Value
toJSON_generic = generic
where
generic a =
case dataTypeRep (dataTypeOf a) of
AlgRep [] -> Null
AlgRep [c] -> encodeArgs c (gmapQ toJSON a)
AlgRep _ -> encodeConstr (toConstr a) (gmapQ toJSON a)
rep -> err (dataTypeOf a) rep
where
err dt r = error $ "Data.Aeson.Generic.toJSON: not AlgRep " ++
show r ++ "(" ++ show dt ++ ")"
encodeConstr c [] = String . constrString $ c
encodeConstr c as = object [(constrString c, encodeArgs c as)]
constrString = pack . showConstr
encodeArgs c = encodeArgs' (constrFields c)
encodeArgs' [] [j] = j
encodeArgs' [] js = Array . V.fromList $ js
encodeArgs' ns js = object $ zip (map mungeField ns) js
mungeField ('_':cs) = pack cs
mungeField cs = pack cs
fromJSON :: (Data a) => Value -> Result a
fromJSON = parse parseJSON
type F a = Parser a
parseJSON :: (Data a) => Value -> Parser a
parseJSON j = parseJSON_generic j
`ext1R` list
`ext1R` vector
`ext1R` mapText
`ext1R` mapLazyText
`ext1R` mapString
`extR` (value :: F Integer)
`extR` (value :: F Int)
`extR` (value :: F Int8)
`extR` (value :: F Int16)
`extR` (value :: F Int32)
`extR` (value :: F Int64)
`extR` (value :: F Word)
`extR` (value :: F Word8)
`extR` (value :: F Word16)
`extR` (value :: F Word32)
`extR` (value :: F Word64)
`extR` (value :: F Double)
`extR` (value :: F Number)
`extR` (value :: F Float)
`extR` (value :: F Rational)
`extR` (value :: F Char)
`extR` (value :: F Text)
`extR` (value :: F L.Text)
`extR` (value :: F String)
`extR` (value :: F B.ByteString)
`extR` (value :: F L.ByteString)
`extR` (value :: F T.Value)
`extR` (value :: F DotNetTime)
`extR` (value :: F UTCTime)
`extR` (value :: F IntSet)
`extR` (value :: F Bool)
`extR` (value :: F ())
where
value :: (T.FromJSON a) => Parser a
value = T.parseJSON j
list :: (Data a) => Parser [a]
list = V.toList <$> parseJSON j
vector :: (Data a) => Parser (V.Vector a)
vector = case j of
Array js -> V.mapM parseJSON js
_ -> modFail "parseJSON" $ "bad data: " ++ show j
mapText :: (Data a) => Parser (Map.Map Text a)
mapText = case j of
Object js -> T.mapM parseJSON js
_ -> modFail "parseJSON" $ "bad data: " ++ show j
mapLazyText :: (Data a) => Parser (Map.Map L.Text a)
mapLazyText = Map.mapKeysMonotonic L.fromStrict <$> parseJSON j
mapString :: (Data a) => Parser (Map.Map String a)
mapString = Map.mapKeysMonotonic unpack <$> parseJSON j
parseJSON_generic :: (Data a) => Value -> Parser a
parseJSON_generic j = generic
where
typ = dataTypeOf $ resType generic
generic = case dataTypeRep typ of
AlgRep [] -> case j of
Null -> return (error "Empty type")
_ -> modFail "parseJSON" "no-constr bad data"
AlgRep [_] -> decodeArgs (indexConstr typ 1) j
AlgRep _ -> do (c, j') <- getConstr typ j; decodeArgs c j'
rep -> modFail "parseJSON" $
show rep ++ "(" ++ show typ ++ ")"
getConstr t (Object o) | [(s, j')] <- fromJSObject o = do
c <- readConstr' t s
return (c, j')
getConstr t (String js) = do c <- readConstr' t (unpack js)
return (c, Null)
getConstr _ _ = modFail "parseJSON" "bad constructor encoding"
readConstr' t s =
maybe (modFail "parseJSON" $ "unknown constructor: " ++ s ++ " " ++
show t)
return $ readConstr t s
decodeArgs c0 = go (numConstrArgs (resType generic) c0) c0
(constrFields c0)
where
go 0 c _ Null = construct c []
go 1 c [] jd = construct c [jd]
go n c [] (Array js)
| n > 1 = construct c (V.toList js)
go _ c fs@(_:_) (Object o) = selectFields o fs >>=
construct c
go _ c _ jd = modFail "parseJSON" $
"bad decodeArgs data " ++ show (c, jd)
fromJSObject = map (first unpack) . Map.toList
construct c = evalStateT $ fromConstrM f c
where f :: (Data a) => StateT [Value] Parser a
f = do js <- get
case js of
[] -> lift $ modFail "construct" "empty list"
(j':js') -> do put js'; lift $ parseJSON j'
selectFields fjs = mapM sel
where sel f = maybe (modFail "parseJSON" $ "field does not exist " ++
f) return $ Map.lookup (pack f) fjs
numConstrArgs :: (Data a) => a -> Constr -> Int
numConstrArgs x c = execState (fromConstrM f c `asTypeOf` return x) 0
where f = do modify (+1); return undefined
resType :: MonadPlus m => m a -> a
resType _ = error "resType"
modFail :: (Monad m) => String -> String -> m a
modFail func err = fail $ "Data.Aeson.Generic." ++ func ++ ": " ++ err