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 ListSetOps ( insertList )
import Outputable
import UniqSupply ( mkSplitUniqSupply )
import SrcLoc ( Located(..), SrcSpan, unLoc )
import DATA_IOREF ( readIORef )
import FastString
+import Data.List ( sort )
\end{code}
%************************************************************************
tcg_exports = exports,
tcg_dus = dus,
tcg_inst_uses = dfun_uses_var,
+ tcg_th_used = th_var,
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
+
+ ; th_used <- readIORef th_var
; let
+ pkgs | th_used = insertList thPackage (imp_dep_pkgs imports)
+ | otherwise = imp_dep_pkgs 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,
-- 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
import BasicTypes ( DeprecTxt )
import ListSetOps ( removeDups )
import Util ( sortLt, notNull, isSingleton )
-import List ( partition, insert )
+import List ( partition )
import IO ( openFile, IOMode(..) )
\end{code}
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)
= -- 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
tvs_var <- newIORef emptyVarSet ;
type_env_var <- newIORef emptyNameEnv ;
dfuns_var <- newIORef emptyNameSet ;
+ th_var <- newIORef False ;
let {
gbl_env = TcGblEnv {
tcg_type_env_var = type_env_var,
tcg_inst_env = mkImpInstEnv hsc_env,
tcg_inst_uses = dfuns_var,
+ tcg_th_used = th_var,
tcg_exports = emptyNameSet,
tcg_imports = init_imports,
tcg_dus = emptyDUs,
%************************************************************************
\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) }
-- 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
-- Typecheck expr to make sure it is valid,
-- but throw away the results. We'll type check
-- it again when we actually use it.
+ recordThUse `thenM_`
newMutVar [] `thenM` \ pending_splices ->
getLIEVar `thenM` \ lie_var ->
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
= 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)
+
-- Solve the constraints
- tcSimplifyTop lie `thenM` \ const_binds ->
+ ; const_binds <- tcSimplifyTop lie
-- And zonk it
- zonkTopLExpr (mkHsLet const_binds expr')
+ ; zonkTopLExpr (mkHsLet const_binds expr') }
\end{code}
\begin{code}
module ListSetOps (
- unionLists, minusList,
+ unionLists, minusList, insertList,
-- 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}
-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
-\begin{code}
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]
\end{code}
projects / ghc-hetmet.git / commitdiff