Comment cleanup and literisation(?) by Wolfram Kahl <kahl@DI.Unipi.IT>.
% (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
%
% Author: Juan J. Quintela <quintela@krilin.dc.fi.udc.es>
+\section{Module @Check@ in @deSugar@}
\begin{code}
\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
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
\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}
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}
\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.
\end{code}
This function splits the equations @qs@ in groups that deal with the
-same constructor
+same constructor.
\begin{code}
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}
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
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
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
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)
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}
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
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 ->
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' ->
-- 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
worthSCC core_expr = True
\end{code}
-If profiling and dealing with a dict binding, wrap the dict in "_scc_ DICT <dict>":
+If profiling and dealing with a dict binding,
+wrap the dict in @_scc_ DICT <dict>@:
\begin{code}
addDictScc var rhs = returnDs rhs
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}
%* *
%************************************************************************
-@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.
-- 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 $
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
%* *
%************************************************************************
-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.
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)
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)
\end{code}
-Type lambda and application
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\noindent
+\underline{\bf Type lambda and application}
+% ~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
dsExpr (TyLam tyvars expr)
= dsExpr expr `thenDs` \ core_expr ->
\end{code}
-Various data construction things
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\noindent
+\underline{\bf Various data construction things}
+% ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
dsExpr (ExplicitListOut ty xs)
= go xs
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)
\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
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.
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.
= 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)
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
= 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]
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}
-> [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
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
\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
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
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)
\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.
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
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
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
\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]
\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)
%************************************************************************
%* *
-%* type synonym EquationInfo and access functions for its pieces *
+\subsection{Type synonym @EquationInfo@ and access functions for its pieces}
%* *
%************************************************************************
%************************************************************************
%* *
-%* Building lets
+\subsection{ Building lets}
%* *
%************************************************************************
%************************************************************************
%* *
-%* Selecting match variables
+\subsection{ Selecting match variables}
%* *
%************************************************************************
-- 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
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
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
| 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
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
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
\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
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
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?)
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 ()
= 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:
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
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
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
| 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
--- /dev/null
+\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}
-%\r
-% (c) The GRASP Project, Glasgow University, 1992-1998\r
-%\r
-\section[Rename]{Renaming and dependency analysis passes}\r
-\r
-\begin{code}\r
-module Rename ( renameModule ) where\r
-\r
-#include "HsVersions.h"\r
-\r
-import HsSyn\r
-import RdrHsSyn ( RdrNameHsModule )\r
-import RnHsSyn ( RenamedHsModule, RenamedHsDecl, \r
- extractHsTyNames, extractHsCtxtTyNames\r
- )\r
-\r
-import CmdLineOpts ( opt_HiMap, opt_D_dump_rn_trace,\r
- opt_D_dump_rn, opt_D_dump_rn_stats,\r
- opt_WarnUnusedBinds, opt_WarnUnusedImports\r
- )\r
-import RnMonad\r
-import RnNames ( getGlobalNames )\r
-import RnSource ( rnSourceDecls, rnDecl )\r
-import RnIfaces ( getImportedInstDecls, importDecl, getImportVersions,\r
- getImportedRules, loadHomeInterface, getSlurped\r
- )\r
-import RnEnv ( availName, availNames, availsToNameSet, \r
- warnUnusedTopNames, mapFvRn,\r
- FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs\r
- )\r
-import Module ( Module, ModuleName, pprModule, mkSearchPath, mkThisModule )\r
-import Name ( Name, isLocallyDefined,\r
- NamedThing(..), ImportReason(..), Provenance(..),\r
- pprOccName, nameOccName,\r
- getNameProvenance, occNameUserString, \r
- maybeWiredInTyConName, maybeWiredInIdName, isWiredInName\r
- )\r
-import Id ( idType )\r
-import DataCon ( dataConTyCon, dataConType )\r
-import TyCon ( TyCon, tyConDataCons, isSynTyCon, getSynTyConDefn )\r
-import RdrName ( RdrName )\r
-import NameSet\r
-import PrelMods ( mAIN_Name, pREL_MAIN_Name )\r
-import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon, boolTyCon )\r
-import PrelInfo ( ioTyCon_NAME, thinAirIdNames )\r
-import Type ( namesOfType, funTyCon )\r
-import ErrUtils ( pprBagOfErrors, pprBagOfWarnings,\r
- doIfSet, dumpIfSet, ghcExit\r
- )\r
-import BasicTypes ( NewOrData(..) )\r
-import Bag ( isEmptyBag, bagToList )\r
-import FiniteMap ( fmToList, delListFromFM, addToFM, sizeFM, eltsFM )\r
-import UniqSupply ( UniqSupply )\r
-import Util ( equivClasses )\r
-import Maybes ( maybeToBool )\r
-import Outputable\r
-\end{code}\r
-\r
-\r
-\r
-\begin{code}\r
-renameModule :: UniqSupply\r
- -> RdrNameHsModule\r
- -> IO (Maybe \r
- ( Module\r
- , RenamedHsModule -- Output, after renaming\r
- , InterfaceDetails -- Interface; for interface file generation\r
- , RnNameSupply -- Final env; for renaming derivings\r
- , [ModuleName] -- Imported modules; for profiling\r
- ))\r
-\r
-renameModule us this_mod@(HsModule mod_name vers exports imports local_decls loc)\r
- = -- Initialise the renamer monad\r
- initRn mod_name us (mkSearchPath opt_HiMap) loc\r
- (rename this_mod) >>=\r
- \ (maybe_rn_stuff, rn_errs_bag, rn_warns_bag) ->\r
-\r
- -- Check for warnings\r
- doIfSet (not (isEmptyBag rn_warns_bag))\r
- (printErrs (pprBagOfWarnings rn_warns_bag)) >>\r
-\r
- -- Check for errors; exit if so\r
- doIfSet (not (isEmptyBag rn_errs_bag))\r
- (printErrs (pprBagOfErrors rn_errs_bag) >>\r
- ghcExit 1\r
- ) >>\r
-\r
- -- Dump output, if any\r
- (case maybe_rn_stuff of\r
- Nothing -> return ()\r
- Just results@(_, rn_mod, _, _, _)\r
- -> dumpIfSet opt_D_dump_rn "Renamer:"\r
- (ppr rn_mod)\r
- ) >>\r
-\r
- -- Return results\r
- return maybe_rn_stuff\r
-\end{code}\r
-\r
-\r
-\begin{code}\r
-rename this_mod@(HsModule mod_name vers exports imports local_decls loc)\r
- = -- FIND THE GLOBAL NAME ENVIRONMENT\r
- getGlobalNames this_mod `thenRn` \ maybe_stuff ->\r
-\r
- -- CHECK FOR EARLY EXIT\r
- if not (maybeToBool maybe_stuff) then\r
- -- Everything is up to date; no need to recompile further\r
- rnStats [] `thenRn_`\r
- returnRn Nothing\r
- else\r
- let\r
- Just (export_env, gbl_env, fixity_env, global_avail_env) = maybe_stuff\r
- in\r
-\r
- -- RENAME THE SOURCE\r
- initRnMS gbl_env fixity_env SourceMode (\r
- rnSourceDecls local_decls\r
- ) `thenRn` \ (rn_local_decls, source_fvs) ->\r
-\r
- -- SLURP IN ALL THE NEEDED DECLARATIONS\r
- let\r
- real_source_fvs = implicitFVs mod_name `plusFV` source_fvs\r
- -- It's important to do the "plus" this way round, so that\r
- -- when compiling the prelude, locally-defined (), Bool, etc\r
- -- override the implicit ones. \r
- in\r
- slurpImpDecls real_source_fvs `thenRn` \ rn_imp_decls ->\r
-\r
- -- EXIT IF ERRORS FOUND\r
- checkErrsRn `thenRn` \ no_errs_so_far ->\r
- if not no_errs_so_far then\r
- -- Found errors already, so exit now\r
- rnStats [] `thenRn_`\r
- returnRn Nothing\r
- else\r
-\r
- -- GENERATE THE VERSION/USAGE INFO\r
- getImportVersions mod_name exports `thenRn` \ my_usages ->\r
- getNameSupplyRn `thenRn` \ name_supply ->\r
-\r
- -- REPORT UNUSED NAMES\r
- reportUnusedNames gbl_env global_avail_env\r
- export_env\r
- source_fvs `thenRn_`\r
-\r
- -- RETURN THE RENAMED MODULE\r
- let\r
- has_orphans = any isOrphanDecl rn_local_decls\r
- direct_import_mods = [mod | ImportDecl mod _ _ _ _ _ <- imports]\r
- rn_all_decls = rn_imp_decls ++ rn_local_decls \r
- renamed_module = HsModule mod_name vers \r
- trashed_exports trashed_imports\r
- rn_all_decls\r
- loc\r
- in\r
- rnStats rn_imp_decls `thenRn_`\r
- returnRn (Just (mkThisModule mod_name,\r
- renamed_module, \r
- (has_orphans, my_usages, export_env),\r
- name_supply,\r
- direct_import_mods))\r
- where\r
- trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing\r
- trashed_imports = {-trace "rnSource:trashed_imports"-} []\r
-\end{code}\r
-\r
-@implicitFVs@ forces the renamer to slurp in some things which aren't\r
-mentioned explicitly, but which might be needed by the type checker.\r
-\r
-\begin{code}\r
-implicitFVs mod_name\r
- = implicit_main `plusFV` \r
- mkNameSet default_tys `plusFV`\r
- mkNameSet thinAirIdNames\r
- where\r
- -- Add occurrences for Int, Double, and (), because they\r
- -- are the types to which ambigious type variables may be defaulted by\r
- -- the type checker; so they won't always appear explicitly.\r
- -- [The () one is a GHC extension for defaulting CCall results.]\r
- -- ALSO: funTyCon, since it occurs implicitly everywhere!\r
- -- (we don't want to be bothered with making funTyCon a\r
- -- free var at every function application!)\r
- default_tys = [getName intTyCon, getName doubleTyCon,\r
- getName unitTyCon, getName funTyCon, getName boolTyCon]\r
-\r
- -- Add occurrences for IO or PrimIO\r
- implicit_main | mod_name == mAIN_Name\r
- || mod_name == pREL_MAIN_Name = unitFV ioTyCon_NAME\r
- | otherwise = emptyFVs\r
-\end{code}\r
-\r
-\begin{code}\r
-isOrphanDecl (InstD (InstDecl inst_ty _ _ _ _))\r
- = not (foldNameSet ((||) . isLocallyDefined) False (extractHsTyNames inst_ty))\r
-isOrphanDecl (RuleD (RuleDecl _ _ _ lhs _ _))\r
- = check lhs\r
- where\r
- check (HsVar v) = not (isLocallyDefined v)\r
- check (HsApp f a) = check f && check a\r
- check other = True\r
-isOrphanDecl other = False\r
-\end{code}\r
-\r
-\r
-%*********************************************************\r
-%* *\r
-\subsection{Slurping declarations}\r
-%* *\r
-%*********************************************************\r
-\r
-\begin{code}\r
--------------------------------------------------------\r
-slurpImpDecls source_fvs\r
- = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenRn_`\r
-\r
- -- The current slurped-set records all local things\r
- getSlurped `thenRn` \ source_binders ->\r
- slurpSourceRefs source_binders source_fvs `thenRn` \ (decls1, needed1, inst_gates) ->\r
-\r
- -- Now we can get the instance decls\r
- slurpInstDecls decls1 needed1 inst_gates `thenRn` \ (decls2, needed2) ->\r
-\r
- -- And finally get everything else\r
- closeDecls decls2 needed2\r
-\r
--------------------------------------------------------\r
-slurpSourceRefs :: NameSet -- Variables defined in source\r
- -> FreeVars -- Variables referenced in source\r
- -> RnMG ([RenamedHsDecl],\r
- FreeVars, -- Un-satisfied needs\r
- FreeVars) -- "Gates"\r
--- The declaration (and hence home module) of each gate has\r
--- already been loaded\r
-\r
-slurpSourceRefs source_binders source_fvs\r
- = go [] -- Accumulating decls\r
- emptyFVs -- Unsatisfied needs\r
- source_fvs -- Accumulating gates\r
- (nameSetToList source_fvs) -- Gates whose defn hasn't been loaded yet\r
- where\r
- go decls fvs gates []\r
- = returnRn (decls, fvs, gates)\r
-\r
- go decls fvs gates (wanted_name:refs) \r
- | isWiredInName wanted_name\r
- = load_home wanted_name `thenRn_`\r
- go decls fvs (gates `plusFV` getWiredInGates wanted_name) refs\r
-\r
- | otherwise\r
- = importDecl wanted_name `thenRn` \ maybe_decl ->\r
- case maybe_decl of\r
- -- No declaration... (already slurped, or local)\r
- Nothing -> go decls fvs gates refs\r
- Just decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) ->\r
- let\r
- new_gates = getGates source_fvs new_decl\r
- in\r
- go (new_decl : decls)\r
- (fvs1 `plusFV` fvs)\r
- (gates `plusFV` new_gates)\r
- (nameSetToList new_gates ++ refs)\r
-\r
- -- When we find a wired-in name we must load its\r
- -- home module so that we find any instance decls therein\r
- load_home name \r
- | name `elemNameSet` source_binders = returnRn ()\r
- -- When compiling the prelude, a wired-in thing may\r
- -- be defined in this module, in which case we don't\r
- -- want to load its home module!\r
- -- Using 'isLocallyDefined' doesn't work because some of\r
- -- the free variables returned are simply 'listTyCon_Name',\r
- -- with a system provenance. We could look them up every time\r
- -- but that seems a waste.\r
- | otherwise = loadHomeInterface doc name `thenRn_`\r
- returnRn ()\r
- where\r
- doc = ptext SLIT("need home module for wired in thing") <+> ppr name\r
-\r
--------------------------------------------------------\r
--- slurpInstDecls imports appropriate instance decls.\r
--- It has to incorporate a loop, because consider\r
--- instance Foo a => Baz (Maybe a) where ...\r
--- It may be that Baz and Maybe are used in the source module,\r
--- but not Foo; so we need to chase Foo too.\r
-\r
-slurpInstDecls decls needed gates\r
- | isEmptyFVs gates\r
- = returnRn (decls, needed)\r
-\r
- | otherwise\r
- = getImportedInstDecls gates `thenRn` \ inst_decls ->\r
- rnInstDecls decls needed emptyFVs inst_decls `thenRn` \ (decls1, needed1, gates1) ->\r
- slurpInstDecls decls1 needed1 gates1\r
- where\r
- rnInstDecls decls fvs gates []\r
- = returnRn (decls, fvs, gates)\r
- rnInstDecls decls fvs gates (d:ds) \r
- = rnIfaceDecl d `thenRn` \ (new_decl, fvs1) ->\r
- rnInstDecls (new_decl:decls) \r
- (fvs1 `plusFV` fvs)\r
- (gates `plusFV` getInstDeclGates new_decl)\r
- ds\r
- \r
-\r
--------------------------------------------------------\r
--- closeDecls keeps going until the free-var set is empty\r
-closeDecls decls needed\r
- | not (isEmptyFVs needed)\r
- = slurpDecls decls needed `thenRn` \ (decls1, needed1) ->\r
- closeDecls decls1 needed1\r
-\r
- | otherwise\r
- = getImportedRules `thenRn` \ rule_decls ->\r
- case rule_decls of\r
- [] -> returnRn decls -- No new rules, so we are done\r
- other -> rnIfaceDecls decls emptyFVs rule_decls `thenRn` \ (decls1, needed1) ->\r
- closeDecls decls1 needed1\r
- \r
-\r
--------------------------------------------------------\r
-rnIfaceDecls :: [RenamedHsDecl] -> FreeVars\r
- -> [(Module, RdrNameHsDecl)]\r
- -> RnM d ([RenamedHsDecl], FreeVars)\r
-rnIfaceDecls decls fvs [] = returnRn (decls, fvs)\r
-rnIfaceDecls decls fvs (d:ds) = rnIfaceDecl d `thenRn` \ (new_decl, fvs1) ->\r
- rnIfaceDecls (new_decl:decls) (fvs1 `plusFV` fvs) ds\r
-\r
-rnIfaceDecl (mod, decl) = initIfaceRnMS mod (rnDecl decl) \r
- \r
-\r
--------------------------------------------------------\r
--- Augment decls with any decls needed by needed.\r
--- Return also free vars of the new decls (only)\r
-slurpDecls decls needed\r
- = go decls emptyFVs (nameSetToList needed) \r
- where\r
- go decls fvs [] = returnRn (decls, fvs)\r
- go decls fvs (ref:refs) = slurpDecl decls fvs ref `thenRn` \ (decls1, fvs1) ->\r
- go decls1 fvs1 refs\r
-\r
--------------------------------------------------------\r
-slurpDecl decls fvs wanted_name\r
- = importDecl wanted_name `thenRn` \ maybe_decl ->\r
- case maybe_decl of\r
- -- No declaration... (wired in thing)\r
- Nothing -> returnRn (decls, fvs)\r
-\r
- -- Found a declaration... rename it\r
- Just decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) ->\r
- returnRn (new_decl:decls, fvs1 `plusFV` fvs)\r
-\end{code}\r
-\r
-\r
-%*********************************************************\r
-%* *\r
-\subsection{Extracting the 'gates'}\r
-%* *\r
-%*********************************************************\r
-\r
-When we import a declaration like\r
-\r
- data T = T1 Wibble | T2 Wobble\r
-\r
-we don't want to treat Wibble and Wobble as gates *unless* T1, T2\r
-respectively are mentioned by the user program. If only T is mentioned\r
-we want only T to be a gate; that way we don't suck in useless instance\r
-decls for (say) Eq Wibble, when they can't possibly be useful.\r
-\r
-@getGates@ takes a newly imported (and renamed) decl, and the free\r
-vars of the source program, and extracts from the decl the gate names.\r
-\r
-\begin{code}\r
-getGates source_fvs (SigD (IfaceSig _ ty _ _))\r
- = extractHsTyNames ty\r
-\r
-getGates source_fvs (TyClD (ClassDecl ctxt cls tvs sigs _ _ _ _ _ _))\r
- = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)\r
- (map getTyVarName tvs)\r
- `addOneToNameSet` cls\r
- where\r
- get (ClassOpSig n _ ty _) \r
- | n `elemNameSet` source_fvs = extractHsTyNames ty\r
- | otherwise = emptyFVs\r
-\r
-getGates source_fvs (TyClD (TySynonym tycon tvs ty _))\r
- = delListFromNameSet (extractHsTyNames ty)\r
- (map getTyVarName tvs)\r
- -- A type synonym type constructor isn't a "gate" for instance decls\r
-\r
-getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _))\r
- = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons)\r
- (map getTyVarName tvs)\r
- `addOneToNameSet` tycon\r
- where\r
- get (ConDecl n tvs ctxt details _)\r
- | n `elemNameSet` source_fvs\r
- -- If the constructor is method, get fvs from all its fields\r
- = delListFromNameSet (get_details details `plusFV` \r
- extractHsCtxtTyNames ctxt)\r
- (map getTyVarName tvs)\r
- get (ConDecl n tvs ctxt (RecCon fields) _)\r
- -- Even if the constructor isn't mentioned, the fields\r
- -- might be, as selectors. They can't mention existentially\r
- -- bound tyvars (typechecker checks for that) so no need for \r
- -- the deleteListFromNameSet part\r
- = foldr (plusFV . get_field) emptyFVs fields\r
- \r
- get other_con = emptyFVs\r
-\r
- get_details (VanillaCon tys) = plusFVs (map get_bang tys)\r
- get_details (InfixCon t1 t2) = get_bang t1 `plusFV` get_bang t2\r
- get_details (RecCon fields) = plusFVs [get_bang t | (_, t) <- fields]\r
- get_details (NewCon t _) = extractHsTyNames t\r
-\r
- get_field (fs,t) | any (`elemNameSet` source_fvs) fs = get_bang t\r
- | otherwise = emptyFVs\r
-\r
- get_bang (Banged t) = extractHsTyNames t\r
- get_bang (Unbanged t) = extractHsTyNames t\r
- get_bang (Unpacked t) = extractHsTyNames t\r
-\r
-getGates source_fvs other_decl = emptyFVs\r
-\end{code}\r
-\r
-getWiredInGates is just like getGates, but it sees a wired-in Name\r
-rather than a declaration.\r
-\r
-\begin{code}\r
-getWiredInGates :: Name -> FreeVars\r
-getWiredInGates name -- No classes are wired in\r
- | is_id = getWiredInGates_s (namesOfType (idType the_id))\r
- | isSynTyCon the_tycon = getWiredInGates_s (delListFromNameSet (namesOfType ty) (map getName tyvars))\r
- | otherwise = unitFV name\r
- where\r
- maybe_wired_in_id = maybeWiredInIdName name\r
- is_id = maybeToBool maybe_wired_in_id\r
- maybe_wired_in_tycon = maybeWiredInTyConName name\r
- Just the_id = maybe_wired_in_id\r
- Just the_tycon = maybe_wired_in_tycon\r
- (tyvars,ty) = getSynTyConDefn the_tycon\r
-\r
-getWiredInGates_s names = foldr (plusFV . getWiredInGates) emptyFVs (nameSetToList names)\r
-\end{code}\r
-\r
-\begin{code}\r
-getInstDeclGates (InstD (InstDecl inst_ty _ _ _ _)) = extractHsTyNames inst_ty\r
-getInstDeclGates other = emptyFVs\r
-\end{code}\r
-\r
-\r
-%*********************************************************\r
-%* *\r
-\subsection{Unused names}\r
-%* *\r
-%*********************************************************\r
-\r
-\begin{code}\r
-reportUnusedNames gbl_env avail_env (ExportEnv export_avails _) mentioned_names\r
- | not (opt_WarnUnusedBinds || opt_WarnUnusedImports)\r
- = returnRn ()\r
-\r
- | otherwise\r
- = let\r
- used_names = mentioned_names `unionNameSets` availsToNameSet export_avails\r
-\r
- -- Now, a use of C implies a use of T,\r
- -- if C was brought into scope by T(..) or T(C)\r
- really_used_names = used_names `unionNameSets`\r
- mkNameSet [ availName avail \r
- | sub_name <- nameSetToList used_names,\r
- let avail = case lookupNameEnv avail_env sub_name of\r
- Just avail -> avail\r
- Nothing -> pprTrace "r.u.n" (ppr sub_name) $\r
- Avail sub_name\r
- ]\r
-\r
- defined_names = mkNameSet (concat (rdrEnvElts gbl_env))\r
- defined_but_not_used = nameSetToList (defined_names `minusNameSet` really_used_names)\r
-\r
- -- Filter out the ones only defined implicitly\r
- bad_guys = filter reportableUnusedName defined_but_not_used\r
- in\r
- warnUnusedTopNames bad_guys `thenRn_`\r
- returnRn ()\r
-\r
-reportableUnusedName :: Name -> Bool\r
-reportableUnusedName name\r
- = explicitlyImported (getNameProvenance name) &&\r
- not (startsWithUnderscore (occNameUserString (nameOccName name)))\r
- where\r
- explicitlyImported (LocalDef _ _) = True -- Report unused defns of local vars\r
- explicitlyImported (NonLocalDef (UserImport _ _ expl) _) = expl -- Report unused explicit imports\r
- explicitlyImported other = False -- Don't report others\r
- \r
- -- Haskell 98 encourages compilers to suppress warnings about\r
- -- unused names in a pattern if they start with "_".\r
- startsWithUnderscore ('_' : _) = True -- Suppress warnings for names starting\r
- startsWithUnderscore other = False -- with an underscore\r
-\r
-rnStats :: [RenamedHsDecl] -> RnMG ()\r
-rnStats imp_decls\r
- | opt_D_dump_rn_trace || \r
- opt_D_dump_rn_stats ||\r
- opt_D_dump_rn \r
- = getRnStats imp_decls `thenRn` \ msg ->\r
- ioToRnM (printErrs msg) `thenRn_`\r
- returnRn ()\r
-\r
- | otherwise = returnRn ()\r
-\end{code}\r
-\r
-\r
-\r
-%*********************************************************\r
-%* *\r
-\subsection{Statistics}\r
-%* *\r
-%*********************************************************\r
-\r
-\begin{code}\r
-getRnStats :: [RenamedHsDecl] -> RnMG SDoc\r
-getRnStats imported_decls\r
- = getIfacesRn `thenRn` \ ifaces ->\r
- let\r
- n_mods = length [() | (_, _, Just _) <- eltsFM (iImpModInfo ifaces)]\r
-\r
- decls_read = [decl | (_, avail, True, (_,decl)) <- nameEnvElts (iDecls ifaces),\r
- -- Data, newtype, and class decls are in the decls_fm\r
- -- under multiple names; the tycon/class, and each\r
- -- constructor/class op too.\r
- -- The 'True' selects just the 'main' decl\r
- not (isLocallyDefined (availName avail))\r
- ]\r
-\r
- (cd_rd, dd_rd, nd_rd, sd_rd, vd_rd, _) = count_decls decls_read\r
- (cd_sp, dd_sp, nd_sp, sd_sp, vd_sp, id_sp) = count_decls imported_decls\r
-\r
- unslurped_insts = iInsts ifaces\r
- inst_decls_unslurped = length (bagToList unslurped_insts)\r
- inst_decls_read = id_sp + inst_decls_unslurped\r
-\r
- stats = vcat \r
- [int n_mods <+> text "interfaces read",\r
- hsep [ int cd_sp, text "class decls imported, out of", \r
- int cd_rd, text "read"],\r
- hsep [ int dd_sp, text "data decls imported, out of", \r
- int dd_rd, text "read"],\r
- hsep [ int nd_sp, text "newtype decls imported, out of", \r
- int nd_rd, text "read"],\r
- hsep [int sd_sp, text "type synonym decls imported, out of", \r
- int sd_rd, text "read"],\r
- hsep [int vd_sp, text "value signatures imported, out of", \r
- int vd_rd, text "read"],\r
- hsep [int id_sp, text "instance decls imported, out of", \r
- int inst_decls_read, text "read"],\r
- text "cls dcls slurp" <+> fsep (map (ppr . tyClDeclName) \r
- [d | TyClD d <- imported_decls, isClassDecl d]),\r
- text "cls dcls read" <+> fsep (map (ppr . tyClDeclName) \r
- [d | TyClD d <- decls_read, isClassDecl d])]\r
- in\r
- returnRn (hcat [text "Renamer stats: ", stats])\r
-\r
-count_decls decls\r
- = (class_decls, \r
- data_decls, \r
- newtype_decls,\r
- syn_decls, \r
- val_decls, \r
- inst_decls)\r
- where\r
- tycl_decls = [d | TyClD d <- decls]\r
- (class_decls, data_decls, newtype_decls, syn_decls) = countTyClDecls tycl_decls\r
-\r
- val_decls = length [() | SigD _ <- decls]\r
- inst_decls = length [() | InstD _ <- decls]\r
-\end{code} \r
-\r
+%
+% (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}
+
-%\r
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998\r
-%\r
-\section[RnBinds]{Renaming and dependency analysis of bindings}\r
-\r
-This module does renaming and dependency analysis on value bindings in\r
-the abstract syntax. It does {\em not} do cycle-checks on class or\r
-type-synonym declarations; those cannot be done at this stage because\r
-they may be affected by renaming (which isn't fully worked out yet).\r
-\r
-\begin{code}\r
-module RnBinds (\r
- rnTopBinds, rnTopMonoBinds,\r
- rnMethodBinds, renameSigs,\r
- rnBinds,\r
- unknownSigErr\r
- ) where\r
-\r
-#include "HsVersions.h"\r
-\r
-import {-# SOURCE #-} RnSource ( rnHsSigType )\r
-\r
-import HsSyn\r
-import HsBinds ( sigsForMe )\r
-import RdrHsSyn\r
-import RnHsSyn\r
-import RnMonad\r
-import RnExpr ( rnMatch, rnGRHSs, rnPat, checkPrecMatch )\r
-import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupGlobalOccRn,\r
- warnUnusedLocalBinds, mapFvRn, \r
- FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV,\r
- unknownNameErr\r
- )\r
-import CmdLineOpts ( opt_WarnMissingSigs )\r
-import Digraph ( stronglyConnComp, SCC(..) )\r
-import Name ( OccName, Name, nameOccName )\r
-import NameSet\r
-import RdrName ( RdrName, rdrNameOcc )\r
-import BasicTypes ( RecFlag(..), TopLevelFlag(..) )\r
-import Util ( thenCmp, removeDups )\r
-import List ( partition )\r
-import ListSetOps ( minusList )\r
-import Bag ( bagToList )\r
-import FiniteMap ( lookupFM, listToFM )\r
-import Maybe ( isJust )\r
-import Outputable\r
-\end{code}\r
-\r
--- ToDo: Put the annotations into the monad, so that they arrive in the proper\r
--- place and can be used when complaining.\r
-\r
-The code tree received by the function @rnBinds@ contains definitions\r
-in where-clauses which are all apparently mutually recursive, but which may\r
-not really depend upon each other. For example, in the top level program\r
-\begin{verbatim}\r
-f x = y where a = x\r
- y = x\r
-\end{verbatim}\r
-the definitions of @a@ and @y@ do not depend on each other at all.\r
-Unfortunately, the typechecker cannot always check such definitions.\r
-\footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive\r
-definitions. In Proceedings of the International Symposium on Programming,\r
-Toulouse, pp. 217-39. LNCS 167. Springer Verlag.}\r
-However, the typechecker usually can check definitions in which only the\r
-strongly connected components have been collected into recursive bindings.\r
-This is precisely what the function @rnBinds@ does.\r
-\r
-ToDo: deal with case where a single monobinds binds the same variable\r
-twice.\r
-\r
-The vertag tag is a unique @Int@; the tags only need to be unique\r
-within one @MonoBinds@, so that unique-Int plumbing is done explicitly\r
-(heavy monad machinery not needed).\r
-\r
-\begin{code}\r
-type VertexTag = Int\r
-type Cycle = [VertexTag]\r
-type Edge = (VertexTag, VertexTag)\r
-\end{code}\r
-\r
-%************************************************************************\r
-%* *\r
-%* naming conventions *\r
-%* *\r
-%************************************************************************\r
-\r
-\subsection[name-conventions]{Name conventions}\r
-\r
-The basic algorithm involves walking over the tree and returning a tuple\r
-containing the new tree plus its free variables. Some functions, such\r
-as those walking polymorphic bindings (HsBinds) and qualifier lists in\r
-list comprehensions (@Quals@), return the variables bound in local\r
-environments. These are then used to calculate the free variables of the\r
-expression evaluated in these environments.\r
-\r
-Conventions for variable names are as follows:\r
-\begin{itemize}\r
-\item\r
-new code is given a prime to distinguish it from the old.\r
-\r
-\item\r
-a set of variables defined in @Exp@ is written @dvExp@\r
-\r
-\item\r
-a set of variables free in @Exp@ is written @fvExp@\r
-\end{itemize}\r
-\r
-%************************************************************************\r
-%* *\r
-%* analysing polymorphic bindings (HsBinds, Bind, MonoBinds) *\r
-%* *\r
-%************************************************************************\r
-\r
-\subsubsection[dep-HsBinds]{Polymorphic bindings}\r
-\r
-Non-recursive expressions are reconstructed without any changes at top\r
-level, although their component expressions may have to be altered.\r
-However, non-recursive expressions are currently not expected as\r
-\Haskell{} programs, and this code should not be executed.\r
-\r
-Monomorphic bindings contain information that is returned in a tuple\r
-(a @FlatMonoBindsInfo@) containing:\r
-\r
-\begin{enumerate}\r
-\item\r
-a unique @Int@ that serves as the ``vertex tag'' for this binding.\r
-\r
-\item\r
-the name of a function or the names in a pattern. These are a set\r
-referred to as @dvLhs@, the defined variables of the left hand side.\r
-\r
-\item\r
-the free variables of the body. These are referred to as @fvBody@.\r
-\r
-\item\r
-the definition's actual code. This is referred to as just @code@.\r
-\end{enumerate}\r
-\r
-The function @nonRecDvFv@ returns two sets of variables. The first is\r
-the set of variables defined in the set of monomorphic bindings, while the\r
-second is the set of free variables in those bindings.\r
-\r
-The set of variables defined in a non-recursive binding is just the\r
-union of all of them, as @union@ removes duplicates. However, the\r
-free variables in each successive set of cumulative bindings is the\r
-union of those in the previous set plus those of the newest binding after\r
-the defined variables of the previous set have been removed.\r
-\r
-@rnMethodBinds@ deals only with the declarations in class and\r
-instance declarations. It expects only to see @FunMonoBind@s, and\r
-it expects the global environment to contain bindings for the binders\r
-(which are all class operations).\r
-\r
-%************************************************************************\r
-%* *\r
-%* Top-level bindings\r
-%* *\r
-%************************************************************************\r
-\r
-@rnTopBinds@ assumes that the environment already\r
-contains bindings for the binders of this particular binding.\r
-\r
-\begin{code}\r
-rnTopBinds :: RdrNameHsBinds -> RnMS (RenamedHsBinds, FreeVars)\r
-\r
-rnTopBinds EmptyBinds = returnRn (EmptyBinds, emptyFVs)\r
-rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs\r
- -- The parser doesn't produce other forms\r
-\r
-\r
-rnTopMonoBinds EmptyMonoBinds sigs \r
- = returnRn (EmptyBinds, emptyFVs)\r
-\r
-rnTopMonoBinds mbinds sigs\r
- = mapRn lookupBndrRn binder_rdr_names `thenRn` \ binder_names ->\r
- let\r
- binder_set = mkNameSet binder_names\r
- binder_occ_fm = listToFM [(nameOccName x,x) | x <- binder_names]\r
- in\r
- renameSigs opt_WarnMissingSigs binder_set\r
- (lookupSigOccRn binder_occ_fm) sigs `thenRn` \ (siglist, sig_fvs) ->\r
- rn_mono_binds siglist mbinds `thenRn` \ (final_binds, bind_fvs) ->\r
- returnRn (final_binds, bind_fvs `plusFV` sig_fvs)\r
- where\r
- binder_rdr_names = map fst (bagToList (collectMonoBinders mbinds))\r
-\r
--- the names appearing in the sigs have to be bound by \r
--- this group's binders.\r
-lookupSigOccRn binder_occ_fm rdr_name\r
- = case lookupFM binder_occ_fm (rdrNameOcc rdr_name) of\r
- Nothing -> failWithRn (mkUnboundName rdr_name)\r
- (unknownNameErr rdr_name)\r
- Just x -> returnRn x\r
-\end{code}\r
-\r
-%************************************************************************\r
-%* *\r
-%* Nested binds\r
-%* *\r
-%************************************************************************\r
-\r
-@rnMonoBinds@\r
- - collects up the binders for this declaration group,\r
- - checks that they form a set\r
- - extends the environment to bind them to new local names\r
- - calls @rnMonoBinds@ to do the real work\r
-\r
-\begin{code}\r
-rnBinds :: RdrNameHsBinds \r
- -> (RenamedHsBinds -> RnMS (result, FreeVars))\r
- -> RnMS (result, FreeVars)\r
-\r
-rnBinds EmptyBinds thing_inside = thing_inside EmptyBinds\r
-rnBinds (MonoBind bind sigs _) thing_inside = rnMonoBinds bind sigs thing_inside\r
- -- the parser doesn't produce other forms\r
-\r
-\r
-rnMonoBinds :: RdrNameMonoBinds \r
- -> [RdrNameSig]\r
- -> (RenamedHsBinds -> RnMS (result, FreeVars))\r
- -> RnMS (result, FreeVars)\r
-\r
-rnMonoBinds EmptyMonoBinds sigs thing_inside = thing_inside EmptyBinds\r
-\r
-rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds\r
- = -- Extract all the binders in this group,\r
- -- and extend current scope, inventing new names for the new binders\r
- -- This also checks that the names form a set\r
- bindLocatedLocalsRn (text "a binding group") mbinders_w_srclocs $ \ new_mbinders ->\r
- let\r
- binder_set = mkNameSet new_mbinders\r
-\r
- -- Weed out the fixity declarations that do not\r
- -- apply to any of the binders in this group.\r
- (sigs_for_me, fixes_not_for_me) = partition forLocalBind sigs\r
-\r
- forLocalBind (FixSig sig@(FixitySig name _ _ )) =\r
- isJust (lookupFM binder_occ_fm (rdrNameOcc name))\r
- forLocalBind _ = True\r
-\r
- binder_occ_fm = listToFM [(nameOccName x,x) | x <- new_mbinders]\r
-\r
- in\r
- -- Report the fixity declarations in this group that \r
- -- don't refer to any of the group's binders.\r
- --\r
- mapRn_ (unknownSigErr) fixes_not_for_me `thenRn_`\r
- renameSigs False binder_set\r
- (lookupSigOccRn binder_occ_fm) sigs_for_me `thenRn` \ (siglist, sig_fvs) ->\r
- let\r
- fixity_sigs = [(name,sig) | FixSig sig@(FixitySig name _ _) <- siglist ]\r
- in\r
- -- Install the fixity declarations that do apply here and go.\r
- extendFixityEnv fixity_sigs (\r
- rn_mono_binds siglist mbinds\r
- ) `thenRn` \ (binds, bind_fvs) ->\r
-\r
- -- Now do the "thing inside", and deal with the free-variable calculations\r
- thing_inside binds `thenRn` \ (result,result_fvs) ->\r
- let\r
- all_fvs = result_fvs `plusFV` bind_fvs `plusFV` sig_fvs\r
- unused_binders = nameSetToList (binder_set `minusNameSet` all_fvs)\r
- in\r
- warnUnusedLocalBinds unused_binders `thenRn_`\r
- returnRn (result, delListFromNameSet all_fvs new_mbinders)\r
- where\r
- mbinders_w_srclocs = bagToList (collectMonoBinders mbinds)\r
-\end{code}\r
-\r
-\r
-%************************************************************************\r
-%* *\r
-%* MonoBinds -- the main work is done here\r
-%* *\r
-%************************************************************************\r
-\r
-@rn_mono_binds@ is used by *both* top-level and nested bindings. It\r
-assumes that all variables bound in this group are already in scope.\r
-This is done *either* by pass 3 (for the top-level bindings), *or* by\r
-@rnMonoBinds@ (for the nested ones).\r
-\r
-\begin{code}\r
-rn_mono_binds :: [RenamedSig] -- Signatures attached to this group\r
- -> RdrNameMonoBinds \r
- -> RnMS (RenamedHsBinds, -- \r
- FreeVars) -- Free variables\r
-\r
-rn_mono_binds siglist mbinds\r
- =\r
- -- Rename the bindings, returning a MonoBindsInfo\r
- -- which is a list of indivisible vertices so far as\r
- -- the strongly-connected-components (SCC) analysis is concerned\r
- flattenMonoBinds siglist mbinds `thenRn` \ mbinds_info ->\r
-\r
- -- Do the SCC analysis\r
- let \r
- edges = mkEdges (mbinds_info `zip` [(0::Int)..])\r
- scc_result = stronglyConnComp edges\r
- final_binds = foldr1 ThenBinds (map reconstructCycle scc_result)\r
-\r
- -- Deal with bound and free-var calculation\r
- rhs_fvs = plusFVs [fvs | (_,fvs,_,_) <- mbinds_info]\r
- in\r
- returnRn (final_binds, rhs_fvs)\r
-\end{code}\r
-\r
-@flattenMonoBinds@ is ever-so-slightly magical in that it sticks\r
-unique ``vertex tags'' on its output; minor plumbing required.\r
-\r
-Sigh - need to pass along the signatures for the group of bindings,\r
-in case any of them \r
-\r
-\begin{code}\r
-flattenMonoBinds :: [RenamedSig] -- Signatures\r
- -> RdrNameMonoBinds\r
- -> RnMS [FlatMonoBindsInfo]\r
-\r
-flattenMonoBinds sigs EmptyMonoBinds = returnRn []\r
-\r
-flattenMonoBinds sigs (AndMonoBinds bs1 bs2)\r
- = flattenMonoBinds sigs bs1 `thenRn` \ flat1 ->\r
- flattenMonoBinds sigs bs2 `thenRn` \ flat2 ->\r
- returnRn (flat1 ++ flat2)\r
-\r
-flattenMonoBinds sigs (PatMonoBind pat grhss locn)\r
- = pushSrcLocRn locn $\r
- rnPat pat `thenRn` \ (pat', pat_fvs) ->\r
-\r
- -- Find which things are bound in this group\r
- let\r
- names_bound_here = mkNameSet (collectPatBinders pat')\r
- sigs_for_me = sigsForMe (`elemNameSet` names_bound_here) sigs\r
- in\r
- rnGRHSs grhss `thenRn` \ (grhss', fvs) ->\r
- returnRn \r
- [(names_bound_here,\r
- fvs `plusFV` pat_fvs,\r
- PatMonoBind pat' grhss' locn,\r
- sigs_for_me\r
- )]\r
-\r
-flattenMonoBinds sigs (FunMonoBind name inf matches locn)\r
- = pushSrcLocRn locn $\r
- lookupBndrRn name `thenRn` \ new_name ->\r
- let\r
- sigs_for_me = sigsForMe (new_name ==) sigs\r
- in\r
- mapFvRn rnMatch matches `thenRn` \ (new_matches, fvs) ->\r
- mapRn_ (checkPrecMatch inf new_name) new_matches `thenRn_`\r
- returnRn\r
- [(unitNameSet new_name,\r
- fvs,\r
- FunMonoBind new_name inf new_matches locn,\r
- sigs_for_me\r
- )]\r
-\end{code}\r
-\r
-\r
-@rnMethodBinds@ is used for the method bindings of a class and an instance\r
-declaration. like @rnMonoBinds@ but without dependency analysis.\r
-\r
-NOTA BENE: we record each *binder* of a method-bind group as a free variable.\r
-That's crucial when dealing with an instance decl:\r
- instance Foo (T a) where\r
- op x = ...\r
-This might be the *sole* occurrence of 'op' for an imported class Foo,\r
-and unless op occurs we won't treat the type signature of op in the class\r
-decl for Foo as a source of instance-decl gates. But we should! Indeed,\r
-in many ways the op in an instance decl is just like an occurrence, not\r
-a binder.\r
-\r
-\begin{code}\r
-rnMethodBinds :: RdrNameMonoBinds -> RnMS (RenamedMonoBinds, FreeVars)\r
-\r
-rnMethodBinds EmptyMonoBinds = returnRn (EmptyMonoBinds, emptyFVs)\r
-\r
-rnMethodBinds (AndMonoBinds mb1 mb2)\r
- = rnMethodBinds mb1 `thenRn` \ (mb1', fvs1) ->\r
- rnMethodBinds mb2 `thenRn` \ (mb2', fvs2) ->\r
- returnRn (mb1' `AndMonoBinds` mb2', fvs1 `plusFV` fvs2)\r
-\r
-rnMethodBinds (FunMonoBind name inf matches locn)\r
- = pushSrcLocRn locn $\r
-\r
- lookupGlobalOccRn name `thenRn` \ sel_name -> \r
- -- We use the selector name as the binder\r
-\r
- mapFvRn rnMatch matches `thenRn` \ (new_matches, fvs) ->\r
- mapRn_ (checkPrecMatch inf sel_name) new_matches `thenRn_`\r
- returnRn (FunMonoBind sel_name inf new_matches locn, fvs `addOneFV` sel_name)\r
-\r
-rnMethodBinds (PatMonoBind (VarPatIn name) grhss locn)\r
- = pushSrcLocRn locn $\r
- lookupGlobalOccRn name `thenRn` \ sel_name -> \r
- rnGRHSs grhss `thenRn` \ (grhss', fvs) ->\r
- returnRn (PatMonoBind (VarPatIn sel_name) grhss' locn, fvs `addOneFV` sel_name)\r
-\r
--- Can't handle method pattern-bindings which bind multiple methods.\r
-rnMethodBinds mbind@(PatMonoBind other_pat _ locn)\r
- = pushSrcLocRn locn $\r
- failWithRn (EmptyMonoBinds, emptyFVs) (methodBindErr mbind)\r
-\end{code}\r
-\r
-\r
-%************************************************************************\r
-%* *\r
-\subsection[reconstruct-deps]{Reconstructing dependencies}\r
-%* *\r
-%************************************************************************\r
-\r
-This @MonoBinds@- and @ClassDecls@-specific code is segregated here,\r
-as the two cases are similar.\r
-\r
-\begin{code}\r
-reconstructCycle :: SCC FlatMonoBindsInfo\r
- -> RenamedHsBinds\r
-\r
-reconstructCycle (AcyclicSCC (_, _, binds, sigs))\r
- = MonoBind binds sigs NonRecursive\r
-\r
-reconstructCycle (CyclicSCC cycle)\r
- = MonoBind this_gp_binds this_gp_sigs Recursive\r
- where\r
- this_gp_binds = foldr1 AndMonoBinds [binds | (_, _, binds, _) <- cycle]\r
- this_gp_sigs = foldr1 (++) [sigs | (_, _, _, sigs) <- cycle]\r
-\end{code}\r
-\r
-%************************************************************************\r
-%* *\r
-%* Manipulating FlatMonoBindInfo *\r
-%* *\r
-%************************************************************************\r
-\r
-During analysis a @MonoBinds@ is flattened to a @FlatMonoBindsInfo@.\r
-The @RenamedMonoBinds@ is always an empty bind, a pattern binding or\r
-a function binding, and has itself been dependency-analysed and\r
-renamed.\r
-\r
-\begin{code}\r
-type FlatMonoBindsInfo\r
- = (NameSet, -- Set of names defined in this vertex\r
- NameSet, -- Set of names used in this vertex\r
- RenamedMonoBinds,\r
- [RenamedSig]) -- Signatures, if any, for this vertex\r
-\r
-mkEdges :: [(FlatMonoBindsInfo, VertexTag)] -> [(FlatMonoBindsInfo, VertexTag, [VertexTag])]\r
-\r
-mkEdges flat_info\r
- = [ (info, tag, dest_vertices (nameSetToList names_used))\r
- | (info@(names_defined, names_used, mbind, sigs), tag) <- flat_info\r
- ]\r
- where\r
- -- An edge (v,v') indicates that v depends on v'\r
- dest_vertices src_mentions = [ target_vertex\r
- | ((names_defined, _, _, _), target_vertex) <- flat_info,\r
- mentioned_name <- src_mentions,\r
- mentioned_name `elemNameSet` names_defined\r
- ]\r
-\end{code}\r
-\r
-\r
-%************************************************************************\r
-%* *\r
-\subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}\r
-%* *\r
-%************************************************************************\r
-\r
-@renameSigs@ checks for: (a)~more than one sig for one thing;\r
-(b)~signatures given for things not bound here; (c)~with suitably\r
-flaggery, that all top-level things have type signatures.\r
-\r
-At the moment we don't gather free-var info from the types in\r
-signatures. We'd only need this if we wanted to report unused tyvars.\r
-\r
-\begin{code}\r
-renameSigs :: Bool -- True => warn if (required) type signatures are missing.\r
- -> NameSet -- Set of names bound in this group\r
- -> (RdrName -> RnMS Name)\r
- -> [RdrNameSig]\r
- -> RnMS ([RenamedSig], FreeVars) -- List of Sig constructors\r
-\r
-renameSigs sigs_required binders lookup_occ_nm sigs\r
- = -- Rename the signatures\r
- mapFvRn (renameSig lookup_occ_nm) sigs `thenRn` \ (sigs', fvs) ->\r
-\r
- -- Check for (a) duplicate signatures\r
- -- (b) signatures for things not in this group\r
- -- (c) optionally, bindings with no signature\r
- let\r
- (goodies, dups) = removeDups cmp_sig (sigsForMe (not . isUnboundName) sigs')\r
- not_this_group = sigsForMe (not . (`elemNameSet` binders)) goodies\r
- type_sig_vars = [n | Sig n _ _ <- goodies]\r
- un_sigd_binders | sigs_required = nameSetToList binders `minusList` type_sig_vars\r
- | otherwise = []\r
- in\r
- mapRn_ dupSigDeclErr dups `thenRn_`\r
- mapRn_ unknownSigErr not_this_group `thenRn_`\r
- mapRn_ (addWarnRn.missingSigWarn) un_sigd_binders `thenRn_`\r
- returnRn (sigs', fvs) \r
- -- bad ones and all:\r
- -- we need bindings of *some* sort for every name\r
-\r
--- We use lookupOccRn in the signatures, which is a little bit unsatisfactory\r
--- because this won't work for:\r
--- instance Foo T where\r
--- {-# INLINE op #-}\r
--- Baz.op = ...\r
--- We'll just rename the INLINE prag to refer to whatever other 'op'\r
--- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.)\r
--- Doesn't seem worth much trouble to sort this.\r
-\r
-renameSig lookup_occ_nm (Sig v ty src_loc)\r
- = pushSrcLocRn src_loc $\r
- lookup_occ_nm v `thenRn` \ new_v ->\r
- rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs) ->\r
- returnRn (Sig new_v new_ty src_loc, fvs `addOneFV` new_v)\r
-\r
-renameSig _ (SpecInstSig ty src_loc)\r
- = pushSrcLocRn src_loc $\r
- rnHsSigType (text "A SPECIALISE instance pragma") ty `thenRn` \ (new_ty, fvs) ->\r
- returnRn (SpecInstSig new_ty src_loc, fvs)\r
-\r
-renameSig lookup_occ_nm (SpecSig v ty src_loc)\r
- = pushSrcLocRn src_loc $\r
- lookup_occ_nm v `thenRn` \ new_v ->\r
- rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs) ->\r
- returnRn (SpecSig new_v new_ty src_loc, fvs `addOneFV` new_v)\r
-\r
-renameSig lookup_occ_nm (InlineSig v src_loc)\r
- = pushSrcLocRn src_loc $\r
- lookup_occ_nm v `thenRn` \ new_v ->\r
- returnRn (InlineSig new_v src_loc, unitFV new_v)\r
-\r
-renameSig lookup_occ_nm (FixSig (FixitySig v fix src_loc))\r
- = pushSrcLocRn src_loc $\r
- lookup_occ_nm v `thenRn` \ new_v ->\r
- returnRn (FixSig (FixitySig new_v fix src_loc), unitFV new_v)\r
-\r
-renameSig lookup_occ_nm (NoInlineSig v src_loc)\r
- = pushSrcLocRn src_loc $\r
- lookup_occ_nm v `thenRn` \ new_v ->\r
- returnRn (NoInlineSig new_v src_loc, unitFV new_v)\r
-\end{code}\r
-\r
-Checking for distinct signatures; oh, so boring\r
-\r
-\begin{code}\r
-cmp_sig :: RenamedSig -> RenamedSig -> Ordering\r
-cmp_sig (Sig n1 _ _) (Sig n2 _ _) = n1 `compare` n2\r
-cmp_sig (InlineSig n1 _) (InlineSig n2 _) = n1 `compare` n2\r
-cmp_sig (NoInlineSig n1 _) (NoInlineSig n2 _) = n1 `compare` n2\r
-cmp_sig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = cmpHsType compare ty1 ty2\r
-cmp_sig (SpecSig n1 ty1 _) (SpecSig n2 ty2 _) \r
- = -- may have many specialisations for one value;\r
- -- but not ones that are exactly the same...\r
- thenCmp (n1 `compare` n2) (cmpHsType compare ty1 ty2)\r
-\r
-cmp_sig other_1 other_2 -- Tags *must* be different\r
- | (sig_tag other_1) _LT_ (sig_tag other_2) = LT \r
- | otherwise = GT\r
-\r
-sig_tag (Sig n1 _ _) = (ILIT(1) :: FAST_INT)\r
-sig_tag (SpecSig n1 _ _) = ILIT(2)\r
-sig_tag (InlineSig n1 _) = ILIT(3)\r
-sig_tag (NoInlineSig n1 _) = ILIT(4)\r
-sig_tag (SpecInstSig _ _) = ILIT(5)\r
-sig_tag (FixSig _) = ILIT(6)\r
-sig_tag _ = panic# "tag(RnBinds)"\r
-\end{code}\r
-\r
-%************************************************************************\r
-%* *\r
-\subsection{Error messages}\r
-%* *\r
-%************************************************************************\r
-\r
-\begin{code}\r
-dupSigDeclErr (sig:sigs)\r
- = pushSrcLocRn loc $\r
- addErrRn (sep [ptext SLIT("Duplicate") <+> ptext what_it_is <> colon,\r
- ppr sig])\r
- where\r
- (what_it_is, loc) = sig_doc sig\r
-\r
-unknownSigErr sig\r
- = pushSrcLocRn loc $\r
- addErrRn (sep [ptext SLIT("Misplaced"),\r
- ptext what_it_is <> colon,\r
- ppr sig])\r
- where\r
- (what_it_is, loc) = sig_doc sig\r
-\r
-sig_doc (Sig _ _ loc) = (SLIT("type signature"),loc)\r
-sig_doc (ClassOpSig _ _ _ loc) = (SLIT("class-method type signature"), loc)\r
-sig_doc (SpecSig _ _ loc) = (SLIT("SPECIALISE pragma"),loc)\r
-sig_doc (InlineSig _ loc) = (SLIT("INLINE pragma"),loc)\r
-sig_doc (NoInlineSig _ loc) = (SLIT("NOINLINE pragma"),loc)\r
-sig_doc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc)\r
-sig_doc (FixSig (FixitySig _ _ loc)) = (SLIT("fixity declaration"), loc)\r
-\r
-missingSigWarn var\r
- = sep [ptext SLIT("definition but no type signature for"), quotes (ppr var)]\r
-\r
-methodBindErr mbind\r
- = hang (ptext SLIT("Can't handle multiple methods defined by one pattern binding"))\r
- 4 (ppr mbind)\r
-\end{code}\r
+%
+% (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}
%*********************************************************
%* *
-\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
\begin{code}
-------------------------------------
-bindLocatedLocalsRn :: SDoc -- Documentation string for error message
+bindLocatedLocalsRn :: SDoc -- Documentation string for error message
-> [(RdrName,SrcLoc)]
-> ([Name] -> RnMS a)
-> RnMS a
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 []
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
-- 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
-- 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
-- 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}
%* *
%************************************************************************
-=============== NameEnv ================
+\subsubsection{NameEnv}% ================
+
\begin{code}
plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
plusGlobalRdrEnv env1 env2 = plusFM_C combine_globals env1 env2
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)
\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))
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 ()
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
(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}
\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}
%* *
%************************************************************************
-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}
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)
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) ->
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
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
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"
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
@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.
%* *
%*********************************************************
-@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
-- 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,
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
%* *
%*********************************************************
-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
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
@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
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_`
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
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}
-%\r
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998\r
-%\r
-\section[RnMonad]{The monad used by the renamer}\r
-\r
-\begin{code}\r
-module RnMonad(\r
- module RnMonad,\r
- Module,\r
- FiniteMap,\r
- Bag,\r
- Name,\r
- RdrNameHsDecl,\r
- RdrNameInstDecl,\r
- Version,\r
- NameSet,\r
- OccName,\r
- Fixity\r
- ) where\r
-\r
-#include "HsVersions.h"\r
-\r
-import PrelIOBase ( fixIO ) -- Should be in GlaExts\r
-import IOExts ( IORef, newIORef, readIORef, writeIORef, unsafePerformIO )\r
- \r
-import HsSyn \r
-import RdrHsSyn\r
-import RnHsSyn ( RenamedFixitySig )\r
-import BasicTypes ( Version )\r
-import SrcLoc ( noSrcLoc )\r
-import ErrUtils ( addShortErrLocLine, addShortWarnLocLine,\r
- pprBagOfErrors, ErrMsg, WarnMsg, Message\r
- )\r
-import Name ( Name, OccName, NamedThing(..),\r
- isLocallyDefinedName, nameModule, nameOccName,\r
- decode, mkLocalName\r
- )\r
-import Module ( Module, ModuleName, ModuleHiMap, SearchPath, WhereFrom,\r
- mkModuleHiMaps, moduleName\r
- )\r
-import NameSet \r
-import RdrName ( RdrName, dummyRdrVarName, rdrNameOcc )\r
-import CmdLineOpts ( opt_D_dump_rn_trace, opt_IgnoreIfacePragmas )\r
-import PrelInfo ( builtinNames )\r
-import TysWiredIn ( boolTyCon )\r
-import SrcLoc ( SrcLoc, mkGeneratedSrcLoc )\r
-import Unique ( Unique, getUnique, unboundKey )\r
-import UniqFM ( UniqFM )\r
-import FiniteMap ( FiniteMap, emptyFM, bagToFM, lookupFM, addToFM, addListToFM, \r
- addListToFM_C, addToFM_C, eltsFM, fmToList\r
- )\r
-import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag )\r
-import Maybes ( mapMaybe )\r
-import UniqSet\r
-import UniqFM\r
-import UniqSupply\r
-import Util\r
-import Outputable\r
-\r
-infixr 9 `thenRn`, `thenRn_`\r
-\end{code}\r
-\r
-\r
-%************************************************************************\r
-%* *\r
-\subsection{Somewhat magical interface to other monads}\r
-%* *\r
-%************************************************************************\r
-\r
-\begin{code}\r
-ioToRnM :: IO r -> RnM d (Either IOError r)\r
-ioToRnM io rn_down g_down = (io >>= \ ok -> return (Right ok)) \r
- `catch` \r
- (\ err -> return (Left err))\r
- \r
-traceRn :: SDoc -> RnM d ()\r
-traceRn msg | opt_D_dump_rn_trace = putDocRn msg\r
- | otherwise = returnRn ()\r
-\r
-putDocRn :: SDoc -> RnM d ()\r
-putDocRn msg = ioToRnM (printErrs msg) `thenRn_`\r
- returnRn ()\r
-\end{code}\r
-\r
-\r
-%************************************************************************\r
-%* *\r
-\subsection{Data types}\r
-%* *\r
-%************************************************************************\r
-\r
-===================================================\r
- MONAD TYPES\r
-===================================================\r
-\r
-\begin{code}\r
-type RnM d r = RnDown -> d -> IO r\r
-type RnMS r = RnM SDown r -- Renaming source\r
-type RnMG r = RnM () r -- Getting global names etc\r
-\r
- -- Common part\r
-data RnDown = RnDown {\r
- rn_mod :: ModuleName,\r
- rn_loc :: SrcLoc,\r
- rn_ns :: IORef RnNameSupply,\r
- rn_errs :: IORef (Bag WarnMsg, Bag ErrMsg),\r
- rn_ifaces :: IORef Ifaces,\r
- rn_hi_maps :: (ModuleHiMap, -- for .hi files\r
- ModuleHiMap) -- for .hi-boot files\r
- }\r
-\r
- -- For renaming source code\r
-data SDown = SDown {\r
- rn_mode :: RnMode,\r
-\r
- rn_genv :: GlobalRdrEnv, -- Global envt; the fixity component gets extended\r
- -- with local fixity decls\r
-\r
- rn_lenv :: LocalRdrEnv, -- Local name envt\r
- -- Does *not* includes global name envt; may shadow it\r
- -- Includes both ordinary variables and type variables;\r
- -- they are kept distinct because tyvar have a different\r
- -- occurrence contructor (Name.TvOcc)\r
- -- We still need the unsullied global name env so that\r
- -- we can look up record field names\r
-\r
- rn_fixenv :: FixityEnv -- Local fixities\r
- -- The global ones are held in the\r
- -- rn_ifaces field\r
- }\r
-\r
-data RnMode = SourceMode -- Renaming source code\r
- | InterfaceMode -- Renaming interface declarations. \r
-\end{code}\r
-\r
-===================================================\r
- ENVIRONMENTS\r
-===================================================\r
-\r
-\begin{code}\r
---------------------------------\r
-type RdrNameEnv a = FiniteMap RdrName a\r
-type GlobalRdrEnv = RdrNameEnv [Name] -- The list is because there may be name clashes\r
- -- These only get reported on lookup,\r
- -- not on construction\r
-type LocalRdrEnv = RdrNameEnv Name\r
-\r
-emptyRdrEnv :: RdrNameEnv a\r
-lookupRdrEnv :: RdrNameEnv a -> RdrName -> Maybe a\r
-addListToRdrEnv :: RdrNameEnv a -> [(RdrName,a)] -> RdrNameEnv a\r
-extendRdrEnv :: RdrNameEnv a -> RdrName -> a -> RdrNameEnv a\r
-\r
-emptyRdrEnv = emptyFM\r
-lookupRdrEnv = lookupFM\r
-addListToRdrEnv = addListToFM\r
-rdrEnvElts = eltsFM\r
-extendRdrEnv = addToFM\r
-rdrEnvToList = fmToList\r
-\r
---------------------------------\r
-type NameEnv a = UniqFM a -- Domain is Name\r
-\r
-emptyNameEnv :: NameEnv a\r
-nameEnvElts :: NameEnv a -> [a]\r
-addToNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a\r
-addToNameEnv :: NameEnv a -> Name -> a -> NameEnv a\r
-plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a\r
-extendNameEnv :: NameEnv a -> [(Name,a)] -> NameEnv a\r
-lookupNameEnv :: NameEnv a -> Name -> Maybe a\r
-delFromNameEnv :: NameEnv a -> Name -> NameEnv a\r
-elemNameEnv :: Name -> NameEnv a -> Bool\r
-\r
-emptyNameEnv = emptyUFM\r
-nameEnvElts = eltsUFM\r
-addToNameEnv_C = addToUFM_C\r
-addToNameEnv = addToUFM\r
-plusNameEnv = plusUFM\r
-extendNameEnv = addListToUFM\r
-lookupNameEnv = lookupUFM\r
-delFromNameEnv = delFromUFM\r
-elemNameEnv = elemUFM\r
-\r
---------------------------------\r
-type FixityEnv = NameEnv RenamedFixitySig\r
- -- We keep the whole fixity sig so that we\r
- -- can report line-number info when there is a duplicate\r
- -- fixity declaration\r
-\end{code}\r
-\r
-\begin{code}\r
---------------------------------\r
-type RnNameSupply\r
- = ( UniqSupply\r
-\r
- , FiniteMap (OccName, OccName) Int\r
- -- This is used as a name supply for dictionary functions\r
- -- From the inst decl we derive a (class, tycon) pair;\r
- -- this map then gives a unique int for each inst decl with that\r
- -- (class, tycon) pair. (In Haskell 98 there can only be one,\r
- -- but not so in more extended versions.)\r
- -- \r
- -- We could just use one Int for all the instance decls, but this\r
- -- way the uniques change less when you add an instance decl, \r
- -- hence less recompilation\r
-\r
- , FiniteMap (ModuleName, OccName) Name\r
- -- Ensures that one (module,occname) pair gets one unique\r
- )\r
-\r
-\r
---------------------------------\r
-data ExportEnv = ExportEnv Avails Fixities\r
-type Avails = [AvailInfo]\r
-type Fixities = [(Name, Fixity)]\r
-\r
-type ExportAvails = (FiniteMap ModuleName Avails, -- Used to figure out "module M" export specifiers\r
- -- Includes avails only from *unqualified* imports\r
- -- (see 1.4 Report Section 5.1.1)\r
-\r
- NameEnv AvailInfo) -- Used to figure out all other export specifiers.\r
- -- Maps a Name to the AvailInfo that contains it\r
-\r
-\r
-data GenAvailInfo name = Avail name -- An ordinary identifier\r
- | AvailTC name -- The name of the type or class\r
- [name] -- The available pieces of type/class. NB: If the type or\r
- -- class is itself to be in scope, it must be in this list.\r
- -- Thus, typically: AvailTC Eq [Eq, ==, /=]\r
-type AvailInfo = GenAvailInfo Name\r
-type RdrAvailInfo = GenAvailInfo OccName\r
-\end{code}\r
-\r
-===================================================\r
- INTERFACE FILE STUFF\r
-===================================================\r
-\r
-\begin{code}\r
-type ExportItem = (ModuleName, [RdrAvailInfo])\r
-type VersionInfo name = [ImportVersion name]\r
-\r
-type ImportVersion name = (ModuleName, Version, WhetherHasOrphans, WhatsImported name)\r
-\r
-type WhetherHasOrphans = Bool\r
- -- An "orphan" is \r
- -- * an instance decl in a module other than the defn module for \r
- -- one of the tycons or classes in the instance head\r
- -- * a transformation rule in a module other than the one defining\r
- -- the function in the head of the rule.\r
-\r
-data WhatsImported name = Everything \r
- | Specifically [LocalVersion name] -- List guaranteed non-empty\r
-\r
- -- ("M", hif, ver, Everything) means there was a "module M" in \r
- -- this module's export list, so we just have to go by M's version, "ver",\r
- -- not the list of LocalVersions.\r
-\r
-\r
-type LocalVersion name = (name, Version)\r
-\r
-data ParsedIface\r
- = ParsedIface {\r
- pi_mod :: Version, -- Module version number\r
- pi_orphan :: WhetherHasOrphans, -- Whether this module has orphans\r
- pi_usages :: [ImportVersion OccName], -- Usages\r
- pi_exports :: [ExportItem], -- Exports\r
- pi_decls :: [(Version, RdrNameHsDecl)], -- Local definitions\r
- pi_insts :: [RdrNameInstDecl], -- Local instance declarations\r
- pi_rules :: [RdrNameRuleDecl] -- Rules\r
- }\r
-\r
-type InterfaceDetails = (WhetherHasOrphans,\r
- VersionInfo Name, -- Version information for what this module imports\r
- ExportEnv) -- What modules this one depends on\r
-\r
-\r
--- needed by Main to fish out the fixities assoc list.\r
-getIfaceFixities :: InterfaceDetails -> Fixities\r
-getIfaceFixities (_, _, ExportEnv _ fs) = fs\r
-\r
-\r
-type RdrNamePragma = () -- Fudge for now\r
--------------------\r
-\r
-data Ifaces = Ifaces {\r
- iImpModInfo :: ImportedModuleInfo,\r
- -- Modules this one depends on: that is, the union \r
- -- of the modules its direct imports depend on.\r
-\r
- iDecls :: DeclsMap, -- A single, global map of Names to decls\r
-\r
- iFixes :: FixityEnv, -- A single, global map of Names to fixities\r
-\r
- iSlurp :: NameSet, -- All the names (whether "big" or "small", whether wired-in or not,\r
- -- whether locally defined or not) that have been slurped in so far.\r
-\r
- iVSlurp :: [(Name,Version)], -- All the (a) non-wired-in (b) "big" (c) non-locally-defined \r
- -- names that have been slurped in so far, with their versions. \r
- -- This is used to generate the "usage" information for this module.\r
- -- Subset of the previous field.\r
-\r
- iInsts :: Bag GatedDecl,\r
- -- The as-yet un-slurped instance decls; this bag is depleted when we\r
- -- slurp an instance decl so that we don't slurp the same one twice.\r
- -- Each is 'gated' by the names that must be available before\r
- -- this instance decl is needed.\r
-\r
- iRules :: Bag GatedDecl\r
- -- Ditto transformation rules\r
- }\r
-\r
-type GatedDecl = (NameSet, (Module, RdrNameHsDecl))\r
-\r
-type ImportedModuleInfo \r
- = FiniteMap ModuleName (Version, Bool, Maybe (Module, Bool, Avails))\r
- -- Suppose the domain element is module 'A'\r
- --\r
- -- The first Bool is True if A contains \r
- -- 'orphan' rules or instance decls\r
-\r
- -- The second Bool is true if the interface file actually\r
- -- read was an .hi-boot file\r
-\r
- -- Nothing => A's interface not yet read, but this module has\r
- -- imported a module, B, that itself depends on A\r
- --\r
- -- Just xx => A's interface has been read. The Module in \r
- -- the Just has the correct Dll flag\r
-\r
- -- This set is used to decide whether to look for\r
- -- A.hi or A.hi-boot when importing A.f.\r
- -- Basically, we look for A.hi if A is in the map, and A.hi-boot\r
- -- otherwise\r
-\r
-type DeclsMap = NameEnv (Version, AvailInfo, Bool, (Module, RdrNameHsDecl))\r
- -- A DeclsMap contains a binding for each Name in the declaration\r
- -- including the constructors of a type decl etc.\r
- -- The Bool is True just for the 'main' Name.\r
-\end{code}\r
-\r
-\r
-%************************************************************************\r
-%* *\r
-\subsection{Main monad code}\r
-%* *\r
-%************************************************************************\r
-\r
-\begin{code}\r
-initRn :: ModuleName -> UniqSupply -> SearchPath -> SrcLoc\r
- -> RnMG r\r
- -> IO (r, Bag ErrMsg, Bag WarnMsg)\r
-\r
-initRn mod us dirs loc do_rn = do\r
- himaps <- mkModuleHiMaps dirs\r
- names_var <- newIORef (us, emptyFM, builtins)\r
- errs_var <- newIORef (emptyBag,emptyBag)\r
- iface_var <- newIORef emptyIfaces \r
- let\r
- rn_down = RnDown { rn_loc = loc, rn_ns = names_var, \r
- rn_errs = errs_var, \r
- rn_hi_maps = himaps, \r
- rn_ifaces = iface_var,\r
- rn_mod = mod }\r
-\r
- -- do the business\r
- res <- do_rn rn_down ()\r
-\r
- -- grab errors and return\r
- (warns, errs) <- readIORef errs_var\r
-\r
- return (res, errs, warns)\r
-\r
-\r
-initRnMS :: GlobalRdrEnv -> FixityEnv -> RnMode -> RnMS r -> RnM d r\r
-initRnMS rn_env fixity_env mode thing_inside rn_down g_down\r
- = let\r
- s_down = SDown { rn_genv = rn_env, rn_lenv = emptyRdrEnv, \r
- rn_fixenv = fixity_env, rn_mode = mode }\r
- in\r
- thing_inside rn_down s_down\r
-\r
-initIfaceRnMS :: Module -> RnMS r -> RnM d r\r
-initIfaceRnMS mod thing_inside \r
- = initRnMS emptyRdrEnv emptyNameEnv InterfaceMode $\r
- setModuleRn (moduleName mod) thing_inside\r
-\r
-emptyIfaces :: Ifaces\r
-emptyIfaces = Ifaces { iImpModInfo = emptyFM,\r
- iDecls = emptyNameEnv,\r
- iFixes = emptyNameEnv,\r
- iSlurp = unitNameSet (mkUnboundName dummyRdrVarName),\r
- -- Pretend that the dummy unbound name has already been\r
- -- slurped. This is what's returned for an out-of-scope name,\r
- -- and we don't want thereby to try to suck it in!\r
- iVSlurp = [],\r
- iInsts = emptyBag,\r
- iRules = emptyBag\r
- }\r
-\r
--- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly\r
--- during compiler debugging.\r
-mkUnboundName :: RdrName -> Name\r
-mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc\r
-\r
-isUnboundName :: Name -> Bool\r
-isUnboundName name = getUnique name == unboundKey\r
-\r
-builtins :: FiniteMap (ModuleName,OccName) Name\r
-builtins = \r
- bagToFM (\r
- mapBag (\ name -> ((moduleName (nameModule name), nameOccName name), name))\r
- builtinNames)\r
-\end{code}\r
-\r
-@renameSourceCode@ is used to rename stuff "out-of-line"; that is, not as part of\r
-the main renamer. Sole examples: derived definitions, which are only generated\r
-in the type checker.\r
-\r
-The @RnNameSupply@ includes a @UniqueSupply@, so if you call it more than\r
-once you must either split it, or install a fresh unique supply.\r
-\r
-\begin{code}\r
-renameSourceCode :: ModuleName\r
- -> RnNameSupply\r
- -> RnMS r\r
- -> r\r
-\r
-renameSourceCode mod_name name_supply m\r
- = unsafePerformIO (\r
- -- It's not really unsafe! When renaming source code we\r
- -- only do any I/O if we need to read in a fixity declaration;\r
- -- and that doesn't happen in pragmas etc\r
-\r
- newIORef name_supply >>= \ names_var ->\r
- newIORef (emptyBag,emptyBag) >>= \ errs_var ->\r
- let\r
- rn_down = RnDown { rn_loc = mkGeneratedSrcLoc, rn_ns = names_var,\r
- rn_errs = errs_var,\r
- rn_mod = mod_name }\r
- s_down = SDown { rn_mode = InterfaceMode, -- So that we can refer to PrelBase.True etc\r
- rn_genv = emptyRdrEnv, rn_lenv = emptyRdrEnv,\r
- rn_fixenv = emptyNameEnv }\r
- in\r
- m rn_down s_down >>= \ result ->\r
- \r
- readIORef errs_var >>= \ (warns,errs) ->\r
-\r
- (if not (isEmptyBag errs) then\r
- pprTrace "Urk! renameSourceCode found errors" (display errs) \r
-#ifdef DEBUG\r
- else if not (isEmptyBag warns) then\r
- pprTrace "Note: renameSourceCode found warnings" (display warns)\r
-#endif\r
- else\r
- id) $\r
-\r
- return result\r
- )\r
- where\r
- display errs = pprBagOfErrors errs\r
-\r
-{-# INLINE thenRn #-}\r
-{-# INLINE thenRn_ #-}\r
-{-# INLINE returnRn #-}\r
-{-# INLINE andRn #-}\r
-\r
-returnRn :: a -> RnM d a\r
-thenRn :: RnM d a -> (a -> RnM d b) -> RnM d b\r
-thenRn_ :: RnM d a -> RnM d b -> RnM d b\r
-andRn :: (a -> a -> a) -> RnM d a -> RnM d a -> RnM d a\r
-mapRn :: (a -> RnM d b) -> [a] -> RnM d [b]\r
-mapRn_ :: (a -> RnM d b) -> [a] -> RnM d ()\r
-mapMaybeRn :: (a -> RnM d (Maybe b)) -> [a] -> RnM d [b]\r
-sequenceRn :: [RnM d a] -> RnM d [a]\r
-foldlRn :: (b -> a -> RnM d b) -> b -> [a] -> RnM d b\r
-mapAndUnzipRn :: (a -> RnM d (b,c)) -> [a] -> RnM d ([b],[c])\r
-fixRn :: (a -> RnM d a) -> RnM d a\r
-\r
-returnRn v gdown ldown = return v\r
-thenRn m k gdown ldown = m gdown ldown >>= \ r -> k r gdown ldown\r
-thenRn_ m k gdown ldown = m gdown ldown >> k gdown ldown\r
-fixRn m gdown ldown = fixIO (\r -> m r gdown ldown)\r
-andRn combiner m1 m2 gdown ldown\r
- = m1 gdown ldown >>= \ res1 ->\r
- m2 gdown ldown >>= \ res2 ->\r
- return (combiner res1 res2)\r
-\r
-sequenceRn [] = returnRn []\r
-sequenceRn (m:ms) = m `thenRn` \ r ->\r
- sequenceRn ms `thenRn` \ rs ->\r
- returnRn (r:rs)\r
-\r
-mapRn f [] = returnRn []\r
-mapRn f (x:xs)\r
- = f x `thenRn` \ r ->\r
- mapRn f xs `thenRn` \ rs ->\r
- returnRn (r:rs)\r
-\r
-mapRn_ f [] = returnRn ()\r
-mapRn_ f (x:xs) = \r
- f x `thenRn_`\r
- mapRn_ f xs\r
-\r
-foldlRn k z [] = returnRn z\r
-foldlRn k z (x:xs) = k z x `thenRn` \ z' ->\r
- foldlRn k z' xs\r
-\r
-mapAndUnzipRn f [] = returnRn ([],[])\r
-mapAndUnzipRn f (x:xs)\r
- = f x `thenRn` \ (r1, r2) ->\r
- mapAndUnzipRn f xs `thenRn` \ (rs1, rs2) ->\r
- returnRn (r1:rs1, r2:rs2)\r
-\r
-mapAndUnzip3Rn f [] = returnRn ([],[],[])\r
-mapAndUnzip3Rn f (x:xs)\r
- = f x `thenRn` \ (r1, r2, r3) ->\r
- mapAndUnzip3Rn f xs `thenRn` \ (rs1, rs2, rs3) ->\r
- returnRn (r1:rs1, r2:rs2, r3:rs3)\r
-\r
-mapMaybeRn f [] = returnRn []\r
-mapMaybeRn f (x:xs) = f x `thenRn` \ maybe_r ->\r
- mapMaybeRn f xs `thenRn` \ rs ->\r
- case maybe_r of\r
- Nothing -> returnRn rs\r
- Just r -> returnRn (r:rs)\r
-\end{code}\r
-\r
-\r
-\r
-%************************************************************************\r
-%* *\r
-\subsection{Boring plumbing for common part}\r
-%* *\r
-%************************************************************************\r
-\r
-\r
-================ Errors and warnings =====================\r
-\r
-\begin{code}\r
-failWithRn :: a -> Message -> RnM d a\r
-failWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down\r
- = readIORef errs_var >>= \ (warns,errs) ->\r
- writeIORef errs_var (warns, errs `snocBag` err) >> \r
- return res\r
- where\r
- err = addShortErrLocLine loc msg\r
-\r
-warnWithRn :: a -> Message -> RnM d a\r
-warnWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down\r
- = readIORef errs_var >>= \ (warns,errs) ->\r
- writeIORef errs_var (warns `snocBag` warn, errs) >> \r
- return res\r
- where\r
- warn = addShortWarnLocLine loc msg\r
-\r
-addErrRn :: Message -> RnM d ()\r
-addErrRn err = failWithRn () err\r
-\r
-checkRn :: Bool -> Message -> RnM d () -- Check that a condition is true\r
-checkRn False err = addErrRn err\r
-checkRn True err = returnRn ()\r
-\r
-warnCheckRn :: Bool -> Message -> RnM d () -- Check that a condition is true\r
-warnCheckRn False err = addWarnRn err\r
-warnCheckRn True err = returnRn ()\r
-\r
-addWarnRn :: Message -> RnM d ()\r
-addWarnRn warn = warnWithRn () warn\r
-\r
-checkErrsRn :: RnM d Bool -- True <=> no errors so far\r
-checkErrsRn (RnDown {rn_errs = errs_var}) l_down\r
- = readIORef errs_var >>= \ (warns,errs) ->\r
- return (isEmptyBag errs)\r
-\end{code}\r
-\r
-\r
-================ Source location =====================\r
-\r
-\begin{code}\r
-pushSrcLocRn :: SrcLoc -> RnM d a -> RnM d a\r
-pushSrcLocRn loc' m down l_down\r
- = m (down {rn_loc = loc'}) l_down\r
-\r
-getSrcLocRn :: RnM d SrcLoc\r
-getSrcLocRn down l_down\r
- = return (rn_loc down)\r
-\end{code}\r
-\r
-================ Name supply =====================\r
-\r
-\begin{code}\r
-getNameSupplyRn :: RnM d RnNameSupply\r
-getNameSupplyRn rn_down l_down\r
- = readIORef (rn_ns rn_down)\r
-\r
-setNameSupplyRn :: RnNameSupply -> RnM d ()\r
-setNameSupplyRn names' (RnDown {rn_ns = names_var}) l_down\r
- = writeIORef names_var names'\r
-\r
--- See comments with RnNameSupply above.\r
-newInstUniq :: (OccName, OccName) -> RnM d Int\r
-newInstUniq key (RnDown {rn_ns = names_var}) l_down\r
- = readIORef names_var >>= \ (us, mapInst, cache) ->\r
- let\r
- uniq = case lookupFM mapInst key of\r
- Just x -> x+1\r
- Nothing -> 0\r
- mapInst' = addToFM mapInst key uniq\r
- in\r
- writeIORef names_var (us, mapInst', cache) >>\r
- return uniq\r
-\r
-getUniqRn :: RnM d Unique\r
-getUniqRn (RnDown {rn_ns = names_var}) l_down\r
- = readIORef names_var >>= \ (us, mapInst, cache) ->\r
- let\r
- (us1,us') = splitUniqSupply us\r
- in\r
- writeIORef names_var (us', mapInst, cache) >>\r
- return (uniqFromSupply us1)\r
-\end{code}\r
-\r
-================ Module =====================\r
-\r
-\begin{code}\r
-getModuleRn :: RnM d ModuleName\r
-getModuleRn (RnDown {rn_mod = mod_name}) l_down\r
- = return mod_name\r
-\r
-setModuleRn :: ModuleName -> RnM d a -> RnM d a\r
-setModuleRn new_mod enclosed_thing rn_down l_down\r
- = enclosed_thing (rn_down {rn_mod = new_mod}) l_down\r
-\end{code}\r
-\r
-\r
-%************************************************************************\r
-%* *\r
-\subsection{Plumbing for rename-source part}\r
-%* *\r
-%************************************************************************\r
-\r
-================ RnEnv =====================\r
-\r
-\begin{code}\r
-getNameEnvs :: RnMS (GlobalRdrEnv, LocalRdrEnv)\r
-getNameEnvs rn_down (SDown {rn_genv = global_env, rn_lenv = local_env})\r
- = return (global_env, local_env)\r
-\r
-getLocalNameEnv :: RnMS LocalRdrEnv\r
-getLocalNameEnv rn_down (SDown {rn_lenv = local_env})\r
- = return local_env\r
-\r
-setLocalNameEnv :: LocalRdrEnv -> RnMS a -> RnMS a\r
-setLocalNameEnv local_env' m rn_down l_down\r
- = m rn_down (l_down {rn_lenv = local_env'})\r
-\r
-getFixityEnv :: RnMS FixityEnv\r
-getFixityEnv rn_down (SDown {rn_fixenv = fixity_env})\r
- = return fixity_env\r
-\r
-extendFixityEnv :: [(Name, RenamedFixitySig)] -> RnMS a -> RnMS a\r
-extendFixityEnv fixes enclosed_scope\r
- rn_down l_down@(SDown {rn_fixenv = fixity_env})\r
- = let\r
- new_fixity_env = extendNameEnv fixity_env fixes\r
- in\r
- enclosed_scope rn_down (l_down {rn_fixenv = new_fixity_env})\r
-\end{code}\r
-\r
-================ Mode =====================\r
-\r
-\begin{code}\r
-getModeRn :: RnMS RnMode\r
-getModeRn rn_down (SDown {rn_mode = mode})\r
- = return mode\r
-\r
-setModeRn :: RnMode -> RnMS a -> RnMS a\r
-setModeRn new_mode thing_inside rn_down l_down\r
- = thing_inside rn_down (l_down {rn_mode = new_mode})\r
-\end{code}\r
-\r
-\r
-%************************************************************************\r
-%* *\r
-\subsection{Plumbing for rename-globals part}\r
-%* *\r
-%************************************************************************\r
-\r
-\begin{code}\r
-getIfacesRn :: RnM d Ifaces\r
-getIfacesRn (RnDown {rn_ifaces = iface_var}) _\r
- = readIORef iface_var\r
-\r
-setIfacesRn :: Ifaces -> RnM d ()\r
-setIfacesRn ifaces (RnDown {rn_ifaces = iface_var}) _\r
- = writeIORef iface_var ifaces\r
-\r
-getHiMaps :: RnM d (ModuleHiMap, ModuleHiMap)\r
-getHiMaps (RnDown {rn_hi_maps = himaps}) _ \r
- = return himaps\r
-\end{code}\r
+%
+% (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}
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
-- 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
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
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)
-- (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_`
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 ])
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
-- (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}
= -- 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))
}}
-> 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
%************************************************************************
%* *
-\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
| 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
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')
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 (..)")]
= 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),
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}
\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}
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)
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' ->
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
(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.
-- 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`
-- 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_`
(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
(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
\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
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
= 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)
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
%*********************************************************
-%* *
+%* *
\subsection{IdInfo}
-%* *
+%* *
%*********************************************************
\begin{code}
= 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)
returnRn (UfRuleBody str vars' args' rhs', fvs1 `plusFV` fvs2)
\end{code}
-UfCore expressions.
+@UfCore@ expressions.
\begin{code}
rnCoreExpr (UfType ty)
\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
%*********************************************************
-%* *
+%* *
\subsection{Errors}
-%* *
+%* *
%*********************************************************
\begin{code}
(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
--- /dev/null
+\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}
projects / ghc-hetmet.git / commitdiff