diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2012-01-12 15:10:54 +0000 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2012-01-12 15:10:54 +0000 |
| commit | 5508ada4b1d90ee54d92f69bbff7f66b3e8eceef (patch) | |
| tree | 302bb0c73f96faf9249521b5baf0d879fe11fd6f | |
| parent | b8fe21e9ba5486256c83784ca8b9a839b5c527f4 (diff) | |
| download | haskell-5508ada4b1d90ee54d92f69bbff7f66b3e8eceef.tar.gz | |
Implememt -fdefer-type-errors (Trac #5624)
This patch implements the idea of deferring (most) type errors to
runtime, instead emitting only a warning at compile time. The
basic idea is very simple:
* The on-the-fly unifier in TcUnify never fails; instead if it
gets stuck it emits a constraint.
* The constraint solver tries to solve the constraints (and is
entirely unchanged, hooray).
* The remaining, unsolved constraints (if any) are passed to
TcErrors.reportUnsolved. With -fdefer-type-errors, instead of
emitting an error message, TcErrors emits a warning, AND emits
a binding for the constraint witness, binding it
to (error "the error message"), via the new form of evidence
TcEvidence.EvDelayedError. So, when the program is run,
when (and only when) that witness is needed, the program will
crash with the exact same error message that would have been
given at compile time.
Simple really. But, needless to say, the exercise forced me
into some major refactoring.
* TcErrors is almost entirely rewritten
* EvVarX and WantedEvVar have gone away entirely
* ErrUtils is changed a bit:
* New Severity field in ErrMsg
* Renamed the type Message to MsgDoc (this change
touches a lot of files trivially)
* One minor change is that in the constraint solver we try
NOT to combine insoluble constraints, like Int~Bool, else
all such type errors get combined together and result in
only one error message!
* I moved some definitions from TcSMonad to TcRnTypes,
where they seem to belong more
45 files changed, 1340 insertions, 1126 deletions
diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index fa22e7efea..1f2c34cddc 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -105,7 +105,7 @@ find an occurence of an Id, we fetch it from the in-scope set. \begin{code} -lintCoreBindings :: CoreProgram -> (Bag Message, Bag Message) +lintCoreBindings :: CoreProgram -> (Bag MsgDoc, Bag MsgDoc) -- Returns (warnings, errors) lintCoreBindings binds = initL $ @@ -150,7 +150,7 @@ We use this to check all unfoldings that come in from interfaces lintUnfolding :: SrcLoc -> [Var] -- Treat these as in scope -> CoreExpr - -> Maybe Message -- Nothing => OK + -> Maybe MsgDoc -- Nothing => OK lintUnfolding locn vars expr | isEmptyBag errs = Nothing @@ -905,7 +905,7 @@ newtype LintM a = WarnsAndErrs -> -- Error and warning messages so far (Maybe a, WarnsAndErrs) } -- Result and messages (if any) -type WarnsAndErrs = (Bag Message, Bag Message) +type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc) {- Note [Type substitution] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -953,23 +953,23 @@ initL m \end{code} \begin{code} -checkL :: Bool -> Message -> LintM () +checkL :: Bool -> MsgDoc -> LintM () checkL True _ = return () checkL False msg = failWithL msg -failWithL :: Message -> LintM a +failWithL :: MsgDoc -> LintM a failWithL msg = LintM $ \ loc subst (warns,errs) -> (Nothing, (warns, addMsg subst errs msg loc)) -addErrL :: Message -> LintM () +addErrL :: MsgDoc -> LintM () addErrL msg = LintM $ \ loc subst (warns,errs) -> (Just (), (warns, addMsg subst errs msg loc)) -addWarnL :: Message -> LintM () +addWarnL :: MsgDoc -> LintM () addWarnL msg = LintM $ \ loc subst (warns,errs) -> (Just (), (addMsg subst warns msg loc, errs)) -addMsg :: TvSubst -> Bag Message -> Message -> [LintLocInfo] -> Bag Message +addMsg :: TvSubst -> Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc addMsg subst msgs msg locs = ASSERT( notNull locs ) msgs `snocBag` mk_msg msg @@ -980,7 +980,7 @@ addMsg subst msgs msg locs ptext (sLit "Substitution:") <+> ppr subst | otherwise = cxt1 - mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg) + mk_msg msg = mkLocMessage SevWarning (mkSrcSpan loc loc) (context $$ msg) addLoc :: LintLocInfo -> LintM a -> LintM a addLoc extra_loc m = @@ -1052,7 +1052,7 @@ checkInScope loc_msg var = ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst)) (hsep [ppr var, loc_msg]) } -checkTys :: OutType -> OutType -> Message -> LintM () +checkTys :: OutType -> OutType -> MsgDoc -> LintM () -- check ty2 is subtype of ty1 (ie, has same structure but usage -- annotations need only be consistent, not equal) -- Assumes ty1,ty2 are have alrady had the substitution applied @@ -1110,39 +1110,39 @@ pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)] ------------------------------------------------------ -- Messages for case expressions -mkNullAltsMsg :: CoreExpr -> Message +mkNullAltsMsg :: CoreExpr -> MsgDoc mkNullAltsMsg e = hang (text "Case expression with no alternatives:") 4 (ppr e) -mkDefaultArgsMsg :: [Var] -> Message +mkDefaultArgsMsg :: [Var] -> MsgDoc mkDefaultArgsMsg args = hang (text "DEFAULT case with binders") 4 (ppr args) -mkCaseAltMsg :: CoreExpr -> Type -> Type -> Message +mkCaseAltMsg :: CoreExpr -> Type -> Type -> MsgDoc mkCaseAltMsg e ty1 ty2 = hang (text "Type of case alternatives not the same as the annotation on case:") 4 (vcat [ppr ty1, ppr ty2, ppr e]) -mkScrutMsg :: Id -> Type -> Type -> TvSubst -> Message +mkScrutMsg :: Id -> Type -> Type -> TvSubst -> MsgDoc mkScrutMsg var var_ty scrut_ty subst = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var, text "Result binder type:" <+> ppr var_ty,--(idType var), text "Scrutinee type:" <+> ppr scrut_ty, hsep [ptext (sLit "Current TV subst"), ppr subst]] -mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> Message +mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> MsgDoc mkNonDefltMsg e = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e) mkNonIncreasingAltsMsg e = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e) -nonExhaustiveAltsMsg :: CoreExpr -> Message +nonExhaustiveAltsMsg :: CoreExpr -> MsgDoc nonExhaustiveAltsMsg e = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e) -mkBadConMsg :: TyCon -> DataCon -> Message +mkBadConMsg :: TyCon -> DataCon -> MsgDoc mkBadConMsg tycon datacon = vcat [ text "In a case alternative, data constructor isn't in scrutinee type:", @@ -1150,7 +1150,7 @@ mkBadConMsg tycon datacon text "Data con:" <+> ppr datacon ] -mkBadPatMsg :: Type -> Type -> Message +mkBadPatMsg :: Type -> Type -> MsgDoc mkBadPatMsg con_result_ty scrut_ty = vcat [ text "In a case alternative, pattern result type doesn't match scrutinee type:", @@ -1158,17 +1158,17 @@ mkBadPatMsg con_result_ty scrut_ty text "Scrutinee type:" <+> ppr scrut_ty ] -integerScrutinisedMsg :: Message +integerScrutinisedMsg :: MsgDoc integerScrutinisedMsg = text "In a LitAlt, the literal is lifted (probably Integer)" -mkBadAltMsg :: Type -> CoreAlt -> Message +mkBadAltMsg :: Type -> CoreAlt -> MsgDoc mkBadAltMsg scrut_ty alt = vcat [ text "Data alternative when scrutinee is not a tycon application", text "Scrutinee type:" <+> ppr scrut_ty, text "Alternative:" <+> pprCoreAlt alt ] -mkNewTyDataConAltMsg :: Type -> CoreAlt -> Message +mkNewTyDataConAltMsg :: Type -> CoreAlt -> MsgDoc mkNewTyDataConAltMsg scrut_ty alt = vcat [ text "Data alternative for newtype datacon", text "Scrutinee type:" <+> ppr scrut_ty, @@ -1178,21 +1178,21 @@ mkNewTyDataConAltMsg scrut_ty alt ------------------------------------------------------ -- Other error messages -mkAppMsg :: Type -> Type -> CoreExpr -> Message +mkAppMsg :: Type -> Type -> CoreExpr -> MsgDoc mkAppMsg fun_ty arg_ty arg = vcat [ptext (sLit "Argument value doesn't match argument type:"), hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty), hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty), hang (ptext (sLit "Arg:")) 4 (ppr arg)] -mkNonFunAppMsg :: Type -> Type -> CoreExpr -> Message +mkNonFunAppMsg :: Type -> Type -> CoreExpr -> MsgDoc mkNonFunAppMsg fun_ty arg_ty arg = vcat [ptext (sLit "Non-function type in function position"), hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty), hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty), hang (ptext (sLit "Arg:")) 4 (ppr arg)] -mkLetErr :: TyVar -> CoreExpr -> Message +mkLetErr :: TyVar -> CoreExpr -> MsgDoc mkLetErr bndr rhs = vcat [ptext (sLit "Bad `let' binding:"), hang (ptext (sLit "Variable:")) @@ -1200,7 +1200,7 @@ mkLetErr bndr rhs hang (ptext (sLit "Rhs:")) 4 (ppr rhs)] -mkTyCoAppErrMsg :: TyVar -> Coercion -> Message +mkTyCoAppErrMsg :: TyVar -> Coercion -> MsgDoc mkTyCoAppErrMsg tyvar arg_co = vcat [ptext (sLit "Kinds don't match in lifted coercion application:"), hang (ptext (sLit "Type variable:")) @@ -1208,7 +1208,7 @@ mkTyCoAppErrMsg tyvar arg_co hang (ptext (sLit "Arg coercion:")) 4 (ppr arg_co <+> dcolon <+> pprEqPred (coercionKind arg_co))] -mkTyAppMsg :: Type -> Type -> Message +mkTyAppMsg :: Type -> Type -> MsgDoc mkTyAppMsg ty arg_ty = vcat [text "Illegal type application:", hang (ptext (sLit "Exp type:")) @@ -1216,7 +1216,7 @@ mkTyAppMsg ty arg_ty hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] -mkRhsMsg :: Id -> Type -> Message +mkRhsMsg :: Id -> Type -> MsgDoc mkRhsMsg binder ty = vcat [hsep [ptext (sLit "The type of this binder doesn't match the type of its RHS:"), @@ -1224,14 +1224,14 @@ mkRhsMsg binder ty hsep [ptext (sLit "Binder's type:"), ppr (idType binder)], hsep [ptext (sLit "Rhs type:"), ppr ty]] -mkRhsPrimMsg :: Id -> CoreExpr -> Message +mkRhsPrimMsg :: Id -> CoreExpr -> MsgDoc mkRhsPrimMsg binder _rhs = vcat [hsep [ptext (sLit "The type of this binder is primitive:"), ppr binder], hsep [ptext (sLit "Binder's type:"), ppr (idType binder)] ] -mkStrictMsg :: Id -> Message +mkStrictMsg :: Id -> MsgDoc mkStrictMsg binder = vcat [hsep [ptext (sLit "Recursive or top-level binder has strict demand info:"), ppr binder], @@ -1239,7 +1239,7 @@ mkStrictMsg binder ] -mkKindErrMsg :: TyVar -> Type -> Message +mkKindErrMsg :: TyVar -> Type -> MsgDoc mkKindErrMsg tyvar arg_ty = vcat [ptext (sLit "Kinds don't match in type application:"), hang (ptext (sLit "Type variable:")) @@ -1247,7 +1247,7 @@ mkKindErrMsg tyvar arg_ty hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] -mkArityMsg :: Id -> Message +mkArityMsg :: Id -> MsgDoc mkArityMsg binder = vcat [hsep [ptext (sLit "Demand type has "), ppr (dmdTypeDepth dmd_ty), @@ -1260,24 +1260,24 @@ mkArityMsg binder ] where (StrictSig dmd_ty) = idStrictness binder -mkUnboxedTupleMsg :: Id -> Message +mkUnboxedTupleMsg :: Id -> MsgDoc mkUnboxedTupleMsg binder = vcat [hsep [ptext (sLit "A variable has unboxed tuple type:"), ppr binder], hsep [ptext (sLit "Binder's type:"), ppr (idType binder)]] -mkCastErr :: Type -> Type -> Message +mkCastErr :: Type -> Type -> MsgDoc mkCastErr from_ty expr_ty = vcat [ptext (sLit "From-type of Cast differs from type of enclosed expression"), ptext (sLit "From-type:") <+> ppr from_ty, ptext (sLit "Type of enclosed expr:") <+> ppr expr_ty ] -dupVars :: [[Var]] -> Message +dupVars :: [[Var]] -> MsgDoc dupVars vars = hang (ptext (sLit "Duplicate variables brought into scope")) 2 (ppr vars) -dupExtVars :: [[Name]] -> Message +dupExtVars :: [[Name]] -> MsgDoc dupExtVars vars = hang (ptext (sLit "Duplicate top-level variables with the same qualified name")) 2 (ppr vars) @@ -1310,7 +1310,7 @@ lintSplitCoVar cv Nothing -> failWithL (sep [ ptext (sLit "Coercion variable with non-equality kind:") , nest 2 (ppr cv <+> dcolon <+> ppr (tyVarKind cv))]) -mkCoVarLetErr :: CoVar -> Coercion -> Message +mkCoVarLetErr :: CoVar -> Coercion -> MsgDoc mkCoVarLetErr covar co = vcat [ptext (sLit "Bad `let' binding for coercion variable:"), hang (ptext (sLit "Coercion variable:")) @@ -1318,7 +1318,7 @@ mkCoVarLetErr covar co hang (ptext (sLit "Arg coercion:")) 4 (ppr co)] -mkCoAppErrMsg :: CoVar -> Coercion -> Message +mkCoAppErrMsg :: CoVar -> Coercion -> MsgDoc mkCoAppErrMsg covar arg_co = vcat [ptext (sLit "Kinds don't match in coercion application:"), hang (ptext (sLit "Coercion variable:")) @@ -1327,7 +1327,7 @@ mkCoAppErrMsg covar arg_co 4 (ppr arg_co <+> dcolon <+> pprEqPred (coercionKind arg_co))] -mkCoAppMsg :: Type -> Coercion -> Message +mkCoAppMsg :: Type -> Coercion -> MsgDoc mkCoAppMsg ty arg_co = vcat [text "Illegal type application:", hang (ptext (sLit "exp type:")) diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 7cc58583dd..8e8278783e 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -32,6 +32,7 @@ import DsUtils import HsSyn -- lots of things import CoreSyn -- lots of things +import Literal ( Literal(MachStr) ) import CoreSubst import MkCore import CoreUtils @@ -40,6 +41,7 @@ import CoreUnfold import CoreFVs import Digraph + import TyCon ( isTupleTyCon, tyConDataCons_maybe ) import TcEvidence import TcType @@ -705,7 +707,10 @@ dsEvTerm (EvSuperClass d n) = Var sc_sel_id `mkTyApps` tys `App` Var d where sc_sel_id = classSCSelId cls n -- Zero-indexed - (cls, tys) = getClassPredTys (evVarPred d) + (cls, tys) = getClassPredTys (evVarPred d) +dsEvTerm (EvDelayedError ty msg) = Var errorId `mkTyApps` [ty] `mkApps` [litMsg] + where errorId = rUNTIME_ERROR_ID + litMsg = Lit (MachStr msg) --------------------------------------- dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> CoreExpr diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index bf05fdffe2..551165a3ad 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -226,7 +226,7 @@ initDs hsc_env mod rdr_env type_env thing_inside where loadOneModule :: ModuleName -- the module to load -> DsM Bool -- under which condition - -> Message -- error message if module not found + -> MsgDoc -- error message if module not found -> DsM GlobalRdrEnv -- empty if condition 'False' loadOneModule modname check err = do { doLoad <- check @@ -370,8 +370,7 @@ putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) warnDs :: SDoc -> DsM () warnDs warn = do { env <- getGblEnv ; loc <- getSrcSpanDs - ; let msg = mkWarnMsg loc (ds_unqual env) - (ptext (sLit "Warning:") <+> warn) + ; let msg = mkWarnMsg loc (ds_unqual env) warn ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) } failWithDs :: SDoc -> DsM a diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 3e9ab43579..f4ad61757f 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -443,8 +443,8 @@ linkExpr hsc_env span root_ul_bco -- All wired-in names are in the base package, which we link -- by default, so we can safely ignore them here. -dieWith :: SrcSpan -> Message -> IO a -dieWith span msg = ghcError (ProgramError (showSDoc (mkLocMessage span msg))) +dieWith :: SrcSpan -> MsgDoc -> IO a +dieWith span msg = ghcError (ProgramError (showSDoc (mkLocMessage SevFatal span msg))) checkNonStdWay :: DynFlags -> SrcSpan -> IO Bool diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index f294a1b8c5..4292a112ff 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -48,25 +48,25 @@ import GHC.Exts ------------------------------------------------------------------- -- The external interface -convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName] +convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl RdrName] convertToHsDecls loc ds = initCvt loc (mapM cvt_dec ds) where cvt_dec d = wrapMsg "declaration" d (cvtDec d) -convertToHsExpr :: SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName) +convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr RdrName) convertToHsExpr loc e = initCvt loc $ wrapMsg "expression" e $ cvtl e -convertToPat :: SrcSpan -> TH.Pat -> Either Message (LPat RdrName) +convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat RdrName) convertToPat loc p = initCvt loc $ wrapMsg "pattern" p $ cvtPat p -convertToHsType :: SrcSpan -> TH.Type -> Either Message (LHsType RdrName) +convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType RdrName) convertToHsType loc t = initCvt loc $ wrapMsg "type" t $ cvtType t ------------------------------------------------------------------- -newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either Message a } +newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc a } -- Push down the source location; -- Can fail, with a single error message @@ -85,13 +85,13 @@ instance Monad CvtM where Left err -> Left err Right v -> unCvtM (k v) loc -initCvt :: SrcSpan -> CvtM a -> Either Message a +initCvt :: SrcSpan -> CvtM a -> Either MsgDoc a initCvt loc (CvtM m) = m loc force :: a -> CvtM () force a = a `seq` return () -failWith :: Message -> CvtM a +failWith :: MsgDoc -> CvtM a failWith m = CvtM (\_ -> Left m) getL :: CvtM SrcSpan @@ -232,7 +232,7 @@ cvtDec (TySynInstD tc tys rhs) ; returnL $ TyClD (TySynonym tc' tvs' tys' rhs') } ---------------- -cvt_ci_decs :: Message -> [TH.Dec] +cvt_ci_decs :: MsgDoc -> [TH.Dec] -> CvtM (LHsBinds RdrName, [LSig RdrName], [LTyClDecl RdrName]) @@ -304,7 +304,7 @@ is_bind :: LHsDecl RdrName -> Either (LHsBind RdrName) (LHsDecl RdrName) is_bind (L loc (Hs.ValD bind)) = Left (L loc bind) is_bind decl = Right decl -mkBadDecMsg :: Message -> [LHsDecl RdrName] -> Message +mkBadDecMsg :: MsgDoc -> [LHsDecl RdrName] -> MsgDoc mkBadDecMsg doc bads = sep [ ptext (sLit "Illegal declaration(s) in") <+> doc <> colon , nest 2 (vcat (map Outputable.ppr bads)) ] @@ -437,7 +437,7 @@ cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation)) -- Declarations --------------------------------------------------- -cvtLocalDecs :: Message -> [TH.Dec] -> CvtM (HsLocalBinds RdrName) +cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds RdrName) cvtLocalDecs doc ds | null ds = return EmptyLocalBinds diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index ec1205f83d..37379b5be4 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -167,7 +167,7 @@ loadInterfaceWithException doc mod_name where_from ------------------ loadInterface :: SDoc -> Module -> WhereFrom - -> IfM lcl (MaybeErr Message ModIface) + -> IfM lcl (MaybeErr MsgDoc ModIface) -- loadInterface looks in both the HPT and PIT for the required interface -- If not found, it loads it, and puts it in the PIT (always). @@ -294,7 +294,7 @@ loadInterface doc_str mod from }}}} wantHiBootFile :: DynFlags -> ExternalPackageState -> Module -> WhereFrom - -> MaybeErr Message IsBootInterface + -> MaybeErr MsgDoc IsBootInterface -- Figure out whether we want Foo.hi or Foo.hi-boot wantHiBootFile dflags eps mod from = case from of @@ -472,7 +472,7 @@ bumpDeclStats name findAndReadIface :: SDoc -> Module -> IsBootInterface -- True <=> Look for a .hi-boot file -- False <=> Look for .hi file - -> TcRnIf gbl lcl (MaybeErr Message (ModIface, FilePath)) + -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath)) -- Nothing <=> file not found, or unreadable, or illegible -- Just x <=> successfully found and parsed @@ -537,7 +537,7 @@ findAndReadIface doc_str mod hi_boot_file \begin{code} readIface :: Module -> FilePath -> IsBootInterface - -> TcRnIf gbl lcl (MaybeErr Message ModIface) + -> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface) -- Failed err <=> file not found, or unreadable, or illegible -- Succeeded iface <=> successfully found and parsed @@ -794,7 +794,7 @@ badIfaceFile file err = vcat [ptext (sLit "Bad interface file:") <+> text file, nest 4 err] -hiModuleNameMismatchWarn :: Module -> Module -> Message +hiModuleNameMismatchWarn :: Module -> Module -> MsgDoc hiModuleNameMismatchWarn requested_mod read_mod = withPprStyle defaultUserStyle $ -- we want the Modules below to be qualified with package names, diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 4e8c96b962..35b4c91f2a 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -844,7 +844,7 @@ oldMD5 dflags bh = do instOrphWarn :: PrintUnqualified -> ClsInst -> WarnMsg instOrphWarn unqual inst = mkWarnMsg (getSrcSpan inst) unqual $ - hang (ptext (sLit "Warning: orphan instance:")) 2 (pprInstanceHdr inst) + hang (ptext (sLit "Orphan instance:")) 2 (pprInstanceHdr inst) ruleOrphWarn :: PrintUnqualified -> Module -> IfaceRule -> WarnMsg ruleOrphWarn unqual mod rule diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 570a6315cc..5894607f28 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -125,7 +125,7 @@ tcImportDecl name Succeeded thing -> return thing Failed err -> failWithTc err } -importDecl :: Name -> IfM lcl (MaybeErr Message TyThing) +importDecl :: Name -> IfM lcl (MaybeErr MsgDoc TyThing) -- Get the TyThing for this Name from an interface file -- It's not a wired-in thing -- the caller caught that importDecl name diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs index c0301dc29b..148e11f65b 100644 --- a/compiler/main/CmdLineParser.hs +++ b/compiler/main/CmdLineParser.hs @@ -80,8 +80,7 @@ addErr :: Monad m => String -> EwM m () addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` L loc e, ws, ())) addWarn :: Monad m => String -> EwM m () -addWarn msg = EwM (\(L loc _) es ws -> return (es, ws `snocBag` L loc w, ())) - where w = "Warning: " ++ msg +addWarn msg = EwM (\(L loc _) es ws -> return (es, ws `snocBag` L loc msg, ())) deprecate :: Monad m => String -> EwM m () deprecate s = do diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 1bd4fcef8a..48830e1b99 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -113,7 +113,7 @@ import Outputable #ifdef GHCI import Foreign.C ( CInt(..) ) #endif -import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage ) +import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessage ) #ifdef GHCI import System.IO.Unsafe ( unsafePerformIO ) @@ -288,6 +288,7 @@ data DynFlag | Opt_GhciSandbox | Opt_GhciHistory | Opt_HelpfulErrors + | Opt_DeferTypeErrors -- temporary flags | Opt_RunCPS @@ -578,7 +579,7 @@ data DynFlags = DynFlags { -- flattenExtensionFlags language extensions extensionFlags :: IntSet, - -- | Message output action: use "ErrUtils" instead of this if you can + -- | MsgDoc output action: use "ErrUtils" instead of this if you can log_action :: LogAction, haddockOptions :: Maybe String, @@ -921,7 +922,7 @@ defaultDynFlags mySettings = profAuto = NoProfAuto } -type LogAction = Severity -> SrcSpan -> PprStyle -> Message -> IO () +type LogAction = Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO () defaultLogAction :: LogAction defaultLogAction severity srcSpan style msg @@ -930,7 +931,7 @@ defaultLogAction severity srcSpan style msg SevInfo -> printErrs msg style SevFatal -> printErrs msg style _ -> do hPutChar stderr '\n' - printErrs (mkLocMessage srcSpan msg) style + printErrs (mkLocMessage severity srcSpan msg) style -- careful (#2302): printErrs prints in UTF-8, whereas -- converting to string first and using hPutStr would -- just emit the low 8 bits of each unicode char. @@ -1326,7 +1327,7 @@ safeFlagCheck cmdl dflags = False | not cmdl && safeInferOn dflags && packageTrustOn dflags -> (dopt_unset dflags' Opt_PackageTrust, [L (pkgTrustOnLoc dflags') $ - "Warning: -fpackage-trust ignored;" ++ + "-fpackage-trust ignored;" ++ " must be specified with a Safe Haskell flag"] ) @@ -1349,8 +1350,8 @@ safeFlagCheck cmdl dflags = apFix f = if safeInferOn dflags then id else f - safeFailure loc str = [L loc $ "Warning: " ++ str ++ " is not allowed in" - ++ " Safe Haskell; ignoring " ++ str] + safeFailure loc str + = [L loc $ str ++ " is not allowed in Safe Haskell; ignoring " ++ str] bad_flags = [("-XGeneralizedNewtypeDeriving", newDerivOnLoc dflags, xopt Opt_GeneralizedNewtypeDeriving, @@ -1829,6 +1830,7 @@ fFlags = [ ( "ghci-sandbox", Opt_GhciSandbox, nop ), ( "ghci-history", Opt_GhciHistory, nop ), ( "helpful-errors", Opt_HelpfulErrors, nop ), + ( "defer-type-errors", Opt_DeferTypeErrors, nop ), ( "building-cabal-package", Opt_BuildingCabalPackage, nop ), ( "implicit-import-qualified", Opt_ImplicitImportQualified, nop ), ( "prof-count-entries", Opt_ProfCountEntries, nop ), diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index 1cce4ec633..6ba9df436c 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -6,15 +6,15 @@ \begin{code} module ErrUtils ( - Message, mkLocMessage, printError, pprMessageBag, pprErrMsgBag, - Severity(..), - - ErrMsg, WarnMsg, - ErrorMessages, WarningMessages, + ErrMsg, WarnMsg, Severity(..), + Messages, ErrorMessages, WarningMessages, errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo, - Messages, errorsFound, emptyMessages, + MsgDoc, mkLocMessage, printError, pprMessageBag, pprErrMsgBag, + pprLocErrMsg, makeIntoWarning, + + errorsFound, emptyMessages, mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg, - printBagOfErrors, printBagOfWarnings, + printBagOfErrors, warnIsErrorMsg, mkLongWarnMsg, ghcExit, @@ -36,6 +36,7 @@ module ErrUtils ( import Bag ( Bag, bagToList, isEmptyBag, emptyBag ) import Util import Outputable +import FastString import SrcLoc import DynFlags import StaticFlags ( opt_ErrorSpans ) @@ -51,10 +52,21 @@ import System.IO -- ----------------------------------------------------------------------------- -- Basic error messages: just render a message with a source location. -type Message = SDoc +type Messages = (WarningMessages, ErrorMessages) +type WarningMessages = Bag WarnMsg +type ErrorMessages = Bag ErrMsg -pprMessageBag :: Bag Message -> SDoc -pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) +data ErrMsg = ErrMsg { + errMsgSpans :: [SrcSpan], + errMsgContext :: PrintUnqualified, + errMsgShortDoc :: MsgDoc, + errMsgExtraInfo :: MsgDoc, + errMsgSeverity :: Severity + } + -- The SrcSpan is used for sorting errors into line-number order + +type WarnMsg = ErrMsg +type MsgDoc = SDoc data Severity = SevOutput @@ -63,70 +75,56 @@ data Severity | SevError | SevFatal -mkLocMessage :: SrcSpan -> Message -> Message -mkLocMessage locn msg - | opt_ErrorSpans = hang (ppr locn <> colon) 4 msg - | otherwise = hang (ppr (srcSpanStart locn) <> colon) 4 msg - -- always print the location, even if it is unhelpful. Error messages +instance Show ErrMsg where + show em = showSDoc (errMsgShortDoc em) + +pprMessageBag :: Bag MsgDoc -> SDoc +pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) + +mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc + -- Always print the location, even if it is unhelpful. Error messages -- are supposed to be in a standard format, and one without a location -- would look strange. Better to say explicitly "<no location info>". +mkLocMessage severity locn msg + | opt_ErrorSpans = hang (ppr locn <> colon <+> sev_info) 4 msg + | otherwise = hang (ppr (srcSpanStart locn) <> colon <+> sev_info) 4 msg + where + sev_info = case severity of + SevWarning -> ptext (sLit "Warning:") + _other -> empty + -- For warnings, print Foo.hs:34: Warning: + -- <the warning message> -printError :: SrcSpan -> Message -> IO () -printError span msg = - printErrs (mkLocMessage span msg) defaultErrStyle +printError :: SrcSpan -> MsgDoc -> IO () +printError span msg = printErrs (mkLocMessage SevError span msg) defaultErrStyle +makeIntoWarning :: ErrMsg -> ErrMsg +makeIntoWarning err = err { errMsgSeverity = SevWarning } -- ----------------------------------------------------------------------------- -- Collecting up messages for later ordering and printing. -data ErrMsg = ErrMsg { - errMsgSpans :: [SrcSpan], - errMsgContext :: PrintUnqualified, - errMsgShortDoc :: Message, - errMsgExtraInfo :: Message - } - -- The SrcSpan is used for sorting errors into line-number order - -instance Show ErrMsg where - show em = showSDoc (errMsgShortDoc em) - -type WarnMsg = ErrMsg - --- A short (one-line) error message, with context to tell us whether --- to qualify names in the message or not. -mkErrMsg :: SrcSpan -> PrintUnqualified -> Message -> ErrMsg -mkErrMsg locn print_unqual msg - = ErrMsg { errMsgSpans = [locn], errMsgContext = print_unqual - , errMsgShortDoc = msg, errMsgExtraInfo = empty } - --- Variant that doesn't care about qualified/unqualified names -mkPlainErrMsg :: SrcSpan -> Message -> ErrMsg -mkPlainErrMsg locn msg - = ErrMsg { errMsgSpans = [locn], errMsgContext = alwaysQualify - , errMsgShortDoc = msg, errMsgExtraInfo = empty } - --- A long (multi-line) error message, with context to tell us whether --- to qualify names in the message or not. -mkLongErrMsg :: SrcSpan -> PrintUnqualified -> Message -> Message -> ErrMsg -mkLongErrMsg locn print_unqual msg extra +mk_err_msg :: Severity -> SrcSpan -> PrintUnqualified -> MsgDoc -> SDoc -> ErrMsg +mk_err_msg sev locn print_unqual msg extra = ErrMsg { errMsgSpans = [locn], errMsgContext = print_unqual - , errMsgShortDoc = msg, errMsgExtraInfo = extra } - -mkWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> WarnMsg -mkWarnMsg = mkErrMsg - -mkLongWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> Message -> ErrMsg -mkLongWarnMsg = mkLongErrMsg - + , errMsgShortDoc = msg, errMsgExtraInfo = extra + , errMsgSeverity = sev } + +mkLongErrMsg, mkLongWarnMsg :: SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg +-- A long (multi-line) error message +mkErrMsg, mkWarnMsg :: SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg +-- A short (one-line) error message +mkPlainErrMsg, mkPlainWarnMsg :: SrcSpan -> MsgDoc -> ErrMsg -- Variant that doesn't care about qualified/unqualified names -mkPlainWarnMsg :: SrcSpan -> Message -> ErrMsg -mkPlainWarnMsg locn msg = mkWarnMsg locn alwaysQualify msg -type Messages = (Bag WarnMsg, Bag ErrMsg) - -type WarningMessages = Bag WarnMsg -type ErrorMessages = Bag ErrMsg +mkLongErrMsg locn unqual msg extra = mk_err_msg SevError locn unqual msg extra +mkErrMsg locn unqual msg = mk_err_msg SevError locn unqual msg empty +mkPlainErrMsg locn msg = mk_err_msg SevError locn alwaysQualify msg empty +mkLongWarnMsg locn unqual msg extra = mk_err_msg SevWarning locn unqual msg extra +mkWarnMsg locn unqual msg = mk_err_msg SevWarning locn unqual msg empty +mkPlainWarnMsg locn msg = mk_err_msg SevWarning locn alwaysQualify msg empty +---------------- emptyMessages :: Messages emptyMessages = (emptyBag, emptyBag) @@ -137,12 +135,8 @@ errorsFound :: DynFlags -> Messages -> Bool errorsFound _dflags (_warns, errs) = not (isEmptyBag errs) printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO () -printBagOfErrors dflags bag_of_errors = - printMsgBag dflags bag_of_errors SevError - -printBagOfWarnings :: DynFlags -> Bag WarnMsg -> IO () -printBagOfWarnings dflags bag_of_warns = - printMsgBag dflags bag_of_warns SevWarning +printBagOfErrors dflags bag_of_errors + = printMsgBag dflags bag_of_errors pprErrMsgBag :: Bag ErrMsg -> [SDoc] pprErrMsgBag bag @@ -152,12 +146,23 @@ pprErrMsgBag bag errMsgExtraInfo = e, errMsgContext = unqual } <- sortMsgBag bag ] -printMsgBag :: DynFlags -> Bag ErrMsg -> Severity -> IO () -printMsgBag dflags bag sev +pprLocErrMsg :: ErrMsg -> SDoc +pprLocErrMsg (ErrMsg { errMsgSpans = spans + , errMsgShortDoc = d + , errMsgExtraInfo = e + , errMsgSeverity = sev + , errMsgContext = unqual }) + = withPprStyle (mkErrStyle unqual) (mkLocMessage sev s (d $$ e)) + where + (s : _) = spans -- Should be non-empty + +printMsgBag :: DynFlags -> Bag ErrMsg -> IO () +printMsgBag dflags bag = sequence_ [ let style = mkErrStyle unqual in log_action dflags sev s style (d $$ e) | ErrMsg { errMsgSpans = s:_, errMsgShortDoc = d, + errMsgSeverity = sev, errMsgExtraInfo = e, errMsgContext = unqual } <- sortMsgBag bag ] @@ -293,22 +298,22 @@ ifVerbose dflags val act | verbosity dflags >= val = act | otherwise = return () -putMsg :: DynFlags -> Message -> IO () +putMsg :: DynFlags -> MsgDoc -> IO () putMsg dflags msg = log_action dflags SevInfo noSrcSpan defaultUserStyle msg -putMsgWith :: DynFlags -> PrintUnqualified -> Message -> IO () +putMsgWith :: DynFlags -> PrintUnqualified -> MsgDoc -> IO () putMsgWith dflags print_unqual msg = log_action dflags SevInfo noSrcSpan sty msg where sty = mkUserStyle print_unqual AllTheWay -errorMsg :: DynFlags -> Message -> IO () +errorMsg :: DynFlags -> MsgDoc -> IO () errorMsg dflags msg = log_action dflags SevError noSrcSpan defaultErrStyle msg -fatalErrorMsg :: DynFlags -> Message -> IO () +fatalErrorMsg :: DynFlags -> MsgDoc -> IO () fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) msg -fatalErrorMsg' :: LogAction -> Message -> IO () +fatalErrorMsg' :: LogAction -> MsgDoc -> IO () fatalErrorMsg' la msg = la SevFatal noSrcSpan defaultErrStyle msg compilationProgressMsg :: DynFlags -> String -> IO () @@ -319,7 +324,7 @@ showPass :: DynFlags -> String -> IO () showPass dflags what = ifVerbose dflags 2 (log_action dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon)) -debugTraceMsg :: DynFlags -> Int -> Message -> IO () +debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO () debugTraceMsg dflags val msg = ifVerbose dflags val (log_action dflags SevInfo noSrcSpan defaultDumpStyle msg) \end{code} diff --git a/compiler/main/ErrUtils.lhs-boot b/compiler/main/ErrUtils.lhs-boot index 08115a4b48..7718cbe2a6 100644 --- a/compiler/main/ErrUtils.lhs-boot +++ b/compiler/main/ErrUtils.lhs-boot @@ -11,8 +11,8 @@ data Severity | SevError | SevFatal -type Message = SDoc +type MsgDoc = SDoc -mkLocMessage :: SrcSpan -> Message -> Message +mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc \end{code} diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index 9fad73a9f8..6322024c9e 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -123,7 +123,7 @@ mkPrelImports this_mod loc implicit_prelude import_decls ideclAs = Nothing, ideclHiding = Nothing } -parseError :: SrcSpan -> Message -> IO a +parseError :: SrcSpan -> MsgDoc -> IO a parseError span err = throwOneError $ mkPlainErrMsg span err -------------------------------------------------------------- diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 8c9e9a8f00..fc53d9d544 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -266,7 +266,7 @@ throwErrors = liftIO . throwIO . mkSrcErr -- failed, it must have been due to the warnings (i.e., @-Werror@). ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a ioMsgMaybe ioA = do - ((warns,errs), mb_r) <- liftIO $ ioA + ((warns,errs), mb_r) <- liftIO ioA logWarnings warns case mb_r of Nothing -> throwErrors errs @@ -844,8 +844,7 @@ hscFileFrontEnd mod_summary = do return tcg_env' where pprMod t = ppr $ moduleName $ tcg_mod t - errSafe t = text "Warning:" <+> quotes (pprMod t) - <+> text "has been infered as safe!" + errSafe t = quotes (pprMod t) <+> text "has been infered as safe!" -------------------------------------------------------------- -- Safe Haskell @@ -1120,8 +1119,7 @@ wipeTrust tcg_env whyUnsafe = do where wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = [] } pprMod = ppr $ moduleName $ tcg_mod tcg_env - whyUnsafe' = vcat [ text "Warning:" <+> quotes pprMod - <+> text "has been infered as unsafe!" + whyUnsafe' = vcat [ quotes pprMod <+> text "has been infered as unsafe!" , text "Reason:" , nest 4 (vcat $ pprErrMsgBag whyUnsafe) ] diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 3eda19fba1..b6bf938332 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -238,12 +238,12 @@ printOrThrowWarnings dflags warns = when (not (isEmptyBag warns)) $ do throwIO $ mkSrcErr $ warns `snocBag` warnIsErrorMsg | otherwise - = printBagOfWarnings dflags warns + = printBagOfErrors dflags warns handleFlagWarnings :: DynFlags -> [Located String] -> IO () handleFlagWarnings dflags warns = when (wopt Opt_WarnDeprecatedFlags dflags) $ do - -- It would be nicer if warns :: [Located Message], but that + -- It would be nicer if warns :: [Located MsgDoc], but that -- has circular import problems. let bag = listToBag [ mkPlainWarnMsg loc (text warn) | L loc warn <- warns ] diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index d7dc6bc764..d1fbe2f253 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -59,7 +59,7 @@ import Distribution.InstalledPackageInfo import Distribution.InstalledPackageInfo.Binary import Distribution.Package hiding (PackageId,depends) import FastString -import ErrUtils ( debugTraceMsg, putMsg, Message ) +import ErrUtils ( debugTraceMsg, putMsg, MsgDoc ) import Exception import System.Directory @@ -986,7 +986,7 @@ closeDeps :: PackageConfigMap -> IO [PackageId] closeDeps pkg_map ipid_map ps = throwErr (closeDepsErr pkg_map ipid_map ps) -throwErr :: MaybeErr Message a -> IO a +throwErr :: MaybeErr MsgDoc a -> IO a throwErr m = case m of Failed e -> ghcError (CmdLineError (showSDoc e)) Succeeded r -> return r @@ -994,7 +994,7 @@ throwErr m = case m of closeDepsErr :: PackageConfigMap -> Map InstalledPackageId PackageId -> [(PackageId,Maybe PackageId)] - -> MaybeErr Message [PackageId] + -> MaybeErr MsgDoc [PackageId] closeDepsErr pkg_map ipid_map ps = foldM (add_package pkg_map ipid_map) [] ps -- internal helper @@ -1002,7 +1002,7 @@ add_package :: PackageConfigMap -> Map InstalledPackageId PackageId -> [PackageId] -> (PackageId,Maybe PackageId) - -> MaybeErr Message [PackageId] + -> MaybeErr MsgDoc [PackageId] add_package pkg_db ipid_map ps (p, mb_parent) | p `elem` ps = return ps -- Check if we've already added this package | otherwise = diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 21984eced9..e0e97fed4a 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -145,7 +145,7 @@ haskell :- -- everywhere: skip whitespace and comments $white_no_nl+ ; -$tab+ { warn Opt_WarnTabs (text "Warning: Tab character") } +$tab+ { warn Opt_WarnTabs (text "Tab character") } -- Everywhere: deal with nested comments. We explicitly rule out -- pragmas, "{-#", so that we don't accidentally treat them as comments. @@ -1484,7 +1484,7 @@ data ParseResult a SrcSpan -- The start and end of the text span related to -- the error. Might be used in environments which can -- show this span, e.g. by highlighting it. - Message -- The error message + MsgDoc -- The error message data PState = PState { buffer :: StringBuffer, @@ -1959,7 +1959,7 @@ getOffside = P $ \s@PState{last_loc=loc, context=stk} -> srcParseErr :: StringBuffer -- current buffer (placed just after the last token) -> Int -- length of the previous token - -> Message + -> MsgDoc srcParseErr buf len = hcat [ if null token then ptext (sLit "parse error (possibly incorrect indentation)") diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index ccce0c9caf..a4bf1f2d69 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -63,7 +63,7 @@ import Module ( ModuleName, moduleName ) import UniqFM import DataCon ( dataConFieldLabels ) import PrelNames ( mkUnboundName, rOOT_MAIN, forall_tv_RDR ) -import ErrUtils ( Message ) +import ErrUtils ( MsgDoc ) import SrcLoc import Outputable import Util @@ -672,7 +672,7 @@ lookupSigOccRn ctxt sig lookupBindGroupOcc :: HsSigCtxt -> SDoc - -> RdrName -> RnM (Either Message Name) + -> RdrName -> RnM (Either MsgDoc Name) -- Looks up the RdrName, expecting it to resolve to one of the -- bound names passed in. If not, return an appropriate error message -- diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index a09509754e..1f9041e473 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -725,9 +725,9 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) -- data constructors of an associated family, we need separate -- AvailInfos for the data constructors and the family (as they have -- different parents). See the discussion at occ_env. - lookup_ie :: Bool -> IE RdrName -> MaybeErr Message [(IE Name,AvailInfo)] + lookup_ie :: Bool -> IE RdrName -> MaybeErr MsgDoc [(IE Name,AvailInfo)] lookup_ie opt_typeFamilies ie - = let bad_ie :: MaybeErr Message a + = let bad_ie :: MaybeErr MsgDoc a bad_ie = Failed (badImportItemErr iface decl_spec ie all_avails) lookup_name rdr @@ -1680,7 +1680,7 @@ typeItemErr name wherestr ptext (sLit "Use -XTypeFamilies to enable this extension") ] exportClashErr :: GlobalRdrEnv -> Name -> Name -> IE RdrName -> IE RdrName - -> Message + -> MsgDoc exportClashErr global_env name1 name2 ie1 ie2 = vcat [ ptext (sLit "Conflicting exports for") <+> quotes (ppr occ) <> colon , ppr_export ie1' name1' diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index c82a5577c6..829c2ca40f 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -184,7 +184,7 @@ lintPassResult dflags pass binds ; displayLintResults dflags pass warns errs binds } displayLintResults :: DynFlags -> CoreToDo - -> Bag Err.Message -> Bag Err.Message -> CoreProgram + -> Bag Err.MsgDoc -> Bag Err.MsgDoc -> CoreProgram -> IO () displayLintResults dflags pass warns errs binds | not (isEmptyBag errs) diff --git a/compiler/stgSyn/StgLint.lhs b/compiler/stgSyn/StgLint.lhs index d54294f4f3..ea1fab7eea 100644 --- a/compiler/stgSyn/StgLint.lhs +++ b/compiler/stgSyn/StgLint.lhs @@ -24,7 +24,7 @@ import PrimOp ( primOpType ) import Literal ( literalType ) import Maybes import Name ( getSrcLoc ) -import ErrUtils ( Message, mkLocMessage ) +import ErrUtils ( MsgDoc, Severity(..), mkLocMessage ) import TypeRep import Type import TyCon @@ -288,8 +288,8 @@ lintAlt scrut_ty (DataAlt con, args, _, rhs) = do newtype LintM a = LintM { unLintM :: [LintLocInfo] -- Locations -> IdSet -- Local vars in scope - -> Bag Message -- Error messages so far - -> (a, Bag Message) -- Result and error messages (if any) + -> Bag MsgDoc -- Error messages so far + -> (a, Bag MsgDoc) -- Result and error messages (if any) } data LintLocInfo @@ -316,7 +316,7 @@ pp_binders bs \end{code} \begin{code} -initL :: LintM a -> Maybe Message +initL :: LintM a -> Maybe MsgDoc initL (LintM m) = case (m [] emptyVarSet emptyBag) of { (_, errs) -> if isEmptyBag errs then @@ -342,19 +342,19 @@ thenL_ m k = LintM $ \loc scope errs \end{code} \begin{code} -checkL :: Bool -> Message -> LintM () +checkL :: Bool -> MsgDoc -> LintM () checkL True _ = return () checkL False msg = addErrL msg -addErrL :: Message -> LintM () +addErrL :: MsgDoc -> LintM () addErrL msg = LintM $ \loc _scope errs -> ((), addErr errs msg loc) -addErr :: Bag Message -> Message -> [LintLocInfo] -> Bag Message +addErr :: Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc addErr errs_so_far msg locs = errs_so_far `snocBag` mk_msg locs where mk_msg (loc:_) = let (l,hdr) = dumpLoc loc - in mkLocMessage l (hdr $$ msg) + in mkLocMessage SevWarning l (hdr $$ msg) mk_msg [] = msg addLoc :: LintLocInfo -> LintM a -> LintM a @@ -387,7 +387,7 @@ have long since disappeared. \begin{code} checkFunApp :: Type -- The function type -> [Type] -- The arg type(s) - -> Message -- Error message + -> MsgDoc -- Error message -> LintM (Maybe Type) -- Just ty => result type is accurate checkFunApp fun_ty arg_tys msg @@ -399,7 +399,7 @@ checkFunApp fun_ty arg_tys msg (mb_ty, mb_msg) = cfa True fun_ty arg_tys cfa :: Bool -> Type -> [Type] -> (Maybe Type -- Accurate result? - , Maybe Message) -- Errors? + , Maybe MsgDoc) -- Errors? cfa accurate fun_ty [] -- Args have run out; that's fine = (if accurate then Just fun_ty else Nothing, Nothing) @@ -468,7 +468,7 @@ checkInScope id = LintM $ \loc scope errs else ((), errs) -checkTys :: Type -> Type -> Message -> LintM () +checkTys :: Type -> Type -> MsgDoc -> LintM () checkTys ty1 ty2 msg = LintM $ \loc _scope errs -> if (ty1 `stgEqType` ty2) then ((), errs) @@ -476,35 +476,35 @@ checkTys ty1 ty2 msg = LintM $ \loc _scope errs \end{code} \begin{code} -_mkCaseAltMsg :: [StgAlt] -> Message +_mkCaseAltMsg :: [StgAlt] -> MsgDoc _mkCaseAltMsg _alts = ($$) (text "In some case alternatives, type of alternatives not all same:") (empty) -- LATER: ppr alts -mkDefltMsg :: Id -> TyCon -> Message +mkDefltMsg :: Id -> TyCon -> MsgDoc mkDefltMsg bndr tc = ($$) (ptext (sLit "Binder of a case expression doesn't match type of scrutinee:")) (ppr bndr $$ ppr (idType bndr) $$ ppr tc) -mkFunAppMsg :: Type -> [Type] -> StgExpr -> Message +mkFunAppMsg :: Type -> [Type] -> StgExpr -> MsgDoc mkFunAppMsg fun_ty arg_tys expr = vcat [text "In a function application, function type doesn't match arg types:", hang (ptext (sLit "Function type:")) 4 (ppr fun_ty), hang (ptext (sLit "Arg types:")) 4 (vcat (map (ppr) arg_tys)), hang (ptext (sLit "Expression:")) 4 (ppr expr)] -mkRhsConMsg :: Type -> [Type] -> Message +mkRhsConMsg :: Type -> [Type] -> MsgDoc mkRhsConMsg fun_ty arg_tys = vcat [text "In a RHS constructor application, con type doesn't match arg types:", hang (ptext (sLit "Constructor type:")) 4 (ppr fun_ty), hang (ptext (sLit "Arg types:")) 4 (vcat (map (ppr) arg_tys))] -mkAltMsg1 :: Type -> Message +mkAltMsg1 :: Type -> MsgDoc mkAltMsg1 ty = ($$) (text "In a case expression, type of scrutinee does not match patterns") (ppr ty) -mkAlgAltMsg2 :: Type -> DataCon -> Message +mkAlgAltMsg2 :: Type -> DataCon -> MsgDoc mkAlgAltMsg2 ty con = vcat [ text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:", @@ -512,7 +512,7 @@ mkAlgAltMsg2 ty con ppr con ] -mkAlgAltMsg3 :: DataCon -> [Id] -> Message +mkAlgAltMsg3 :: DataCon -> [Id] -> MsgDoc mkAlgAltMsg3 con alts = vcat [ text "In some algebraic case alternative, number of arguments doesn't match constructor:", @@ -520,7 +520,7 @@ mkAlgAltMsg3 con alts ppr alts ] -mkAlgAltMsg4 :: Type -> Id -> Message +mkAlgAltMsg4 :: Type -> Id -> MsgDoc mkAlgAltMsg4 ty arg = vcat [ text "In some algebraic case alternative, type of argument doesn't match data constructor:", @@ -528,7 +528,7 @@ mkAlgAltMsg4 ty arg ppr arg ] -_mkRhsMsg :: Id -> Type -> Message +_mkRhsMsg :: Id -> Type -> MsgDoc _mkRhsMsg binder ty = vcat [hsep [ptext (sLit "The type of this binder doesn't match the type of its RHS:"), ppr binder], diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 09ea2dfab4..b589c265db 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -27,14 +27,12 @@ module Inst ( -- Simple functions over evidence variables hasEqualities, unitImplication, - tyVarsOfWC, tyVarsOfBag, tyVarsOfEvVarXs, tyVarsOfEvVarX, + tyVarsOfWC, tyVarsOfBag, tyVarsOfEvVar, tyVarsOfEvVars, tyVarsOfImplication, tyVarsOfCt, tyVarsOfCts, tyVarsOfCDict, tyVarsOfCDicts, - tidyWantedEvVar, tidyWantedEvVars, tidyWC, - tidyEvVar, tidyImplication, tidyCt, + tidyEvVar, tidyCt, tidyGivenLoc, - substWantedEvVar, substWantedEvVars, substEvVar, substImplication, substCt ) where @@ -87,7 +85,7 @@ emitWanteds origin theta = mapM (emitWanted origin) theta emitWanted :: CtOrigin -> TcPredType -> TcM EvVar emitWanted origin pred = do { loc <- getCtLoc origin ; ev <- newWantedEvVar pred - ; emitFlat (mkEvVarX ev loc) + ; emitFlat (mkNonCanonical ev (Wanted loc)) ; return ev } newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId) @@ -550,13 +548,7 @@ tyVarsOfWC (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol }) tyVarsOfImplication :: Implication -> TyVarSet tyVarsOfImplication (Implic { ic_skols = skols, ic_wanted = wanted }) - = tyVarsOfWC wanted `minusVarSet` skols - -tyVarsOfEvVarX :: EvVarX a -> TyVarSet -tyVarsOfEvVarX (EvVarX ev _) = tyVarsOfEvVar ev - -tyVarsOfEvVarXs :: Bag (EvVarX a) -> TyVarSet -tyVarsOfEvVarXs = tyVarsOfBag tyVarsOfEvVarX + = tyVarsOfWC wanted `delVarSetList` skols tyVarsOfEvVar :: EvVar -> TyVarSet tyVarsOfEvVar ev = tyVarsOfType $ evVarPred ev @@ -576,34 +568,9 @@ tidyCt env ct , cc_flavor = tidyFlavor env (cc_flavor ct) , cc_depth = cc_depth ct } -tidyWC :: TidyEnv -> WantedConstraints -> WantedConstraints -tidyWC env (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol }) - = WC { wc_flat = mapBag (tidyCt env) flat - , wc_impl = mapBag (tidyImplication env) implic - , wc_insol = mapBag (tidyCt env) insol } - -tidyImplication :: TidyEnv -> Implication -> Implication -tidyImplication env implic@(Implic { ic_skols = tvs - , ic_given = given - , ic_wanted = wanted - , ic_loc = loc }) - = implic { ic_skols = mkVarSet tvs' - , ic_given = map (tidyEvVar env1) given - , ic_wanted = tidyWC env1 wanted - , ic_loc = tidyGivenLoc env1 loc } - where - (env1, tvs') = mapAccumL tidyTyVarBndr env (varSetElems tvs) - tidyEvVar :: TidyEnv -> EvVar -> EvVar tidyEvVar env var = setVarType var (tidyType env (varType var)) -tidyWantedEvVar :: TidyEnv -> WantedEvVar -> WantedEvVar -tidyWantedEvVar env (EvVarX v l) = EvVarX (tidyEvVar env v) l - -tidyWantedEvVars :: TidyEnv -> Bag WantedEvVar -> Bag WantedEvVar -tidyWantedEvVars env = mapBag (tidyWantedEvVar env) - - tidyFlavor :: TidyEnv -> CtFlavor -> CtFlavor tidyFlavor env (Given loc gk) = Given (tidyGivenLoc env loc) gk tidyFlavor _ fl = fl @@ -614,6 +581,14 @@ tidyGivenLoc env (CtLoc skol span ctxt) = CtLoc (tidySkolemInfo env skol) span c tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo tidySkolemInfo env (SigSkol cx ty) = SigSkol cx (tidyType env ty) tidySkolemInfo env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids) +tidySkolemInfo env (UnifyForAllSkol skol_tvs ty) + = UnifyForAllSkol (map tidy_tv skol_tvs) (tidyType env ty) + where + tidy_tv tv = case getTyVar_maybe ty' of + Just tv' -> tv' + Nothing -> pprPanic "ticySkolemInfo" (ppr tv <+> ppr ty') + where + ty' = tidyTyVarOcc env tv tidySkolemInfo _ info = info ---------------- Substitution ------------------------- @@ -641,23 +616,16 @@ substImplication subst implic@(Implic { ic_skols = tvs , ic_given = given , ic_wanted = wanted , ic_loc = loc }) - = implic { ic_skols = mkVarSet tvs' + = implic { ic_skols = tvs' , ic_given = map (substEvVar subst1) given , ic_wanted = substWC subst1 wanted , ic_loc = substGivenLoc subst1 loc } where - (subst1, tvs') = mapAccumL substTyVarBndr subst (varSetElems tvs) + (subst1, tvs') = mapAccumL substTyVarBndr subst tvs substEvVar :: TvSubst -> EvVar -> EvVar substEvVar subst var = setVarType var (substTy subst (varType var)) -substWantedEvVars :: TvSubst -> Bag WantedEvVar -> Bag WantedEvVar -substWantedEvVars subst = mapBag (substWantedEvVar subst) - -substWantedEvVar :: TvSubst -> WantedEvVar -> WantedEvVar -substWantedEvVar subst (EvVarX v l) = EvVarX (substEvVar subst v) l - - substFlavor :: TvSubst -> CtFlavor -> CtFlavor substFlavor subst (Given loc gk) = Given (substGivenLoc subst loc) gk substFlavor _ fl = fl diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index ac826b7507..7d20aaa946 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -130,7 +130,7 @@ tcHsBootSigs (ValBindsOut binds sigs) tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s) tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups) -badBootDeclErr :: Message +badBootDeclErr :: MsgDoc badBootDeclErr = ptext (sLit "Illegal declarations in an hs-boot file") ------------------------ @@ -739,7 +739,7 @@ tcVect (HsVectInstOut _) vectCtxt :: Outputable thing => thing -> SDoc vectCtxt thing = ptext (sLit "When checking the vectorisation declaration for") <+> ppr thing -scalarTyConMustBeNullary :: Message +scalarTyConMustBeNullary :: MsgDoc scalarTyConMustBeNullary = ptext (sLit "VECTORISE SCALAR type constructor must be nullary") -------------- diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index dce91b1f02..426fbe7a68 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -736,7 +736,7 @@ flatten d ctxt ty@(ForAllTy {}) -- We allow for-alls when, but only when, no type function -- applications inside the forall involve the bound type variables. = do { let (tvs, rho) = splitForAllTys ty - ; when (under_families tvs rho) $ flattenForAllErrorTcS ctxt ty + ; when (under_families tvs rho) $ wrapErrTcS $ flattenForAllErrorTcS ctxt ty ; (rho', co) <- flatten d ctxt rho ; return (mkForAllTys tvs rho', foldr mkTcForAllCo co tvs) } @@ -818,26 +818,6 @@ canEq _d fl eqv ty1 ty2 do { _ <- setEqBind eqv (mkTcReflCo ty1) fl; return () } ; return Stop } --- Split up an equality between function types into two equalities. -canEq d fl eqv (FunTy s1 t1) (FunTy s2 t2) - = do { argeqv <- newEqVar fl s1 s2 - ; reseqv <- newEqVar fl t1 t2 - ; let argeqv_v = evc_the_evvar argeqv - reseqv_v = evc_the_evvar reseqv - ; (fl1,fl2) <- case fl of - Wanted {} -> - do { _ <- setEqBind eqv (mkTcFunCo (mkTcCoVarCo argeqv_v) (mkTcCoVarCo reseqv_v)) fl - ; return (fl,fl) } - Given {} -> - do { fl1 <- setEqBind argeqv_v (mkTcNthCo 0 (mkTcCoVarCo eqv)) fl - ; fl2 <- setEqBind reseqv_v (mkTcNthCo 1 (mkTcCoVarCo eqv)) fl - ; return (fl1,fl2) - } - Derived {} -> - return (fl,fl) - - ; canEqEvVarsCreated d [fl2,fl1] [reseqv,argeqv] [t1,s1] [t2,s2] } - -- If one side is a variable, orient and flatten, -- WITHOUT expanding type synonyms, so that we tend to -- substitute a ~ Age rather than a ~ Int when @type Age = Int@ @@ -846,6 +826,11 @@ canEq d fl eqv ty1@(TyVarTy {}) ty2 canEq d fl eqv ty1 ty2@(TyVarTy {}) = canEqLeaf d fl eqv ty1 ty2 +-- See Note [Naked given applications] +canEq d fl eqv ty1 ty2 + | Just ty1' <- tcView ty1 = canEq d fl eqv ty1' ty2 + | Just ty2' <- tcView ty2 = canEq d fl eqv ty1 ty2' + canEq d fl eqv ty1@(TyConApp fn tys) ty2 | isSynFamilyTyCon fn, length tys == tyConArity fn = canEqLeaf d fl eqv ty1 ty2 @@ -853,14 +838,18 @@ canEq d fl eqv ty1 ty2@(TyConApp fn tys) | isSynFamilyTyCon fn, length tys == tyConArity fn = canEqLeaf d fl eqv ty1 ty2 -canEq d fl eqv (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | isDecomposableTyCon tc1 && isDecomposableTyCon tc2 - , tc1 == tc2 - , length tys1 == length tys2 +canEq d fl eqv ty1 ty2 + | Just (tc1,tys1) <- tcSplitTyConApp_maybe ty1 + , Just (tc2,tys2) <- tcSplitTyConApp_maybe ty2 + , isDecomposableTyCon tc1 && isDecomposableTyCon tc2 = -- Generate equalities for each of the corresponding arguments - do { let (kis1, tys1') = span isKind tys1 + if (tc1 /= tc2 || length tys1 /= length tys2) + -- Fail straight away for better error messages + then canEqFailure d fl eqv + else do { + let (kis1, tys1') = span isKind tys1 (_kis2, tys2') = span isKind tys2 - ; let kicos = map mkTcReflCo kis1 + kicos = map mkTcReflCo kis1 ; argeqvs <- zipWithM (newEqVar fl) tys1' tys2' ; fls <- case fl of @@ -878,16 +867,32 @@ canEq d fl eqv (TyConApp tc1 tys1) (TyConApp tc2 tys2) -- See Note [Equality between type applications] -- Note [Care with type applications] in TcUnify -canEq d fl eqv ty1 ty2 - | Nothing <- tcView ty1 -- Naked applications ONLY - , Nothing <- tcView ty2 -- See Note [Naked given applications] - , Just (s1,t1) <- tcSplitAppTy_maybe ty1 +canEq d fl eqv ty1 ty2 -- e.g. F a b ~ Maybe c + -- where F has arity 1 + | Just (s1,t1) <- tcSplitAppTy_maybe ty1 , Just (s2,t2) <- tcSplitAppTy_maybe ty2 + = canEqAppTy d fl eqv s1 t1 s2 t2 + +canEq d fl eqv s1@(ForAllTy {}) s2@(ForAllTy {}) + | tcIsForAllTy s1, tcIsForAllTy s2, + Wanted {} <- fl + = canEqFailure d fl eqv + | otherwise + = do { traceTcS "Ommitting decomposition of given polytype equality" (pprEq s1 s2) + ; return Stop } + +canEq d fl eqv _ _ = canEqFailure d fl eqv + +-- Type application +canEqAppTy :: SubGoalDepth + -> CtFlavor -> EqVar -> Type -> Type -> Type -> Type + -> TcS StopOrContinue +canEqAppTy d fl eqv s1 t1 s2 t2 = ASSERT( not (isKind t1) && not (isKind t2) ) if isGivenOrSolved fl then - do { traceTcS "canEq/(app case)" $ + do { traceTcS "canEq (app case)" $ text "Ommitting decomposition of given equality between: " - <+> ppr ty1 <+> text "and" <+> ppr ty2 + <+> ppr (AppTy s1 t1) <+> text "and" <+> ppr (AppTy s2 t2) -- We cannot decompose given applications -- because we no longer have 'left' and 'right' ; return Stop } @@ -903,25 +908,30 @@ canEq d fl eqv ty1 ty2 ; canEqEvVarsCreated d [fl,fl] [evc1,evc2] [s1,t1] [s2,t2] } - -canEq d fl eqv s1@(ForAllTy {}) s2@(ForAllTy {}) - | tcIsForAllTy s1, tcIsForAllTy s2, - Wanted {} <- fl - = canEqFailure d fl eqv - | otherwise - = do { traceTcS "Ommitting decomposition of given polytype equality" (pprEq s1 s2) - ; return Stop } - --- Finally expand any type synonym applications. -canEq d fl eqv ty1 ty2 | Just ty1' <- tcView ty1 = canEq d fl eqv ty1' ty2 -canEq d fl eqv ty1 ty2 | Just ty2' <- tcView ty2 = canEq d fl eqv ty1 ty2' -canEq d fl eqv _ _ = canEqFailure d fl eqv - canEqFailure :: SubGoalDepth -> CtFlavor -> EvVar -> TcS StopOrContinue -canEqFailure d fl eqv = do { emitFrozenError fl eqv d; return Stop } +canEqFailure d fl eqv + = do { when (isWanted fl) (delCachedEvVar eqv fl) + -- See Note [Combining insoluble constraints] + ; emitFrozenError fl eqv d + ; return Stop } \end{code} +Note [Combining insoluble constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As this point we have an insoluble constraint, like Int~Bool. + + * If it is Wanted, delete it from the cache, so that subsequent + Int~Bool constraints give rise to separate error messages + + * But if it is Derived, DO NOT delete from cache. A class constraint + may get kicked out of the inert set, and then have its functional + dependency Derived constraints generated a second time. In that + case we don't want to get two (or more) error messages by + generating two (or more) insoluble fundep constraints from the same + class constraint. + + Note [Naked given applications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider: diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index ba77be5f4d..dda82fff99 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -1516,25 +1516,25 @@ genDerivStuff loc fix_env clas name tycon %************************************************************************ \begin{code} -derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Message +derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> MsgDoc derivingKindErr tc cls cls_tys cls_kind = hang (ptext (sLit "Cannot derive well-kinded instance of form") <+> quotes (pprClassPred cls cls_tys <+> parens (ppr tc <+> ptext (sLit "...")))) 2 (ptext (sLit "Class") <+> quotes (ppr cls) <+> ptext (sLit "expects an argument of kind") <+> quotes (pprKind cls_kind)) -derivingEtaErr :: Class -> [Type] -> Type -> Message +derivingEtaErr :: Class -> [Type] -> Type -> MsgDoc derivingEtaErr cls cls_tys inst_ty = sep [ptext (sLit "Cannot eta-reduce to an instance of form"), nest 2 (ptext (sLit "instance (...) =>") <+> pprClassPred cls (cls_tys ++ [inst_ty]))] -typeFamilyPapErr :: TyCon -> Class -> [Type] -> Type -> Message +typeFamilyPapErr :: TyCon -> Class -> [Type] -> Type -> MsgDoc typeFamilyPapErr tc cls cls_tys inst_ty = hang (ptext (sLit "Derived instance") <+> quotes (pprClassPred cls (cls_tys ++ [inst_ty]))) 2 (ptext (sLit "requires illegal partial application of data type family") <+> ppr tc) -derivingThingErr :: Bool -> Class -> [Type] -> Type -> Message -> Message +derivingThingErr :: Bool -> Class -> [Type] -> Type -> MsgDoc -> MsgDoc derivingThingErr newtype_deriving clas tys ty why = sep [(hang (ptext (sLit "Can't make a derived instance of")) 2 (quotes (ppr pred)) @@ -1554,7 +1554,7 @@ standaloneCtxt :: LHsType Name -> SDoc standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for")) 2 (quotes (ppr ty)) -derivInstCtxt :: PredType -> Message +derivInstCtxt :: PredType -> MsgDoc derivInstCtxt pred = ptext (sLit "When deriving the instance for") <+> parens (ppr pred) \end{code} diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index 8e86afc5dd..be9830819d 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -1,4 +1,5 @@ \begin{code} +{-# LANGUAGE ScopedTypeVariables #-} {-# 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 @@ -7,9 +8,10 @@ -- for details module TcErrors( - reportUnsolved, + reportUnsolved, ErrEnv, warnDefaulting, unifyCtxt, + misMatchMsg, flattenForAllErrorTcS, solverDepthErrorTcS @@ -19,33 +21,31 @@ module TcErrors( import TcRnMonad import TcMType -import TcSMonad import TcType import TypeRep import Type import Kind ( isKind ) -import Class -import Unify ( tcMatchTys ) +import Unify ( tcMatchTys ) import Inst import InstEnv import TyCon +import TcEvidence import Name import NameEnv -import Id ( idType ) +import Id ( idType ) import Var import VarSet import VarEnv -import SrcLoc import Bag -import BasicTypes ( IPName ) -import ListSetOps( equivClasses ) -import Maybes( mapCatMaybes ) +import Maybes +import ErrUtils ( ErrMsg, makeIntoWarning, pprLocErrMsg ) import Util import FastString import Outputable import DynFlags -import Data.List( partition ) -import Control.Monad( when, unless, filterM ) +import Data.List ( partition, mapAccumL ) +import Data.Either ( partitionEithers ) +-- import Control.Monad ( when ) \end{code} %************************************************************************ @@ -59,26 +59,40 @@ from the insts, or just whatever seems to be around in the monad just now? \begin{code} -reportUnsolved :: WantedConstraints -> TcM () -reportUnsolved wanted +-- We keep an environment mapping coercion ids to the error messages they +-- trigger; this is handy for -fwarn--type-errors +type ErrEnv = VarEnv [ErrMsg] + +reportUnsolved :: Bool -> WantedConstraints -> TcM (Bag EvBind) +reportUnsolved runtimeCoercionErrors wanted | isEmptyWC wanted - = return () + = return emptyBag | otherwise = do { -- Zonk to un-flatten any flatten-skols - ; wanted <- zonkWC wanted + wanted <- zonkWC wanted ; env0 <- tcInitTidyEnv + ; defer <- if runtimeCoercionErrors + then do { ev <- newTcEvBinds + ; return (Just ev) } + else return Nothing + + ; errs_so_far <- ifErrsM (return True) (return False) ; let tidy_env = tidyFreeTyVars env0 free_tvs free_tvs = tyVarsOfWC wanted err_ctxt = CEC { cec_encl = [] - , cec_insol = insolubleWC wanted + , cec_insol = errs_so_far , cec_extra = empty - , cec_tidy = tidy_env } - tidy_wanted = tidyWC tidy_env wanted + , cec_tidy = tidy_env + , cec_defer = defer } + + ; traceTc "reportUnsolved" (ppr free_tvs $$ ppr wanted) - ; traceTc "reportUnsolved" (ppr tidy_wanted) + ; reportWanteds err_ctxt wanted - ; reportTidyWanteds err_ctxt tidy_wanted } + ; case defer of + Nothing -> return emptyBag + Just ev -> getTcEvBinds ev } -------------------------------------------- -- Internal functions @@ -87,175 +101,265 @@ reportUnsolved wanted data ReportErrCtxt = CEC { cec_encl :: [Implication] -- Enclosing implications -- (innermost first) + -- ic_skols and givens are tidied, rest are not , cec_tidy :: TidyEnv , cec_extra :: SDoc -- Add this to each error message - , cec_insol :: Bool -- True <=> we are reporting insoluble errors only - -- Main effect: don't say "Cannot deduce..." - -- when reporting equality errors; see misMatchOrCND + , cec_insol :: Bool -- True <=> do not report errors involving + -- ambiguous errors + , cec_defer :: Maybe EvBindsVar + -- Nothinng <=> errors are, well, errors + -- Just ev <=> make errors into warnings, and emit evidence + -- bindings into 'ev' for unsolved constraints } -reportTidyImplic :: ReportErrCtxt -> Implication -> TcM () -reportTidyImplic ctxt implic - | BracketSkol <- ctLocOrigin (ic_loc implic) - , not insoluble -- For Template Haskell brackets report only - = return () -- definite errors. The whole thing will be re-checked - -- later when we plug it in, and meanwhile there may - -- certainly be un-satisfied constraints +reportImplic :: ReportErrCtxt -> Implication -> TcM () +reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given + , ic_wanted = wanted, ic_binds = evb + , ic_insol = insoluble, ic_loc = loc }) + | BracketSkol <- ctLocOrigin loc + , not insoluble -- For Template Haskell brackets report only + = return () -- definite errors. The whole thing will be re-checked + -- later when we plug it in, and meanwhile there may + -- certainly be un-satisfied constraints | otherwise - = reportTidyWanteds ctxt' (ic_wanted implic) + = reportWanteds ctxt' wanted where - insoluble = ic_insol implic - ctxt' = ctxt { cec_encl = implic : cec_encl ctxt - , cec_insol = insoluble } - -reportTidyWanteds :: ReportErrCtxt -> WantedConstraints -> TcM () -reportTidyWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics }) - | cec_insol ctxt -- If there are any insolubles, report only them - -- because they are unconditionally wrong - -- Moreover, if any of the insolubles are givens, stop right there - -- ignoring nested errors, because the code is inaccessible - = do { let (given, other) = partitionBag (isGivenOrSolved . cc_flavor) insols - insol_implics = filterBag ic_insol implics - ; if isEmptyBag given - then do { mapBagM_ (reportInsoluble ctxt) other - ; mapBagM_ (reportTidyImplic ctxt) insol_implics } - else mapBagM_ (reportInsoluble ctxt) given } - - | otherwise -- No insoluble ones - = ASSERT( isEmptyBag insols ) - do { let flat_evs = bagToList $ mapBag to_wev flats - to_wev ct | Wanted wl <- cc_flavor ct = mkEvVarX (cc_id ct) wl - | otherwise = panic "reportTidyWanteds: unsolved is not wanted!" - (ambigs, non_ambigs) = partition is_ambiguous flat_evs - (tv_eqs, others) = partitionWith is_tv_eq non_ambigs - - ; groupErrs (reportEqErrs ctxt) tv_eqs - ; when (null tv_eqs) $ groupErrs (reportFlat ctxt) others - ; mapBagM_ (reportTidyImplic ctxt) implics - - -- Only report ambiguity if no other errors (at all) happened - -- See Note [Avoiding spurious errors] in TcSimplify - ; ifErrsM (return ()) $ reportAmbigErrs ctxt ambigs } + (env1, tvs') = mapAccumL tidyTyVarBndr (cec_tidy ctxt) tvs + implic' = implic { ic_skols = tvs' + , ic_given = map (tidyEvVar env1) given + , ic_loc = tidyGivenLoc env1 loc } + ctxt' = ctxt { cec_tidy = env1 + , cec_encl = implic' : cec_encl ctxt + , cec_defer = case cec_defer ctxt of + Nothing -> Nothing + Just {} -> Just evb } + +reportWanteds :: ReportErrCtxt -> WantedConstraints -> TcM () +reportWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics }) + = reportTidyWanteds ctxt tidy_insols tidy_flats implics where - -- Report equalities of form (a~ty) first. They are usually - -- skolem-equalities, and they cause confusing knock-on - -- effects in other errors; see test T4093b. - is_tv_eq c | Just (ty1, ty2) <- getEqPredTys_maybe (evVarOfPred c) - , tcIsTyVarTy ty1 || tcIsTyVarTy ty2 - = Left (c, (ty1, ty2)) - | otherwise - = Right (c, evVarOfPred c) - - -- Treat it as "ambiguous" if - -- (a) it is a class constraint - -- (b) it constrains only type variables - -- (else we'd prefer to report it as "no instance for...") - -- (c) it mentions a (presumably un-filled-in) meta type variable - is_ambiguous d = isTyVarClassPred pred - && any isAmbiguousTyVar (varSetElems (tyVarsOfType pred)) - where - pred = evVarOfPred d - -reportInsoluble :: ReportErrCtxt -> Ct -> TcM () --- Precondition: insolubles are always NonCanonicals! -reportInsoluble ctxt ct - | ev <- cc_id ct - , flav <- cc_flavor ct - , Just (ty1, ty2) <- getEqPredTys_maybe (evVarPred ev) - = setCtFlavorLoc flav $ - do { let ctxt2 = ctxt { cec_extra = cec_extra ctxt $$ inaccessible_msg } - ; reportEqErr ctxt2 ty1 ty2 } + env = cec_tidy ctxt + tidy_insols = mapBag (tidyCt env) insols + tidy_flats = mapBag (tidyCt env) flats + +reportTidyWanteds :: ReportErrCtxt -> Bag Ct -> Bag Ct -> Bag Implication -> TcM () +reportTidyWanteds ctxt insols flats implics + | Just ev_binds_var <- cec_defer ctxt + = do { -- Defer errors to runtime + -- See Note [Deferring coercion errors to runtime] in TcSimplify + mapBagM_ (deferToRuntime ev_binds_var ctxt mkFlatErr) + (flats `unionBags` insols) + ; mapBagM_ (reportImplic ctxt) implics } + | otherwise - = pprPanic "reportInsoluble" (pprEvVarWithType (cc_id ct)) + = do { reportInsolsAndFlats ctxt insols flats + ; mapBagM_ (reportImplic ctxt) implics } + + +deferToRuntime :: EvBindsVar -> ReportErrCtxt -> (ReportErrCtxt -> Ct -> TcM ErrMsg) + -> Ct -> TcM () +deferToRuntime ev_binds_var ctxt mk_err_msg ct + | Wanted loc <- cc_flavor ct + = do { err <- setCtLoc loc $ + mk_err_msg ctxt ct + ; let ev_id = cc_id ct + err_msg = pprLocErrMsg err + err_fs = mkFastString $ showSDoc $ + err_msg $$ text "(deferred type error)" + + -- Create the binding + ; addTcEvBind ev_binds_var ev_id (EvDelayedError (idType ev_id) err_fs) + + -- And emit a warning + ; reportWarning (makeIntoWarning err) } + + | otherwise -- Do not set any evidence for Given/Derived + = return () + +reportInsolsAndFlats :: ReportErrCtxt -> Cts -> Cts -> TcM () +reportInsolsAndFlats ctxt insols flats + = tryReporters + [ -- First deal with things that are utterly wrong + -- Like Int ~ Bool (incl nullary TyCons) + -- or Int ~ t a (AppTy on one side) + ("Utterly wrong", utterly_wrong, groupErrs (mkEqErr ctxt)) + + -- Report equalities of form (a~ty). They are usually + -- skolem-equalities, and they cause confusing knock-on + -- effects in other errors; see test T4093b. + , ("Skolem equalities", skolem_eq, mkReporter (mkEqErr1 ctxt)) + + , ("Unambiguous", unambiguous, reportFlatErrs ctxt) ] + (reportAmbigErrs ctxt) + (bagToList (insols `unionBags` flats)) + where + utterly_wrong, skolem_eq, unambiguous :: Ct -> PredTree -> Bool + + utterly_wrong _ (EqPred ty1 ty2) = isRigid ty1 && isRigid ty2 + utterly_wrong _ _ = False + + skolem_eq _ (EqPred ty1 ty2) = isRigidOrSkol ty1 && isRigidOrSkol ty2 + skolem_eq _ _ = False + + unambiguous ct pred + | not (any isAmbiguousTyVar (varSetElems (tyVarsOfCt ct))) + = True + | otherwise + = case pred of + EqPred ty1 ty2 -> isNothing (isTyFun_maybe ty1) && isNothing (isTyFun_maybe ty2) + _ -> False + +--------------- +isRigid, isRigidOrSkol :: Type -> Bool +isRigid ty + | Just (tc,_) <- tcSplitTyConApp_maybe ty = isDecomposableTyCon tc + | Just {} <- tcSplitAppTy_maybe ty = True + | isForAllTy ty = True + | otherwise = False + +isRigidOrSkol ty + | Just tv <- getTyVar_maybe ty = isSkolemTyVar tv + | otherwise = isRigid ty + +isTyFun_maybe :: Type -> Maybe TyCon +isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of + Just (tc,_) | isSynFamilyTyCon tc -> Just tc + _ -> Nothing + +----------------- +type Reporter = [Ct] -> TcM () + +mkReporter :: (Ct -> TcM ErrMsg) -> [Ct] -> TcM () +-- Reports errors one at a time +mkReporter mk_err = mapM_ (\ct -> do { err <- setCtFlavorLoc (cc_flavor ct) $ + mk_err ct; + ; reportError err }) + +tryReporters :: [(String, Ct -> PredTree -> Bool, Reporter)] -> Reporter -> Reporter +tryReporters reporters deflt cts + = do { traceTc "tryReporters {" (ppr cts) + ; go reporters cts + ; traceTc "tryReporters }" empty } where - inaccessible_msg | Given loc GivenOrig <- (cc_flavor ct) - -- If a GivenSolved then we should not report inaccessible code - = hang (ptext (sLit "Inaccessible code in")) - 2 (ppr (ctLocOrigin loc)) - | otherwise = empty - -reportFlat :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM () --- The [PredType] are already tidied -reportFlat ctxt flats origin - = do { unless (null dicts) $ reportDictErrs ctxt dicts origin - ; unless (null eqs) $ reportEqErrs ctxt eqs origin - ; unless (null ips) $ reportIPErrs ctxt ips origin - ; unless (null irreds) $ reportIrredsErrs ctxt irreds origin } + go [] cts = deflt cts + go ((str, pred, reporter) : rs) cts + | null yeses = traceTc "tryReporters: no" (text str) >> + go rs cts + | otherwise = traceTc "tryReporters: yes" (text str <+> ppr yeses) >> + reporter yeses + where + yeses = filter keep_me cts + keep_me ct = pred ct (classifyPredType (ctPred ct)) + +----------------- +mkFlatErr :: ReportErrCtxt -> Ct -> TcM ErrMsg +-- Context is already set +mkFlatErr ctxt ct -- The constraint is always wanted + = case classifyPredType (ctPred ct) of + ClassPred {} -> mkDictErr ctxt [ct] + IPPred {} -> mkIPErr ctxt [ct] + IrredPred {} -> mkIrredErr ctxt [ct] + EqPred {} -> mkEqErr1 ctxt ct + TuplePred {} -> panic "mkFlat" + +reportAmbigErrs :: ReportErrCtxt -> Reporter +reportAmbigErrs ctxt cts + | cec_insol ctxt = return () + | otherwise = reportFlatErrs ctxt cts + -- Only report ambiguity if no other errors (at all) happened + -- See Note [Avoiding spurious errors] in TcSimplify + +reportFlatErrs :: ReportErrCtxt -> Reporter +-- Called once for non-ambigs, once for ambigs +-- Report equality errors, and others only if we've done all +-- the equalities. The equality errors are more basic, and +-- can lead to knock on type-class errors +reportFlatErrs ctxt cts + = tryReporters + [ ("Equalities", is_equality, groupErrs (mkEqErr ctxt)) ] + (\cts -> do { let (dicts, ips, irreds) = go cts [] [] [] + ; groupErrs (mkIPErr ctxt) ips + ; groupErrs (mkIrredErr ctxt) irreds + ; groupErrs (mkDictErr ctxt) dicts }) + cts where - (dicts, eqs, ips, irreds) = go_many (map classifyPredType flats) - - go_many [] = ([], [], [], []) - go_many (t:ts) = (as ++ as', bs ++ bs', cs ++ cs', ds ++ ds') - where (as, bs, cs, ds) = go t - (as', bs', cs', ds') = go_many ts - - go (ClassPred cls tys) = ([(cls, tys)], [], [], []) - go (EqPred ty1 ty2) = ([], [(ty1, ty2)], [], []) - go (IPPred ip ty) = ([], [], [(ip, ty)], []) - go (IrredPred ty) = ([], [], [], [ty]) - go (TuplePred {}) = panic "reportFlat" + is_equality _ (EqPred {}) = True + is_equality _ _ = False + + go [] dicts ips irreds + = (dicts, ips, irreds) + go (ct:cts) dicts ips irreds + = case classifyPredType (ctPred ct) of + ClassPred {} -> go cts (ct:dicts) ips irreds + IPPred {} -> go cts dicts (ct:ips) irreds + IrredPred {} -> go cts dicts ips (ct:irreds) + _ -> panic "mkFlat" -- TuplePreds should have been expanded away by the constraint -- simplifier, so they shouldn't show up at this point + -- And EqPreds are dealt with by the is_equality test + -------------------------------------------- -- Support code -------------------------------------------- -groupErrs :: ([a] -> CtOrigin -> TcM ()) -- Deal with one group - -> [(WantedEvVar, a)] -- Unsolved wanteds +groupErrs :: ([Ct] -> TcM ErrMsg) -- Deal with one group + -> [Ct] -- Unsolved wanteds -> TcM () --- Group together insts with the same origin +-- Group together insts from same location -- We want to report them together in error messages groupErrs _ [] = return () -groupErrs report_err ((wanted, x) : wanteds) - = do { setCtLoc the_loc $ - report_err the_xs (ctLocOrigin the_loc) - ; groupErrs report_err others } +groupErrs mk_err (ct1 : rest) + = do { err <- setCtFlavorLoc flavor $ mk_err cts + ; reportError err + ; groupErrs mk_err others } where - the_loc = evVarX wanted - the_key = mk_key the_loc - the_xs = x:map snd friends - (friends, others) = partition (is_friend . fst) wanteds - is_friend friend = mk_key (evVarX friend) `same_key` the_key + flavor = cc_flavor ct1 + cts = ct1 : friends + (friends, others) = partition is_friend rest + is_friend friend = cc_flavor friend `same_group` flavor - mk_key :: WantedLoc -> (SrcSpan, CtOrigin) - mk_key loc = (ctLocSpan loc, ctLocOrigin loc) - - same_key (s1, o1) (s2, o2) = s1==s2 && o1 `same_orig` o2 - same_orig (OccurrenceOf n1) (OccurrenceOf n2) = n1==n2 - same_orig ScOrigin ScOrigin = True - same_orig DerivOrigin DerivOrigin = True - same_orig DefaultOrigin DefaultOrigin = True - same_orig _ _ = False + same_group :: CtFlavor -> CtFlavor -> Bool + same_group (Given l1 _) (Given l2 _) = same_loc l1 l2 + same_group (Derived l1) (Derived l2) = same_loc l1 l2 + same_group (Wanted l1) (Wanted l2) = same_loc l1 l2 + same_group _ _ = False + same_loc :: CtLoc o -> CtLoc o -> Bool + same_loc (CtLoc _ s1 _) (CtLoc _ s2 _) = s1==s2 -- Add the "arising from..." part to a message about bunch of dicts addArising :: CtOrigin -> SDoc -> SDoc addArising orig msg = msg $$ nest 2 (pprArising orig) -pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc) +pprWithArising :: [Ct] -> (WantedLoc, SDoc) -- Print something like -- (Eq a) arising from a use of x at y -- (Show a) arising from a use of p at q -- Also return a location for the error message +-- Works for Wanted/Derived only pprWithArising [] = panic "pprWithArising" -pprWithArising [EvVarX ev loc] - = (loc, hang (pprEvVarTheta [ev]) 2 (pprArising (ctLocOrigin loc))) -pprWithArising ev_vars - = (first_loc, vcat (map ppr_one ev_vars)) +pprWithArising (ct:cts) + | null cts + = (loc, hang (pprEvVarTheta [cc_id ct]) + 2 (pprArising (ctLocOrigin (ctWantedLoc ct)))) + | otherwise + = (loc, vcat (map ppr_one (ct:cts))) where - first_loc = evVarX (head ev_vars) - ppr_one (EvVarX v loc) - = hang (parens (pprType (evVarPred v))) 2 (pprArisingAt loc) + loc = ctWantedLoc ct + ppr_one ct = hang (parens (pprType (ctPred ct))) + 2 (pprArisingAt (ctWantedLoc ct)) -addErrorReport :: ReportErrCtxt -> SDoc -> TcM () -addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt) +mkErrorReport :: ReportErrCtxt -> SDoc -> TcM ErrMsg +mkErrorReport ctxt msg = mkErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt) -getUserGivens :: ReportErrCtxt -> [([EvVar], GivenLoc)] +type UserGiven = ([EvVar], GivenLoc) + +getUserGivens :: ReportErrCtxt -> [UserGiven] -- One item for each enclosing implication getUserGivens (CEC {cec_encl = ctxt}) = reverse $ @@ -270,12 +374,14 @@ getUserGivens (CEC {cec_encl = ctxt}) %************************************************************************ \begin{code} -reportIrredsErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM () -reportIrredsErrs ctxt irreds orig - = addErrorReport ctxt msg +mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg +mkIrredErr ctxt cts + = mkErrorReport ctxt msg where - givens = getUserGivens ctxt - msg = couldNotDeduce givens (irreds, orig) + (ct1:_) = cts + orig = ctLocOrigin (ctWantedLoc ct1) + givens = getUserGivens ctxt + msg = couldNotDeduce givens (map ctPred cts, orig) \end{code} @@ -286,17 +392,21 @@ reportIrredsErrs ctxt irreds orig %************************************************************************ \begin{code} -reportIPErrs :: ReportErrCtxt -> [(IPName Name, Type)] -> CtOrigin -> TcM () -reportIPErrs ctxt ips orig - = addErrorReport ctxt msg +mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg +mkIPErr ctxt cts + = do { (ctxt', _, ambig_err) <- mkAmbigMsg ctxt cts + ; mkErrorReport ctxt' (msg $$ ambig_err) } where - givens = getUserGivens ctxt + (ct1:_) = cts + orig = ctLocOrigin (ctWantedLoc ct1) + preds = map ctPred cts + givens = getUserGivens ctxt msg | null givens = addArising orig $ - sep [ ptext (sLit "Unbound implicit parameter") <> plural ips - , nest 2 (pprTheta (map (uncurry mkIPPred) ips)) ] + sep [ ptext (sLit "Unbound implicit parameter") <> plural cts + , nest 2 (pprTheta preds) ] | otherwise - = couldNotDeduce givens (map (uncurry mkIPPred) ips, orig) + = couldNotDeduce givens (preds, orig) \end{code} @@ -307,69 +417,88 @@ reportIPErrs ctxt ips orig %************************************************************************ \begin{code} -reportEqErrs :: ReportErrCtxt -> [(Type, Type)] -> CtOrigin -> TcM () --- The [PredType] are already tidied -reportEqErrs ctxt eqs orig - = do { orig' <- zonkTidyOrigin ctxt orig - ; mapM_ (report_one orig') eqs } +mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg +-- Don't have multiple equality errors from the same location +-- E.g. (Int,Bool) ~ (Bool,Int) one error will do! +mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct +mkEqErr _ [] = panic "mkEqErr" + +mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg +-- Wanted constraints only! +mkEqErr1 ctxt ct + = case cc_flavor ct of + Given gl gk -> mkEqErr_help ctxt2 ct False ty1 ty2 + where + ctxt2 = ctxt { cec_extra = cec_extra ctxt $$ + inaccessible_msg gl gk } + + flav -> do { let orig = ctLocOrigin (getWantedLoc flav) + ; (ctxt1, orig') <- zonkTidyOrigin ctxt orig + ; mk_err ctxt1 orig' } where - report_one orig (ty1, ty2) - = do { let extra = getWantedEqExtra orig ty1 ty2 - ctxt' = ctxt { cec_extra = extra $$ cec_extra ctxt } - ; reportEqErr ctxt' ty1 ty2 } - -getWantedEqExtra :: CtOrigin -> TcType -> TcType -> SDoc -getWantedEqExtra (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp })) - ty1 ty2 - -- If the types in the error message are the same as the types we are unifying, - -- don't add the extra expected/actual message - | act `eqType` ty1 && exp `eqType` ty2 = empty - | exp `eqType` ty1 && act `eqType` ty2 = empty - | otherwise = mkExpectedActualMsg act exp - -getWantedEqExtra orig _ _ = pprArising orig - -reportEqErr :: ReportErrCtxt -> TcType -> TcType -> TcM () --- ty1 and ty2 are already tidied -reportEqErr ctxt ty1 ty2 - | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt tv1 ty2 - | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt tv2 ty1 - - | otherwise -- Neither side is a type variable - -- Since the unsolved constraint is canonical, - -- it must therefore be of form (F tys ~ ty) - = addErrorReport ctxt (misMatchOrCND ctxt ty1 ty2 $$ mkTyFunInfoMsg ty1 ty2) - - -reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM () + -- If a GivenSolved then we should not report inaccessible code + inaccessible_msg loc GivenOrig = hang (ptext (sLit "Inaccessible code in")) + 2 (ppr (ctLocOrigin loc)) + inaccessible_msg _ _ = empty + + (ty1, ty2) = getEqPredTys (evVarPred (cc_id ct)) + + -- If the types in the error message are the same as the types + -- we are unifying, don't add the extra expected/actual message + mk_err ctxt1 (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp })) + | act `pickyEqType` ty1 + , exp `pickyEqType` ty2 = mkEqErr_help ctxt1 ct True ty2 ty1 + | exp `pickyEqType` ty1 + , act `pickyEqType` ty2 = mkEqErr_help ctxt1 ct True ty1 ty2 + | otherwise = mkEqErr_help ctxt2 ct False ty1 ty2 + where + ctxt2 = ctxt1 { cec_extra = msg $$ cec_extra ctxt1 } + 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 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 + = do { ctxt' <- mkEqInfoMsg ctxt ct ty1 ty2 + ; mkErrorReport ctxt' (misMatchOrCND ctxt' ct oriented ty1 ty2) } + +mkTyVarEqErr :: ReportErrCtxt -> Ct -> Bool -> TcTyVar -> TcType -> TcM ErrMsg -- tv1 and ty2 are already tidied -reportTyVarEqErr ctxt tv1 ty2 +mkTyVarEqErr ctxt ct oriented tv1 ty2 | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar, or else the thing would -- be oriented the other way round; see TcCanonical.reOrient || isSigTyVar tv1 && not (isTyVarTy ty2) - = addErrorReport (addExtraInfo ctxt ty1 ty2) - (misMatchOrCND ctxt ty1 ty2) + = mkErrorReport (addExtraTyVarInfo ctxt ty1 ty2) + (misMatchOrCND ctxt ct oriented ty1 ty2) -- So tv is a meta tyvar, and presumably it is -- an *untouchable* meta tyvar, else it'd have been unified | not (k2 `isSubKind` k1) -- Kind error - = addErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2) + = mkErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2) -- Occurs check | tv1 `elemVarSet` tyVarsOfType ty2 = let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2 (sep [ppr ty1, char '=', ppr ty2]) - in addErrorReport ctxt occCheckMsg + in mkErrorReport ctxt occCheckMsg -- Check for skolem escape | (implic:_) <- cec_encl ctxt -- Get the innermost context - , let esc_skols = varSetElems (tyVarsOfType ty2 `intersectVarSet` ic_skols implic) + , let esc_skols = filter (`elemVarSet` (tyVarsOfType ty2)) (ic_skols implic) implic_loc = ic_loc implic , not (null esc_skols) = setCtLoc implic_loc $ -- Override the error message location from the -- place the equality arose to the implication site - do { (env1, env_sigs) <- findGlobals ctxt (unitVarSet tv1) - ; let msg = misMatchMsg ty1 ty2 + do { (ctxt', env_sigs) <- findGlobals ctxt (unitVarSet tv1) + ; let msg = misMatchMsg oriented ty1 ty2 esc_doc = sep [ ptext (sLit "because type variable") <> plural esc_skols <+> pprQuotedList esc_skols , ptext (sLit "would escape") <+> @@ -381,23 +510,23 @@ reportTyVarEqErr ctxt tv1 ty2 else ptext (sLit "These (rigid, skolem) type variables are")) <+> ptext (sLit "bound by") , nest 2 $ ppr (ctLocOrigin implic_loc) ] ] - ; addErrTcM (env1, msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) } + ; mkErrorReport ctxt' (msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) } -- Nastiest case: attempt to unify an untouchable variable | (implic:_) <- cec_encl ctxt -- Get the innermost context , let implic_loc = ic_loc implic given = ic_given implic = setCtLoc (ic_loc implic) $ - do { let msg = misMatchMsg ty1 ty2 + do { let msg = misMatchMsg oriented ty1 ty2 extra = quotes (ppr tv1) <+> sep [ ptext (sLit "is untouchable") , ptext (sLit "inside the constraints") <+> pprEvVarTheta given , ptext (sLit "bound at") <+> ppr (ctLocOrigin implic_loc)] - ; addErrorReport (addExtraInfo ctxt ty1 ty2) (msg $$ nest 2 extra) } + ; mkErrorReport (addExtraTyVarInfo ctxt ty1 ty2) (msg $$ nest 2 extra) } | otherwise - = pprTrace "reportTyVarEqErr" (ppr tv1 $$ ppr ty2 $$ ppr (cec_encl ctxt)) $ - return () + = 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. @@ -416,30 +545,43 @@ reportTyVarEqErr ctxt tv1 ty2 k2 = typeKind ty2 ty1 = mkTyVarTy tv1 -mkTyFunInfoMsg :: TcType -> TcType -> SDoc --- See Note [Non-injective type functions] -mkTyFunInfoMsg ty1 ty2 - | Just (tc1,_) <- tcSplitTyConApp_maybe ty1 - , Just (tc2,_) <- tcSplitTyConApp_maybe ty2 - , tc1 == tc2, isSynFamilyTyCon tc1 - = ptext (sLit "NB:") <+> quotes (ppr tc1) - <+> ptext (sLit "is a type function") <> (pp_inj tc1) - | otherwise = empty - where - pp_inj tc | isInjectiveTyCon tc = empty - | otherwise = ptext (sLit (", and may not be injective")) - -misMatchOrCND :: ReportErrCtxt -> TcType -> TcType -> SDoc -misMatchOrCND ctxt ty1 ty2 - | cec_insol ctxt = misMatchMsg ty1 ty2 -- If the equality is unconditionally - -- insoluble, don't report the context - | null givens = misMatchMsg ty1 ty2 - | otherwise = couldNotDeduce givens ([mkEqPred (ty1, ty2)], orig) +mkEqInfoMsg :: ReportErrCtxt -> Ct -> TcType -> TcType -> TcM ReportErrCtxt +-- Report (a) ambiguity if either side is a type function application +-- e.g. F a0 ~ Int +-- (b) warning about injectivity if both sides are the same +-- type function application F a ~ F b +-- See Note [Non-injective type functions] +mkEqInfoMsg ctxt ct ty1 ty2 + = do { (ctxt', _, ambig_msg) <- if isJust mb_fun1 || isJust mb_fun2 + then mkAmbigMsg ctxt [ct] + else return (ctxt, False, empty) + ; return (ctxt' { cec_extra = tyfun_msg $$ ambig_msg $$ cec_extra ctxt' }) } + where + mb_fun1 = isTyFun_maybe ty1 + mb_fun2 = isTyFun_maybe ty2 + tyfun_msg | Just tc1 <- mb_fun1 + , Just tc2 <- mb_fun2 + , tc1 == tc2 + = ptext (sLit "NB:") <+> quotes (ppr tc1) + <+> ptext (sLit "is a type function, and may not be injective") + | otherwise = empty + +misMatchOrCND :: ReportErrCtxt -> Ct -> Bool -> TcType -> TcType -> SDoc +-- If oriented then ty1 is expected, ty2 is actual +misMatchOrCND ctxt ct oriented ty1 ty2 + | null givens || + (isRigid ty1 && isRigid ty2) || + isGivenOrSolved (cc_flavor ct) + -- If the equality is unconditionally insoluble + -- or there is no context, don't report the context + = misMatchMsg oriented ty1 ty2 + | otherwise + = couldNotDeduce givens ([mkEqPred (ty1, ty2)], orig) where givens = getUserGivens ctxt orig = TypeEqOrigin (UnifyOrigin ty1 ty2) -couldNotDeduce :: [([EvVar], GivenLoc)] -> (ThetaType, CtOrigin) -> SDoc +couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc couldNotDeduce givens (wanteds, orig) = vcat [ hang (ptext (sLit "Could not deduce") <+> pprTheta wanteds) 2 (pprArising orig) @@ -456,35 +598,18 @@ pp_givens givens 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin loc) , ptext (sLit "at") <+> ppr (ctLocSpan loc)]) -addExtraInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt +addExtraTyVarInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt -- Add on extra info about the types themselves -- NB: The types themselves are already tidied -addExtraInfo ctxt ty1 ty2 +addExtraTyVarInfo ctxt ty1 ty2 = ctxt { cec_extra = nest 2 (extra1 $$ extra2) $$ cec_extra ctxt } where - extra1 = typeExtraInfoMsg (cec_encl ctxt) ty1 - extra2 = typeExtraInfoMsg (cec_encl ctxt) ty2 - -misMatchMsg :: TcType -> TcType -> SDoc -- Types are already tidy -misMatchMsg ty1 ty2 - = sep [ ptext cm_ty_or_knd <+> quotes (ppr ty1) - , nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)] - where cm_ty_or_knd - | isKind ty1 = sLit "Couldn't match kind" - | otherwise = sLit "Couldn't match type" - -kindErrorMsg :: TcType -> TcType -> SDoc -- Types are already tidy -kindErrorMsg ty1 ty2 - = vcat [ ptext (sLit "Kind incompatibility when matching types:") - , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1 - , ppr ty2 <+> dcolon <+> ppr k2 ]) ] - where - k1 = typeKind ty1 - k2 = typeKind ty2 + extra1 = tyVarExtraInfoMsg (cec_encl ctxt) ty1 + extra2 = tyVarExtraInfoMsg (cec_encl ctxt) ty2 -typeExtraInfoMsg :: [Implication] -> Type -> SDoc +tyVarExtraInfoMsg :: [Implication] -> Type -> SDoc -- Shows a bit of extra info about skolem constants -typeExtraInfoMsg implics ty +tyVarExtraInfoMsg implics ty | Just tv <- tcGetTyVar_maybe ty , isTcTyVar tv, isSkolemTyVar tv , let pp_tv = quotes (ppr tv) @@ -502,15 +627,37 @@ typeExtraInfoMsg implics ty ppr_skol info loc = sep [ptext (sLit "is a rigid type variable bound by"), sep [ppr info, ptext (sLit "at") <+> ppr loc]] +kindErrorMsg :: TcType -> TcType -> SDoc -- Types are already tidy +kindErrorMsg ty1 ty2 + = vcat [ ptext (sLit "Kind incompatibility when matching types:") + , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1 + , ppr ty2 <+> dcolon <+> ppr k2 ]) ] + where + k1 = typeKind ty1 + k2 = typeKind ty2 + -------------------- unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc) unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env = do { (env1, act_ty') <- zonkTidyTcType tidy_env act_ty ; (env2, exp_ty') <- zonkTidyTcType env1 exp_ty - ; return (env2, mkExpectedActualMsg act_ty' exp_ty') } + ; return (env2, mkExpectedActualMsg exp_ty' act_ty') } + +misMatchMsg :: Bool -> TcType -> TcType -> SDoc -- Types are already tidy +-- If oriented then ty1 is expected, ty2 is actual +misMatchMsg oriented ty1 ty2 + | oriented + = sep [ ptext (sLit "Couldn't match expected") <+> what <+> quotes (ppr ty1) + , nest 12 $ ptext (sLit "with actual") <+> what <+> quotes (ppr ty2) ] + | otherwise + = sep [ ptext (sLit "Couldn't match") <+> what <+> quotes (ppr ty1) + , nest 14 $ ptext (sLit "with") <+> quotes (ppr ty2) ] + where + what | isKind ty1 = ptext (sLit "kind") + | otherwise = ptext (sLit "type") mkExpectedActualMsg :: Type -> Type -> SDoc -mkExpectedActualMsg act_ty exp_ty +mkExpectedActualMsg exp_ty act_ty = vcat [ text "Expected type" <> colon <+> ppr exp_ty , text " Actual type" <> colon <+> ppr act_ty ] \end{code} @@ -533,27 +680,33 @@ Warn of loopy local equalities that were dropped. %************************************************************************ \begin{code} -reportDictErrs :: ReportErrCtxt -> [(Class, [Type])] -> CtOrigin -> TcM () -reportDictErrs ctxt wanteds orig +mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg +mkDictErr ctxt cts = do { inst_envs <- tcGetInstEnvs - ; non_overlaps <- filterM (reportOverlap ctxt inst_envs orig) wanteds - ; unless (null non_overlaps) $ - addErrorReport ctxt (mk_no_inst_err non_overlaps) } + ; stuff <- mapM (mkOverlap ctxt inst_envs orig) cts + ; let (non_overlaps, overlap_errs) = partitionEithers stuff + ; if null non_overlaps + then mkErrorReport ctxt (vcat overlap_errs) + else do + { (ctxt', is_ambig, ambig_msg) <- mkAmbigMsg ctxt cts + ; mkErrorReport ctxt' + (vcat [ mkNoInstErr givens non_overlaps orig + , ambig_msg + , mk_no_inst_fixes is_ambig non_overlaps]) } } where - mk_no_inst_err :: [(Class, [Type])] -> SDoc - mk_no_inst_err wanteds - | null givens -- Top level - = vcat [ addArising orig $ - ptext (sLit "No instance") <> plural min_wanteds - <+> ptext (sLit "for") <+> pprTheta min_wanteds - , show_fixes (fixes2 ++ fixes3) ] + (ct1:_) = cts + orig = ctLocOrigin (ctWantedLoc ct1) - | otherwise - = vcat [ couldNotDeduce givens (min_wanteds, orig) - , show_fixes (fixes1 ++ fixes2 ++ fixes3) ] + givens = getUserGivens ctxt + + mk_no_inst_fixes is_ambig cts + | null givens = show_fixes (fixes2 ++ fixes3) + | otherwise = show_fixes (fixes1 ++ fixes2 ++ fixes3) where - givens = getUserGivens ctxt - min_wanteds = mkMinimalBySCs (map (uncurry mkClassPred) wanteds) + min_wanteds = map ctPred cts + instance_dicts = filterOut isTyVarClassPred min_wanteds + -- Insts for which it is worth suggesting an adding an + -- instance declaration. Exclude tyvar dicts. fixes2 = case instance_dicts of [] -> [] @@ -565,19 +718,11 @@ reportDictErrs ctxt wanteds orig DerivOrigin -> [drv_fix] _ -> [] - instance_dicts = filterOut isTyVarClassPred min_wanteds - -- Insts for which it is worth suggesting an adding an - -- instance declaration. Exclude tyvar dicts. - drv_fix = vcat [ptext (sLit "use a standalone 'deriving instance' declaration,"), nest 2 $ ptext (sLit "so you can specify the instance context yourself")] - show_fixes :: [SDoc] -> SDoc - show_fixes [] = empty - show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"), - nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))] - - fixes1 | (orig:origs) <- mapCatMaybes get_good_orig (cec_encl ctxt) + fixes1 | not is_ambig + , (orig:origs) <- mapCatMaybes get_good_orig (cec_encl ctxt) = [sep [ ptext (sLit "add") <+> pprTheta min_wanteds <+> ptext (sLit "to the context of") , nest 2 $ ppr_skol orig $$ @@ -594,19 +739,38 @@ reportDictErrs ctxt wanteds orig SigSkol (InfSigCtxt {}) _ -> Nothing origin -> Just origin -reportOverlap :: ReportErrCtxt -> (InstEnv,InstEnv) -> CtOrigin - -> (Class, [Type]) -> TcM Bool + + show_fixes :: [SDoc] -> SDoc + show_fixes [] = empty + show_fixes (f:fs) = sep [ ptext (sLit "Possible fix:") + , nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))] + +mkNoInstErr :: [UserGiven] -> [Ct] -> CtOrigin -> SDoc +mkNoInstErr givens cts orig + | null givens -- Top level + = addArising orig $ + ptext (sLit "No instance") <> plural cts + <+> ptext (sLit "for") <+> pprTheta theta + + | otherwise + = couldNotDeduce givens (theta, orig) + where + theta = map ctPred cts + +mkOverlap :: ReportErrCtxt -> (InstEnv,InstEnv) -> CtOrigin + -> Ct -> TcM (Either Ct SDoc) -- Report an overlap error if this class constraint results --- from an overlap (returning Nothing), otherwise return (Just pred) -reportOverlap ctxt inst_envs orig (clas, tys) +-- from an overlap (returning Left clas), otherwise return (Right pred) +mkOverlap ctxt inst_envs orig ct = do { tys_flat <- mapM quickFlattenTy tys -- Note [Flattening in error message generation] ; case lookupInstEnv inst_envs clas tys_flat of - ([], _, _) -> return True -- No match - res -> do { addErrorReport ctxt (mk_overlap_msg res) - ; return False } } + ([], _, _) -> return (Left ct) -- No match + res -> return (Right (mk_overlap_msg res)) } where + (clas, tys) = getClassPredTys (ctPred ct) + -- Normal overlap error mk_overlap_msg (matches, unifiers, False) = ASSERT( not (null matches) ) @@ -729,66 +893,60 @@ that match such things. And flattening under a for-all is problematic anyway; consider C (forall a. F a) \begin{code} -reportAmbigErrs :: ReportErrCtxt -> [WantedEvVar] -> TcM () -reportAmbigErrs ctxt ambigs --- Divide into groups that share a common set of ambiguous tyvars - = mapM_ (reportAmbigGroup ctxt) (equivClasses cmp ambigs_w_tvs) - where - ambigs_w_tvs = [ (d, filter isAmbiguousTyVar (varSetElems (tyVarsOfEvVarX d))) - | d <- ambigs ] - cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2 - - -reportAmbigGroup :: ReportErrCtxt -> [(WantedEvVar, [TcTyVar])] -> TcM () --- The pairs all have the same [TcTyVar] -reportAmbigGroup ctxt pairs - = setCtLoc loc $ - do { dflags <- getDOpts - ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet tvs) - ; addErrTcM (tidy_env, main_msg $$ mk_msg dflags docs) } +mkAmbigMsg :: ReportErrCtxt -> [Ct] + -> TcM (ReportErrCtxt, Bool, SDoc) +mkAmbigMsg ctxt cts + | isEmptyVarSet ambig_tv_set + = return (ctxt, False, empty) + | otherwise + = do { dflags <- getDOpts + ; (ctxt', gbl_docs) <- findGlobals ctxt ambig_tv_set + ; return (ctxt', True, mk_msg dflags gbl_docs) } where - (wev, tvs) : _ = pairs - (loc, pp_wanteds) = pprWithArising (map fst pairs) - main_msg = sep [ text "Ambiguous type variable" <> plural tvs - <+> pprQuotedList tvs - <+> text "in the constraint" <> plural pairs <> colon - , nest 2 pp_wanteds ] - + ambig_tv_set = foldr (unionVarSet . filterVarSet isAmbiguousTyVar . tyVarsOfCt) + emptyVarSet cts + ambig_tvs = varSetElems ambig_tv_set + + is_or_are | isSingleton ambig_tvs = text "is" + | otherwise = text "are" + mk_msg dflags docs - | any isRuntimeUnkSkol tvs -- See Note [Runtime skolems] - = vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+> - (pprWithCommas ppr tvs), - ptext (sLit "Use :print or :force to determine these types")] - - | DerivOrigin <- ctLocOrigin (evVarX wev) - = ptext (sLit "Probable fix: use a 'standalone deriving' declaration instead") - - | null docs - = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)") + | any isRuntimeUnkSkol ambig_tvs -- See Note [Runtime skolems] + = vcat [ ptext (sLit "Cannot resolve unknown runtime type") <> plural ambig_tvs + <+> pprQuotedList ambig_tvs + , ptext (sLit "Use :print or :force to determine these types")] + | otherwise + = vcat [ text "The type variable" <> plural ambig_tvs + <+> pprQuotedList ambig_tvs + <+> is_or_are <+> text "ambiguous" + , mk_extra_msg dflags docs ] + + mk_extra_msg dflags docs + | null docs + = ptext (sLit "Possible fix: add a type signature that fixes these type variable(s)") -- This happens in things like -- f x = show (read "foo") -- where monomorphism doesn't play any role - | otherwise - = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"), - nest 2 (vcat docs), - mono_fix dflags] - - mono_fix :: DynFlags -> SDoc - mono_fix dflags - = ptext (sLit "Probable fix:") <+> vcat - [ptext (sLit "give these definition(s) an explicit type signature"), - if xopt Opt_MonomorphismRestriction dflags - then ptext (sLit "or use -XNoMonomorphismRestriction") - else empty] -- Only suggest adding "-XNoMonomorphismRestriction" - -- if it is not already set! + | otherwise + = vcat [ ptext (sLit "Possible cause: the monomorphism restriction applied to the following:") + , nest 2 (vcat docs) + , ptext (sLit "Probable fix:") <+> vcat + [ ptext (sLit "give these definition(s) an explicit type signature") + , if xopt Opt_MonomorphismRestriction dflags + then ptext (sLit "or use -XNoMonomorphismRestriction") + else empty ] -- Only suggest adding "-XNoMonomorphismRestriction" + -- if it is not already set! + ] getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo +-- Get the skolem info for a type variable +-- from the implication constraint that binds it getSkolemInfo [] tv = WARN( True, ptext (sLit "No skolem info:") <+> ppr tv ) UnkSkol getSkolemInfo (implic:implics) tv - | tv `elemVarSet` ic_skols implic = ctLocOrigin (ic_loc implic) - | otherwise = getSkolemInfo implics tv + | tv `elem` ic_skols implic = ctLocOrigin (ic_loc implic) + | otherwise = getSkolemInfo implics tv ----------------------- -- findGlobals looks at the value environment and finds values whose @@ -804,7 +962,7 @@ mkEnvSigMsg what env_sigs findGlobals :: ReportErrCtxt -> TcTyVarSet - -> TcM (TidyEnv, [SDoc]) + -> TcM (ReportErrCtxt, [SDoc]) findGlobals ctxt tvs = do { lcl_ty_env <- case cec_encl ctxt of @@ -812,12 +970,12 @@ findGlobals ctxt tvs (i:_) -> return (ic_env i) ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) } where - go tidy_env acc [] = return (tidy_env, acc) - go tidy_env acc (thing : things) = do - (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing - case maybe_doc of - Just d -> go tidy_env1 (d:acc) things - Nothing -> go tidy_env1 acc things + go tidy_env acc [] = return (ctxt { cec_tidy = tidy_env }, acc) + go tidy_env acc (thing : things) + = do { (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing + ; case maybe_doc of + Just d -> go tidy_env1 (d:acc) things + Nothing -> go tidy_env1 acc things } ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty @@ -861,18 +1019,11 @@ warnDefaulting wanteds default_ty tidy_env = tidyFreeTyVars env0 $ tyVarsOfCts wanted_bag tidy_wanteds = mapBag (tidyCt tidy_env) wanted_bag - (loc, ppr_wanteds) = pprWithArising (map mk_wev (bagToList tidy_wanteds)) + (loc, ppr_wanteds) = pprWithArising (bagToList tidy_wanteds) warn_msg = hang (ptext (sLit "Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty)) 2 ppr_wanteds ; setCtLoc loc $ warnTc warn_default warn_msg } - where mk_wev :: Ct -> WantedEvVar - mk_wev ct - | ev <- cc_id ct - , Wanted wloc <- cc_flavor ct - = EvVarX ev wloc -- must return a WantedEvVar - mk_wev _ct = panic "warnDefaulting: encountered non-wanted for defaulting" - \end{code} Note [Runtime skolems] @@ -889,13 +1040,12 @@ are created by in RtClosureInspect.zonkRTTIType. %************************************************************************ \begin{code} -solverDepthErrorTcS :: Int -> [Ct] -> TcS a +solverDepthErrorTcS :: Int -> [Ct] -> TcM a solverDepthErrorTcS depth stack | null stack -- Shouldn't happen unless you say -fcontext-stack=0 - = wrapErrTcS $ failWith msg + = failWith msg | otherwise - = wrapErrTcS $ - setCtFlavorLoc (cc_flavor top_item) $ + = setCtFlavorLoc (cc_flavor top_item) $ do { ev_vars <- mapM (zonkEvVar . cc_id) stack ; env0 <- tcInitTidyEnv ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfEvVars ev_vars) @@ -906,10 +1056,9 @@ solverDepthErrorTcS depth stack msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ] -flattenForAllErrorTcS :: CtFlavor -> TcType -> TcS a +flattenForAllErrorTcS :: CtFlavor -> TcType -> TcM a flattenForAllErrorTcS fl ty - = wrapErrTcS $ - setCtFlavorLoc fl $ + = setCtFlavorLoc fl $ do { env0 <- tcInitTidyEnv ; let (env1, ty') = tidyOpenType env0 ty msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:") @@ -941,12 +1090,11 @@ zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType) zonkTidyTcType env ty = do { ty' <- zonkTcType ty ; return (tidyOpenType env ty') } -zonkTidyOrigin :: ReportErrCtxt -> CtOrigin -> TcM CtOrigin +zonkTidyOrigin :: ReportErrCtxt -> CtOrigin -> TcM (ReportErrCtxt, CtOrigin) zonkTidyOrigin ctxt (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp })) = do { (env1, act') <- zonkTidyTcType (cec_tidy ctxt) act - ; (_env2, exp') <- zonkTidyTcType env1 exp - ; return (TypeEqOrigin (UnifyOrigin { uo_actual = act', uo_expected = exp' })) } - -- Drop the returned env on the floor; we may conceivably thereby get - -- inconsistent naming between uses of this function -zonkTidyOrigin _ orig = return orig + ; (env2, exp') <- zonkTidyTcType env1 exp + ; return ( ctxt { cec_tidy = env2 } + , TypeEqOrigin (UnifyOrigin { uo_actual = act', uo_expected = exp' })) } +zonkTidyOrigin ctxt orig = return (ctxt, orig) \end{code} diff --git a/compiler/typecheck/TcEvidence.lhs b/compiler/typecheck/TcEvidence.lhs index 87aaa3238d..7845f381bf 100644 --- a/compiler/typecheck/TcEvidence.lhs +++ b/compiler/typecheck/TcEvidence.lhs @@ -461,6 +461,10 @@ data EvTerm | EvTupleMk [EvId] -- tuple built from this stuff
+ | EvDelayedError Type FastString -- Used with Opt_DeferTypeErrors
+ -- See Note [Deferring coercion errors to runtime]
+ -- in TcSimplify
+
| EvSuperClass DictId Int -- n'th superclass. Used for both equalities and
-- dictionaries, even though the former have no
-- selector Id. We count up from _0_
@@ -523,12 +527,13 @@ isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds" evVarsOfTerm :: EvTerm -> [EvVar]
evVarsOfTerm (EvId v) = [v]
-evVarsOfTerm (EvCoercion co) = varSetElems (coVarsOfTcCo co)
-evVarsOfTerm (EvDFunApp _ _ evs) = evs
-evVarsOfTerm (EvTupleSel v _) = [v]
-evVarsOfTerm (EvSuperClass v _) = [v]
-evVarsOfTerm (EvCast v co) = v : varSetElems (coVarsOfTcCo co)
-evVarsOfTerm (EvTupleMk evs) = evs
+evVarsOfTerm (EvCoercion co) = varSetElems (coVarsOfTcCo co)
+evVarsOfTerm (EvDFunApp _ _ evs) = evs
+evVarsOfTerm (EvTupleSel v _) = [v]
+evVarsOfTerm (EvSuperClass v _) = [v]
+evVarsOfTerm (EvCast v co) = v : varSetElems (coVarsOfTcCo co)
+evVarsOfTerm (EvTupleMk evs) = evs
+evVarsOfTerm (EvDelayedError _ _) = []
evVarsOfTerm (EvKindCast v co) = v : varSetElems (coVarsOfTcCo co)
\end{code}
@@ -589,5 +594,7 @@ instance Outputable EvTerm where ppr (EvTupleMk vs) = ptext (sLit "tupmk") <+> ppr vs
ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n))
ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ]
+ ppr (EvDelayedError ty msg) = ptext (sLit "error")
+ <+> sep [ char '@' <> ppr ty, ppr msg ]
\end{code}
diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 67f212fd98..a3b33bca60 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -1395,7 +1395,7 @@ funAppCtxt fun arg arg_no 2 (quotes (ppr arg)) funResCtxt :: LHsExpr Name -> TcType -> TcType - -> TidyEnv -> TcM (TidyEnv, Message) + -> TidyEnv -> TcM (TidyEnv, MsgDoc) -- When we have a mis-match in the return type of a function -- try to give a helpful message about too many/few arguments funResCtxt fun fun_res_ty res_ty env0 diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index c040d6d58f..c9c6a1e24e 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -468,7 +468,7 @@ checkCConv CmmCallConv = panic "checkCConv CmmCallConv" Warnings \begin{code} -check :: Bool -> Message -> TcM () +check :: Bool -> MsgDoc -> TcM () check True _ = return () check _ the_err = addErrTc the_err @@ -483,7 +483,7 @@ argument, result :: SDoc argument = text "argument" result = text "result" -badCName :: CLabelString -> Message +badCName :: CLabelString -> MsgDoc badCName target = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")] diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 3e18da52cc..73361aefaa 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -1117,6 +1117,9 @@ zonkEvTerm env (EvDFunApp df tys tms) = do { tys' <- zonkTcTypeToTypes env tys ; let tms' = map (zonkEvVarOcc env) tms ; return (EvDFunApp (zonkIdOcc env df) tys' tms') } +zonkEvTerm env (EvDelayedError ty msg) + = do { ty' <- zonkTcTypeToType env ty + ; return (EvDelayedError ty' msg) } zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds) zonkTcEvBinds env (TcEvBinds var) = do { (env', bs') <- zonkEvBindsVar env var diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 08086e4e56..c83027715c 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -7,7 +7,6 @@ -- for details module TcInteract ( - solveInteractWanted, -- Solves [WantedEvVar] solveInteractGiven, -- Solves [EvVar],GivenLoc solveInteractCts, -- Solves [Cts] ) where @@ -104,20 +103,30 @@ solveInteractCts cts -> Ct -> TcS ([Ct],TypeMap (EvVar,CtFlavor)) solve_or_cache (acc_cts,acc_cache) ct - | isIPPred pty - = return (ct:acc_cts,acc_cache) -- Do not use the cache, - -- nor update it for IPPreds due to subtle shadowing - | Just (ev',fl') <- lookupTM pty acc_cache + | dont_cache (classifyPredType pred_ty) + = return (ct:acc_cts,acc_cache) + + | Just (ev',fl') <- lookupTM pred_ty acc_cache , fl' `canSolve` fl , isWanted fl = do { _ <- setEvBind ev (EvId ev') fl ; return (acc_cts,acc_cache) } + | otherwise -- If it's a given keep it in the work list, even if it exists in the cache! - = return (ct:acc_cts, alterTM pty (\_ -> Just (ev,fl)) acc_cache) + = return (ct:acc_cts, alterTM pred_ty (\_ -> Just (ev,fl)) acc_cache) where fl = cc_flavor ct ev = cc_id ct - pty = ctPred ct - + pred_ty = ctPred ct + + dont_cache :: PredTree -> Bool + -- Do not use the cache, not update it, if this is true + dont_cache (IPPred {}) = True -- IPPreds have subtle shadowing + dont_cache (EqPred ty1 ty2) -- Report Int ~ Bool errors separately + | Just tc1 <- tyConAppTyCon_maybe ty1 + , Just tc2 <- tyConAppTyCon_maybe ty2 + , tc1 /= tc2 + = isDecomposableTyCon tc1 && isDecomposableTyCon tc2 + dont_cache _ = False solveInteractGiven :: GivenLoc -> [EvVar] -> TcS () solveInteractGiven gloc evs @@ -126,14 +135,6 @@ solveInteractGiven gloc evs , cc_flavor = Given gloc GivenOrig , cc_depth = 0 } -solveInteractWanted :: [WantedEvVar] -> TcS () --- Solve these wanteds along with current inerts and wanteds! -solveInteractWanted wevs - = solveInteractCts (map mk_noncan wevs) - where mk_noncan (EvVarX v w) - = CNonCanonical { cc_id = v, cc_flavor = Wanted w, cc_depth = 0 } - - -- The main solver loop implements Note [Basic Simplifier Plan] --------------------------------------------------------------- solveInteract :: TcS () @@ -149,7 +150,7 @@ solveInteract NoWorkRemaining -- Done, successfuly (modulo frozen) -> return () MaxDepthExceeded ct -- Failure, depth exceeded - -> solverDepthErrorTcS (cc_depth ct) [ct] + -> wrapErrTcS $ solverDepthErrorTcS (cc_depth ct) [ct] NextWorkItem ct -- More work, loop around! -> runSolverPipeline thePipeline ct >> solve_loop } ; solve_loop } @@ -1443,7 +1444,9 @@ doTopReact _inerts workItem@(CDictCan { cc_flavor = Derived loc -- Wanted dictionary doTopReact inerts workItem@(CDictCan { cc_flavor = fl@(Wanted loc) - , cc_class = cls, cc_tyargs = xis }) + , cc_id = dict_id + , cc_class = cls, cc_tyargs = xis + , cc_depth = depth }) -- See Note [MATCHING-SYNONYMS] = do { traceTcS "doTopReact" (ppr workItem) ; instEnvs <- getInstEnvs @@ -1457,7 +1460,7 @@ doTopReact inerts workItem@(CDictCan { cc_flavor = fl@(Wanted loc) do { lkup_inst_res <- matchClassInst inerts cls xis loc ; case lkup_inst_res of GenInst wtvs ev_term - -> doSolveFromInstance wtvs ev_term workItem + -> doSolveFromInstance wtvs ev_term NoInstance -> return NoTopInt } @@ -1467,31 +1470,26 @@ doTopReact inerts workItem@(CDictCan { cc_flavor = fl@(Wanted loc) ; return SomeTopInt { tir_rule = "Dict/Top (fundeps)" , tir_new_item = ContinueWith workItem } } } - where doSolveFromInstance :: [WantedEvVar] - -> EvTerm - -> Ct - -> TcS TopInteractResult + where doSolveFromInstance :: [EvVar] -> EvTerm -> TcS TopInteractResult -- Precondition: evidence term matches the predicate of cc_id of workItem - doSolveFromInstance wtvs ev_term workItem - | null wtvs - = do { traceTcS "doTopReact/found nullary instance for" (ppr (cc_id workItem)) - ; _ <- setEvBind (cc_id workItem) ev_term fl + doSolveFromInstance evs ev_term + | null evs + = do { traceTcS "doTopReact/found nullary instance for" (ppr dict_id) + ; _ <- setEvBind dict_id ev_term fl ; return $ SomeTopInt { tir_rule = "Dict/Top (solved, no new work)" , tir_new_item = Stop } } -- Don't put him in the inerts | otherwise - = do { traceTcS "doTopReact/found non-nullary instance for" $ - ppr (cc_id workItem) - ; _ <- setEvBind (cc_id workItem) ev_term fl + = do { traceTcS "doTopReact/found non-nullary instance for" (ppr dict_id) + ; _ <- setEvBind dict_id ev_term fl -- Solved and new wanted work produced, you may cache the -- (tentatively solved) dictionary as Solved given. -- ; let _solved = workItem { cc_flavor = solved_fl } -- solved_fl = mkSolvedFlavor fl UnkSkol - ; let ct_from_wev (EvVarX v fl) - = CNonCanonical { cc_id = v, cc_flavor = Wanted fl - , cc_depth = cc_depth workItem + 1 } - wtvs_cts = map ct_from_wev wtvs - ; updWorkListTcS (appendWorkListCt wtvs_cts) + ; let mk_new_wanted ev + = CNonCanonical { cc_id = ev, cc_flavor = fl + , cc_depth = depth + 1 } + ; updWorkListTcS (appendWorkListCt (map mk_new_wanted evs)) ; return $ SomeTopInt { tir_rule = "Dict/Top (solved, more work)" , tir_new_item = Stop } @@ -1763,7 +1761,7 @@ NB: The desugarer needs be more clever to deal with equalities \begin{code} data LookupInstResult = NoInstance - | GenInst [WantedEvVar] EvTerm + | GenInst [EvVar] EvTerm matchClassInst :: InertSet -> Class -> [Type] -> WantedLoc -> TcS LookupInstResult matchClassInst inerts clas tys loc @@ -1798,10 +1796,9 @@ matchClassInst inerts clas tys loc else do { evc_vars <- instDFunConstraints theta (Wanted loc) ; let ev_vars = map evc_the_evvar evc_vars - new_evc_vars = filter isNewEvVar evc_vars - wevs = map (\v -> EvVarX (evc_the_evvar v) loc) new_evc_vars - -- wevs are only the real new variables that can be emitted - ; return $ GenInst wevs (EvDFunApp dfun_id tys ev_vars) } + new_ev_vars = [evc_the_evvar evc | evc <- evc_vars, isNewEvVar evc] + -- new_ev_vars are only the real new variables that can be emitted + ; return $ GenInst new_ev_vars (EvDFunApp dfun_id tys ev_vars) } } } where diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 2d658165ff..d92d80c093 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -66,9 +66,8 @@ module TcMType ( zonkTcType, zonkTcTypes, zonkTcThetaType, zonkTcKind, defaultKindVarToStar, zonkCt, zonkCts, - zonkImplication, zonkEvVar, zonkWantedEvVar, + zonkImplication, zonkEvVar, zonkWC, - zonkWC, zonkWantedEvVars, zonkTcTypeAndSubst, tcGetGlobalTyVars, @@ -695,12 +694,6 @@ zonkCt ct zonkCts :: Cts -> TcM Cts zonkCts = mapBagM zonkCt -zonkWantedEvVars :: Bag WantedEvVar -> TcM (Bag WantedEvVar) -zonkWantedEvVars = mapBagM zonkWantedEvVar - -zonkWantedEvVar :: WantedEvVar -> TcM WantedEvVar -zonkWantedEvVar (EvVarX v l) = do { v' <- zonkEvVar v; return (EvVarX v' l) } - zonkFlavor :: CtFlavor -> TcM CtFlavor zonkFlavor (Given loc gk) = do { loc' <- zonkGivenLoc loc; return (Given loc' gk) } zonkFlavor fl = return fl @@ -1625,7 +1618,7 @@ The underlying idea is that \begin{code} -checkInstTermination :: [TcType] -> ThetaType -> [Message] +checkInstTermination :: [TcType] -> ThetaType -> [MsgDoc] checkInstTermination tys theta = mapCatMaybes check theta where @@ -1682,7 +1675,7 @@ checkValidFamInst typats rhs -- checkFamInstRhs :: [Type] -- lhs -> [(TyCon, [Type])] -- type family instances - -> [Message] + -> [MsgDoc] checkFamInstRhs lhsTys famInsts = mapCatMaybes check famInsts where diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index 1474686c15..333c2d0984 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -31,6 +31,7 @@ import TcMType import TcType import TcBinds import TcUnify +import TcErrors ( misMatchMsg ) import Name import TysWiredIn import Id @@ -876,5 +877,22 @@ checkArgs fun (MatchGroup (match1:matches) _) args_in_match :: LMatch Name -> Int args_in_match (L _ (Match pats _ _)) = length pats checkArgs fun _ = pprPanic "TcPat.checkArgs" (ppr fun) -- Matches always non-empty + +failWithMisMatch :: [EqOrigin] -> TcM a +-- Generate the message when two types fail to match, +-- going to some trouble to make it helpful. +-- We take the failing types from the top of the origin stack +-- rather than reporting the particular ones we are looking +-- at right now +failWithMisMatch (item:origin) + = wrapEqCtxt origin $ + do { ty_act <- zonkTcType (uo_actual item) + ; ty_exp <- zonkTcType (uo_expected item) + ; env0 <- tcInitTidyEnv + ; let (env1, pp_exp) = tidyOpenType env0 ty_exp + (env2, pp_act) = tidyOpenType env1 ty_act + ; failWithTcM (env2, misMatchMsg True pp_exp pp_act) } +failWithMisMatch [] + = panic "failWithMisMatch" \end{code} diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index bb1013b33d..4e46de90d9 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -191,7 +191,7 @@ tcRnModule hsc_env hsc_src save_rn_syntax -- Process the export list traceRn (text "rn4a: before exports"); tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ; - traceRn (text "rn4b: after exportss") ; + traceRn (text "rn4b: after exports") ; -- Check that main is exported (must be after rnExports) checkMainExported tcg_env ; diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 08125d75d0..2c6461fef9 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -450,7 +450,7 @@ traceOptTcRn :: DynFlag -> SDoc -> TcRn () traceOptTcRn flag doc = ifDOptM flag $ do { loc <- getSrcSpanM ; let real_doc - | opt_PprStyle_Debug = mkLocMessage loc doc + | opt_PprStyle_Debug = mkLocMessage SevInfo loc doc | otherwise = doc -- The full location is -- usually way too much ; dumpTcRn real_doc } @@ -563,13 +563,13 @@ getErrsVar = do { env <- getLclEnv; return (tcl_errs env) } setErrsVar :: TcRef Messages -> TcRn a -> TcRn a setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v }) -addErr :: Message -> TcRn () -- Ignores the context stack +addErr :: MsgDoc -> TcRn () -- Ignores the context stack addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg } -failWith :: Message -> TcRn a +failWith :: MsgDoc -> TcRn a failWith msg = addErr msg >> failM -addErrAt :: SrcSpan -> Message -> TcRn () +addErrAt :: SrcSpan -> MsgDoc -> TcRn () -- addErrAt is mainly (exclusively?) used by the renamer, where -- tidying is not an issue, but it's all lazy so the extra -- work doesn't matter @@ -578,22 +578,16 @@ addErrAt loc msg = do { ctxt <- getErrCtxt ; err_info <- mkErrInfo tidy_env ctxt ; addLongErrAt loc msg err_info } -addErrs :: [(SrcSpan,Message)] -> TcRn () +addErrs :: [(SrcSpan,MsgDoc)] -> TcRn () addErrs msgs = mapM_ add msgs where add (loc,msg) = addErrAt loc msg -addWarn :: Message -> TcRn () -addWarn msg = addReport (ptext (sLit "Warning:") <+> msg) empty - -addWarnAt :: SrcSpan -> Message -> TcRn () -addWarnAt loc msg = addReportAt loc (ptext (sLit "Warning:") <+> msg) empty - -checkErr :: Bool -> Message -> TcRn () +checkErr :: Bool -> MsgDoc -> TcRn () -- Add the error if the bool is False checkErr ok msg = unless ok (addErr msg) -warnIf :: Bool -> Message -> TcRn () +warnIf :: Bool -> MsgDoc -> TcRn () warnIf True msg = addWarn msg warnIf False _ = return () @@ -628,29 +622,31 @@ discardWarnings thing_inside %************************************************************************ \begin{code} -addReport :: Message -> Message -> TcRn () -addReport msg extra_info = do { traceTc "addr" msg; loc <- getSrcSpanM; addReportAt loc msg extra_info } - -addReportAt :: SrcSpan -> Message -> Message -> TcRn () -addReportAt loc msg extra_info - = do { errs_var <- getErrsVar ; +mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg +mkLongErrAt loc msg extra + = do { traceTc "Adding error:" (mkLocMessage SevError loc (msg $$ extra)) ; rdr_env <- getGlobalRdrEnv ; dflags <- getDOpts ; - let { warn = mkLongWarnMsg loc (mkPrintUnqualified dflags rdr_env) - msg extra_info } ; - (warns, errs) <- readTcRef errs_var ; - writeTcRef errs_var (warns `snocBag` warn, errs) } + return $ mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } -addLongErrAt :: SrcSpan -> Message -> Message -> TcRn () -addLongErrAt loc msg extra - = do { traceTc "Adding error:" (mkLocMessage loc (msg $$ extra)) ; - errs_var <- getErrsVar ; - rdr_env <- getGlobalRdrEnv ; - dflags <- getDOpts ; - let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ; +addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn () +addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError + +reportErrors :: [ErrMsg] -> TcM () +reportErrors = mapM_ reportError + +reportError :: ErrMsg -> TcRn () +reportError err + = do { errs_var <- getErrsVar ; (warns, errs) <- readTcRef errs_var ; writeTcRef errs_var (warns, errs `snocBag` err) } +reportWarning :: ErrMsg -> TcRn () +reportWarning warn + = do { errs_var <- getErrsVar ; + (warns, errs) <- readTcRef errs_var ; + writeTcRef errs_var (warns `snocBag` warn, errs) } + dumpDerivingInfo :: SDoc -> TcM () dumpDerivingInfo doc = do { dflags <- getDOpts @@ -773,9 +769,9 @@ checkNoErrs main } ifErrsM :: TcRn r -> TcRn r -> TcRn r --- ifErrsM bale_out main +-- ifErrsM bale_out normal -- does 'bale_out' if there are errors in errors collection --- otherwise does 'main' +-- otherwise does 'normal' ifErrsM bale_out normal = do { errs_var <- getErrsVar ; msgs <- readTcRef errs_var ; @@ -804,13 +800,13 @@ getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) } setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt }) -addErrCtxt :: Message -> TcM a -> TcM a +addErrCtxt :: MsgDoc -> TcM a -> TcM a addErrCtxt msg = addErrCtxtM (\env -> return (env, msg)) -addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a +addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts) -addLandmarkErrCtxt :: Message -> TcM a -> TcM a +addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a addLandmarkErrCtxt msg = updCtxt (\ctxts -> (True, \env -> return (env,msg)) : ctxts) -- Helper function for the above @@ -842,32 +838,40 @@ setCtLoc (CtLoc _ src_loc ctxt) thing_inside tidy up the message; we then use it to tidy the context messages \begin{code} -addErrTc :: Message -> TcM () +addErrTc :: MsgDoc -> TcM () addErrTc err_msg = do { env0 <- tcInitTidyEnv ; addErrTcM (env0, err_msg) } -addErrsTc :: [Message] -> TcM () +addErrsTc :: [MsgDoc] -> TcM () addErrsTc err_msgs = mapM_ addErrTc err_msgs -addErrTcM :: (TidyEnv, Message) -> TcM () +addErrTcM :: (TidyEnv, MsgDoc) -> TcM () addErrTcM (tidy_env, err_msg) = do { ctxt <- getErrCtxt ; loc <- getSrcSpanM ; add_err_tcm tidy_env err_msg loc ctxt } + +-- Return the error message, instead of reporting it straight away +mkErrTcM :: (TidyEnv, MsgDoc) -> TcM ErrMsg +mkErrTcM (tidy_env, err_msg) + = do { ctxt <- getErrCtxt ; + loc <- getSrcSpanM ; + err_info <- mkErrInfo tidy_env ctxt ; + mkLongErrAt loc err_msg err_info } \end{code} The failWith functions add an error message and cause failure \begin{code} -failWithTc :: Message -> TcM a -- Add an error message and fail +failWithTc :: MsgDoc -> TcM a -- Add an error message and fail failWithTc err_msg = addErrTc err_msg >> failM -failWithTcM :: (TidyEnv, Message) -> TcM a -- Add an error message and fail +failWithTcM :: (TidyEnv, MsgDoc) -> TcM a -- Add an error message and fail failWithTcM local_and_msg = addErrTcM local_and_msg >> failM -checkTc :: Bool -> Message -> TcM () -- Check that the boolean is true +checkTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is true checkTc True _ = return () checkTc False err = failWithTc err \end{code} @@ -875,20 +879,39 @@ checkTc False err = failWithTc err Warnings have no 'M' variant, nor failure \begin{code} -addWarnTc :: Message -> TcM () +warnTc :: Bool -> MsgDoc -> TcM () +warnTc warn_if_true warn_msg + | warn_if_true = addWarnTc warn_msg + | otherwise = return () + +addWarnTc :: MsgDoc -> TcM () addWarnTc msg = do { env0 <- tcInitTidyEnv ; addWarnTcM (env0, msg) } -addWarnTcM :: (TidyEnv, Message) -> TcM () +addWarnTcM :: (TidyEnv, MsgDoc) -> TcM () addWarnTcM (env0, msg) = do { ctxt <- getErrCtxt ; err_info <- mkErrInfo env0 ctxt ; - addReport (ptext (sLit "Warning:") <+> msg) err_info } + add_warn msg err_info } -warnTc :: Bool -> Message -> TcM () -warnTc warn_if_true warn_msg - | warn_if_true = addWarnTc warn_msg - | otherwise = return () +addWarn :: MsgDoc -> TcRn () +addWarn msg = add_warn msg empty + +addWarnAt :: SrcSpan -> MsgDoc -> TcRn () +addWarnAt loc msg = add_warn_at loc msg empty + +add_warn :: MsgDoc -> MsgDoc -> TcRn () +add_warn msg extra_info + = do { loc <- getSrcSpanM + ; add_warn_at loc msg extra_info } + +add_warn_at :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn () +add_warn_at loc msg extra_info + = do { rdr_env <- getGlobalRdrEnv ; + dflags <- getDOpts ; + let { warn = mkLongWarnMsg loc (mkPrintUnqualified dflags rdr_env) + msg extra_info } ; + reportWarning warn } \end{code} ----------------------------------- @@ -919,7 +942,7 @@ tcInitTidyEnv Other helper functions \begin{code} -add_err_tcm :: TidyEnv -> Message -> SrcSpan +add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan -> [ErrCtxt] -> TcM () add_err_tcm tidy_env err_msg loc ctxt @@ -929,8 +952,8 @@ add_err_tcm tidy_env err_msg loc ctxt mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc -- Tidy the error info, trimming excessive contexts mkErrInfo env ctxts - | opt_PprStyle_Debug -- In -dppr-debug style the output - = return empty -- just becomes too voluminous +-- | opt_PprStyle_Debug -- In -dppr-debug style the output +-- = return empty -- just becomes too voluminous | otherwise = go 0 env ctxts where @@ -976,6 +999,11 @@ addTcEvBind (EvBindsVar ev_ref _) var t = do { bnds <- readTcRef ev_ref ; writeTcRef ev_ref (extendEvBinds bnds var t) } +getTcEvBinds :: EvBindsVar -> TcM (Bag EvBind) +getTcEvBinds (EvBindsVar ev_ref _) + = do { bnds <- readTcRef ev_ref + ; return (evBindMapBinds bnds) } + chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName chooseUniqueOccTc fn = do { env <- getGblEnv @@ -996,24 +1024,15 @@ emitConstraints ct = do { lie_var <- getConstraintVar ; updTcRef lie_var (`andWC` ct) } -emitFlat :: WantedEvVar -> TcM () +emitFlat :: Ct -> TcM () emitFlat ct = do { lie_var <- getConstraintVar ; updTcRef lie_var (`addFlats` unitBag ct) } -emitFlats :: Bag WantedEvVar -> TcM () -emitFlats ct +emitFlats :: Cts -> TcM () +emitFlats cts = do { lie_var <- getConstraintVar ; - updTcRef lie_var (`addFlats` ct) } - -emitWantedCts :: Cts -> TcM () --- Precondition: all wanted -emitWantedCts = mapBagM_ emit_wanted_ct - where emit_wanted_ct ct - | v <- cc_id ct - , Wanted loc <- cc_flavor ct - = emitFlat (EvVarX v loc) - | otherwise = panic "emitWantedCts: can't emit non-wanted!" + updTcRef lie_var (`addFlats` cts) } emitImplication :: Implication -> TcM () emitImplication ct @@ -1196,7 +1215,7 @@ getIfModule :: IfL Module getIfModule = do { env <- getLclEnv; return (if_mod env) } -------------------- -failIfM :: Message -> IfL a +failIfM :: MsgDoc -> IfL a -- The Iface monad doesn't have a place to accumulate errors, so we -- just fall over fast if one happens; it "shouldnt happen". -- We use IfL here so that we can get context info out of the local env diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 8b59a1224f..015510fb3f 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -54,15 +54,14 @@ module TcRnTypes( Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, singleCt, extendCts, isEmptyCts, isCTyEqCan, isCDictCan_Maybe, isCIPCan_Maybe, isCFunEqCan_Maybe, - isCIrredEvCan, isCNonCanonical, - SubGoalDepth, ctPred, + isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt, + isGivenCt_maybe, isGivenOrSolvedCt, + ctWantedLoc, + SubGoalDepth, mkNonCanonical, ctPred, WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC, andWC, addFlats, addImplics, mkFlatWC, - EvVarX(..), mkEvVarX, evVarOf, evVarX, evVarOfPred, - WantedEvVar, - Implication(..), CtLoc(..), ctLocSpan, ctLocOrigin, setCtLocOrigin, CtOrigin(..), EqOrigin(..), @@ -71,13 +70,15 @@ module TcRnTypes( SkolemInfo(..), - CtFlavor(..), pprFlavorArising, isWanted, - isGivenOrSolved, isGiven_maybe, isSolved, - isDerived, + CtFlavor(..), pprFlavorArising, + mkSolvedFlavor, mkGivenFlavor, mkWantedFlavor, + isWanted, isGivenOrSolved, isGiven_maybe, isSolved, + isDerived, getWantedLoc, canSolve, canRewrite, + combineCtLoc, -- Pretty printing - pprEvVarTheta, pprWantedEvVar, pprWantedsWithLocs, - pprEvVars, pprEvVarWithType, pprWantedEvVarWithLoc, + pprEvVarTheta, pprWantedsWithLocs, + pprEvVars, pprEvVarWithType, pprArising, pprArisingAt, -- Misc other types @@ -651,7 +652,7 @@ Note that: \begin{code} -type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, Message)) +type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, MsgDoc)) -- Monadic so that we have a chance -- to deal with bound type variables just before error -- message construction @@ -903,6 +904,8 @@ data Ct \end{code} \begin{code} +mkNonCanonical :: EvVar -> CtFlavor -> Ct +mkNonCanonical ev flav = CNonCanonical { cc_id = ev, cc_flavor = flav, cc_depth = 0} ctPred :: Ct -> PredType ctPred (CNonCanonical { cc_id = v }) = evVarPred v @@ -918,6 +921,57 @@ ctPred (CIrredEvCan { cc_ty = xi }) = xi \end{code} +%************************************************************************ +%* * + CtFlavor + The "flavor" of a canonical constraint +%* * +%************************************************************************ + +\begin{code} +ctWantedLoc :: Ct -> WantedLoc +-- Only works for Wanted/Derived +ctWantedLoc ct = ASSERT2( not (isGivenOrSolved (cc_flavor ct)), ppr ct ) + getWantedLoc (cc_flavor ct) + +isWantedCt :: Ct -> Bool +isWantedCt ct = isWanted (cc_flavor ct) + +isDerivedCt :: Ct -> Bool +isDerivedCt ct = isDerived (cc_flavor ct) + +isGivenCt_maybe :: Ct -> Maybe GivenKind +isGivenCt_maybe ct = isGiven_maybe (cc_flavor ct) + +isGivenOrSolvedCt :: Ct -> Bool +isGivenOrSolvedCt ct = isGivenOrSolved (cc_flavor ct) + +isCTyEqCan :: Ct -> Bool +isCTyEqCan (CTyEqCan {}) = True +isCTyEqCan (CFunEqCan {}) = False +isCTyEqCan _ = False + +isCDictCan_Maybe :: Ct -> Maybe Class +isCDictCan_Maybe (CDictCan {cc_class = cls }) = Just cls +isCDictCan_Maybe _ = Nothing + +isCIPCan_Maybe :: Ct -> Maybe (IPName Name) +isCIPCan_Maybe (CIPCan {cc_ip_nm = nm }) = Just nm +isCIPCan_Maybe _ = Nothing + +isCIrredEvCan :: Ct -> Bool +isCIrredEvCan (CIrredEvCan {}) = True +isCIrredEvCan _ = False + +isCFunEqCan_Maybe :: Ct -> Maybe TyCon +isCFunEqCan_Maybe (CFunEqCan { cc_fun = tc }) = Just tc +isCFunEqCan_Maybe _ = Nothing + +isCNonCanonical :: Ct -> Bool +isCNonCanonical (CNonCanonical {}) = True +isCNonCanonical _ = False +\end{code} + \begin{code} instance Outputable Ct where ppr ct = ppr (cc_flavor ct) <> braces (ppr (cc_depth ct)) @@ -951,31 +1005,6 @@ emptyCts = emptyBag isEmptyCts :: Cts -> Bool isEmptyCts = isEmptyBag - -isCTyEqCan :: Ct -> Bool -isCTyEqCan (CTyEqCan {}) = True -isCTyEqCan (CFunEqCan {}) = False -isCTyEqCan _ = False - -isCDictCan_Maybe :: Ct -> Maybe Class -isCDictCan_Maybe (CDictCan {cc_class = cls }) = Just cls -isCDictCan_Maybe _ = Nothing - -isCIPCan_Maybe :: Ct -> Maybe (IPName Name) -isCIPCan_Maybe (CIPCan {cc_ip_nm = nm }) = Just nm -isCIPCan_Maybe _ = Nothing - -isCIrredEvCan :: Ct -> Bool -isCIrredEvCan (CIrredEvCan {}) = True -isCIrredEvCan _ = False - -isCFunEqCan_Maybe :: Ct -> Maybe TyCon -isCFunEqCan_Maybe (CFunEqCan { cc_fun = tc }) = Just tc -isCFunEqCan_Maybe _ = Nothing - -isCNonCanonical :: Ct -> Bool -isCNonCanonical (CNonCanonical {}) = True -isCNonCanonical _ = False \end{code} %************************************************************************ @@ -992,7 +1021,7 @@ v%************************************************************************ \begin{code} data WantedConstraints - = WC { wc_flat :: Cts -- Unsolved constraints, all wanted + = WC { wc_flat :: Cts -- Unsolved constraints, all wanted , wc_impl :: Bag Implication , wc_insol :: Cts -- Insoluble constraints, can be -- wanted, given, or derived @@ -1022,12 +1051,9 @@ andWC (WC { wc_flat = f1, wc_impl = i1, wc_insol = n1 }) , wc_impl = i1 `unionBags` i2 , wc_insol = n1 `unionBags` n2 } -addFlats :: WantedConstraints -> Bag WantedEvVar -> WantedConstraints -addFlats wc wevs +addFlats :: WantedConstraints -> Bag Ct -> WantedConstraints +addFlats wc cts = wc { wc_flat = wc_flat wc `unionBags` cts } - where cts = mapBag mk_noncan wevs - mk_noncan (EvVarX v wl) - = CNonCanonical { cc_id = v, cc_flavor = Wanted wl, cc_depth = 0} addImplics :: WantedConstraints -> Bag Implication -> WantedConstraints addImplics wc implic = wc { wc_impl = wc_impl wc `unionBags` implic } @@ -1096,7 +1122,7 @@ data Implication -- However, we don't zonk ic_env when zonking the Implication -- Instead we do that when generating a skolem-escape error message - ic_skols :: TcTyVarSet, -- Introduced skolems + ic_skols :: [TcTyVar], -- Introduced skolems -- See Note [Skolems in an implication] ic_given :: [EvVar], -- Given evidence variables @@ -1163,38 +1189,11 @@ will be able to report a more informative error: %************************************************************************ %* * - EvVarX, WantedEvVar, FlavoredEvVar + Pretty printing %* * %************************************************************************ \begin{code} -data EvVarX a = EvVarX EvVar a - -- An evidence variable with accompanying info - -type WantedEvVar = EvVarX WantedLoc -- The location where it arose - - -instance Outputable (EvVarX a) where - ppr (EvVarX ev _) = pprEvVarWithType ev - -- If you want to see the associated info, - -- use a more specific printing function - -mkEvVarX :: EvVar -> a -> EvVarX a -mkEvVarX = EvVarX - -evVarOf :: EvVarX a -> EvVar -evVarOf (EvVarX ev _) = ev - -evVarX :: EvVarX a -> a -evVarX (EvVarX _ a) = a - -evVarOfPred :: EvVarX a -> PredType -evVarOfPred wev = evVarPred (evVarOf wev) - -\end{code} - - -\begin{code} pprEvVars :: [EvVar] -> SDoc -- Print with their types pprEvVars ev_vars = vcat (map pprEvVarWithType ev_vars) @@ -1209,11 +1208,6 @@ pprWantedsWithLocs wcs = vcat [ pprBag ppr (wc_flat wcs) , pprBag ppr (wc_impl wcs) , pprBag ppr (wc_insol wcs) ] - -pprWantedEvVarWithLoc, pprWantedEvVar :: WantedEvVar -> SDoc -pprWantedEvVarWithLoc (EvVarX v loc) = hang (pprEvVarWithType v) - 2 (pprArisingAt loc) -pprWantedEvVar (EvVarX v _) = pprEvVarWithType v \end{code} %************************************************************************ @@ -1242,6 +1236,11 @@ instance Outputable CtFlavor where ppr (Wanted {}) = ptext (sLit "[W]") ppr (Derived {}) = ptext (sLit "[D]") +getWantedLoc :: CtFlavor -> WantedLoc +getWantedLoc (Wanted wl) = wl +getWantedLoc (Derived wl) = wl +getWantedLoc flav@(Given {}) = pprPanic "getWantedLoc" (ppr flav) + pprFlavorArising :: CtFlavor -> SDoc pprFlavorArising (Derived wl) = pprArisingAt wl pprFlavorArising (Wanted wl) = pprArisingAt wl @@ -1266,6 +1265,52 @@ isGiven_maybe _ = Nothing isDerived :: CtFlavor -> Bool isDerived (Derived {}) = True isDerived _ = False + +canSolve :: CtFlavor -> CtFlavor -> Bool +-- canSolve ctid1 ctid2 +-- The constraint ctid1 can be used to solve ctid2 +-- "to solve" means a reaction where the active parts of the two constraints match. +-- active(F xis ~ xi) = F xis +-- active(tv ~ xi) = tv +-- active(D xis) = D xis +-- active(IP nm ty) = nm +-- +-- NB: either (a `canSolve` b) or (b `canSolve` a) must hold +----------------------------------------- +canSolve (Given {}) _ = True +canSolve (Wanted {}) (Derived {}) = True +canSolve (Wanted {}) (Wanted {}) = True +canSolve (Derived {}) (Derived {}) = True -- Important: derived can't solve wanted/given +canSolve _ _ = False -- (There is no *evidence* for a derived.) + +canRewrite :: CtFlavor -> CtFlavor -> Bool +-- canRewrite ctid1 ctid2 +-- The *equality_constraint* ctid1 can be used to rewrite inside ctid2 +canRewrite = canSolve + +combineCtLoc :: CtFlavor -> CtFlavor -> WantedLoc +-- Precondition: At least one of them should be wanted +combineCtLoc (Wanted loc) _ = loc +combineCtLoc _ (Wanted loc) = loc +combineCtLoc (Derived loc ) _ = loc +combineCtLoc _ (Derived loc ) = loc +combineCtLoc _ _ = panic "combineCtLoc: both given" + +mkSolvedFlavor :: CtFlavor -> SkolemInfo -> EvTerm -> CtFlavor +-- To be called when we actually solve a wanted/derived (perhaps leaving residual goals) +mkSolvedFlavor (Wanted loc) sk evterm = Given (setCtLocOrigin loc sk) (GivenSolved (Just evterm)) +mkSolvedFlavor (Derived loc) sk evterm = Given (setCtLocOrigin loc sk) (GivenSolved (Just evterm)) +mkSolvedFlavor fl@(Given {}) _sk _evterm = pprPanic "Solving a given constraint!" $ ppr fl + +mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor +mkGivenFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk) GivenOrig +mkGivenFlavor (Derived loc) sk = Given (setCtLocOrigin loc sk) GivenOrig +mkGivenFlavor fl@(Given {}) _sk = pprPanic "Solving a given constraint!" $ ppr fl + +mkWantedFlavor :: CtFlavor -> CtFlavor +mkWantedFlavor (Wanted loc) = Wanted loc +mkWantedFlavor (Derived loc) = Wanted loc +mkWantedFlavor fl@(Given {}) = pprPanic "mkWantedFlavor" (ppr fl) \end{code} %************************************************************************ @@ -1355,7 +1400,8 @@ data SkolemInfo | BracketSkol -- Template Haskell bracket | UnifyForAllSkol -- We are unifying two for-all types - TcType + [TcTyVar] -- The instantiated skolem variables + TcType -- The instantiated type *inside* the forall | UnkSkol -- Unhelpful info (until I improve it) @@ -1385,7 +1431,7 @@ pprSkolInfo (PatSkol dc mc) = sep [ ptext (sLit "a pattern with constructor") pprSkolInfo (InferSkol ids) = sep [ ptext (sLit "the inferred type of") , vcat [ ppr name <+> dcolon <+> ppr ty | (name,ty) <- ids ]] -pprSkolInfo (UnifyForAllSkol ty) = ptext (sLit "the type") <+> ppr ty +pprSkolInfo (UnifyForAllSkol tvs ty) = ptext (sLit "the type") <+> ppr (mkForAllTys tvs ty) -- UnkSkol -- For type variables the others are dealt with by pprSkolTvBinding. diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 1106c92dba..240ba9c017 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -30,7 +30,7 @@ module TcSMonad ( canRewrite, canSolve, combineCtLoc, mkSolvedFlavor, mkGivenFlavor, mkWantedFlavor, - getWantedLoc, + ctWantedLoc, TcS, runTcS, failTcS, panicTcS, traceTcS, -- Basic functionality traceFireTcS, bumpStepCountTcS, doWithInert, @@ -600,82 +600,6 @@ extractRelevantInerts wi \end{code} - - -%************************************************************************ -%* * - CtFlavor - The "flavor" of a canonical constraint -%* * -%************************************************************************ - -\begin{code} -getWantedLoc :: Ct -> WantedLoc -getWantedLoc ct - = ASSERT (isWanted (cc_flavor ct)) - case cc_flavor ct of - Wanted wl -> wl - _ -> pprPanic "Can't get WantedLoc of non-wanted constraint!" empty - -isWantedCt :: Ct -> Bool -isWantedCt ct = isWanted (cc_flavor ct) -isDerivedCt :: Ct -> Bool -isDerivedCt ct = isDerived (cc_flavor ct) - -isGivenCt_maybe :: Ct -> Maybe GivenKind -isGivenCt_maybe ct = isGiven_maybe (cc_flavor ct) - -isGivenOrSolvedCt :: Ct -> Bool -isGivenOrSolvedCt ct = isGivenOrSolved (cc_flavor ct) - - -canSolve :: CtFlavor -> CtFlavor -> Bool --- canSolve ctid1 ctid2 --- The constraint ctid1 can be used to solve ctid2 --- "to solve" means a reaction where the active parts of the two constraints match. --- active(F xis ~ xi) = F xis --- active(tv ~ xi) = tv --- active(D xis) = D xis --- active(IP nm ty) = nm --- --- NB: either (a `canSolve` b) or (b `canSolve` a) must hold ------------------------------------------ -canSolve (Given {}) _ = True -canSolve (Wanted {}) (Derived {}) = True -canSolve (Wanted {}) (Wanted {}) = True -canSolve (Derived {}) (Derived {}) = True -- Important: derived can't solve wanted/given -canSolve _ _ = False -- (There is no *evidence* for a derived.) - -canRewrite :: CtFlavor -> CtFlavor -> Bool --- canRewrite ctid1 ctid2 --- The *equality_constraint* ctid1 can be used to rewrite inside ctid2 -canRewrite = canSolve - -combineCtLoc :: CtFlavor -> CtFlavor -> WantedLoc --- Precondition: At least one of them should be wanted -combineCtLoc (Wanted loc) _ = loc -combineCtLoc _ (Wanted loc) = loc -combineCtLoc (Derived loc ) _ = loc -combineCtLoc _ (Derived loc ) = loc -combineCtLoc _ _ = panic "combineCtLoc: both given" - -mkSolvedFlavor :: CtFlavor -> SkolemInfo -> EvTerm -> CtFlavor --- To be called when we actually solve a wanted/derived (perhaps leaving residual goals) -mkSolvedFlavor (Wanted loc) sk evterm = Given (setCtLocOrigin loc sk) (GivenSolved (Just evterm)) -mkSolvedFlavor (Derived loc) sk evterm = Given (setCtLocOrigin loc sk) (GivenSolved (Just evterm)) -mkSolvedFlavor fl@(Given {}) _sk _evterm = pprPanic "Solving a given constraint!" $ ppr fl - -mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor -mkGivenFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk) GivenOrig -mkGivenFlavor (Derived loc) sk = Given (setCtLocOrigin loc sk) GivenOrig -mkGivenFlavor fl@(Given {}) _sk = pprPanic "Solving a given constraint!" $ ppr fl - -mkWantedFlavor :: CtFlavor -> CtFlavor -mkWantedFlavor (Wanted loc) = Wanted loc -mkWantedFlavor (Derived loc) = Wanted loc -mkWantedFlavor fl@(Given {}) = pprPanic "mkWantedFlavor" (ppr fl) -\end{code} - %************************************************************************ %* * %* The TcS solver monad * @@ -842,7 +766,7 @@ runTcS context untouch is wl tcs = do { ty_binds_var <- TcM.newTcRef emptyVarEnv ; ev_cache_var <- TcM.newTcRef $ EvVarCache { evc_cache = emptyTM, evc_flat_cache = emptyTM } - ; ev_binds_var@(EvBindsVar evb_ref _) <- TcM.newTcEvBinds + ; ev_binds_var <- TcM.newTcEvBinds ; step_count <- TcM.newTcRef 0 ; inert_var <- TcM.newTcRef is @@ -871,8 +795,8 @@ runTcS context untouch is wl tcs <+> int count <+> ppr context) } -- And return - ; ev_binds <- TcM.readTcRef evb_ref - ; return (res, evBindMapBinds ev_binds) } + ; ev_binds <- TcM.getTcEvBinds ev_binds_var + ; return (res, ev_binds) } where do_unification (tv,ty) = TcM.writeMetaTyVar tv ty diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index a36be651b4..39a0ab7985 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -40,6 +40,7 @@ import Control.Monad ( when ) import Outputable import FastString import TrieMap +import DynFlags \end{code} @@ -110,9 +111,9 @@ simplifyDeriv orig pred tvs theta ; wanted <- newFlatWanteds orig (substTheta skol_subst theta) ; traceTc "simplifyDeriv" (ppr tvs $$ ppr theta $$ ppr wanted) - ; (residual_wanted, _binds) - <- solveWanteds (SimplInfer doc) NoUntouchables $ - mkFlatWC wanted + ; (residual_wanted, _ev_binds1) + <- runTcS (SimplInfer doc) NoUntouchables emptyInert emptyWorkList $ + solveWanteds $ mkFlatWC wanted ; let (good, bad) = partitionBagWith get_good (wc_flat residual_wanted) -- See Note [Exotic derived instance contexts] @@ -121,7 +122,9 @@ simplifyDeriv orig pred tvs theta | otherwise = Right ct where p = ctPred ct - ; reportUnsolved (residual_wanted { wc_flat = bad }) + -- We never want to defer these errors because they are errors in the + -- compiler! Hence the `False` below + ; _ev_binds2 <- reportUnsolved False (residual_wanted { wc_flat = bad }) ; let min_theta = mkMinimalBySCs (bagToList good) ; return (substTheta subst_skol min_theta) } @@ -247,6 +250,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds = do { zonked_wanteds <- zonkWC wanteds ; zonked_taus <- zonkTcTypes (map snd name_taus) ; gbl_tvs <- tcGetGlobalTyVars + ; runtimeCoercionErrors <- doptM Opt_DeferTypeErrors ; traceTc "simplifyInfer {" $ vcat [ ptext (sLit "names =") <+> ppr (map fst name_taus) @@ -274,46 +278,50 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds , ptext (sLit "surely_fref =") <+> ppr surely_free ] - ; emitWantedCts surely_free + ; emitFlats surely_free ; traceTc "sinf" $ vcat [ ptext (sLit "perhaps_bound =") <+> ppr perhaps_bound , ptext (sLit "surely_free =") <+> ppr surely_free ] -- Step 2 - -- Now simplify the possibly-bound constraints - ; (simpl_results, tc_binds0) - <- runTcS (SimplInfer (ppr (map fst name_taus))) NoUntouchables emptyInert emptyWorkList $ - simplifyWithApprox (zonked_wanteds { wc_flat = perhaps_bound }) - - ; when (insolubleWC simpl_results) -- Fail fast if there is an insoluble constraint - (do { reportUnsolved simpl_results; failM }) + -- Now simplify the possibly-bound constraints + ; let ctxt = SimplInfer (ppr (map fst name_taus)) + ; (simpl_results, tc_binds) + <- runTcS ctxt NoUntouchables emptyInert emptyWorkList $ + simplifyWithApprox (zonked_wanteds { wc_flat = perhaps_bound }) + + -- Fail fast if there is an insoluble constraint, + -- unless we are deferring errors to runtime + ; when (not runtimeCoercionErrors && insolubleWC simpl_results) $ + do { _ev_binds <- reportUnsolved False simpl_results + ; failM } -- Step 3 -- Split again simplified_perhaps_bound, because some unifications -- may have happened, and emit the free constraints. ; gbl_tvs <- tcGetGlobalTyVars ; zonked_tau_tvs <- zonkTcTyVarsAndFV zonked_tau_tvs - ; zonked_simples <- zonkCts (wc_flat simpl_results) + ; zonked_flats <- zonkCts (wc_flat simpl_results) ; let init_tvs = zonked_tau_tvs `minusVarSet` gbl_tvs - poly_qtvs = growWantedEVs gbl_tvs zonked_simples init_tvs - (pbound, pfree) = partitionBag (quantifyMe poly_qtvs) zonked_simples + poly_qtvs = growWantedEVs gbl_tvs zonked_flats init_tvs + (pbound, pfree) = partitionBag (quantifyMe poly_qtvs) zonked_flats -- Monomorphism restriction mr_qtvs = init_tvs `minusVarSet` constrained_tvs - constrained_tvs = tyVarsOfCts zonked_simples + constrained_tvs = tyVarsOfCts zonked_flats mr_bites = apply_mr && not (isEmptyBag pbound) (qtvs, (bound, free)) - | mr_bites = (mr_qtvs, (emptyBag, zonked_simples)) + | mr_bites = (mr_qtvs, (emptyBag, zonked_flats)) | otherwise = (poly_qtvs, (pbound, pfree)) - ; emitWantedCts free + ; emitFlats free ; if isEmptyVarSet qtvs && isEmptyBag bound then ASSERT( isEmptyBag (wc_insol simpl_results) ) do { traceTc "} simplifyInfer/no quantification" empty ; emitImplications (wc_impl simpl_results) - ; return ([], [], mr_bites, EvBinds tc_binds0) } + ; return ([], [], mr_bites, EvBinds tc_binds) } else do -- Step 4, zonk quantified variables @@ -331,12 +339,13 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds -- Minimize `bound' and emit an implication ; minimal_bound_ev_vars <- mapM TcMType.newEvVar minimal_flat_preds ; ev_binds_var <- newTcEvBinds - ; mapBagM_ (\(EvBind evar etrm) -> addTcEvBind ev_binds_var evar etrm) tc_binds0 + ; mapBagM_ (\(EvBind evar etrm) -> addTcEvBind ev_binds_var evar etrm) + tc_binds ; lcl_env <- getLclTypeEnv ; gloc <- getCtLoc skol_info ; let implic = Implic { ic_untch = NoUntouchables , ic_env = lcl_env - , ic_skols = mkVarSet qtvs_to_return + , ic_skols = qtvs_to_return , ic_given = minimal_bound_ev_vars , ic_wanted = simpl_results { wc_flat = bound } , ic_insol = False @@ -347,7 +356,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds vcat [ ptext (sLit "implic =") <+> ppr implic -- ic_skols, ic_given give rest of result , ptext (sLit "qtvs =") <+> ppr qtvs_to_return - , ptext (sLit "spb =") <+> ppr zonked_simples + , ptext (sLit "spb =") <+> ppr zonked_flats , ptext (sLit "bound =") <+> ppr bound ] @@ -405,7 +414,7 @@ approximateImplications impls float_implic skols imp = (unitBag (imp { ic_wanted = wanted' }), floats) where - (wanted', floats) = float_wc (skols `unionVarSet` ic_skols imp) (ic_wanted imp) + (wanted', floats) = float_wc (skols `extendVarSetList` ic_skols imp) (ic_wanted imp) float_wc skols wc@(WC { wc_flat = flat, wc_impl = implic }) = (wc { wc_flat = flat', wc_impl = implic' }, floats1 `unionBags` floats2) @@ -444,7 +453,7 @@ growImplics gbl_tvs implics tvs = foldrBag grow_implic tvs implics where grow_implic implic tvs - = grow tvs `minusVarSet` ic_skols implic + = grow tvs `delVarSetList` ic_skols implic where grow = growWC gbl_tvs (ic_wanted implic) . growPreds gbl_tvs evVarPred (listToBag (ic_given implic)) @@ -568,7 +577,7 @@ Consider f :: (forall a. Eq a => a->a) -> Bool -> ... {-# RULES "foo" forall (v::forall b. Eq b => b->b). f b True = ... - #=} + #-} Here we *must* solve the wanted (Eq a) from the given (Eq a) resulting from skolemising the agument type of g. So we revert to SimplCheck when going under an implication. @@ -590,7 +599,8 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted -- variables; hence *no untouchables* ; (lhs_results, lhs_binds) - <- solveWanteds (SimplRuleLhs name) untch zonked_lhs + <- runTcS (SimplRuleLhs name) untch emptyInert emptyWorkList $ + solveWanteds zonked_lhs ; traceTc "simplifyRule" $ vcat [ text "zonked_lhs" <+> ppr zonked_lhs @@ -609,7 +619,7 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted ; ev_binds_var <- newTcEvBinds ; emitImplication $ Implic { ic_untch = untch , ic_env = emptyNameEnv - , ic_skols = mkVarSet tv_bndrs + , ic_skols = tv_bndrs , ic_given = lhs_dicts , ic_wanted = lhs_results { wc_flat = eqs } , ic_insol = insolubleWC lhs_results @@ -638,7 +648,7 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted , wc_impl = unitBag $ Implic { ic_untch = NoUntouchables , ic_env = emptyNameEnv - , ic_skols = mkVarSet tv_bndrs + , ic_skols = tv_bndrs , ic_given = lhs_dicts , ic_wanted = rhs_wanted , ic_insol = insolubleWC rhs_wanted @@ -680,29 +690,66 @@ simplifyCheck ctxt wanteds ; traceTc "simplifyCheck {" (vcat [ ptext (sLit "wanted =") <+> ppr wanteds ]) - ; (unsolved, ev_binds) <- - solveWanteds ctxt NoUntouchables wanteds + ; (unsolved, eb1) + <- runTcS ctxt NoUntouchables emptyInert emptyWorkList $ + solveWanteds wanteds + + ; traceTc "simplifyCheck }" $ ptext (sLit "unsolved =") <+> ppr unsolved - ; traceTc "simplifyCheck }" $ - ptext (sLit "unsolved =") <+> ppr unsolved + -- See Note [Deferring coercion errors to runtime] + ; runtimeCoercionErrors <- doptM Opt_DeferTypeErrors + ; eb2 <- reportUnsolved runtimeCoercionErrors unsolved + + ; return (eb1 `unionBags` eb2) } +\end{code} - ; reportUnsolved unsolved +Note [Deferring coercion errors to runtime] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ; return ev_binds } +While developing, sometimes it is desirable to allow compilation to succeed even +if there are type errors in the code. Consider the following case: ----------------- -solveWanteds :: SimplContext - -> Untouchables - -> WantedConstraints - -> TcM (WantedConstraints, Bag EvBind) + module Main where + + a :: Int + a = 'a' + + main = print "b" + +Even though `a` is ill-typed, it is not used in the end, so if all that we're +interested in is `main` it is handy to be able to ignore the problems in `a`. + +Since we treat type equalities as evidence, this is relatively simple. Whenever +we run into a type mismatch in TcUnify, we normally just emit an error. But it +is always safe to defer the mismatch to the main constraint solver. If we do +that, `a` will get transformed into + + co :: Int ~ Char + co = ... + + a :: Int + a = 'a' `cast` co + +The constraint solver would realize that `co` is an insoluble constraint, and +emit an error with `reportUnsolved`. But we can also replace the right-hand side +of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program +to compile, and it will run fine unless we evaluate `a`. This is what +`deferErrorsToRuntime` does. + +It does this by keeping track of which errors correspond to which coercion +in TcErrors (with ErrEnv). TcErrors.reportTidyWanteds does not print the errors +and does not fail if -fwarn-type-errors is on, so that we can continue +compilation. The errors are turned into warnings in `reportUnsolved`. + +\begin{code} +solveWanteds :: WantedConstraints -> TcS WantedConstraints -- Returns: residual constraints, plus evidence bindings -- NB: When we are called from TcM there are no inerts to pass down to TcS -solveWanteds ctxt untch wanted - = do { (wc_out, ev_binds) <- runTcS ctxt untch emptyInert emptyWorkList $ - solve_wanteds wanted +solveWanteds wanted + = do { wc_out <- solve_wanteds wanted ; let wc_ret = wc_out { wc_flat = keepWanted (wc_flat wc_out) } -- Discard Derived - ; return (wc_ret, ev_binds) } + ; return wc_ret } solve_wanteds :: WantedConstraints -> TcS WantedConstraints -- NB: wc_flats may be wanted *or* derived now @@ -874,7 +921,7 @@ solveImplication tcs_untouchables -- and we are back to the original inerts -floatEqualities :: TcTyVarSet -> [EvVar] -> Cts -> (Cts, Cts) +floatEqualities :: [TcTyVar] -> [EvVar] -> Cts -> (Cts, Cts) -- Post: The returned FlavoredEvVar's are only Wanted or Derived -- and come from the input wanted ev vars or deriveds floatEqualities skols can_given wantders @@ -882,11 +929,12 @@ floatEqualities skols can_given wantders -- Note [Float Equalities out of Implications] | otherwise = partitionBag is_floatable wantders - where is_floatable :: Ct -> Bool + where skol_set = mkVarSet skols + is_floatable :: Ct -> Bool is_floatable ct | ct_predty <- ctPred ct , isEqPred ct_predty - = skols `disjointVarSet` tvs_under_fsks ct_predty + = skol_set `disjointVarSet` tvs_under_fsks ct_predty is_floatable _ct = False tvs_under_fsks :: Type -> TyVarSet diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 6346480b98..56fa95300b 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -748,7 +748,7 @@ deprecatedDollar quoter data MetaOps th_syn hs_syn = MT { mt_desc :: String -- Type of beast (expression, type etc) , mt_show :: th_syn -> String -- How to show the th_syn thing - , mt_cvt :: SrcSpan -> th_syn -> Either Message hs_syn + , mt_cvt :: SrcSpan -> th_syn -> Either MsgDoc hs_syn -- How to convert to hs_syn } @@ -801,7 +801,7 @@ runMetaD = runMetaQ declMetaOps --------------- runMeta :: (Outputable hs_syn) => Bool -- Whether code should be printed in the exception message - -> (SrcSpan -> x -> TcM (Either Message hs_syn)) -- How to run x + -> (SrcSpan -> x -> TcM (Either MsgDoc hs_syn)) -- How to run x -> LHsExpr Id -- Of type x; typically x = Q TH.Exp, or something like that -> TcM hs_syn -- Of type t runMeta show_code run_and_convert expr @@ -902,8 +902,8 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where ; let i = getKey u ; return (TH.mkNameU s i) } - qReport True msg = addErr (text msg) - qReport False msg = addReport (text msg) empty + qReport True msg = addErr (text msg) + qReport False msg = addWarn (text msg) qLocation = do { m <- getModule ; l <- getSrcSpanM diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index d4d2642315..fa59db97da 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -58,7 +58,7 @@ module TcType ( -- Predicates. -- Again, newtypes are opaque eqType, eqTypes, eqPred, cmpType, cmpTypes, cmpPred, eqTypeX, - eqKind, + pickyEqType, eqKind, isSigmaTy, isOverloadedTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy, isIntegerTy, isBoolTy, isUnitTy, isCharTy, @@ -90,6 +90,7 @@ module TcType ( tidyOpenKind, tidyTyVarBndr, tidyFreeTyVars, tidyOpenTyVar, tidyOpenTyVars, + tidyTyVarOcc, tidyTopType, tidyKind, tidyCo, tidyCos, @@ -473,7 +474,24 @@ tidyTyVarBndr tidy_env@(occ_env, subst) tyvar tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv -- ^ Add the free 'TyVar's to the env in tidy form, -- so that we can tidy the type they are free in -tidyFreeTyVars env tyvars = fst (tidyOpenTyVars env (varSetElems tyvars)) +tidyFreeTyVars (full_occ_env, var_env) tyvars + = fst (tidyOpenTyVars (trimmed_occ_env, var_env) tv_list) + + where + tv_list = varSetElems tyvars + + trimmed_occ_env = foldr mk_occ_env emptyOccEnv tv_list + -- The idea here is that we restrict the new TidyEnv to the + -- _free_ vars of the type, so that we don't gratuitously rename + -- the _bound_ variables of the type + + mk_occ_env :: TyVar -> TidyOccEnv -> TidyOccEnv + mk_occ_env tv env + = case lookupOccEnv full_occ_env occ of + Just n -> extendOccEnv env occ n + Nothing -> env + where + occ = getOccName tv --------------- tidyOpenTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar]) @@ -490,26 +508,18 @@ tidyOpenTyVar env@(_, subst) tyvar Nothing -> tidyTyVarBndr env tyvar -- Treat it as a binder --------------- -tidyType :: TidyEnv -> Type -> Type -tidyType env@(_, subst) ty - = go ty +tidyTyVarOcc :: TidyEnv -> TyVar -> Type +tidyTyVarOcc env@(_, subst) tv + = case lookupVarEnv subst tv of + Nothing -> expand tv + Just tv' -> expand tv' where - go (TyVarTy tv) = case lookupVarEnv subst tv of - Nothing -> expand tv - Just tv' -> expand tv' - go (TyConApp tycon tys) = let args = map go tys - in args `seqList` TyConApp tycon args - go (AppTy fun arg) = (AppTy $! (go fun)) $! (go arg) - go (FunTy fun arg) = (FunTy $! (go fun)) $! (go arg) - go (ForAllTy tv ty) = ForAllTy tvp $! (tidyType envp ty) - where - (envp, tvp) = tidyTyVarBndr env tv - -- Expand FlatSkols, the skolems introduced by flattening process -- We don't want to show them in type error messages expand tv | isTcTyVar tv , FlatSkol ty <- tcTyVarDetails tv - = go ty + = WARN( True, text "I DON'T THINK THIS SHOULD EVER HAPPEN" <+> ppr tv <+> ppr ty ) + tidyType env ty | otherwise = TyVarTy tv @@ -518,6 +528,17 @@ tidyTypes :: TidyEnv -> [Type] -> [Type] tidyTypes env tys = map (tidyType env) tys --------------- +tidyType :: TidyEnv -> Type -> Type +tidyType env (TyVarTy tv) = tidyTyVarOcc env tv +tidyType env (TyConApp tycon tys) = let args = tidyTypes env tys + in args `seqList` TyConApp tycon args +tidyType env (AppTy fun arg) = (AppTy $! (tidyType env fun)) $! (tidyType env arg) +tidyType env (FunTy fun arg) = (FunTy $! (tidyType env fun)) $! (tidyType env arg) +tidyType env (ForAllTy tv ty) = ForAllTy tvp $! (tidyType envp ty) + where + (envp, tvp) = tidyTyVarBndr env tv + +--------------- -- | Grabs the free type variables, tidies them -- and then uses 'tidyType' to work over the type itself tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type) @@ -1000,7 +1021,25 @@ tcInstHeadTyAppAllTyVars ty get_tv _ = Nothing \end{code} - +\begin{code} +pickyEqType :: TcType -> TcType -> Bool +-- Check when two types _look_ the same, _including_ synonyms. +-- So (pickyEqType String [Char]) returns False +pickyEqType ty1 ty2 + = go init_env ty1 ty2 + where + init_env = mkRnEnv2 (mkInScopeSet (tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2)) + go env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 == rnOccR env tv2 + go env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = go (rnBndr2 env tv1 tv2) t1 t2 + go env (AppTy s1 t1) (AppTy s2 t2) = go env s1 s2 && go env t1 t2 + go env (FunTy s1 t1) (FunTy s2 t2) = go env s1 s2 && go env t1 t2 + go env (TyConApp tc1 ts1) (TyConApp tc2 ts2) = (tc1 == tc2) && gos env ts1 ts2 + go _ _ _ = False + + gos _ [] [] = True + gos env (t1:ts1) (t2:ts2) = go env t1 t2 && gos env ts1 ts2 + gos _ _ _ = False +\end{code} %************************************************************************ %* * diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 23de50af56..a6e1db183c 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -31,7 +31,7 @@ module TcUnify ( matchExpectedFunTys, matchExpectedFunKind, wrapFunResCoercion, - failWithMisMatch, + wrapEqCtxt, -------------------------------- -- Errors @@ -148,11 +148,6 @@ matchExpectedFunTys herald arity orig_ty = do { (co, tys, ty_r) <- go (n_req-1) res_ty ; return (mkTcFunCo (mkTcReflCo arg_ty) co, arg_ty:tys, ty_r) } - go _ (TyConApp tc _) -- A common case - | not (isSynFamilyTyCon tc) - = do { (env,msg) <- mk_ctxt emptyTidyEnv - ; failWithTcM (env,msg) } - go n_req ty@(TyVarTy tv) | ASSERT( isTcTyVar tv) isMetaTyVar tv = do { cts <- readMetaTyVar tv @@ -172,7 +167,7 @@ matchExpectedFunTys herald arity orig_ty ; return (co, arg_tys, res_ty) } ------------ - mk_ctxt :: TidyEnv -> TcM (TidyEnv, Message) + mk_ctxt :: TidyEnv -> TcM (TidyEnv, MsgDoc) mk_ctxt env = do { orig_ty1 <- zonkTcType orig_ty ; let (env', orig_ty2) = tidyOpenType env orig_ty1 (args, _) = tcSplitFunTys orig_ty2 @@ -449,7 +444,7 @@ newImplication skol_info skol_tvs given thing_inside ; loc <- getCtLoc skol_info ; emitImplication $ Implic { ic_untch = untch , ic_env = lcl_env - , ic_skols = mkVarSet skol_tvs + , ic_skols = skol_tvs , ic_given = given , ic_wanted = wanted , ic_insol = insolubleWC wanted @@ -536,11 +531,11 @@ uType, uType_np, uType_defer -------------- -- It is always safe to defer unification to the main constraint solver -- See Note [Deferred unification] -uType_defer (item : origin) ty1 ty2 - = wrapEqCtxt origin $ +uType_defer items ty1 ty2 + = ASSERT( not (null items) ) do { eqv <- newEq ty1 ty2 - ; loc <- getCtLoc (TypeEqOrigin item) - ; emitFlat (mkEvVarX eqv loc) + ; loc <- getCtLoc (TypeEqOrigin (last items)) + ; emitFlat (mkNonCanonical eqv (Wanted loc)) -- Error trace only -- NB. do *not* call mkErrInfo unless tracing is on, because @@ -549,11 +544,9 @@ uType_defer (item : origin) ty1 ty2 { ctxt <- getErrCtxt ; doc <- mkErrInfo emptyTidyEnv ctxt ; traceTc "utype_defer" (vcat [ppr eqv, ppr ty1, - ppr ty2, ppr origin, doc]) + ppr ty2, ppr items, doc]) } ; return (mkTcCoVarCo eqv) } -uType_defer [] _ _ - = panic "uType_defer" -------------- -- Push a new item on the origin stack (the most common case) @@ -572,9 +565,6 @@ uType_np origin orig_ty1 orig_ty2 else traceTc "u_tys yields coercion:" (ppr co) ; return co } where - bale_out :: [EqOrigin] -> TcM a - bale_out origin = failWithMisMatch origin - go :: TcType -> TcType -> TcM TcCoercion -- The arguments to 'go' are always semantically identical -- to orig_ty{1,2} except for looking through type synonyms @@ -583,8 +573,16 @@ uType_np origin orig_ty1 orig_ty2 -- Note that we pass in *original* (before synonym expansion), -- so that type variables tend to get filled in with -- the most informative version of the type - go (TyVarTy tyvar1) ty2 = uVar origin NotSwapped tyvar1 ty2 - go ty1 (TyVarTy tyvar2) = uVar origin IsSwapped tyvar2 ty1 + go (TyVarTy tv1) ty2 + = do { lookup_res <- lookupTcTyVar tv1 + ; case lookup_res of + Filled ty1 -> go ty1 ty2 + Unfilled ds1 -> uUnfilledVar origin NotSwapped tv1 ds1 ty2 } + go ty1 (TyVarTy tv2) + = do { lookup_res <- lookupTcTyVar tv2 + ; case lookup_res of + Filled ty2 -> go ty1 ty2 + Unfilled ds2 -> uUnfilledVar origin IsSwapped tv2 ds2 ty1 } -- See Note [Expanding synonyms during unification] -- @@ -612,62 +610,61 @@ uType_np origin orig_ty1 orig_ty2 | isSynFamilyTyCon tc2 = uType_defer origin ty1 ty2 go (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | tc1 == tc2 -- See Note [TyCon app] - = do { cos <- uList origin uType tys1 tys2 + -- See Note [Mismatched type lists and application decomposition] + | tc1 == tc2, length tys1 == length tys2 + = do { cos <- zipWithM (uType origin) tys1 tys2 ; return $ mkTcTyConAppCo tc1 cos } -- See Note [Care with type applications] - go (AppTy s1 t1) ty2 - | Just (s2,t2) <- tcSplitAppTy_maybe ty2 - = do { co_s <- uType_np origin s1 s2 -- See Note [Unifying AppTy] - ; co_t <- uType origin t1 t2 - ; return $ mkTcAppCo co_s co_t } + -- Do not decompose FunTy against App; + -- it's often a type error, so leave it for the constraint solver + go (AppTy s1 t1) (AppTy s2 t2) + = go_app s1 t1 s2 t2 - go ty1 (AppTy s2 t2) - | Just (s1,t1) <- tcSplitAppTy_maybe ty1 - = do { co_s <- uType_np origin s1 s2 - ; co_t <- uType origin t1 t2 - ; return $ mkTcAppCo co_s co_t } + go (AppTy s1 t1) (TyConApp tc2 ts2) + | Just (ts2', t2') <- snocView ts2 + = ASSERT( isDecomposableTyCon tc2 ) + go_app s1 t1 (TyConApp tc2 ts2') t2' + + go (TyConApp tc1 ts1) (AppTy s2 t2) + | Just (ts1', t1') <- snocView ts1 + = ASSERT( isDecomposableTyCon tc1 ) + go_app (TyConApp tc1 ts1') t1' s2 t2 go ty1 ty2 | tcIsForAllTy ty1 || tcIsForAllTy ty2 = unifySigmaTy origin ty1 ty2 -- Anything else fails - go _ _ = bale_out origin + go ty1 ty2 = uType_defer origin ty1 ty2 -- failWithMisMatch origin + + ------------------ + go_app s1 t1 s2 t2 + = do { co_s <- uType_np origin s1 s2 -- See Note [Unifying AppTy] + ; co_t <- uType origin t1 t2 + ; return $ mkTcAppCo co_s co_t } unifySigmaTy :: [EqOrigin] -> TcType -> TcType -> TcM TcCoercion unifySigmaTy origin ty1 ty2 = do { let (tvs1, body1) = tcSplitForAllTys ty1 (tvs2, body2) = tcSplitForAllTys ty2 - ; unless (equalLength tvs1 tvs2) (failWithMisMatch origin) - ; skol_tvs <- tcInstSkolTyVars tvs1 + + ; defer_or_continue (not (equalLength tvs1 tvs2)) $ do { + skol_tvs <- tcInstSkolTyVars tvs1 -- Get location from monad, not from tvs1 ; let tys = mkTyVarTys skol_tvs in_scope = mkInScopeSet (mkVarSet skol_tvs) phi1 = Type.substTy (mkTvSubst in_scope (zipTyEnv tvs1 tys)) body1 phi2 = Type.substTy (mkTvSubst in_scope (zipTyEnv tvs2 tys)) body2 - skol_info = UnifyForAllSkol ty1 + skol_info = UnifyForAllSkol skol_tvs phi1 ; (ev_binds, co) <- checkConstraints skol_info skol_tvs [] $ uType origin phi1 phi2 - ; return (foldr mkTcForAllCo (TcLetCo ev_binds co) skol_tvs) } - ---------------- -uList :: [EqOrigin] - -> ([EqOrigin] -> a -> a -> TcM b) - -> [a] -> [a] -> TcM [b] --- Unify corresponding elements of two lists of types, which --- should be of equal length. We charge down the list explicitly so that --- we can complain if their lengths differ. -uList _ _ [] [] = return [] -uList origin unify (ty1:tys1) (ty2:tys2) = do { x <- unify origin ty1 ty2; - ; xs <- uList origin unify tys1 tys2 - ; return (x:xs) } -uList origin _ _ _ = failWithMisMatch origin - -- See Note [Mismatched type lists and application decomposition] - + ; return (foldr mkTcForAllCo (TcLetCo ev_binds co) skol_tvs) } } + where + defer_or_continue True _ = uType_defer origin ty1 ty2 + defer_or_continue False m = m \end{code} Note [Care with type applications] @@ -679,7 +676,7 @@ so if one type is an App the other one jolly well better be too Note [Unifying AppTy] ~~~~~~~~~~~~~~~~~~~~~ -Considerm unifying (m Int) ~ (IO Int) where m is a unification variable +Consider unifying (m Int) ~ (IO Int) where m is a unification variable that is now bound to (say) (Bool ->). Then we want to report "Can't unify (Bool -> Int) with (IO Int) and not @@ -687,16 +684,6 @@ and not That is why we use the "_np" variant of uType, which does not alter the error message. -Note [TyCon app] -~~~~~~~~~~~~~~~~ -When we find two TyConApps, the argument lists are guaranteed equal -length. Reason: intially the kinds of the two types to be unified is -the same. The only way it can become not the same is when unifying two -AppTys (f1 a1)~(f2 a2). In that case there can't be a TyConApp in -the f1,f2 (because it'd absorb the app). If we unify f1~f2 first, -which we do, that ensures that f1,f2 have the same kind; and that -means a1,a2 have the same kind. And now the argument repeats. - Note [Mismatched type lists and application decomposition] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we find two TyConApps, you might think that the argument lists @@ -765,20 +752,6 @@ of the substitution; rather, notice that @uVar@ (defined below) nips back into @uTys@ if it turns out that the variable is already bound. \begin{code} -uVar :: [EqOrigin] -> SwapFlag -> TcTyVar -> TcTauType -> TcM TcCoercion -uVar origin swapped tv1 ty2 - = do { traceTc "uVar" (vcat [ ppr origin - , ppr swapped - , ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1) - , nest 2 (ptext (sLit " ~ ")) - , ppr ty2 <+> dcolon <+> ppr (typeKind ty2)]) - ; details <- lookupTcTyVar tv1 - ; case details of - Filled ty1 -> unSwap swapped (uType_np origin) ty1 ty2 - Unfilled details1 -> uUnfilledVar origin swapped tv1 details1 ty2 - } - ----------------- uUnfilledVar :: [EqOrigin] -> SwapFlag -> TcTyVar -> TcTyVarDetails -- Tyvar 1 @@ -923,15 +896,11 @@ checkTauTvUpdate tv ty Note [Avoid deferring] ~~~~~~~~~~~~~~~~~~~~~~ -We try to avoid creating deferred constraints for two reasons. - * First, efficiency. - * Second, currently we can only defer some constraints - under a forall. See unifySigmaTy. -So expanding synonyms here is a good thing to do. Example (Trac #4917) +We try to avoid creating deferred constraints only for efficiency. +Example (Trac #4917) a ~ Const a b where type Const a b = a. We can solve this immediately, even when -'a' is a skolem, just by expanding the synonym; and we should do so - in case this unification happens inside unifySigmaTy (sigh). +'a' is a skolem, just by expanding the synonym. Note [Type synonyms and the occur check] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1041,29 +1010,6 @@ wrapEqCtxt :: [EqOrigin] -> TcM a -> TcM a -- comes from the outermost item wrapEqCtxt [] thing_inside = thing_inside wrapEqCtxt items thing_inside = addErrCtxtM (unifyCtxt (last items)) thing_inside - ---------------- -failWithMisMatch :: [EqOrigin] -> TcM a --- Generate the message when two types fail to match, --- going to some trouble to make it helpful. --- We take the failing types from the top of the origin stack --- rather than reporting the particular ones we are looking --- at right now -failWithMisMatch (item:origin) - = wrapEqCtxt origin $ - do { ty_act <- zonkTcType (uo_actual item) - ; ty_exp <- zonkTcType (uo_expected item) - ; env0 <- tcInitTidyEnv - ; let (env1, pp_exp) = tidyOpenType env0 ty_exp - (env2, pp_act) = tidyOpenType env1 ty_act - ; failWithTcM (env2, misMatchMsg pp_act pp_exp) } -failWithMisMatch [] - = panic "failWithMisMatch" - -misMatchMsg :: TcType -> TcType -> SDoc -misMatchMsg ty_act ty_exp - = sep [ ptext (sLit "Couldn't match expected type") <+> quotes (ppr ty_exp) - , nest 12 $ ptext (sLit "with actual type") <+> quotes (ppr ty_act)] \end{code} @@ -1377,7 +1323,7 @@ These two context are used with checkSigTyVars \begin{code} sigCtxt :: Id -> [TcTyVar] -> TcThetaType -> TcTauType - -> TidyEnv -> TcM (TidyEnv, Message) + -> TidyEnv -> TcM (TidyEnv, MsgDoc) sigCtxt id sig_tvs sig_theta sig_tau tidy_env = do actual_tau <- zonkTcType sig_tau let diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index ee0749a78a..1e99775906 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -454,7 +454,7 @@ where the 'Left b' indicates that 'b' can be freely instantiated. -- lookupUniqueInstEnv :: (InstEnv, InstEnv) -> Class -> [Type] - -> Either Message (ClsInst, [Type]) + -> Either MsgDoc (ClsInst, [Type]) lookupUniqueInstEnv instEnv cls tys = case lookupInstEnv instEnv cls tys of ([(inst, inst_tys)], _, _) diff --git a/compiler/types/Unify.lhs b/compiler/types/Unify.lhs index 9a8cafc9ec..7d648aef7e 100644 --- a/compiler/types/Unify.lhs +++ b/compiler/types/Unify.lhs @@ -579,7 +579,7 @@ data BindFlag \begin{code} newtype UM a = UM { unUM :: (TyVar -> BindFlag) - -> MaybeErr Message a } + -> MaybeErr MsgDoc a } instance Monad UM where return a = UM (\_tvs -> Succeeded a) @@ -588,13 +588,13 @@ instance Monad UM where Failed err -> Failed err Succeeded v -> unUM (k v) tvs) -initUM :: (TyVar -> BindFlag) -> UM a -> MaybeErr Message a +initUM :: (TyVar -> BindFlag) -> UM a -> MaybeErr MsgDoc a initUM badtvs um = unUM um badtvs tvBindFlag :: TyVar -> UM BindFlag tvBindFlag tv = UM (\tv_fn -> Succeeded (tv_fn tv)) -failWith :: Message -> UM a +failWith :: MsgDoc -> UM a failWith msg = UM (\_tv_fn -> Failed msg) maybeErrToMaybe :: MaybeErr fail succ -> Maybe succ diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index 6ce948a6af..ecce941082 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -1167,17 +1167,17 @@ </row> <row> - <entry><option>-fwarn-unrecognised-pragmas</option></entry> - <entry>warn about uses of pragmas that GHC doesn't recognise</entry> + <entry><option>-fdefer-type-errors</option></entry> + <entry>Defer as many type errors as possible until runtime.</entry> <entry>dynamic</entry> - <entry><option>-fno-warn-unrecognised-pragmas</option></entry> + <entry><option>-fno-defer-type-errors</option></entry> </row> <row> - <entry><option>-fwarn-warnings-deprecations</option></entry> - <entry>warn about uses of functions & types that have warnings or deprecated pragmas</entry> + <entry><option>-fhelpful-errors</option></entry> + <entry>Make suggestions for mis-spelled names.</entry> <entry>dynamic</entry> - <entry><option>-fno-warn-warnings-deprecations</option></entry> + <entry><option>-fno-helpful-errors</option></entry> </row> <row> @@ -1282,6 +1282,13 @@ </row> <row> + <entry><option>-fwarn-monomorphism-restriction</option></entry> + <entry>warn when the Monomorphism Restriction is applied</entry> + <entry>dynamic</entry> + <entry><option>-fno-warn-monomorphism-restriction</option></entry> + </row> + + <row> <entry><option>-fwarn-name-shadowing</option></entry> <entry>warn when names are shadowed</entry> <entry>dynamic</entry> @@ -1318,10 +1325,10 @@ </row> <row> - <entry><option>-fwarn-monomorphism-restriction</option></entry> - <entry>warn when the Monomorphism Restriction is applied</entry> + <entry><option>-fwarn-unrecognised-pragmas</option></entry> + <entry>warn about uses of pragmas that GHC doesn't recognise</entry> <entry>dynamic</entry> - <entry><option>-fno-warn-monomorphism-restriction</option></entry> + <entry><option>-fno-warn-unrecognised-pragmas</option></entry> </row> <row> @@ -1377,6 +1384,13 @@ <entry><option>-fno-warn-safe</option></entry> </row> + <row> + <entry><option>-fwarn-warnings-deprecations</option></entry> + <entry>warn about uses of functions & types that have warnings or deprecated pragmas</entry> + <entry>dynamic</entry> + <entry><option>-fno-warn-warnings-deprecations</option></entry> + </row> + </tbody> </tgroup> </informaltable> diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml index 77b701402c..169a5dfa23 100644 --- a/docs/users_guide/using.xml +++ b/docs/users_guide/using.xml @@ -1022,6 +1022,32 @@ ghc -c Foo.hs</screen> <variablelist> <varlistentry> + <term><option>-fdefer-type-errors</option>:</term> + <listitem> + <indexterm><primary><option>-fdefer-type-errors</option></primary> + </indexterm> + <indexterm><primary>warnings</primary></indexterm> + <para>Defer as many type errors as possible until runtime. + At compile time you get a warning (instead of an error). At + runtime, if you use a value that depends on a type error, you + get a runtime error; but you can run any type-correct parts of your code + just fine.</para> + </listitem> + </varlistentry> + + <varlistentry> + <term><option>-fhelpful-errors</option>:</term> + <listitem> + <indexterm><primary><option>-fhelpful-errors</option></primary> + </indexterm> + <indexterm><primary>warnings</primary></indexterm> + <para>When a name or package is not found in scope, make + suggestions for the name or package you might have meant instead.</para> + <para>This option is on by default.</para> + </listitem> + </varlistentry> + + <varlistentry> <term><option>-fwarn-unrecognised-pragmas</option>:</term> <listitem> <indexterm><primary><option>-fwarn-unrecognised-pragmas</option></primary> |