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