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 -- 2.6.0.rc2.230.g3dd15c0
