-%*********************************************************
-%* *
-\subsection{Default declarations}
-%* *
-%*********************************************************
-
-\begin{code}
-rnDecl (DefD (DefaultDecl tys src_loc))
- = pushSrcLocRn src_loc $
- rnHsTypes doc_str tys `thenRn` \ (tys', fvs) ->
- returnRn (DefD (DefaultDecl tys' src_loc), fvs)
- where
- doc_str = text "a `default' declaration"
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Foreign declarations}
-%* *
-%*********************************************************
-
-\begin{code}
-rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
- = pushSrcLocRn src_loc $
- lookupOccRn name `thenRn` \ name' ->
- let
- extra_fvs FoExport
- | isDyn = lookupOrigNames [makeStablePtr_RDR, deRefStablePtr_RDR,
- bindIO_RDR, returnIO_RDR]
- | otherwise =
- lookupOrigNames [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs ->
- returnRn (addOneFV fvs name')
- extra_fvs other = returnRn emptyFVs
- in
- checkRn (ok_ext_nm ext_nm) (badExtName ext_nm) `thenRn_`
-
- extra_fvs imp_exp `thenRn` \ fvs1 ->
-
- rnHsSigType fo_decl_msg ty `thenRn` \ (ty', fvs2) ->
- returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc),
- fvs1 `plusFV` fvs2)
- where
- fo_decl_msg = ptext SLIT("a foreign declaration")
- isDyn = isDynamicExtName ext_nm
-
- ok_ext_nm Dynamic = True
- ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb
- ok_ext_nm (ExtName nm Nothing) = isCLabelString nm
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Rules}
-%* *
-%*********************************************************
-
-\begin{code}
-rnDecl (RuleD (IfaceRule rule_name vars fn args rhs src_loc))
- = pushSrcLocRn src_loc $
- lookupOccRn fn `thenRn` \ fn' ->
- rnCoreBndrs vars $ \ vars' ->
- mapFvRn rnCoreExpr args `thenRn` \ (args', fvs1) ->
- rnCoreExpr rhs `thenRn` \ (rhs', fvs2) ->
- returnRn (RuleD (IfaceRule rule_name vars' fn' args' rhs' src_loc),
- (fvs1 `plusFV` fvs2) `addOneFV` fn')
-
-rnDecl (RuleD (IfaceRuleOut fn rule))
- -- This one is used for BuiltInRules
- -- The rule itself is already done, but the thing
- -- to attach it to is not.
- = lookupOccRn fn `thenRn` \ fn' ->
- returnRn (RuleD (IfaceRuleOut fn' rule), unitFV fn')
-
-rnDecl (RuleD (HsRule rule_name tvs vars lhs rhs src_loc))
- = ASSERT( null tvs )
- pushSrcLocRn src_loc $
-
- bindTyVarsFV2Rn doc (map UserTyVar sig_tvs) $ \ sig_tvs' _ ->
- bindLocalsFVRn doc (map get_var vars) $ \ ids ->
- mapFvRn rn_var (vars `zip` ids) `thenRn` \ (vars', fv_vars) ->
-
- rnExpr lhs `thenRn` \ (lhs', fv_lhs) ->
- rnExpr rhs `thenRn` \ (rhs', fv_rhs) ->
- checkRn (validRuleLhs ids lhs')
- (badRuleLhsErr rule_name lhs') `thenRn_`
- let
- bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
- in
- mapRn (addErrRn . badRuleVar rule_name) bad_vars `thenRn_`
- returnRn (RuleD (HsRule rule_name sig_tvs' vars' lhs' rhs' src_loc),
- fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
- where
- doc = text "the transformation rule" <+> ptext rule_name
- sig_tvs = extractRuleBndrsTyVars vars
-
- get_var (RuleBndr v) = v
- get_var (RuleBndrSig v _) = v
-
- rn_var (RuleBndr v, id) = returnRn (RuleBndr id, emptyFVs)
- rn_var (RuleBndrSig v t, id) = rnHsType doc t `thenRn` \ (t', fvs) ->
- returnRn (RuleBndrSig id t', fvs)