-%*********************************************************
-%* *
-\subsection{IdInfo}
-%* *
-%*********************************************************
-
-\begin{code}
-rnIdInfo (HsWorker worker arity)
- = lookupOccRn worker `thenM` \ worker' ->
- returnM (HsWorker worker' arity)
-
-rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenM` \ expr' ->
- returnM (HsUnfold inline expr')
-rnIdInfo (HsStrictness str) = returnM (HsStrictness str)
-rnIdInfo (HsArity arity) = returnM (HsArity arity)
-rnIdInfo HsNoCafRefs = returnM HsNoCafRefs
-\end{code}
-
-@UfCore@ expressions.
-
-\begin{code}
-rnCoreExpr (UfType ty)
- = rnHsType (text "unfolding type") ty `thenM` \ ty' ->
- returnM (UfType ty')
-
-rnCoreExpr (UfVar v)
- = lookupOccRn v `thenM` \ v' ->
- returnM (UfVar v')
-
-rnCoreExpr (UfLit l)
- = returnM (UfLit l)
-
-rnCoreExpr (UfLitLit l ty)
- = rnHsType (text "litlit") ty `thenM` \ ty' ->
- returnM (UfLitLit l ty')
-
-rnCoreExpr (UfFCall cc ty)
- = rnHsType (text "ccall") ty `thenM` \ ty' ->
- returnM (UfFCall cc ty')
-
-rnCoreExpr (UfTuple (HsTupCon boxity arity) args)
- = mappM rnCoreExpr args `thenM` \ args' ->
- returnM (UfTuple (HsTupCon boxity arity) args')
-
-rnCoreExpr (UfApp fun arg)
- = rnCoreExpr fun `thenM` \ fun' ->
- rnCoreExpr arg `thenM` \ arg' ->
- returnM (UfApp fun' arg')
-
-rnCoreExpr (UfCase scrut bndr alts)
- = rnCoreExpr scrut `thenM` \ scrut' ->
- bindCoreLocalRn bndr $ \ bndr' ->
- mappM rnCoreAlt alts `thenM` \ alts' ->
- returnM (UfCase scrut' bndr' alts')
-
-rnCoreExpr (UfNote note expr)
- = rnNote note `thenM` \ note' ->
- rnCoreExpr expr `thenM` \ expr' ->
- returnM (UfNote note' expr')
-
-rnCoreExpr (UfLam bndr body)
- = rnCoreBndr bndr $ \ bndr' ->
- rnCoreExpr body `thenM` \ body' ->
- returnM (UfLam bndr' body')
-
-rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
- = rnCoreExpr rhs `thenM` \ rhs' ->
- rnCoreBndr bndr $ \ bndr' ->
- rnCoreExpr body `thenM` \ body' ->
- returnM (UfLet (UfNonRec bndr' rhs') body')
-
-rnCoreExpr (UfLet (UfRec pairs) body)
- = rnCoreBndrs bndrs $ \ bndrs' ->
- mappM rnCoreExpr rhss `thenM` \ rhss' ->
- rnCoreExpr body `thenM` \ body' ->
- returnM (UfLet (UfRec (bndrs' `zip` rhss')) body')
- where
- (bndrs, rhss) = unzip pairs
-\end{code}
-
-\begin{code}
-rnCoreBndr (UfValBinder name ty) thing_inside
- = rnHsType doc ty `thenM` \ ty' ->
- bindCoreLocalRn name $ \ name' ->
- thing_inside (UfValBinder name' ty')
- where
- doc = text "unfolding id"
-
-rnCoreBndr (UfTyBinder name kind) thing_inside
- = bindCoreLocalRn name $ \ name' ->
- thing_inside (UfTyBinder name' kind)
-
-rnCoreBndrs [] thing_inside = thing_inside []
-rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b $ \ name' ->
- rnCoreBndrs bs $ \ names' ->
- thing_inside (name':names')
-\end{code}
-
-\begin{code}
-rnCoreAlt (con, bndrs, rhs)
- = rnUfCon con `thenM` \ con' ->
- bindCoreLocalsRn bndrs $ \ bndrs' ->
- rnCoreExpr rhs `thenM` \ rhs' ->
- returnM (con', bndrs', rhs')
-
-rnNote (UfCoerce ty)
- = rnHsType (text "unfolding coerce") ty `thenM` \ ty' ->
- returnM (UfCoerce ty')
-
-rnNote (UfSCC cc) = returnM (UfSCC cc)
-rnNote UfInlineCall = returnM UfInlineCall
-rnNote UfInlineMe = returnM UfInlineMe
-
-
-rnUfCon UfDefault
- = returnM UfDefault
-
-rnUfCon (UfTupleAlt tup_con)
- = returnM (UfTupleAlt tup_con)
-
-rnUfCon (UfDataAlt con)
- = lookupOccRn con `thenM` \ con' ->
- returnM (UfDataAlt con')
-
-rnUfCon (UfLitAlt lit)
- = returnM (UfLitAlt lit)
-
-rnUfCon (UfLitLitAlt lit ty)
- = rnHsType (text "litlit") ty `thenM` \ ty' ->
- returnM (UfLitLitAlt lit ty')
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Statistics}
-%* *
-%*********************************************************
-
-\begin{code}
-rnStats :: [RenamedHsDecl] -- Imported decls
- -> TcRn m ()
-rnStats imp_decls
- = doptM Opt_D_dump_rn_trace `thenM` \ dump_rn_trace ->
- doptM Opt_D_dump_rn_stats `thenM` \ dump_rn_stats ->
- doptM Opt_D_dump_rn `thenM` \ dump_rn ->
- getEps `thenM` \ eps ->
-
- ioToTcRn (dumpIfSet (dump_rn_trace || dump_rn_stats || dump_rn)
- "Renamer statistics"
- (getRnStats eps imp_decls)) `thenM_`
- returnM ()
-
-getRnStats :: ExternalPackageState -> [RenamedHsDecl] -> SDoc
-getRnStats eps imported_decls
- = hcat [text "Renamer stats: ", stats]
- where
- n_mods = length [() | _ <- moduleEnvElts (eps_PIT eps)]
- -- This is really only right for a one-shot compile
-
- (decls_map, n_decls_slurped) = eps_decls eps
-
- n_decls_left = length [decl | (avail, True, (_,decl)) <- nameEnvElts decls_map
- -- 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
- ]
-
- (insts_left, n_insts_slurped) = eps_insts eps
- n_insts_left = length (bagToList insts_left)
-
- (rules_left, n_rules_slurped) = eps_rules eps
- n_rules_left = length (bagToList rules_left)
-
- stats = vcat
- [int n_mods <+> text "interfaces read",
- hsep [ int n_decls_slurped, text "type/class/variable imported, out of",
- int (n_decls_slurped + n_decls_left), text "read"],
- hsep [ int n_insts_slurped, text "instance decls imported, out of",
- int (n_insts_slurped + n_insts_left), text "read"],
- hsep [ int n_rules_slurped, text "rule decls imported, out of",
- int (n_rules_slurped + n_rules_left), text "read"]
- ]
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Errors}
-%* *
-%*********************************************************
-
-\begin{code}
-badDataCon name
- = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
-
-badRuleLhsErr name lhs (Just bad_e)
- = sep [ptext SLIT("Rule") <+> ftext name <> colon,
- nest 4 (vcat [ptext SLIT("Illegal expression:") <+> ppr bad_e,
- ptext SLIT("in left-hand side:") <+> ppr lhs])]
- $$
- ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
-
-badRuleVar name var
- = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon,
- ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
- ptext SLIT("does not appear on left hand side")]
-
-emptyConDeclsErr tycon
- = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
- nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))]
-\end{code}