diff options
Diffstat (limited to 'compiler')
-rw-r--r-- | compiler/deSugar/DsMeta.hs | 27 | ||||
-rw-r--r-- | compiler/hsSyn/HsTypes.lhs | 29 | ||||
-rw-r--r-- | compiler/rename/RnBinds.lhs | 16 | ||||
-rw-r--r-- | compiler/rename/RnEnv.lhs | 89 | ||||
-rw-r--r-- | compiler/rename/RnSource.lhs | 68 | ||||
-rw-r--r-- | compiler/typecheck/TcCanonical.lhs | 112 | ||||
-rw-r--r-- | compiler/typecheck/TcErrors.lhs | 41 | ||||
-rw-r--r-- | compiler/typecheck/TcHsType.lhs | 11 | ||||
-rw-r--r-- | compiler/typecheck/TcInteract.lhs | 5 | ||||
-rw-r--r-- | compiler/typecheck/TcMType.lhs | 2 | ||||
-rw-r--r-- | compiler/typecheck/TcType.lhs | 4 |
11 files changed, 241 insertions, 163 deletions
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 6d1520ba8a..625c17ab33 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -280,7 +280,7 @@ mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name mk_extra_tvs tc tvs defn | TyData { td_kindSig = Just hs_kind } <- defn = do { extra_tvs <- go hs_kind - ; return (mkHsQTvs (hsQTvBndrs tvs ++ extra_tvs)) } + ; return (tvs { hsq_tvs = hsq_tvs tvs ++ extra_tvs }) } | otherwise = return tvs where @@ -360,7 +360,7 @@ repFamInstD (FamInstDecl { fid_tycon = tc_name -- polymorphism in Template Haskell (sigh) do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] ; let loc = getLoc tc_name - hs_tvs = mkHsQTvs (userHsTyVarBndrs loc tv_names) -- Yuk + hs_tvs = HsQTvs { hsq_kvs = kv_names, hsq_tvs = userHsTyVarBndrs loc tv_names } -- Yuk ; addTyClTyVarBinds hs_tvs $ \ bndrs -> do { tys1 <- repLTys tys ; tys2 <- coreList typeQTyConName tys1 @@ -420,27 +420,30 @@ ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:") repC :: [Name] -> LConDecl Name -> DsM (Core TH.ConQ) repC _ (L _ (ConDecl { con_name = con, con_qvars = con_tvs, con_cxt = L _ [] - , con_details = details, con_res = ResTyH98 })) + , con_details = details, con_res = ResTyH98 })) | null (hsQTvBndrs con_tvs) - = do { con1 <- lookupLOcc con -- See note [Binders and occurrences] + = do { con1 <- lookupLOcc con -- See Note [Binders and occurrences] ; repConstr con1 details } + repC tvs (L _ (ConDecl { con_name = con , con_qvars = con_tvs, con_cxt = L _ ctxt , con_details = details , con_res = res_ty })) = do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty - ; let ex_tvs = mkHsQTvs [ tv | tv <- hsQTvBndrs con_tvs, not (hsLTyVarName tv `in_subst` con_tv_subst)] + ; let ex_tvs = HsQTvs { hsq_kvs = filterOut (in_subst con_tv_subst) (hsq_kvs con_tvs) + , hsq_tvs = filterOut (in_subst con_tv_subst . hsLTyVarName) (hsq_tvs con_tvs) } + ; binds <- mapM dupBinder con_tv_subst ; dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs addTyVarBinds ex_tvs $ \ ex_bndrs -> -- Binds the remaining con_tvs - do { con1 <- lookupLOcc con -- See note [Binders and occurrences] + do { con1 <- lookupLOcc con -- See Note [Binders and occurrences] ; c' <- repConstr con1 details ; ctxt' <- repContext (eq_ctxt ++ ctxt) ; rep2 forallCName [unC ex_bndrs, unC ctxt', unC c'] } } -in_subst :: Name -> [(Name,Name)] -> Bool -in_subst _ [] = False -in_subst n ((n',_):ns) = n==n' || in_subst n ns +in_subst :: [(Name,Name)] -> Name -> Bool +in_subst [] _ = False +in_subst ((n',_):ns) n = n==n' || in_subst ns n mkGadtCtxt :: [Name] -- Tyvars of the data type -> ResType (LHsType Name) @@ -472,7 +475,7 @@ mkGadtCtxt data_tvs (ResTyGADT res_ty) go cxt subst ((data_tv, ty) : rest) | Just con_tv <- is_hs_tyvar ty , isTyVarName con_tv - , not (in_subst con_tv subst) + , not (in_subst subst con_tv) = go cxt ((con_tv, data_tv) : subst) rest | otherwise = go (eq_pred : cxt) subst rest @@ -628,7 +631,7 @@ addTyVarBinds :: LHsTyVarBndrs Name -- the binders to be -- meta environment and gets the *new* names on Core-level as an argument addTyVarBinds tvs m - = do { freshNames <- mkGenSyms (hsLTyVarNames tvs) + = do { freshNames <- mkGenSyms (hsLKiTyVarNames tvs) ; term <- addBinds freshNames $ do { kbs1 <- mapM mk_tv_bndr (hsQTvBndrs tvs `zip` freshNames) ; kbs2 <- coreList tyVarBndrTyConName kbs1 @@ -647,7 +650,7 @@ addTyClTyVarBinds :: LHsTyVarBndrs Name -- type W (T a) = blah -- The 'a' in the type instance is the one bound by the instance decl addTyClTyVarBinds tvs m - = do { let tv_names = hsLTyVarNames tvs + = do { let tv_names = hsLKiTyVarNames tvs ; env <- dsGetMetaEnv ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names) -- Make fresh names for the ones that are not already in scope diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index 183960a4e8..fe4a266700 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -34,7 +34,7 @@ module HsTypes ( mkHsQTvs, hsQTvBndrs, mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs, - hsTyVarName, hsTyVarNames, mkHsWithBndrs, + hsTyVarName, mkHsWithBndrs, hsLKiTyVarNames, hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames, splitLHsInstDeclTy_maybe, splitHsClassTy_maybe, splitLHsClassTy_maybe, @@ -51,6 +51,7 @@ import HsLit import NameSet( FreeVars ) import Name( Name ) +import RdrName( RdrName ) import Type import HsDoc import BasicTypes @@ -143,9 +144,14 @@ data LHsTyVarBndrs name } deriving( Data, Typeable ) -mkHsQTvs :: [LHsTyVarBndr name] -> LHsTyVarBndrs name +mkHsQTvs :: [LHsTyVarBndr RdrName] -> LHsTyVarBndrs RdrName +-- Just at RdrName because in the Name variant we should know just +-- what the kind-variable binders are; and we don't mkHsQTvs tvs = HsQTvs { hsq_kvs = panic "mkHsQTvs", hsq_tvs = tvs } +emptyHsQTvs :: LHsTyVarBndrs name -- Use only when you know there are no kind binders +emptyHsQTvs = HsQTvs { hsq_kvs = [], hsq_tvs = [] } + hsQTvBndrs :: LHsTyVarBndrs name -> [LHsTyVarBndr name] hsQTvBndrs = hsq_tvs @@ -387,18 +393,18 @@ data ConDeclField name -- Record fields have Haddoc docs on them -- -- A valid type must have one for-all at the top of the type, or of the fn arg types -mkImplicitHsForAllTy :: LHsContext name -> LHsType name -> HsType name -mkExplicitHsForAllTy :: [LHsTyVarBndr name] -> LHsContext name -> LHsType name -> HsType name +mkImplicitHsForAllTy :: LHsContext RdrName -> LHsType RdrName -> HsType RdrName +mkExplicitHsForAllTy :: [LHsTyVarBndr RdrName] -> LHsContext RdrName -> LHsType RdrName -> HsType RdrName mkImplicitHsForAllTy ctxt ty = mkHsForAllTy Implicit [] ctxt ty mkExplicitHsForAllTy tvs ctxt ty = mkHsForAllTy Explicit tvs ctxt ty -mkHsForAllTy :: HsExplicitFlag -> [LHsTyVarBndr name] -> LHsContext name -> LHsType name -> HsType name +mkHsForAllTy :: HsExplicitFlag -> [LHsTyVarBndr RdrName] -> LHsContext RdrName -> LHsType RdrName -> HsType RdrName -- Smart constructor for HsForAllTy mkHsForAllTy exp tvs (L _ []) ty = mk_forall_ty exp tvs ty mkHsForAllTy exp tvs ctxt ty = HsForAllTy exp (mkHsQTvs tvs) ctxt ty -- mk_forall_ty makes a pure for-all type (no context) -mk_forall_ty :: HsExplicitFlag -> [LHsTyVarBndr name] -> LHsType name -> HsType name +mk_forall_ty :: HsExplicitFlag -> [LHsTyVarBndr RdrName] -> LHsType RdrName -> HsType RdrName mk_forall_ty exp tvs (L _ (HsParTy ty)) = mk_forall_ty exp tvs ty mk_forall_ty exp1 tvs1 (L _ (HsForAllTy exp2 qtvs2 ctxt ty)) = mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ hsq_tvs qtvs2) ctxt ty mk_forall_ty exp tvs ty = HsForAllTy exp (mkHsQTvs tvs) (noLoc []) ty @@ -425,12 +431,15 @@ hsTyVarName (KindedTyVar n _) = n hsLTyVarName :: LHsTyVarBndr name -> name hsLTyVarName = hsTyVarName . unLoc -hsTyVarNames :: [HsTyVarBndr name] -> [name] -hsTyVarNames tvs = map hsTyVarName tvs - hsLTyVarNames :: LHsTyVarBndrs name -> [name] +-- Type variables only hsLTyVarNames qtvs = map hsLTyVarName (hsQTvBndrs qtvs) +hsLKiTyVarNames :: LHsTyVarBndrs Name -> [Name] +-- Kind and type variables +hsLKiTyVarNames (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs }) + = kvs ++ map hsLTyVarName tvs + hsLTyVarLocName :: LHsTyVarBndr name -> Located name hsLTyVarLocName = fmap hsTyVarName @@ -469,7 +478,7 @@ splitLHsForAllTy poly_ty = case unLoc poly_ty of HsParTy ty -> splitLHsForAllTy ty HsForAllTy _ tvs cxt ty -> (tvs, unLoc cxt, ty) - _ -> (mkHsQTvs [], [], poly_ty) + _ -> (emptyHsQTvs, [], poly_ty) -- The type vars should have been computed by now, even if they were implicit splitHsClassTy_maybe :: HsType name -> Maybe (name, [LHsType name]) diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index b4876754fa..d3d16033eb 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -170,13 +170,13 @@ rnTopBindsLHS :: MiniFixityEnv rnTopBindsLHS fix_env binds = rnValBindsLHS (topRecNameMaker fix_env) binds -rnTopBindsRHS :: HsValBindsLR Name RdrName +rnTopBindsRHS :: NameSet -> HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) -rnTopBindsRHS binds +rnTopBindsRHS bound_names binds = do { is_boot <- tcIsHsBoot ; if is_boot then rnTopBindsBoot binds - else rnValBindsRHS TopSigCtxt binds } + else rnValBindsRHS (TopSigCtxt bound_names False) binds } rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) -- A hs-boot file has no bindings. @@ -538,7 +538,7 @@ mkSigTvFn sigs = \n -> lookupNameEnv env n `orElse` [] where env :: NameEnv [Name] - env = mkNameEnv [ (name, hsLTyVarNames ltvs) + env = mkNameEnv [ (name, hsLKiTyVarNames ltvs) -- Kind variables and type variables | L _ (TypeSig names (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs , (L _ name) <- names] @@ -695,8 +695,8 @@ renameSig _ (SpecInstSig ty) -- then the SPECIALISE pragma is ambiguous, unlike all other signatures renameSig ctxt sig@(SpecSig v ty inl) = do { new_v <- case ctxt of - TopSigCtxt -> lookupLocatedOccRn v - _ -> lookupSigOccRn ctxt sig v + TopSigCtxt {} -> lookupLocatedOccRn v + _ -> lookupSigOccRn ctxt sig v ; (new_ty, fvs) <- rnHsSigType (quotes (ppr v)) ty ; return (SpecSig new_v new_ty inl, fvs) } @@ -722,14 +722,14 @@ okHsSig ctxt (L _ sig) (FixSig {}, InstDeclCtxt {}) -> False (FixSig {}, _) -> True - (IdSig {}, TopSigCtxt) -> True + (IdSig {}, TopSigCtxt {}) -> True (IdSig {}, InstDeclCtxt {}) -> True (IdSig {}, _) -> False (InlineSig {}, HsBootCtxt) -> False (InlineSig {}, _) -> True - (SpecSig {}, TopSigCtxt) -> True + (SpecSig {}, TopSigCtxt {}) -> True (SpecSig {}, LocalBindCtxt {}) -> True (SpecSig {}, InstDeclCtxt {}) -> True (SpecSig {}, _) -> False diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index b1f393baaf..2f1de923c2 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -837,13 +837,36 @@ We don't want to say 'f' is out of scope; instead, we want to return the imported 'f', so that later on the reanamer will correctly report "misplaced type sig". +Note [Signatures for top level things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +data HsSigCtxt = ... | TopSigCtxt NameSet Bool | .... + +* The NameSet says what is bound in this group of bindings. + We can't use isLocalGRE from the GlobalRdrEnv, because of this: + f x = x + $( ...some TH splice... ) + f :: Int -> Int + When we encounter the signature for 'f', the binding for 'f' + will be in the GlobalRdrEnv, and will be a LocalDef. Yet the + signature is mis-placed + +* The Bool says whether the signature is ok for a class method + or record selector. Consider + infix 3 `f` -- Yes, ok + f :: C a => a -> a -- No, not ok + class C a where + f :: a -> a + \begin{code} data HsSigCtxt - = HsBootCtxt -- Top level of a hs-boot file - | TopSigCtxt -- At top level + = TopSigCtxt NameSet Bool -- At top level, binding these names + -- See Note [Signatures for top level things] + -- Bool <=> ok to give sig for + -- class method or record selctor | LocalBindCtxt NameSet -- In a local binding, binding these names | ClsDeclCtxt Name -- Class decl for this class | InstDeclCtxt Name -- Intsance decl for this class + | HsBootCtxt -- Top level of a hs-boot file lookupSigOccRn :: HsSigCtxt -> Sig RdrName @@ -875,11 +898,11 @@ lookupBindGroupOcc ctxt what rdr_name | otherwise = case ctxt of - HsBootCtxt -> lookup_top - TopSigCtxt -> lookup_top - LocalBindCtxt ns -> lookup_group ns - ClsDeclCtxt cls -> lookup_cls_op cls - InstDeclCtxt cls -> lookup_cls_op cls + HsBootCtxt -> lookup_top (const True) True + TopSigCtxt ns meth_ok -> lookup_top (`elemNameSet` ns) meth_ok + LocalBindCtxt ns -> lookup_group ns + ClsDeclCtxt cls -> lookup_cls_op cls + InstDeclCtxt cls -> lookup_cls_op cls where lookup_cls_op cls = do { env <- getGlobalRdrEnv @@ -893,21 +916,22 @@ lookupBindGroupOcc ctxt what rdr_name where doc = ptext (sLit "method of class") <+> quotes (ppr cls) - lookup_top + lookup_top keep_me meth_ok = do { env <- getGlobalRdrEnv - ; let gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name) - ; case filter isLocalGRE gres of - [] | null gres -> bale_out_with empty - | otherwise -> bale_out_with (bad_msg (ptext (sLit "an imported value"))) + ; let all_gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name) + ; case filter (keep_me . gre_name) all_gres of + [] | null all_gres -> bale_out_with empty + | otherwise -> bale_out_with local_msg (gre:_) - | ParentIs {} <- gre_par gre - -> bale_out_with (bad_msg (ptext (sLit "a record selector or class method"))) + | ParentIs {} <- gre_par gre + , not meth_ok + -> bale_out_with sub_msg | otherwise -> return (Right (gre_name gre)) } - lookup_group bound_names - = do { mb_name <- lookupOccRn_maybe rdr_name - ; case mb_name of + lookup_group bound_names -- Look in the local envt (not top level) + = do { local_env <- getLocalRdrEnv + ; case lookupLocalRdrEnv local_env rdr_name of Just n | n `elemNameSet` bound_names -> return (Right n) | otherwise -> bale_out_with local_msg @@ -922,31 +946,31 @@ lookupBindGroupOcc ctxt what rdr_name local_msg = parens $ ptext (sLit "The") <+> what <+> ptext (sLit "must be given where") <+> quotes (ppr rdr_name) <+> ptext (sLit "is declared") - bad_msg thing = parens $ ptext (sLit "You cannot give a") <+> what - <+> ptext (sLit "for") <+> thing + sub_msg = parens $ ptext (sLit "You cannot give a") <+> what + <+> ptext (sLit "for a record selector or class method") --------------- -lookupLocalTcNames :: NameSet -> SDoc -> RdrName -> RnM [Name] +lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [Name] -- GHC extension: look up both the tycon and data con or variable. --- Used for top-level fixity signatures. Complain if neither is in scope. +-- Used for top-level fixity signatures and deprecations. +-- Complain if neither is in scope. -- See Note [Fixity signature lookup] -lookupLocalTcNames bndr_set what rdr_name - | Just n <- isExact_maybe rdr_name - -- Special case for (:), which doesn't get into the GlobalRdrEnv - = do { n' <- lookupExactOcc n; return [n'] } -- For this we don't need to try the tycon too - | otherwise +lookupLocalTcNames ctxt what rdr_name = do { mb_gres <- mapM lookup (dataTcOccs rdr_name) ; let (errs, names) = splitEithers mb_gres ; when (null names) $ addErr (head errs) -- Bleat about one only ; return names } where - lookup = lookupBindGroupOcc (LocalBindCtxt bndr_set) what + lookup = lookupBindGroupOcc ctxt what dataTcOccs :: RdrName -> [RdrName] -- Return both the given name and the same name promoted to the TcClsName -- namespace. This is useful when we aren't sure which we are looking at. dataTcOccs rdr_name + | Just n <- isExact_maybe rdr_name + , not (isBuiltInSyntax n) -- See Note [dataTcOccs and Exact Names] + = [rdr_name] | isDataOcc occ || isVarOcc occ = [rdr_name, rdr_name_tc] | otherwise @@ -956,6 +980,17 @@ dataTcOccs rdr_name rdr_name_tc = setRdrNameSpace rdr_name tcName \end{code} +Note [dataTcOccs and Exact Names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Exact RdrNames can occur in code generated by Template Haskell, and generally +those references are, well, exact, so it's wrong to return the TyClsName too. +But there is an awkward exception for built-in syntax. Example in GHCi + :info [] +This parses as the Exact RdrName for nilDataCon, but we also want +the list type constructor. + +Note that setRdrNameSpace on an Exact name requires the Name to be External, +which it always is for built in syntax. %********************************************************* %* * diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 9509b0a4b2..595f4653d3 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -114,9 +114,9 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls, -- It uses the fixity env from (A) to bind fixities for view patterns. new_lhs <- rnTopBindsLHS local_fix_env val_decls ; -- bind the LHSes (and their fixities) in the global rdr environment - let { val_binders = collectHsValBinders new_lhs ; - all_bndr_set = addListToNameSet tc_bndrs val_binders ; - val_avails = map Avail val_binders } ; + let { val_binders = collectHsValBinders new_lhs ; + all_bndrs = addListToNameSet tc_bndrs val_binders ; + val_avails = map Avail val_binders } ; (tcg_env, tcl_env) <- extendGlobalRdrEnvRn val_avails local_fix_env ; traceRn (ptext (sLit "Val binders") <+> (ppr val_binders)) ; setEnvs (tcg_env, tcl_env) $ do { @@ -138,19 +138,19 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls, -- (F) Rename Value declarations right-hand sides traceRn (text "Start rnmono") ; - (rn_val_decls, bind_dus) <- rnTopBindsRHS new_lhs ; + (rn_val_decls, bind_dus) <- rnTopBindsRHS all_bndrs new_lhs ; traceRn (text "finish rnmono" <+> ppr rn_val_decls) ; -- (G) Rename Fixity and deprecations -- Rename fixity declarations and error if we try to -- fix something from another module (duplicates were checked in (A)) - rn_fix_decls <- rnSrcFixityDecls all_bndr_set fix_decls ; + rn_fix_decls <- rnSrcFixityDecls all_bndrs fix_decls ; -- Rename deprec decls; -- check for duplicates and ensure that deprecated things are defined locally -- at the moment, we don't keep these around past renaming - rn_warns <- rnSrcWarnDecls all_bndr_set warn_decls ; + rn_warns <- rnSrcWarnDecls all_bndrs warn_decls ; -- (H) Rename Everything else @@ -260,6 +260,9 @@ rnSrcFixityDecls bndr_set fix_decls = do fix_decls <- mapM rn_decl fix_decls return (concat fix_decls) where + sig_ctxt = TopSigCtxt bndr_set True + -- True <=> can give fixity for class decls and record selectors + rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name] -- GHC extension: look up both the tycon and data con -- for con-like things; hence returning a list @@ -268,7 +271,7 @@ rnSrcFixityDecls bndr_set fix_decls rn_decl (L loc (FixitySig (L name_loc rdr_name) fixity)) = setSrcSpan name_loc $ -- this lookup will fail if the definition isn't local - do names <- lookupLocalTcNames bndr_set what rdr_name + do names <- lookupLocalTcNames sig_ctxt what rdr_name return [ L loc (FixitySig (L name_loc name) fixity) | name <- names ] what = ptext (sLit "fixity signature") @@ -301,9 +304,12 @@ rnSrcWarnDecls bndr_set decls ; pairs_s <- mapM (addLocM rn_deprec) decls ; return (WarnSome ((concat pairs_s))) } where + sig_ctxt = TopSigCtxt bndr_set True + -- True <=> Can give deprecations for class ops and record sels + rn_deprec (Warning rdr_name txt) -- ensures that the names are defined locally - = do { names <- lookupLocalTcNames bndr_set what rdr_name + = do { names <- lookupLocalTcNames sig_ctxt what rdr_name ; return [(nameOccName name, txt) | name <- names] } what = ptext (sLit "deprecation") @@ -436,13 +442,14 @@ rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds Just (inst_tyvars, _, L _ cls,_) -> do { let (spec_inst_prags, other_sigs) = partition isSpecInstLSig uprags - tv_names = hsLTyVarNames inst_tyvars + ktv_names = hsLKiTyVarNames inst_tyvars -- Rename the associated types, and type signatures -- Both need to have the instance type variables in scope + ; traceRn (text "rnSrcInstDecl" <+> ppr inst_ty' $$ ppr inst_tyvars $$ ppr ktv_names) ; ((ats', other_sigs'), more_fvs) - <- extendTyVarEnvFVRn tv_names $ - do { (ats', at_fvs) <- rnATInstDecls cls tv_names ats + <- extendTyVarEnvFVRn ktv_names $ + do { (ats', at_fvs) <- rnATInstDecls cls inst_tyvars ats ; (other_sigs', sig_fvs) <- renameSigs (InstDeclCtxt cls) other_sigs ; return ( (ats', other_sigs') , at_fvs `plusFV` sig_fvs) } @@ -452,7 +459,7 @@ rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds -- the bindings are for the right class -- (Slightly strangely) when scoped type variables are on, the -- forall-d tyvars scope over the method bindings too - ; (mbinds', meth_fvs) <- extendTyVarEnvForMethodBinds inst_tyvars $ + ; (mbinds', meth_fvs) <- extendTyVarEnvForMethodBinds ktv_names $ rnMethodBinds cls (mkSigTvFn other_sigs') mbinds @@ -527,9 +534,19 @@ rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon Renaming of the associated types in instances. \begin{code} -rnATInstDecls :: Name -- Class - -> [Name] -- Type variable binders (but NOT kind variables) - -- See Note [Renaming associated types] in RnTypes +rnATDecls :: Name -- Class + -> LHsTyVarBndrs Name + -> [LTyClDecl RdrName] + -> RnM ([LTyClDecl Name], FreeVars) +rnATDecls cls hs_tvs at_decls + = rnList (rnTyClDecl (Just (cls, tv_ns))) at_decls + where + tv_ns = hsLTyVarNames hs_tvs + -- Type variable binders (but NOT kind variables) + -- See Note [Renaming associated types] in RnTypes + +rnATInstDecls :: Name -- Class + -> LHsTyVarBndrs Name -> [LFamInstDecl RdrName] -> RnM ([LFamInstDecl Name], FreeVars) -- Used for the family declarations and defaults in a class decl @@ -537,21 +554,25 @@ rnATInstDecls :: Name -- Class -- -- NB: We allow duplicate associated-type decls; -- See Note [Associated type instances] in TcInstDcls -rnATInstDecls cls tvs atDecls - = rnList (rnFamInstDecl (Just (cls, tvs))) atDecls +rnATInstDecls cls hs_tvs at_insts + = rnList (rnFamInstDecl (Just (cls, tv_ns))) at_insts + where + tv_ns = hsLTyVarNames hs_tvs + -- Type variable binders (but NOT kind variables) + -- See Note [Renaming associated types] in RnTypes \end{code} For the method bindings in class and instance decls, we extend the type variable environment iff -fglasgow-exts \begin{code} -extendTyVarEnvForMethodBinds :: LHsTyVarBndrs Name +extendTyVarEnvForMethodBinds :: [Name] -> RnM (Bag (LHsBind Name), FreeVars) -> RnM (Bag (LHsBind Name), FreeVars) -extendTyVarEnvForMethodBinds tyvars thing_inside +extendTyVarEnvForMethodBinds ktv_names thing_inside = do { scoped_tvs <- xoptM Opt_ScopedTypeVariables ; if scoped_tvs then - extendTyVarEnvFVRn (hsLTyVarNames tyvars) thing_inside + extendTyVarEnvFVRn ktv_names thing_inside else thing_inside } \end{code} @@ -882,9 +903,8 @@ rnTyClDecl mb_cls (ClassDecl {tcdCtxt = context, tcdLName = lcls, { (context', cxt_fvs) <- rnContext cls_doc context ; fds' <- rnFds (docOfHsDocContext cls_doc) fds -- The fundeps have no free variables - ; let tv_ns = hsLTyVarNames tyvars' - ; (ats', fv_ats) <- rnList (rnTyClDecl (Just (cls', tv_ns))) ats - ; (at_defs', fv_at_defs) <- rnATInstDecls cls' tv_ns at_defs + ; (ats', fv_ats) <- rnATDecls cls' tyvars' ats + ; (at_defs', fv_at_defs) <- rnATInstDecls cls' tyvars' at_defs ; (sigs', sig_fvs) <- renameSigs (ClsDeclCtxt cls') sigs ; let fvs = cxt_fvs `plusFV` sig_fvs `plusFV` @@ -913,7 +933,7 @@ rnTyClDecl mb_cls (ClassDecl {tcdCtxt = context, tcdLName = lcls, -- we want to name both "x" tyvars with the same unique, so that they are -- easy to group together in the typechecker. ; (mbinds', meth_fvs) - <- extendTyVarEnvForMethodBinds tyvars' $ + <- extendTyVarEnvForMethodBinds (hsLKiTyVarNames tyvars') $ -- No need to check for duplicate method signatures -- since that is done by RnNames.extendGlobalRdrEnvRn -- and the methods are already in scope diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index c7b69a9654..49431ae977 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -7,7 +7,7 @@ -- for details module TcCanonical( - canonicalize, flatten, flattenMany, + canonicalize, flatten, flattenMany, occurCheckExpand, FlattenMode (..), StopOrContinue (..) ) where @@ -1244,8 +1244,8 @@ canEqLeafTyVarLeft d fl tv s2 -- eqv : tv ~ s2 return Stop else do -- Not reflexivity but maybe an occurs error - { occ_check_result <- canOccursCheck fl tv xi2 - ; let xi2' = fromMaybe xi2 occ_check_result + { let occ_check_result = occurCheckExpand tv xi2 + xi2' = fromMaybe xi2 occ_check_result not_occ_err = isJust occ_check_result -- Delicate: don't want to cache as solved a constraint with occurs error! @@ -1261,28 +1261,20 @@ canEqLeafTyVarLeft d fl tv s2 -- eqv : tv ~ s2 canEqFailure d new_fl Nothing -> return Stop } } - --- See Note [Type synonyms and canonicalization]. --- Check whether the given variable occurs in the given type. We may --- have needed to do some type synonym unfolding in order to get rid --- of the variable, so we also return the unfolded version of the --- type, which is guaranteed to be syntactically free of the given --- type variable. If the type is already syntactically free of the --- variable, then the same type is returned. --- --- Precondition: the two types are not equal (looking though synonyms) -canOccursCheck :: CtEvidence -> TcTyVar -> Xi -> TcS (Maybe Xi) -canOccursCheck _gw tv xi = return (expandAway tv xi) \end{code} -@expandAway tv xi@ expands synonyms in xi just enough to get rid of -occurrences of tv, if that is possible; otherwise, it returns Nothing. +Note [Occurs check expansion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +@occurCheckExpand tv xi@ expands synonyms in xi just enough to get rid +of occurrences of tv outside type function arguments, if that is +possible; otherwise, it returns Nothing. + For example, suppose we have type F a b = [a] Then - expandAway b (F Int b) = Just [Int] + occurCheckExpand b (F Int b) = Just [Int] but - expandAway a (F a Int) = Nothing + occurCheckExpand a (F a Int) = Nothing We don't promise to do the absolute minimum amount of expanding necessary, but we try not to do expansions we don't need to. We @@ -1290,49 +1282,61 @@ prefer doing inner expansions first. For example, type F a b = (a, Int, a, [a]) type G b = Char We have - expandAway b (F (G b)) = F Char + occurCheckExpand b (F (G b)) = F Char even though we could also expand F to get rid of b. +See also Note [Type synonyms and canonicalization]. + \begin{code} -expandAway :: TcTyVar -> Xi -> Maybe Xi -expandAway tv t@(TyVarTy tv') - | tv == tv' = Nothing - | otherwise = Just t -expandAway tv xi - | not (tv `elemVarSet` tyVarsOfType xi) = Just xi -expandAway tv (AppTy ty1 ty2) - = do { ty1' <- expandAway tv ty1 - ; ty2' <- expandAway tv ty2 - ; return (mkAppTy ty1' ty2') } --- mkAppTy <$> expandAway tv ty1 <*> expandAway tv ty2 -expandAway tv (FunTy ty1 ty2) - = do { ty1' <- expandAway tv ty1 - ; ty2' <- expandAway tv ty2 - ; return (mkFunTy ty1' ty2') } --- mkFunTy <$> expandAway tv ty1 <*> expandAway tv ty2 -expandAway tv ty@(ForAllTy {}) - = let (tvs,rho) = splitForAllTys ty - tvs_knds = map tyVarKind tvs - in if tv `elemVarSet` tyVarsOfTypes tvs_knds then - -- Can't expand away the kinds unless we create - -- fresh variables which we don't want to do at this point. - Nothing - else do { rho' <- expandAway tv rho - ; return (mkForAllTys tvs rho') } --- For a type constructor application, first try expanding away the --- offending variable from the arguments. If that doesn't work, next --- see if the type constructor is a type synonym, and if so, expand --- it and try again. -expandAway tv ty@(TyConApp tc tys) - = (mkTyConApp tc <$> mapM (expandAway tv) tys) <|> (tcView ty >>= expandAway tv) - -expandAway _ xi@(LitTy {}) = return xi +occurCheckExpand :: TcTyVar -> Type -> Maybe Type +-- Check whether the given variable occurs in the given type. We may +-- have needed to do some type synonym unfolding in order to get rid +-- of the variable, so we also return the unfolded version of the +-- type, which is guaranteed to be syntactically free of the given +-- type variable. If the type is already syntactically free of the +-- variable, then the same type is returned. +occurCheckExpand tv ty + | not (tv `elemVarSet` tyVarsOfType ty) = Just ty + | otherwise = go ty + where + go t@(TyVarTy tv') | tv == tv' = Nothing + | otherwise = Just t + go ty@(LitTy {}) = return ty + go (AppTy ty1 ty2) = do { ty1' <- go ty1 + ; ty2' <- go ty2 + ; return (mkAppTy ty1' ty2') } + -- mkAppTy <$> go ty1 <*> go ty2 + go (FunTy ty1 ty2) = do { ty1' <- go ty1 + ; ty2' <- go ty2 + ; return (mkFunTy ty1' ty2') } + -- mkFunTy <$> go ty1 <*> go ty2 + go ty@(ForAllTy {}) + | tv `elemVarSet` tyVarsOfTypes tvs_knds = Nothing + -- Can't expand away the kinds unless we create + -- fresh variables which we don't want to do at this point. + | otherwise = do { rho' <- go rho + ; return (mkForAllTys tvs rho') } + where + (tvs,rho) = splitForAllTys ty + tvs_knds = map tyVarKind tvs + + -- For a type constructor application, first try expanding away the + -- offending variable from the arguments. If that doesn't work, next + -- see if the type constructor is a type synonym, and if so, expand + -- it and try again. + go ty@(TyConApp tc tys) + | isSynFamilyTyCon tc -- It's ok for tv to occur under a type family application + = return ty -- Eg. (a ~ F a) is not an occur-check error + -- NB This case can't occur during canonicalisation, + -- because the arg is a Xi-type, but can occur in the + -- call from TcErrors + | otherwise + = (mkTyConApp tc <$> mapM go tys) <|> (tcView ty >>= go) \end{code} Note [Type synonyms and canonicalization] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - We treat type synonym applications as xi types, that is, they do not count as type function applications. However, we do need to be a bit careful with type synonyms: like type functions they may not be diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index 08926ea745..3c6598efb1 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -17,6 +17,7 @@ module TcErrors( #include "HsVersions.h" +import TcCanonical( occurCheckExpand ) import TcRnMonad import TcMType import TcType @@ -457,17 +458,20 @@ mkEqErr1 ctxt ct msg = mkExpectedActualMsg exp act mk_err ctxt1 _ = mkEqErr_help ctxt1 ct False ty1 ty2 -mkEqErr_help :: ReportErrCtxt - -> Ct - -> Bool -- True <=> Types are correct way round; - -- report "expected ty1, actual ty2" - -- False <=> Just report a mismatch without orientation - -- The ReportErrCtxt has expected/actual - -> TcType -> TcType -> TcM ErrMsg +mkEqErr_help, reportEqErr + :: ReportErrCtxt + -> Ct + -> Bool -- True <=> Types are correct way round; + -- report "expected ty1, actual ty2" + -- False <=> Just report a mismatch without orientation + -- The ReportErrCtxt has expected/actual + -> TcType -> TcType -> TcM ErrMsg mkEqErr_help ctxt ct oriented ty1 ty2 | Just tv1 <- tcGetTyVar_maybe ty1 = mkTyVarEqErr ctxt ct oriented tv1 ty2 | Just tv2 <- tcGetTyVar_maybe ty2 = mkTyVarEqErr ctxt ct oriented tv2 ty1 - | otherwise -- Neither side is a type variable + | otherwise = reportEqErr ctxt ct oriented ty1 ty2 + +reportEqErr ctxt ct oriented ty1 ty2 = do { ctxt' <- mkEqInfoMsg ctxt ct ty1 ty2 ; mkErrorReport ctxt' (misMatchOrCND ctxt' ct oriented ty1 ty2) } @@ -486,7 +490,7 @@ mkTyVarEqErr ctxt ct oriented tv1 ty2 = mkErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2) -- Occurs check - | tv1 `elemVarSet` tyVarsOfType ty2 + | isNothing (occurCheckExpand tv1 ty2) = let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2 (sep [ppr ty1, char '=', ppr ty2]) in mkErrorReport ctxt occCheckMsg @@ -526,21 +530,10 @@ mkTyVarEqErr ctxt ct oriented tv1 ty2 ; mkErrorReport (addExtraTyVarInfo ctxt ty1 ty2) (msg $$ nest 2 extra) } | otherwise - = pprTrace "mkTyVarEqErr" (ppr tv1 $$ ppr ty2 $$ ppr (cec_encl ctxt)) $ - panic "mkTyVarEqErr" - -- I don't think this should happen, and if it does I want to know - -- Trac #5130 happened because an actual type error was not - -- reported at all! So not reporting is pretty dangerous. - -- - -- OLD, OUT OF DATE COMMENT - -- This can happen, by a recursive decomposition of frozen - -- occurs check constraints - -- Example: alpha ~ T Int alpha has frozen. - -- Then alpha gets unified to T beta gamma - -- So now we have T beta gamma ~ T Int (T beta gamma) - -- Decompose to (beta ~ Int, gamma ~ T beta gamma) - -- The (gamma ~ T beta gamma) is the occurs check, but - -- the (beta ~ Int) isn't an error at all. So return () + = reportEqErr ctxt ct oriented (mkTyVarTy tv1) ty2 + -- This *can* happen (Trac #6123, and test T2627b) + -- Consider an ambiguous top-level constraint (a ~ F a) + -- Not an occurs check, becuase F is a type function. where k1 = tyVarKind tv1 k2 = typeKind ty2 diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 8439088904..3bf5003525 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -833,15 +833,24 @@ kindGeneralize tkvs = do { gbl_tvs <- tcGetGlobalTyVars -- Already zonked ; tidy_env <- tcInitTidyEnv ; tkvs <- zonkTyVarsAndFV tkvs - ; let kvs_to_quantify = varSetElems (tkvs `minusVarSet` gbl_tvs) + ; let kvs_to_quantify = filter isKindVar (varSetElems (tkvs `minusVarSet` gbl_tvs)) -- Any type varaibles in tkvs will be in scope, -- and hence in gbl_tvs, so after removing gbl_tvs -- we should only have kind variables left + -- + -- BUT there is a smelly case (to be fixed when TH is reorganised) + -- f t = [| e :: $t |] + -- When typechecking the body of the bracket, we typecheck $t to a + -- unification variable 'alpha', with no biding forall. We don't + -- want to kind-quantify it! (_, tidy_kvs_to_quantify) = tidyTyVarBndrs tidy_env kvs_to_quantify -- We do not get a later chance to tidy! ; ASSERT2 (all isKindVar kvs_to_quantify, ppr kvs_to_quantify $$ ppr tkvs) + -- This assertion is obviosy true because of the filter isKindVar + -- but we'll remove that when reorganising TH, and then the assertion + -- will mean something zonkQuantifiedTyVars tidy_kvs_to_quantify } \end{code} diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 25bbf622ab..d987e0f75a 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -592,6 +592,11 @@ solveWithIdentity :: SubGoalDepth -- must work for Derived as well as Wanted -- Returns: workItem where -- workItem = the new Given constraint +-- +-- NB: No need for an occurs check here, because solveWithIdentity always +-- arises from a CTyEqCan, a *canonical* constraint. Its invariants +-- say that in (a ~ xi), the type variable a does not appear in xi. +-- See TcRnTypes.Ct invariants. solveWithIdentity d wd tv xi = do { let tv_ty = mkTyVarTy tv ; traceTcS "Sneaky unification:" $ diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index c87a521b19..d05b1dd25b 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -1624,7 +1624,7 @@ checkValidFamInst typats rhs mapM_ addErrTc (checkFamInstRhs typats (tcTyFamInsts rhs)) } --- Make sure that each type family instance is +-- Make sure that each type family application is -- (1) strictly smaller than the lhs, -- (2) mentions no type variable more often than the lhs, and -- (3) does not contain any further type family instances. diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index 0864e5de33..18f2dfa6a2 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -609,8 +609,8 @@ tidyCos env = map (tidyCo env) %************************************************************************ \begin{code} - --- | Finds type family instances occuring in a type after expanding synonyms. +-- | Finds outermost type-family applications occuring in a type, +-- after expanding synonyms. tcTyFamInsts :: Type -> [(TyCon, [Type])] tcTyFamInsts ty | Just exp_ty <- tcView ty = tcTyFamInsts exp_ty |