diff options
Diffstat (limited to 'compiler/GHC/Tc/Module.hs')
| -rw-r--r-- | compiler/GHC/Tc/Module.hs | 1146 |
1 files changed, 472 insertions, 674 deletions
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 5c381f9e70..0783608bd5 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -44,9 +44,7 @@ module GHC.Tc.Module ( tcRnInstantiateSignature, loadUnqualIfaces, -- More private... - badReexportedBootThing, checkBootDeclM, - missingBootThing, getRenamedStuff, RenamedStuff ) where @@ -82,12 +80,12 @@ import GHC.Tc.Gen.Foreign import GHC.Tc.TyCl.Instance import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType -import GHC.Tc.Utils.Instantiate (tcGetInsts) import GHC.Tc.Solver import GHC.Tc.TyCl import GHC.Tc.Instance.Typeable ( mkTypeableBinds ) import GHC.Tc.Utils.Backpack +import GHC.Rename.Bind ( rejectBootDecls ) import GHC.Rename.Splice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) ) import GHC.Rename.HsType import GHC.Rename.Expr @@ -99,8 +97,6 @@ import GHC.Rename.Doc import GHC.Rename.Utils ( mkNameClashErr ) import GHC.Iface.Decl ( coAxiomToIfaceDecl ) -import GHC.Iface.Syntax ( ShowSub(..), showToHeader ) -import GHC.Iface.Type ( ShowForAllFlag(..) ) import GHC.Iface.Env ( externaliseName ) import GHC.Iface.Load @@ -108,20 +104,19 @@ import GHC.Builtin.Types ( mkListTy, anyTypeOfKind ) import GHC.Builtin.Names import GHC.Builtin.Utils -import GHC.Hs +import GHC.Hs hiding ( FunDep(..) ) import GHC.Hs.Dump import GHC.Core.PatSyn import GHC.Core.Predicate ( classMethodTy ) import GHC.Core.InstEnv import GHC.Core.TyCon -import GHC.Core.ConLike import GHC.Core.DataCon +import GHC.Core.TyCo.Rep import GHC.Core.Type import GHC.Core.Class import GHC.Core.Coercion.Axiom import GHC.Core.Reduction ( Reduction(..) ) -import GHC.Core.RoughMap( RoughMatchTc(..) ) import GHC.Core.TyCo.Ppr( debugPprType ) import GHC.Core.FamInstEnv ( FamInst, pprFamInst, famInstsRepTyCons, orphNamesOfFamInst @@ -156,7 +151,6 @@ import GHC.Types.Basic hiding( SuccessFlag(..) ) import GHC.Types.Annotations import GHC.Types.SrcLoc import GHC.Types.SourceFile -import GHC.Types.TyThing.Ppr ( pprTyThingInContext ) import GHC.Types.PkgQual import qualified GHC.LanguageExtensions as LangExt @@ -177,8 +171,10 @@ import GHC.Data.List.SetOps import GHC.Data.Bag import qualified GHC.Data.BooleanFormula as BF +import Control.Arrow ( second ) import Control.DeepSeq import Control.Monad +import Control.Monad.Trans.Writer.CPS import Data.Data ( Data ) import Data.Functor.Classes ( liftEq ) import Data.List ( sortBy, sort ) @@ -186,6 +182,7 @@ import Data.List.NonEmpty ( NonEmpty (..) ) import qualified Data.List.NonEmpty as NE import Data.Ord import qualified Data.Set as S +import Data.Foldable ( for_ ) import Data.Traversable ( for ) @@ -271,9 +268,7 @@ tcRnModuleTcRnM hsc_env mod_sum implicit_prelude import_decls } ; when (notNull prel_imports) $ do - let msg = mkTcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnImplicitPrelude) noHints (implicitPreludeWarn) - addDiagnostic msg + addDiagnostic TcRnImplicitImportOfPrelude ; -- TODO This is a little skeevy; maybe handle a bit more directly let { simplifyImport (L _ idecl) = @@ -319,17 +314,19 @@ tcRnModuleTcRnM hsc_env mod_sum ; setGblEnv tcg_env1 $ do { -- Rename and type check the declarations traceRn "rn1a" empty - ; tcg_env <- if isHsBootOrSig hsc_src - then do { - ; tcg_env <- tcRnHsBootDecls hsc_src local_decls - ; traceRn "rn4a: before exports" empty - ; tcg_env <- setGblEnv tcg_env $ - rnExports explicit_mod_hdr export_ies - ; traceRn "rn4b: after exports" empty - ; return tcg_env - } - else {-# SCC "tcRnSrcDecls" #-} - tcRnSrcDecls explicit_mod_hdr export_ies local_decls + ; tcg_env <- + case hsc_src of + HsBootOrSig boot_or_sig -> + do { tcg_env <- tcRnHsBootDecls boot_or_sig local_decls + ; traceRn "rn4a: before exports" empty + ; tcg_env <- setGblEnv tcg_env $ + rnExports explicit_mod_hdr export_ies + ; traceRn "rn4b: after exports" empty + ; return tcg_env + } + HsSrcFile -> + {-# SCC "tcRnSrcDecls" #-} + tcRnSrcDecls explicit_mod_hdr export_ies local_decls ; whenM (goptM Opt_DoCoreLinting) $ lintGblEnv (hsc_logger hsc_env) (hsc_dflags hsc_env) tcg_env @@ -370,10 +367,6 @@ tcRnModuleTcRnM hsc_env mod_sum } } -implicitPreludeWarn :: SDoc -implicitPreludeWarn - = text "Module `Prelude' implicitly imported" - {- ************************************************************************ * * @@ -633,18 +626,15 @@ tc_rn_src_decls ds ; case th_group_tail of { Nothing -> return () ; Just (SpliceDecl _ (L loc _) _, _) -> - setSrcSpanA loc - $ addErr (mkTcRnUnknownMessage $ mkPlainError noHints $ text - ("Declaration splices are not " - ++ "permitted inside top-level " - ++ "declarations added with addTopDecls")) + setSrcSpanA loc $ addErr $ + TcRnUnexpectedDeclarationSplice } -- Rename TH-generated top-level declarations ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env $ rnTopSrcDecls th_group -- Dump generated top-level declarations - ; let msg = "top-level declarations added with addTopDecls" + ; let msg = "top-level declarations added with 'addTopDecls'" ; traceSplice $ SpliceInfo { spliceDescription = msg , spliceIsDecl = True @@ -693,8 +683,8 @@ tc_rn_src_decls ds ************************************************************************ -} -tcRnHsBootDecls :: HscSource -> [LHsDecl GhcPs] -> TcM TcGblEnv -tcRnHsBootDecls hsc_src decls +tcRnHsBootDecls :: HsBootOrSig -> [LHsDecl GhcPs] -> TcM TcGblEnv +tcRnHsBootDecls boot_or_sig decls = do { (first_group, group_tail) <- findSplice decls -- Rename the declarations @@ -716,11 +706,11 @@ tcRnHsBootDecls hsc_src decls -- Check for illegal declarations ; case group_tail of - Just (SpliceDecl _ d _, _) -> badBootDecl hsc_src "splice" d + Just (SpliceDecl _ d _, _) -> rejectBootDecls boot_or_sig BootSpliceDecls [d] Nothing -> return () - ; mapM_ (badBootDecl hsc_src "foreign") for_decls - ; mapM_ (badBootDecl hsc_src "default") def_decls - ; mapM_ (badBootDecl hsc_src "rule") rule_decls + ; rejectBootDecls boot_or_sig BootForeignDecls for_decls + ; rejectBootDecls boot_or_sig BootDefaultDecls def_decls + ; rejectBootDecls boot_or_sig BootRuleDecls rule_decls -- Typecheck type/class/instance decls ; traceTc "Tc2 (boot)" empty @@ -754,17 +744,6 @@ tcRnHsBootDecls hsc_src decls }}} ; traceTc "boot" (ppr lie); return gbl_env } -badBootDecl :: HscSource -> String -> LocatedA decl -> TcM () -badBootDecl hsc_src what (L loc _) - = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (char 'A' <+> text what - <+> text "declaration is not (currently) allowed in a" - <+> (case hsc_src of - HsBootFile -> text "hs-boot" - HsigFile -> text "hsig" - _ -> panic "badBootDecl: should be an hsig or hs-boot file") - <+> text "file") - {- Once we've typechecked the body of the module, we want to compare what we've found (gathered in a TypeEnv) with the hi-boot details (if any). @@ -1005,7 +984,7 @@ checkHiBootIface' -- that the hs-boot file exports. [] -> do addErrAt (nameSrcSpan missing_name) - (missingBootThing True missing_name "exported by") + (missingBootThing HsBoot missing_name MissingBootExport) return Nothing -- If the boot module does not *define* the thing, we are done @@ -1017,11 +996,11 @@ checkHiBootIface' -- then compare the definitions | Just real_thing <- lookupTypeEnv local_type_env name, Just boot_thing <- mb_boot_thing - = do checkBootDeclM True boot_thing real_thing + = do checkBootDeclM HsBoot boot_thing real_thing return Nothing | otherwise - = do addErrTc (missingBootThing True name "defined in") + = do addErrTc (missingBootThing HsBoot name MissingBootDefinition) return Nothing where name = availName boot_avail @@ -1069,7 +1048,8 @@ checkHiBootIface' vcat (map (ppr . idType . instanceDFunId) local_insts) , text "boot_dfun_ty" <+> ppr (idType boot_dfun) ] - ; addErrTc (instMisMatch boot_dfun) + ; addErrTc $ TcRnBootMismatch HsBoot + $ MissingBootInstance boot_dfun ; return Nothing } find_real_dfun :: DFunId -> [DFunId] @@ -1091,13 +1071,18 @@ checkHiBootIface' -- | Compares two things for equivalence between boot-file and normal code, -- reporting an error if they don't match up. -checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig) - -> TyThing -> TyThing -> TcM () -checkBootDeclM is_boot boot_thing real_thing - = whenIsJust (checkBootDecl is_boot boot_thing real_thing) $ \ err -> - addErrAt span - (bootMisMatch is_boot err real_thing boot_thing) +checkBootDeclM :: HsBootOrSig + -> TyThing -- ^ boot thing + -> TyThing -- ^ real thing + -> TcM () +checkBootDeclM boot_or_sig boot_thing real_thing + = for_ boot_errs $ \ boot_err -> + addErrAt span $ + TcRnBootMismatch boot_or_sig $ + BootMismatch boot_thing real_thing boot_err where + boot_errs = execWriter $ checkBootDecl boot_or_sig boot_thing real_thing + -- Here we use the span of the boot thing or, if it doesn't have a sensible -- span, that of the real thing, span @@ -1107,69 +1092,77 @@ checkBootDeclM is_boot boot_thing real_thing | otherwise = nameSrcSpan (getName real_thing) +-- | Writer monad for accumulating errors when comparing an hs-boot or +-- signature file with its implementing module. +type BootErrsM err = Writer [err] () + +-- | If the test in the first parameter is True, succeed. +-- Otherwise, record the given error. +check :: Bool -> err -> BootErrsM err +check True _ = checkSuccess +check False err = bootErr err + +-- | Record an error. +bootErr :: err -> BootErrsM err +bootErr err = tell [err] + +-- | A convenience synonym for a lack of errors, for @checkBootDecl@ and friends. +checkSuccess :: BootErrsM err +checkSuccess = return () + +-- | Map over the error types in an error-accumulating computation. +embedErrs :: (err1 -> err2) -> BootErrsM err1 -> BootErrsM err2 +embedErrs f = mapWriter (second (fmap f)) + +-- | Wrap up a list of errors into a single message. +wrapErrs :: (NE.NonEmpty err1 -> err2) -> BootErrsM err1 -> BootErrsM err2 +wrapErrs f w = + case execWriter w of + [] -> checkSuccess + err : errs -> bootErr (f $ err :| errs) + -- | Compares the two things for equivalence between boot-file and normal -- code. Returns @Nothing@ on success or @Just "some helpful info for user"@ -- failure. If the difference will be apparent to the user, @Just empty@ is -- perfectly suitable. -checkBootDecl :: Bool -> TyThing -> TyThing -> Maybe SDoc +checkBootDecl :: HsBootOrSig -> TyThing -> TyThing -> BootErrsM BootMismatchWhat checkBootDecl _ (AnId id1) (AnId id2) = assert (id1 == id2) $ check (idType id1 `eqType` idType id2) - (text "The two types are different") - -checkBootDecl is_boot (ATyCon tc1) (ATyCon tc2) - = checkBootTyCon is_boot tc1 tc2 - -checkBootDecl _ (AConLike (RealDataCon dc1)) (AConLike (RealDataCon _)) - = pprPanic "checkBootDecl" (ppr dc1) - -checkBootDecl _ _ _ = Just empty -- probably shouldn't happen + (BootMismatchedIdTypes id1 id2) --- | Combines two potential error messages -andThenCheck :: Maybe SDoc -> Maybe SDoc -> Maybe SDoc -Nothing `andThenCheck` msg = msg -msg `andThenCheck` Nothing = msg -Just d1 `andThenCheck` Just d2 = Just (d1 $$ d2) -infixr 0 `andThenCheck` +checkBootDecl boot_or_sig (ATyCon tc1) (ATyCon tc2) + = wrapErrs (BootMismatchedTyCons tc1 tc2) $ + checkBootTyCon boot_or_sig tc1 tc2 --- | If the test in the first parameter is True, succeed with @Nothing@; --- otherwise, return the provided check -checkUnless :: Bool -> Maybe SDoc -> Maybe SDoc -checkUnless True _ = Nothing -checkUnless False k = k +checkBootDecl _ t1 t2 + = pprPanic "checkBootDecl" (ppr t1 $$ ppr t2) -- | Run the check provided for every pair of elements in the lists. --- The provided SDoc should name the element type, in the plural. -checkListBy :: (a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc - -> Maybe SDoc -checkListBy check_fun as bs whats = go [] as bs +-- +-- Records an error: +-- +-- - when any two items at the same position in the two lists don't match +-- according to the given function, +-- - when the lists are of different lengths. +checkListBy :: (a -> a -> BootErrsM err) -> [a] -> [a] + -> (BootListMismatches a err -> err2) + -> BootErrsM err2 +checkListBy check_fun as bs mk_err = wrapErrs mk_err $ go 1 as bs where - herald = text "The" <+> whats <+> text "do not match" - - go [] [] [] = Nothing - go docs [] [] = Just (hang (herald <> colon) 2 (vcat $ reverse docs)) - go docs (x:xs) (y:ys) = case check_fun x y of - Just doc -> go (doc:docs) xs ys - Nothing -> go docs xs ys - go _ _ _ = Just (hang (herald <> colon) - 2 (text "There are different numbers of" <+> whats)) - --- | If the test in the first parameter is True, succeed with @Nothing@; --- otherwise, fail with the given SDoc. -check :: Bool -> SDoc -> Maybe SDoc -check True _ = Nothing -check False doc = Just doc - --- | A more perspicuous name for @Nothing@, for @checkBootDecl@ and friends. -checkSuccess :: Maybe SDoc -checkSuccess = Nothing + go _ [] [] = checkSuccess + go !i (x:xs) (y:ys) = + do { embedErrs (MismatchedThing i x y) $ check_fun x y + ; go (i+1) xs ys } + go _ _ _ = bootErr MismatchedLength ---------------- -checkBootTyCon :: Bool -> TyCon -> TyCon -> Maybe SDoc -checkBootTyCon is_boot tc1 tc2 +checkBootTyCon :: HsBootOrSig -> TyCon -> TyCon -> BootErrsM BootTyConMismatch +checkBootTyCon boot_or_sig tc1 tc2 | not (eqType (tyConKind tc1) (tyConKind tc2)) - = Just $ text "The types have different kinds" -- First off, check the kind + -- First off, check the kind + = bootErr TyConKindMismatch | Just c1 <- tyConClass_maybe tc1 , Just c2 <- tyConClass_maybe tc2 @@ -1178,383 +1171,407 @@ checkBootTyCon is_boot tc1 tc2 (clas_tvs2, clas_fds2, sc_theta2, _, ats2, op_stuff2) = classExtraBigSig c2 , Just env <- eqVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2 - = let - eqSig (id1, def_meth1) (id2, def_meth2) - = check (name1 == name2) - (text "The names" <+> pname1 <+> text "and" <+> pname2 <+> - text "are different") `andThenCheck` - check (eqTypeX env op_ty1 op_ty2) - (text "The types of" <+> pname1 <+> - text "are different") `andThenCheck` - if is_boot - then check (liftEq eqDM def_meth1 def_meth2) - (text "The default methods associated with" <+> pname1 <+> - text "are different") - else check (subDM op_ty1 def_meth1 def_meth2) - (text "The default methods associated with" <+> pname1 <+> - text "are not compatible") - where - name1 = idName id1 - name2 = idName id2 - pname1 = quotes (ppr name1) - pname2 = quotes (ppr name2) - op_ty1 = classMethodTy id1 - op_ty2 = classMethodTy id2 - - eqAT (ATI tc1 def_ats1) (ATI tc2 def_ats2) - = checkBootTyCon is_boot tc1 tc2 `andThenCheck` - check (eqATDef def_ats1 def_ats2) - (text "The associated type defaults differ") - - eqDM (_, VanillaDM) (_, VanillaDM) = True - eqDM (_, GenericDM t1) (_, GenericDM t2) = eqTypeX env t1 t2 - eqDM _ _ = False - - -- NB: first argument is from hsig, second is from real impl. - -- Order of pattern matching matters. - subDM _ Nothing _ = True - subDM _ _ Nothing = False - - -- If the hsig wrote: - -- - -- f :: a -> a - -- default f :: a -> a - -- - -- this should be validly implementable using an old-fashioned - -- vanilla default method. - subDM t1 (Just (_, GenericDM gdm_t1)) (Just (_, VanillaDM)) - = eqType t1 gdm_t1 -- Take care (#22476). Both t1 and gdm_t1 come - -- from tc1, so use eqType, and /not/ eqTypeX - - -- This case can occur when merging signatures - subDM t1 (Just (_, VanillaDM)) (Just (_, GenericDM t2)) - = eqTypeX env t1 t2 - - subDM _ (Just (_, VanillaDM)) (Just (_, VanillaDM)) = True - subDM _ (Just (_, GenericDM t1)) (Just (_, GenericDM t2)) - = eqTypeX env t1 t2 - - -- Ignore the location of the defaults - eqATDef Nothing Nothing = True - eqATDef (Just (ty1, _loc1)) (Just (ty2, _loc2)) = eqTypeX env ty1 ty2 - eqATDef _ _ = False - - eqFD (as1,bs1) (as2,bs2) = - liftEq (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && - liftEq (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2) - in - checkRoles roles1 roles2 `andThenCheck` - -- Checks kind of class - check (liftEq eqFD clas_fds1 clas_fds2) - (text "The functional dependencies do not match") `andThenCheck` - checkUnless (isAbstractTyCon tc1) $ - check (liftEq (eqTypeX env) sc_theta1 sc_theta2) - (text "The class constraints do not match") `andThenCheck` - checkListBy eqSig op_stuff1 op_stuff2 (text "methods") `andThenCheck` - checkListBy eqAT ats1 ats2 (text "associated types") `andThenCheck` - check (classMinimalDef c1 `BF.implies` classMinimalDef c2) - (text "The MINIMAL pragmas are not compatible") + = do { check_roles + ; embedErrs (TyConMismatchedClasses c1 c2) $ + do { -- Checks kind of class + ; check (liftEq (eqFD env) clas_fds1 clas_fds2) + MismatchedFunDeps + ; unless (isAbstractTyCon tc1) $ + do { check (liftEq (eqTypeX env) sc_theta1 sc_theta2) + MismatchedSuperclasses + ; checkListBy (compatClassOp env boot_or_sig) op_stuff1 op_stuff2 + MismatchedMethods + ; checkListBy (compatAT env boot_or_sig) ats1 ats2 + MismatchedATs + ; check (classMinimalDef c1 `BF.implies` classMinimalDef c2) + MismatchedMinimalPragmas + } } } | Just syn_rhs1 <- synTyConRhs_maybe tc1 , Just syn_rhs2 <- synTyConRhs_maybe tc2 , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) = assert (tc1 == tc2) $ - checkRoles roles1 roles2 `andThenCheck` - check (eqTypeX env syn_rhs1 syn_rhs2) empty -- nothing interesting to say + do { check_roles + ; check (eqTypeX env syn_rhs1 syn_rhs2) $ + TyConSynonymMismatch syn_rhs1 syn_rhs2 } + -- This allows abstract 'data T a' to be implemented using 'type T = ...' -- and abstract 'class K a' to be implement using 'type K = ...' -- See Note [Synonyms implement abstract data] - | not is_boot -- don't support for hs-boot yet + | Hsig <- boot_or_sig -- don't support for hs-boot yet , isAbstractTyCon tc1 , Just (tvs, ty) <- synTyConDefn_maybe tc2 - , Just (tc2', args) <- tcSplitTyConApp_maybe ty - = checkSynAbsData tvs ty tc2' args - -- TODO: When it's a synonym implementing a class, we really - -- should check if the fundeps are satisfied, but - -- there is not an obvious way to do this for a constraint synonym. - -- So for now, let it all through (it won't cause segfaults, anyway). - -- Tracked at #12704. - - -- This allows abstract 'data T :: Nat' to be implemented using - -- 'type T = 42' Since the kinds already match (we have checked this - -- upfront) all we need to check is that the implementation 'type T - -- = ...' defined an actual literal. See #15138 for the case this - -- handles. - | not is_boot - , isAbstractTyCon tc1 - , Just (_,ty2) <- synTyConDefn_maybe tc2 - , isJust (isLitTy ty2) - = Nothing + = checkSynAbsData tc1 tc2 tvs ty | Just fam_flav1 <- famTyConFlav_maybe tc1 , Just fam_flav2 <- famTyConFlav_maybe tc2 = assert (tc1 == tc2) $ - let eqFamFlav OpenSynFamilyTyCon OpenSynFamilyTyCon = True - eqFamFlav (DataFamilyTyCon {}) (DataFamilyTyCon {}) = True - -- This case only happens for hsig merging: - eqFamFlav AbstractClosedSynFamilyTyCon AbstractClosedSynFamilyTyCon = True - eqFamFlav AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) = True - eqFamFlav (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon = True - eqFamFlav (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2) - = eqClosedFamilyAx ax1 ax2 - eqFamFlav (BuiltInSynFamTyCon {}) (BuiltInSynFamTyCon {}) = tc1 == tc2 - eqFamFlav _ _ = False - injInfo1 = tyConInjectivityInfo tc1 - injInfo2 = tyConInjectivityInfo tc2 - in - -- check equality of roles, family flavours and injectivity annotations - -- (NB: Type family roles are always nominal. But the check is - -- harmless enough.) - checkRoles roles1 roles2 `andThenCheck` - check (eqFamFlav fam_flav1 fam_flav2) - (whenPprDebug $ - text "Family flavours" <+> ppr fam_flav1 <+> text "and" <+> ppr fam_flav2 <+> - text "do not match") `andThenCheck` - check (injInfo1 == injInfo2) (text "Injectivities do not match") + do { let injInfo1 = tyConInjectivityInfo tc1 + injInfo2 = tyConInjectivityInfo tc2 + ; -- check equality of roles, family flavours and injectivity annotations + -- (NB: Type family roles are always nominal. But the check is + -- harmless enough.) + ; check_roles + ; compatFamFlav fam_flav1 fam_flav2 + ; check (injInfo1 == injInfo2) TyConInjectivityMismatch } | isAlgTyCon tc1 && isAlgTyCon tc2 , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) = assert (tc1 == tc2) $ - checkRoles roles1 roles2 `andThenCheck` - check (liftEq (eqTypeX env) + do { check_roles + ; let rhs1 = algTyConRhs tc1 + rhs2 = algTyConRhs tc2 + ; embedErrs (TyConMismatchedData rhs1 rhs2) $ + do { check (liftEq (eqTypeX env) (tyConStupidTheta tc1) (tyConStupidTheta tc2)) - (text "The datatype contexts do not match") `andThenCheck` - eqAlgRhs tc1 (algTyConRhs tc1) (algTyConRhs tc2) + MismatchedDatatypeContexts + ; compatAlgRhs rhs1 rhs2 } } - | otherwise = Just empty -- two very different types -- should be obvious + | otherwise = bootErr TyConsVeryDifferent + -- two very different types; + -- should be obvious to the user what the problem is where - roles1 = tyConRoles tc1 -- the abstract one - roles2 = tyConRoles tc2 - roles_msg = text "The roles do not match." $$ - (text "Roles on abstract types default to" <+> - quotes (text "representational") <+> text "in boot files.") - - roles_subtype_msg = text "The roles are not compatible:" $$ - text "Main module:" <+> ppr roles2 $$ - text "Hsig file:" <+> ppr roles1 - - checkRoles r1 r2 - | is_boot || isInjectiveTyCon tc1 Representational -- See Note [Role subtyping] - = check (r1 == r2) roles_msg - | otherwise = check (r2 `rolesSubtypeOf` r1) roles_subtype_msg - - -- Note [Role subtyping] - -- ~~~~~~~~~~~~~~~~~~~~~ - -- In the current formulation of roles, role subtyping is only OK if the - -- "abstract" TyCon was not representationally injective. Among the most - -- notable examples of non representationally injective TyCons are abstract - -- data, which can be implemented via newtypes (which are not - -- representationally injective). The key example is - -- in this example from #13140: - -- - -- -- In an hsig file - -- data T a -- abstract! - -- type role T nominal - -- - -- -- Elsewhere - -- foo :: Coercible (T a) (T b) => a -> b - -- foo x = x - -- - -- We must NOT allow foo to typecheck, because if we instantiate - -- T with a concrete data type with a phantom role would cause - -- Coercible (T a) (T b) to be provable. Fortunately, if T is not - -- representationally injective, we cannot make the inference that a ~N b if - -- T a ~R T b. - -- - -- Unconditional role subtyping would be possible if we setup - -- an extra set of roles saying when we can project out coercions - -- (we call these proj-roles); then it would NOT be valid to instantiate T - -- with a data type at phantom since the proj-role subtyping check - -- would fail. See #13140 for more details. - -- - -- One consequence of this is we get no role subtyping for non-abstract - -- data types in signatures. Suppose you have: - -- - -- signature A where - -- type role T nominal - -- data T a = MkT - -- - -- If you write this, we'll treat T as injective, and make inferences - -- like T a ~R T b ==> a ~N b (mkSelCo). But if we can - -- subsequently replace T with one at phantom role, we would then be able to - -- infer things like T Int ~R T Bool which is bad news. + check_roles = checkRoles boot_or_sig tc1 (tyConRoles tc2) + + +emptyRnEnv2 :: RnEnv2 +emptyRnEnv2 = mkRnEnv2 emptyInScopeSet + +-- | Check that two class methods have compatible type signatures. +compatClassOp :: RnEnv2 -> HsBootOrSig -> ClassOpItem -> ClassOpItem -> BootErrsM BootMethodMismatch +compatClassOp env boot_or_sig (id1, def_meth1) (id2, def_meth2) + = do { check (name1 == name2) $ + MismatchedMethodNames + ; check (eqTypeX env op_ty1 op_ty2) $ + MismatchedMethodTypes op_ty1 op_ty2 + ; case boot_or_sig of + HsBoot -> + check (liftEq eqDM def_meth1 def_meth2) $ + MismatchedDefaultMethods False + Hsig -> + check (subDM op_ty1 def_meth1 def_meth2) $ + MismatchedDefaultMethods True } + where + name1 = idName id1 + name2 = idName id2 + op_ty1 = classMethodTy id1 + op_ty2 = classMethodTy id2 + + eqDM (_, VanillaDM) (_, VanillaDM) = True + eqDM (_, GenericDM t1) (_, GenericDM t2) = eqTypeX env t1 t2 + eqDM _ _ = False + + -- NB: first argument is from hsig, second is from real impl. + -- Order of pattern matching matters. + subDM _ Nothing _ = True + subDM _ _ Nothing = False + + -- If the hsig wrote: -- - -- We could allow role subtyping here if we didn't treat *any* data types - -- defined in signatures as injective. But this would be a bit surprising, - -- replacing a data type in a module with one in a signature could cause - -- your code to stop typechecking (whereas if you made the type abstract, - -- it is more understandable that the type checker knows less). + -- f :: a -> a + -- default f :: a -> a -- - -- It would have been best if this was purely a question of defaults - -- (i.e., a user could explicitly ask for one behavior or another) but - -- the current role system isn't expressive enough to do this. - -- Having explicit proj-roles would solve this problem. + -- this should be validly implementable using an old-fashioned + -- vanilla default method. + subDM t1 (Just (_, GenericDM gdm_t1)) (Just (_, VanillaDM)) + = eqType t1 gdm_t1 -- Take care (#22476). Both t1 and gdm_t1 come + -- from tc1, so use eqType, and /not/ eqTypeX + + -- This case can occur when merging signatures + subDM t1 (Just (_, VanillaDM)) (Just (_, GenericDM t2)) + = eqTypeX env t1 t2 + + subDM _ (Just (_, VanillaDM)) (Just (_, VanillaDM)) = True + subDM _ (Just (_, GenericDM t1)) (Just (_, GenericDM t2)) + = eqTypeX env t1 t2 + +-- | Check that two associated types are compatible. +compatAT :: RnEnv2 -> HsBootOrSig -> ClassATItem -> ClassATItem + -> BootErrsM BootATMismatch +compatAT env boot_or_sig (ATI tc1 def_ats1) (ATI tc2 def_ats2) + = do { embedErrs MismatchedTyConAT $ + checkBootTyCon boot_or_sig tc1 tc2 + ; check (compatATDef def_ats1 def_ats2) + MismatchedATDefaultType } + + where + -- Ignore the location of the defaults + compatATDef Nothing Nothing = True + compatATDef (Just (ty1, _loc1)) (Just (ty2, _loc2)) = eqTypeX env ty1 ty2 + compatATDef _ _ = False + +-- | Check that two functional dependencies are the same. +eqFD :: RnEnv2 -> FunDep TyVar -> FunDep TyVar -> Bool +eqFD env (as1,bs1) (as2,bs2) = + liftEq (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && + liftEq (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2) + +-- | Check compatibility of two type family flavours. +compatFamFlav :: FamTyConFlav -> FamTyConFlav -> BootErrsM BootTyConMismatch +compatFamFlav OpenSynFamilyTyCon OpenSynFamilyTyCon + = checkSuccess +compatFamFlav (DataFamilyTyCon {}) (DataFamilyTyCon {}) + = checkSuccess +compatFamFlav AbstractClosedSynFamilyTyCon AbstractClosedSynFamilyTyCon + = checkSuccess -- This case only happens for hsig merging. +compatFamFlav AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) + = checkSuccess +compatFamFlav (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon + = checkSuccess +compatFamFlav (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2) + = eqClosedFamilyAx ax1 ax2 +compatFamFlav (BuiltInSynFamTyCon {}) (BuiltInSynFamTyCon {}) + = checkSuccess +compatFamFlav flav1 flav2 + = bootErr $ TyConFlavourMismatch flav1 flav2 + +-- | Check that two 'AlgTyConRhs's are compatible. +compatAlgRhs :: AlgTyConRhs -> AlgTyConRhs -> BootErrsM BootDataMismatch +compatAlgRhs (AbstractTyCon {}) _rhs2 = + checkSuccess -- rhs2 is guaranteed to be injective, since it's an AlgTyCon +compatAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} = + checkListBy compatCon (data_cons tc1) (data_cons tc2) MismatchedConstructors +compatAlgRhs tc1@NewTyCon{ data_con = dc1 } tc2@NewTyCon{ data_con = dc2 } = + embedErrs (MismatchedConstructors . NE.singleton . MismatchedThing 1 dc1 dc2) $ + compatCon (data_con tc1) (data_con tc2) +compatAlgRhs _ _ = bootErr MismatchedNewtypeVsData + +-- | Check that two 'DataCon's are compatible. +compatCon :: DataCon -> DataCon -> BootErrsM BootDataConMismatch +compatCon c1 c2 + = do { check (dataConName c1 == dataConName c2) + MismatchedDataConNames + ; check (dataConIsInfix c1 == dataConIsInfix c2) + MismatchedDataConFixities + ; check (liftEq eqHsBang (dataConImplBangs c1) (dataConImplBangs c2)) + MismatchedDataConBangs + ; check (map flSelector (dataConFieldLabels c1) == map flSelector (dataConFieldLabels c2)) + MismatchedDataConFieldLabels + ; check (eqType (dataConWrapperType c1) (dataConWrapperType c2)) + MismatchedDataConTypes } + +eqClosedFamilyAx :: Maybe (CoAxiom br) -> Maybe (CoAxiom br1) + -> BootErrsM BootTyConMismatch +eqClosedFamilyAx Nothing Nothing = checkSuccess +eqClosedFamilyAx Nothing (Just _) = bootErr $ TyConAxiomMismatch $ NE.singleton MismatchedLength +eqClosedFamilyAx (Just _) Nothing = bootErr $ TyConAxiomMismatch $ NE.singleton MismatchedLength +eqClosedFamilyAx (Just (CoAxiom { co_ax_branches = branches1 })) + (Just (CoAxiom { co_ax_branches = branches2 })) + = checkListBy eqClosedFamilyBranch branch_list1 branch_list2 + TyConAxiomMismatch + where + branch_list1 = fromBranches branches1 + branch_list2 = fromBranches branches2 + +eqClosedFamilyBranch :: CoAxBranch -> CoAxBranch -> BootErrsM BootAxiomBranchMismatch +eqClosedFamilyBranch (CoAxBranch { cab_tvs = tvs1, cab_cvs = cvs1 + , cab_lhs = lhs1, cab_rhs = rhs1 }) + (CoAxBranch { cab_tvs = tvs2, cab_cvs = cvs2 + , cab_lhs = lhs2, cab_rhs = rhs2 }) + | Just env1 <- eqVarBndrs emptyRnEnv2 tvs1 tvs2 + , Just env <- eqVarBndrs env1 cvs1 cvs2 + = do { check (liftEq (eqTypeX env) lhs1 lhs2) MismatchedAxiomLHS + ; check (eqTypeX env rhs1 rhs2) MismatchedAxiomRHS } + | otherwise + = bootErr MismatchedAxiomBinders + +{- Note [Role subtyping] +~~~~~~~~~~~~~~~~~~~~~~~~ +In the current formulation of roles, role subtyping is only OK if the +"abstract" TyCon was not representationally injective. Among the most +notable examples of non representationally injective TyCons are abstract +data, which can be implemented via newtypes (which are not +representationally injective). The key example is +in this example from #13140: + + -- In an hsig file + data T a -- abstract! + type role T nominal + + -- Elsewhere + foo :: Coercible (T a) (T b) => a -> b + foo x = x + +We must NOT allow foo to typecheck, because if we instantiate +T with a concrete data type with a phantom role would cause +Coercible (T a) (T b) to be provable. Fortunately, if T is not +representationally injective, we cannot make the inference that a ~N b if +T a ~R T b. + +Unconditional role subtyping would be possible if we setup +an extra set of roles saying when we can project out coercions +(we call these proj-roles); then it would NOT be valid to instantiate T +with a data type at phantom since the proj-role subtyping check +would fail. See #13140 for more details. + +One consequence of this is we get no role subtyping for non-abstract +data types in signatures. Suppose you have: + + signature A where + type role T nominal + data T a = MkT + +If you write this, we'll treat T as injective, and make inferences +like T a ~R T b ==> a ~N b (mkSelCo). But if we can +subsequently replace T with one at phantom role, we would then be able to +infer things like T Int ~R T Bool which is bad news. + +We could allow role subtyping here if we didn't treat *any* data types +defined in signatures as injective. But this would be a bit surprising, +replacing a data type in a module with one in a signature could cause +your code to stop typechecking (whereas if you made the type abstract, +it is more understandable that the type checker knows less). + +It would have been best if this was purely a question of defaults +(i.e., a user could explicitly ask for one behavior or another) but +the current role system isn't expressive enough to do this. +Having explicit proj-roles would solve this problem. +-} + +checkRoles :: HsBootOrSig -> TyCon -> [Role] -> BootErrsM BootTyConMismatch +checkRoles boot_or_sig tc1 r2 + | boot_or_sig == HsBoot + || isInjectiveTyCon tc1 Representational -- See Note [Role subtyping] + = check (r1 == r2) (TyConRoleMismatch False) + | otherwise + = check (r2 `rolesSubtypeOf` r1) (TyConRoleMismatch True) + where + + r1 = tyConRoles tc1 rolesSubtypeOf [] [] = True -- NB: this relation is the OPPOSITE of the subroling relation rolesSubtypeOf (x:xs) (y:ys) = x >= y && rolesSubtypeOf xs ys rolesSubtypeOf _ _ = False - -- Note [Synonyms implement abstract data] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- An abstract data type or class can be implemented using a type synonym, - -- but ONLY if the type synonym is nullary and has no type family - -- applications. This arises from two properties of skolem abstract data: - -- - -- For any T (with some number of parameters), - -- - -- 1. T is a valid type (it is "curryable"), and - -- - -- 2. T is valid in an instance head (no type families). - -- - -- See also 'HowAbstract' and Note [Skolem abstract data]. - - -- Given @type T tvs = ty@, where @ty@ decomposes into @tc2' args@, - -- check that this synonym is an acceptable implementation of @tc1@. - -- See Note [Synonyms implement abstract data] - checkSynAbsData :: [TyVar] -> Type -> TyCon -> [Type] -> Maybe SDoc - checkSynAbsData tvs ty tc2' args = - check (null (tcTyFamInsts ty)) - (text "Illegal type family application in implementation of abstract data.") - `andThenCheck` - check (null tvs) - (text "Illegal parameterized type synonym in implementation of abstract data." $$ - text "(Try eta reducing your type synonym so that it is nullary.)") - `andThenCheck` - -- Don't report roles errors unless the type synonym is nullary - checkUnless (not (null tvs)) $ - assert (null roles2) $ - -- If we have something like: - -- - -- signature H where - -- data T a - -- module H where - -- data K a b = ... - -- type T = K Int - -- - -- we need to drop the first role of K when comparing! - checkRoles roles1 (drop (length args) (tyConRoles tc2')) -{- - -- Hypothetically, if we were allow to non-nullary type synonyms, here - -- is how you would check the roles - if length tvs == length roles1 - then checkRoles roles1 roles2 - else case tcSplitTyConApp_maybe ty of - Just (tc2', args) -> - checkRoles roles1 (drop (length args) (tyConRoles tc2') ++ roles2) - Nothing -> Just roles_msg --} +{- Note [Synonyms implement abstract data] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An abstract data type or class can be implemented using a type synonym, +but ONLY if: - eqAlgRhs _ (AbstractTyCon {}) _rhs2 - = checkSuccess -- rhs2 is guaranteed to be injective, since it's an AlgTyCon - eqAlgRhs _ tc1@DataTyCon{} tc2@DataTyCon{} = - checkListBy eqCon (data_cons tc1) (data_cons tc2) (text "constructors") - eqAlgRhs _ tc1@NewTyCon{} tc2@NewTyCon{} = - eqCon (data_con tc1) (data_con tc2) - eqAlgRhs _ _ _ = Just (text "Cannot match a" <+> quotes (text "data") <+> - text "definition with a" <+> quotes (text "newtype") <+> - text "definition") - - eqCon c1 c2 - = check (name1 == name2) - (text "The names" <+> pname1 <+> text "and" <+> pname2 <+> - text "differ") `andThenCheck` - check (dataConIsInfix c1 == dataConIsInfix c2) - (text "The fixities of" <+> pname1 <+> - text "differ") `andThenCheck` - check (liftEq eqHsBang (dataConImplBangs c1) (dataConImplBangs c2)) - (text "The strictness annotations for" <+> pname1 <+> - text "differ") `andThenCheck` - check (map flSelector (dataConFieldLabels c1) == map flSelector (dataConFieldLabels c2)) - (text "The record label lists for" <+> pname1 <+> - text "differ") `andThenCheck` - check (eqType (dataConWrapperType c1) (dataConWrapperType c2)) - (text "The types for" <+> pname1 <+> text "differ") - where - name1 = dataConName c1 - name2 = dataConName c2 - pname1 = quotes (ppr name1) - pname2 = quotes (ppr name2) - - eqClosedFamilyAx Nothing Nothing = True - eqClosedFamilyAx Nothing (Just _) = False - eqClosedFamilyAx (Just _) Nothing = False - eqClosedFamilyAx (Just (CoAxiom { co_ax_branches = branches1 })) - (Just (CoAxiom { co_ax_branches = branches2 })) - = numBranches branches1 == numBranches branches2 - && (and $ zipWith eqClosedFamilyBranch branch_list1 branch_list2) - where - branch_list1 = fromBranches branches1 - branch_list2 = fromBranches branches2 + 1. T, as a standalone occurrence, is a valid type + (T is "curryable"), and - eqClosedFamilyBranch (CoAxBranch { cab_tvs = tvs1, cab_cvs = cvs1 - , cab_lhs = lhs1, cab_rhs = rhs1 }) - (CoAxBranch { cab_tvs = tvs2, cab_cvs = cvs2 - , cab_lhs = lhs2, cab_rhs = rhs2 }) - | Just env1 <- eqVarBndrs emptyRnEnv2 tvs1 tvs2 - , Just env <- eqVarBndrs env1 cvs1 cvs2 - = liftEq (eqTypeX env) lhs1 lhs2 && - eqTypeX env rhs1 rhs2 + 2. T is valid in an instance head. - | otherwise = False +This gives rise to the following conditions under which we can implement +an abstract data declaration @data T@ using a type synonym @type T tvs = rhs@: -emptyRnEnv2 :: RnEnv2 -emptyRnEnv2 = mkRnEnv2 emptyInScopeSet + 1. The type synonym T is nullary (tvs is null). ----------------- -missingBootThing :: Bool -> Name -> String -> TcRnMessage -missingBootThing is_boot name what - = mkTcRnUnknownMessage $ mkPlainError noHints $ - quotes (ppr name) <+> text "is exported by the" - <+> (if is_boot then text "hs-boot" else text "hsig") - <+> text "file, but not" - <+> text what <+> text "the module" - -badReexportedBootThing :: Bool -> Name -> Name -> TcRnMessage -badReexportedBootThing is_boot name name' - = mkTcRnUnknownMessage $ mkPlainError noHints $ - withUserStyle alwaysQualify AllTheWay $ vcat - [ text "The" <+> (if is_boot then text "hs-boot" else text "hsig") - <+> text "file (re)exports" <+> quotes (ppr name) - , text "but the implementing module exports a different identifier" <+> quotes (ppr name') - ] - -bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> TcRnMessage -bootMisMatch is_boot extra_info real_thing boot_thing - = mkTcRnUnknownMessage $ mkPlainError noHints $ - pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc + 2. The rhs must not contain any foralls, quantified types, or type family + applications. + See 'invalidAbsDataSubTypes' which computes a collection of + invalid subtypes. + +See also 'HowAbstract' and Note [Skolem abstract data]. +-} + +-- | We are implementing an abstract data declaration of the form @data T@ +-- in a signature file, with a type synonym @type T tvs = rhs@ in the +-- implementing module. +-- +-- This function checks that the implementation is valid: +-- +-- 1. the type synonym T is nullary, i.e. tvs is null, +-- 2. rhs doesn't contain any type families, foralls, or qualified types. +-- +-- See Note [Synonyms implement abstract data] +checkSynAbsData :: TyCon -- ^ @tc1@, the abstract data 'TyCon' we are implementing + -> TyCon -- ^ @tc2@, a type synonym @type T tvs = ty@ + -- we are using to implement @tc1@ + -> [TyVar] -- ^ @tvs@ + -> Type -- ^ @ty@ + -> BootErrsM BootTyConMismatch +checkSynAbsData tc1 tc2 syn_tvs syn_rhs + -- We are implementing @data T@ with @type T tvs = rhs@. + -- Check the conditions of Note [Synonyms implement abstract data]. + = do { -- (1): T is nullary. + ; check (null syn_tvs) $ + SynAbstractData SynAbsDataTySynNotNullary + -- (2): the RHS of the type synonym is valid. + ; case invalidAbsDataSubTypes syn_rhs of + [] -> checkSuccess + err:errs -> bootErr $ SynAbstractData $ + SynAbstractDataInvalidRHS (err :| errs) + -- NB: this allows implementing e.g. @data T :: Nat@ with @type T = 3@. + -- See #15138. + + -- TODO: When it's a synonym implementing a class, we really + -- should check that the fundeps are satisfied, but + -- there is not an obvious way to do this for a constraint synonym. + -- So for now, let it all through (it won't cause segfaults, anyway). + -- Tracked at #12704. + + -- ... we also need to check roles. + ; if | Just (tc2', args) <- tcSplitTyConApp_maybe syn_rhs + , null syn_tvs -- Don't report role errors unless the type synonym is nullary + -> assert (null (tyConRoles tc2)) $ + -- If we have something like: + -- + -- signature H where + -- data T a + -- module H where + -- data K a b = ... + -- type T = K Int + -- + -- we need to drop the first role of K when comparing! + checkRoles Hsig tc1 (drop (length args) (tyConRoles tc2')) + | otherwise + -> checkSuccess + } + +{- + -- Hypothetically, if we were allow to non-nullary type synonyms, here + -- is how you would check the roles + if length tvs == length roles1 + then checkRoles roles1 roles2 + else case tcSplitTyConApp_maybe ty of + Just (tc2', args) -> + checkRoles Hsig tc1 (drop (length args) (tyConRoles tc2') ++ roles2) + Nothing -> Just roles_msg +-} + +-- | Is this type a valid implementation of abstract data? +-- +-- Returns a list of invalid sub-types encountered. +invalidAbsDataSubTypes :: Type -> [Type] +invalidAbsDataSubTypes = execWriter . go where - to_doc - = pprTyThingInContext $ showToHeader { ss_forall = - if is_boot - then ShowForAllMust - else ShowForAllWhen } - - real_doc = to_doc real_thing - boot_doc = to_doc boot_thing - - pprBootMisMatch :: Bool -> SDoc -> TyThing -> SDoc -> SDoc -> SDoc - pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc - = vcat - [ ppr real_thing <+> - text "has conflicting definitions in the module", - text "and its" <+> - (if is_boot - then text "hs-boot file" - else text "hsig file"), - text "Main module:" <+> real_doc, - (if is_boot - then text "Boot file: " - else text "Hsig file: ") - <+> boot_doc, - extra_info - ] - -instMisMatch :: DFunId -> TcRnMessage -instMisMatch dfun - = mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "instance" <+> ppr (idType dfun)) - 2 (text "is defined in the hs-boot file, but not in the module itself") + go :: Type -> Writer [Type] () + go ty + | Just ty' <- coreView ty + = go ty' + go TyVarTy{} + = ok -- We report an error at the binding site of type variables, + -- e.g. in the TySyn LHS or in the forall. + -- It's not useful to report a second error for their occurrences + go (AppTy t1 t2) + = do { go t1; go t2 } + go ty@(TyConApp tc tys) + | isTypeFamilyTyCon tc + = invalid ty + | otherwise + = mapM_ go tys + go ty@(ForAllTy{}) + = invalid ty + go ty@(FunTy af w t1 t2) + | af == FTF_T_T + = do { go w + ; go (typeKind t1) ; go t1 + ; go (typeKind t2) ; go t2 + } + | otherwise + = invalid ty + go LitTy{} + = ok + go ty@(CastTy{}) + = invalid ty + go ty@(CoercionTy{}) + = invalid ty + + ok = pure () + invalid ty = tell [ty] {- ************************************************************************ @@ -1609,13 +1626,6 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, updLclEnv (\tcl_env -> tcl_env { tcl_th_bndrs = th_bndrs `plusNameEnv` tcl_th_bndrs tcl_env }) $ setGblEnv tcg_env $ do { - -- Generate Applicative/Monad proposal (AMP) warnings - traceTc "Tc3b" empty ; - - -- Generate Semigroup/Monoid warnings - traceTc "Tc3c" empty ; - tcSemigroupWarnings ; - -- Foreign import declarations next. traceTc "Tc4" empty ; (fi_ids, fi_decls, fi_gres) <- tcForeignImports foreign_decls ; @@ -1689,196 +1699,6 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, tcTopSrcDecls _ = panic "tcTopSrcDecls: ValBindsIn" - -tcSemigroupWarnings :: TcM () -tcSemigroupWarnings = do - mod <- getModule - -- ghc-prim doesn't depend on base - unless (moduleUnit mod == primUnit) $ do - traceTc "tcSemigroupWarnings" empty - let warnFlag = Opt_WarnSemigroup - tcPreludeClashWarn warnFlag sappendName - tcMissingParentClassWarn warnFlag monoidClassName semigroupClassName - - --- | Warn on local definitions of names that would clash with future Prelude --- elements. --- --- A name clashes if the following criteria are met: --- 1. It would is imported (unqualified) from Prelude --- 2. It is locally defined in the current module --- 3. It has the same literal name as the reference function --- 4. It is not identical to the reference function -tcPreludeClashWarn :: WarningFlag - -> Name - -> TcM () -tcPreludeClashWarn warnFlag name = do - { warn <- woptM warnFlag - ; when warn $ do - { traceTc "tcPreludeClashWarn/wouldBeImported" empty - -- Is the name imported (unqualified) from Prelude? (Point 4 above) - ; rnImports <- fmap (map unLoc . tcg_rn_imports) getGblEnv - -- (Note that this automatically handles -XNoImplicitPrelude, as Prelude - -- will not appear in rnImports automatically if it is set.) - - -- Continue only the name is imported from Prelude - ; when (importedViaPrelude name rnImports) $ do - -- Handle 2.-4. - { rdrElts <- fmap (concat . nonDetOccEnvElts . tcg_rdr_env) getGblEnv - - ; let clashes :: GlobalRdrElt -> Bool - clashes x = isLocalDef && nameClashes && isNotInProperModule - where - isLocalDef = gre_lcl x == True - -- Names are identical ... - nameClashes = nameOccName (greName x) == nameOccName name - -- ... but not the actual definitions, because we don't want to - -- warn about a bad definition of e.g. <> in Data.Semigroup, which - -- is the (only) proper place where this should be defined - isNotInProperModule = greName x /= name - - -- List of all offending definitions - clashingElts :: [GlobalRdrElt] - clashingElts = filter clashes rdrElts - - ; traceTc "tcPreludeClashWarn/prelude_functions" - (hang (ppr name) 4 (sep [ppr clashingElts])) - - ; let warn_msg x = addDiagnosticAt (nameSrcSpan (greName x)) $ - mkTcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag warnFlag) noHints $ (hsep - [ text "Local definition of" - , (quotes . ppr . nameOccName . greName) x - , text "clashes with a future Prelude name." ] - $$ - text "This will become an error in a future release." ) - ; mapM_ warn_msg clashingElts - }}} - - where - - -- Is the given name imported via Prelude? - -- - -- Possible scenarios: - -- a) Prelude is imported implicitly, issue warnings. - -- b) Prelude is imported explicitly, but without mentioning the name in - -- question. Issue no warnings. - -- c) Prelude is imported hiding the name in question. Issue no warnings. - -- d) Qualified import of Prelude, no warnings. - importedViaPrelude :: Name - -> [ImportDecl GhcRn] - -> Bool - importedViaPrelude name = any importViaPrelude - where - isPrelude :: ImportDecl GhcRn -> Bool - isPrelude imp = unLoc (ideclName imp) == pRELUDE_NAME - - -- Implicit (Prelude) import? - isImplicit :: ImportDecl GhcRn -> Bool - isImplicit = ideclImplicit . ideclExt - - -- Unqualified import? - isUnqualified :: ImportDecl GhcRn -> Bool - isUnqualified = not . isImportDeclQualified . ideclQualified - - -- List of explicitly imported (or hidden) Names from a single import. - -- Nothing -> No explicit imports - -- Just (False, <names>) -> Explicit import list of <names> - -- Just (True , <names>) -> Explicit hiding of <names> - importListOf :: ImportDecl GhcRn -> Maybe (ImportListInterpretation, [Name]) - importListOf = fmap toImportList . ideclImportList - where - toImportList (h, loc) = (h, map (ieName . unLoc) (unLoc loc)) - - isExplicit :: ImportDecl GhcRn -> Bool - isExplicit x = case importListOf x of - Nothing -> False - Just (Exactly, explicit) - -> nameOccName name `elem` map nameOccName explicit - Just (EverythingBut, hidden) - -> nameOccName name `notElem` map nameOccName hidden - - -- Check whether the given name would be imported (unqualified) from - -- an import declaration. - importViaPrelude :: ImportDecl GhcRn -> Bool - importViaPrelude x = isPrelude x - && isUnqualified x - && (isImplicit x || isExplicit x) - - --- Notation: is* is for classes the type is an instance of, should* for those --- that it should also be an instance of based on the corresponding --- is*. -tcMissingParentClassWarn :: WarningFlag - -> Name -- ^ Instances of this ... - -> Name -- ^ should also be instances of this - -> TcM () -tcMissingParentClassWarn warnFlag isName shouldName - = do { warn <- woptM warnFlag - ; when warn $ do - { traceTc "tcMissingParentClassWarn" empty - ; isClass' <- tcLookupClass_maybe isName - ; shouldClass' <- tcLookupClass_maybe shouldName - ; case (isClass', shouldClass') of - (Just isClass, Just shouldClass) -> do - { localInstances <- tcGetInsts - ; let isInstance m = is_cls m == isClass - isInsts = filter isInstance localInstances - ; traceTc "tcMissingParentClassWarn/isInsts" (ppr isInsts) - ; forM_ isInsts (checkShouldInst isClass shouldClass) - } - (is',should') -> - traceTc "tcMissingParentClassWarn/notIsShould" - (hang (ppr isName <> text "/" <> ppr shouldName) 2 ( - (hsep [ quotes (text "Is"), text "lookup for" - , ppr isName - , text "resulted in", ppr is' ]) - $$ - (hsep [ quotes (text "Should"), text "lookup for" - , ppr shouldName - , text "resulted in", ppr should' ]))) - }} - where - -- Check whether the desired superclass exists in a given environment. - checkShouldInst :: Class -- Class of existing instance - -> Class -- Class there should be an instance of - -> ClsInst -- Existing instance - -> TcM () - checkShouldInst isClass shouldClass isInst - = do { instEnv <- tcGetInstEnvs - ; let (instanceMatches, shouldInsts, _) - = lookupInstEnv False instEnv shouldClass (is_tys isInst) - - ; traceTc "tcMissingParentClassWarn/checkShouldInst" - (hang (ppr isInst) 4 - (sep [ppr instanceMatches, ppr shouldInsts])) - - -- "<location>: Warning: <type> is an instance of <is> but not - -- <should>" e.g. "Foo is an instance of Monad but not Applicative" - ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst - warnMsg (RM_KnownTc name:_) = - addDiagnosticAt instLoc $ - mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag warnFlag) noHints $ - hsep [ (quotes . ppr . nameOccName) name - , text "is an instance of" - , (ppr . nameOccName . className) isClass - , text "but not" - , (ppr . nameOccName . className) shouldClass ] - <> text "." - $$ - hsep [ text "This will become an error in" - , text "a future release." ] - warnMsg _ = pure () - ; when (nullUnifiers shouldInsts && null instanceMatches) $ - warnMsg (is_tcs isInst) - } - - tcLookupClass_maybe :: Name -> TcM (Maybe Class) - tcLookupClass_maybe name = tcLookupImported_maybe name >>= \case - Succeeded (ATyCon tc) | cls@(Just _) <- tyConClass_maybe tc -> pure cls - _else -> pure Nothing - - --------------------------- tcTyClsInstDecls :: [TyClGroup GhcRn] -> [LDerivDecl GhcRn] @@ -1996,13 +1816,7 @@ checkMain explicit_mod_hdr export_ies -- in other modes, add error message and go on with typechecking. noMainMsg main_mod main_occ - = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "The" <+> ppMainFn main_occ - <+> text "is not" <+> text defOrExp <+> text "module" - <+> quotes (ppr main_mod) - - defOrExp | explicit_export_list = "exported by" - | otherwise = "defined in" + = TcRnMissingMain explicit_export_list main_mod main_occ explicit_export_list = explicit_mod_hdr && isJust export_ies -- | Get the unqualified name of the function to use as the \"main\" for the main module. @@ -2010,17 +1824,7 @@ checkMain explicit_mod_hdr export_ies getMainOcc :: DynFlags -> OccName getMainOcc dflags = case mainFunIs dflags of Just fn -> mkVarOccFS (mkFastString fn) - Nothing -> mainOcc - -ppMainFn :: OccName -> SDoc -ppMainFn main_occ - | main_occ == mainOcc - = text "IO action" <+> quotes (ppr main_occ) - | otherwise - = text "main IO action" <+> quotes (ppr main_occ) - -mainOcc :: OccName -mainOcc = mkVarOccFS (fsLit "main") + Nothing -> mkVarOccFS (fsLit "main") generateMainBinding :: TcGblEnv -> Name -> TcM TcGblEnv -- There is a single exported 'main' function, called 'foo' (say), @@ -2302,7 +2106,8 @@ tcRnStmt hsc_env rdr_stmt -- None of the Ids should be of unboxed type, because we -- cast them all to HValues in the end! - mapM_ bad_unboxed (filter (mightBeUnliftedType . idType) zonked_ids) ; + mapM_ (addErr . TcRnGhciUnliftedBind) $ + filter (mightBeUnliftedType . idType) zonked_ids ; traceTc "tcs 1" empty ; this_mod <- getModule ; @@ -2315,10 +2120,6 @@ tcRnStmt hsc_env rdr_stmt return (global_ids, zonked_expr, fix_env) } - where - bad_unboxed id = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (sep [text "GHCi can't bind a variable of unlifted type:", - nest 2 (pprPrefixOcc id <+> dcolon <+> ppr (idType id))]) {- -------------------------------------------------------------------------- @@ -2675,9 +2476,7 @@ isGHCiMonad hsc_env ty let userTy = mkTyConApp userTyCon [] _ <- tcLookupInstance ghciClass [userTy] return name - - Just _ -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ text "Ambiguous type!" - Nothing -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ text ("Can't find type:" ++ ty) + _ -> failWithTc $ TcRnGhciMonadLookupFail ty occIO -- | How should we infer a type? See Note [TcRnExprMode] data TcRnExprMode = TM_Inst -- ^ Instantiate inferred quantifiers only (:type) @@ -2981,8 +2780,7 @@ tcRnLookupRdrName hsc_env (L loc rdr_name) let rdr_names = dataTcOccs rdr_name ; names_s <- mapM lookupInfoOccRn rdr_names ; let names = concat names_s - ; when (null names) (addErrTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (text "Not in scope:" <+> quotes (ppr rdr_name))) + ; when (null names) (addErrTc $ mkTcRnNotInScope rdr_name NotInScope) ; return names } tcRnLookupName :: HscEnv -> Name -> IO (Messages TcRnMessage, Maybe TyThing) |