#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
IMPORT_DELOOPER(RnLoop) -- *check* the RnPass/RnExpr/RnBinds loop-breaking
#else
-import {-# SOURCE #-} RnExpr
+import RnExpr
+--import {-# SOURCE #-} RnExpr
#endif
import HsSyn
-import HsDecls ( HsIdInfo(..) )
+import HsDecls ( HsIdInfo(..), HsStrictnessInfo(..) )
import HsPragmas
import HsTypes ( getTyVarName )
import RdrHsSyn
import RnBinds ( rnTopBinds, rnMethodBinds )
import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, lookupImplicitOccRn, bindLocalsRn,
- newSysName, newDfunName, checkDupOrQualNames, checkDupNames,
+ newDfunName, checkDupOrQualNames, checkDupNames,
+ newLocallyDefinedGlobalName, newGlobalName, ifaceFlavour,
listType_RDR, tupleType_RDR )
import RnMonad
import Name ( Name, isLocallyDefined,
OccName(..), occNameString, prefixOccName,
ExportFlag(..),
- Provenance,
+ Provenance(..), getNameProvenance,
SYN_IE(NameSet), unionNameSets, emptyNameSet, mkNameSet, unitNameSet,
elemNameSet
)
import ListSetOps ( unionLists, minusList )
import Maybes ( maybeToBool, catMaybes )
import Bag ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList )
-import Outputable ( PprStyle(..), Outputable(..){-instances-} )
+import Outputable ( PprStyle(..), Outputable(..){-instances-}, pprQuote )
import Pretty
import SrcLoc ( SrcLoc )
import Unique ( Unique )
import UniqSet ( SYN_IE(UniqSet) )
import UniqFM ( UniqFM, lookupUFM )
-import Util {- ( isIn, isn'tIn, thenCmp, removeDups, cmpPString,
- panic, assertPanic{- , pprTrace ToDo:rm-} ) -}
+import Util
+IMPORT_1_3(List(nub))
\end{code}
rnDecl `renames' declarations.
\begin{code}
rnDecl (ClD (ClassDecl context cname tyvar sigs mbinds pragmas src_loc))
= pushSrcLocRn src_loc $
+
bindTyVarsRn cls_doc [tyvar] ( \ [tyvar'] ->
rnContext context `thenRn` \ context' ->
lookupBndrRn cname `thenRn` \ cname' ->
-- Check the signatures
- checkDupOrQualNames sig_doc sig_names `thenRn_`
- mapRn (rn_op cname' (getTyVarName tyvar')) sigs `thenRn` \ sigs' ->
+ checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_`
+ mapRn (rn_op cname' (getTyVarName tyvar')) sigs `thenRn` \ sigs' ->
returnRn (tyvar', context', cname', sigs')
) `thenRn` \ (tyvar', context', cname', sigs') ->
-- Check the methods
- checkDupOrQualNames meth_doc meth_names `thenRn_`
+ checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
rnMethodBinds mbinds `thenRn` \ mbinds' ->
-- Typechecker is responsible for checking that we only
sig_doc sty = text "the signatures for class" <+> ppr sty cname
meth_doc sty = text "the default-methods for class" <+> ppr sty cname
- sig_names = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
- meth_names = bagToList (collectMonoBinders mbinds)
+ sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
+ meth_rdr_names_w_locs = bagToList (collectMonoBinders mbinds)
+ meth_rdr_names = map fst meth_rdr_names_w_locs
- rn_op clas clas_tyvar sig@(ClassOpSig op _ ty locn)
+ rn_op clas clas_tyvar sig@(ClassOpSig op maybe_dm ty locn)
= pushSrcLocRn locn $
lookupBndrRn op `thenRn` \ op_name ->
rnHsSigType (\sty -> ppr sty op) ty `thenRn` \ new_ty ->
- -- Call up interface info for default method, if such info exists
+ -- Make the default-method name
let
dm_occ = prefixOccName SLIT("$m") (rdrNameOcc op)
in
- newSysName dm_occ Exported locn `thenRn` \ dm_name ->
- setModeRn (InterfaceMode Optional) (
- addOccurrenceName dm_name
- ) `thenRn_`
+ getModuleRn `thenRn` \ mod_name ->
+ getModeRn `thenRn` \ mode ->
+ (case (mode, maybe_dm) of
+ (SourceMode, _) | op `elem` meth_rdr_names
+ -> -- There's an explicit method decl
+ newLocallyDefinedGlobalName mod_name dm_occ
+ (\_ -> Exported) locn `thenRn` \ dm_name ->
+ returnRn (Just dm_name)
+
+ (InterfaceMode _, Just _)
+ -> -- Imported class that has a default method decl
+ newGlobalName mod_name dm_occ (ifaceFlavour clas) `thenRn` \ dm_name ->
+ addOccurrenceName dm_name `thenRn_`
+ returnRn (Just dm_name)
+
+ other -> returnRn Nothing
+ ) `thenRn` \ maybe_dm_name ->
-- Checks.....
let
(classTyVarNotInOpTyErr clas_tyvar sig)
`thenRn_`
- -- Check that class tyvar *doesn't* appear in the sig's context
- checkRn (not (clas_tyvar `elemNameSet` ctxt_fvs))
- (classTyVarInOpCtxtErr clas_tyvar sig)
- `thenRn_`
-
- returnRn (ClassOpSig op_name dm_name new_ty locn)
+ returnRn (ClassOpSig op_name maybe_dm_name new_ty locn)
\end{code}
-- rnHsSigType is used for source-language type signatures,
-- which use *implicit* universal quantification.
+-- Given the signature C => T we universally quantify over FV(T) \ {in-scope-tyvars}
+--
+-- We insist that the universally quantified type vars is a superset of FV(C)
+-- It follows that FV(T) is a superset of FV(C), so that the context constrains
+-- no type variables that don't appear free in the tau-type part.
+
rnHsSigType doc_str full_ty@(HsPreForAllTy ctxt ty) -- From source code (no kinds on tyvars)
= getNameEnv `thenRn` \ name_env ->
let
- mentioned_tyvars = extractHsTyVars full_ty
- forall_tyvars = filter not_in_scope mentioned_tyvars
- not_in_scope tv = case lookupFM name_env tv of
- Nothing -> True
- Just _ -> False
-
- non_foralld_constrained = [tv | (clas, ty) <- ctxt,
- tv <- extractHsTyVars ty,
- not (tv `elem` forall_tyvars)
- ]
+ mentioned_tyvars = extractHsTyVars ty
+ forall_tyvars = filter (not . in_scope) mentioned_tyvars
+ in_scope tv = maybeToBool (lookupFM name_env tv)
+
+ constrained_tyvars = nub (concat (map (extractHsTyVars . snd) ctxt))
+ constrained_and_in_scope = filter in_scope constrained_tyvars
+ constrained_and_not_mentioned = filter (not . (`elem` mentioned_tyvars)) constrained_tyvars
+
+ -- Zap the context if there's a problem, to avoid duplicate error message.
+ ctxt' | null constrained_and_in_scope && null constrained_and_not_mentioned = ctxt
+ | otherwise = []
in
- checkRn (null non_foralld_constrained)
- (ctxtErr sig_doc non_foralld_constrained) `thenRn_`
+ checkRn (null constrained_and_in_scope)
+ (ctxtErr1 sig_doc constrained_and_in_scope) `thenRn_`
+ checkRn (null constrained_and_not_mentioned)
+ (ctxtErr2 sig_doc constrained_and_not_mentioned ty) `thenRn_`
(bindTyVarsRn sig_doc (map UserTyVar forall_tyvars) $ \ new_tyvars ->
- rnContext ctxt `thenRn` \ new_ctxt ->
+ rnContext ctxt' `thenRn` \ new_ctxt ->
rnHsType ty `thenRn` \ new_ty ->
returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
)
rnIdInfo (HsArgUsage au) = returnRn (HsArgUsage au)
rnIdInfo (HsDeforest df) = returnRn (HsDeforest df)
-rnStrict (StrictnessInfo demands (Just (worker,cons)))
+rnStrict (HsStrictnessInfo demands (Just (worker,cons)))
-- The sole purpose of the "cons" field is so that we can mark the constructors
-- needed to build the wrapper as "needed", so that their data type decl will be
-- slurped in. After that their usefulness is o'er, so we just put in the empty list.
= lookupOccRn worker `thenRn` \ worker' ->
mapRn lookupOccRn cons `thenRn_`
- returnRn (StrictnessInfo demands (Just (worker',[])))
+ returnRn (HsStrictnessInfo demands (Just (worker',[])))
-- Boring, but necessary for the type checker.
-rnStrict (StrictnessInfo demands Nothing) = returnRn (StrictnessInfo demands Nothing)
-rnStrict BottomGuaranteed = returnRn BottomGuaranteed
-rnStrict NoStrictnessInfo = returnRn NoStrictnessInfo
+rnStrict (HsStrictnessInfo demands Nothing) = returnRn (HsStrictnessInfo demands Nothing)
+rnStrict HsBottom = returnRn HsBottom
\end{code}
UfCore expressions.
\begin{code}
derivingNonStdClassErr clas sty
- = hsep [ptext SLIT("non-standard class in deriving:"), ppr sty clas]
+ = hsep [ptext SLIT("non-standard class"), ppr sty clas, ptext SLIT("in deriving clause")]
classTyVarNotInOpTyErr clas_tyvar sig sty
- = hang (hcat [ptext SLIT("Class type variable `"),
+ = hang (hsep [ptext SLIT("Class type variable"),
ppr sty clas_tyvar,
- ptext SLIT("' does not appear in method signature:")])
- 4 (ppr sty sig)
-
-classTyVarInOpCtxtErr clas_tyvar sig sty
- = hang (hcat [ ptext SLIT("Class type variable `"), ppr sty clas_tyvar,
- ptext SLIT("' present in method's local overloading context:")])
+ ptext SLIT("does not appear in method signature")])
4 (ppr sty sig)
-dupClassAssertWarn ctxt dups sty
- = hang (hcat [ptext SLIT("Duplicate class assertion `"),
- ppr sty dups,
- ptext SLIT("' in context:")])
- 4 (ppr sty ctxt)
+dupClassAssertWarn ctxt ((clas,ty) : dups) sty
+ = sep [hsep [ptext SLIT("Duplicated class assertion"),
+ pprQuote sty $ \ sty -> ppr sty clas <+> ppr sty ty,
+ ptext SLIT("in context:")],
+ nest 4 (pprQuote sty $ \ sty -> pprContext sty ctxt)]
badDataCon name sty
- = hsep [ptext SLIT("Illegal data constructor name:"), ppr sty name]
+ = hsep [ptext SLIT("Illegal data constructor name"), ppr sty name]
allOfNonTyVar ty sty
- = hsep [ptext SLIT("`All' applied to a non-type variable:"), ppr sty ty]
+ = hsep [ptext SLIT("`All' applied to a non-type variable"), ppr sty ty]
-ctxtErr doc tyvars sty
- = hsep [ptext SLIT("Context constrains type variable(s)"),
+ctxtErr1 doc tyvars sty
+ = hsep [ptext SLIT("Context constrains in-scope type variable(s)"),
hsep (punctuate comma (map (ppr sty) tyvars))]
- $$ nest 4 (ptext SLIT("in") <+> doc sty)
+ $$
+ nest 4 (ptext SLIT("in") <+> doc sty)
+
+ctxtErr2 doc tyvars ty sty
+ = (ptext SLIT("Context constrains type variable(s)")
+ <+> hsep (punctuate comma (map (ppr sty) tyvars)))
+ $$
+ nest 4 (vcat [ptext SLIT("that do not appear in") <+> ppr sty ty,
+ ptext SLIT("in") <+> doc sty])
\end{code}
projects / ghc-hetmet.git / blobdiff