diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs index 681f00861f8ac0692288e03f4131aed5755a0ca4..ef3bcf55fac05c40c6090e589ebee082a94f39e6 100644 --- a/ghc/compiler/deSugar/Check.lhs +++ b/ghc/compiler/deSugar/Check.lhs @@ -2,6 +2,7 @@ % (c) The GRASP/AQUA Project, Glasgow University, 1997-1998 % % Author: Juan J. Quintela +\section{Module @Check@ in @deSugar@} \begin{code} @@ -56,61 +57,69 @@ import Outputable \end{code} This module performs checks about if one list of equations are: - - Overlapped - - Non exhaustive - +\begin{itemize} +\item Overlapped +\item Non exhaustive +\end{itemize} To discover that we go through the list of equations in a tree-like fashion. If you like theory, a similar algorithm is described in: - Two Techniques for Compiling Lazy Pattern Matching - Luc Maranguet +\begin{quotation} + {\em Two Techniques for Compiling Lazy Pattern Matching}, + Luc Maranguet, INRIA Rocquencourt (RR-2385, 1994) - -The algorithm is based in the first Technique, but there are some differences: - - We don't generate code - - We have constructors and literals (not only literals as in the +\end{quotation} +The algorithm is based on the first technique, but there are some differences: +\begin{itemize} +\item We don't generate code +\item We have constructors and literals (not only literals as in the article) - - We don't use directions, we must select the columns from +\item We don't use directions, we must select the columns from left-to-right - +\end{itemize} (By the way the second technique is really similar to the one used in - Match.lhs to generate code) + @Match.lhs@ to generate code) This function takes the equations of a pattern and returns: - - The patterns that are not recognized - - The equations that are not overlapped - -It simplify the patterns and then call check' (the same semantics),and it +\begin{itemize} +\item The patterns that are not recognized +\item The equations that are not overlapped +\end{itemize} +It simplify the patterns and then call @check'@ (the same semantics), and it needs to reconstruct the patterns again .... The problem appear with things like: +\begin{verbatim} f [x,y] = .... f (x:xs) = ..... - +\end{verbatim} We want to put the two patterns with the same syntax, (prefix form) and then all the constructors are equal: +\begin{verbatim} f (: x (: y [])) = .... f (: x xs) = ..... +\end{verbatim} +(more about that in @simplify_eqns@) -(more about that in simplify_eqns) - -We would prefer to have a WarningPat of type String, but Strings and the +We would prefer to have a @WarningPat@ of type @String@, but Strings and the Pretty Printer are not friends. -We use InPat in WarningPat instead of OutPat because we need to print the +We use @InPat@ in @WarningPat@ instead of @OutPat@ +because we need to print the warning messages in the same way they are introduced, i.e. if the user wrote: +\begin{verbatim} f [x,y] = .. - +\end{verbatim} He don't want a warning message written: - +\begin{verbatim} f (: x (: y [])) ........ - +\end{verbatim} Then we need to use InPats. - - Juan Quintela 5 JUL 1998 +\begin{quotation} + Juan Quintela 5 JUL 1998\\ User-friendliness and compiler writers are no friends. - +\end{quotation} \begin{code} type WarningPat = InPat Name @@ -178,11 +187,11 @@ untidy_lit lit = lit This equation is the same that check, the only difference is that the boring work is done, that work needs to be done only once, this is the reason top have two functions, check is the external interface, -check' is called recursively. +@check'@ is called recursively. There are several cases: -\begin{item} +\begin{itemize} \item There are no equations: Everything is OK. \item There are only one equation, that can fail, and all the patterns are variables. Then that equation is used and the same equation is @@ -198,7 +207,7 @@ There are several cases: \item In the general case, there can exist literals ,constructors or only vars in the first column, we actuate in consequence. -\end{item} +\end{itemize} \begin{code} @@ -243,7 +252,7 @@ split_by_literals qs = process_literals used_lits qs used_lits = get_used_lits qs \end{code} -process_explicit_literals is a function that process each literal that appears +@process_explicit_literals@ is a function that process each literal that appears in the column of the matrix. \begin{code} @@ -256,7 +265,7 @@ process_explicit_literals lits qs = (concat pats, unionManyUniqSets indexs) \end{code} -Process_literals calls process_explicit_literals to deal with the literals +@process_literals@ calls @process_explicit_literals@ to deal with the literals that appears in the matrix and deal also with the rest of the cases. It must be one Variable to be complete. @@ -297,7 +306,7 @@ remove_first_column_lit lit qs = \end{code} This function splits the equations @qs@ in groups that deal with the -same constructor +same constructor. \begin{code} @@ -327,7 +336,7 @@ constructor, using all the constructors that appears in the first column of the pattern matching. We can need a default clause or not ...., it depends if we used all the -constructors or not explicitly. The reasoning is similar to process_literals, +constructors or not explicitly. The reasoning is similar to @process_literals@, the difference is that here the default case is not always needed. \begin{code} @@ -362,15 +371,15 @@ Here remove first column is more difficult that with literals due to the fact that constructors can have arguments. For instance, the matrix - +\begin{verbatim} (: x xs) y z y - +\end{verbatim} is transformed in: - +\begin{verbatim} x xs y _ _ y - +\end{verbatim} \begin{code} remove_first_column :: TypecheckedPat -- Constructor @@ -436,7 +445,8 @@ get_unused_cons used_cons = unused_cons Just (ty_con,_) = splitTyConApp_maybe ty all_cons = tyConDataCons ty_con used_cons_as_id = map (\ (ConPat d _ _ _ _) -> d) used_cons - unused_cons = uniqSetToList (mkUniqSet all_cons minusUniqSet mkUniqSet used_cons_as_id) + unused_cons = uniqSetToList + (mkUniqSet all_cons minusUniqSet mkUniqSet used_cons_as_id) all_vars :: [TypecheckedPat] -> Bool @@ -446,7 +456,8 @@ all_vars _ = False remove_var :: EquationInfo -> EquationInfo remove_var (EqnInfo n ctx (WildPat _:ps) result) = EqnInfo n ctx ps result -remove_var _ = panic "Check:remove_var: equation not begin with a variable" +remove_var _ = + panic "Check.remove_var: equation does not begin with a variable" is_con :: EquationInfo -> Bool is_con (EqnInfo _ _ ((ConPat _ _ _ _ _):_) _) = True @@ -481,39 +492,43 @@ is_var_lit lit (EqnInfo _ _ ((NPat lit' _ _):_) _) | lit == lit' = True is_var_lit lit _ = False \end{code} -The difference beteewn make_con and make_whole_con is that -make_wole_con creates a new constructor with all their arguments, and -make_Con takes a list of argumntes, creates the contructor geting thir -argumnts from the list. See where are used for details. +The difference beteewn @make_con@ and @make_whole_con@ is that +@make_wole_con@ creates a new constructor with all their arguments, and +@make_con@ takes a list of argumntes, creates the contructor getting their +arguments from the list. See where \fbox{\ ???\ } are used for details. We need to reconstruct the patterns (make the constructors infix and similar) at the same time that we create the constructors. You can tell tuple constructors using - +\begin{verbatim} Id.isTupleCon - +\end{verbatim} You can see if one constructor is infix with this clearer code :-)))))))))) - +\begin{verbatim} Lex.isLexConSym (Name.occNameString (Name.getOccName con)) +\end{verbatim} Rather clumsy but it works. (Simon Peyton Jones) -We con't mind the nilDataCon because it doesn't change the way to -print the messsage, we are searching only for things like: [1,2,3], -not x:xs .... +We don't mind the @nilDataCon@ because it doesn't change the way to +print the messsage, we are searching only for things like: @[1,2,3]@, +not @x:xs@ .... -In reconstruct_pat we want to "undo" the work that we have done in simplify_pat +In @reconstruct_pat@ we want to undo'' the work +that we have done in @simplify_pat@. In particular: - ((,) x y) returns to be (x, y) - ((:) x xs) returns to be (x:xs) - (x:(...:[]) returns to be [x,...] - +\begin{tabular}{lll} + @((,) x y)@ & returns to be & @(x, y)@ +\\ @((:) x xs)@ & returns to be & @(x:xs)@ +\\ @(x:(...:[])@ & returns to be & @[x,...]@ +\end{tabular} +% The difficult case is the third one becouse we need to follow all the -contructors until the [] to know taht we need to use the second case, -not the second. - +contructors until the @[]@ to know that we need to use the second case, +not the second. \fbox{\ ???\ } +% \begin{code} isInfixCon con = isDataSymOcc (getOccName con) @@ -560,9 +575,9 @@ new_wild_pat :: WarningPat new_wild_pat = WildPatIn \end{code} -This equation makes the same thing that tidy in Match.lhs, the +This equation makes the same thing as @tidy@ in @Match.lhs@, the difference is that here we can do all the tidy in one place and in the -Match tidy it must be done one column each time due to bookkeeping +@Match@ tidy it must be done one column each time due to bookkeeping constraints. \begin{code} @@ -584,9 +599,9 @@ simplify_pat (AsPat id p) = simplify_pat p simplify_pat (ConPat id ty tvs dicts ps) = ConPat id ty tvs dicts (map simplify_pat ps) -simplify_pat (ListPat ty ps) = foldr (\ x -> \y -> ConPat consDataCon list_ty [] [] [x, y]) - (ConPat nilDataCon list_ty [] [] []) - (map simplify_pat ps) +simplify_pat (ListPat ty ps) = foldr (\ x -> \y -> ConPat consDataCon list_ty [] [] [x, y]) + (ConPat nilDataCon list_ty [] [] []) + (map simplify_pat ps) where list_ty = mkListTy ty diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 26ff4d2837eea20261c22f67b67c606e9611d98a..cd2da89b2aaefd01b9332f8a8b85b9e3d9f7effd 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -76,7 +76,7 @@ deSugar mod_name us (TcResults {tc_env = global_val_env, module_and_group = (mod_name, grp_name) grp_name = case opt_SccGroup of Just xx -> _PK_ xx - Nothing -> _PK_ (moduleString mod_name) -- default: module name + Nothing -> _PK_ (moduleString mod_name) -- default: module name dsProgram mod_name all_binds rules fo_decls = dsMonoBinds auto_scc all_binds [] thenDs \ core_prs -> @@ -121,8 +121,8 @@ dsRule (RuleDecl name sig_tvs vars lhs rhs loc) ds_lhs all_vars lhs = let (dict_binds, body) = case lhs of - (HsLet (MonoBind dict_binds _ _) body) -> (dict_binds, body) - other -> (EmptyMonoBinds, lhs) + (HsLet (MonoBind dict_binds _ _) body) -> (dict_binds, body) + other -> (EmptyMonoBinds, lhs) in ds_dict_binds dict_binds thenDs \ dict_binds' -> dsExpr body thenDs \ body' -> diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index 129b0c8741998937952178863a28ed086c811b2a..0db0d82876e40d6a4b81c09694e0b3941da4d713 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -89,7 +89,8 @@ dsMonoBinds auto_scc (PatMonoBind pat grhss locn) rest -- Common case: one exported variable -- All non-recursive bindings come through this way -dsMonoBinds auto_scc (AbsBinds all_tyvars dicts exps@[(tyvars, global, local)] inlines binds) rest +dsMonoBinds auto_scc + (AbsBinds all_tyvars dicts exps@[(tyvars, global, local)] inlines binds) rest = ASSERT( all (elem tyvars) all_tyvars ) dsMonoBinds (addSccs auto_scc exps) binds [] thenDs \ core_prs -> let @@ -207,7 +208,8 @@ worthSCC (Con _ _) = False worthSCC core_expr = True \end{code} -If profiling and dealing with a dict binding, wrap the dict in "_scc_ DICT ": +If profiling and dealing with a dict binding, +wrap the dict in @_scc_ DICT @: \begin{code} addDictScc var rhs = returnDs rhs diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index 00ec5118649c6fc9f155b25362b318cfa2213e92..84631e39f419a9424d4aaa9b3a1152e13c95945a 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -180,9 +180,10 @@ unboxArg arg Just (arg2_tycon,_) = maybe_arg2_tycon can'tSeeDataConsPanic thing ty - = pprPanic "ERROR: Can't see the data constructor(s) for _ccall_/_casm_/foreign declaration" - (hcat [text thing, text "; type: ", ppr ty, text "(try compiling with -fno-prune-tydecls ..)\n"]) - + = pprPanic + "ERROR: Can't see the data constructor(s) for _ccall_/_casm_/foreign declaration" + (hcat [ text thing, text "; type: ", ppr ty + , text "(try compiling with -fno-prune-tydecls ..)\n"]) \end{code} diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 095e7cea99fbca478be7a9e0e1a5f2803fb105b1..a8421fd0b0f31ca263aa55d81c93178df6f716bc 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -60,14 +60,14 @@ import Outputable %* * %************************************************************************ -@dsLet@ is a match-result transformer, taking the MatchResult for the body +@dsLet@ is a match-result transformer, taking the @MatchResult@ for the body and transforming it into one for the let-bindings enclosing the body. This may seem a bit odd, but (source) let bindings can contain unboxed binds like - +\begin{verbatim} C x# = e - +\end{verbatim} This must be transformed to a case expression and, if the type has more than one constructor, may fail. @@ -83,7 +83,8 @@ dsLet (ThenBinds b1 b2) body -- Special case for bindings which bind unlifted variables -- Silently ignore INLINE pragmas... -dsLet (MonoBind (AbsBinds [] [] binder_triples inlines (PatMonoBind pat grhss loc)) sigs is_rec) body +dsLet (MonoBind (AbsBinds [] [] binder_triples inlines + (PatMonoBind pat grhss loc)) sigs is_rec) body | or [isUnLiftedType (idType g) | (_, g, l) <- binder_triples] = ASSERT (case is_rec of {NonRecursive -> True; other -> False}) putSrcLocDs loc $@@ -93,7 +94,8 @@ dsLet (MonoBind (AbsBinds [] [] binder_triples inlines (PatMonoBind pat grhss lo bind (tyvars, g, l) body = ASSERT( null tyvars ) bindNonRec g (Var l) body in - mkErrorAppDs iRREFUT_PAT_ERROR_ID result_ty (showSDoc (ppr pat)) thenDs \ error_expr -> + mkErrorAppDs iRREFUT_PAT_ERROR_ID result_ty (showSDoc (ppr pat)) + thenDs \ error_expr -> matchSimply rhs PatBindMatch pat body' error_expr where result_ty = coreExprType body @@ -124,17 +126,17 @@ dsExpr e@(HsVar var) = returnDs (Var var) %* * %************************************************************************ -We give int/float literals type Integer and Rational, respectively. +We give int/float literals type @Integer@ and @Rational@, respectively. The typechecker will (presumably) have put \tr{from{Integer,Rational}s} around them. -ToDo: put in range checks for when converting "i" +ToDo: put in range checks for when converting @i@'' (or should that be in the typechecker?) For numeric literals, we try to detect there use at a standard type -(Int, Float, etc.) are directly put in the right constructor. +(@Int@, @Float@, etc.) are directly put in the right constructor. [NB: down with the @App@ conversion.] -Otherwise, we punt, putting in a "NoRep" Core literal (where the +Otherwise, we punt, putting in a @NoRep@ Core literal (where the representation decisions are delayed)... See also below where we look for @DictApps@ for \tr{plusInt}, etc. @@ -322,8 +324,8 @@ dsExpr (HsSCC cc expr) dsExpr (HsCase discrim matches@[Match _ [TuplePat ps boxed] _ _] src_loc) | not boxed && all var_pat ps = putSrcLocDs src_loc$ - dsExpr discrim thenDs \ core_discrim -> - matchWrapper CaseMatch matches "case" thenDs \ ([discrim_var], matching_code) -> + dsExpr discrim thenDs \ core_discrim -> + matchWrapper CaseMatch matches "case" thenDs \ ([discrim_var], matching_code) -> case matching_code of Case (Var x) bndr alts | x == discrim_var -> returnDs (Case core_discrim bndr alts) @@ -331,8 +333,8 @@ dsExpr (HsCase discrim matches@[Match _ [TuplePat ps boxed] _ _] src_loc) dsExpr (HsCase discrim matches src_loc) = putSrcLocDs src_loc $- dsExpr discrim thenDs \ core_discrim -> - matchWrapper CaseMatch matches "case" thenDs \ ([discrim_var], matching_code) -> + dsExpr discrim thenDs \ core_discrim -> + matchWrapper CaseMatch matches "case" thenDs \ ([discrim_var], matching_code) -> returnDs (bindNonRec discrim_var core_discrim matching_code) dsExpr (HsLet binds body) @@ -370,8 +372,9 @@ dsExpr (HsIf guard_expr then_expr else_expr src_loc) \end{code} -Type lambda and application -~~~~~~~~~~~~~~~~~~~~~~~~~~~ +\noindent +\underline{\bf Type lambda and application} +% ~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} dsExpr (TyLam tyvars expr) = dsExpr expr thenDs \ core_expr -> @@ -383,8 +386,9 @@ dsExpr (TyApp expr tys) \end{code} -Various data construction things -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +\noindent +\underline{\bf Various data construction things} +% ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} dsExpr (ExplicitListOut ty xs) = go xs @@ -443,25 +447,26 @@ dsExpr (ArithSeqOut expr (FromThenTo from thn two)) returnDs (mkApps expr2 [from2, thn2, two2]) \end{code} -Record construction and update -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +\noindent +\underline{\bf Record construction and update} +% ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For record construction we do this (assuming T has three arguments) - +\begin{verbatim} T { op2 = e } ==> let err = /\a -> recConErr a T (recConErr t1 "M.lhs/230/op1") e (recConErr t1 "M.lhs/230/op3") - -recConErr then converts its arugment string into a proper message +\end{verbatim} +@recConErr@ then converts its arugment string into a proper message before printing it as +\begin{verbatim} + M.lhs, line 230: missing field op1 was evaluated +\end{verbatim} - M.lhs, line 230: Missing field in record construction op1 - - -We also handle C{} as valid construction syntax for an unlabelled -constructor C, setting all of C's fields to bottom. +We also handle @C{}@ as valid construction syntax for an unlabelled +constructor @C@, setting all of @C@'s fields to bottom. \begin{code} dsExpr (RecordConOut data_con con_expr rbinds) @@ -489,13 +494,13 @@ dsExpr (RecordConOut data_con con_expr rbinds) \end{code} Record update is a little harder. Suppose we have the decl: - +\begin{verbatim} data T = T1 {op1, op2, op3 :: Int} | T2 {op4, op2 :: Int} | T3 - +\end{verbatim} Then we translate as follows: - +\begin{verbatim} r { op2 = e } ===> let op2 = e in @@ -503,9 +508,9 @@ Then we translate as follows: T1 op1 _ op3 -> T1 op1 op2 op3 T2 op4 _ -> T2 op4 op2 other -> recUpdError "M.lhs/230" - -It's important that we use the constructor Ids for T1, T2 etc on the -RHSs, and do not generate a Core Con directly, because the constructor +\end{verbatim} +It's important that we use the constructor Ids for @T1@, @T2@ etc on the +RHSs, and do not generate a Core @Con@ directly, because the constructor might do some argument-evaluation first; and may have to throw away some dictionaries. @@ -569,8 +574,10 @@ dsExpr (RecordUpdOut record_expr record_out_ty dicts rbinds) ok (sel_id, _, _) = recordSelectorFieldLabel sel_id elem con_fields \end{code} -Dictionary lambda and application -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +\noindent +\underline{\bf Dictionary lambda and application} +% ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @DictLam@ and @DictApp@ turn into the regular old things. (OLD:) @DictFunApp@ also becomes a curried application, albeit slightly more complicated; reminiscent of fully-applied constructors. @@ -625,7 +632,7 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty = do_expr expr locn thenDs \ expr2 -> go stmts thenDs \ rest -> let msg = ASSERT( isNotUsgTy b_ty ) - "Pattern match failure in do expression, " ++ showSDoc (ppr locn) in + "Pattern match failure in do expression, " ++ showSDoc (ppr locn) in returnDs (mkIfThenElse expr2 rest (App (App (Var fail_id) @@ -635,7 +642,7 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty go (ExprStmt expr locn : stmts) = do_expr expr locn thenDs \ expr2 -> let - (_, a_ty) = splitAppTy (coreExprType expr2) -- Must be of form (m a) + (_, a_ty) = splitAppTy (coreExprType expr2) -- Must be of form (m a) in if null stmts then returnDs expr2 @@ -653,13 +660,15 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty = putSrcLocDs locn$ dsExpr expr thenDs \ expr2 -> let - (_, a_ty) = splitAppTy (coreExprType expr2) -- Must be of form (m a) - fail_expr = HsApp (TyApp (HsVar fail_id) [b_ty]) (HsLitOut (HsString (_PK_ msg)) stringTy) + (_, a_ty) = splitAppTy (coreExprType expr2) -- Must be of form (m a) + fail_expr = HsApp (TyApp (HsVar fail_id) [b_ty]) + (HsLitOut (HsString (_PK_ msg)) stringTy) msg = ASSERT2( isNotUsgTy a_ty, ppr a_ty ) ASSERT2( isNotUsgTy b_ty, ppr b_ty ) "Pattern match failure in do expression, " ++ showSDoc (ppr locn) main_match = mkSimpleMatch [pat] - (HsDoOut do_or_lc stmts return_id then_id fail_id result_ty locn) + (HsDoOut do_or_lc stmts return_id then_id + fail_id result_ty locn) (Just result_ty) locn the_matches | failureFreePat pat = [main_match] diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index 6efaea41c52b73a6d142480bf5d770497ccadc3f..b6abdbf1c30ec212b5e961be81ec35c7f5dc8f85 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -47,15 +47,15 @@ import Outputable Desugaring of @foreign@ declarations is naturally split up into parts, an @import@ and an @export@ part. A @foreign import@ -declaration - +declaration +\begin{verbatim} foreign import cc nm f :: prim_args -> IO prim_res - +\end{verbatim} is the same as - +\begin{verbatim} f :: prim_args -> IO prim_res f a1 ... an = _ccall_ nm cc a1 ... an - +\end{verbatim} so we reuse the desugaring code in @DsCCall@ to deal with these. \begin{code} @@ -63,8 +63,10 @@ dsForeigns :: Module -> [TypecheckedForeignDecl] -> DsM ( [CoreBind] -- desugared foreign imports , [CoreBind] -- helper functions for foreign exports - , SDoc -- Header file prototypes for "foreign exported" functions. - , SDoc -- C stubs to use when calling "foreign exported" funs. + , SDoc -- Header file prototypes for + -- "foreign exported" functions. + , SDoc -- C stubs to use when calling + -- "foreign exported" functions. ) dsForeigns mod_name fos = foldlDs combine ([],[],empty,empty) fos where @@ -99,7 +101,7 @@ dsForeigns mod_name fos = foldlDs combine ([],[],empty,empty) fos Desugaring foreign imports is just the matter of creating a binding that on its RHS unboxes its arguments, performs the external call -(using the CCallOp primop), before boxing the result up and returning it. +(using the @CCallOp@ primop), before boxing the result up and returning it. \begin{code} dsFImport :: Id @@ -201,16 +203,16 @@ dsFLabel nm ext_name = returnDs (NonRec nm fo_rhs) \end{code} -The function that does most of the work for 'foreign export' declarations. -(see below for the boilerplate code a 'foreign export' declaration expands +The function that does most of the work for @foreign export@' declarations. +(see below for the boilerplate code a @foreign export@' declaration expands into.) -For each 'foreign export foo' in a module M we generate: - -* a C function 'foo', which calls -* a Haskell stub 'M.$ffoo', which calls - -the user-written Haskell function 'M.foo'. +For each @foreign export foo@' in a module M we generate: +\begin{itemize} +\item a C function @foo@', which calls +\item a Haskell stub @M.$ffoo@', which calls +\end{itemize} +the user-written Haskell function @M.foo@'. \begin{code} dsFExport :: Id @@ -267,7 +269,7 @@ dsFExport i ty mod_name ext_name cconv isDyn = returnDs (i, \ body -> body, panic "stbl_ptr" -- should never be touched. - )) thenDs \ (i, getFun_wrapper, stbl_ptr) -> + )) thenDs \ (i, getFun_wrapper, stbl_ptr) -> let wrapper_args | isDyn = stbl_ptr:fe_args @@ -291,7 +293,8 @@ dsFExport i ty mod_name ext_name cconv isDyn = ExtName fs _ -> fs Dynamic -> panic "dsFExport: Dynamic - shouldn't ever happen." - (h_stub, c_stub) = fexportEntry c_nm f_helper_glob wrapper_arg_tys the_result_ty cconv isDyn + (h_stub, c_stub) = fexportEntry c_nm f_helper_glob + wrapper_arg_tys the_result_ty cconv isDyn in returnDs (NonRec f_helper_glob the_body, h_stub, c_stub) @@ -333,7 +336,7 @@ dsFExport i ty mod_name ext_name cconv isDyn = \end{code} -"foreign export dynamic" lets you dress up Haskell IO actions +@foreign export dynamic@ lets you dress up Haskell IO actions of some fixed type behind an externally callable interface (i.e., as a C function pointer). Useful for callbacks and stuff. @@ -376,7 +379,8 @@ dsFExportDynamic i ty mod_name ext_name cconv = fe_nm = toCName fe_id fe_ext_name = ExtName (_PK_ fe_nm) Nothing in - dsFExport i export_ty mod_name fe_ext_name cconv True thenDs \ (fe@(NonRec fe_helper fe_expr), h_code, c_code) -> + dsFExport i export_ty mod_name fe_ext_name cconv True + thenDs \ (fe@(NonRec fe_helper fe_expr), h_code, c_code) -> newSysLocalDs arg_ty thenDs \ cback -> dsLookupGlobalValue makeStablePtr_NAME thenDs \ makeStablePtrId -> let diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs index 80ace7445bd741696f703d950d6e222f37d3e6a0..e5b823b32d2c2846e1498091e3e1644db87bf77c 100644 --- a/ghc/compiler/deSugar/DsGRHSs.lhs +++ b/ghc/compiler/deSugar/DsGRHSs.lhs @@ -32,7 +32,7 @@ It desugars: where binds \end{verbatim} producing an expression with a runtime error in the corner if -necessary. The type argument gives the type of the ei. +necessary. The type argument gives the type of the @ei@. \begin{code} dsGuarded :: TypecheckedGRHSs -> DsM CoreExpr @@ -103,7 +103,8 @@ matchGuard (BindStmt pat rhs locn : stmts) ctx matchSinglePat core_rhs ctx pat match_result \end{code} --- Should *fail* if e returns D - +Should {\em fail} if @e@ returns @D@ +\begin{verbatim} f x | p <- e', let C y# = e, f y# = r1 | otherwise = r2 +\end{verbatim} \ No newline at end of file diff --git a/ghc/compiler/deSugar/DsHsSyn.lhs b/ghc/compiler/deSugar/DsHsSyn.lhs index 3f14f9da829c36d52ee04eae155b976502937f1f..498ffcc4be0416e46bf71002e263c055236f9621 100644 --- a/ghc/compiler/deSugar/DsHsSyn.lhs +++ b/ghc/compiler/deSugar/DsHsSyn.lhs @@ -44,11 +44,11 @@ outPatType (DictPat ds ms) = case (length ds_ms) of \end{code} -Nota bene: DsBinds relies on the fact that at least for simple +Nota bene: @DsBinds@ relies on the fact that at least for simple tuple patterns @collectTypedPatBinders@ returns the binders in the same order as they appear in the tuple. -collectTypedBinders and collectedTypedPatBinders are the exportees. +@collectTypedBinders@ and @collectedTypedPatBinders@ are the exportees. \begin{code} collectTypedMonoBinders :: TypecheckedMonoBinds -> [Id] diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index 52283b44e1855b8b09c63d3effcf0671fe87373c..6affb36cb1d107f5e3a909608f009f6e27c3bf8b 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -107,7 +107,7 @@ already desugared. @dsListComp@ does the top TE rule mentioned above. \begin{code} deListComp :: [TypecheckedStmt] -> CoreExpr -> DsM CoreExpr -deListComp [ReturnStmt expr] list -- Figure 7.4, SLPJ, p 135, rule C above +deListComp [ReturnStmt expr] list -- Figure 7.4, SLPJ, p 135, rule C above = dsExpr expr thenDs \ core_expr -> returnDs (mkConsExpr (coreExprType core_expr) core_expr list) diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index fcee34d3fc1719ea589491abb96b9159cac387d2..1c6c033469c89177b9bd3605efaaf52ddcdb7daa 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -216,7 +216,7 @@ dsLookupGlobalValue name us genv loc mod_and_grp warns %************************************************************************ %* * -%* type synonym EquationInfo and access functions for its pieces * +\subsection{Type synonym @EquationInfo@ and access functions for its pieces} %* * %************************************************************************ diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index e289d2439f1a72744bd55df7112569b8f84987f7..98a7177e84e66cf0fd5d2c246283ba30a758c52a 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -57,7 +57,7 @@ import Outputable %************************************************************************ %* * -%* Building lets +\subsection{ Building lets} %* * %************************************************************************ @@ -78,7 +78,7 @@ mkDsLets binds body = foldr mkDsLet body binds %************************************************************************ %* * -%* Selecting match variables +\subsection{ Selecting match variables} %* * %************************************************************************ @@ -224,7 +224,8 @@ mkCoAlgCaseMatchResult var match_alts -- Stuff for newtype (con_id, arg_ids, match_result) = head match_alts arg_id = head arg_ids - coercion_bind = NonRec arg_id (Note (Coerce (idType arg_id) scrut_ty) (Var var)) + coercion_bind = NonRec arg_id + (Note (Coerce (idType arg_id) scrut_ty) (Var var)) newtype_sanity = null (tail match_alts) && null (tail arg_ids) -- Stuff for data types @@ -253,10 +254,12 @@ mkCoAlgCaseMatchResult var match_alts un_mentioned_constructors = mkUniqSet data_cons minusUniqSet mkUniqSet [ con | (con, _, _) <- match_alts] exhaustive_case = isEmptyUniqSet un_mentioned_constructors - --- for each constructor we match on, we might need to re-pack some --- of the strict fields if they are unpacked in the constructor. - +\end{code} +% +For each constructor we match on, we might need to re-pack some +of the strict fields if they are unpacked in the constructor. +% +\begin{code} rebuildConArgs :: DataCon -- the con we're matching on -> [Id] -- the source-level args @@ -314,10 +317,10 @@ mkErrorAppDs err_id ty msg This is used in various places to do with lazy patterns. For each binder $b$ in the pattern, we create a binding: - +\begin{verbatim} b = case v of pat' -> b' - -where pat' is pat with each binder b cloned into b'. +\end{verbatim} +where @pat'@ is @pat@ with each binder @b@ cloned into @b'@. ToDo: making these bindings should really depend on whether there's much work to be done per binding. If the pattern is complex, it @@ -354,11 +357,15 @@ mkSelectorBinds pat val_expr | otherwise - = mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (showSDoc (ppr pat)) thenDs \ error_expr -> - matchSimply val_expr LetMatch pat local_tuple error_expr thenDs \ tuple_expr -> - newSysLocalDs tuple_ty thenDs \ tuple_var -> + = mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (showSDoc (ppr pat)) + thenDs \ error_expr -> + matchSimply val_expr LetMatch pat local_tuple error_expr + thenDs \ tuple_expr -> + newSysLocalDs tuple_ty + thenDs \ tuple_var -> let - mk_tup_bind binder = (binder, mkTupleSelector binders binder tuple_var (Var tuple_var)) + mk_tup_bind binder = + (binder, mkTupleSelector binders binder tuple_var (Var tuple_var)) in returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders ) where @@ -413,10 +420,10 @@ If there is just one id in the tuple'', then the selector is just the identity. \begin{code} -mkTupleSelector :: [Id] -- The tuple args - -> Id -- The selected one - -> Id -- A variable of the same type as the scrutinee - -> CoreExpr -- Scrutinee +mkTupleSelector :: [Id] -- The tuple args + -> Id -- The selected one + -> Id -- A variable of the same type as the scrutinee + -> CoreExpr -- Scrutinee -> CoreExpr mkTupleSelector [var] should_be_the_same_var scrut_var scrut @@ -467,7 +474,7 @@ fail-variable, and use that variable if the thing fails: Then \begin{itemize} \item -If the case can't fail, then there'll be no mention of fail.33, and the +If the case can't fail, then there'll be no mention of @fail.33@, and the simplifier will later discard it. \item @@ -478,7 +485,7 @@ Only if it is used more than once will the let-binding remain. \end{itemize} There's a problem when the result of the case expression is of -unboxed type. Then the type of fail.33 is unboxed too, and +unboxed type. Then the type of @fail.33@ is unboxed too, and there is every chance that someone will change the let into a case: \begin{verbatim} case error "Help" of @@ -499,7 +506,7 @@ for the primitive case: p4 -> ... \end{verbatim} -Now fail.33 is a function, so it can be let-bound. +Now @fail.33@ is a function, so it can be let-bound. \begin{code} mkFailurePair :: CoreExpr -- Result type of the whole case expression diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index 7e70501872d8cb628be38d7ae495b6356bb4b547..6c242a9c9bf52e8e69c8af34b4f797189d2416f3 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -78,8 +78,8 @@ matchExport vars qs@((EqnInfo _ ctx _ (MatchResult _ _)) : _) eqns_shadow = map (\n -> qs!!(n - 1)) unused_eqns \end{code} -This variable shows the maximun number of lines of output generated for warnings. -It will limit the number of patterns/equations displayed to maximum_output. +This variable shows the maximum number of lines of output generated for warnings. +It will limit the number of patterns/equations displayed to@ maximum_output@. (ToDo: add command-line option?) @@ -87,7 +87,7 @@ It will limit the number of patterns/equations displayed to maximum_output. maximum_output = 4 \end{code} -The next two functions creates the warning message. +The next two functions create the warning message. \begin{code} dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM () @@ -582,7 +582,8 @@ tidy1 v non_interesting_pat match_result = returnDs (non_interesting_pat, match_result) \end{code} -PREVIOUS matchTwiddled STUFF: +\noindent +{\bf Previous @matchTwiddled@ stuff:} Now we get to the only interesting part; note: there are choices for translation [from Simon's notes]; translation~1: @@ -741,23 +742,29 @@ matchWrapper :: DsMatchKind -- For shadowing warning messages There is one small problem with the Lambda Patterns, when somebody writes something similar to: +\begin{verbatim} (\ (x:xs) -> ...) +\end{verbatim} he/she don't want a warning about incomplete patterns, that is done with - the flag opt_WarnSimplePatterns. - This problem also appears in the : - do patterns, but if the do can fail it creates another equation if the match can - fail (see DsExpr.doDo function) - let patterns, are treated by matchSimply - List Comprension Patterns, are treated by matchSimply also - -We can't call matchSimply with Lambda patterns, due to lambda patterns can have more than + the flag @opt_WarnSimplePatterns@. + This problem also appears in the: +\begin{itemize} +\item @do@ patterns, but if the @do@ can fail + it creates another equation if the match can fail + (see @DsExpr.doDo@ function) +\item @let@ patterns, are treated by @matchSimply@ + List Comprension Patterns, are treated by @matchSimply@ also +\end{itemize} + +We can't call @matchSimply@ with Lambda patterns, +due to the fact that lambda patterns can have more than one pattern, and match simply only accepts one pattern. JJQC 30-Nov-1997 - + \begin{code} matchWrapper kind matches error_string - = flattenMatches kind matches thenDs \ (result_ty, eqns_info) -> + = flattenMatches kind matches thenDs \ (result_ty, eqns_info) -> let EqnInfo _ _ arg_pats _ : _ = eqns_info in diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs index ddacd1626d2e0e2a59ba67d1dacd6ba2952daa10..5040362df0e0439dd938a478901f346c13ac7c94 100644 --- a/ghc/compiler/deSugar/MatchLit.lhs +++ b/ghc/compiler/deSugar/MatchLit.lhs @@ -73,18 +73,20 @@ matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (LitPat literal lit_t mk_core_lit ty (HsFloatPrim f) = MachFloat f mk_core_lit ty (HsDoublePrim d) = MachDouble d mk_core_lit ty (HsLitLit s) = ASSERT(isUnLiftedType ty) - MachLitLit s (panic "MatchLit.matchLiterals:mk_core_lit:HsLitLit; typePrimRep???") + MachLitLit s (panic + "MatchLit.matchLiterals:mk_core_lit:HsLitLit; typePrimRep???") mk_core_lit ty other = panic "matchLiterals:mk_core_lit:unhandled" \end{code} \begin{code} -matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx ((NPat literal lit_ty eq_chk):ps1) _ : eqns) +matchLiterals all_vars@(var:vars) + eqns_info@(EqnInfo n ctx ((NPat literal lit_ty eq_chk):ps1) _ : eqns) = let (shifted_eqns_for_this_lit, eqns_not_for_this_lit) = partitionEqnsByLit Nothing literal eqns_info in - dsExpr (HsApp eq_chk (HsVar var)) thenDs \ pred_expr -> - match vars shifted_eqns_for_this_lit thenDs \ inner_match_result -> + dsExpr (HsApp eq_chk (HsVar var)) thenDs \ pred_expr -> + match vars shifted_eqns_for_this_lit thenDs \ inner_match_result -> let match_result1 = mkGuardedMatchResult pred_expr inner_match_result in @@ -131,9 +133,9 @@ matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx ((NPlusKPat master_n returnDs (combineMatchResults match_result1 match_result2) \end{code} -Given a blob of LitPats/NPats, we want to split them into those +Given a blob of @LitPat@s/@NPat@s, we want to split them into those that are same''/different as one we are looking at. We need to know -whether we're looking at a LitPat/NPat, and what literal we're after. +whether we're looking at a @LitPat@/@NPat@, and what literal we're after. \begin{code} partitionEqnsByLit :: Maybe Id -- (Just v) for N-plus-K patterns, where v @@ -163,15 +165,19 @@ partitionEqnsByLit nPlusK lit eqns | lit eq_lit k = (Just (EqnInfo n ctx remaining_pats match_result), Nothing) -- NB the pattern is stripped off the EquationInfo - partition_eqn (Just master_n) lit (EqnInfo n ctx (NPlusKPat n' k _ _ _ : remaining_pats) match_result) + partition_eqn (Just master_n) lit + (EqnInfo n ctx (NPlusKPat n' k _ _ _ : remaining_pats) match_result) | lit eq_lit k = (Just (EqnInfo n ctx remaining_pats new_match_result), Nothing) -- NB the pattern is stripped off the EquationInfo where new_match_result | master_n == n' = match_result - | otherwise = mkCoLetsMatchResult [NonRec n' (Var master_n)] match_result + | otherwise = mkCoLetsMatchResult + [NonRec n' (Var master_n)] match_result - -- Wild-card patterns, which will only show up in the shadows, go into both groups - partition_eqn nPlusK lit eqn@(EqnInfo n ctx (WildPat _ : remaining_pats) match_result) + -- Wild-card patterns, which will only show up in the shadows, + -- go into both groups + partition_eqn nPlusK lit + eqn@(EqnInfo n ctx (WildPat _ : remaining_pats) match_result) = (Just (EqnInfo n ctx remaining_pats match_result), Just eqn) -- Default case; not for this pattern diff --git a/ghc/compiler/deSugar/deSugar.tex b/ghc/compiler/deSugar/deSugar.tex new file mode 100644 index 0000000000000000000000000000000000000000..02cb28574272a780e1aca821e5ca53a5ebc325a5 --- /dev/null +++ b/ghc/compiler/deSugar/deSugar.tex @@ -0,0 +1,23 @@ +\documentstyle{report} +\input{lit-style} + +\begin{document} +\centerline{{\Large{deSugar}}} +\tableofcontents + +\input{Desugar} % {@deSugar@: the main function} +\input{DsBinds} % {Pattern-matching bindings (HsBinds and MonoBinds)} +\input{DsGRHSs} % {Matching guarded right-hand-sides (GRHSs)} +\input{DsExpr} % {Matching expressions (Exprs)} +\input{DsHsSyn} % {Haskell abstract syntax---added things for desugarer} +\input{DsListComp} % {Desugaring list comprehensions} +\input{DsMonad} % {@DsMonad@: monadery used in desugaring} +\input{DsUtils} % {Utilities for desugaring} +\input{Check} % {Module @Check@ in @deSugar@} +\input{Match} % {The @match@ function} +\input{MatchCon} % {Pattern-matching constructors} +\input{MatchLit} % {Pattern-matching literal patterns} +\input{DsForeign} % {Desugaring \tr{foreign} declarations} +\input{DsCCall} % {Desugaring \tr{_ccall_}s and \tr{_casm_}s} + +\end{document} diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 377e4baf06f4c77e7f5223488494ee19d836f31a..a5769238fb3cadd05f42afb87fbc0acfe957008f 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -1,578 +1,589 @@ -% -% (c) The GRASP Project, Glasgow University, 1992-1998 -% -\section[Rename]{Renaming and dependency analysis passes} - -\begin{code} -module Rename ( renameModule ) where - -#include "HsVersions.h" - -import HsSyn -import RdrHsSyn ( RdrNameHsModule ) -import RnHsSyn ( RenamedHsModule, RenamedHsDecl, - extractHsTyNames, extractHsCtxtTyNames - ) - -import CmdLineOpts ( opt_HiMap, opt_D_dump_rn_trace, - opt_D_dump_rn, opt_D_dump_rn_stats, - opt_WarnUnusedBinds, opt_WarnUnusedImports - ) -import RnMonad -import RnNames ( getGlobalNames ) -import RnSource ( rnSourceDecls, rnDecl ) -import RnIfaces ( getImportedInstDecls, importDecl, getImportVersions, - getImportedRules, loadHomeInterface, getSlurped - ) -import RnEnv ( availName, availNames, availsToNameSet, - warnUnusedTopNames, mapFvRn, - FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs - ) -import Module ( Module, ModuleName, pprModule, mkSearchPath, mkThisModule ) -import Name ( Name, isLocallyDefined, - NamedThing(..), ImportReason(..), Provenance(..), - pprOccName, nameOccName, - getNameProvenance, occNameUserString, - maybeWiredInTyConName, maybeWiredInIdName, isWiredInName - ) -import Id ( idType ) -import DataCon ( dataConTyCon, dataConType ) -import TyCon ( TyCon, tyConDataCons, isSynTyCon, getSynTyConDefn ) -import RdrName ( RdrName ) -import NameSet -import PrelMods ( mAIN_Name, pREL_MAIN_Name ) -import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon, boolTyCon ) -import PrelInfo ( ioTyCon_NAME, thinAirIdNames ) -import Type ( namesOfType, funTyCon ) -import ErrUtils ( pprBagOfErrors, pprBagOfWarnings, - doIfSet, dumpIfSet, ghcExit - ) -import BasicTypes ( NewOrData(..) ) -import Bag ( isEmptyBag, bagToList ) -import FiniteMap ( fmToList, delListFromFM, addToFM, sizeFM, eltsFM ) -import UniqSupply ( UniqSupply ) -import Util ( equivClasses ) -import Maybes ( maybeToBool ) -import Outputable -\end{code} - - - -\begin{code} -renameModule :: UniqSupply - -> RdrNameHsModule - -> IO (Maybe - ( Module - , RenamedHsModule -- Output, after renaming - , InterfaceDetails -- Interface; for interface file generation - , RnNameSupply -- Final env; for renaming derivings - , [ModuleName] -- Imported modules; for profiling - )) - -renameModule us this_mod@(HsModule mod_name vers exports imports local_decls loc) - = -- Initialise the renamer monad - initRn mod_name us (mkSearchPath opt_HiMap) loc - (rename this_mod) >>= - \ (maybe_rn_stuff, rn_errs_bag, rn_warns_bag) -> - - -- Check for warnings - doIfSet (not (isEmptyBag rn_warns_bag)) - (printErrs (pprBagOfWarnings rn_warns_bag)) >> - - -- Check for errors; exit if so - doIfSet (not (isEmptyBag rn_errs_bag)) - (printErrs (pprBagOfErrors rn_errs_bag) >> - ghcExit 1 - ) >> - - -- Dump output, if any - (case maybe_rn_stuff of - Nothing -> return () - Just results@(_, rn_mod, _, _, _) - -> dumpIfSet opt_D_dump_rn "Renamer:" - (ppr rn_mod) - ) >> - - -- Return results - return maybe_rn_stuff -\end{code} - - -\begin{code} -rename this_mod@(HsModule mod_name vers exports imports local_decls loc) - = -- FIND THE GLOBAL NAME ENVIRONMENT - getGlobalNames this_mod thenRn \ maybe_stuff -> - - -- CHECK FOR EARLY EXIT - if not (maybeToBool maybe_stuff) then - -- Everything is up to date; no need to recompile further - rnStats [] thenRn_ - returnRn Nothing - else - let - Just (export_env, gbl_env, fixity_env, global_avail_env) = maybe_stuff - in - - -- RENAME THE SOURCE - initRnMS gbl_env fixity_env SourceMode ( - rnSourceDecls local_decls - ) thenRn \ (rn_local_decls, source_fvs) -> - - -- SLURP IN ALL THE NEEDED DECLARATIONS - let - real_source_fvs = implicitFVs mod_name plusFV source_fvs - -- It's important to do the "plus" this way round, so that - -- when compiling the prelude, locally-defined (), Bool, etc - -- override the implicit ones. - in - slurpImpDecls real_source_fvs thenRn \ rn_imp_decls -> - - -- EXIT IF ERRORS FOUND - checkErrsRn thenRn \ no_errs_so_far -> - if not no_errs_so_far then - -- Found errors already, so exit now - rnStats [] thenRn_ - returnRn Nothing - else - - -- GENERATE THE VERSION/USAGE INFO - getImportVersions mod_name exports thenRn \ my_usages -> - getNameSupplyRn thenRn \ name_supply -> - - -- REPORT UNUSED NAMES - reportUnusedNames gbl_env global_avail_env - export_env - source_fvs thenRn_ - - -- RETURN THE RENAMED MODULE - let - has_orphans = any isOrphanDecl rn_local_decls - direct_import_mods = [mod | ImportDecl mod _ _ _ _ _ <- imports] - rn_all_decls = rn_imp_decls ++ rn_local_decls - renamed_module = HsModule mod_name vers - trashed_exports trashed_imports - rn_all_decls - loc - in - rnStats rn_imp_decls thenRn_ - returnRn (Just (mkThisModule mod_name, - renamed_module, - (has_orphans, my_usages, export_env), - name_supply, - direct_import_mods)) - where - trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing - trashed_imports = {-trace "rnSource:trashed_imports"-} [] -\end{code} - -@implicitFVs@ forces the renamer to slurp in some things which aren't -mentioned explicitly, but which might be needed by the type checker. - -\begin{code} -implicitFVs mod_name - = implicit_main plusFV - mkNameSet default_tys plusFV - mkNameSet thinAirIdNames - where - -- Add occurrences for Int, Double, and (), because they - -- are the types to which ambigious type variables may be defaulted by - -- the type checker; so they won't always appear explicitly. - -- [The () one is a GHC extension for defaulting CCall results.] - -- ALSO: funTyCon, since it occurs implicitly everywhere! - -- (we don't want to be bothered with making funTyCon a - -- free var at every function application!) - default_tys = [getName intTyCon, getName doubleTyCon, - getName unitTyCon, getName funTyCon, getName boolTyCon] - - -- Add occurrences for IO or PrimIO - implicit_main | mod_name == mAIN_Name - || mod_name == pREL_MAIN_Name = unitFV ioTyCon_NAME - | otherwise = emptyFVs -\end{code} - -\begin{code} -isOrphanDecl (InstD (InstDecl inst_ty _ _ _ _)) - = not (foldNameSet ((||) . isLocallyDefined) False (extractHsTyNames inst_ty)) -isOrphanDecl (RuleD (RuleDecl _ _ _ lhs _ _)) - = check lhs - where - check (HsVar v) = not (isLocallyDefined v) - check (HsApp f a) = check f && check a - check other = True -isOrphanDecl other = False -\end{code} - - -%********************************************************* -%* * -\subsection{Slurping declarations} -%* * -%********************************************************* - -\begin{code} -------------------------------------------------------- -slurpImpDecls source_fvs - = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) thenRn_ - - -- The current slurped-set records all local things - getSlurped thenRn \ source_binders -> - slurpSourceRefs source_binders source_fvs thenRn \ (decls1, needed1, inst_gates) -> - - -- Now we can get the instance decls - slurpInstDecls decls1 needed1 inst_gates thenRn \ (decls2, needed2) -> - - -- And finally get everything else - closeDecls decls2 needed2 - -------------------------------------------------------- -slurpSourceRefs :: NameSet -- Variables defined in source - -> FreeVars -- Variables referenced in source - -> RnMG ([RenamedHsDecl], - FreeVars, -- Un-satisfied needs - FreeVars) -- "Gates" --- The declaration (and hence home module) of each gate has --- already been loaded - -slurpSourceRefs source_binders source_fvs - = go [] -- Accumulating decls - emptyFVs -- Unsatisfied needs - source_fvs -- Accumulating gates - (nameSetToList source_fvs) -- Gates whose defn hasn't been loaded yet - where - go decls fvs gates [] - = returnRn (decls, fvs, gates) - - go decls fvs gates (wanted_name:refs) - | isWiredInName wanted_name - = load_home wanted_name thenRn_ - go decls fvs (gates plusFV getWiredInGates wanted_name) refs - - | otherwise - = importDecl wanted_name thenRn \ maybe_decl -> - case maybe_decl of - -- No declaration... (already slurped, or local) - Nothing -> go decls fvs gates refs - Just decl -> rnIfaceDecl decl thenRn \ (new_decl, fvs1) -> - let - new_gates = getGates source_fvs new_decl - in - go (new_decl : decls) - (fvs1 plusFV fvs) - (gates plusFV new_gates) - (nameSetToList new_gates ++ refs) - - -- When we find a wired-in name we must load its - -- home module so that we find any instance decls therein - load_home name - | name elemNameSet source_binders = returnRn () - -- When compiling the prelude, a wired-in thing may - -- be defined in this module, in which case we don't - -- want to load its home module! - -- Using 'isLocallyDefined' doesn't work because some of - -- the free variables returned are simply 'listTyCon_Name', - -- with a system provenance. We could look them up every time - -- but that seems a waste. - | otherwise = loadHomeInterface doc name thenRn_ - returnRn () - where - doc = ptext SLIT("need home module for wired in thing") <+> ppr name - -------------------------------------------------------- --- slurpInstDecls imports appropriate instance decls. --- It has to incorporate a loop, because consider --- instance Foo a => Baz (Maybe a) where ... --- It may be that Baz and Maybe are used in the source module, --- but not Foo; so we need to chase Foo too. - -slurpInstDecls decls needed gates - | isEmptyFVs gates - = returnRn (decls, needed) - - | otherwise - = getImportedInstDecls gates thenRn \ inst_decls -> - rnInstDecls decls needed emptyFVs inst_decls thenRn \ (decls1, needed1, gates1) -> - slurpInstDecls decls1 needed1 gates1 - where - rnInstDecls decls fvs gates [] - = returnRn (decls, fvs, gates) - rnInstDecls decls fvs gates (d:ds) - = rnIfaceDecl d thenRn \ (new_decl, fvs1) -> - rnInstDecls (new_decl:decls) - (fvs1 plusFV fvs) - (gates plusFV getInstDeclGates new_decl) - ds - - -------------------------------------------------------- --- closeDecls keeps going until the free-var set is empty -closeDecls decls needed - | not (isEmptyFVs needed) - = slurpDecls decls needed thenRn \ (decls1, needed1) -> - closeDecls decls1 needed1 - - | otherwise - = getImportedRules thenRn \ rule_decls -> - case rule_decls of - [] -> returnRn decls -- No new rules, so we are done - other -> rnIfaceDecls decls emptyFVs rule_decls thenRn \ (decls1, needed1) -> - closeDecls decls1 needed1 - - -------------------------------------------------------- -rnIfaceDecls :: [RenamedHsDecl] -> FreeVars - -> [(Module, RdrNameHsDecl)] - -> RnM d ([RenamedHsDecl], FreeVars) -rnIfaceDecls decls fvs [] = returnRn (decls, fvs) -rnIfaceDecls decls fvs (d:ds) = rnIfaceDecl d thenRn \ (new_decl, fvs1) -> - rnIfaceDecls (new_decl:decls) (fvs1 plusFV fvs) ds - -rnIfaceDecl (mod, decl) = initIfaceRnMS mod (rnDecl decl) - - -------------------------------------------------------- --- Augment decls with any decls needed by needed. --- Return also free vars of the new decls (only) -slurpDecls decls needed - = go decls emptyFVs (nameSetToList needed) - where - go decls fvs [] = returnRn (decls, fvs) - go decls fvs (ref:refs) = slurpDecl decls fvs ref thenRn \ (decls1, fvs1) -> - go decls1 fvs1 refs - -------------------------------------------------------- -slurpDecl decls fvs wanted_name - = importDecl wanted_name thenRn \ maybe_decl -> - case maybe_decl of - -- No declaration... (wired in thing) - Nothing -> returnRn (decls, fvs) - - -- Found a declaration... rename it - Just decl -> rnIfaceDecl decl thenRn \ (new_decl, fvs1) -> - returnRn (new_decl:decls, fvs1 plusFV fvs) -\end{code} - - -%********************************************************* -%* * -\subsection{Extracting the 'gates'} -%* * -%********************************************************* - -When we import a declaration like - - data T = T1 Wibble | T2 Wobble - -we don't want to treat Wibble and Wobble as gates *unless* T1, T2 -respectively are mentioned by the user program. If only T is mentioned -we want only T to be a gate; that way we don't suck in useless instance -decls for (say) Eq Wibble, when they can't possibly be useful. - -@getGates@ takes a newly imported (and renamed) decl, and the free -vars of the source program, and extracts from the decl the gate names. - -\begin{code} -getGates source_fvs (SigD (IfaceSig _ ty _ _)) - = extractHsTyNames ty - -getGates source_fvs (TyClD (ClassDecl ctxt cls tvs sigs _ _ _ _ _ _)) - = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs) - (map getTyVarName tvs) - addOneToNameSet cls - where - get (ClassOpSig n _ ty _) - | n elemNameSet source_fvs = extractHsTyNames ty - | otherwise = emptyFVs - -getGates source_fvs (TyClD (TySynonym tycon tvs ty _)) - = delListFromNameSet (extractHsTyNames ty) - (map getTyVarName tvs) - -- A type synonym type constructor isn't a "gate" for instance decls - -getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _)) - = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons) - (map getTyVarName tvs) - addOneToNameSet tycon - where - get (ConDecl n tvs ctxt details _) - | n elemNameSet source_fvs - -- If the constructor is method, get fvs from all its fields - = delListFromNameSet (get_details details plusFV - extractHsCtxtTyNames ctxt) - (map getTyVarName tvs) - get (ConDecl n tvs ctxt (RecCon fields) _) - -- Even if the constructor isn't mentioned, the fields - -- might be, as selectors. They can't mention existentially - -- bound tyvars (typechecker checks for that) so no need for - -- the deleteListFromNameSet part - = foldr (plusFV . get_field) emptyFVs fields - - get other_con = emptyFVs - - get_details (VanillaCon tys) = plusFVs (map get_bang tys) - get_details (InfixCon t1 t2) = get_bang t1 plusFV get_bang t2 - get_details (RecCon fields) = plusFVs [get_bang t | (_, t) <- fields] - get_details (NewCon t _) = extractHsTyNames t - - get_field (fs,t) | any (elemNameSet source_fvs) fs = get_bang t - | otherwise = emptyFVs - - get_bang (Banged t) = extractHsTyNames t - get_bang (Unbanged t) = extractHsTyNames t - get_bang (Unpacked t) = extractHsTyNames t - -getGates source_fvs other_decl = emptyFVs -\end{code} - -getWiredInGates is just like getGates, but it sees a wired-in Name -rather than a declaration. - -\begin{code} -getWiredInGates :: Name -> FreeVars -getWiredInGates name -- No classes are wired in - | is_id = getWiredInGates_s (namesOfType (idType the_id)) - | isSynTyCon the_tycon = getWiredInGates_s (delListFromNameSet (namesOfType ty) (map getName tyvars)) - | otherwise = unitFV name - where - maybe_wired_in_id = maybeWiredInIdName name - is_id = maybeToBool maybe_wired_in_id - maybe_wired_in_tycon = maybeWiredInTyConName name - Just the_id = maybe_wired_in_id - Just the_tycon = maybe_wired_in_tycon - (tyvars,ty) = getSynTyConDefn the_tycon - -getWiredInGates_s names = foldr (plusFV . getWiredInGates) emptyFVs (nameSetToList names) -\end{code} - -\begin{code} -getInstDeclGates (InstD (InstDecl inst_ty _ _ _ _)) = extractHsTyNames inst_ty -getInstDeclGates other = emptyFVs -\end{code} - - -%********************************************************* -%* * -\subsection{Unused names} -%* * -%********************************************************* - -\begin{code} -reportUnusedNames gbl_env avail_env (ExportEnv export_avails _) mentioned_names - | not (opt_WarnUnusedBinds || opt_WarnUnusedImports) - = returnRn () - - | otherwise - = let - used_names = mentioned_names unionNameSets availsToNameSet export_avails - - -- Now, a use of C implies a use of T, - -- if C was brought into scope by T(..) or T(C) - really_used_names = used_names unionNameSets - mkNameSet [ availName avail - | sub_name <- nameSetToList used_names, - let avail = case lookupNameEnv avail_env sub_name of - Just avail -> avail - Nothing -> pprTrace "r.u.n" (ppr sub_name) $- Avail sub_name - ] - - defined_names = mkNameSet (concat (rdrEnvElts gbl_env)) - defined_but_not_used = nameSetToList (defined_names minusNameSet really_used_names) - - -- Filter out the ones only defined implicitly - bad_guys = filter reportableUnusedName defined_but_not_used - in - warnUnusedTopNames bad_guys thenRn_ - returnRn () - -reportableUnusedName :: Name -> Bool -reportableUnusedName name - = explicitlyImported (getNameProvenance name) && - not (startsWithUnderscore (occNameUserString (nameOccName name))) - where - explicitlyImported (LocalDef _ _) = True -- Report unused defns of local vars - explicitlyImported (NonLocalDef (UserImport _ _ expl) _) = expl -- Report unused explicit imports - explicitlyImported other = False -- Don't report others - - -- Haskell 98 encourages compilers to suppress warnings about - -- unused names in a pattern if they start with "_". - startsWithUnderscore ('_' : _) = True -- Suppress warnings for names starting - startsWithUnderscore other = False -- with an underscore - -rnStats :: [RenamedHsDecl] -> RnMG () -rnStats imp_decls - | opt_D_dump_rn_trace || - opt_D_dump_rn_stats || - opt_D_dump_rn - = getRnStats imp_decls thenRn \ msg -> - ioToRnM (printErrs msg) thenRn_ - returnRn () - - | otherwise = returnRn () -\end{code} - - - -%********************************************************* -%* * -\subsection{Statistics} -%* * -%********************************************************* - -\begin{code} -getRnStats :: [RenamedHsDecl] -> RnMG SDoc -getRnStats imported_decls - = getIfacesRn thenRn \ ifaces -> - let - n_mods = length [() | (_, _, Just _) <- eltsFM (iImpModInfo ifaces)] - - decls_read = [decl | (_, avail, True, (_,decl)) <- nameEnvElts (iDecls ifaces), - -- Data, newtype, and class decls are in the decls_fm - -- under multiple names; the tycon/class, and each - -- constructor/class op too. - -- The 'True' selects just the 'main' decl - not (isLocallyDefined (availName avail)) - ] - - (cd_rd, dd_rd, nd_rd, sd_rd, vd_rd, _) = count_decls decls_read - (cd_sp, dd_sp, nd_sp, sd_sp, vd_sp, id_sp) = count_decls imported_decls - - unslurped_insts = iInsts ifaces - inst_decls_unslurped = length (bagToList unslurped_insts) - inst_decls_read = id_sp + inst_decls_unslurped - - stats = vcat - [int n_mods <+> text "interfaces read", - hsep [ int cd_sp, text "class decls imported, out of", - int cd_rd, text "read"], - hsep [ int dd_sp, text "data decls imported, out of", - int dd_rd, text "read"], - hsep [ int nd_sp, text "newtype decls imported, out of", - int nd_rd, text "read"], - hsep [int sd_sp, text "type synonym decls imported, out of", - int sd_rd, text "read"], - hsep [int vd_sp, text "value signatures imported, out of", - int vd_rd, text "read"], - hsep [int id_sp, text "instance decls imported, out of", - int inst_decls_read, text "read"], - text "cls dcls slurp" <+> fsep (map (ppr . tyClDeclName) - [d | TyClD d <- imported_decls, isClassDecl d]), - text "cls dcls read" <+> fsep (map (ppr . tyClDeclName) - [d | TyClD d <- decls_read, isClassDecl d])] - in - returnRn (hcat [text "Renamer stats: ", stats]) - -count_decls decls - = (class_decls, - data_decls, - newtype_decls, - syn_decls, - val_decls, - inst_decls) - where - tycl_decls = [d | TyClD d <- decls] - (class_decls, data_decls, newtype_decls, syn_decls) = countTyClDecls tycl_decls - - val_decls = length [() | SigD _ <- decls] - inst_decls = length [() | InstD _ <- decls] -\end{code} - +% +% (c) The GRASP Project, Glasgow University, 1992-1998 +% +\section[Rename]{Renaming and dependency analysis passes} + +\begin{code} +module Rename ( renameModule ) where + +#include "HsVersions.h" + +import HsSyn +import RdrHsSyn ( RdrNameHsModule ) +import RnHsSyn ( RenamedHsModule, RenamedHsDecl, + extractHsTyNames, extractHsCtxtTyNames + ) + +import CmdLineOpts ( opt_HiMap, opt_D_dump_rn_trace, + opt_D_dump_rn, opt_D_dump_rn_stats, + opt_WarnUnusedBinds, opt_WarnUnusedImports + ) +import RnMonad +import RnNames ( getGlobalNames ) +import RnSource ( rnSourceDecls, rnDecl ) +import RnIfaces ( getImportedInstDecls, importDecl, getImportVersions, + getImportedRules, loadHomeInterface, getSlurped + ) +import RnEnv ( availName, availNames, availsToNameSet, + warnUnusedTopNames, mapFvRn, + FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs + ) +import Module ( Module, ModuleName, pprModule, mkSearchPath, mkThisModule ) +import Name ( Name, isLocallyDefined, + NamedThing(..), ImportReason(..), Provenance(..), + pprOccName, nameOccName, + getNameProvenance, occNameUserString, + maybeWiredInTyConName, maybeWiredInIdName, isWiredInName + ) +import Id ( idType ) +import DataCon ( dataConTyCon, dataConType ) +import TyCon ( TyCon, tyConDataCons, isSynTyCon, getSynTyConDefn ) +import RdrName ( RdrName ) +import NameSet +import PrelMods ( mAIN_Name, pREL_MAIN_Name ) +import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon, boolTyCon ) +import PrelInfo ( ioTyCon_NAME, thinAirIdNames ) +import Type ( namesOfType, funTyCon ) +import ErrUtils ( pprBagOfErrors, pprBagOfWarnings, + doIfSet, dumpIfSet, ghcExit + ) +import BasicTypes ( NewOrData(..) ) +import Bag ( isEmptyBag, bagToList ) +import FiniteMap ( fmToList, delListFromFM, addToFM, sizeFM, eltsFM ) +import UniqSupply ( UniqSupply ) +import Util ( equivClasses ) +import Maybes ( maybeToBool ) +import Outputable +\end{code} + + + +\begin{code} +renameModule :: UniqSupply + -> RdrNameHsModule + -> IO (Maybe + ( Module + , RenamedHsModule -- Output, after renaming + , InterfaceDetails -- Interface; for interface file generation + , RnNameSupply -- Final env; for renaming derivings + , [ModuleName] -- Imported modules; for profiling + )) + +renameModule us this_mod@(HsModule mod_name vers exports imports local_decls loc) + = -- Initialise the renamer monad + initRn mod_name us (mkSearchPath opt_HiMap) loc + (rename this_mod) >>= + \ (maybe_rn_stuff, rn_errs_bag, rn_warns_bag) -> + + -- Check for warnings + doIfSet (not (isEmptyBag rn_warns_bag)) + (printErrs (pprBagOfWarnings rn_warns_bag)) >> + + -- Check for errors; exit if so + doIfSet (not (isEmptyBag rn_errs_bag)) + (printErrs (pprBagOfErrors rn_errs_bag) >> + ghcExit 1 + ) >> + + -- Dump output, if any + (case maybe_rn_stuff of + Nothing -> return () + Just results@(_, rn_mod, _, _, _) + -> dumpIfSet opt_D_dump_rn "Renamer:" + (ppr rn_mod) + ) >> + + -- Return results + return maybe_rn_stuff +\end{code} + + +\begin{code} +rename this_mod@(HsModule mod_name vers exports imports local_decls loc) + = -- FIND THE GLOBAL NAME ENVIRONMENT + getGlobalNames this_mod thenRn \ maybe_stuff -> + + -- CHECK FOR EARLY EXIT + if not (maybeToBool maybe_stuff) then + -- Everything is up to date; no need to recompile further + rnStats [] thenRn_ + returnRn Nothing + else + let + Just (export_env, gbl_env, fixity_env, global_avail_env) = maybe_stuff + in + + -- RENAME THE SOURCE + initRnMS gbl_env fixity_env SourceMode ( + rnSourceDecls local_decls + ) thenRn \ (rn_local_decls, source_fvs) -> + + -- SLURP IN ALL THE NEEDED DECLARATIONS + let + real_source_fvs = implicitFVs mod_name plusFV source_fvs + -- It's important to do the "plus" this way round, so that + -- when compiling the prelude, locally-defined (), Bool, etc + -- override the implicit ones. + in + slurpImpDecls real_source_fvs thenRn \ rn_imp_decls -> + + -- EXIT IF ERRORS FOUND + checkErrsRn thenRn \ no_errs_so_far -> + if not no_errs_so_far then + -- Found errors already, so exit now + rnStats [] thenRn_ + returnRn Nothing + else + + -- GENERATE THE VERSION/USAGE INFO + getImportVersions mod_name exports thenRn \ my_usages -> + getNameSupplyRn thenRn \ name_supply -> + + -- REPORT UNUSED NAMES + reportUnusedNames gbl_env global_avail_env + export_env + source_fvs thenRn_ + + -- RETURN THE RENAMED MODULE + let + has_orphans = any isOrphanDecl rn_local_decls + direct_import_mods = [mod | ImportDecl mod _ _ _ _ _ <- imports] + rn_all_decls = rn_imp_decls ++ rn_local_decls + renamed_module = HsModule mod_name vers + trashed_exports trashed_imports + rn_all_decls + loc + in + rnStats rn_imp_decls thenRn_ + returnRn (Just (mkThisModule mod_name, + renamed_module, + (has_orphans, my_usages, export_env), + name_supply, + direct_import_mods)) + where + trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing + trashed_imports = {-trace "rnSource:trashed_imports"-} [] +\end{code} + +@implicitFVs@ forces the renamer to slurp in some things which aren't +mentioned explicitly, but which might be needed by the type checker. + +\begin{code} +implicitFVs mod_name + = implicit_main plusFV + mkNameSet default_tys plusFV + mkNameSet thinAirIdNames + where + -- Add occurrences for Int, Double, and (), because they + -- are the types to which ambigious type variables may be defaulted by + -- the type checker; so they won't always appear explicitly. + -- [The () one is a GHC extension for defaulting CCall results.] + -- ALSO: funTyCon, since it occurs implicitly everywhere! + -- (we don't want to be bothered with making funTyCon a + -- free var at every function application!) + default_tys = [getName intTyCon, getName doubleTyCon, + getName unitTyCon, getName funTyCon, getName boolTyCon] + + -- Add occurrences for IO or PrimIO + implicit_main | mod_name == mAIN_Name + || mod_name == pREL_MAIN_Name = unitFV ioTyCon_NAME + | otherwise = emptyFVs +\end{code} + +\begin{code} +isOrphanDecl (InstD (InstDecl inst_ty _ _ _ _)) + = not (foldNameSet ((||) . isLocallyDefined) False (extractHsTyNames inst_ty)) +isOrphanDecl (RuleD (RuleDecl _ _ _ lhs _ _)) + = check lhs + where + check (HsVar v) = not (isLocallyDefined v) + check (HsApp f a) = check f && check a + check other = True +isOrphanDecl other = False +\end{code} + + +%********************************************************* +%* * +\subsection{Slurping declarations} +%* * +%********************************************************* + +\begin{code} +------------------------------------------------------- +slurpImpDecls source_fvs + = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) thenRn_ + + -- The current slurped-set records all local things + getSlurped thenRn \ source_binders -> + slurpSourceRefs source_binders source_fvs thenRn \ (decls1, needed1, inst_gates) -> + + -- Now we can get the instance decls + slurpInstDecls decls1 needed1 inst_gates thenRn \ (decls2, needed2) -> + + -- And finally get everything else + closeDecls decls2 needed2 + +------------------------------------------------------- +slurpSourceRefs :: NameSet -- Variables defined in source + -> FreeVars -- Variables referenced in source + -> RnMG ([RenamedHsDecl], + FreeVars, -- Un-satisfied needs + FreeVars) -- "Gates" +-- The declaration (and hence home module) of each gate has +-- already been loaded + +slurpSourceRefs source_binders source_fvs + = go [] -- Accumulating decls + emptyFVs -- Unsatisfied needs + source_fvs -- Accumulating gates + (nameSetToList source_fvs) -- Gates whose defn hasn't been loaded yet + where + go decls fvs gates [] + = returnRn (decls, fvs, gates) + + go decls fvs gates (wanted_name:refs) + | isWiredInName wanted_name + = load_home wanted_name thenRn_ + go decls fvs (gates plusFV getWiredInGates wanted_name) refs + + | otherwise + = importDecl wanted_name thenRn \ maybe_decl -> + case maybe_decl of + -- No declaration... (already slurped, or local) + Nothing -> go decls fvs gates refs + Just decl -> rnIfaceDecl decl thenRn \ (new_decl, fvs1) -> + let + new_gates = getGates source_fvs new_decl + in + go (new_decl : decls) + (fvs1 plusFV fvs) + (gates plusFV new_gates) + (nameSetToList new_gates ++ refs) + + -- When we find a wired-in name we must load its + -- home module so that we find any instance decls therein + load_home name + | name elemNameSet source_binders = returnRn () + -- When compiling the prelude, a wired-in thing may + -- be defined in this module, in which case we don't + -- want to load its home module! + -- Using 'isLocallyDefined' doesn't work because some of + -- the free variables returned are simply 'listTyCon_Name', + -- with a system provenance. We could look them up every time + -- but that seems a waste. + | otherwise = loadHomeInterface doc name thenRn_ + returnRn () + where + doc = ptext SLIT("need home module for wired in thing") <+> ppr name +\end{code} +% +@slurpInstDecls@ imports appropriate instance decls. +It has to incorporate a loop, because consider +\begin{verbatim} + instance Foo a => Baz (Maybe a) where ... +\end{verbatim} +It may be that @Baz@ and @Maybe@ are used in the source module, +but not @Foo@; so we need to chase @Foo@ too. + +\begin{code} +slurpInstDecls decls needed gates + | isEmptyFVs gates + = returnRn (decls, needed) + + | otherwise + = getImportedInstDecls gates thenRn \ inst_decls -> + rnInstDecls decls needed emptyFVs inst_decls thenRn \ (decls1, needed1, gates1) -> + slurpInstDecls decls1 needed1 gates1 + where + rnInstDecls decls fvs gates [] + = returnRn (decls, fvs, gates) + rnInstDecls decls fvs gates (d:ds) + = rnIfaceDecl d thenRn \ (new_decl, fvs1) -> + rnInstDecls (new_decl:decls) + (fvs1 plusFV fvs) + (gates plusFV getInstDeclGates new_decl) + ds + + +------------------------------------------------------- +-- closeDecls keeps going until the free-var set is empty +closeDecls decls needed + | not (isEmptyFVs needed) + = slurpDecls decls needed thenRn \ (decls1, needed1) -> + closeDecls decls1 needed1 + + | otherwise + = getImportedRules thenRn \ rule_decls -> + case rule_decls of + [] -> returnRn decls -- No new rules, so we are done + other -> rnIfaceDecls decls emptyFVs rule_decls thenRn \ (decls1, needed1) -> + closeDecls decls1 needed1 + + +------------------------------------------------------- +rnIfaceDecls :: [RenamedHsDecl] -> FreeVars + -> [(Module, RdrNameHsDecl)] + -> RnM d ([RenamedHsDecl], FreeVars) +rnIfaceDecls decls fvs [] = returnRn (decls, fvs) +rnIfaceDecls decls fvs (d:ds) = rnIfaceDecl d thenRn \ (new_decl, fvs1) -> + rnIfaceDecls (new_decl:decls) (fvs1 plusFV fvs) ds + +rnIfaceDecl (mod, decl) = initIfaceRnMS mod (rnDecl decl) + + +------------------------------------------------------- +-- Augment decls with any decls needed by needed. +-- Return also free vars of the new decls (only) +slurpDecls decls needed + = go decls emptyFVs (nameSetToList needed) + where + go decls fvs [] = returnRn (decls, fvs) + go decls fvs (ref:refs) = slurpDecl decls fvs ref thenRn \ (decls1, fvs1) -> + go decls1 fvs1 refs + +------------------------------------------------------- +slurpDecl decls fvs wanted_name + = importDecl wanted_name thenRn \ maybe_decl -> + case maybe_decl of + -- No declaration... (wired in thing) + Nothing -> returnRn (decls, fvs) + + -- Found a declaration... rename it + Just decl -> rnIfaceDecl decl thenRn \ (new_decl, fvs1) -> + returnRn (new_decl:decls, fvs1 plusFV fvs) +\end{code} + + +%********************************************************* +%* * +\subsection{Extracting the gates'} +%* * +%********************************************************* + +When we import a declaration like +\begin{verbatim} + data T = T1 Wibble | T2 Wobble +\end{verbatim} +we don't want to treat @Wibble@ and @Wobble@ as gates +{\em unless} @T1@, @T2@ respectively are mentioned by the user program. +If only @T@ is mentioned +we want only @T@ to be a gate; +that way we don't suck in useless instance +decls for (say) @Eq Wibble@, when they can't possibly be useful. + +@getGates@ takes a newly imported (and renamed) decl, and the free +vars of the source program, and extracts from the decl the gate names. + +\begin{code} +getGates source_fvs (SigD (IfaceSig _ ty _ _)) + = extractHsTyNames ty + +getGates source_fvs (TyClD (ClassDecl ctxt cls tvs sigs _ _ _ _ _ _)) + = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs) + (map getTyVarName tvs) + addOneToNameSet cls + where + get (ClassOpSig n _ ty _) + | n elemNameSet source_fvs = extractHsTyNames ty + | otherwise = emptyFVs + +getGates source_fvs (TyClD (TySynonym tycon tvs ty _)) + = delListFromNameSet (extractHsTyNames ty) + (map getTyVarName tvs) + -- A type synonym type constructor isn't a "gate" for instance decls + +getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _)) + = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons) + (map getTyVarName tvs) + addOneToNameSet tycon + where + get (ConDecl n tvs ctxt details _) + | n elemNameSet source_fvs + -- If the constructor is method, get fvs from all its fields + = delListFromNameSet (get_details details plusFV + extractHsCtxtTyNames ctxt) + (map getTyVarName tvs) + get (ConDecl n tvs ctxt (RecCon fields) _) + -- Even if the constructor isn't mentioned, the fields + -- might be, as selectors. They can't mention existentially + -- bound tyvars (typechecker checks for that) so no need for + -- the deleteListFromNameSet part + = foldr (plusFV . get_field) emptyFVs fields + + get other_con = emptyFVs + + get_details (VanillaCon tys) = plusFVs (map get_bang tys) + get_details (InfixCon t1 t2) = get_bang t1 plusFV get_bang t2 + get_details (RecCon fields) = plusFVs [get_bang t | (_, t) <- fields] + get_details (NewCon t _) = extractHsTyNames t + + get_field (fs,t) | any (elemNameSet source_fvs) fs = get_bang t + | otherwise = emptyFVs + + get_bang (Banged t) = extractHsTyNames t + get_bang (Unbanged t) = extractHsTyNames t + get_bang (Unpacked t) = extractHsTyNames t + +getGates source_fvs other_decl = emptyFVs +\end{code} + +@getWiredInGates@ is just like @getGates@, but it sees a wired-in @Name@ +rather than a declaration. + +\begin{code} +getWiredInGates :: Name -> FreeVars +getWiredInGates name -- No classes are wired in + | is_id = getWiredInGates_s (namesOfType (idType the_id)) + | isSynTyCon the_tycon = getWiredInGates_s + (delListFromNameSet (namesOfType ty) (map getName tyvars)) + | otherwise = unitFV name + where + maybe_wired_in_id = maybeWiredInIdName name + is_id = maybeToBool maybe_wired_in_id + maybe_wired_in_tycon = maybeWiredInTyConName name + Just the_id = maybe_wired_in_id + Just the_tycon = maybe_wired_in_tycon + (tyvars,ty) = getSynTyConDefn the_tycon + +getWiredInGates_s names = foldr (plusFV . getWiredInGates) emptyFVs (nameSetToList names) +\end{code} + +\begin{code} +getInstDeclGates (InstD (InstDecl inst_ty _ _ _ _)) = extractHsTyNames inst_ty +getInstDeclGates other = emptyFVs +\end{code} + + +%********************************************************* +%* * +\subsection{Unused names} +%* * +%********************************************************* + +\begin{code} +reportUnusedNames gbl_env avail_env (ExportEnv export_avails _) mentioned_names + | not (opt_WarnUnusedBinds || opt_WarnUnusedImports) + = returnRn () + + | otherwise + = let + used_names = mentioned_names unionNameSets availsToNameSet export_avails + + -- Now, a use of C implies a use of T, + -- if C was brought into scope by T(..) or T(C) + really_used_names = used_names unionNameSets + mkNameSet [ availName avail + | sub_name <- nameSetToList used_names, + let avail = case lookupNameEnv avail_env sub_name of + Just avail -> avail + Nothing -> pprTrace "r.u.n" (ppr sub_name)$ + Avail sub_name + ] + + defined_names = mkNameSet (concat (rdrEnvElts gbl_env)) + defined_but_not_used = + nameSetToList (defined_names minusNameSet really_used_names) + + -- Filter out the ones only defined implicitly + bad_guys = filter reportableUnusedName defined_but_not_used + in + warnUnusedTopNames bad_guys thenRn_ + returnRn () + +reportableUnusedName :: Name -> Bool +reportableUnusedName name + = explicitlyImported (getNameProvenance name) && + not (startsWithUnderscore (occNameUserString (nameOccName name))) + where + explicitlyImported (LocalDef _ _) = True + -- Report unused defns of local vars + explicitlyImported (NonLocalDef (UserImport _ _ expl) _) = expl + -- Report unused explicit imports + explicitlyImported other = False + -- Don't report others + + -- Haskell 98 encourages compilers to suppress warnings about + -- unused names in a pattern if they start with "_". + startsWithUnderscore ('_' : _) = True + -- Suppress warnings for names starting with an underscore + startsWithUnderscore other = False + +rnStats :: [RenamedHsDecl] -> RnMG () +rnStats imp_decls + | opt_D_dump_rn_trace || + opt_D_dump_rn_stats || + opt_D_dump_rn + = getRnStats imp_decls thenRn \ msg -> + ioToRnM (printErrs msg) thenRn_ + returnRn () + + | otherwise = returnRn () +\end{code} + + + +%********************************************************* +%* * +\subsection{Statistics} +%* * +%********************************************************* + +\begin{code} +getRnStats :: [RenamedHsDecl] -> RnMG SDoc +getRnStats imported_decls + = getIfacesRn thenRn \ ifaces -> + let + n_mods = length [() | (_, _, Just _) <- eltsFM (iImpModInfo ifaces)] + + decls_read = [decl | (_, avail, True, (_,decl)) <- nameEnvElts (iDecls ifaces), + -- Data, newtype, and class decls are in the decls_fm + -- under multiple names; the tycon/class, and each + -- constructor/class op too. + -- The 'True' selects just the 'main' decl + not (isLocallyDefined (availName avail)) + ] + + (cd_rd, dd_rd, nd_rd, sd_rd, vd_rd, _) = count_decls decls_read + (cd_sp, dd_sp, nd_sp, sd_sp, vd_sp, id_sp) = count_decls imported_decls + + unslurped_insts = iInsts ifaces + inst_decls_unslurped = length (bagToList unslurped_insts) + inst_decls_read = id_sp + inst_decls_unslurped + + stats = vcat + [int n_mods <+> text "interfaces read", + hsep [ int cd_sp, text "class decls imported, out of", + int cd_rd, text "read"], + hsep [ int dd_sp, text "data decls imported, out of", + int dd_rd, text "read"], + hsep [ int nd_sp, text "newtype decls imported, out of", + int nd_rd, text "read"], + hsep [int sd_sp, text "type synonym decls imported, out of", + int sd_rd, text "read"], + hsep [int vd_sp, text "value signatures imported, out of", + int vd_rd, text "read"], + hsep [int id_sp, text "instance decls imported, out of", + int inst_decls_read, text "read"], + text "cls dcls slurp" <+> fsep (map (ppr . tyClDeclName) + [d | TyClD d <- imported_decls, isClassDecl d]), + text "cls dcls read" <+> fsep (map (ppr . tyClDeclName) + [d | TyClD d <- decls_read, isClassDecl d])] + in + returnRn (hcat [text "Renamer stats: ", stats]) + +count_decls decls + = (class_decls, + data_decls, + newtype_decls, + syn_decls, + val_decls, + inst_decls) + where + tycl_decls = [d | TyClD d <- decls] + (class_decls, data_decls, newtype_decls, syn_decls) = countTyClDecls tycl_decls + + val_decls = length [() | SigD _ <- decls] + inst_decls = length [() | InstD _ <- decls] +\end{code} + diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index b55f6feb8cce03abc5d0e296fe26e6316006181d..c29ecd9ee74bf1ae8733a5e0167071ad9c8e421e 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -1,607 +1,617 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[RnBinds]{Renaming and dependency analysis of bindings} - -This module does renaming and dependency analysis on value bindings in -the abstract syntax. It does {\em not} do cycle-checks on class or -type-synonym declarations; those cannot be done at this stage because -they may be affected by renaming (which isn't fully worked out yet). - -\begin{code} -module RnBinds ( - rnTopBinds, rnTopMonoBinds, - rnMethodBinds, renameSigs, - rnBinds, - unknownSigErr - ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} RnSource ( rnHsSigType ) - -import HsSyn -import HsBinds ( sigsForMe ) -import RdrHsSyn -import RnHsSyn -import RnMonad -import RnExpr ( rnMatch, rnGRHSs, rnPat, checkPrecMatch ) -import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupGlobalOccRn, - warnUnusedLocalBinds, mapFvRn, - FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV, - unknownNameErr - ) -import CmdLineOpts ( opt_WarnMissingSigs ) -import Digraph ( stronglyConnComp, SCC(..) ) -import Name ( OccName, Name, nameOccName ) -import NameSet -import RdrName ( RdrName, rdrNameOcc ) -import BasicTypes ( RecFlag(..), TopLevelFlag(..) ) -import Util ( thenCmp, removeDups ) -import List ( partition ) -import ListSetOps ( minusList ) -import Bag ( bagToList ) -import FiniteMap ( lookupFM, listToFM ) -import Maybe ( isJust ) -import Outputable -\end{code} - --- ToDo: Put the annotations into the monad, so that they arrive in the proper --- place and can be used when complaining. - -The code tree received by the function @rnBinds@ contains definitions -in where-clauses which are all apparently mutually recursive, but which may -not really depend upon each other. For example, in the top level program -\begin{verbatim} -f x = y where a = x - y = x -\end{verbatim} -the definitions of @a@ and @y@ do not depend on each other at all. -Unfortunately, the typechecker cannot always check such definitions. -\footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive -definitions. In Proceedings of the International Symposium on Programming, -Toulouse, pp. 217-39. LNCS 167. Springer Verlag.} -However, the typechecker usually can check definitions in which only the -strongly connected components have been collected into recursive bindings. -This is precisely what the function @rnBinds@ does. - -ToDo: deal with case where a single monobinds binds the same variable -twice. - -The vertag tag is a unique @Int@; the tags only need to be unique -within one @MonoBinds@, so that unique-Int plumbing is done explicitly -(heavy monad machinery not needed). - -\begin{code} -type VertexTag = Int -type Cycle = [VertexTag] -type Edge = (VertexTag, VertexTag) -\end{code} - -%************************************************************************ -%* * -%* naming conventions * -%* * -%************************************************************************ - -\subsection[name-conventions]{Name conventions} - -The basic algorithm involves walking over the tree and returning a tuple -containing the new tree plus its free variables. Some functions, such -as those walking polymorphic bindings (HsBinds) and qualifier lists in -list comprehensions (@Quals@), return the variables bound in local -environments. These are then used to calculate the free variables of the -expression evaluated in these environments. - -Conventions for variable names are as follows: -\begin{itemize} -\item -new code is given a prime to distinguish it from the old. - -\item -a set of variables defined in @Exp@ is written @dvExp@ - -\item -a set of variables free in @Exp@ is written @fvExp@ -\end{itemize} - -%************************************************************************ -%* * -%* analysing polymorphic bindings (HsBinds, Bind, MonoBinds) * -%* * -%************************************************************************ - -\subsubsection[dep-HsBinds]{Polymorphic bindings} - -Non-recursive expressions are reconstructed without any changes at top -level, although their component expressions may have to be altered. -However, non-recursive expressions are currently not expected as -\Haskell{} programs, and this code should not be executed. - -Monomorphic bindings contain information that is returned in a tuple -(a @FlatMonoBindsInfo@) containing: - -\begin{enumerate} -\item -a unique @Int@ that serves as the vertex tag'' for this binding. - -\item -the name of a function or the names in a pattern. These are a set -referred to as @dvLhs@, the defined variables of the left hand side. - -\item -the free variables of the body. These are referred to as @fvBody@. - -\item -the definition's actual code. This is referred to as just @code@. -\end{enumerate} - -The function @nonRecDvFv@ returns two sets of variables. The first is -the set of variables defined in the set of monomorphic bindings, while the -second is the set of free variables in those bindings. - -The set of variables defined in a non-recursive binding is just the -union of all of them, as @union@ removes duplicates. However, the -free variables in each successive set of cumulative bindings is the -union of those in the previous set plus those of the newest binding after -the defined variables of the previous set have been removed. - -@rnMethodBinds@ deals only with the declarations in class and -instance declarations. It expects only to see @FunMonoBind@s, and -it expects the global environment to contain bindings for the binders -(which are all class operations). - -%************************************************************************ -%* * -%* Top-level bindings -%* * -%************************************************************************ - -@rnTopBinds@ assumes that the environment already -contains bindings for the binders of this particular binding. - -\begin{code} -rnTopBinds :: RdrNameHsBinds -> RnMS (RenamedHsBinds, FreeVars) - -rnTopBinds EmptyBinds = returnRn (EmptyBinds, emptyFVs) -rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs - -- The parser doesn't produce other forms - - -rnTopMonoBinds EmptyMonoBinds sigs - = returnRn (EmptyBinds, emptyFVs) - -rnTopMonoBinds mbinds sigs - = mapRn lookupBndrRn binder_rdr_names thenRn \ binder_names -> - let - binder_set = mkNameSet binder_names - binder_occ_fm = listToFM [(nameOccName x,x) | x <- binder_names] - in - renameSigs opt_WarnMissingSigs binder_set - (lookupSigOccRn binder_occ_fm) sigs thenRn \ (siglist, sig_fvs) -> - rn_mono_binds siglist mbinds thenRn \ (final_binds, bind_fvs) -> - returnRn (final_binds, bind_fvs plusFV sig_fvs) - where - binder_rdr_names = map fst (bagToList (collectMonoBinders mbinds)) - --- the names appearing in the sigs have to be bound by --- this group's binders. -lookupSigOccRn binder_occ_fm rdr_name - = case lookupFM binder_occ_fm (rdrNameOcc rdr_name) of - Nothing -> failWithRn (mkUnboundName rdr_name) - (unknownNameErr rdr_name) - Just x -> returnRn x -\end{code} - -%************************************************************************ -%* * -%* Nested binds -%* * -%************************************************************************ - -@rnMonoBinds@ - - collects up the binders for this declaration group, - - checks that they form a set - - extends the environment to bind them to new local names - - calls @rnMonoBinds@ to do the real work - -\begin{code} -rnBinds :: RdrNameHsBinds - -> (RenamedHsBinds -> RnMS (result, FreeVars)) - -> RnMS (result, FreeVars) - -rnBinds EmptyBinds thing_inside = thing_inside EmptyBinds -rnBinds (MonoBind bind sigs _) thing_inside = rnMonoBinds bind sigs thing_inside - -- the parser doesn't produce other forms - - -rnMonoBinds :: RdrNameMonoBinds - -> [RdrNameSig] - -> (RenamedHsBinds -> RnMS (result, FreeVars)) - -> RnMS (result, FreeVars) - -rnMonoBinds EmptyMonoBinds sigs thing_inside = thing_inside EmptyBinds - -rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds - = -- Extract all the binders in this group, - -- and extend current scope, inventing new names for the new binders - -- This also checks that the names form a set - bindLocatedLocalsRn (text "a binding group") mbinders_w_srclocs $\ new_mbinders -> - let - binder_set = mkNameSet new_mbinders - - -- Weed out the fixity declarations that do not - -- apply to any of the binders in this group. - (sigs_for_me, fixes_not_for_me) = partition forLocalBind sigs - - forLocalBind (FixSig sig@(FixitySig name _ _ )) = - isJust (lookupFM binder_occ_fm (rdrNameOcc name)) - forLocalBind _ = True - - binder_occ_fm = listToFM [(nameOccName x,x) | x <- new_mbinders] - - in - -- Report the fixity declarations in this group that - -- don't refer to any of the group's binders. - -- - mapRn_ (unknownSigErr) fixes_not_for_me thenRn_ - renameSigs False binder_set - (lookupSigOccRn binder_occ_fm) sigs_for_me thenRn \ (siglist, sig_fvs) -> - let - fixity_sigs = [(name,sig) | FixSig sig@(FixitySig name _ _) <- siglist ] - in - -- Install the fixity declarations that do apply here and go. - extendFixityEnv fixity_sigs ( - rn_mono_binds siglist mbinds - ) thenRn \ (binds, bind_fvs) -> - - -- Now do the "thing inside", and deal with the free-variable calculations - thing_inside binds thenRn \ (result,result_fvs) -> - let - all_fvs = result_fvs plusFV bind_fvs plusFV sig_fvs - unused_binders = nameSetToList (binder_set minusNameSet all_fvs) - in - warnUnusedLocalBinds unused_binders thenRn_ - returnRn (result, delListFromNameSet all_fvs new_mbinders) - where - mbinders_w_srclocs = bagToList (collectMonoBinders mbinds) -\end{code} - - -%************************************************************************ -%* * -%* MonoBinds -- the main work is done here -%* * -%************************************************************************ - -@rn_mono_binds@ is used by *both* top-level and nested bindings. It -assumes that all variables bound in this group are already in scope. -This is done *either* by pass 3 (for the top-level bindings), *or* by -@rnMonoBinds@ (for the nested ones). - -\begin{code} -rn_mono_binds :: [RenamedSig] -- Signatures attached to this group - -> RdrNameMonoBinds - -> RnMS (RenamedHsBinds, -- - FreeVars) -- Free variables - -rn_mono_binds siglist mbinds - = - -- Rename the bindings, returning a MonoBindsInfo - -- which is a list of indivisible vertices so far as - -- the strongly-connected-components (SCC) analysis is concerned - flattenMonoBinds siglist mbinds thenRn \ mbinds_info -> - - -- Do the SCC analysis - let - edges = mkEdges (mbinds_info zip [(0::Int)..]) - scc_result = stronglyConnComp edges - final_binds = foldr1 ThenBinds (map reconstructCycle scc_result) - - -- Deal with bound and free-var calculation - rhs_fvs = plusFVs [fvs | (_,fvs,_,_) <- mbinds_info] - in - returnRn (final_binds, rhs_fvs) -\end{code} - -@flattenMonoBinds@ is ever-so-slightly magical in that it sticks -unique vertex tags'' on its output; minor plumbing required. - -Sigh - need to pass along the signatures for the group of bindings, -in case any of them - -\begin{code} -flattenMonoBinds :: [RenamedSig] -- Signatures - -> RdrNameMonoBinds - -> RnMS [FlatMonoBindsInfo] - -flattenMonoBinds sigs EmptyMonoBinds = returnRn [] - -flattenMonoBinds sigs (AndMonoBinds bs1 bs2) - = flattenMonoBinds sigs bs1 thenRn \ flat1 -> - flattenMonoBinds sigs bs2 thenRn \ flat2 -> - returnRn (flat1 ++ flat2) - -flattenMonoBinds sigs (PatMonoBind pat grhss locn) - = pushSrcLocRn locn$ - rnPat pat thenRn \ (pat', pat_fvs) -> - - -- Find which things are bound in this group - let - names_bound_here = mkNameSet (collectPatBinders pat') - sigs_for_me = sigsForMe (elemNameSet names_bound_here) sigs - in - rnGRHSs grhss thenRn \ (grhss', fvs) -> - returnRn - [(names_bound_here, - fvs plusFV pat_fvs, - PatMonoBind pat' grhss' locn, - sigs_for_me - )] - -flattenMonoBinds sigs (FunMonoBind name inf matches locn) - = pushSrcLocRn locn $- lookupBndrRn name thenRn \ new_name -> - let - sigs_for_me = sigsForMe (new_name ==) sigs - in - mapFvRn rnMatch matches thenRn \ (new_matches, fvs) -> - mapRn_ (checkPrecMatch inf new_name) new_matches thenRn_ - returnRn - [(unitNameSet new_name, - fvs, - FunMonoBind new_name inf new_matches locn, - sigs_for_me - )] -\end{code} - - -@rnMethodBinds@ is used for the method bindings of a class and an instance -declaration. like @rnMonoBinds@ but without dependency analysis. - -NOTA BENE: we record each *binder* of a method-bind group as a free variable. -That's crucial when dealing with an instance decl: - instance Foo (T a) where - op x = ... -This might be the *sole* occurrence of 'op' for an imported class Foo, -and unless op occurs we won't treat the type signature of op in the class -decl for Foo as a source of instance-decl gates. But we should! Indeed, -in many ways the op in an instance decl is just like an occurrence, not -a binder. - -\begin{code} -rnMethodBinds :: RdrNameMonoBinds -> RnMS (RenamedMonoBinds, FreeVars) - -rnMethodBinds EmptyMonoBinds = returnRn (EmptyMonoBinds, emptyFVs) - -rnMethodBinds (AndMonoBinds mb1 mb2) - = rnMethodBinds mb1 thenRn \ (mb1', fvs1) -> - rnMethodBinds mb2 thenRn \ (mb2', fvs2) -> - returnRn (mb1' AndMonoBinds mb2', fvs1 plusFV fvs2) - -rnMethodBinds (FunMonoBind name inf matches locn) - = pushSrcLocRn locn$ - - lookupGlobalOccRn name thenRn \ sel_name -> - -- We use the selector name as the binder - - mapFvRn rnMatch matches thenRn \ (new_matches, fvs) -> - mapRn_ (checkPrecMatch inf sel_name) new_matches thenRn_ - returnRn (FunMonoBind sel_name inf new_matches locn, fvs addOneFV sel_name) - -rnMethodBinds (PatMonoBind (VarPatIn name) grhss locn) - = pushSrcLocRn locn $- lookupGlobalOccRn name thenRn \ sel_name -> - rnGRHSs grhss thenRn \ (grhss', fvs) -> - returnRn (PatMonoBind (VarPatIn sel_name) grhss' locn, fvs addOneFV sel_name) - --- Can't handle method pattern-bindings which bind multiple methods. -rnMethodBinds mbind@(PatMonoBind other_pat _ locn) - = pushSrcLocRn locn$ - failWithRn (EmptyMonoBinds, emptyFVs) (methodBindErr mbind) -\end{code} - - -%************************************************************************ -%* * -\subsection[reconstruct-deps]{Reconstructing dependencies} -%* * -%************************************************************************ - -This @MonoBinds@- and @ClassDecls@-specific code is segregated here, -as the two cases are similar. - -\begin{code} -reconstructCycle :: SCC FlatMonoBindsInfo - -> RenamedHsBinds - -reconstructCycle (AcyclicSCC (_, _, binds, sigs)) - = MonoBind binds sigs NonRecursive - -reconstructCycle (CyclicSCC cycle) - = MonoBind this_gp_binds this_gp_sigs Recursive - where - this_gp_binds = foldr1 AndMonoBinds [binds | (_, _, binds, _) <- cycle] - this_gp_sigs = foldr1 (++) [sigs | (_, _, _, sigs) <- cycle] -\end{code} - -%************************************************************************ -%* * -%* Manipulating FlatMonoBindInfo * -%* * -%************************************************************************ - -During analysis a @MonoBinds@ is flattened to a @FlatMonoBindsInfo@. -The @RenamedMonoBinds@ is always an empty bind, a pattern binding or -a function binding, and has itself been dependency-analysed and -renamed. - -\begin{code} -type FlatMonoBindsInfo - = (NameSet, -- Set of names defined in this vertex - NameSet, -- Set of names used in this vertex - RenamedMonoBinds, - [RenamedSig]) -- Signatures, if any, for this vertex - -mkEdges :: [(FlatMonoBindsInfo, VertexTag)] -> [(FlatMonoBindsInfo, VertexTag, [VertexTag])] - -mkEdges flat_info - = [ (info, tag, dest_vertices (nameSetToList names_used)) - | (info@(names_defined, names_used, mbind, sigs), tag) <- flat_info - ] - where - -- An edge (v,v') indicates that v depends on v' - dest_vertices src_mentions = [ target_vertex - | ((names_defined, _, _, _), target_vertex) <- flat_info, - mentioned_name <- src_mentions, - mentioned_name elemNameSet names_defined - ] -\end{code} - - -%************************************************************************ -%* * -\subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)} -%* * -%************************************************************************ - -@renameSigs@ checks for: (a)~more than one sig for one thing; -(b)~signatures given for things not bound here; (c)~with suitably -flaggery, that all top-level things have type signatures. - -At the moment we don't gather free-var info from the types in -signatures. We'd only need this if we wanted to report unused tyvars. - -\begin{code} -renameSigs :: Bool -- True => warn if (required) type signatures are missing. - -> NameSet -- Set of names bound in this group - -> (RdrName -> RnMS Name) - -> [RdrNameSig] - -> RnMS ([RenamedSig], FreeVars) -- List of Sig constructors - -renameSigs sigs_required binders lookup_occ_nm sigs - = -- Rename the signatures - mapFvRn (renameSig lookup_occ_nm) sigs thenRn \ (sigs', fvs) -> - - -- Check for (a) duplicate signatures - -- (b) signatures for things not in this group - -- (c) optionally, bindings with no signature - let - (goodies, dups) = removeDups cmp_sig (sigsForMe (not . isUnboundName) sigs') - not_this_group = sigsForMe (not . (elemNameSet binders)) goodies - type_sig_vars = [n | Sig n _ _ <- goodies] - un_sigd_binders | sigs_required = nameSetToList binders minusList type_sig_vars - | otherwise = [] - in - mapRn_ dupSigDeclErr dups thenRn_ - mapRn_ unknownSigErr not_this_group thenRn_ - mapRn_ (addWarnRn.missingSigWarn) un_sigd_binders thenRn_ - returnRn (sigs', fvs) - -- bad ones and all: - -- we need bindings of *some* sort for every name - --- We use lookupOccRn in the signatures, which is a little bit unsatisfactory --- because this won't work for: --- instance Foo T where --- {-# INLINE op #-} --- Baz.op = ... --- We'll just rename the INLINE prag to refer to whatever other 'op' --- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.) --- Doesn't seem worth much trouble to sort this. - -renameSig lookup_occ_nm (Sig v ty src_loc) - = pushSrcLocRn src_loc $- lookup_occ_nm v thenRn \ new_v -> - rnHsSigType (quotes (ppr v)) ty thenRn \ (new_ty,fvs) -> - returnRn (Sig new_v new_ty src_loc, fvs addOneFV new_v) - -renameSig _ (SpecInstSig ty src_loc) - = pushSrcLocRn src_loc$ - rnHsSigType (text "A SPECIALISE instance pragma") ty thenRn \ (new_ty, fvs) -> - returnRn (SpecInstSig new_ty src_loc, fvs) - -renameSig lookup_occ_nm (SpecSig v ty src_loc) - = pushSrcLocRn src_loc $- lookup_occ_nm v thenRn \ new_v -> - rnHsSigType (quotes (ppr v)) ty thenRn \ (new_ty,fvs) -> - returnRn (SpecSig new_v new_ty src_loc, fvs addOneFV new_v) - -renameSig lookup_occ_nm (InlineSig v src_loc) - = pushSrcLocRn src_loc$ - lookup_occ_nm v thenRn \ new_v -> - returnRn (InlineSig new_v src_loc, unitFV new_v) - -renameSig lookup_occ_nm (FixSig (FixitySig v fix src_loc)) - = pushSrcLocRn src_loc $- lookup_occ_nm v thenRn \ new_v -> - returnRn (FixSig (FixitySig new_v fix src_loc), unitFV new_v) - -renameSig lookup_occ_nm (NoInlineSig v src_loc) - = pushSrcLocRn src_loc$ - lookup_occ_nm v thenRn \ new_v -> - returnRn (NoInlineSig new_v src_loc, unitFV new_v) -\end{code} - -Checking for distinct signatures; oh, so boring - -\begin{code} -cmp_sig :: RenamedSig -> RenamedSig -> Ordering -cmp_sig (Sig n1 _ _) (Sig n2 _ _) = n1 compare n2 -cmp_sig (InlineSig n1 _) (InlineSig n2 _) = n1 compare n2 -cmp_sig (NoInlineSig n1 _) (NoInlineSig n2 _) = n1 compare n2 -cmp_sig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = cmpHsType compare ty1 ty2 -cmp_sig (SpecSig n1 ty1 _) (SpecSig n2 ty2 _) - = -- may have many specialisations for one value; - -- but not ones that are exactly the same... - thenCmp (n1 compare n2) (cmpHsType compare ty1 ty2) - -cmp_sig other_1 other_2 -- Tags *must* be different - | (sig_tag other_1) _LT_ (sig_tag other_2) = LT - | otherwise = GT - -sig_tag (Sig n1 _ _) = (ILIT(1) :: FAST_INT) -sig_tag (SpecSig n1 _ _) = ILIT(2) -sig_tag (InlineSig n1 _) = ILIT(3) -sig_tag (NoInlineSig n1 _) = ILIT(4) -sig_tag (SpecInstSig _ _) = ILIT(5) -sig_tag (FixSig _) = ILIT(6) -sig_tag _ = panic# "tag(RnBinds)" -\end{code} - -%************************************************************************ -%* * -\subsection{Error messages} -%* * -%************************************************************************ - -\begin{code} -dupSigDeclErr (sig:sigs) - = pushSrcLocRn loc $- addErrRn (sep [ptext SLIT("Duplicate") <+> ptext what_it_is <> colon, - ppr sig]) - where - (what_it_is, loc) = sig_doc sig - -unknownSigErr sig - = pushSrcLocRn loc$ - addErrRn (sep [ptext SLIT("Misplaced"), - ptext what_it_is <> colon, - ppr sig]) - where - (what_it_is, loc) = sig_doc sig - -sig_doc (Sig _ _ loc) = (SLIT("type signature"),loc) -sig_doc (ClassOpSig _ _ _ loc) = (SLIT("class-method type signature"), loc) -sig_doc (SpecSig _ _ loc) = (SLIT("SPECIALISE pragma"),loc) -sig_doc (InlineSig _ loc) = (SLIT("INLINE pragma"),loc) -sig_doc (NoInlineSig _ loc) = (SLIT("NOINLINE pragma"),loc) -sig_doc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc) -sig_doc (FixSig (FixitySig _ _ loc)) = (SLIT("fixity declaration"), loc) - -missingSigWarn var - = sep [ptext SLIT("definition but no type signature for"), quotes (ppr var)] - -methodBindErr mbind - = hang (ptext SLIT("Can't handle multiple methods defined by one pattern binding")) - 4 (ppr mbind) -\end{code} +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[RnBinds]{Renaming and dependency analysis of bindings} + +This module does renaming and dependency analysis on value bindings in +the abstract syntax. It does {\em not} do cycle-checks on class or +type-synonym declarations; those cannot be done at this stage because +they may be affected by renaming (which isn't fully worked out yet). + +\begin{code} +module RnBinds ( + rnTopBinds, rnTopMonoBinds, + rnMethodBinds, renameSigs, + rnBinds, + unknownSigErr + ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} RnSource ( rnHsSigType ) + +import HsSyn +import HsBinds ( sigsForMe ) +import RdrHsSyn +import RnHsSyn +import RnMonad +import RnExpr ( rnMatch, rnGRHSs, rnPat, checkPrecMatch ) +import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupGlobalOccRn, + warnUnusedLocalBinds, mapFvRn, + FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV, + unknownNameErr + ) +import CmdLineOpts ( opt_WarnMissingSigs ) +import Digraph ( stronglyConnComp, SCC(..) ) +import Name ( OccName, Name, nameOccName ) +import NameSet +import RdrName ( RdrName, rdrNameOcc ) +import BasicTypes ( RecFlag(..), TopLevelFlag(..) ) +import Util ( thenCmp, removeDups ) +import List ( partition ) +import ListSetOps ( minusList ) +import Bag ( bagToList ) +import FiniteMap ( lookupFM, listToFM ) +import Maybe ( isJust ) +import Outputable +\end{code} + +-- ToDo: Put the annotations into the monad, so that they arrive in the proper +-- place and can be used when complaining. + +The code tree received by the function @rnBinds@ contains definitions +in where-clauses which are all apparently mutually recursive, but which may +not really depend upon each other. For example, in the top level program +\begin{verbatim} +f x = y where a = x + y = x +\end{verbatim} +the definitions of @a@ and @y@ do not depend on each other at all. +Unfortunately, the typechecker cannot always check such definitions. +\footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive +definitions. In Proceedings of the International Symposium on Programming, +Toulouse, pp. 217-39. LNCS 167. Springer Verlag.} +However, the typechecker usually can check definitions in which only the +strongly connected components have been collected into recursive bindings. +This is precisely what the function @rnBinds@ does. + +ToDo: deal with case where a single monobinds binds the same variable +twice. + +The vertag tag is a unique @Int@; the tags only need to be unique +within one @MonoBinds@, so that unique-Int plumbing is done explicitly +(heavy monad machinery not needed). + +\begin{code} +type VertexTag = Int +type Cycle = [VertexTag] +type Edge = (VertexTag, VertexTag) +\end{code} + +%************************************************************************ +%* * +%* naming conventions * +%* * +%************************************************************************ + +\subsection[name-conventions]{Name conventions} + +The basic algorithm involves walking over the tree and returning a tuple +containing the new tree plus its free variables. Some functions, such +as those walking polymorphic bindings (HsBinds) and qualifier lists in +list comprehensions (@Quals@), return the variables bound in local +environments. These are then used to calculate the free variables of the +expression evaluated in these environments. + +Conventions for variable names are as follows: +\begin{itemize} +\item +new code is given a prime to distinguish it from the old. + +\item +a set of variables defined in @Exp@ is written @dvExp@ + +\item +a set of variables free in @Exp@ is written @fvExp@ +\end{itemize} + +%************************************************************************ +%* * +%* analysing polymorphic bindings (HsBinds, Bind, MonoBinds) * +%* * +%************************************************************************ + +\subsubsection[dep-HsBinds]{Polymorphic bindings} + +Non-recursive expressions are reconstructed without any changes at top +level, although their component expressions may have to be altered. +However, non-recursive expressions are currently not expected as +\Haskell{} programs, and this code should not be executed. + +Monomorphic bindings contain information that is returned in a tuple +(a @FlatMonoBindsInfo@) containing: + +\begin{enumerate} +\item +a unique @Int@ that serves as the vertex tag'' for this binding. + +\item +the name of a function or the names in a pattern. These are a set +referred to as @dvLhs@, the defined variables of the left hand side. + +\item +the free variables of the body. These are referred to as @fvBody@. + +\item +the definition's actual code. This is referred to as just @code@. +\end{enumerate} + +The function @nonRecDvFv@ returns two sets of variables. The first is +the set of variables defined in the set of monomorphic bindings, while the +second is the set of free variables in those bindings. + +The set of variables defined in a non-recursive binding is just the +union of all of them, as @union@ removes duplicates. However, the +free variables in each successive set of cumulative bindings is the +union of those in the previous set plus those of the newest binding after +the defined variables of the previous set have been removed. + +@rnMethodBinds@ deals only with the declarations in class and +instance declarations. It expects only to see @FunMonoBind@s, and +it expects the global environment to contain bindings for the binders +(which are all class operations). + +%************************************************************************ +%* * +\subsubsection{ Top-level bindings} +%* * +%************************************************************************ + +@rnTopBinds@ assumes that the environment already +contains bindings for the binders of this particular binding. + +\begin{code} +rnTopBinds :: RdrNameHsBinds -> RnMS (RenamedHsBinds, FreeVars) + +rnTopBinds EmptyBinds = returnRn (EmptyBinds, emptyFVs) +rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs + -- The parser doesn't produce other forms + + +rnTopMonoBinds EmptyMonoBinds sigs + = returnRn (EmptyBinds, emptyFVs) + +rnTopMonoBinds mbinds sigs + = mapRn lookupBndrRn binder_rdr_names thenRn \ binder_names -> + let + binder_set = mkNameSet binder_names + binder_occ_fm = listToFM [(nameOccName x,x) | x <- binder_names] + in + renameSigs opt_WarnMissingSigs binder_set + (lookupSigOccRn binder_occ_fm) sigs thenRn \ (siglist, sig_fvs) -> + rn_mono_binds siglist mbinds thenRn \ (final_binds, bind_fvs) -> + returnRn (final_binds, bind_fvs plusFV sig_fvs) + where + binder_rdr_names = map fst (bagToList (collectMonoBinders mbinds)) + +-- the names appearing in the sigs have to be bound by +-- this group's binders. +lookupSigOccRn binder_occ_fm rdr_name + = case lookupFM binder_occ_fm (rdrNameOcc rdr_name) of + Nothing -> failWithRn (mkUnboundName rdr_name) + (unknownNameErr rdr_name) + Just x -> returnRn x +\end{code} + +%************************************************************************ +%* * +%* Nested binds +%* * +%************************************************************************ + +\subsubsection{Nested binds} + +@rnMonoBinds@ +\begin{itemize} +\item collects up the binders for this declaration group, +\item checks that they form a set +\item extends the environment to bind them to new local names +\item calls @rnMonoBinds@ to do the real work +\end{itemize} +% +\begin{code} +rnBinds :: RdrNameHsBinds + -> (RenamedHsBinds -> RnMS (result, FreeVars)) + -> RnMS (result, FreeVars) + +rnBinds EmptyBinds thing_inside = thing_inside EmptyBinds +rnBinds (MonoBind bind sigs _) thing_inside = rnMonoBinds bind sigs thing_inside + -- the parser doesn't produce other forms + + +rnMonoBinds :: RdrNameMonoBinds + -> [RdrNameSig] + -> (RenamedHsBinds -> RnMS (result, FreeVars)) + -> RnMS (result, FreeVars) + +rnMonoBinds EmptyMonoBinds sigs thing_inside = thing_inside EmptyBinds + +rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds + = -- Extract all the binders in this group, + -- and extend current scope, inventing new names for the new binders + -- This also checks that the names form a set + bindLocatedLocalsRn (text "a binding group") mbinders_w_srclocs + $\ new_mbinders -> + let + binder_set = mkNameSet new_mbinders + + -- Weed out the fixity declarations that do not + -- apply to any of the binders in this group. + (sigs_for_me, fixes_not_for_me) = partition forLocalBind sigs + + forLocalBind (FixSig sig@(FixitySig name _ _ )) = + isJust (lookupFM binder_occ_fm (rdrNameOcc name)) + forLocalBind _ = True + + binder_occ_fm = listToFM [(nameOccName x,x) | x <- new_mbinders] + + in + -- Report the fixity declarations in this group that + -- don't refer to any of the group's binders. + -- + mapRn_ (unknownSigErr) fixes_not_for_me thenRn_ + renameSigs False binder_set + (lookupSigOccRn binder_occ_fm) sigs_for_me thenRn \ (siglist, sig_fvs) -> + let + fixity_sigs = [(name,sig) | FixSig sig@(FixitySig name _ _) <- siglist ] + in + -- Install the fixity declarations that do apply here and go. + extendFixityEnv fixity_sigs ( + rn_mono_binds siglist mbinds + ) thenRn \ (binds, bind_fvs) -> + + -- Now do the "thing inside", and deal with the free-variable calculations + thing_inside binds thenRn \ (result,result_fvs) -> + let + all_fvs = result_fvs plusFV bind_fvs plusFV sig_fvs + unused_binders = nameSetToList (binder_set minusNameSet all_fvs) + in + warnUnusedLocalBinds unused_binders thenRn_ + returnRn (result, delListFromNameSet all_fvs new_mbinders) + where + mbinders_w_srclocs = bagToList (collectMonoBinders mbinds) +\end{code} + + +%************************************************************************ +%* * +\subsubsection{ MonoBinds -- the main work is done here} +%* * +%************************************************************************ + +@rn_mono_binds@ is used by {\em both} top-level and nested bindings. +It assumes that all variables bound in this group are already in scope. +This is done {\em either} by pass 3 (for the top-level bindings), +{\em or} by @rnMonoBinds@ (for the nested ones). + +\begin{code} +rn_mono_binds :: [RenamedSig] -- Signatures attached to this group + -> RdrNameMonoBinds + -> RnMS (RenamedHsBinds, -- + FreeVars) -- Free variables + +rn_mono_binds siglist mbinds + = + -- Rename the bindings, returning a MonoBindsInfo + -- which is a list of indivisible vertices so far as + -- the strongly-connected-components (SCC) analysis is concerned + flattenMonoBinds siglist mbinds thenRn \ mbinds_info -> + + -- Do the SCC analysis + let + edges = mkEdges (mbinds_info zip [(0::Int)..]) + scc_result = stronglyConnComp edges + final_binds = foldr1 ThenBinds (map reconstructCycle scc_result) + + -- Deal with bound and free-var calculation + rhs_fvs = plusFVs [fvs | (_,fvs,_,_) <- mbinds_info] + in + returnRn (final_binds, rhs_fvs) +\end{code} + +@flattenMonoBinds@ is ever-so-slightly magical in that it sticks +unique vertex tags'' on its output; minor plumbing required. + +Sigh --- need to pass along the signatures for the group of bindings, +in case any of them \fbox{\ ???\ } + +\begin{code} +flattenMonoBinds :: [RenamedSig] -- Signatures + -> RdrNameMonoBinds + -> RnMS [FlatMonoBindsInfo] + +flattenMonoBinds sigs EmptyMonoBinds = returnRn [] + +flattenMonoBinds sigs (AndMonoBinds bs1 bs2) + = flattenMonoBinds sigs bs1 thenRn \ flat1 -> + flattenMonoBinds sigs bs2 thenRn \ flat2 -> + returnRn (flat1 ++ flat2) + +flattenMonoBinds sigs (PatMonoBind pat grhss locn) + = pushSrcLocRn locn$ + rnPat pat thenRn \ (pat', pat_fvs) -> + + -- Find which things are bound in this group + let + names_bound_here = mkNameSet (collectPatBinders pat') + sigs_for_me = sigsForMe (elemNameSet names_bound_here) sigs + in + rnGRHSs grhss thenRn \ (grhss', fvs) -> + returnRn + [(names_bound_here, + fvs plusFV pat_fvs, + PatMonoBind pat' grhss' locn, + sigs_for_me + )] + +flattenMonoBinds sigs (FunMonoBind name inf matches locn) + = pushSrcLocRn locn $+ lookupBndrRn name thenRn \ new_name -> + let + sigs_for_me = sigsForMe (new_name ==) sigs + in + mapFvRn rnMatch matches thenRn \ (new_matches, fvs) -> + mapRn_ (checkPrecMatch inf new_name) new_matches thenRn_ + returnRn + [(unitNameSet new_name, + fvs, + FunMonoBind new_name inf new_matches locn, + sigs_for_me + )] +\end{code} + + +@rnMethodBinds@ is used for the method bindings of a class and an instance +declaration. Like @rnMonoBinds@ but without dependency analysis. + +NOTA BENE: we record each {\em binder} of a method-bind group as a free variable. +That's crucial when dealing with an instance decl: +\begin{verbatim} + instance Foo (T a) where + op x = ... +\end{verbatim} +This might be the {\em sole} occurrence of @op@ for an imported class @Foo@, +and unless @op@ occurs we won't treat the type signature of @op@ in the class +decl for @Foo@ as a source of instance-decl gates. But we should! Indeed, +in many ways the @op@ in an instance decl is just like an occurrence, not +a binder. + +\begin{code} +rnMethodBinds :: RdrNameMonoBinds -> RnMS (RenamedMonoBinds, FreeVars) + +rnMethodBinds EmptyMonoBinds = returnRn (EmptyMonoBinds, emptyFVs) + +rnMethodBinds (AndMonoBinds mb1 mb2) + = rnMethodBinds mb1 thenRn \ (mb1', fvs1) -> + rnMethodBinds mb2 thenRn \ (mb2', fvs2) -> + returnRn (mb1' AndMonoBinds mb2', fvs1 plusFV fvs2) + +rnMethodBinds (FunMonoBind name inf matches locn) + = pushSrcLocRn locn$ + + lookupGlobalOccRn name thenRn \ sel_name -> + -- We use the selector name as the binder + + mapFvRn rnMatch matches thenRn \ (new_matches, fvs) -> + mapRn_ (checkPrecMatch inf sel_name) new_matches thenRn_ + returnRn (FunMonoBind sel_name inf new_matches locn, fvs addOneFV sel_name) + +rnMethodBinds (PatMonoBind (VarPatIn name) grhss locn) + = pushSrcLocRn locn $+ lookupGlobalOccRn name thenRn \ sel_name -> + rnGRHSs grhss thenRn \ (grhss', fvs) -> + returnRn (PatMonoBind (VarPatIn sel_name) grhss' locn, fvs addOneFV sel_name) + +-- Can't handle method pattern-bindings which bind multiple methods. +rnMethodBinds mbind@(PatMonoBind other_pat _ locn) + = pushSrcLocRn locn$ + failWithRn (EmptyMonoBinds, emptyFVs) (methodBindErr mbind) +\end{code} + + +%************************************************************************ +%* * +\subsection[reconstruct-deps]{Reconstructing dependencies} +%* * +%************************************************************************ + +This @MonoBinds@- and @ClassDecls@-specific code is segregated here, +as the two cases are similar. + +\begin{code} +reconstructCycle :: SCC FlatMonoBindsInfo + -> RenamedHsBinds + +reconstructCycle (AcyclicSCC (_, _, binds, sigs)) + = MonoBind binds sigs NonRecursive + +reconstructCycle (CyclicSCC cycle) + = MonoBind this_gp_binds this_gp_sigs Recursive + where + this_gp_binds = foldr1 AndMonoBinds [binds | (_, _, binds, _) <- cycle] + this_gp_sigs = foldr1 (++) [sigs | (_, _, _, sigs) <- cycle] +\end{code} + +%************************************************************************ +%* * +\subsubsection{ Manipulating FlatMonoBindInfo} +%* * +%************************************************************************ + +During analysis a @MonoBinds@ is flattened to a @FlatMonoBindsInfo@. +The @RenamedMonoBinds@ is always an empty bind, a pattern binding or +a function binding, and has itself been dependency-analysed and +renamed. + +\begin{code} +type FlatMonoBindsInfo + = (NameSet, -- Set of names defined in this vertex + NameSet, -- Set of names used in this vertex + RenamedMonoBinds, + [RenamedSig]) -- Signatures, if any, for this vertex + +mkEdges :: [(FlatMonoBindsInfo, VertexTag)] -> [(FlatMonoBindsInfo, VertexTag, [VertexTag])] + +mkEdges flat_info + = [ (info, tag, dest_vertices (nameSetToList names_used)) + | (info@(names_defined, names_used, mbind, sigs), tag) <- flat_info + ] + where + -- An edge (v,v') indicates that v depends on v' + dest_vertices src_mentions = [ target_vertex + | ((names_defined, _, _, _), target_vertex) <- flat_info, + mentioned_name <- src_mentions, + mentioned_name elemNameSet names_defined + ] +\end{code} + + +%************************************************************************ +%* * +\subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)} +%* * +%************************************************************************ + +@renameSigs@ checks for: +\begin{enumerate} +\item more than one sig for one thing; +\item signatures given for things not bound here; +\item with suitably flaggery, that all top-level things have type signatures. +\end{enumerate} +% +At the moment we don't gather free-var info from the types in +signatures. We'd only need this if we wanted to report unused tyvars. + +\begin{code} +renameSigs :: Bool -- True => warn if (required) type signatures are missing. + -> NameSet -- Set of names bound in this group + -> (RdrName -> RnMS Name) + -> [RdrNameSig] + -> RnMS ([RenamedSig], FreeVars) -- List of Sig constructors + +renameSigs sigs_required binders lookup_occ_nm sigs + = -- Rename the signatures + mapFvRn (renameSig lookup_occ_nm) sigs thenRn \ (sigs', fvs) -> + + -- Check for (a) duplicate signatures + -- (b) signatures for things not in this group + -- (c) optionally, bindings with no signature + let + (goodies, dups) = removeDups cmp_sig (sigsForMe (not . isUnboundName) sigs') + not_this_group = sigsForMe (not . (elemNameSet binders)) goodies + type_sig_vars = [n | Sig n _ _ <- goodies] + un_sigd_binders | sigs_required = nameSetToList binders minusList type_sig_vars + | otherwise = [] + in + mapRn_ dupSigDeclErr dups thenRn_ + mapRn_ unknownSigErr not_this_group thenRn_ + mapRn_ (addWarnRn.missingSigWarn) un_sigd_binders thenRn_ + returnRn (sigs', fvs) + -- bad ones and all: + -- we need bindings of *some* sort for every name + +-- We use lookupOccRn in the signatures, which is a little bit unsatisfactory +-- because this won't work for: +-- instance Foo T where +-- {-# INLINE op #-} +-- Baz.op = ... +-- We'll just rename the INLINE prag to refer to whatever other 'op' +-- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.) +-- Doesn't seem worth much trouble to sort this. + +renameSig lookup_occ_nm (Sig v ty src_loc) + = pushSrcLocRn src_loc $+ lookup_occ_nm v thenRn \ new_v -> + rnHsSigType (quotes (ppr v)) ty thenRn \ (new_ty,fvs) -> + returnRn (Sig new_v new_ty src_loc, fvs addOneFV new_v) + +renameSig _ (SpecInstSig ty src_loc) + = pushSrcLocRn src_loc$ + rnHsSigType (text "A SPECIALISE instance pragma") ty thenRn \ (new_ty, fvs) -> + returnRn (SpecInstSig new_ty src_loc, fvs) + +renameSig lookup_occ_nm (SpecSig v ty src_loc) + = pushSrcLocRn src_loc $+ lookup_occ_nm v thenRn \ new_v -> + rnHsSigType (quotes (ppr v)) ty thenRn \ (new_ty,fvs) -> + returnRn (SpecSig new_v new_ty src_loc, fvs addOneFV new_v) + +renameSig lookup_occ_nm (InlineSig v src_loc) + = pushSrcLocRn src_loc$ + lookup_occ_nm v thenRn \ new_v -> + returnRn (InlineSig new_v src_loc, unitFV new_v) + +renameSig lookup_occ_nm (FixSig (FixitySig v fix src_loc)) + = pushSrcLocRn src_loc $+ lookup_occ_nm v thenRn \ new_v -> + returnRn (FixSig (FixitySig new_v fix src_loc), unitFV new_v) + +renameSig lookup_occ_nm (NoInlineSig v src_loc) + = pushSrcLocRn src_loc$ + lookup_occ_nm v thenRn \ new_v -> + returnRn (NoInlineSig new_v src_loc, unitFV new_v) +\end{code} + +Checking for distinct signatures; oh, so boring + +\begin{code} +cmp_sig :: RenamedSig -> RenamedSig -> Ordering +cmp_sig (Sig n1 _ _) (Sig n2 _ _) = n1 compare n2 +cmp_sig (InlineSig n1 _) (InlineSig n2 _) = n1 compare n2 +cmp_sig (NoInlineSig n1 _) (NoInlineSig n2 _) = n1 compare n2 +cmp_sig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = cmpHsType compare ty1 ty2 +cmp_sig (SpecSig n1 ty1 _) (SpecSig n2 ty2 _) + = -- may have many specialisations for one value; + -- but not ones that are exactly the same... + thenCmp (n1 compare n2) (cmpHsType compare ty1 ty2) + +cmp_sig other_1 other_2 -- Tags *must* be different + | (sig_tag other_1) _LT_ (sig_tag other_2) = LT + | otherwise = GT + +sig_tag (Sig n1 _ _) = (ILIT(1) :: FAST_INT) +sig_tag (SpecSig n1 _ _) = ILIT(2) +sig_tag (InlineSig n1 _) = ILIT(3) +sig_tag (NoInlineSig n1 _) = ILIT(4) +sig_tag (SpecInstSig _ _) = ILIT(5) +sig_tag (FixSig _) = ILIT(6) +sig_tag _ = panic# "tag(RnBinds)" +\end{code} + +%************************************************************************ +%* * +\subsection{Error messages} +%* * +%************************************************************************ + +\begin{code} +dupSigDeclErr (sig:sigs) + = pushSrcLocRn loc $+ addErrRn (sep [ptext SLIT("Duplicate") <+> ptext what_it_is <> colon, + ppr sig]) + where + (what_it_is, loc) = sig_doc sig + +unknownSigErr sig + = pushSrcLocRn loc$ + addErrRn (sep [ptext SLIT("Misplaced"), + ptext what_it_is <> colon, + ppr sig]) + where + (what_it_is, loc) = sig_doc sig + +sig_doc (Sig _ _ loc) = (SLIT("type signature"),loc) +sig_doc (ClassOpSig _ _ _ loc) = (SLIT("class-method type signature"), loc) +sig_doc (SpecSig _ _ loc) = (SLIT("SPECIALISE pragma"),loc) +sig_doc (InlineSig _ loc) = (SLIT("INLINE pragma"),loc) +sig_doc (NoInlineSig _ loc) = (SLIT("NOINLINE pragma"),loc) +sig_doc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc) +sig_doc (FixSig (FixitySig _ _ loc)) = (SLIT("fixity declaration"), loc) + +missingSigWarn var + = sep [ptext SLIT("definition but no type signature for"), quotes (ppr var)] + +methodBindErr mbind + = hang (ptext SLIT("Can't handle multiple methods defined by one pattern binding")) + 4 (ppr mbind) +\end{code} diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index b2491188b977f094dfa87506f784f7eaac124d24..430a3677c50526327d3bda776e294944995caf12 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -149,11 +149,12 @@ newLocalTopBinder mod occ rec_exp_fn loc %********************************************************* %* * -\subsection{Dfuns and default methods +\subsection{Dfuns and default methods} %* * %********************************************************* -@newImplicitBinder@ is used for (a) dfuns (b) default methods, defined in this module +@newImplicitBinder@ is used for (a) dfuns +(b) default methods, defined in this module. \begin{code} newImplicitBinder occ src_loc @@ -193,7 +194,7 @@ get_tycon_key (MonoFunTy _ _) = getOccName funTyCon \begin{code} ------------------------------------- -bindLocatedLocalsRn :: SDoc -- Documentation string for error message +bindLocatedLocalsRn :: SDoc -- Documentation string for error message -> [(RdrName,SrcLoc)] -> ([Name] -> RnMS a) -> RnMS a @@ -258,7 +259,7 @@ bindCoreLocalFVRn rdr_name enclosed_scope let new_name_env = extendRdrEnv name_env rdr_name name in - setLocalNameEnv new_name_env (enclosed_scope name) thenRn \ (result, fvs) -> + setLocalNameEnv new_name_env (enclosed_scope name) thenRn \ (result, fvs) -> returnRn (result, delFromNameSet fvs name) bindCoreLocalsFVRn [] thing_inside = thing_inside [] @@ -379,15 +380,15 @@ lookupBndrRn rdr_name InterfaceMode -> -- Look in the global name cache mkImportedGlobalFromRdrName rdr_name - SourceMode -> -- Source mode, so look up a *qualified* version - -- of the name, so that we get the right one even - -- if there are many with the same occ name - -- There must *be* a binding - getModuleRn thenRn \ mod -> - case lookupRdrEnv global_env (qualifyRdrName mod rdr_name) of - Just (name:rest) -> ASSERT( null rest ) - returnRn name - Nothing -> pprPanic "lookupBndrRn" (ppr mod <+> ppr rdr_name) + SourceMode -> -- Source mode, so look up a *qualified* version + -- of the name, so that we get the right one even + -- if there are many with the same occ name + -- There must *be* a binding + getModuleRn thenRn \ mod -> + case lookupRdrEnv global_env (qualifyRdrName mod rdr_name) of + Just (name:rest) -> ASSERT( null rest ) + returnRn name + Nothing -> pprPanic "lookupBndrRn" (ppr mod <+> ppr rdr_name) } -- Just like lookupRn except that we record the occurrence too @@ -396,7 +397,7 @@ lookupBndrRn rdr_name -- deciding which instance declarations to import. lookupOccRn :: RdrName -> RnMS Name lookupOccRn rdr_name - = getNameEnvs thenRn \ (global_env, local_env) -> + = getNameEnvs thenRn \ (global_env, local_env) -> lookup_occ global_env local_env rdr_name -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global @@ -405,7 +406,7 @@ lookupOccRn rdr_name -- class op names in class and instance decls lookupGlobalOccRn :: RdrName -> RnMS Name lookupGlobalOccRn rdr_name - = getNameEnvs thenRn \ (global_env, local_env) -> + = getNameEnvs thenRn \ (global_env, local_env) -> lookup_global_occ global_env rdr_name -- Look in both local and global env @@ -429,32 +430,35 @@ lookup_global_occ global_env rdr_name -- Not found when processing an imported declaration, -- so we create a new name for the purpose InterfaceMode -> mkImportedGlobalFromRdrName rdr_name +\end{code} +% +@lookupImplicitOccRn@ takes an RdrName representing an {\em original} name, +and adds it to the occurrence pool so that it'll be loaded later. +This is used when language constructs +(such as monad comprehensions, overloaded literals, or deriving clauses) +require some stuff to be loaded that isn't explicitly mentioned in the code. + +This doesn't apply in interface mode, where everything is explicit, +but we don't check for this case: +it does no harm to record an extra'' occurrence +and @lookupImplicitOccRn@ isn't used much in interface mode +(it's only the @Nothing@ clause of @rnDerivs@ that calls it at all I think). + + \fbox{{\em Jan 98: this comment is wrong: @rnHsType@ uses it quite a bit.}} - --- lookupImplicitOccRn takes an RdrName representing an *original* name, and --- adds it to the occurrence pool so that it'll be loaded later. This is --- used when language constructs (such as monad comprehensions, overloaded literals, --- or deriving clauses) require some stuff to be loaded that isn't explicitly --- mentioned in the code. --- --- This doesn't apply in interface mode, where everything is explicit, but --- we don't check for this case: it does no harm to record an "extra" occurrence --- and lookupImplicitOccRn isn't used much in interface mode (it's only the --- Nothing clause of rnDerivs that calls it at all I think). --- [Jan 98: this comment is wrong: rnHsType uses it quite a bit.] --- --- For List and Tuple types it's important to get the correct --- isLocallyDefined flag, which is used in turn when deciding --- whether there are any instance decls in this module are "special". --- The name cache should have the correct provenance, though. +For List and Tuple types it's important to get the correct +@isLocallyDefined@ flag, which is used in turn when deciding +whether there are any instance decls in this module are special''. +The name cache should have the correct provenance, though. +\begin{code} lookupImplicitOccRn :: RdrName -> RnMS Name lookupImplicitOccRn rdr_name = mkImportedGlobalFromRdrName rdr_name \end{code} -unQualInScope returns a function that takes a Name and tells whether +@unQualInScope@ returns a function that takes a @Name@ and tells whether its unqualified name is in scope. This is put as a boolean flag in -the Name's provenance to guide whether or not to print the name qualified +the @Name@'s provenance to guide whether or not to print the name qualified in error messages. \begin{code} @@ -473,7 +477,8 @@ unQualInScope env %* * %************************************************************************ -=============== NameEnv ================ +\subsubsection{NameEnv}% ================ + \begin{code} plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv plusGlobalRdrEnv env1 env2 = plusFM_C combine_globals env1 env2 @@ -510,22 +515,23 @@ better_provenance n1 n2 is_duplicate :: Name -> Name -> Bool is_duplicate n1 n2 | isLocallyDefined n1 && isLocallyDefined n2 = False | otherwise = n1 == n2 - -- We treat two bindings of a locally-defined name as a duplicate, - -- because they might be two separate, local defns and we want to report - -- and error for that, *not* eliminate a duplicate. - - -- On the other hand, if you import the same name from two different - -- import statements, we *do* want to eliminate the duplicate, not report - -- an error. - -- - -- If a module imports itself then there might be a local defn and an imported - -- defn of the same name; in this case the names will compare as equal, but - -- will still have different provenances \end{code} +We treat two bindings of a locally-defined name as a duplicate, +because they might be two separate, local defns and we want to report +and error for that, {\em not} eliminate a duplicate. + +On the other hand, if you import the same name from two different +import statements, we {\em d}* want to eliminate the duplicate, not report +an error. + +If a module imports itself then there might be a local defn and an imported +defn of the same name; in this case the names will compare as equal, but +will still have different provenances. -=============== ExportAvails ================ +\subsubsection{ExportAvails}% ================ + \begin{code} mkEmptyExportAvails :: ModuleName -> ExportAvails mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyUFM) @@ -564,7 +570,8 @@ plusExportAvails (m1, e1) (m2, e2) \end{code} -=============== AvailInfo ================ +\subsubsection{AvailInfo}% ================ + \begin{code} plusAvail (Avail n1) (Avail n2) = Avail n1 plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n1 (nub (ns1 ++ ns2)) @@ -682,8 +689,10 @@ mapFvRn f xs = mapRn f xs thenRn \ stuff -> warnUnusedLocalBinds, warnUnusedTopNames, warnUnusedMatches :: [Name] -> RnM d () warnUnusedTopNames names - | not opt_WarnUnusedBinds && not opt_WarnUnusedImports = returnRn () -- Don't force ns unless necessary - | otherwise = warnUnusedBinds (\ is_local -> not is_local) names + | not opt_WarnUnusedBinds && not opt_WarnUnusedImports + = returnRn () -- Don't force ns unless necessary + | otherwise + = warnUnusedBinds (\ is_local -> not is_local) names warnUnusedLocalBinds ns | not opt_WarnUnusedBinds = returnRn () @@ -706,7 +715,8 @@ warnUnusedBinds warn_when_local names cmp_prov (LocalDef _ _) (NonLocalDef _ _) = LT cmp_prov (LocalDef loc1 _) (LocalDef loc2 _) = loc1 compare loc2 cmp_prov (NonLocalDef (UserImport m1 loc1 _) _) - (NonLocalDef (UserImport m2 loc2 _) _) = (m1 compare m2) thenCmp (loc1 compare loc2) + (NonLocalDef (UserImport m2 loc2 _) _) = + (m1 compare m2) thenCmp (loc1 compare loc2) cmp_prov (NonLocalDef _ _) (LocalDef _ _) = GT -- In-scope NonLocalDefs must have UserImport info on them @@ -727,8 +737,9 @@ warnUnusedGroup emit_warning names (is_local, def_loc, msg) = case getNameProvenance name1 of LocalDef loc _ -> (True, loc, text "Defined but not used") - NonLocalDef (UserImport mod loc _) _ -> (True, loc, text "Imported from" <+> quotes (ppr mod) <+> - text "but not used") + NonLocalDef (UserImport mod loc _) _ -> + (True, loc, text "Imported from" <+> quotes (ppr mod) <+> + text "but not used") other -> (False, getSrcLoc name1, text "Strangely defined but not used") \end{code} diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 3e73732fabd4da6bbe084026e343914f3b1be1a0..34df4180050b623cdf4e228b99bfe8b11b325234 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -684,9 +684,10 @@ checkPrec op pat right \end{code} Consider +\begin{verbatim} a op1 b op2 c - -(compareFixity op1 op2) tells which way to arrange appication, or +\end{verbatim} +@(compareFixity op1 op2)@ tells which way to arrange appication, or whether there's an error. \begin{code} @@ -713,7 +714,8 @@ compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2) %* * %************************************************************************ -When literals occur we have to make sure that the types and classes they involve +When literals occur we have to make sure +that the types and classes they involve are made available. \begin{code} @@ -822,8 +824,9 @@ precParseErr op1 op2 ptext SLIT("in the same infix expression")]) nonStdGuardErr guard - = hang (ptext SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")) - 4 (ppr guard) + = hang (ptext + SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)") + ) 4 (ppr guard) patSigErr ty = hang (ptext SLIT("Illegal signature in pattern:") <+> ppr ty) diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index ff32230fef79889026e4d01ca2fc99113c531962..8298af0adc734db4016b754bdde003a76dc3fae7 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -108,17 +108,18 @@ loadInterface doc_str mod_name from mod_map_result -> -- READ THE MODULE IN - findAndReadIface doc_str mod_name from in_map thenRn \ (hi_boot_read, read_result) -> + findAndReadIface doc_str mod_name from in_map + thenRn \ (hi_boot_read, read_result) -> case read_result of { Nothing -> -- Not found, so add an empty export env to the Ifaces map -- so that we don't look again - let - mod = mkVanillaModule mod_name - new_mod_map = addToFM mod_map mod_name (0, False, Just (mod, False, [])) - new_ifaces = ifaces { iImpModInfo = new_mod_map } - in - setIfacesRn new_ifaces thenRn_ - failWithRn (mod, new_ifaces) (noIfaceErr mod hi_boot_read) ; + let + mod = mkVanillaModule mod_name + new_mod_map = addToFM mod_map mod_name (0, False, Just (mod, False, [])) + new_ifaces = ifaces { iImpModInfo = new_mod_map } + in + setIfacesRn new_ifaces thenRn_ + failWithRn (mod, new_ifaces) (noIfaceErr mod hi_boot_read) ; -- Found and parsed! Just (mod, iface) -> @@ -169,7 +170,7 @@ addModDeps mod mod_deps new_deps is_lib = isLibModule mod -- Don't record dependencies when importing a library module add (imp_mod, version, has_orphans, _) deps | is_lib && not has_orphans = deps - | otherwise = addToFM_C combine deps imp_mod (version, has_orphans, Nothing) + | otherwise = addToFM_C combine deps imp_mod (version, has_orphans, Nothing) -- Record dependencies for modules that are -- either are dependent via a non-library module -- or contain orphan rules or instance decls @@ -273,8 +274,9 @@ loadDecl mod decls_map (version, decl) dates from a time where we picked up a .hi file first if it existed?] -} decl' = case decl of - SigD (IfaceSig name tp ls loc) | opt_IgnoreIfacePragmas -> SigD (IfaceSig name tp [] loc) - other -> decl + SigD (IfaceSig name tp ls loc) | opt_IgnoreIfacePragmas + -> SigD (IfaceSig name tp [] loc) + other -> decl loadInstDecl :: Module -> Bag GatedDecl @@ -363,18 +365,18 @@ checkModUsage ((mod_name, old_mod_vers, _, whats_imported) : rest) Nothing -> -- If we can't find a version number for the old module then -- bail out saying things aren't up to date traceRn (sep [ptext SLIT("Can't find version number for module"), - pprModuleName mod_name]) thenRn_ - returnRn False ; + pprModuleName mod_name]) + thenRn_ returnRn False ; Just new_mod_vers -> -- If the module version hasn't changed, just move on if new_mod_vers == old_mod_vers then - traceRn (sep [ptext SLIT("Module version unchanged:"), pprModuleName mod_name]) thenRn_ - checkModUsage rest + traceRn (sep [ptext SLIT("Module version unchanged:"), pprModuleName mod_name]) + thenRn_ checkModUsage rest else - traceRn (sep [ptext SLIT("Module version has changed:"), pprModuleName mod_name]) thenRn_ - + traceRn (sep [ptext SLIT("Module version has changed:"), pprModuleName mod_name]) + thenRn_ -- Module version changed, so check entities inside -- If the usage info wants to say "I imported everything from this module" @@ -406,8 +408,8 @@ checkEntityUsage mod decls ((occ_name,old_vers) : rest) case lookupNameEnv decls name of Nothing -> -- We used it before, but it ain't there now - putDocRn (sep [ptext SLIT("No longer exported:"), ppr name]) thenRn_ - returnRn False + putDocRn (sep [ptext SLIT("No longer exported:"), ppr name]) + thenRn_ returnRn False Just (new_vers,_,_,_) -- It's there, but is it up to date? | new_vers == old_vers @@ -475,20 +477,20 @@ getNonWiredInDecl needed_name @getWiredInDecl@ maps a wired-in @Name@ to what it makes available. It behaves exactly as if the wired in decl were actually in an interface file. Specifically, - - * if the wired-in name is a data type constructor or a data constructor, +\begin{itemize} +\item if the wired-in name is a data type constructor or a data constructor, it brings in the type constructor and all the data constructors; and - marks as "occurrences" any free vars of the data con. + marks as occurrences'' any free vars of the data con. - * similarly for synonum type constructor +\item similarly for synonum type constructor - * if the wired-in name is another wired-in Id, it marks as "occurrences" +\item if the wired-in name is another wired-in Id, it marks as occurrences'' the free vars of the Id's type. - * it loads the interface file for the wired-in thing for the +\item it loads the interface file for the wired-in thing for the sole purpose of making sure that its instance declarations are available - -All this is necessary so that we know all types that are "in play", so +\end{itemize} +All this is necessary so that we know all types that are in play'', so that we know just what instances to bring into scope. @@ -500,18 +502,18 @@ that we know just what instances to bring into scope. %* * %********************************************************* -@getInterfaceExports@ is called only for directly-imported modules +@getInterfaceExports@ is called only for directly-imported modules. \begin{code} getInterfaceExports :: ModuleName -> WhereFrom -> RnMG (Module, Avails) getInterfaceExports mod_name from = loadInterface doc_str mod_name from thenRn \ (mod, ifaces) -> case lookupFM (iImpModInfo ifaces) mod_name of - Nothing -> -- Not there; it must be that the interface file wasn't found; - -- the error will have been reported already. - -- (Actually loadInterface should put the empty export env in there - -- anyway, but this does no harm.) - returnRn (mod, []) + Nothing -> -- Not there; it must be that the interface file wasn't found; + -- the error will have been reported already. + -- (Actually loadInterface should put the empty export env in there + -- anyway, but this does no harm.) + returnRn (mod, []) Just (_, _, Just (mod, _, avails)) -> returnRn (mod, avails) where @@ -532,10 +534,11 @@ getImportedInstDecls gates -- Orphan-instance modules are recorded in the module dependecnies getIfacesRn thenRn \ ifaces -> let - orphan_mods = [mod | (mod, (_, True, Nothing)) <- fmToList (iImpModInfo ifaces)] + orphan_mods = + [mod | (mod, (_, True, Nothing)) <- fmToList (iImpModInfo ifaces)] in - traceRn (text "Loading orphan modules" <+> fsep (map pprModuleName orphan_mods)) thenRn_ - mapRn_ load_it orphan_mods thenRn_ + traceRn (text "Loading orphan modules" <+> fsep (map pprModuleName orphan_mods)) + thenRn_ mapRn_ load_it orphan_mods thenRn_ -- Now we're ready to grab the instance declarations -- Find the un-gated ones and return them, @@ -548,7 +551,8 @@ getImportedInstDecls gates traceRn (sep [text "getImportedInstDecls:", nest 4 (fsep (map ppr (nameSetToList gates))), - text "Slurped" <+> int (length decls) <+> text "instance declarations"]) thenRn_ + text "Slurped" <+> int (length decls) + <+> text "instance declarations"]) thenRn_ returnRn decls where load_it mod = loadInterface (doc_str mod) mod ImportBySystem @@ -603,42 +607,50 @@ lookupFixity name %* * %********************************************************* -getImportVersions figures out what the "usage information" for this moudule is; +getImportVersions figures out +what the usage information'' for this moudule is; that is, what it must record in its interface file as the things it uses. It records: - - anything reachable from its body code - - any module exported with a "module Foo". - -Why the latter? Because if Foo changes then this module's export list +\begin{itemize} +\item anything reachable from its body code +\item any module exported with a @module Foo@. +\end{itemize} +% +Why the latter? Because if @Foo@ changes then this module's export list will change, so we must recompile this module at least as far as making a new interface file --- but in practice that means complete recompilation. What about this? - module A( f, g ) where module B( f ) where - import B( f ) f = h 3 - g = ... h = ... - -Should we record B.f in A's usages? In fact we don't. Certainly, if -anything about B.f changes than anyone who imports A should be recompiled; -they'll get an early exit if they don't use B.f. However, even if B.f -doesn't change at all, B.h may do so, and this change may not be reflected -in f's version number. So there are two things going on when compiling module A: - -1. Are A.o and A.hi correct? Then we can bale out early. -2. Should modules that import A be recompiled? - -For (1) it is slightly harmful to record B.f in A's usages, because a change in -B.f's version will provoke full recompilation of A, producing an identical A.o, -and A.hi differing only in its usage-version of B.f (which isn't used by any importer). - -For (2), because of the tricky B.h question above, we ensure that A.hi is touched -(even if identical to its previous version) if A's recompilation was triggered by -an imported .hi file date change. Given that, there's no need to record B.f in -A's usages. - -On the other hand, if A exports "module B" then we *do* count module B among -A's usages, because we must recompile A to ensure that A.hi changes appropriately. +\begin{verbatim} + module A( f, g ) where | module B( f ) where + import B( f ) | f = h 3 + g = ... | h = ... +\end{verbatim} +Should we record @B.f@ in @A@'s usages? In fact we don't. Certainly, if +anything about @B.f@ changes than anyone who imports @A@ should be recompiled; +they'll get an early exit if they don't use @B.f@. However, even if @B.f@ +doesn't change at all, @B.h@ may do so, and this change may not be reflected +in @f@'s version number. So there are two things going on when compiling module @A@: +\begin{enumerate} +\item Are @A.o@ and @A.hi@ correct? Then we can bale out early. +\item Should modules that import @A@ be recompiled? +\end{enumerate} +For (1) it is slightly harmful to record @B.f@ in @A@'s usages, +because a change in @B.f@'s version will provoke full recompilation of @A@, +producing an identical @A.o@, +and @A.hi@ differing only in its usage-version of @B.f@ +(which isn't used by any importer). + +For (2), because of the tricky @B.h@ question above, +we ensure that @A.hi@ is touched +(even if identical to its previous version) +if A's recompilation was triggered by an imported @.hi@ file date change. +Given that, there's no need to record @B.f@ in @A@'s usages. + +On the other hand, if @A@ exports @module B@, +then we {\em do} count @module B@ among @A@'s usages, +because we must recompile @A@ to ensure that @A.hi@ changes appropriately. \begin{code} getImportVersions :: ModuleName -- Name of this module @@ -722,8 +734,8 @@ recordSlurp maybe_version avail It's used for both source code (from @availsFromDecl@) and interface files (from @loadDecl@). -It doesn't deal with source-code specific things: ValD, DefD. They -are handled by the sourc-code specific stuff in RnNames. +It doesn't deal with source-code specific things: @ValD@, @DefD@. They +are handled by the sourc-code specific stuff in @RnNames@. \begin{code} getDeclBinders :: (RdrName -> SrcLoc -> RnM d Name) -- New-name function @@ -788,8 +800,8 @@ getClassOpNames new_name (ClassOpSig op _ _ src_loc) = new_name op src_loc @getDeclSysBinders@ gets the implicit binders introduced by a decl. A the moment that's just the tycon and datacon that come with a class decl. -They aren'te returned by getDeclBinders because they aren't in scope; -but they *should* be put into the DeclsMap of this module. +They aren't returned by @getDeclBinders@ because they aren't in scope; +but they {\em should} be put into the @DeclsMap@ of this module. Note that this excludes the default-method names of a class decl, and the dict fun of an instance decl, because both of these have @@ -833,7 +845,8 @@ findAndReadIface doc_str mod_name from hi_file case find_path from hi_maps of -- Found the file - (hi_boot, Just (fpath, mod)) -> traceRn (ptext SLIT("...reading from") <+> text fpath) thenRn_ + (hi_boot, Just (fpath, mod)) -> traceRn (ptext SLIT("...reading from") <+> text fpath) + thenRn_ readIface mod fpath thenRn \ result -> returnRn (hi_boot, result) (hi_boot, Nothing) -> traceRn (ptext SLIT("...not found")) thenRn_ @@ -879,13 +892,13 @@ readIface the_mod file_path loc = mkSrcLoc (mkFastString file_path) 1 } of PFailed err -> failWithRn Nothing err POk _ (PIface mod_nm iface) -> - warnCheckRn (mod_nm == moduleName the_mod) - (hsep [ ptext SLIT("Something is amiss; requested module name") - , pprModule the_mod - , ptext SLIT("differs from name found in the interface file ") - , pprModuleName mod_nm - ]) thenRn_ - returnRn (Just (the_mod, iface)) + warnCheckRn (mod_nm == moduleName the_mod) + (hsep [ ptext SLIT("Something is amiss; requested module name") + , pprModule the_mod + , ptext SLIT("differs from name found in the interface file ") + , pprModuleName mod_nm + ]) + thenRn_ returnRn (Just (the_mod, iface)) Left err | isDoesNotExistError err -> returnRn Nothing @@ -920,12 +933,15 @@ getDeclWarn name loc ptext SLIT("desired at") <+> ppr loc] importDeclWarn mod name - = sep [ptext SLIT("Compiler tried to import decl from interface file with same name as module."), - ptext SLIT("(possible cause: module name clashes with interface file already in scope.)") + = sep [ptext SLIT( + "Compiler tried to import decl from interface file with same name as module."), + ptext SLIT( + "(possible cause: module name clashes with interface file already in scope.)") ]  hsep [ptext SLIT("Interface:"), quotes (pprModuleName mod), comma, ptext SLIT("name:"), quotes (ppr name)] warnRedundantSourceImport mod_name - = ptext SLIT("Unnecessary {- SOURCE -} in the import of module") <+> quotes (pprModuleName mod_name) + = ptext SLIT("Unnecessary {- SOURCE -} in the import of module") + <+> quotes (pprModuleName mod_name) \end{code} diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index b303525674d1199771a5308645817ad271a54d08..fae50f335f5ce9239bc0a34240c6fae946bdd982 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -1,700 +1,720 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[RnMonad]{The monad used by the renamer} - -\begin{code} -module RnMonad( - module RnMonad, - Module, - FiniteMap, - Bag, - Name, - RdrNameHsDecl, - RdrNameInstDecl, - Version, - NameSet, - OccName, - Fixity - ) where - -#include "HsVersions.h" - -import PrelIOBase ( fixIO ) -- Should be in GlaExts -import IOExts ( IORef, newIORef, readIORef, writeIORef, unsafePerformIO ) - -import HsSyn -import RdrHsSyn -import RnHsSyn ( RenamedFixitySig ) -import BasicTypes ( Version ) -import SrcLoc ( noSrcLoc ) -import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, - pprBagOfErrors, ErrMsg, WarnMsg, Message - ) -import Name ( Name, OccName, NamedThing(..), - isLocallyDefinedName, nameModule, nameOccName, - decode, mkLocalName - ) -import Module ( Module, ModuleName, ModuleHiMap, SearchPath, WhereFrom, - mkModuleHiMaps, moduleName - ) -import NameSet -import RdrName ( RdrName, dummyRdrVarName, rdrNameOcc ) -import CmdLineOpts ( opt_D_dump_rn_trace, opt_IgnoreIfacePragmas ) -import PrelInfo ( builtinNames ) -import TysWiredIn ( boolTyCon ) -import SrcLoc ( SrcLoc, mkGeneratedSrcLoc ) -import Unique ( Unique, getUnique, unboundKey ) -import UniqFM ( UniqFM ) -import FiniteMap ( FiniteMap, emptyFM, bagToFM, lookupFM, addToFM, addListToFM, - addListToFM_C, addToFM_C, eltsFM, fmToList - ) -import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag ) -import Maybes ( mapMaybe ) -import UniqSet -import UniqFM -import UniqSupply -import Util -import Outputable - -infixr 9 thenRn, thenRn_ -\end{code} - - -%************************************************************************ -%* * -\subsection{Somewhat magical interface to other monads} -%* * -%************************************************************************ - -\begin{code} -ioToRnM :: IO r -> RnM d (Either IOError r) -ioToRnM io rn_down g_down = (io >>= \ ok -> return (Right ok)) - catch - (\ err -> return (Left err)) - -traceRn :: SDoc -> RnM d () -traceRn msg | opt_D_dump_rn_trace = putDocRn msg - | otherwise = returnRn () - -putDocRn :: SDoc -> RnM d () -putDocRn msg = ioToRnM (printErrs msg) thenRn_ - returnRn () -\end{code} - - -%************************************************************************ -%* * -\subsection{Data types} -%* * -%************************************************************************ - -=================================================== - MONAD TYPES -=================================================== - -\begin{code} -type RnM d r = RnDown -> d -> IO r -type RnMS r = RnM SDown r -- Renaming source -type RnMG r = RnM () r -- Getting global names etc - - -- Common part -data RnDown = RnDown { - rn_mod :: ModuleName, - rn_loc :: SrcLoc, - rn_ns :: IORef RnNameSupply, - rn_errs :: IORef (Bag WarnMsg, Bag ErrMsg), - rn_ifaces :: IORef Ifaces, - rn_hi_maps :: (ModuleHiMap, -- for .hi files - ModuleHiMap) -- for .hi-boot files - } - - -- For renaming source code -data SDown = SDown { - rn_mode :: RnMode, - - rn_genv :: GlobalRdrEnv, -- Global envt; the fixity component gets extended - -- with local fixity decls - - rn_lenv :: LocalRdrEnv, -- Local name envt - -- Does *not* includes global name envt; may shadow it - -- Includes both ordinary variables and type variables; - -- they are kept distinct because tyvar have a different - -- occurrence contructor (Name.TvOcc) - -- We still need the unsullied global name env so that - -- we can look up record field names - - rn_fixenv :: FixityEnv -- Local fixities - -- The global ones are held in the - -- rn_ifaces field - } - -data RnMode = SourceMode -- Renaming source code - | InterfaceMode -- Renaming interface declarations. -\end{code} - -=================================================== - ENVIRONMENTS -=================================================== - -\begin{code} --------------------------------- -type RdrNameEnv a = FiniteMap RdrName a -type GlobalRdrEnv = RdrNameEnv [Name] -- The list is because there may be name clashes - -- These only get reported on lookup, - -- not on construction -type LocalRdrEnv = RdrNameEnv Name - -emptyRdrEnv :: RdrNameEnv a -lookupRdrEnv :: RdrNameEnv a -> RdrName -> Maybe a -addListToRdrEnv :: RdrNameEnv a -> [(RdrName,a)] -> RdrNameEnv a -extendRdrEnv :: RdrNameEnv a -> RdrName -> a -> RdrNameEnv a - -emptyRdrEnv = emptyFM -lookupRdrEnv = lookupFM -addListToRdrEnv = addListToFM -rdrEnvElts = eltsFM -extendRdrEnv = addToFM -rdrEnvToList = fmToList - --------------------------------- -type NameEnv a = UniqFM a -- Domain is Name - -emptyNameEnv :: NameEnv a -nameEnvElts :: NameEnv a -> [a] -addToNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a -addToNameEnv :: NameEnv a -> Name -> a -> NameEnv a -plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a -extendNameEnv :: NameEnv a -> [(Name,a)] -> NameEnv a -lookupNameEnv :: NameEnv a -> Name -> Maybe a -delFromNameEnv :: NameEnv a -> Name -> NameEnv a -elemNameEnv :: Name -> NameEnv a -> Bool - -emptyNameEnv = emptyUFM -nameEnvElts = eltsUFM -addToNameEnv_C = addToUFM_C -addToNameEnv = addToUFM -plusNameEnv = plusUFM -extendNameEnv = addListToUFM -lookupNameEnv = lookupUFM -delFromNameEnv = delFromUFM -elemNameEnv = elemUFM - --------------------------------- -type FixityEnv = NameEnv RenamedFixitySig - -- We keep the whole fixity sig so that we - -- can report line-number info when there is a duplicate - -- fixity declaration -\end{code} - -\begin{code} --------------------------------- -type RnNameSupply - = ( UniqSupply - - , FiniteMap (OccName, OccName) Int - -- This is used as a name supply for dictionary functions - -- From the inst decl we derive a (class, tycon) pair; - -- this map then gives a unique int for each inst decl with that - -- (class, tycon) pair. (In Haskell 98 there can only be one, - -- but not so in more extended versions.) - -- - -- We could just use one Int for all the instance decls, but this - -- way the uniques change less when you add an instance decl, - -- hence less recompilation - - , FiniteMap (ModuleName, OccName) Name - -- Ensures that one (module,occname) pair gets one unique - ) - - --------------------------------- -data ExportEnv = ExportEnv Avails Fixities -type Avails = [AvailInfo] -type Fixities = [(Name, Fixity)] - -type ExportAvails = (FiniteMap ModuleName Avails, -- Used to figure out "module M" export specifiers - -- Includes avails only from *unqualified* imports - -- (see 1.4 Report Section 5.1.1) - - NameEnv AvailInfo) -- Used to figure out all other export specifiers. - -- Maps a Name to the AvailInfo that contains it - - -data GenAvailInfo name = Avail name -- An ordinary identifier - | AvailTC name -- The name of the type or class - [name] -- The available pieces of type/class. NB: If the type or - -- class is itself to be in scope, it must be in this list. - -- Thus, typically: AvailTC Eq [Eq, ==, /=] -type AvailInfo = GenAvailInfo Name -type RdrAvailInfo = GenAvailInfo OccName -\end{code} - -=================================================== - INTERFACE FILE STUFF -=================================================== - -\begin{code} -type ExportItem = (ModuleName, [RdrAvailInfo]) -type VersionInfo name = [ImportVersion name] - -type ImportVersion name = (ModuleName, Version, WhetherHasOrphans, WhatsImported name) - -type WhetherHasOrphans = Bool - -- An "orphan" is - -- * an instance decl in a module other than the defn module for - -- one of the tycons or classes in the instance head - -- * a transformation rule in a module other than the one defining - -- the function in the head of the rule. - -data WhatsImported name = Everything - | Specifically [LocalVersion name] -- List guaranteed non-empty - - -- ("M", hif, ver, Everything) means there was a "module M" in - -- this module's export list, so we just have to go by M's version, "ver", - -- not the list of LocalVersions. - - -type LocalVersion name = (name, Version) - -data ParsedIface - = ParsedIface { - pi_mod :: Version, -- Module version number - pi_orphan :: WhetherHasOrphans, -- Whether this module has orphans - pi_usages :: [ImportVersion OccName], -- Usages - pi_exports :: [ExportItem], -- Exports - pi_decls :: [(Version, RdrNameHsDecl)], -- Local definitions - pi_insts :: [RdrNameInstDecl], -- Local instance declarations - pi_rules :: [RdrNameRuleDecl] -- Rules - } - -type InterfaceDetails = (WhetherHasOrphans, - VersionInfo Name, -- Version information for what this module imports - ExportEnv) -- What modules this one depends on - - --- needed by Main to fish out the fixities assoc list. -getIfaceFixities :: InterfaceDetails -> Fixities -getIfaceFixities (_, _, ExportEnv _ fs) = fs - - -type RdrNamePragma = () -- Fudge for now -------------------- - -data Ifaces = Ifaces { - iImpModInfo :: ImportedModuleInfo, - -- Modules this one depends on: that is, the union - -- of the modules its direct imports depend on. - - iDecls :: DeclsMap, -- A single, global map of Names to decls - - iFixes :: FixityEnv, -- A single, global map of Names to fixities - - iSlurp :: NameSet, -- All the names (whether "big" or "small", whether wired-in or not, - -- whether locally defined or not) that have been slurped in so far. - - iVSlurp :: [(Name,Version)], -- All the (a) non-wired-in (b) "big" (c) non-locally-defined - -- names that have been slurped in so far, with their versions. - -- This is used to generate the "usage" information for this module. - -- Subset of the previous field. - - iInsts :: Bag GatedDecl, - -- The as-yet un-slurped instance decls; this bag is depleted when we - -- slurp an instance decl so that we don't slurp the same one twice. - -- Each is 'gated' by the names that must be available before - -- this instance decl is needed. - - iRules :: Bag GatedDecl - -- Ditto transformation rules - } - -type GatedDecl = (NameSet, (Module, RdrNameHsDecl)) - -type ImportedModuleInfo - = FiniteMap ModuleName (Version, Bool, Maybe (Module, Bool, Avails)) - -- Suppose the domain element is module 'A' - -- - -- The first Bool is True if A contains - -- 'orphan' rules or instance decls - - -- The second Bool is true if the interface file actually - -- read was an .hi-boot file - - -- Nothing => A's interface not yet read, but this module has - -- imported a module, B, that itself depends on A - -- - -- Just xx => A's interface has been read. The Module in - -- the Just has the correct Dll flag - - -- This set is used to decide whether to look for - -- A.hi or A.hi-boot when importing A.f. - -- Basically, we look for A.hi if A is in the map, and A.hi-boot - -- otherwise - -type DeclsMap = NameEnv (Version, AvailInfo, Bool, (Module, RdrNameHsDecl)) - -- A DeclsMap contains a binding for each Name in the declaration - -- including the constructors of a type decl etc. - -- The Bool is True just for the 'main' Name. -\end{code} - - -%************************************************************************ -%* * -\subsection{Main monad code} -%* * -%************************************************************************ - -\begin{code} -initRn :: ModuleName -> UniqSupply -> SearchPath -> SrcLoc - -> RnMG r - -> IO (r, Bag ErrMsg, Bag WarnMsg) - -initRn mod us dirs loc do_rn = do - himaps <- mkModuleHiMaps dirs - names_var <- newIORef (us, emptyFM, builtins) - errs_var <- newIORef (emptyBag,emptyBag) - iface_var <- newIORef emptyIfaces - let - rn_down = RnDown { rn_loc = loc, rn_ns = names_var, - rn_errs = errs_var, - rn_hi_maps = himaps, - rn_ifaces = iface_var, - rn_mod = mod } - - -- do the business - res <- do_rn rn_down () - - -- grab errors and return - (warns, errs) <- readIORef errs_var - - return (res, errs, warns) - - -initRnMS :: GlobalRdrEnv -> FixityEnv -> RnMode -> RnMS r -> RnM d r -initRnMS rn_env fixity_env mode thing_inside rn_down g_down - = let - s_down = SDown { rn_genv = rn_env, rn_lenv = emptyRdrEnv, - rn_fixenv = fixity_env, rn_mode = mode } - in - thing_inside rn_down s_down - -initIfaceRnMS :: Module -> RnMS r -> RnM d r -initIfaceRnMS mod thing_inside - = initRnMS emptyRdrEnv emptyNameEnv InterfaceMode $- setModuleRn (moduleName mod) thing_inside - -emptyIfaces :: Ifaces -emptyIfaces = Ifaces { iImpModInfo = emptyFM, - iDecls = emptyNameEnv, - iFixes = emptyNameEnv, - iSlurp = unitNameSet (mkUnboundName dummyRdrVarName), - -- Pretend that the dummy unbound name has already been - -- slurped. This is what's returned for an out-of-scope name, - -- and we don't want thereby to try to suck it in! - iVSlurp = [], - iInsts = emptyBag, - iRules = emptyBag - } - --- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly --- during compiler debugging. -mkUnboundName :: RdrName -> Name -mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc - -isUnboundName :: Name -> Bool -isUnboundName name = getUnique name == unboundKey - -builtins :: FiniteMap (ModuleName,OccName) Name -builtins = - bagToFM ( - mapBag (\ name -> ((moduleName (nameModule name), nameOccName name), name)) - builtinNames) -\end{code} - -@renameSourceCode@ is used to rename stuff "out-of-line"; that is, not as part of -the main renamer. Sole examples: derived definitions, which are only generated -in the type checker. - -The @RnNameSupply@ includes a @UniqueSupply@, so if you call it more than -once you must either split it, or install a fresh unique supply. - -\begin{code} -renameSourceCode :: ModuleName - -> RnNameSupply - -> RnMS r - -> r - -renameSourceCode mod_name name_supply m - = unsafePerformIO ( - -- It's not really unsafe! When renaming source code we - -- only do any I/O if we need to read in a fixity declaration; - -- and that doesn't happen in pragmas etc - - newIORef name_supply >>= \ names_var -> - newIORef (emptyBag,emptyBag) >>= \ errs_var -> - let - rn_down = RnDown { rn_loc = mkGeneratedSrcLoc, rn_ns = names_var, - rn_errs = errs_var, - rn_mod = mod_name } - s_down = SDown { rn_mode = InterfaceMode, -- So that we can refer to PrelBase.True etc - rn_genv = emptyRdrEnv, rn_lenv = emptyRdrEnv, - rn_fixenv = emptyNameEnv } - in - m rn_down s_down >>= \ result -> - - readIORef errs_var >>= \ (warns,errs) -> - - (if not (isEmptyBag errs) then - pprTrace "Urk! renameSourceCode found errors" (display errs) -#ifdef DEBUG - else if not (isEmptyBag warns) then - pprTrace "Note: renameSourceCode found warnings" (display warns) -#endif - else - id)$ - - return result - ) - where - display errs = pprBagOfErrors errs - -{-# INLINE thenRn #-} -{-# INLINE thenRn_ #-} -{-# INLINE returnRn #-} -{-# INLINE andRn #-} - -returnRn :: a -> RnM d a -thenRn :: RnM d a -> (a -> RnM d b) -> RnM d b -thenRn_ :: RnM d a -> RnM d b -> RnM d b -andRn :: (a -> a -> a) -> RnM d a -> RnM d a -> RnM d a -mapRn :: (a -> RnM d b) -> [a] -> RnM d [b] -mapRn_ :: (a -> RnM d b) -> [a] -> RnM d () -mapMaybeRn :: (a -> RnM d (Maybe b)) -> [a] -> RnM d [b] -sequenceRn :: [RnM d a] -> RnM d [a] -foldlRn :: (b -> a -> RnM d b) -> b -> [a] -> RnM d b -mapAndUnzipRn :: (a -> RnM d (b,c)) -> [a] -> RnM d ([b],[c]) -fixRn :: (a -> RnM d a) -> RnM d a - -returnRn v gdown ldown = return v -thenRn m k gdown ldown = m gdown ldown >>= \ r -> k r gdown ldown -thenRn_ m k gdown ldown = m gdown ldown >> k gdown ldown -fixRn m gdown ldown = fixIO (\r -> m r gdown ldown) -andRn combiner m1 m2 gdown ldown - = m1 gdown ldown >>= \ res1 -> - m2 gdown ldown >>= \ res2 -> - return (combiner res1 res2) - -sequenceRn [] = returnRn [] -sequenceRn (m:ms) = m thenRn \ r -> - sequenceRn ms thenRn \ rs -> - returnRn (r:rs) - -mapRn f [] = returnRn [] -mapRn f (x:xs) - = f x thenRn \ r -> - mapRn f xs thenRn \ rs -> - returnRn (r:rs) - -mapRn_ f [] = returnRn () -mapRn_ f (x:xs) = - f x thenRn_ - mapRn_ f xs - -foldlRn k z [] = returnRn z -foldlRn k z (x:xs) = k z x thenRn \ z' -> - foldlRn k z' xs - -mapAndUnzipRn f [] = returnRn ([],[]) -mapAndUnzipRn f (x:xs) - = f x thenRn \ (r1, r2) -> - mapAndUnzipRn f xs thenRn \ (rs1, rs2) -> - returnRn (r1:rs1, r2:rs2) - -mapAndUnzip3Rn f [] = returnRn ([],[],[]) -mapAndUnzip3Rn f (x:xs) - = f x thenRn \ (r1, r2, r3) -> - mapAndUnzip3Rn f xs thenRn \ (rs1, rs2, rs3) -> - returnRn (r1:rs1, r2:rs2, r3:rs3) - -mapMaybeRn f [] = returnRn [] -mapMaybeRn f (x:xs) = f x thenRn \ maybe_r -> - mapMaybeRn f xs thenRn \ rs -> - case maybe_r of - Nothing -> returnRn rs - Just r -> returnRn (r:rs) -\end{code} - - - -%************************************************************************ -%* * -\subsection{Boring plumbing for common part} -%* * -%************************************************************************ - - -================ Errors and warnings ===================== - -\begin{code} -failWithRn :: a -> Message -> RnM d a -failWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down - = readIORef errs_var >>= \ (warns,errs) -> - writeIORef errs_var (warns, errs snocBag err) >> - return res - where - err = addShortErrLocLine loc msg - -warnWithRn :: a -> Message -> RnM d a -warnWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down - = readIORef errs_var >>= \ (warns,errs) -> - writeIORef errs_var (warns snocBag warn, errs) >> - return res - where - warn = addShortWarnLocLine loc msg - -addErrRn :: Message -> RnM d () -addErrRn err = failWithRn () err - -checkRn :: Bool -> Message -> RnM d () -- Check that a condition is true -checkRn False err = addErrRn err -checkRn True err = returnRn () - -warnCheckRn :: Bool -> Message -> RnM d () -- Check that a condition is true -warnCheckRn False err = addWarnRn err -warnCheckRn True err = returnRn () - -addWarnRn :: Message -> RnM d () -addWarnRn warn = warnWithRn () warn - -checkErrsRn :: RnM d Bool -- True <=> no errors so far -checkErrsRn (RnDown {rn_errs = errs_var}) l_down - = readIORef errs_var >>= \ (warns,errs) -> - return (isEmptyBag errs) -\end{code} - - -================ Source location ===================== - -\begin{code} -pushSrcLocRn :: SrcLoc -> RnM d a -> RnM d a -pushSrcLocRn loc' m down l_down - = m (down {rn_loc = loc'}) l_down - -getSrcLocRn :: RnM d SrcLoc -getSrcLocRn down l_down - = return (rn_loc down) -\end{code} - -================ Name supply ===================== - -\begin{code} -getNameSupplyRn :: RnM d RnNameSupply -getNameSupplyRn rn_down l_down - = readIORef (rn_ns rn_down) - -setNameSupplyRn :: RnNameSupply -> RnM d () -setNameSupplyRn names' (RnDown {rn_ns = names_var}) l_down - = writeIORef names_var names' - --- See comments with RnNameSupply above. -newInstUniq :: (OccName, OccName) -> RnM d Int -newInstUniq key (RnDown {rn_ns = names_var}) l_down - = readIORef names_var >>= \ (us, mapInst, cache) -> - let - uniq = case lookupFM mapInst key of - Just x -> x+1 - Nothing -> 0 - mapInst' = addToFM mapInst key uniq - in - writeIORef names_var (us, mapInst', cache) >> - return uniq - -getUniqRn :: RnM d Unique -getUniqRn (RnDown {rn_ns = names_var}) l_down - = readIORef names_var >>= \ (us, mapInst, cache) -> - let - (us1,us') = splitUniqSupply us - in - writeIORef names_var (us', mapInst, cache) >> - return (uniqFromSupply us1) -\end{code} - -================ Module ===================== - -\begin{code} -getModuleRn :: RnM d ModuleName -getModuleRn (RnDown {rn_mod = mod_name}) l_down - = return mod_name - -setModuleRn :: ModuleName -> RnM d a -> RnM d a -setModuleRn new_mod enclosed_thing rn_down l_down - = enclosed_thing (rn_down {rn_mod = new_mod}) l_down -\end{code} - - -%************************************************************************ -%* * -\subsection{Plumbing for rename-source part} -%* * -%************************************************************************ - -================ RnEnv ===================== - -\begin{code} -getNameEnvs :: RnMS (GlobalRdrEnv, LocalRdrEnv) -getNameEnvs rn_down (SDown {rn_genv = global_env, rn_lenv = local_env}) - = return (global_env, local_env) - -getLocalNameEnv :: RnMS LocalRdrEnv -getLocalNameEnv rn_down (SDown {rn_lenv = local_env}) - = return local_env - -setLocalNameEnv :: LocalRdrEnv -> RnMS a -> RnMS a -setLocalNameEnv local_env' m rn_down l_down - = m rn_down (l_down {rn_lenv = local_env'}) - -getFixityEnv :: RnMS FixityEnv -getFixityEnv rn_down (SDown {rn_fixenv = fixity_env}) - = return fixity_env - -extendFixityEnv :: [(Name, RenamedFixitySig)] -> RnMS a -> RnMS a -extendFixityEnv fixes enclosed_scope - rn_down l_down@(SDown {rn_fixenv = fixity_env}) - = let - new_fixity_env = extendNameEnv fixity_env fixes - in - enclosed_scope rn_down (l_down {rn_fixenv = new_fixity_env}) -\end{code} - -================ Mode ===================== - -\begin{code} -getModeRn :: RnMS RnMode -getModeRn rn_down (SDown {rn_mode = mode}) - = return mode - -setModeRn :: RnMode -> RnMS a -> RnMS a -setModeRn new_mode thing_inside rn_down l_down - = thing_inside rn_down (l_down {rn_mode = new_mode}) -\end{code} - - -%************************************************************************ -%* * -\subsection{Plumbing for rename-globals part} -%* * -%************************************************************************ - -\begin{code} -getIfacesRn :: RnM d Ifaces -getIfacesRn (RnDown {rn_ifaces = iface_var}) _ - = readIORef iface_var - -setIfacesRn :: Ifaces -> RnM d () -setIfacesRn ifaces (RnDown {rn_ifaces = iface_var}) _ - = writeIORef iface_var ifaces - -getHiMaps :: RnM d (ModuleHiMap, ModuleHiMap) -getHiMaps (RnDown {rn_hi_maps = himaps}) _ - = return himaps -\end{code} +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[RnMonad]{The monad used by the renamer} + +\begin{code} +module RnMonad( + module RnMonad, + Module, + FiniteMap, + Bag, + Name, + RdrNameHsDecl, + RdrNameInstDecl, + Version, + NameSet, + OccName, + Fixity + ) where + +#include "HsVersions.h" + +import PrelIOBase ( fixIO ) -- Should be in GlaExts +import IOExts ( IORef, newIORef, readIORef, writeIORef, unsafePerformIO ) + +import HsSyn +import RdrHsSyn +import RnHsSyn ( RenamedFixitySig ) +import BasicTypes ( Version ) +import SrcLoc ( noSrcLoc ) +import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, + pprBagOfErrors, ErrMsg, WarnMsg, Message + ) +import Name ( Name, OccName, NamedThing(..), + isLocallyDefinedName, nameModule, nameOccName, + decode, mkLocalName + ) +import Module ( Module, ModuleName, ModuleHiMap, SearchPath, WhereFrom, + mkModuleHiMaps, moduleName + ) +import NameSet +import RdrName ( RdrName, dummyRdrVarName, rdrNameOcc ) +import CmdLineOpts ( opt_D_dump_rn_trace, opt_IgnoreIfacePragmas ) +import PrelInfo ( builtinNames ) +import TysWiredIn ( boolTyCon ) +import SrcLoc ( SrcLoc, mkGeneratedSrcLoc ) +import Unique ( Unique, getUnique, unboundKey ) +import UniqFM ( UniqFM ) +import FiniteMap ( FiniteMap, emptyFM, bagToFM, lookupFM, addToFM, addListToFM, + addListToFM_C, addToFM_C, eltsFM, fmToList + ) +import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag ) +import Maybes ( mapMaybe ) +import UniqSet +import UniqFM +import UniqSupply +import Util +import Outputable + +infixr 9 thenRn, thenRn_ +\end{code} + + +%************************************************************************ +%* * +\subsection{Somewhat magical interface to other monads} +%* * +%************************************************************************ + +\begin{code} +ioToRnM :: IO r -> RnM d (Either IOError r) +ioToRnM io rn_down g_down = (io >>= \ ok -> return (Right ok)) + catch + (\ err -> return (Left err)) + +traceRn :: SDoc -> RnM d () +traceRn msg | opt_D_dump_rn_trace = putDocRn msg + | otherwise = returnRn () + +putDocRn :: SDoc -> RnM d () +putDocRn msg = ioToRnM (printErrs msg) thenRn_ + returnRn () +\end{code} + + +%************************************************************************ +%* * +\subsection{Data types} +%* * +%************************************************************************ + +%=================================================== +\subsubsection{ MONAD TYPES} +%=================================================== + +\begin{code} +type RnM d r = RnDown -> d -> IO r +type RnMS r = RnM SDown r -- Renaming source +type RnMG r = RnM () r -- Getting global names etc + + -- Common part +data RnDown = RnDown { + rn_mod :: ModuleName, + rn_loc :: SrcLoc, + rn_ns :: IORef RnNameSupply, + rn_errs :: IORef (Bag WarnMsg, Bag ErrMsg), + rn_ifaces :: IORef Ifaces, + rn_hi_maps :: (ModuleHiMap, -- for .hi files + ModuleHiMap) -- for .hi-boot files + } + + -- For renaming source code +data SDown = SDown { + rn_mode :: RnMode, + + rn_genv :: GlobalRdrEnv, + -- Global envt; the fixity component gets extended + -- with local fixity decls + + rn_lenv :: LocalRdrEnv, -- Local name envt + -- Does *not* include global name envt; may shadow it + -- Includes both ordinary variables and type variables; + -- they are kept distinct because tyvar have a different + -- occurrence contructor (Name.TvOcc) + -- We still need the unsullied global name env so that + -- we can look up record field names + + rn_fixenv :: FixityEnv -- Local fixities + -- The global ones are held in the + -- rn_ifaces field + } + +data RnMode = SourceMode -- Renaming source code + | InterfaceMode -- Renaming interface declarations. +\end{code} + +%=================================================== +\subsubsection{ ENVIRONMENTS} +%=================================================== + +\begin{code} +-------------------------------- +type RdrNameEnv a = FiniteMap RdrName a +type GlobalRdrEnv = RdrNameEnv [Name] -- The list is because there may be name clashes + -- These only get reported on lookup, + -- not on construction +type LocalRdrEnv = RdrNameEnv Name + +emptyRdrEnv :: RdrNameEnv a +lookupRdrEnv :: RdrNameEnv a -> RdrName -> Maybe a +addListToRdrEnv :: RdrNameEnv a -> [(RdrName,a)] -> RdrNameEnv a +extendRdrEnv :: RdrNameEnv a -> RdrName -> a -> RdrNameEnv a + +emptyRdrEnv = emptyFM +lookupRdrEnv = lookupFM +addListToRdrEnv = addListToFM +rdrEnvElts = eltsFM +extendRdrEnv = addToFM +rdrEnvToList = fmToList + +-------------------------------- +type NameEnv a = UniqFM a -- Domain is Name + +emptyNameEnv :: NameEnv a +nameEnvElts :: NameEnv a -> [a] +addToNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a +addToNameEnv :: NameEnv a -> Name -> a -> NameEnv a +plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a +extendNameEnv :: NameEnv a -> [(Name,a)] -> NameEnv a +lookupNameEnv :: NameEnv a -> Name -> Maybe a +delFromNameEnv :: NameEnv a -> Name -> NameEnv a +elemNameEnv :: Name -> NameEnv a -> Bool + +emptyNameEnv = emptyUFM +nameEnvElts = eltsUFM +addToNameEnv_C = addToUFM_C +addToNameEnv = addToUFM +plusNameEnv = plusUFM +extendNameEnv = addListToUFM +lookupNameEnv = lookupUFM +delFromNameEnv = delFromUFM +elemNameEnv = elemUFM + +-------------------------------- +type FixityEnv = NameEnv RenamedFixitySig + -- We keep the whole fixity sig so that we + -- can report line-number info when there is a duplicate + -- fixity declaration +\end{code} + +\begin{code} +-------------------------------- +type RnNameSupply + = ( UniqSupply + + , FiniteMap (OccName, OccName) Int + -- This is used as a name supply for dictionary functions + -- From the inst decl we derive a (class, tycon) pair; + -- this map then gives a unique int for each inst decl with that + -- (class, tycon) pair. (In Haskell 98 there can only be one, + -- but not so in more extended versions.) + -- + -- We could just use one Int for all the instance decls, but this + -- way the uniques change less when you add an instance decl, + -- hence less recompilation + + , FiniteMap (ModuleName, OccName) Name + -- Ensures that one (module,occname) pair gets one unique + ) + + +-------------------------------- +data ExportEnv = ExportEnv Avails Fixities +type Avails = [AvailInfo] +type Fixities = [(Name, Fixity)] + +type ExportAvails = (FiniteMap ModuleName Avails, + -- Used to figure out "module M" export specifiers + -- Includes avails only from *unqualified* imports + -- (see 1.4 Report Section 5.1.1) + + NameEnv AvailInfo) -- Used to figure out all other export specifiers. + -- Maps a Name to the AvailInfo that contains it + + +data GenAvailInfo name = Avail name -- An ordinary identifier + | AvailTC name -- The name of the type or class + [name] -- The available pieces of type/class. + -- NB: If the type or class is itself + -- to be in scope, it must be in this list. + -- Thus, typically: AvailTC Eq [Eq, ==, /=] + +type AvailInfo = GenAvailInfo Name +type RdrAvailInfo = GenAvailInfo OccName +\end{code} + +%=================================================== +\subsubsection{ INTERFACE FILE STUFF} +%=================================================== + +\begin{code} +type ExportItem = (ModuleName, [RdrAvailInfo]) +type VersionInfo name = [ImportVersion name] + +type ImportVersion name = (ModuleName, Version, WhetherHasOrphans, WhatsImported name) + +type WhetherHasOrphans = Bool + -- An "orphan" is + -- * an instance decl in a module other than the defn module for + -- one of the tycons or classes in the instance head + -- * a transformation rule in a module other than the one defining + -- the function in the head of the rule. + +data WhatsImported name = Everything + | Specifically [LocalVersion name] -- List guaranteed non-empty + + -- ("M", hif, ver, Everything) means there was a "module M" in + -- this module's export list, so we just have to go by M's version, "ver", + -- not the list of LocalVersions. + + +type LocalVersion name = (name, Version) + +data ParsedIface + = ParsedIface { + pi_mod :: Version, -- Module version number + pi_orphan :: WhetherHasOrphans, -- Whether this module has orphans + pi_usages :: [ImportVersion OccName], -- Usages + pi_exports :: [ExportItem], -- Exports + pi_decls :: [(Version, RdrNameHsDecl)], -- Local definitions + pi_insts :: [RdrNameInstDecl], -- Local instance declarations + pi_rules :: [RdrNameRuleDecl] -- Rules + } + +type InterfaceDetails = (WhetherHasOrphans, + VersionInfo Name, -- Version information for what this module imports + ExportEnv) -- What modules this one depends on + + +-- needed by Main to fish out the fixities assoc list. +getIfaceFixities :: InterfaceDetails -> Fixities +getIfaceFixities (_, _, ExportEnv _ fs) = fs + + +type RdrNamePragma = () -- Fudge for now +------------------- + +data Ifaces = Ifaces { + iImpModInfo :: ImportedModuleInfo, + -- Modules this one depends on: that is, the union + -- of the modules its direct imports depend on. + + iDecls :: DeclsMap, -- A single, global map of Names to decls + + iFixes :: FixityEnv, -- A single, global map of Names to fixities + + iSlurp :: NameSet, + -- All the names (whether "big" or "small", whether wired-in or not, + -- whether locally defined or not) that have been slurped in so far. + + iVSlurp :: [(Name,Version)], + -- All the (a) non-wired-in (b) "big" (c) non-locally-defined + -- names that have been slurped in so far, with their versions. + -- This is used to generate the "usage" information for this module. + -- Subset of the previous field. + + iInsts :: Bag GatedDecl, + -- The as-yet un-slurped instance decls; this bag is depleted when we + -- slurp an instance decl so that we don't slurp the same one twice. + -- Each is 'gated' by the names that must be available before + -- this instance decl is needed. + + iRules :: Bag GatedDecl + -- Ditto transformation rules + } + +type GatedDecl = (NameSet, (Module, RdrNameHsDecl)) + +type ImportedModuleInfo + = FiniteMap ModuleName (Version, Bool, Maybe (Module, Bool, Avails)) + -- Suppose the domain element is module 'A' + -- + -- The first Bool is True if A contains + -- 'orphan' rules or instance decls + + -- The second Bool is true if the interface file actually + -- read was an .hi-boot file + + -- Nothing => A's interface not yet read, but this module has + -- imported a module, B, that itself depends on A + -- + -- Just xx => A's interface has been read. The Module in + -- the Just has the correct Dll flag + + -- This set is used to decide whether to look for + -- A.hi or A.hi-boot when importing A.f. + -- Basically, we look for A.hi if A is in the map, and A.hi-boot + -- otherwise + +type DeclsMap = NameEnv (Version, AvailInfo, Bool, (Module, RdrNameHsDecl)) + -- A DeclsMap contains a binding for each Name in the declaration + -- including the constructors of a type decl etc. + -- The Bool is True just for the 'main' Name. +\end{code} + + +%************************************************************************ +%* * +\subsection{Main monad code} +%* * +%************************************************************************ + +\begin{code} +initRn :: ModuleName -> UniqSupply -> SearchPath -> SrcLoc + -> RnMG r + -> IO (r, Bag ErrMsg, Bag WarnMsg) + +initRn mod us dirs loc do_rn = do + himaps <- mkModuleHiMaps dirs + names_var <- newIORef (us, emptyFM, builtins) + errs_var <- newIORef (emptyBag,emptyBag) + iface_var <- newIORef emptyIfaces + let + rn_down = RnDown { rn_loc = loc, rn_ns = names_var, + rn_errs = errs_var, + rn_hi_maps = himaps, + rn_ifaces = iface_var, + rn_mod = mod } + + -- do the business + res <- do_rn rn_down () + + -- grab errors and return + (warns, errs) <- readIORef errs_var + + return (res, errs, warns) + + +initRnMS :: GlobalRdrEnv -> FixityEnv -> RnMode -> RnMS r -> RnM d r +initRnMS rn_env fixity_env mode thing_inside rn_down g_down + = let + s_down = SDown { rn_genv = rn_env, rn_lenv = emptyRdrEnv, + rn_fixenv = fixity_env, rn_mode = mode } + in + thing_inside rn_down s_down + +initIfaceRnMS :: Module -> RnMS r -> RnM d r +initIfaceRnMS mod thing_inside + = initRnMS emptyRdrEnv emptyNameEnv InterfaceMode $+ setModuleRn (moduleName mod) thing_inside + +emptyIfaces :: Ifaces +emptyIfaces = Ifaces { iImpModInfo = emptyFM, + iDecls = emptyNameEnv, + iFixes = emptyNameEnv, + iSlurp = unitNameSet (mkUnboundName dummyRdrVarName), + -- Pretend that the dummy unbound name has already been + -- slurped. This is what's returned for an out-of-scope name, + -- and we don't want thereby to try to suck it in! + iVSlurp = [], + iInsts = emptyBag, + iRules = emptyBag + } + +-- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly +-- during compiler debugging. +mkUnboundName :: RdrName -> Name +mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc + +isUnboundName :: Name -> Bool +isUnboundName name = getUnique name == unboundKey + +builtins :: FiniteMap (ModuleName,OccName) Name +builtins = + bagToFM ( + mapBag (\ name -> ((moduleName (nameModule name), nameOccName name), name)) + builtinNames) +\end{code} + +@renameSourceCode@ is used to rename stuff out-of-line''; +that is, not as part of the main renamer. +Sole examples: derived definitions, +which are only generated in the type checker. + +The @RnNameSupply@ includes a @UniqueSupply@, so if you call it more than +once you must either split it, or install a fresh unique supply. + +\begin{code} +renameSourceCode :: ModuleName + -> RnNameSupply + -> RnMS r + -> r + +renameSourceCode mod_name name_supply m + = unsafePerformIO ( + -- It's not really unsafe! When renaming source code we + -- only do any I/O if we need to read in a fixity declaration; + -- and that doesn't happen in pragmas etc + + newIORef name_supply >>= \ names_var -> + newIORef (emptyBag,emptyBag) >>= \ errs_var -> + let + rn_down = RnDown { rn_loc = mkGeneratedSrcLoc, rn_ns = names_var, + rn_errs = errs_var, + rn_mod = mod_name } + s_down = SDown { rn_mode = InterfaceMode, + -- So that we can refer to PrelBase.True etc + rn_genv = emptyRdrEnv, rn_lenv = emptyRdrEnv, + rn_fixenv = emptyNameEnv } + in + m rn_down s_down >>= \ result -> + + readIORef errs_var >>= \ (warns,errs) -> + + (if not (isEmptyBag errs) then + pprTrace "Urk! renameSourceCode found errors" (display errs) +#ifdef DEBUG + else if not (isEmptyBag warns) then + pprTrace "Note: renameSourceCode found warnings" (display warns) +#endif + else + id)$ + + return result + ) + where + display errs = pprBagOfErrors errs + +{-# INLINE thenRn #-} +{-# INLINE thenRn_ #-} +{-# INLINE returnRn #-} +{-# INLINE andRn #-} + +returnRn :: a -> RnM d a +thenRn :: RnM d a -> (a -> RnM d b) -> RnM d b +thenRn_ :: RnM d a -> RnM d b -> RnM d b +andRn :: (a -> a -> a) -> RnM d a -> RnM d a -> RnM d a +mapRn :: (a -> RnM d b) -> [a] -> RnM d [b] +mapRn_ :: (a -> RnM d b) -> [a] -> RnM d () +mapMaybeRn :: (a -> RnM d (Maybe b)) -> [a] -> RnM d [b] +sequenceRn :: [RnM d a] -> RnM d [a] +foldlRn :: (b -> a -> RnM d b) -> b -> [a] -> RnM d b +mapAndUnzipRn :: (a -> RnM d (b,c)) -> [a] -> RnM d ([b],[c]) +fixRn :: (a -> RnM d a) -> RnM d a + +returnRn v gdown ldown = return v +thenRn m k gdown ldown = m gdown ldown >>= \ r -> k r gdown ldown +thenRn_ m k gdown ldown = m gdown ldown >> k gdown ldown +fixRn m gdown ldown = fixIO (\r -> m r gdown ldown) +andRn combiner m1 m2 gdown ldown + = m1 gdown ldown >>= \ res1 -> + m2 gdown ldown >>= \ res2 -> + return (combiner res1 res2) + +sequenceRn [] = returnRn [] +sequenceRn (m:ms) = m thenRn \ r -> + sequenceRn ms thenRn \ rs -> + returnRn (r:rs) + +mapRn f [] = returnRn [] +mapRn f (x:xs) + = f x thenRn \ r -> + mapRn f xs thenRn \ rs -> + returnRn (r:rs) + +mapRn_ f [] = returnRn () +mapRn_ f (x:xs) = + f x thenRn_ + mapRn_ f xs + +foldlRn k z [] = returnRn z +foldlRn k z (x:xs) = k z x thenRn \ z' -> + foldlRn k z' xs + +mapAndUnzipRn f [] = returnRn ([],[]) +mapAndUnzipRn f (x:xs) + = f x thenRn \ (r1, r2) -> + mapAndUnzipRn f xs thenRn \ (rs1, rs2) -> + returnRn (r1:rs1, r2:rs2) + +mapAndUnzip3Rn f [] = returnRn ([],[],[]) +mapAndUnzip3Rn f (x:xs) + = f x thenRn \ (r1, r2, r3) -> + mapAndUnzip3Rn f xs thenRn \ (rs1, rs2, rs3) -> + returnRn (r1:rs1, r2:rs2, r3:rs3) + +mapMaybeRn f [] = returnRn [] +mapMaybeRn f (x:xs) = f x thenRn \ maybe_r -> + mapMaybeRn f xs thenRn \ rs -> + case maybe_r of + Nothing -> returnRn rs + Just r -> returnRn (r:rs) +\end{code} + + + +%************************************************************************ +%* * +\subsection{Boring plumbing for common part} +%* * +%************************************************************************ + + +%================ +\subsubsection{ Errors and warnings} +%===================== + +\begin{code} +failWithRn :: a -> Message -> RnM d a +failWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down + = readIORef errs_var >>= \ (warns,errs) -> + writeIORef errs_var (warns, errs snocBag err) >> + return res + where + err = addShortErrLocLine loc msg + +warnWithRn :: a -> Message -> RnM d a +warnWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down + = readIORef errs_var >>= \ (warns,errs) -> + writeIORef errs_var (warns snocBag warn, errs) >> + return res + where + warn = addShortWarnLocLine loc msg + +addErrRn :: Message -> RnM d () +addErrRn err = failWithRn () err + +checkRn :: Bool -> Message -> RnM d () -- Check that a condition is true +checkRn False err = addErrRn err +checkRn True err = returnRn () + +warnCheckRn :: Bool -> Message -> RnM d () -- Check that a condition is true +warnCheckRn False err = addWarnRn err +warnCheckRn True err = returnRn () + +addWarnRn :: Message -> RnM d () +addWarnRn warn = warnWithRn () warn + +checkErrsRn :: RnM d Bool -- True <=> no errors so far +checkErrsRn (RnDown {rn_errs = errs_var}) l_down + = readIORef errs_var >>= \ (warns,errs) -> + return (isEmptyBag errs) +\end{code} + + +%================ +\subsubsection{ Source location} +%===================== + +\begin{code} +pushSrcLocRn :: SrcLoc -> RnM d a -> RnM d a +pushSrcLocRn loc' m down l_down + = m (down {rn_loc = loc'}) l_down + +getSrcLocRn :: RnM d SrcLoc +getSrcLocRn down l_down + = return (rn_loc down) +\end{code} + +%================ +\subsubsection{ Name supply} +%===================== + +\begin{code} +getNameSupplyRn :: RnM d RnNameSupply +getNameSupplyRn rn_down l_down + = readIORef (rn_ns rn_down) + +setNameSupplyRn :: RnNameSupply -> RnM d () +setNameSupplyRn names' (RnDown {rn_ns = names_var}) l_down + = writeIORef names_var names' + +-- See comments with RnNameSupply above. +newInstUniq :: (OccName, OccName) -> RnM d Int +newInstUniq key (RnDown {rn_ns = names_var}) l_down + = readIORef names_var >>= \ (us, mapInst, cache) -> + let + uniq = case lookupFM mapInst key of + Just x -> x+1 + Nothing -> 0 + mapInst' = addToFM mapInst key uniq + in + writeIORef names_var (us, mapInst', cache) >> + return uniq + +getUniqRn :: RnM d Unique +getUniqRn (RnDown {rn_ns = names_var}) l_down + = readIORef names_var >>= \ (us, mapInst, cache) -> + let + (us1,us') = splitUniqSupply us + in + writeIORef names_var (us', mapInst, cache) >> + return (uniqFromSupply us1) +\end{code} + +%================ +\subsubsection{ Module} +%===================== + +\begin{code} +getModuleRn :: RnM d ModuleName +getModuleRn (RnDown {rn_mod = mod_name}) l_down + = return mod_name + +setModuleRn :: ModuleName -> RnM d a -> RnM d a +setModuleRn new_mod enclosed_thing rn_down l_down + = enclosed_thing (rn_down {rn_mod = new_mod}) l_down +\end{code} + + +%************************************************************************ +%* * +\subsection{Plumbing for rename-source part} +%* * +%************************************************************************ + +%================ +\subsubsection{ RnEnv} +%===================== + +\begin{code} +getNameEnvs :: RnMS (GlobalRdrEnv, LocalRdrEnv) +getNameEnvs rn_down (SDown {rn_genv = global_env, rn_lenv = local_env}) + = return (global_env, local_env) + +getLocalNameEnv :: RnMS LocalRdrEnv +getLocalNameEnv rn_down (SDown {rn_lenv = local_env}) + = return local_env + +setLocalNameEnv :: LocalRdrEnv -> RnMS a -> RnMS a +setLocalNameEnv local_env' m rn_down l_down + = m rn_down (l_down {rn_lenv = local_env'}) + +getFixityEnv :: RnMS FixityEnv +getFixityEnv rn_down (SDown {rn_fixenv = fixity_env}) + = return fixity_env + +extendFixityEnv :: [(Name, RenamedFixitySig)] -> RnMS a -> RnMS a +extendFixityEnv fixes enclosed_scope + rn_down l_down@(SDown {rn_fixenv = fixity_env}) + = let + new_fixity_env = extendNameEnv fixity_env fixes + in + enclosed_scope rn_down (l_down {rn_fixenv = new_fixity_env}) +\end{code} + +%================ +\subsubsection{ Mode} +%===================== + +\begin{code} +getModeRn :: RnMS RnMode +getModeRn rn_down (SDown {rn_mode = mode}) + = return mode + +setModeRn :: RnMode -> RnMS a -> RnMS a +setModeRn new_mode thing_inside rn_down l_down + = thing_inside rn_down (l_down {rn_mode = new_mode}) +\end{code} + + +%************************************************************************ +%* * +\subsection{Plumbing for rename-globals part} +%* * +%************************************************************************ + +\begin{code} +getIfacesRn :: RnM d Ifaces +getIfacesRn (RnDown {rn_ifaces = iface_var}) _ + = readIORef iface_var + +setIfacesRn :: Ifaces -> RnM d () +setIfacesRn ifaces (RnDown {rn_ifaces = iface_var}) _ + = writeIORef iface_var ifaces + +getHiMaps :: RnM d (ModuleHiMap, ModuleHiMap) +getHiMaps (RnDown {rn_hi_maps = himaps}) _ + = return himaps +\end{code} diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 4df3ffbf3e03e05c122e4c17af11a8e45617c470..96bf4ef6734b0cb8dd433f79e0c78f7f9db72edd 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -62,9 +62,9 @@ import List ( partition ) getGlobalNames :: RdrNameHsModule -> RnMG (Maybe (ExportEnv, GlobalRdrEnv, - FixityEnv, -- Fixities for local decls only - NameEnv AvailInfo -- Maps a name to its parent AvailInfo - -- Just for in-scope things only + FixityEnv, -- Fixities for local decls only + NameEnv AvailInfo -- Maps a name to its parent AvailInfo + -- Just for in-scope things only )) -- Nothing => no need to recompile @@ -85,7 +85,8 @@ getGlobalNames (HsModule this_mod _ exports imports decls mod_loc) -- PROCESS LOCAL DECLS -- Do these *first* so that the correct provenance gets -- into the global name cache. - importsFromLocalDecls this_mod rec_exp_fn decls thenRn \ (local_gbl_env, local_mod_avails) -> + importsFromLocalDecls this_mod rec_exp_fn decls + thenRn \ (local_gbl_env, local_mod_avails) -> -- PROCESS IMPORT DECLS -- Do the non {- SOURCE -} ones first, so that we get a helpful @@ -95,8 +96,10 @@ getGlobalNames (HsModule this_mod _ exports imports decls mod_loc) is_source_import (ImportDecl _ ImportByUserSource _ _ _ _) = True is_source_import other = False in - mapAndUnzipRn (importsFromImportDecl rec_unqual_fn) ordinary thenRn \ (imp_gbl_envs1, imp_avails_s1) -> - mapAndUnzipRn (importsFromImportDecl rec_unqual_fn) source thenRn \ (imp_gbl_envs2, imp_avails_s2) -> + mapAndUnzipRn (importsFromImportDecl rec_unqual_fn) ordinary + thenRn \ (imp_gbl_envs1, imp_avails_s1) -> + mapAndUnzipRn (importsFromImportDecl rec_unqual_fn) source + thenRn \ (imp_gbl_envs2, imp_avails_s2) -> -- COMBINE RESULTS -- We put the local env second, so that a local provenance @@ -139,7 +142,8 @@ getGlobalNames (HsModule this_mod _ exports imports decls mod_loc) isQual rdr_name]) thenRn_ -- PROCESS EXPORT LISTS - exportsFromAvail this_mod exports all_avails gbl_env thenRn \ exported_avails -> + exportsFromAvail this_mod exports all_avails gbl_env + thenRn \ exported_avails -> -- DONE returnRn (gbl_env, exported_avails, Just all_avails) @@ -158,8 +162,9 @@ getGlobalNames (HsModule this_mod _ exports imports decls mod_loc) -- (a) defined in this module -- (b) exported exported_fixities :: [(Name,Fixity)] - exported_fixities = [(name,fixity) | FixitySig name fixity _ <- nameEnvElts local_fixity_env, - isLocallyDefined name + exported_fixities = [(name,fixity) + | FixitySig name fixity _ <- nameEnvElts local_fixity_env, + isLocallyDefined name ] in traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts local_fixity_env))) thenRn_ @@ -184,12 +189,12 @@ getGlobalNames (HsModule this_mod _ exports imports decls mod_loc) opt_NoImplicitPrelude = [] - | otherwise = [ImportDecl pRELUDE_Name - ImportByUser - False {- Not qualified -} - Nothing {- No "as" -} - Nothing {- No import list -} - mod_loc] + | otherwise = [ImportDecl pRELUDE_Name + ImportByUser + False {- Not qualified -} + Nothing {- No "as" -} + Nothing {- No import list -} + mod_loc] explicit_prelude_import = not (null [ () | (ImportDecl mod _ _ _ _ _) <- imports, mod == pRELUDE_Name ]) @@ -235,7 +240,8 @@ importsFromImportDecl is_unqual (ImportDecl imp_mod_name from qual_only as_mod i returnRn (emptyRdrEnv, mkEmptyExportAvails imp_mod_name) else - filterImports imp_mod_name import_spec avails thenRn \ (filtered_avails, hides, explicits) -> + filterImports imp_mod_name import_spec avails + thenRn \ (filtered_avails, hides, explicits) -> -- We 'improve' the provenance by setting -- (a) the import-reason field, so that the Name says how it came into scope @@ -243,14 +249,16 @@ importsFromImportDecl is_unqual (ImportDecl imp_mod_name from qual_only as_mod i -- (b) the print-unqualified field -- But don't fiddle with wired-in things or we get in a twist let - improve_prov name = setNameProvenance name (NonLocalDef (UserImport imp_mod iloc (is_explicit name)) - (is_unqual name)) + improve_prov name = + setNameProvenance name (NonLocalDef (UserImport imp_mod iloc (is_explicit name)) + (is_unqual name)) is_explicit name = name elemNameSet explicits in qualifyImports imp_mod_name (not qual_only) -- Maybe want unqualified names as_mod hides - filtered_avails improve_prov thenRn \ (rdr_name_env, mod_avails) -> + filtered_avails improve_prov + thenRn \ (rdr_name_env, mod_avails) -> returnRn (rdr_name_env, mod_avails) \end{code} @@ -342,16 +350,16 @@ fixitiesFromLocalDecls gbl_env decls = -- Check for fixity decl for something not declared case lookupRdrEnv gbl_env rdr_name of { Nothing | opt_WarnUnusedBinds - -> pushSrcLocRn loc (addWarnRn (unusedFixityDecl rdr_name fixity)) thenRn_ - returnRn acc + -> pushSrcLocRn loc (addWarnRn (unusedFixityDecl rdr_name fixity)) + thenRn_ returnRn acc | otherwise -> returnRn acc ; Just (name:_) -> -- Check for duplicate fixity decl case lookupNameEnv acc name of { - Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc') thenRn_ - returnRn acc ; + Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc') + thenRn_ returnRn acc ; Nothing -> returnRn (addToNameEnv acc name (FixitySig name fixity loc)) }} @@ -371,7 +379,8 @@ filterImports :: ModuleName -- The module being imported -> Maybe (Bool, [RdrNameIE]) -- Import spec; True => hiding -> [AvailInfo] -- What's available -> RnMG ([AvailInfo], -- What's actually imported - [AvailInfo], -- What's to be hidden (the unqualified version, that is) + [AvailInfo], -- What's to be hidden + -- (the unqualified version, that is) NameSet) -- What was imported explicitly -- Complains if import spec mentions things that the module doesn't export @@ -508,18 +517,21 @@ qualifyImports this_mod unqual_imp as_mod hides %************************************************************************ %* * -\subsection{Export list processing +\subsection{Export list processing} %* * %************************************************************************ Processing the export list. -You might think that we should record things that appear in the export list as -occurrences'' (using addOccurrenceName), but you'd be wrong. We do check (here) -that they are in scope, but there is no need to slurp in their actual declaration -(which is what addOccurrenceName forces). Indeed, doing so would big trouble when -compiling PrelBase, because it re-exports GHC, which includes takeMVar#, whose type -includes ConcBase.StateAndSynchVar#, and so on... +You might think that we should record things that appear in the export list +as occurrences'' (using @addOccurrenceName@), but you'd be wrong. +We do check (here) that they are in scope, +but there is no need to slurp in their actual declaration +(which is what @addOccurrenceName@ forces). + +Indeed, doing so would big trouble when +compiling @PrelBase@, because it re-exports @GHC@, which includes @takeMVar#@, +whose type includes @ConcBase.StateAndSynchVar#@, and so on... \begin{code} type ExportAccum -- The type of the accumulating parameter of @@ -576,7 +588,8 @@ exportsFromAvail this_mod (Just export_items) | otherwise = case lookupFM mod_avail_env mod of Nothing -> failWithRn acc (modExportErr mod) - Just mod_avails -> foldlRn (check_occs ie) occs mod_avails thenRn \ occs' -> + Just mod_avails -> foldlRn (check_occs ie) occs mod_avails + thenRn \ occs' -> let avails' = foldl add_avail avails mod_avails in @@ -627,8 +640,8 @@ check_occs ie occs avail Just (name', ie') | name == name' -> -- Duplicate export warnCheckRn opt_WarnDuplicateExports - (dupExportWarn name_occ ie ie') thenRn_ - returnRn occs + (dupExportWarn name_occ ie ie') + thenRn_ returnRn occs | otherwise -> -- Same occ name but different names: an error failWithRn occs (exportClashErr name_occ ie ie') @@ -654,7 +667,8 @@ badImportItemErr mod ie ptext SLIT("does not export"), quotes (ppr ie)] dodgyImportWarn mod (IEThingAll tc) - = sep [ptext SLIT("Module") <+> quotes (pprModuleName mod) <+> ptext SLIT("exports") <+> quotes (ppr tc), + = sep [ptext SLIT("Module") <+> quotes (pprModuleName mod) + <+> ptext SLIT("exports") <+> quotes (ppr tc), ptext SLIT("with no constructors/class operations;"), ptext SLIT("yet it is imported with a (..)")] @@ -665,8 +679,9 @@ exportItemErr export_item = sep [ ptext SLIT("Bad export item"), quotes (ppr export_item)] exportClashErr occ_name ie1 ie2 - = hsep [ptext SLIT("The export items"), quotes (ppr ie1), ptext SLIT("and"), quotes (ppr ie2), - ptext SLIT("create conflicting exports for"), quotes (ppr occ_name)] + = hsep [ptext SLIT("The export items"), quotes (ppr ie1) + ,ptext SLIT("and"), quotes (ppr ie2) + ,ptext SLIT("create conflicting exports for"), quotes (ppr occ_name)] dupDeclErr (n:ns) = vcat [ptext SLIT("Multiple declarations of") <+> quotes (ppr n), diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 68b817f21b6a58bebb0117e1793cfe48becf2b90..a2a1aeecaa057d9d070ecd49c4a1be5333e48b4a 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -54,7 +54,7 @@ import Maybes ( maybeToBool, catMaybes ) import Util \end{code} -rnDecl renames' declarations. +@rnDecl@ renames' declarations. It simultaneously performs dependency analysis and precedence parsing. It also does the following error checks: \begin{enumerate} @@ -64,7 +64,7 @@ for undefined tyvars, and tyvars in contexts that are ambiguous. \item Checks that all variable occurences are defined. \item -Checks the (..) etc constraints in the export list. +Checks the @(..)@ etc constraints in the export list. \end{enumerate} @@ -125,23 +125,25 @@ names, reporting any unknown names. Renaming type variables is a pain. Because they now contain uniques, it is necessary to pass in an association list which maps a parsed -tyvar to its Name representation. In some cases (type signatures of -values), it is even necessary to go over the type first in order to -get the set of tyvars used by it, make an assoc list, and then go over -it again to rename the tyvars! However, we can also do some scoping -checks at the same time. +tyvar to its @Name@ representation. +In some cases (type signatures of values), +it is even necessary to go over the type first +in order to get the set of tyvars used by it, make an assoc list, +and then go over it again to rename the tyvars! +However, we can also do some scoping checks at the same time. \begin{code} rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc)) = pushSrcLocRn src_loc $- lookupBndrRn tycon thenRn \ tycon' -> - bindTyVarsFVRn data_doc tyvars$ \ tyvars' -> - rnContext data_doc context thenRn \ (context', cxt_fvs) -> - checkDupOrQualNames data_doc con_names thenRn_ - mapFvRn rnConDecl condecls thenRn \ (condecls', con_fvs) -> - rnDerivs derivings thenRn \ (derivings', deriv_fvs) -> + lookupBndrRn tycon thenRn \ tycon' -> + bindTyVarsFVRn data_doc tyvars $\ tyvars' -> + rnContext data_doc context thenRn \ (context', cxt_fvs) -> + checkDupOrQualNames data_doc con_names thenRn_ + mapFvRn rnConDecl condecls thenRn \ (condecls', con_fvs) -> + rnDerivs derivings thenRn \ (derivings', deriv_fvs) -> ASSERT(isNoDataPragmas pragmas) - returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc), + returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls' + derivings' noDataPragmas src_loc), cxt_fvs plusFV con_fvs plusFV deriv_fvs) where data_doc = text "the data type declaration for" <+> quotes (ppr tycon) @@ -156,7 +158,8 @@ rnDecl (TyClD (TySynonym name tyvars ty src_loc)) where syn_doc = text "the declaration for type synonym" <+> quotes (ppr name) -rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname snames src_loc)) +rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas + tname dname snames src_loc)) = pushSrcLocRn src_loc$ lookupBndrRn cname thenRn \ cname' -> @@ -173,10 +176,10 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname sn mapRn mkImportedGlobalFromRdrName snames thenRn \ snames' -> -- Tyvars scope over bindings and context - bindTyVarsFV2Rn cls_doc tyvars ( \ clas_tyvar_names tyvars' -> + bindTyVarsFV2Rn cls_doc tyvars ( \ clas_tyvar_names tyvars' -> -- Check the superclasses - rnContext cls_doc context thenRn \ (context', cxt_fvs) -> + rnContext cls_doc context thenRn \ (context', cxt_fvs) -> -- Check the signatures let @@ -185,16 +188,19 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname sn (fix_sigs, non_sigs) = partition isFixitySig non_op_sigs in checkDupOrQualNames sig_doc sig_rdr_names_w_locs thenRn_ - mapFvRn (rn_op cname' clas_tyvar_names) op_sigs thenRn \ (sigs', sig_fvs) -> + mapFvRn (rn_op cname' clas_tyvar_names) op_sigs + thenRn \ (sigs', sig_fvs) -> mapRn_ (unknownSigErr) non_sigs thenRn_ let binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ] in - renameSigs False binders lookupOccRn fix_sigs thenRn \ (fixs', fix_fvs) -> + renameSigs False binders lookupOccRn fix_sigs + thenRn \ (fixs', fix_fvs) -> -- Check the methods checkDupOrQualNames meth_doc meth_rdr_names_w_locs thenRn_ - rnMethodBinds mbinds thenRn \ (mbinds', meth_fvs) -> + rnMethodBinds mbinds + thenRn \ (mbinds', meth_fvs) -> -- Typechecker is responsible for checking that we only -- give default-method bindings for things in this class. @@ -202,8 +208,8 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname sn -- for instance decls. ASSERT(isNoClassPragmas pragmas) - returnRn (TyClD (ClassDecl context' cname' tyvars' (fixs' ++ sigs') - mbinds' NoClassPragmas tname' dname' snames' src_loc), + returnRn (TyClD (ClassDecl context' cname' tyvars' (fixs' ++ sigs') mbinds' + NoClassPragmas tname' dname' snames' src_loc), sig_fvs plusFV fix_fvs plusFV cxt_fvs plusFV @@ -226,8 +232,9 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname sn -- Check the signature rnHsSigType (quotes (ppr op)) ty thenRn \ (new_ty, op_ty_fvs) -> let - check_in_op_ty clas_tyvar = checkRn (clas_tyvar elemNameSet op_ty_fvs) - (classTyVarNotInOpTyErr clas_tyvar sig) + check_in_op_ty clas_tyvar = + checkRn (clas_tyvar elemNameSet op_ty_fvs) + (classTyVarNotInOpTyErr clas_tyvar sig) in mapRn_ check_in_op_ty clas_tyvars thenRn_ @@ -236,9 +243,10 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname sn (case (mode, maybe_dm) of (SourceMode, _) | op elem meth_rdr_names - -> -- Source class decl with an explicit method decl - newImplicitBinder (mkDefaultMethodOcc (rdrNameOcc op)) locn thenRn \ dm_name -> - returnRn (Just dm_name, emptyFVs) + -> -- Source class decl with an explicit method decl + newImplicitBinder (mkDefaultMethodOcc (rdrNameOcc op)) locn + thenRn \ dm_name -> + returnRn (Just dm_name, emptyFVs) | otherwise -> -- Source class dec, no explicit method decl @@ -247,7 +255,7 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname sn (InterfaceMode, Just dm_rdr_name) -> -- Imported class that has a default method decl -- See comments with tname, snames, above - lookupImplicitOccRn dm_rdr_name thenRn \ dm_name -> + lookupImplicitOccRn dm_rdr_name thenRn \ dm_name -> returnRn (Just dm_name, unitFV dm_name) -- An imported class decl mentions, rather than defines, -- the default method, so we must arrange to pull it in @@ -270,7 +278,7 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname sn \begin{code} rnDecl (InstD (InstDecl inst_ty mbinds uprags dfun_rdr_name src_loc)) = pushSrcLocRn src_loc $- rnHsSigType (text "an instance decl") inst_ty thenRn \ (inst_ty', inst_fvs) -> + rnHsSigType (text "an instance decl") inst_ty thenRn \ (inst_ty', inst_fvs) -> let inst_tyvars = case inst_ty' of HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars @@ -314,13 +322,15 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags dfun_rdr_name src_loc)) getModeRn thenRn \ mode -> (case mode of - InterfaceMode -> lookupImplicitOccRn dfun_rdr_name thenRn \ dfun_name -> + InterfaceMode -> lookupImplicitOccRn dfun_rdr_name thenRn \ dfun_name -> returnRn (dfun_name, unitFV dfun_name) - SourceMode -> newDFunName (getDFunKey inst_ty') src_loc thenRn \ dfun_name -> + SourceMode -> newDFunName (getDFunKey inst_ty') src_loc + thenRn \ dfun_name -> returnRn (dfun_name, emptyFVs) - ) thenRn \ (dfun_name, dfun_fv) -> + ) + thenRn \ (dfun_name, dfun_fv) -> - -- The typechecker checks that all the bindings are for the right class. + -- The typechecker checks that all the bindings are for the right class. returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags dfun_name src_loc), inst_fvs plusFV meth_fvs plusFV prag_fvs plusFV dfun_fv) where @@ -535,9 +545,9 @@ rnHsSigType doc_str ty = rnHsType (text "the type signature for" <+> doc_str) ty rnForAll doc forall_tyvars ctxt ty - = bindTyVarsFVRn doc forall_tyvars$ \ new_tyvars -> - rnContext doc ctxt thenRn \ (new_ctxt, cxt_fvs) -> - rnHsType doc ty thenRn \ (new_ty, ty_fvs) -> + = bindTyVarsFVRn doc forall_tyvars \$ \ new_tyvars -> + rnContext doc ctxt thenRn \ (new_ctxt, cxt_fvs) -> + rnHsType doc ty thenRn \ (new_ty, ty_fvs) -> returnRn (mkHsForAllTy new_tyvars new_ctxt new_ty, cxt_fvs plusFV ty_fvs) @@ -552,8 +562,8 @@ checkConstraints explicit_forall doc forall_tyvars ctxt ty where check ct@(_,tys) | forall_mentioned = returnRn (Just ct) - | otherwise = addErrRn (ctxtErr explicit_forall doc forall_tyvars ct ty) thenRn_ - returnRn Nothing + | otherwise = addErrRn (ctxtErr explicit_forall doc forall_tyvars ct ty) + thenRn_ returnRn Nothing where forall_mentioned = foldr ((||) . any (elem forall_tyvars) . extractHsTyRdrNames) False @@ -664,9 +674,9 @@ rnContext doc ctxt %********************************************************* -%* * +%* * \subsection{IdInfo} -%* * +%* * %********************************************************* \begin{code} @@ -676,14 +686,15 @@ rnIdInfo (HsWorker worker) = lookupOccRn worker thenRn \ worker' -> returnRn (HsWorker worker', unitFV worker') -rnIdInfo (HsUnfold inline (Just expr)) = rnCoreExpr expr thenRn \ (expr', fvs) -> +rnIdInfo (HsUnfold inline (Just expr)) = rnCoreExpr expr thenRn \ (expr', fvs) -> returnRn (HsUnfold inline (Just expr'), fvs) rnIdInfo (HsUnfold inline Nothing) = returnRn (HsUnfold inline Nothing, emptyFVs) rnIdInfo (HsArity arity) = returnRn (HsArity arity, emptyFVs) rnIdInfo (HsUpdate update) = returnRn (HsUpdate update, emptyFVs) rnIdInfo (HsNoCafRefs) = returnRn (HsNoCafRefs, emptyFVs) rnIdInfo (HsCprInfo cpr_info) = returnRn (HsCprInfo cpr_info, emptyFVs) -rnIdInfo (HsSpecialise rule_body) = rnRuleBody rule_body thenRn \ (rule_body', fvs) -> +rnIdInfo (HsSpecialise rule_body) = rnRuleBody rule_body + thenRn \ (rule_body', fvs) -> returnRn (HsSpecialise rule_body', fvs) rnRuleBody (UfRuleBody str vars args rhs) @@ -693,7 +704,7 @@ rnRuleBody (UfRuleBody str vars args rhs) returnRn (UfRuleBody str vars' args' rhs', fvs1 plusFV` fvs2) \end{code} -UfCore expressions. +@UfCore@ expressions. \begin{code} rnCoreExpr (UfType ty) @@ -815,14 +826,14 @@ rnUfCon (UfCCallOp str is_dyn casm gc) \end{code} %********************************************************* -%* * +%* * \subsection{Rule shapes} -%* * +%* * %********************************************************* Check the shape of a transformation rule LHS. Currently -we only allow LHSs of the form (f e1 .. en), where f is -not one of the forall'd variables. +we only allow LHSs of the form @(f e1 .. en)@, where @f@ is +not one of the @forall@'d variables. \begin{code} validRuleLhs foralls lhs @@ -835,9 +846,9 @@ validRuleLhs foralls lhs %********************************************************* -%* * +%* * \subsection{Errors} -%* * +%* * %********************************************************* \begin{code} @@ -886,7 +897,8 @@ forAllErr doc ty tyvar (ptext SLIT("In") <+> doc)) ctxtErr explicit_forall doc tyvars constraint ty - = sep [ptext SLIT("None of the type variable(s) in the constraint") <+> quotes (pprClassAssertion constraint), + = sep [ptext SLIT("None of the type variable(s) in the constraint") + <+> quotes (pprClassAssertion constraint), if explicit_forall then nest 4 (ptext SLIT("is universally quantified (i.e. bound by the forall)")) else diff --git a/ghc/compiler/rename/rename.tex b/ghc/compiler/rename/rename.tex new file mode 100644 index 0000000000000000000000000000000000000000..b3f8e1d770a5ba16cda7d54dccc57c5343e4c0c3 --- /dev/null +++ b/ghc/compiler/rename/rename.tex @@ -0,0 +1,18 @@ +\documentstyle{report} +\input{lit-style} + +\begin{document} +\centerline{{\Large{rename}}} +\tableofcontents + +\input{Rename} % {Renaming and dependency analysis passes} +\input{RnSource} % {Main pass of renamer} +\input{RnMonad} % {The monad used by the renamer} +\input{RnEnv} % {Environment manipulation for the renamer monad} +\input{RnHsSyn} % {Specialisations of the @HsSyn@ syntax for the renamer} +\input{RnNames} % {Extracting imported and top-level names in scope} +\input{RnExpr} % {Renaming of expressions} +\input{RnBinds} % {Renaming and dependency analysis of bindings} +\input{RnIfaces} % {Cacheing and Renaming of Interfaces} + +\end{document}