import HsDecls ( HsIdInfo(..), HsStrictnessInfo(..) )
import HsPragmas
import HsTypes ( getTyVarName, pprClassAssertion, cmpHsTypes )
-import RdrHsSyn
+import RdrName ( RdrName, isRdrDataCon, rdrNameOcc )
+import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
+ extractHsTyVars
+ )
import RnHsSyn
import HsCore
import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn,
lookupImplicitOccRn, addImplicitOccRn,
bindLocalsRn,
- bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvRn,
+ bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn,
checkDupOrQualNames, checkDupNames,
newLocallyDefinedGlobalName, newImportedGlobalName,
newImportedGlobalFromRdrName,
- ifaceFlavour, newDFunName,
+ newDFunName,
FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV
)
import RnMonad
import Name ( Name, OccName,
ExportFlag(..), Provenance(..),
- nameOccName, NamedThing(..), isConOcc,
+ nameOccName, NamedThing(..),
mkDefaultMethodOcc, mkDFunOcc
)
import NameSet
-import BasicTypes ( TopLevelFlag(..), IfaceFlavour(..) )
+import BasicTypes ( TopLevelFlag(..) )
import TysWiredIn ( tupleTyCon, unboxedTupleTyCon, listTyCon )
import Type ( funTyCon )
import FiniteMap ( elemFM )
-- Fixity decls have been dealt with already; ignore them
go fvs ds' [] = returnRn (ds', fvs)
go fvs ds' (FixD _:ds) = go fvs ds' ds
- go fvs ds' (d:ds) = rnDecl d `thenRn` \(d', fvs) ->
- go (fvs `plusFV` fvs) (d':ds') ds
+ go fvs ds' (d:ds) = rnDecl d `thenRn` \(d', fvs') ->
+ go (fvs `plusFV` fvs') (d':ds') ds
rnIfaceDecl :: RdrNameHsDecl -> RnMS s RenamedHsDecl
rnIfaceDecl d
returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc),
cxt_fvs `plusFV` plusFVs con_fvs_s `plusFV` deriv_fvs)
where
- data_doc = text "the data typecodeGen/ declaration for" <+> ppr tycon
+ data_doc = text "the data type declaration for" <+> quotes (ppr tycon)
con_names = map conDeclName condecls
rnDecl (TyClD (TySynonym name tyvars ty src_loc))
(InterfaceMode _, Just _)
-> -- Imported class that has a default method decl
- newImportedGlobalName mod_name dm_occ (ifaceFlavour clas) `thenRn` \ dm_name ->
- addOccurrenceName dm_name `thenRn_`
+ newImportedGlobalName mod_name dm_occ `thenRn` \ dm_name ->
+ addOccurrenceName dm_name `thenRn_`
returnRn (Just dm_name)
other -> returnRn Nothing
-- (Slightly strangely) the forall-d tyvars scope over
-- the method bindings too
in
- extendTyVarEnvRn inst_tyvars $
+ extendTyVarEnvFVRn inst_tyvars $
-- Rename the bindings
-- NB meth_names can be qualified!
let
binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds')))
in
- renameSigs NotTopLevel True binders uprags `thenRn` \ new_uprags ->
+ renameSigs NotTopLevel True binders uprags `thenRn` \ (new_uprags, prag_fvs) ->
mkDFunName inst_ty' maybe_dfun src_loc `thenRn` \ dfun_name ->
addOccurrenceName dfun_name `thenRn_`
-- The dfun is not optional, because we use its version number
-- The typechecker checks that all the bindings are for the right class.
returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags (Just dfun_name) src_loc),
- inst_fvs `plusFV` meth_fvs)
+ inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs)
where
meth_doc = text "the bindings in an instance declaration"
meth_names = bagToList (collectMonoBinders mbinds)
rnDerivs (Just ds)
= mapRn rn_deriv ds `thenRn` \ derivs ->
- returnRn (Just derivs, mkNameSet derivs)
+ returnRn (Just derivs, foldl addOneFV emptyFVs derivs)
where
rn_deriv clas
= lookupOccRn clas `thenRn` \ clas_name ->
rnBangTy doc ty2 `thenRn` \ (new_ty2, fvs2) ->
returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2)
-rnConDetails doc locn (NewCon ty)
- = rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
- returnRn (NewCon new_ty, fvs)
+rnConDetails doc locn (NewCon ty mb_field)
+ = rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
+ rn_field mb_field `thenRn` \ new_mb_field ->
+ returnRn (NewCon new_ty new_mb_field, fvs)
+ where
+ rn_field Nothing = returnRn Nothing
+ rn_field (Just f) =
+ lookupBndrRn f `thenRn` \ new_f ->
+ returnRn (Just new_f)
rnConDetails doc locn (RecCon fields)
= checkDupOrQualNames doc field_names `thenRn_`
-- from interface files, which always print in prefix form
checkConName name
- = checkRn (isConOcc (rdrNameOcc name))
+ = checkRn (isRdrDataCon name)
(badDataCon name)
\end{code}
rnCoreExpr (UfCase scrut bndr alts)
= rnCoreExpr scrut `thenRn` \ scrut' ->
- bindLocalsRn "UfCase" [bndr] $ \ [bndr'] ->
+ bindLocalsRn "a UfCase" [bndr] $ \ [bndr'] ->
mapRn rnCoreAlt alts `thenRn` \ alts' ->
returnRn (UfCase scrut' bndr' alts')
str = "unfolding id"
rnCoreBndr (UfTyBinder name kind) thing_inside
- = bindLocalsRn "unfolding tyvar" [name] $ \ [name'] ->
+ = bindLocalsRn "an unfolding tyvar" [name] $ \ [name'] ->
thing_inside (UfTyBinder name' kind)
rnCoreBndrs bndrs thing_inside -- Expect them all to be ValBinders
\begin{code}
rnCoreAlt (con, bndrs, rhs)
- = rnUfCon con `thenRn` \ con' ->
- bindLocalsRn "unfolding alt" bndrs $ \ bndrs' ->
- rnCoreExpr rhs `thenRn` \ rhs' ->
+ = rnUfCon con `thenRn` \ con' ->
+ bindLocalsRn "an unfolding alt" bndrs $ \ bndrs' ->
+ rnCoreExpr rhs `thenRn` \ rhs' ->
returnRn (con', bndrs', rhs')
= lookupOccRn op `thenRn` \ op' ->
returnRn (UfPrimOp op')
-rnUfCon (UfCCallOp str casm gc)
- = returnRn (UfCCallOp str casm gc)
+rnUfCon (UfCCallOp str is_dyn casm gc)
+ = returnRn (UfCCallOp str is_dyn casm gc)
\end{code}
%*********************************************************
= sep [hsep [ptext SLIT("Duplicate class assertion"),
quotes (pprClassAssertion assertion),
ptext SLIT("in the context:")],
- nest 4 (pprContext ctxt)]
+ nest 4 (pprContext ctxt <+> ptext SLIT("..."))]
badDataCon name
= hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
projects / ghc-hetmet.git / blobdiff