LGTM, thanks
On 11/19/2015 01:04 PM, 'Klaus Aehlig' via ganeti-devel wrote:
When generating error messages, the raw JSValue is rarely
useful. However, keeping it for error messages---even if
only in the unused branch of an if statement---prevents this
value from going out of scope.
Note: with the smaller number of arguments in the readJSONWithDesc
function, newer versions of ghc try too fancy optimisations and thus
run out of memory; hence we have to reduce the ghc optimisation level
for some files.
Signed-off-by: Klaus Aehlig <[email protected]>
---
src/Ganeti/JSON.hs | 8 ++------
src/Ganeti/Objects/Instance.hs | 1 +
src/Ganeti/OpCodes.hs | 2 +-
src/Ganeti/THH.hs | 6 +++---
4 files changed, 7 insertions(+), 10 deletions(-)
diff --git a/src/Ganeti/JSON.hs b/src/Ganeti/JSON.hs
index 24938e3..823dc31 100644
--- a/src/Ganeti/JSON.hs
+++ b/src/Ganeti/JSON.hs
@@ -135,16 +135,12 @@ type JSRecord = [JSField]
-- is being parsed into what.
readJSONWithDesc :: (J.JSON a)
=> String -- ^ description of @a@
- -> Bool -- ^ include input in
- -- error messages
-> J.JSValue -- ^ input value
-> J.Result a
-readJSONWithDesc name incInput input =
+readJSONWithDesc name input =
case J.readJSON input of
J.Ok r -> J.Ok r
- J.Error e -> J.Error $ if incInput then msg ++ " from " ++ show input
- else msg
- where msg = "Can't parse value for '" ++ name ++ "': " ++ e
+ J.Error e -> J.Error $ "Can't parse value for '" ++ name ++ "': " ++ e
-- | Converts a JSON Result into a monadic value.
fromJResult :: Monad m => String -> J.Result a -> m a
diff --git a/src/Ganeti/Objects/Instance.hs b/src/Ganeti/Objects/Instance.hs
index fd8c3d9..e312983 100644
--- a/src/Ganeti/Objects/Instance.hs
+++ b/src/Ganeti/Objects/Instance.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE TemplateHaskell, FunctionalDependencies #-}
+{-# OPTIONS_GHC -O0 #-}
{-| Implementation of the Ganeti Instance config object.
diff --git a/src/Ganeti/OpCodes.hs b/src/Ganeti/OpCodes.hs
index 37b645e..c6ffa5d 100644
--- a/src/Ganeti/OpCodes.hs
+++ b/src/Ganeti/OpCodes.hs
@@ -1,5 +1,5 @@
{-# LANGUAGE ExistentialQuantification, TemplateHaskell, StandaloneDeriving
#-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-orphans -O0 #-}
{-| Implementation of the opcodes.
diff --git a/src/Ganeti/THH.hs b/src/Ganeti/THH.hs
index 91f4c53..33c057b 100644
--- a/src/Ganeti/THH.hs
+++ b/src/Ganeti/THH.hs
@@ -324,7 +324,7 @@ parseFn :: Field -- ^ The field definition
-> Q Exp -- ^ The resulting function that parses a JSON message
parseFn field o =
let fnType = [t| JSON.JSValue -> JSON.Result $(fieldType field) |]
- expr = maybe [| readJSONWithDesc $(stringE $ fieldName field) False |]
+ expr = maybe [| readJSONWithDesc $(stringE $ fieldName field) |]
(`appE` o) (fieldRead field)
in sigE expr fnType
@@ -580,7 +580,7 @@ genReadJSON :: String -> Q Dec
genReadJSON name = do
let s = mkName "s"
body <- [| $(varE (fromRawName name)) =<<
- readJSONWithDesc $(stringE name) True $(varE s) |]
+ readJSONWithDesc $(stringE name) $(varE s) |]
return $ FunD 'JSON.readJSON [Clause [VarP s] (NormalB body) []]
-- | Generates a JSON instance for a given type.
@@ -1299,7 +1299,7 @@ objectReadJSON :: String -> Q Dec
objectReadJSON name = do
let s = mkName "s"
body <- [| $(varE . mkName $ "load" ++ name) =<<
- readJSONWithDesc $(stringE name) False $(varE s) |]
+ readJSONWithDesc $(stringE name) $(varE s) |]
return $ FunD 'JSON.readJSON [Clause [VarP s] (NormalB body) []]
-- * Inheritable parameter tables implementation
