Commit 32a569fe authored by Iustin Pop's avatar Iustin Pop

Cleanup THH function use from built module namespace

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: default avatarIustin Pop <iustin@google.com>
Reviewed-by: default avatarGuido Trotter <ultrotter@google.com>
parent 61899e64
...@@ -34,7 +34,6 @@ import Test.QuickCheck ...@@ -34,7 +34,6 @@ import Test.QuickCheck
import Text.JSON import Text.JSON
import Ganeti.THH import Ganeti.THH
import Ganeti.JSON
import Test.Ganeti.TestHelper import Test.Ganeti.TestHelper
import Test.Ganeti.TestCommon import Test.Ganeti.TestCommon
......
...@@ -50,7 +50,6 @@ import Text.JSON ...@@ -50,7 +50,6 @@ import Text.JSON
import qualified Ganeti.Constants as C import qualified Ganeti.Constants as C
import Ganeti.THH import Ganeti.THH
import Ganeti.JSON
{- {-
Note that we re-export as is from Constants the following simple items: Note that we re-export as is from Constants the following simple items:
......
...@@ -75,12 +75,10 @@ module Ganeti.HTools.Types ...@@ -75,12 +75,10 @@ module Ganeti.HTools.Types
) where ) where
import qualified Data.Map as M import qualified Data.Map as M
import Text.JSON (makeObj, readJSON, showJSON)
import qualified Ganeti.Constants as C import qualified Ganeti.Constants as C
import qualified Ganeti.THH as THH import qualified Ganeti.THH as THH
import Ganeti.BasicTypes import Ganeti.BasicTypes
import Ganeti.JSON
-- | The instance index type. -- | The instance index type.
type Idx = Int type Idx = Int
......
...@@ -50,6 +50,10 @@ import Text.Printf (printf) ...@@ -50,6 +50,10 @@ import Text.Printf (printf)
import qualified Text.JSON as J import qualified Text.JSON as J
import Text.JSON.Pretty (pp_value) 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 import Ganeti.BasicTypes
-- * JSON-related functions -- * JSON-related functions
......
...@@ -30,8 +30,6 @@ module Ganeti.Jobs ...@@ -30,8 +30,6 @@ module Ganeti.Jobs
, JobStatus(..) , JobStatus(..)
) where ) where
import Text.JSON (readJSON, showJSON, JSON)
import qualified Ganeti.Constants as C import qualified Ganeti.Constants as C
import qualified Ganeti.THH as THH import qualified Ganeti.THH as THH
......
...@@ -95,7 +95,7 @@ import Data.List (foldl') ...@@ -95,7 +95,7 @@ import Data.List (foldl')
import Data.Maybe import Data.Maybe
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Set as Set 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 Text.JSON as J
import qualified Ganeti.Constants as C import qualified Ganeti.Constants as C
......
...@@ -39,7 +39,7 @@ module Ganeti.OpCodes ...@@ -39,7 +39,7 @@ module Ganeti.OpCodes
, allOpIDs , allOpIDs
) where ) 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 Text.JSON.Pretty (pp_value)
import qualified Ganeti.Constants as C import qualified Ganeti.Constants as C
......
...@@ -63,7 +63,6 @@ import qualified Text.Regex.PCRE as PCRE ...@@ -63,7 +63,6 @@ import qualified Text.Regex.PCRE as PCRE
import qualified Ganeti.Constants as C import qualified Ganeti.Constants as C
import Ganeti.THH import Ganeti.THH
import Ganeti.JSON
-- * THH declarations, that require ordering. -- * THH declarations, that require ordering.
......
...@@ -73,7 +73,6 @@ module Ganeti.Rpc ...@@ -73,7 +73,6 @@ module Ganeti.Rpc
import Control.Arrow (second) import Control.Arrow (second)
import qualified Text.JSON as J import qualified Text.JSON as J
import Text.JSON.Pretty (pp_value) import Text.JSON.Pretty (pp_value)
import Text.JSON (makeObj)
#ifndef NO_CURL #ifndef NO_CURL
import Network.Curl import Network.Curl
...@@ -84,7 +83,6 @@ import qualified Ganeti.Constants as C ...@@ -84,7 +83,6 @@ import qualified Ganeti.Constants as C
import Ganeti.Objects import Ganeti.Objects
import Ganeti.THH import Ganeti.THH
import Ganeti.Compat import Ganeti.Compat
import Ganeti.JSON
-- * Base RPC functionality and types -- * Base RPC functionality and types
......
...@@ -69,6 +69,8 @@ import Language.Haskell.TH ...@@ -69,6 +69,8 @@ import Language.Haskell.TH
import qualified Text.JSON as JSON import qualified Text.JSON as JSON
import Text.JSON.Pretty (pp_value) import Text.JSON.Pretty (pp_value)
import Ganeti.JSON
-- * Exported types -- * Exported types
-- | Class of objects that can be converted to 'JSObject' -- | Class of objects that can be converted to 'JSObject'
...@@ -239,7 +241,15 @@ varNameE = varE . mkName ...@@ -239,7 +241,15 @@ varNameE = varE . mkName
-- | showJSON as an expression, for reuse. -- | showJSON as an expression, for reuse.
showJSONE :: Q Exp 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. -- | ToRaw function name.
toRawName :: String -> Name toRawName :: String -> Name
...@@ -394,7 +404,7 @@ declareSADT = declareADT ''String ...@@ -394,7 +404,7 @@ declareSADT = declareADT ''String
genShowJSON :: String -> Q Dec genShowJSON :: String -> Q Dec
genShowJSON name = do genShowJSON name = do
body <- [| JSON.showJSON . $(varE (toRawName name)) |] 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. -- | Creates the readJSON member of a JSON instance declaration.
-- --
...@@ -417,7 +427,7 @@ genReadJSON name = do ...@@ -417,7 +427,7 @@ genReadJSON name = do
$(stringE name) ++ ": " ++ e ++ " from " ++ $(stringE name) ++ ": " ++ e ++ " from " ++
show $(varE s) 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. -- | Generates a JSON instance for a given type.
-- --
...@@ -546,7 +556,7 @@ saveConstructor sname fields = do ...@@ -546,7 +556,7 @@ saveConstructor sname fields = do
JSON.showJSON $(stringE . deCamelCase $ sname) )] |] JSON.showJSON $(stringE . deCamelCase $ sname) )] |]
flist = listE (opid:felems) flist = listE (opid:felems)
-- and finally convert all this to a json object -- and finally convert all this to a json object
flist' = [| $(varNameE "makeObj") (concat $flist) |] flist' = [| $makeObjE (concat $flist) |]
clause [pat] (normalB flist') [] clause [pat] (normalB flist') []
-- | Generates the main save opcode function. -- | Generates the main save opcode function.
...@@ -583,8 +593,7 @@ genLoadOpCode opdefs = do ...@@ -583,8 +593,7 @@ genLoadOpCode opdefs = do
opid = mkName "op_id" opid = mkName "op_id"
st1 <- bindS (varP objname) [| liftM JSON.fromJSObject st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
(JSON.readJSON $(varE arg1)) |] (JSON.readJSON $(varE arg1)) |]
st2 <- bindS (varP opid) [| $(varNameE "fromObj") st2 <- bindS (varP opid) [| $fromObjE $(varE objname) $(stringE "OP_ID") |]
$(varE objname) $(stringE "OP_ID") |]
-- the match results (per-constructor blocks) -- the match results (per-constructor blocks)
mexps <- mapM (uncurry loadConstructor) opdefs mexps <- mapM (uncurry loadConstructor) opdefs
fails <- [| fail $ "Unknown opcode " ++ $(varE opid) |] fails <- [| fail $ "Unknown opcode " ++ $(varE opid) |]
...@@ -706,7 +715,7 @@ genSaveObject save_fn sname fields = do ...@@ -706,7 +715,7 @@ genSaveObject save_fn sname fields = do
tdlist = [| concat $flist |] tdlist = [| concat $flist |]
iname = mkName "i" iname = mkName "i"
tclause <- clause [pat] (normalB tdlist) [] tclause <- clause [pat] (normalB tdlist) []
cclause <- [| $(varNameE "makeObj") . $(varE tdname) |] cclause <- [| $makeObjE . $(varE tdname) |]
let fname = mkName ("save" ++ sname) let fname = mkName ("save" ++ sname)
sigt <- [t| $(conT name) -> JSON.JSValue |] sigt <- [t| $(conT name) -> JSON.JSValue |]
return [SigD tdname tdsigt, FunD tdname [tclause], return [SigD tdname tdsigt, FunD tdname [tclause],
...@@ -741,7 +750,7 @@ saveObjectField fvar field = ...@@ -741,7 +750,7 @@ saveObjectField fvar field =
objectShowJSON :: String -> Q Dec objectShowJSON :: String -> Q Dec
objectShowJSON name = do objectShowJSON name = do
body <- [| JSON.showJSON . $(varE . mkName $ "save" ++ name) |] 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. -- | Generates the load object functionality.
genLoadObject :: (Field -> Q (Name, Stmt)) genLoadObject :: (Field -> Q (Name, Stmt))
...@@ -775,12 +784,12 @@ loadObjectField field = do ...@@ -775,12 +784,12 @@ loadObjectField field = do
-- we treat both optional types the same, since -- we treat both optional types the same, since
-- 'maybeFromObj' can deal with both missing and null values -- 'maybeFromObj' can deal with both missing and null values
-- appropriately (the same) -- appropriately (the same)
then [| $(varNameE "maybeFromObj") $objvar $objfield |] then [| $(varE 'maybeFromObj) $objvar $objfield |]
else case fieldDefault field of else case fieldDefault field of
Just defv -> Just defv ->
[| $(varNameE "fromObjWithDefault") $objvar [| $(varE 'fromObjWithDefault) $objvar
$objfield $defv |] $objfield $defv |]
Nothing -> [| $(varNameE "fromObj") $objvar $objfield |] Nothing -> [| $fromObjE $objvar $objfield |]
bexp <- loadFn field loadexp objvar bexp <- loadFn field loadexp objvar
return (fvar, BindS (VarP fvar) bexp) return (fvar, BindS (VarP fvar) bexp)
...@@ -795,7 +804,7 @@ objectReadJSON name = do ...@@ -795,7 +804,7 @@ objectReadJSON name = do
JSON.Error $ "Can't parse value for type " ++ JSON.Error $ "Can't parse value for type " ++
$(stringE name) ++ ": " ++ e $(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 -- * Inheritable parameter tables implementation
...@@ -886,7 +895,7 @@ loadPParamField field = do ...@@ -886,7 +895,7 @@ loadPParamField field = do
-- these are used in all patterns below -- these are used in all patterns below
let objvar = varNameE "o" let objvar = varNameE "o"
objfield = stringE name objfield = stringE name
loadexp = [| $(varNameE "maybeFromObj") $objvar $objfield |] loadexp = [| $(varE 'maybeFromObj) $objvar $objfield |]
bexp <- loadFn field loadexp objvar bexp <- loadFn field loadexp objvar
return (fvar, BindS (VarP fvar) bexp) return (fvar, BindS (VarP fvar) bexp)
...@@ -894,7 +903,7 @@ loadPParamField field = do ...@@ -894,7 +903,7 @@ loadPParamField field = do
buildFromMaybe :: String -> Q Dec buildFromMaybe :: String -> Q Dec
buildFromMaybe fname = buildFromMaybe fname =
valD (varP (mkName $ "n_" ++ fname)) valD (varP (mkName $ "n_" ++ fname))
(normalB [| $(varNameE "fromMaybe") (normalB [| $(varE 'fromMaybe)
$(varNameE $ "f_" ++ fname) $(varNameE $ "f_" ++ fname)
$(varNameE $ "p_" ++ fname) |]) [] $(varNameE $ "p_" ++ fname) |]) []
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment