-%*********************************************************
-%* *
-\subsection{IdInfo}
-%* *
-%*********************************************************
-
-\begin{code}
-rnIdInfo (HsWorker worker)
- = lookupOccRn worker `thenRn` \ worker' ->
- returnRn (HsWorker worker')
-
-rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ expr' ->
- returnRn (HsUnfold inline expr')
-rnIdInfo (HsStrictness str) = returnRn (HsStrictness str)
-rnIdInfo (HsArity arity) = returnRn (HsArity arity)
-rnIdInfo HsNoCafRefs = returnRn HsNoCafRefs
-rnIdInfo HsCprInfo = returnRn HsCprInfo
-\end{code}
-
-@UfCore@ expressions.
-
-\begin{code}
-rnCoreExpr (UfType ty)
- = rnHsType (text "unfolding type") ty `thenRn` \ ty' ->
- returnRn (UfType ty')
-
-rnCoreExpr (UfVar v)
- = lookupOccRn v `thenRn` \ v' ->
- returnRn (UfVar v')
-
-rnCoreExpr (UfLit l)
- = returnRn (UfLit l)
-
-rnCoreExpr (UfLitLit l ty)
- = rnHsType (text "litlit") ty `thenRn` \ ty' ->
- returnRn (UfLitLit l ty')
-
-rnCoreExpr (UfCCall cc ty)
- = rnHsType (text "ccall") ty `thenRn` \ ty' ->
- returnRn (UfCCall cc ty')
-
-rnCoreExpr (UfTuple con args)
- = rnHsTupConWkr con `thenRn` \ con' ->
- mapRn rnCoreExpr args `thenRn` \ args' ->
- returnRn (UfTuple con' args')
-
-rnCoreExpr (UfApp fun arg)
- = rnCoreExpr fun `thenRn` \ fun' ->
- rnCoreExpr arg `thenRn` \ arg' ->
- returnRn (UfApp fun' arg')
-
-rnCoreExpr (UfCase scrut bndr alts)
- = rnCoreExpr scrut `thenRn` \ scrut' ->
- bindCoreLocalRn bndr $ \ bndr' ->
- mapRn rnCoreAlt alts `thenRn` \ alts' ->
- returnRn (UfCase scrut' bndr' alts')
-
-rnCoreExpr (UfNote note expr)
- = rnNote note `thenRn` \ note' ->
- rnCoreExpr expr `thenRn` \ expr' ->
- returnRn (UfNote note' expr')
-
-rnCoreExpr (UfLam bndr body)
- = rnCoreBndr bndr $ \ bndr' ->
- rnCoreExpr body `thenRn` \ body' ->
- returnRn (UfLam bndr' body')
-
-rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
- = rnCoreExpr rhs `thenRn` \ rhs' ->
- rnCoreBndr bndr $ \ bndr' ->
- rnCoreExpr body `thenRn` \ body' ->
- returnRn (UfLet (UfNonRec bndr' rhs') body')
-
-rnCoreExpr (UfLet (UfRec pairs) body)
- = rnCoreBndrs bndrs $ \ bndrs' ->
- mapRn rnCoreExpr rhss `thenRn` \ rhss' ->
- rnCoreExpr body `thenRn` \ body' ->
- returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body')
- where
- (bndrs, rhss) = unzip pairs
-\end{code}
-
-\begin{code}
-rnCoreBndr (UfValBinder name ty) thing_inside
- = rnHsType doc ty `thenRn` \ 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 bndrs `thenRn` \ con' ->
- bindCoreLocalsRn bndrs $ \ bndrs' ->
- rnCoreExpr rhs `thenRn` \ rhs' ->
- returnRn (con', bndrs', rhs')
-
-rnNote (UfCoerce ty)
- = rnHsType (text "unfolding coerce") ty `thenRn` \ ty' ->
- returnRn (UfCoerce ty')
-
-rnNote (UfSCC cc) = returnRn (UfSCC cc)
-rnNote UfInlineCall = returnRn UfInlineCall
-rnNote UfInlineMe = returnRn UfInlineMe
-
-
-rnUfCon UfDefault _
- = returnRn UfDefault
-
-rnUfCon (UfTupleAlt tup_con) bndrs
- = rnHsTupCon tup_con `thenRn` \ (HsTupCon con' _) ->
- returnRn (UfDataAlt con')
- -- Makes the type checker a little easier
-
-rnUfCon (UfDataAlt con) _
- = lookupOccRn con `thenRn` \ con' ->
- returnRn (UfDataAlt con')
-
-rnUfCon (UfLitAlt lit) _
- = returnRn (UfLitAlt lit)
-
-rnUfCon (UfLitLitAlt lit ty) _
- = rnHsType (text "litlit") ty `thenRn` \ ty' ->
- returnRn (UfLitLitAlt lit 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.
-
-\begin{code}
-validRuleLhs foralls lhs
- = check lhs
- where
- check (HsApp e1 e2) = check e1
- check (HsVar v) | v `notElem` foralls = True
- check other = False
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Errors}
-%* *
-%*********************************************************
-
-\begin{code}
-derivingNonStdClassErr clas
- = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")]
-
-badDataCon name
- = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
-
-forAllWarn doc ty tyvar
- = doptRn Opt_WarnUnusedMatches `thenRn` \ warn_unused -> case () of
- () | not warn_unused -> returnRn ()
- | otherwise
- -> getModeRn `thenRn` \ mode ->
- case mode of {
-#ifndef DEBUG
- InterfaceMode -> returnRn () ; -- Don't warn of unused tyvars in interface files
- -- unless DEBUG is on, in which case it is slightly
- -- informative. They can arise from mkRhsTyLam,
-#endif -- leading to (say) f :: forall a b. [b] -> [b]
- other ->
- addWarnRn (
- sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
- nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
- $$
- (ptext SLIT("In") <+> doc)
- )
- }
-
-badRuleLhsErr name lhs
- = sep [ptext SLIT("Rule") <+> ptext name <> colon,
- nest 4 (ptext SLIT("Illegal 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") <+> ptext name <> colon,
- ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
- ptext SLIT("does not appear on left hand side")]
-
-badExtName :: ExtName -> Message
-badExtName ext_nm
- = sep [quotes (ppr ext_nm) <+> ptext SLIT("is not a valid C identifier")]
-
-dupClassAssertWarn ctxt (assertion : dups)
- = sep [hsep [ptext SLIT("Duplicate class assertion"),
- quotes (ppr assertion),
- ptext SLIT("in the context:")],
- nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))]
-
-naughtyCCallContextErr (HsPClass clas _)
- = sep [ptext SLIT("Can't use class") <+> quotes (ppr clas),
- ptext SLIT("in a context")]
-\end{code}