From 32a569fee70ad0df2fa630bf7f45ebcd93f7eb3c Mon Sep 17 00:00:00 2001
From: Iustin Pop <iustin@google.com>
Date: Tue, 13 Nov 2012 17:27:23 +0100
Subject: [PATCH] Cleanup THH function use from built module namespace
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Currently, THH.hs "injects" into the built code names of library
functions like Text.JSON.makeObj, Ganeti.JSON.fromObj, etc. built
directly from strings, via (e.g.)
varE (mkName "makeObj")
This means that the "makeObj" name must exist in the target module,
i.o.w. must be imported there. This leads to the strange case of
having to have imports that do not appear at all in the used
(template) code, but are needed to satisfy this "hidden" dependency;
look at Ganeti/Jobs.hs before this patch, for example.
This is also not very obvious, because we usually import Text.JSON
anyway; I only stumbled upon it while doing some cleanup work.
So to clean this up, the current patch changes the THH.hs to use not
string-derived, but identifier-derived names (Β«'identifierΒ» versus
Β«mkName "identifier"Β»); this is better, as the names must be
resolvable when compiling THH itself (once), and not when compiling
the multiple derived modules. As you can see, this allows removal of
extraneous imports from various modules.
Background information: an `mkName "foo"` results in a name of flavour
NameS (βAn unqualified name; dynamically boundβ) or alternatively to a
qualified name, but still dynamically bound. Whereas what we want is a
statically bound name: `'foo` results in a NameG flavour, βGlobal name
bound outside of the TH AST: An original nameβ.
One more explanation: the change is similar to going from 'x = eval
"map"' to 'x = map'; the name is no longer dynamically evaluated, but
statically when the module is compiled. In our case, previously names
were bound at target module compile time, now they are bound at THH.hs
compile time.
Signed-off-by: Iustin Pop <iustin@google.com>
Reviewed-by: Guido Trotter <ultrotter@google.com>
---
htest/Test/Ganeti/THH.hs | 1 -
htools/Ganeti/Confd/Types.hs | 1 -
htools/Ganeti/HTools/Types.hs | 2 --
htools/Ganeti/JSON.hs | 4 ++++
htools/Ganeti/Jobs.hs | 2 --
htools/Ganeti/Objects.hs | 2 +-
htools/Ganeti/OpCodes.hs | 2 +-
htools/Ganeti/Query/Language.hs | 1 -
htools/Ganeti/Rpc.hs | 2 --
htools/Ganeti/THH.hs | 37 ++++++++++++++++++++-------------
10 files changed, 29 insertions(+), 25 deletions(-)
diff --git a/htest/Test/Ganeti/THH.hs b/htest/Test/Ganeti/THH.hs
index 90f683c03..5d0c9d79d 100644
--- a/htest/Test/Ganeti/THH.hs
+++ b/htest/Test/Ganeti/THH.hs
@@ -34,7 +34,6 @@ import Test.QuickCheck
import Text.JSON
import Ganeti.THH
-import Ganeti.JSON
import Test.Ganeti.TestHelper
import Test.Ganeti.TestCommon
diff --git a/htools/Ganeti/Confd/Types.hs b/htools/Ganeti/Confd/Types.hs
index 4ac4eaead..44dbd030b 100644
--- a/htools/Ganeti/Confd/Types.hs
+++ b/htools/Ganeti/Confd/Types.hs
@@ -50,7 +50,6 @@ import Text.JSON
import qualified Ganeti.Constants as C
import Ganeti.THH
-import Ganeti.JSON
{-
Note that we re-export as is from Constants the following simple items:
diff --git a/htools/Ganeti/HTools/Types.hs b/htools/Ganeti/HTools/Types.hs
index 7efda992e..e0fdf5428 100644
--- a/htools/Ganeti/HTools/Types.hs
+++ b/htools/Ganeti/HTools/Types.hs
@@ -75,12 +75,10 @@ module Ganeti.HTools.Types
) where
import qualified Data.Map as M
-import Text.JSON (makeObj, readJSON, showJSON)
import qualified Ganeti.Constants as C
import qualified Ganeti.THH as THH
import Ganeti.BasicTypes
-import Ganeti.JSON
-- | The instance index type.
type Idx = Int
diff --git a/htools/Ganeti/JSON.hs b/htools/Ganeti/JSON.hs
index 178915a8c..1480140e8 100644
--- a/htools/Ganeti/JSON.hs
+++ b/htools/Ganeti/JSON.hs
@@ -50,6 +50,10 @@ import Text.Printf (printf)
import qualified Text.JSON as J
import Text.JSON.Pretty (pp_value)
+-- Note: this module should not import any Ganeti-specific modules
+-- beside BasicTypes, since it's used in THH which is used itself to
+-- build many other modules.
+
import Ganeti.BasicTypes
-- * JSON-related functions
diff --git a/htools/Ganeti/Jobs.hs b/htools/Ganeti/Jobs.hs
index 405f833b8..04ac18088 100644
--- a/htools/Ganeti/Jobs.hs
+++ b/htools/Ganeti/Jobs.hs
@@ -30,8 +30,6 @@ module Ganeti.Jobs
, JobStatus(..)
) where
-import Text.JSON (readJSON, showJSON, JSON)
-
import qualified Ganeti.Constants as C
import qualified Ganeti.THH as THH
diff --git a/htools/Ganeti/Objects.hs b/htools/Ganeti/Objects.hs
index dfc648038..71dd349d1 100644
--- a/htools/Ganeti/Objects.hs
+++ b/htools/Ganeti/Objects.hs
@@ -95,7 +95,7 @@ import Data.List (foldl')
import Data.Maybe
import qualified Data.Map as Map
import qualified Data.Set as Set
-import Text.JSON (makeObj, showJSON, readJSON, JSON, JSValue(..))
+import Text.JSON (showJSON, readJSON, JSON, JSValue(..))
import qualified Text.JSON as J
import qualified Ganeti.Constants as C
diff --git a/htools/Ganeti/OpCodes.hs b/htools/Ganeti/OpCodes.hs
index e2c91810f..c4f75f56f 100644
--- a/htools/Ganeti/OpCodes.hs
+++ b/htools/Ganeti/OpCodes.hs
@@ -39,7 +39,7 @@ module Ganeti.OpCodes
, allOpIDs
) where
-import Text.JSON (readJSON, showJSON, makeObj, JSON, JSValue(..), fromJSString)
+import Text.JSON (readJSON, showJSON, JSON, JSValue(..), fromJSString)
import Text.JSON.Pretty (pp_value)
import qualified Ganeti.Constants as C
diff --git a/htools/Ganeti/Query/Language.hs b/htools/Ganeti/Query/Language.hs
index 4128bcd95..bb2c07ea0 100644
--- a/htools/Ganeti/Query/Language.hs
+++ b/htools/Ganeti/Query/Language.hs
@@ -63,7 +63,6 @@ import qualified Text.Regex.PCRE as PCRE
import qualified Ganeti.Constants as C
import Ganeti.THH
-import Ganeti.JSON
-- * THH declarations, that require ordering.
diff --git a/htools/Ganeti/Rpc.hs b/htools/Ganeti/Rpc.hs
index 547cb2d60..f328b0e0c 100644
--- a/htools/Ganeti/Rpc.hs
+++ b/htools/Ganeti/Rpc.hs
@@ -73,7 +73,6 @@ module Ganeti.Rpc
import Control.Arrow (second)
import qualified Text.JSON as J
import Text.JSON.Pretty (pp_value)
-import Text.JSON (makeObj)
#ifndef NO_CURL
import Network.Curl
@@ -84,7 +83,6 @@ import qualified Ganeti.Constants as C
import Ganeti.Objects
import Ganeti.THH
import Ganeti.Compat
-import Ganeti.JSON
-- * Base RPC functionality and types
diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs
index 489413d78..338d40cc1 100644
--- a/htools/Ganeti/THH.hs
+++ b/htools/Ganeti/THH.hs
@@ -69,6 +69,8 @@ import Language.Haskell.TH
import qualified Text.JSON as JSON
import Text.JSON.Pretty (pp_value)
+import Ganeti.JSON
+
-- * Exported types
-- | Class of objects that can be converted to 'JSObject'
@@ -239,7 +241,15 @@ varNameE = varE . mkName
-- | showJSON as an expression, for reuse.
showJSONE :: Q Exp
-showJSONE = varNameE "showJSON"
+showJSONE = varE 'JSON.showJSON
+
+-- | makeObj as an expression, for reuse.
+makeObjE :: Q Exp
+makeObjE = varE 'JSON.makeObj
+
+-- | fromObj (Ganeti specific) as an expression, for reuse.
+fromObjE :: Q Exp
+fromObjE = varE 'fromObj
-- | ToRaw function name.
toRawName :: String -> Name
@@ -394,7 +404,7 @@ declareSADT = declareADT ''String
genShowJSON :: String -> Q Dec
genShowJSON name = do
body <- [| JSON.showJSON . $(varE (toRawName name)) |]
- return $ FunD (mkName "showJSON") [Clause [] (NormalB body) []]
+ return $ FunD 'JSON.showJSON [Clause [] (NormalB body) []]
-- | Creates the readJSON member of a JSON instance declaration.
--
@@ -417,7 +427,7 @@ genReadJSON name = do
$(stringE name) ++ ": " ++ e ++ " from " ++
show $(varE s)
|]
- return $ FunD (mkName "readJSON") [Clause [VarP s] (NormalB body) []]
+ return $ FunD 'JSON.readJSON [Clause [VarP s] (NormalB body) []]
-- | Generates a JSON instance for a given type.
--
@@ -546,7 +556,7 @@ saveConstructor sname fields = do
JSON.showJSON $(stringE . deCamelCase $ sname) )] |]
flist = listE (opid:felems)
-- and finally convert all this to a json object
- flist' = [| $(varNameE "makeObj") (concat $flist) |]
+ flist' = [| $makeObjE (concat $flist) |]
clause [pat] (normalB flist') []
-- | Generates the main save opcode function.
@@ -583,8 +593,7 @@ genLoadOpCode opdefs = do
opid = mkName "op_id"
st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
(JSON.readJSON $(varE arg1)) |]
- st2 <- bindS (varP opid) [| $(varNameE "fromObj")
- $(varE objname) $(stringE "OP_ID") |]
+ st2 <- bindS (varP opid) [| $fromObjE $(varE objname) $(stringE "OP_ID") |]
-- the match results (per-constructor blocks)
mexps <- mapM (uncurry loadConstructor) opdefs
fails <- [| fail $ "Unknown opcode " ++ $(varE opid) |]
@@ -706,7 +715,7 @@ genSaveObject save_fn sname fields = do
tdlist = [| concat $flist |]
iname = mkName "i"
tclause <- clause [pat] (normalB tdlist) []
- cclause <- [| $(varNameE "makeObj") . $(varE tdname) |]
+ cclause <- [| $makeObjE . $(varE tdname) |]
let fname = mkName ("save" ++ sname)
sigt <- [t| $(conT name) -> JSON.JSValue |]
return [SigD tdname tdsigt, FunD tdname [tclause],
@@ -741,7 +750,7 @@ saveObjectField fvar field =
objectShowJSON :: String -> Q Dec
objectShowJSON name = do
body <- [| JSON.showJSON . $(varE . mkName $ "save" ++ name) |]
- return $ FunD (mkName "showJSON") [Clause [] (NormalB body) []]
+ return $ FunD 'JSON.showJSON [Clause [] (NormalB body) []]
-- | Generates the load object functionality.
genLoadObject :: (Field -> Q (Name, Stmt))
@@ -775,12 +784,12 @@ loadObjectField field = do
-- we treat both optional types the same, since
-- 'maybeFromObj' can deal with both missing and null values
-- appropriately (the same)
- then [| $(varNameE "maybeFromObj") $objvar $objfield |]
+ then [| $(varE 'maybeFromObj) $objvar $objfield |]
else case fieldDefault field of
Just defv ->
- [| $(varNameE "fromObjWithDefault") $objvar
+ [| $(varE 'fromObjWithDefault) $objvar
$objfield $defv |]
- Nothing -> [| $(varNameE "fromObj") $objvar $objfield |]
+ Nothing -> [| $fromObjE $objvar $objfield |]
bexp <- loadFn field loadexp objvar
return (fvar, BindS (VarP fvar) bexp)
@@ -795,7 +804,7 @@ objectReadJSON name = do
JSON.Error $ "Can't parse value for type " ++
$(stringE name) ++ ": " ++ e
|]
- return $ FunD (mkName "readJSON") [Clause [VarP s] (NormalB body) []]
+ return $ FunD 'JSON.readJSON [Clause [VarP s] (NormalB body) []]
-- * Inheritable parameter tables implementation
@@ -886,7 +895,7 @@ loadPParamField field = do
-- these are used in all patterns below
let objvar = varNameE "o"
objfield = stringE name
- loadexp = [| $(varNameE "maybeFromObj") $objvar $objfield |]
+ loadexp = [| $(varE 'maybeFromObj) $objvar $objfield |]
bexp <- loadFn field loadexp objvar
return (fvar, BindS (VarP fvar) bexp)
@@ -894,7 +903,7 @@ loadPParamField field = do
buildFromMaybe :: String -> Q Dec
buildFromMaybe fname =
valD (varP (mkName $ "n_" ++ fname))
- (normalB [| $(varNameE "fromMaybe")
+ (normalB [| $(varE 'fromMaybe)
$(varNameE $ "f_" ++ fname)
$(varNameE $ "p_" ++ fname) |]) []
--
GitLab