---------------------------------------
Record dependency on Template Haskell package
---------------------------------------
An unforseen consequence of making the Template Haskell package separate
is that we need to record dependency on the package, even if no TH module
is imported. So we carry round (another) mutable variable tcg_th_used in
the tyepchecker monad, and zap it when $(...) and [| ... |] are used.
I did a little tidy-up and documentation in ListSetOps too
import Bag ( Bag, isEmptyBag, mapBag, emptyBag, bagToList )
import CoreLint ( showPass, endPass )
import CoreFVs ( ruleRhsFreeVars )
import Bag ( Bag, isEmptyBag, mapBag, emptyBag, bagToList )
import CoreLint ( showPass, endPass )
import CoreFVs ( ruleRhsFreeVars )
+import Packages ( thPackage )
import ErrUtils ( doIfSet, dumpIfSet_dyn, pprBagOfWarnings,
mkWarnMsg, errorsFound, WarnMsg )
import ErrUtils ( doIfSet, dumpIfSet_dyn, pprBagOfWarnings,
mkWarnMsg, errorsFound, WarnMsg )
+import ListSetOps ( insertList )
import Outputable
import UniqSupply ( mkSplitUniqSupply )
import SrcLoc ( Located(..), SrcSpan, unLoc )
import DATA_IOREF ( readIORef )
import FastString
import Outputable
import UniqSupply ( mkSplitUniqSupply )
import SrcLoc ( Located(..), SrcSpan, unLoc )
import DATA_IOREF ( readIORef )
import FastString
+import Data.List ( sort )
\end{code}
%************************************************************************
\end{code}
%************************************************************************
tcg_exports = exports,
tcg_dus = dus,
tcg_inst_uses = dfun_uses_var,
tcg_exports = exports,
tcg_dus = dus,
tcg_inst_uses = dfun_uses_var,
tcg_rdr_env = rdr_env,
tcg_fix_env = fix_env,
tcg_deprecs = deprecs,
tcg_rdr_env = rdr_env,
tcg_fix_env = fix_env,
tcg_deprecs = deprecs,
; dfun_uses <- readIORef dfun_uses_var -- What dfuns are used
; let used_names = allUses dus `unionNameSets` dfun_uses
; usages <- mkUsageInfo hsc_env imports used_names
; dfun_uses <- readIORef dfun_uses_var -- What dfuns are used
; let used_names = allUses dus `unionNameSets` dfun_uses
; usages <- mkUsageInfo hsc_env imports used_names
+
+ ; th_used <- readIORef th_var
+ pkgs | th_used = insertList thPackage (imp_dep_pkgs imports)
+ | otherwise = imp_dep_pkgs imports
+
deps = Deps { dep_mods = moduleEnvElts (imp_dep_mods imports),
deps = Deps { dep_mods = moduleEnvElts (imp_dep_mods imports),
- dep_pkgs = imp_dep_pkgs imports,
- dep_orphs = imp_orphs imports }
+ dep_pkgs = sort pkgs,
+ dep_orphs = sort (imp_orphs imports) }
+ -- sort to get into canonical order
+
mod_guts = ModGuts {
mg_module = mod,
mg_exports = exports,
mod_guts = ModGuts {
mg_module = mod,
mg_exports = exports,
-- in the import hierarchy. See TcRnTypes.ImportAvails for details.
--
-- Invariant: the dependencies of a module M never includes M
-- in the import hierarchy. See TcRnTypes.ImportAvails for details.
--
-- Invariant: the dependencies of a module M never includes M
+-- Invariant: the lists are unordered, with no duplicates
data Dependencies
= Deps { dep_mods :: [(ModuleName,IsBootInterface)], -- Home-package module dependencies
dep_pkgs :: [PackageName], -- External package dependencies
data Dependencies
= Deps { dep_mods :: [(ModuleName,IsBootInterface)], -- Home-package module dependencies
dep_pkgs :: [PackageName], -- External package dependencies
import BasicTypes ( DeprecTxt )
import ListSetOps ( removeDups )
import Util ( sortLt, notNull, isSingleton )
import BasicTypes ( DeprecTxt )
import ListSetOps ( removeDups )
import Util ( sortLt, notNull, isSingleton )
-import List ( partition, insert )
+import List ( partition )
import IO ( openFile, IOMode(..) )
\end{code}
import IO ( openFile, IOMode(..) )
\end{code}
let
-- Compute new transitive dependencies
let
-- Compute new transitive dependencies
- orphans | is_orph = insert imp_mod_name (dep_orphs deps)
+
+ orphans | is_orph = ASSERT( not (imp_mod_name `elem` dep_orphs deps) )
+ imp_mod_name : dep_orphs deps
| otherwise = dep_orphs deps
(dependent_mods, dependent_pkgs)
| otherwise = dep_orphs deps
(dependent_mods, dependent_pkgs)
= -- Imported module is from another package
-- Dump the dependent modules
-- Add the package imp_mod comes from to the dependent packages
= -- Imported module is from another package
-- Dump the dependent modules
-- Add the package imp_mod comes from to the dependent packages
- -- from imp_mod
- ([], insert (mi_package iface) (dep_pkgs deps))
+ ASSERT( not (mi_package iface `elem` dep_pkgs deps) )
+ ([], mi_package iface : dep_pkgs deps)
not_self (m, _) = m /= this_mod_name
not_self (m, _) = m /= this_mod_name
tvs_var <- newIORef emptyVarSet ;
type_env_var <- newIORef emptyNameEnv ;
dfuns_var <- newIORef emptyNameSet ;
tvs_var <- newIORef emptyVarSet ;
type_env_var <- newIORef emptyNameEnv ;
dfuns_var <- newIORef emptyNameSet ;
+ th_var <- newIORef False ;
let {
gbl_env = TcGblEnv {
let {
gbl_env = TcGblEnv {
tcg_type_env_var = type_env_var,
tcg_inst_env = mkImpInstEnv hsc_env,
tcg_inst_uses = dfuns_var,
tcg_type_env_var = type_env_var,
tcg_inst_env = mkImpInstEnv hsc_env,
tcg_inst_uses = dfuns_var,
tcg_exports = emptyNameSet,
tcg_imports = init_imports,
tcg_dus = emptyDUs,
tcg_exports = emptyNameSet,
tcg_imports = init_imports,
tcg_dus = emptyDUs,
%************************************************************************
\begin{code}
%************************************************************************
\begin{code}
+recordThUse :: TcM ()
+recordThUse = do { env <- getGblEnv; writeMutVar (tcg_th_used env) True }
+
getStage :: TcM ThStage
getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
getStage :: TcM ThStage
getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
-- rather like the free variables of the program, but
-- are implicit instead of explicit.
-- rather like the free variables of the program, but
-- are implicit instead of explicit.
+ tcg_th_used :: TcRef Bool, -- True <=> Template Haskell syntax used
+ -- We need this so that we can generate a dependency on the
+ -- Template Haskell package, becuase the desugarer is going to
+ -- emit loads of references to TH symbols. It's rather like
+ -- tcg_inst_uses; the reference is implicit rather than explicit,
+ -- so we have to zap a mutable variable.
+
-- Now a bunch of things about this module that are simply
-- accumulated, but never consulted until the end.
-- Nevertheless, it's convenient to accumulate them along
-- Now a bunch of things about this module that are simply
-- accumulated, but never consulted until the end.
-- Nevertheless, it's convenient to accumulate them along
-- Typecheck expr to make sure it is valid,
-- but throw away the results. We'll type check
-- it again when we actually use it.
-- Typecheck expr to make sure it is valid,
-- but throw away the results. We'll type check
-- it again when we actually use it.
newMutVar [] `thenM` \ pending_splices ->
getLIEVar `thenM` \ lie_var ->
newMutVar [] `thenM` \ pending_splices ->
getLIEVar `thenM` \ lie_var ->
Just next_level ->
case level of {
Just next_level ->
case level of {
- Comp -> do { e <- tcTopSplice expr res_ty ;
- returnM (unLoc e) };
+ Comp -> do { e <- tcTopSplice expr res_ty
+ ; returnM (unLoc e) } ;
Brack _ ps_var lie_var ->
-- A splice inside brackets
Brack _ ps_var lie_var ->
-- A splice inside brackets
= checkNoErrs $ -- checkNoErrs: must not try to run the thing
-- if the type checker fails!
= checkNoErrs $ -- checkNoErrs: must not try to run the thing
-- if the type checker fails!
- setStage topSpliceStage $
+ setStage topSpliceStage $ do
- -- Typecheck the expression
- getLIE (tcCheckRho expr meta_ty) `thenM` \ (expr', lie) ->
+
+ do { recordThUse -- Record that TH is used (for pkg depdendency)
+ -- Typecheck the expression
+ ; (expr', lie) <- getLIE (tcCheckRho expr meta_ty)
+
- tcSimplifyTop lie `thenM` \ const_binds ->
+ ; const_binds <- tcSimplifyTop lie
- zonkTopLExpr (mkHsLet const_binds expr')
+ ; zonkTopLExpr (mkHsLet const_binds expr') }
\begin{code}
module ListSetOps (
\begin{code}
module ListSetOps (
+ unionLists, minusList, insertList,
-- Association lists
Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing,
-- Association lists
Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing,
%************************************************************************
%* *
%************************************************************************
%* *
-\subsection{Treating lists as sets}
+ Treating lists as sets
+ Assumes the lists contain no duplicates, but are unordered
%* *
%************************************************************************
\begin{code}
%* *
%************************************************************************
\begin{code}
-unionLists :: (Eq a) => [a] -> [a] -> [a]
-unionLists = union
-\end{code}
+insertList :: Eq a => a -> [a] -> [a]
+-- Assumes the arg list contains no dups; guarantees the result has no dups
+insertList x xs | isIn "insert" x xs = xs
+ | otherwise = x : xs
-Everything in the first list that is not in the second list:
+unionLists :: (Eq a) => [a] -> [a] -> [a]
+-- Assumes that the arguments contain no duplicates
+unionLists xs ys = [x | x <- xs, isn'tIn "unionLists" x ys] ++ ys
minusList :: (Eq a) => [a] -> [a] -> [a]
minusList :: (Eq a) => [a] -> [a] -> [a]
-minusList xs ys = [ x | x <- xs, x `not_elem` ys]
- where
- not_elem = isn'tIn "minusList"
+-- Everything in the first list that is not in the second list:
+minusList xs ys = [ x | x <- xs, isn'tIn "minusList" x ys]