module Data.Aeson.TH
( deriveJSON
, deriveToJSON
, deriveFromJSON
, mkToJSON
, mkParseJSON
) where
import Data.Aeson ( toJSON, Object, object, (.=)
, ToJSON, toJSON
, FromJSON, parseJSON
)
import Data.Aeson.Types ( Value(..), Parser )
import Control.Applicative ( pure, (<$>), (<*>) )
import Control.Monad ( return, mapM, liftM2, fail )
import Data.Bool ( otherwise )
import Data.Eq ( (==) )
import Data.Function ( ($), (.), id )
import Data.Functor ( fmap )
import Data.List ( (++), foldl, foldl', intercalate
, length, map, zip, genericLength
)
import Data.Maybe ( Maybe(Nothing, Just) )
import Prelude ( String, (), Integer, fromIntegral, error )
import Text.Printf ( printf )
import Text.Show ( show )
#if __GLASGOW_HASKELL__ < 700
import Control.Monad ( (>>=) )
import Prelude ( fromInteger )
#endif
import qualified Data.HashMap.Strict as H ( lookup, toList, size )
import Language.Haskell.TH
import qualified Data.Text as T ( Text, pack, unpack )
import qualified Data.Vector as V ( unsafeIndex, null, length, create )
import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite )
deriveJSON :: (String -> String)
-> Name
-> Q [Dec]
deriveJSON withField name =
liftM2 (++)
(deriveToJSON withField name)
(deriveFromJSON withField name)
deriveToJSON :: (String -> String)
-> Name
-> Q [Dec]
deriveToJSON withField name =
withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons
where
fromCons :: [TyVarBndr] -> [Con] -> Q Dec
fromCons tvbs cons =
instanceD (return $ map (\t -> ClassP ''ToJSON [VarT t]) typeNames)
(classType `appT` instanceType)
[ funD 'toJSON
[ clause []
(normalB $ consToJSON withField cons)
[]
]
]
where
classType = conT ''ToJSON
typeNames = map tvbName tvbs
instanceType = foldl' appT (conT name) $ map varT typeNames
mkToJSON :: (String -> String)
-> Name
-> Q Exp
mkToJSON withField name = withType name (\_ cons -> consToJSON withField cons)
consToJSON :: (String -> String)
-> [Con]
-> Q Exp
consToJSON _ [] = error $ "Data.Aeson.TH.consToJSON: "
++ "Not a single constructor given!"
consToJSON withField [con] = do
value <- newName "value"
lam1E (varP value)
$ caseE (varE value)
[encodeArgs id withField con]
consToJSON withField cons = do
value <- newName "value"
lam1E (varP value)
$ caseE (varE value)
[ encodeArgs (wrap $ getConName con) withField con
| con <- cons
]
where
wrap :: Name -> Q Exp -> Q Exp
wrap name exp =
let fieldName = [e|T.pack|] `appE` litE (stringL $ nameBase name)
in [e|object|] `appE` listE [ infixApp fieldName
[e|(.=)|]
exp
]
encodeArgs :: (Q Exp -> Q Exp) -> (String -> String) -> Con -> Q Match
encodeArgs withExp _ (NormalC conName []) =
match (conP conName [])
(normalB $ withExp [e|toJSON ([] :: [()])|])
[]
encodeArgs withExp _ (NormalC conName ts) = do
let len = length ts
args <- mapM newName ["arg" ++ show n | n <- [1..len]]
js <- case [[e|toJSON|] `appE` varE arg | arg <- args] of
[e] -> return e
es -> do
mv <- newName "mv"
let newMV = bindS (varP mv)
([e|VM.unsafeNew|] `appE`
litE (integerL $ fromIntegral len))
stmts = [ noBindS $
[e|VM.unsafeWrite|] `appE`
(varE mv) `appE`
litE (integerL ix) `appE`
e
| (ix, e) <- zip [(0::Integer)..] es
]
ret = noBindS $ [e|return|] `appE` varE mv
return $ [e|Array|] `appE`
(varE 'V.create `appE`
doE (newMV:stmts++[ret]))
match (conP conName $ map varP args)
(normalB $ withExp js)
[]
encodeArgs withExp withField (RecC conName ts) = do
args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]
let js = [ infixApp ([e|T.pack|] `appE` fieldNameExp withField field)
[e|(.=)|]
(varE arg)
| (arg, (field, _, _)) <- zip args ts
]
match (conP conName $ map varP args)
(normalB $ withExp $ [e|object|] `appE` listE js)
[]
encodeArgs withExp _ (InfixC _ conName _) = do
al <- newName "argL"
ar <- newName "argR"
match (infixP (varP al) conName (varP ar))
( normalB
$ withExp
$ [e|toJSON|] `appE` listE [ [e|toJSON|] `appE` varE a
| a <- [al,ar]
]
)
[]
encodeArgs withExp withField (ForallC _ _ con) =
encodeArgs withExp withField con
deriveFromJSON :: (String -> String)
-> Name
-> Q [Dec]
deriveFromJSON withField name =
withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons
where
fromCons :: [TyVarBndr] -> [Con] -> Q Dec
fromCons tvbs cons =
instanceD (return $ map (\t -> ClassP ''FromJSON [VarT t]) typeNames)
(classType `appT` instanceType)
[ funD 'parseJSON
[ clause []
(normalB $ consFromJSON name withField cons)
[]
]
]
where
classType = conT ''FromJSON
typeNames = map tvbName tvbs
instanceType = foldl' appT (conT name) $ map varT typeNames
mkParseJSON :: (String -> String)
-> Name
-> Q Exp
mkParseJSON withField name =
withType name (\_ cons -> consFromJSON name withField cons)
consFromJSON :: Name
-> (String -> String)
-> [Con]
-> Q Exp
consFromJSON _ _ [] = error $ "Data.Aeson.TH.consFromJSON: "
++ "Not a single constructor given!"
consFromJSON tName withField [con] = do
value <- newName "value"
lam1E (varP value)
$ caseE (varE value)
(parseArgs tName withField con)
consFromJSON tName withField cons = do
value <- newName "value"
obj <- newName "obj"
conKey <- newName "conKey"
conVal <- newName "conVal"
let
caseLst = caseE ([e|H.toList|] `appE` varE obj)
[ match (listP [tupP [varP conKey, varP conVal]])
(normalB caseKey)
[]
, do other <- newName "other"
match (varP other)
(normalB $ [|wrongPairCountFail|]
`appE` (litE $ stringL $ show tName)
`appE` ([|show . length|] `appE` varE other)
)
[]
]
caseKey = caseE (varE conKey)
[match wildP (guardedB guards) []]
guards = [ do g <- normalG $ infixApp (varE conKey)
[|(==)|]
( [|T.pack|]
`appE` conNameExp con
)
e <- caseE (varE conVal)
(parseArgs tName withField con)
return (g, e)
| con <- cons
]
++
[ liftM2 (,)
(normalG [e|otherwise|])
( [|conNotFoundFail|]
`appE` (litE $ stringL $ show tName)
`appE` listE (map (litE . stringL . nameBase . getConName) cons)
`appE` ([|T.unpack|] `appE` varE conKey)
)
]
lam1E (varP value)
$ caseE (varE value)
[ match (conP 'Object [varP obj])
(normalB caseLst)
[]
, do other <- newName "other"
match (varP other)
( normalB
$ [|noObjectFail|]
`appE` (litE $ stringL $ show tName)
`appE` ([|valueConName|] `appE` varE other)
)
[]
]
parseArgs :: Name
-> (String -> String)
-> Con
-> [Q Match]
parseArgs tName _ (NormalC conName []) =
[ do arr <- newName "arr"
match (conP 'Array [varP arr])
( normalB $ condE ([|V.null|] `appE` varE arr)
([e|pure|] `appE` conE conName)
( parseTypeMismatch tName conName
(litE $ stringL "an empty Array")
( infixApp (litE $ stringL $ "Array of length ")
[|(++)|]
([|show . V.length|] `appE` varE arr)
)
)
)
[]
, matchFailed tName conName "Array"
]
parseArgs _ _ (NormalC conName [_]) =
[ do arg <- newName "arg"
match (varP arg)
( normalB $ infixApp (conE conName)
[e|(<$>)|]
([e|parseJSON|] `appE` varE arg)
)
[]
]
parseArgs tName _ (NormalC conName ts) = parseProduct tName conName $ genericLength ts
parseArgs tName withField (RecC conName ts) =
[ do obj <- newName "recObj"
let x:xs = [ [|lookupField|]
`appE` (litE $ stringL $ show tName)
`appE` (litE $ stringL $ nameBase conName)
`appE` (varE obj)
`appE` ( [e|T.pack|]
`appE`
fieldNameExp withField field
)
| (field, _, _) <- ts
]
match (conP 'Object [varP obj])
( normalB $ condE ( infixApp ([|H.size|] `appE` varE obj)
[|(==)|]
(litE $ integerL $ genericLength ts)
)
( foldl' (\a b -> infixApp a [|(<*>)|] b)
(infixApp (conE conName) [|(<$>)|] x)
xs
)
( parseTypeMismatch tName conName
( litE $ stringL $ "Object with "
++ show (length ts)
++ " name/value pairs"
)
( infixApp ([|show . H.size|] `appE` varE obj)
[|(++)|]
(litE $ stringL $ " name/value pairs")
)
)
)
[]
, matchFailed tName conName "Object"
]
parseArgs tName _ (InfixC _ conName _) = parseProduct tName conName 2
parseArgs tName withField (ForallC _ _ con) = parseArgs tName withField con
parseProduct :: Name
-> Name
-> Integer
-> [Q Match]
parseProduct tName conName numArgs =
[ do arr <- newName "arr"
let x:xs = [ [|parseJSON|]
`appE`
infixApp (varE arr)
[|V.unsafeIndex|]
(litE $ integerL ix)
| ix <- [0 .. numArgs 1]
]
match (conP 'Array [varP arr])
(normalB $ condE ( infixApp ([|V.length|] `appE` varE arr)
[|(==)|]
(litE $ integerL numArgs)
)
( foldl' (\a b -> infixApp a [|(<*>)|] b)
(infixApp (conE conName) [|(<$>)|] x)
xs
)
( parseTypeMismatch tName conName
(litE $ stringL $ "Array of length " ++ show numArgs)
( infixApp (litE $ stringL $ "Array of length ")
[|(++)|]
([|show . V.length|] `appE` varE arr)
)
)
)
[]
, matchFailed tName conName "Array"
]
matchFailed :: Name -> Name -> String -> MatchQ
matchFailed tName conName expected = do
other <- newName "other"
match (varP other)
( normalB $ parseTypeMismatch tName conName
(litE $ stringL expected)
([|valueConName|] `appE` varE other)
)
[]
parseTypeMismatch :: Name -> Name -> ExpQ -> ExpQ -> ExpQ
parseTypeMismatch tName conName expected actual =
foldl appE
[|parseTypeMismatch'|]
[ litE $ stringL $ nameBase conName
, litE $ stringL $ show tName
, expected
, actual
]
lookupField :: (FromJSON a) => String -> String -> Object -> T.Text -> Parser a
lookupField tName rec obj key =
case H.lookup key obj of
Nothing -> unknownFieldFail tName rec (T.unpack key)
Just v -> parseJSON v
unknownFieldFail :: String -> String -> String -> Parser fail
unknownFieldFail tName rec key =
fail $ printf "When parsing the record %s of type %s the key %s was not present."
rec tName key
noObjectFail :: String -> String -> Parser fail
noObjectFail t o =
fail $ printf "When parsing %s expected Object but got %s." t o
wrongPairCountFail :: String -> String -> Parser fail
wrongPairCountFail t n =
fail $ printf "When parsing %s expected an Object with a single name/value pair but got %s pairs."
t n
conNotFoundFail :: String -> [String] -> String -> Parser fail
conNotFoundFail t cs o =
fail $ printf "When parsing %s expected an Object with a name/value pair where the name is one of [%s], but got %s."
t (intercalate ", " cs) o
parseTypeMismatch' :: String -> String -> String -> String -> Parser fail
parseTypeMismatch' tName conName expected actual =
fail $ printf "When parsing the constructor %s of type %s expected %s but got %s."
conName tName expected actual
withType :: Name
-> ([TyVarBndr] -> [Con] -> Q a)
-> Q a
withType name f = do
info <- reify name
case info of
TyConI dec ->
case dec of
DataD _ _ tvbs cons _ -> f tvbs cons
NewtypeD _ _ tvbs con _ -> f tvbs [con]
other -> error $ "Data.Aeson.TH.withType: Unsupported type: "
++ show other
_ -> error "Data.Aeson.TH.withType: I need the name of a type."
getConName :: Con -> Name
getConName (NormalC name _) = name
getConName (RecC name _) = name
getConName (InfixC _ name _) = name
getConName (ForallC _ _ con) = getConName con
tvbName :: TyVarBndr -> Name
tvbName (PlainTV name ) = name
tvbName (KindedTV name _) = name
conNameExp :: Con -> Q Exp
conNameExp = litE . stringL . nameBase . getConName
fieldNameExp :: (String -> String)
-> Name
-> Q Exp
fieldNameExp f = litE . stringL . f . nameBase
valueConName :: Value -> String
valueConName (Object _) = "Object"
valueConName (Array _) = "Array"
valueConName (String _) = "String"
valueConName (Number _) = "Number"
valueConName (Bool _) = "Boolean"
valueConName Null = "Null"