From ffbd959219b2d6d0c41c5d811786337f71ff7f48 Mon Sep 17 00:00:00 2001 From: Iustin Pop <iustin@google.com> Date: Sat, 24 Mar 2012 23:34:42 +0100 Subject: [PATCH] Fix compatibility with TemplateHaskell from GHC 7.4 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit GHC 7.4 has updated the TemplateHaskell library, and it turns out that the way we built the JSON instance implementation for showJSON was not good (probably this is why GHC 6.12 was generating some warnings). The patch changes the build of showJSON to be the same as readJSON, which was working fine. As a bonus, this fixes both the 7.4 issue and the 6.12 one. Signed-off-by: Iustin Pop <iustin@google.com> Reviewed-by: RenΓ© Nussbaumer <rn@google.com> --- htools/Ganeti/THH.hs | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs index 2c036550b..1ad017970 100644 --- a/htools/Ganeti/THH.hs +++ b/htools/Ganeti/THH.hs @@ -328,8 +328,10 @@ declareSADT = declareADT ''String -- @ -- -- in an instance JSON /name/ declaration -genShowJSON :: String -> Q [Dec] -genShowJSON name = [d| showJSON = JSON.showJSON . $(varE (toRawName name)) |] +genShowJSON :: String -> Q Dec +genShowJSON name = do + body <- [| JSON.showJSON . $(varE (toRawName name)) |] + return $ FunD (mkName "showJSON") [Clause [] (NormalB body) []] -- | Creates the readJSON member of a JSON instance declaration. -- @@ -363,7 +365,7 @@ makeJSONInstance name = do let base = nameBase name showJ <- genShowJSON base readJ <- genReadJSON base - return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) (readJ:showJ)] + return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) [readJ,showJ]] -- * Template code for opcodes @@ -595,7 +597,7 @@ buildObjectSerialisation sname fields = do shjson <- objectShowJSON sname rdjson <- objectReadJSON sname let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) - (rdjson:shjson) + [rdjson, shjson] return $ savedecls ++ [loadsig, loadfn, instdecl] genSaveObject :: (Name -> Field -> Q Exp) @@ -634,9 +636,10 @@ saveObjectField fvar field nameE = stringE (fieldName field) fvarE = varE fvar -objectShowJSON :: String -> Q [Dec] -objectShowJSON name = - [d| showJSON = JSON.showJSON . $(varE . mkName $ "save" ++ name) |] +objectShowJSON :: String -> Q Dec +objectShowJSON name = do + body <- [| JSON.showJSON . $(varE . mkName $ "save" ++ name) |] + return $ FunD (mkName "showJSON") [Clause [] (NormalB body) []] genLoadObject :: (Field -> Q (Name, Stmt)) -> String -> [Field] -> Q (Dec, Dec) @@ -732,7 +735,7 @@ buildPParamSerialisation sname fields = do shjson <- objectShowJSON sname rdjson <- objectReadJSON sname let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) - (rdjson:shjson) + [rdjson, shjson] return $ savedecls ++ [loadsig, loadfn, instdecl] savePParamField :: Name -> Field -> Q Exp -- GitLab