Commit 53fe9413 authored by simonpj's avatar simonpj
Browse files

[project @ 2004-02-24 15:57:52 by simonpj]

---------------------------------------
  	 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
parent 42ab01d7
......@@ -36,13 +36,16 @@ import VarSet
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}
%************************************************************************
......@@ -62,6 +65,7 @@ deSugar hsc_env
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,
......@@ -92,10 +96,17 @@ deSugar hsc_env
; 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,
......
......@@ -658,6 +658,7 @@ type IsBootInterface = Bool
-- 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
......
......@@ -54,7 +54,7 @@ import SrcLoc ( noSrcLoc, Located(..), mkGeneralSrcSpan,
import BasicTypes ( DeprecTxt )
import ListSetOps ( removeDups )
import Util ( sortLt, notNull, isSingleton )
import List ( partition, insert )
import List ( partition )
import IO ( openFile, IOMode(..) )
\end{code}
......@@ -192,7 +192,9 @@ importsFromImportDecl this_mod
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)
......@@ -208,8 +210,8 @@ importsFromImportDecl this_mod
= -- 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
......
......@@ -74,6 +74,7 @@ initTc hsc_env mod do_this
tvs_var <- newIORef emptyVarSet ;
type_env_var <- newIORef emptyNameEnv ;
dfuns_var <- newIORef emptyNameSet ;
th_var <- newIORef False ;
let {
gbl_env = TcGblEnv {
......@@ -85,6 +86,7 @@ initTc hsc_env mod do_this
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,
......@@ -733,6 +735,9 @@ setLclTypeEnv lcl_env thing_inside
%************************************************************************
\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) }
......
......@@ -156,6 +156,13 @@ data TcGblEnv
-- 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
......
......@@ -100,6 +100,7 @@ tcBracket brack res_ty
-- 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 ->
......@@ -159,8 +160,8 @@ tcSpliceExpr (HsSplice name expr) res_ty
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
......@@ -226,16 +227,19 @@ tcTopSpliceExpr expr meta_ty
= 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}
......
......@@ -5,7 +5,7 @@
\begin{code}
module ListSetOps (
unionLists, minusList,
unionLists, minusList, insertList,
-- Association lists
Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing,
......@@ -30,22 +30,24 @@ import List ( union )
%************************************************************************
%* *
\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}
......
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