import HsCore
import CmdLineOpts ( opt_IgnoreIfacePragmas )
-import RnBinds ( rnTopBinds, rnMethodBinds )
+import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs )
import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, lookupImplicitOccRn, bindLocalsRn,
- newDfunName, checkDupOrQualNames, checkDupNames,
+ newDfunName, checkDupOrQualNames, checkDupNames, lookupGlobalOccRn,
newLocallyDefinedGlobalName, newImportedGlobalName, ifaceFlavour,
- listType_RDR, tupleType_RDR )
+ listType_RDR, tupleType_RDR, addImplicitOccRn
+ )
import RnMonad
-import Name ( Name, isLocallyDefined,
- OccName(..), occNameString, prefixOccName,
- ExportFlag(..),
- Provenance(..), getNameProvenance,
- NameSet, unionNameSets, emptyNameSet, mkNameSet, unitNameSet,
- elemNameSet, nameSetToList
+import Name ( Name, OccName(..), occNameString, prefixOccName,
+ ExportFlag(..), Provenance(..), NameSet, mkNameSet,
+ elemNameSet, nameOccName, NamedThing(..)
)
-import FiniteMap ( emptyFM, lookupFM, addListToFM_C )
+import BasicTypes ( TopLevelFlag(..) )
+import FiniteMap ( lookupFM )
import Id ( GenId{-instance NamedThing-} )
-import IdInfo ( IdInfo, StrictnessInfo(..), FBTypeInfo, DemandInfo, ArgUsageInfo )
+import IdInfo ( FBTypeInfo, ArgUsageInfo )
import Lex ( isLexCon )
-import CoreUnfold ( Unfolding(..), SimpleUnfolding )
-import MagicUFs ( MagicUnfoldingFun )
import PrelInfo ( derivingOccurrences, evalClass_RDR, numClass_RDR, allClass_NAME )
-import ListSetOps ( unionLists, minusList )
-import Maybes ( maybeToBool, catMaybes )
-import Bag ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList )
+import Maybes ( maybeToBool )
+import Bag ( bagToList )
import Outputable
import SrcLoc ( SrcLoc )
import Unique ( Unique )
where
cls_doc = text "the declaration for class" <+> ppr cname
sig_doc = text "the signatures for class" <+> ppr cname
- meth_doc = text "the default-methods for class" <+> ppr cname
+ meth_doc = text "the default-methods for class" <+> ppr cname
sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
meth_rdr_names_w_locs = bagToList (collectMonoBinders mbinds)
-- NB meth_names can be qualified!
checkDupNames meth_doc meth_names `thenRn_`
rnMethodBinds mbinds `thenRn` \ mbinds' ->
- mapRn rn_uprag uprags `thenRn` \ new_uprags ->
-
- newDfunName maybe_dfun src_loc `thenRn` \ dfun_name ->
- addOccurrenceName dfun_name `thenRn_`
+ let
+ binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds')))
+ in
+ renameSigs NotTopLevel True binders uprags `thenRn` \ new_uprags ->
+
+ let
+ -- We use the class name and the name of the first
+ -- type constructor the class is applied to.
+ (cl_nm, tycon_nm) = mkDictPrefix inst_ty'
+
+ mkDictPrefix (MonoDictTy cl tys) =
+ case tys of
+ [] -> (c_nm, nilOccName )
+ (ty:_) -> (c_nm, getInstHeadTy ty)
+ where
+ c_nm = nameOccName (getName cl)
+
+ mkDictPrefix (HsPreForAllTy _ ty) = mkDictPrefix ty
+ mkDictPrefix (HsForAllTy _ _ ty) = mkDictPrefix ty -- can this
+ mkDictPrefix _ = (nilOccName, nilOccName)
+
+ getInstHeadTy t
+ = case t of
+ MonoTyVar tv -> nameOccName (getName tv)
+ MonoTyApp t _ -> getInstHeadTy t
+ _ -> nilOccName
+ -- I cannot see how the rest of HsType constructors
+ -- can occur, but this isn't really a failure condition,
+ -- so we return silently.
+
+ nilOccName = (VarOcc _NIL_) -- ToDo: add OccName constructor fun for this.
+ in
+ newDfunName cl_nm tycon_nm maybe_dfun src_loc `thenRn` \ dfun_name ->
+ addOccurrenceName dfun_name `thenRn_`
-- The dfun is not optional, because we use its version number
-- to identify the version of the instance declaration
where
meth_doc = text "the bindings in an instance declaration"
meth_names = bagToList (collectMonoBinders mbinds)
-
- rn_uprag (SpecSig op ty using locn)
- = pushSrcLocRn src_loc $
- lookupBndrRn op `thenRn` \ op_name ->
- rnHsSigType (quotes (ppr op)) ty `thenRn` \ new_ty ->
- rn_using using `thenRn` \ new_using ->
- returnRn (SpecSig op_name new_ty new_using locn)
-
- rn_uprag (InlineSig op locn)
- = pushSrcLocRn locn $
- lookupBndrRn op `thenRn` \ op_name ->
- returnRn (InlineSig op_name locn)
-
- rn_uprag (MagicUnfoldingSig op str locn)
- = pushSrcLocRn locn $
- lookupBndrRn op `thenRn` \ op_name ->
- returnRn (MagicUnfoldingSig op_name str locn)
-
- rn_using Nothing = returnRn Nothing
- rn_using (Just v) = lookupOccRn v `thenRn` \ new_v ->
- returnRn (Just new_v)
\end{code}
%*********************************************************
%*********************************************************
%* *
+\subsection{Foreign declarations}
+%* *
+%*********************************************************
+
+\begin{code}
+rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
+ = pushSrcLocRn src_loc $
+ lookupBndrRn name `thenRn` \ name' ->
+ (if is_export then
+ addImplicitOccRn name'
+ else
+ returnRn name') `thenRn_`
+ rnHsSigType fo_decl_msg ty `thenRn` \ ty' ->
+ returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc))
+ where
+ fo_decl_msg = ptext SLIT("a foreign declaration")
+ is_export = not (maybeToBool imp_exp) && not (isDynamic ext_nm)
+
+\end{code}
+
+%*********************************************************
+%* *
\subsection{Support code for type/data declarations}
%* *
%*********************************************************
rnIdInfo (HsUpdate update) = returnRn (HsUpdate update)
rnIdInfo (HsFBType fb) = returnRn (HsFBType fb)
rnIdInfo (HsArgUsage au) = returnRn (HsArgUsage au)
+rnIdInfo (HsSpecialise tyvars tys expr)
+ = bindTyVarsRn doc tyvars $ \ tyvars' ->
+ rnCoreExpr expr `thenRn` \ expr' ->
+ mapRn rnHsType tys `thenRn` \ tys' ->
+ returnRn (HsSpecialise tyvars' tys' expr')
+ where
+ doc = text "Specialise in interface pragma"
+
rnStrict (HsStrictnessInfo demands (Just (worker,cons)))
-- The sole purpose of the "cons" field is so that we can mark the constructors
rnCoreAlts alts `thenRn` \ alts' ->
returnRn (UfCase scrut' alts')
-rnCoreExpr (UfSCC cc expr)
- = rnCoreExpr expr `thenRn` \ expr' ->
- returnRn (UfSCC cc expr')
-
-rnCoreExpr(UfCoerce coercion ty body)
- = rnCoercion coercion `thenRn` \ coercion' ->
- rnHsType ty `thenRn` \ ty' ->
- rnCoreExpr body `thenRn` \ body' ->
- returnRn (UfCoerce coercion' ty' body')
+rnCoreExpr (UfNote note expr)
+ = rnNote note `thenRn` \ note' ->
+ rnCoreExpr expr `thenRn` \ expr' ->
+ returnRn (UfNote note' expr')
rnCoreExpr (UfLam bndr body)
= rnCoreBndr bndr $ \ bndr' ->
rnCoreExpr rhs `thenRn` \ rhs' ->
returnRn (UfBindDefault bndr' rhs')
-rnCoercion (UfIn n) = lookupOccRn n `thenRn` \ n' -> returnRn (UfIn n')
-rnCoercion (UfOut n) = lookupOccRn n `thenRn` \ n' -> returnRn (UfOut n')
+rnNote (UfCoerce ty)
+ = rnHsType ty `thenRn` \ ty' ->
+ returnRn (UfCoerce ty')
+
+rnNote (UfSCC cc) = returnRn (UfSCC cc)
+rnNote UfInlineCall = returnRn UfInlineCall
rnCorePrim (UfOtherOp op)
= lookupOccRn op `thenRn` \ op' ->
4 (ppr sig)
dupClassAssertWarn ctxt (assertion : dups)
- = sep [hsep [ptext SLIT("Duplicated class assertion"),
+ = sep [hsep [ptext SLIT("Duplicate class assertion"),
quotes (pprClassAssertion assertion),
ptext SLIT("in the context:")],
nest 4 (pprContext ctxt)]
projects / ghc-hetmet.git / blobdiff