diff options
Diffstat (limited to 'compiler/rename')
| -rw-r--r-- | compiler/rename/RnEnv.lhs | 17 | ||||
| -rw-r--r-- | compiler/rename/RnExpr.lhs-boot | 19 | ||||
| -rw-r--r-- | compiler/rename/RnNames.lhs | 34 | ||||
| -rw-r--r-- | compiler/rename/RnSource.lhs | 23 | ||||
| -rw-r--r-- | compiler/rename/RnTypes.lhs | 6 |
5 files changed, 55 insertions, 44 deletions
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index bd424e87b8..ecd2cd3147 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -39,7 +39,7 @@ module RnEnv ( addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS, warnUnusedMatches, warnUnusedTopBinds, warnUnusedLocalBinds, - dataTcOccs, unknownNameErr, kindSigErr, polyKindsErr, perhapsForallMsg, + dataTcOccs, unknownNameErr, kindSigErr, dataKindsErr, perhapsForallMsg, HsDocContext(..), docOfHsDocContext ) where @@ -470,9 +470,9 @@ lookupPromotedOccRn rdr_name Nothing -> unboundName WL_Any rdr_name Just demoted_name | data_kinds -> return demoted_name - | otherwise -> unboundNameX WL_Any rdr_name suggest_pk }}} + | otherwise -> unboundNameX WL_Any rdr_name suggest_dk }}} where - suggest_pk = ptext (sLit "A data constructor of that name is in scope; did you mean -XDataKinds?") + suggest_dk = ptext (sLit "A data constructor of that name is in scope; did you mean -XDataKinds?") \end{code} Note [Demotion] @@ -507,7 +507,12 @@ lookupOccRn_maybe rdr_name { -- We allow qualified names on the command line to refer to -- *any* name exported by any module in scope, just as if there -- was an "import qualified M" declaration for every module. - allow_qual <- doptM Opt_ImplicitImportQualified + -- But we DONT allow it under Safe Haskell as we need to check + -- imports. We can and should instead check the qualified import + -- but at the moment this requires some refactoring so leave as a TODO + ; dflags <- getDynFlags + ; let allow_qual = dopt Opt_ImplicitImportQualified dflags && + not (safeDirectImpsReq dflags) ; is_ghci <- getIsGHCi -- This test is not expensive, -- and only happens for failed lookups @@ -1434,8 +1439,8 @@ kindSigErr thing = hang (ptext (sLit "Illegal kind signature for") <+> quotes (ppr thing)) 2 (ptext (sLit "Perhaps you intended to use -XKindSignatures")) -polyKindsErr :: Outputable a => a -> SDoc -polyKindsErr thing +dataKindsErr :: Outputable a => a -> SDoc +dataKindsErr thing = hang (ptext (sLit "Illegal kind:") <+> quotes (ppr thing)) 2 (ptext (sLit "Perhaps you intended to use -XDataKinds")) diff --git a/compiler/rename/RnExpr.lhs-boot b/compiler/rename/RnExpr.lhs-boot index 5ca81d6db4..70d891dcbf 100644 --- a/compiler/rename/RnExpr.lhs-boot +++ b/compiler/rename/RnExpr.lhs-boot @@ -1,24 +1,17 @@ \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module RnExpr where import HsSyn -import Name ( Name ) -import NameSet ( FreeVars ) -import RdrName ( RdrName ) +import Name ( Name ) +import NameSet ( FreeVars ) +import RdrName ( RdrName ) import TcRnTypes rnLExpr :: LHsExpr RdrName - -> RnM (LHsExpr Name, FreeVars) + -> RnM (LHsExpr Name, FreeVars) rnStmts :: --forall thing. - HsStmtContext Name -> [LStmt RdrName] + HsStmtContext Name -> [LStmt RdrName] -> ([Name] -> RnM (thing, FreeVars)) - -> RnM (([LStmt Name], thing), FreeVars) + -> RnM (([LStmt Name], thing), FreeVars) \end{code} diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 68e6d027e6..b1a61db2a2 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -486,12 +486,8 @@ getLocalNonValBinders fixity_env hs_tyclds = tycl_decls, hs_instds = inst_decls, hs_fords = foreign_decls }) - = do { -- Separate out the family instance declarations - let (tyinst_decls, tycl_decls_noinsts) - = partition (isFamInstDecl . unLoc) (concat tycl_decls) - - -- Process all type/class decls *except* family instances - ; tc_avails <- mapM new_tc tycl_decls_noinsts + = do { -- Process all type/class decls *except* family instances + ; tc_avails <- mapM new_tc (concat tycl_decls) ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env ; setEnvs envs $ do { -- Bring these things into scope first @@ -499,7 +495,6 @@ getLocalNonValBinders fixity_env -- Process all family instances -- to bring new data constructors into scope - ; ti_avails <- mapM (new_ti Nothing) tyinst_decls ; nti_avails <- concatMapM new_assoc inst_decls -- Finish off with value binders: @@ -510,7 +505,7 @@ getLocalNonValBinders fixity_env | otherwise = for_hs_bndrs ; val_avails <- mapM new_simple val_bndrs - ; let avails = ti_avails ++ nti_avails ++ val_avails + ; let avails = nti_avails ++ val_avails new_bndrs = availsToNameSet avails `unionNameSets` availsToNameSet tc_avails ; envs <- extendGlobalRdrEnvRn avails fixity_env @@ -529,20 +524,25 @@ getLocalNonValBinders fixity_env ; return (Avail nm) } new_tc tc_decl -- NOT for type/data instances - = do { names@(main_name : _) <- mapM newTopSrcBinder (hsTyClDeclBinders tc_decl) + = do { let bndrs = hsTyClDeclBinders (unLoc tc_decl) + ; names@(main_name : _) <- mapM newTopSrcBinder bndrs ; return (AvailTC main_name names) } - new_ti :: Maybe Name -> LTyClDecl RdrName -> RnM AvailInfo + new_ti :: Maybe Name -> FamInstDecl RdrName -> RnM AvailInfo new_ti mb_cls ti_decl -- ONLY for type/data instances - = do { main_name <- lookupTcdName mb_cls (unLoc ti_decl) + = ASSERT( isFamInstDecl ti_decl ) + do { main_name <- lookupTcdName mb_cls ti_decl ; sub_names <- mapM newTopSrcBinder (hsTyClDeclBinders ti_decl) ; return (AvailTC (unLoc main_name) sub_names) } -- main_name is not bound here! new_assoc :: LInstDecl RdrName -> RnM [AvailInfo] - new_assoc (L _ (InstDecl inst_ty _ _ ats)) + new_assoc (L _ (FamInstDecl d)) + = do { avail <- new_ti Nothing d + ; return [avail] } + new_assoc (L _ (ClsInstDecl inst_ty _ _ ats)) = do { mb_cls_nm <- get_cls_parent inst_ty - ; mapM (new_ti mb_cls_nm) ats } + ; mapM (new_ti mb_cls_nm . unLoc) ats } where get_cls_parent inst_ty | Just (_, _, L loc cls_rdr, _) <- splitLHsInstDeclTy_maybe inst_ty @@ -551,7 +551,8 @@ getLocalNonValBinders fixity_env = return Nothing lookupTcdName :: Maybe Name -> TyClDecl RdrName -> RnM (Located Name) --- Used for TyData and TySynonym only +-- Used for TyData and TySynonym only, +-- both ordinary ones and family instances -- See Note [Family instance binders] lookupTcdName mb_cls tc_decl | not (isFamInstDecl tc_decl) -- The normal case @@ -1511,7 +1512,10 @@ warnUnusedImport (L loc decl, used, unused) <+> ptext (sLit "import") <+> pp_mod <> parens empty ] msg2 = sep [pp_herald <+> quotes (pprWithCommas ppr unused), text "from module" <+> quotes pp_mod <+> pp_not_used] - pp_herald = text "The import of" + pp_herald = text "The" <+> pp_qual <+> text "import of" + pp_qual + | ideclQualified decl = text "qualified" + | otherwise = empty pp_mod = ppr (unLoc (ideclName decl)) pp_not_used = text "is redundant" \end{code} diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 175b9a7ba4..54f95016c7 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -424,7 +424,11 @@ patchCCallTarget packageId callTarget \begin{code} rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars) -rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) +rnSrcInstDecl (FamInstDecl ty_decl) + = do { (ty_decl', fvs) <- rnTyClDecl Nothing ty_decl + ; return (FamInstDecl ty_decl', fvs) } + +rnSrcInstDecl (ClsInstDecl inst_ty mbinds uprags ats) -- Used for both source and interface file decls = do { inst_ty' <- rnLHsInstType (text "In an instance declaration") inst_ty ; let Just (inst_tyvars, _, L _ cls,_) = splitLHsInstDeclTy_maybe inst_ty' @@ -460,7 +464,7 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) renameSigs (InstDeclCtxt cls) spec_inst_prags ; let uprags' = spec_inst_prags' ++ other_sigs' - ; return (InstDecl inst_ty' mbinds' uprags' ats', + ; return (ClsInstDecl inst_ty' mbinds' uprags' ats', meth_fvs `plusFV` more_fvs `plusFV` hsSigsFVs spec_inst_prags' `plusFV` extractHsTyNames inst_ty') } @@ -764,6 +768,7 @@ rnTyClDecls extra_deps tycl_ds all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs' + ; traceRn (text "rnTycl" <+> (ppr ds_w_fvs $$ ppr sccs)) ; return (map flattenSCC sccs, all_fvs) } @@ -995,12 +1000,16 @@ depAnalTyClDecls :: [(LTyClDecl Name, FreeVars)] -> [SCC (LTyClDecl Name)] depAnalTyClDecls ds_w_fvs = stronglyConnCompFromEdgedVertices edges where - edges = [ (d, tcdName (unLoc d), map get_assoc (nameSetToList fvs)) + edges = [ (d, tcdName (unLoc d), map get_parent (nameSetToList fvs)) | (d, fvs) <- ds_w_fvs ] - get_assoc n = lookupNameEnv assoc_env n `orElse` n + + -- We also need to consider data constructor names since + -- they may appear in types because of promotion. + get_parent n = lookupNameEnv assoc_env n `orElse` n + + assoc_env :: NameEnv Name -- Maps a data constructor back + -- to its parent type constructor assoc_env = mkNameEnv assoc_env_list - -- We also need to consider data constructor names since they may - -- appear in types because of promotion. assoc_env_list = do (L _ d, _) <- ds_w_fvs case d of @@ -1210,7 +1219,7 @@ extendRecordFieldEnv tycl_decls inst_decls all_data_cons = [con | L _ (TyData { tcdCons = cons }) <- all_tycl_decls , L _ con <- cons ] all_tycl_decls = at_tycl_decls ++ concat tycl_decls - at_tycl_decls = instDeclATs inst_decls -- Do not forget associated types! + at_tycl_decls = instDeclFamInsts inst_decls -- Do not forget associated types! get_con (ConDecl { con_name = con, con_details = RecCon flds }) (RecFields env fld_set) diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 7840c4ab3a..5275957ce0 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -197,7 +197,7 @@ rnHsTyKi isType doc (HsFunTy ty1 ty2) = do rnHsTyKi isType doc listTy@(HsListTy ty) = do data_kinds <- xoptM Opt_DataKinds - unless (data_kinds || isType) (addErr (polyKindsErr listTy)) + unless (data_kinds || isType) (addErr (dataKindsErr listTy)) ty' <- rnLHsTyKi isType doc ty return (HsListTy ty') @@ -217,7 +217,7 @@ rnHsTyKi isType doc (HsPArrTy ty) = ASSERT ( isType ) do -- sometimes crop up as a result of CPR worker-wrappering dictionaries. rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys) = do data_kinds <- xoptM Opt_DataKinds - unless (data_kinds || isType) (addErr (polyKindsErr tupleTy)) + unless (data_kinds || isType) (addErr (dataKindsErr tupleTy)) tys' <- mapM (rnLHsTyKi isType doc) tys return (HsTupleTy tup_con tys') @@ -225,7 +225,7 @@ rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys) = do -- 2. Check that the integer is positive? rnHsTyKi isType _ tyLit@(HsTyLit t) = do data_kinds <- xoptM Opt_DataKinds - unless (data_kinds || isType) (addErr (polyKindsErr tyLit)) + unless (data_kinds || isType) (addErr (dataKindsErr tyLit)) return (HsTyLit t) rnHsTyKi isType doc (HsAppTy ty1 ty2) = do |