diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2012-01-12 17:21:00 +0000 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2012-01-12 17:21:00 +0000 |
| commit | 50fd5a991f8a941f7357f48c98463d0ed1991fab (patch) | |
| tree | b5bdd7211bb54698d4d6d78ba6a8ff7040a250e6 /compiler | |
| parent | 4ada19d8ed90b03c3ced30be8fff3950a884748a (diff) | |
| parent | 3a3dcc31e401e48771d430f3bf02d5e019b6f997 (diff) | |
| download | haskell-50fd5a991f8a941f7357f48c98463d0ed1991fab.tar.gz | |
Merge branch 'master' of http://darcs.haskell.org/ghc
Diffstat (limited to 'compiler')
50 files changed, 1503 insertions, 1171 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/llvmGen/Llvm.hs b/compiler/llvmGen/Llvm.hs index aec492e151..b15b6f261d 100644 --- a/compiler/llvmGen/Llvm.hs +++ b/compiler/llvmGen/Llvm.hs @@ -34,6 +34,9 @@ module Llvm ( -- ** Some basic types i64, i32, i16, i8, i1, i8Ptr, llvmWord, llvmWordPtr, + -- ** Metadata types + LlvmMetaVal(..), LlvmMetaUnamed(..), LlvmMeta(..), MetaData, + -- ** Operations on the type system. isGlobal, getLitType, getLit, getName, getPlainName, getVarType, getLink, getStatType, getGlobalVar, getGlobalType, pVarLift, pVarLower, @@ -42,7 +45,8 @@ module Llvm ( -- * Pretty Printing ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmGlobals, ppLlvmGlobal, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions, - ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, llvmSDoc + ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, ppLlvmMetas, ppLlvmMeta, + llvmSDoc ) where diff --git a/compiler/llvmGen/Llvm/AbsSyn.hs b/compiler/llvmGen/Llvm/AbsSyn.hs index 93bc62c91f..a28734b152 100644 --- a/compiler/llvmGen/Llvm/AbsSyn.hs +++ b/compiler/llvmGen/Llvm/AbsSyn.hs @@ -31,6 +31,9 @@ data LlvmModule = LlvmModule { -- | LLVM Alias type definitions. modAliases :: [LlvmAlias], + -- | LLVM meta data. + modMeta :: [LlvmMeta], + -- | Global variables to include in the module. modGlobals :: [LMGlobal], @@ -138,8 +141,15 @@ data LlvmStatement -} | Nop + {- | + A LLVM statement with metadata attached to it. + -} + | MetaStmt [MetaData] LlvmStatement + deriving (Show, Eq) +type MetaData = (LMString, LlvmMetaUnamed) + -- | Llvm Expressions data LlvmExpression @@ -229,5 +239,10 @@ data LlvmExpression -} | Asm LMString LMString LlvmType [LlvmVar] Bool Bool + {- | + A LLVM expression with metadata attached to it. + -} + | MetaExpr [MetaData] LlvmExpression + deriving (Show, Eq) diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs index b5c3ba8f7e..2945777f96 100644 --- a/compiler/llvmGen/Llvm/PpLlvm.hs +++ b/compiler/llvmGen/Llvm/PpLlvm.hs @@ -10,8 +10,10 @@ module Llvm.PpLlvm ( ppLlvmComment, ppLlvmGlobals, ppLlvmGlobal, - ppLlvmAlias, ppLlvmAliases, + ppLlvmAlias, + ppLlvmMetas, + ppLlvmMeta, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions, @@ -38,9 +40,10 @@ import Unique -- | Print out a whole LLVM module. ppLlvmModule :: LlvmModule -> Doc -ppLlvmModule (LlvmModule comments aliases globals decls funcs) +ppLlvmModule (LlvmModule comments aliases meta globals decls funcs) = ppLlvmComments comments $+$ newLine $+$ ppLlvmAliases aliases $+$ newLine + $+$ ppLlvmMetas meta $+$ newLine $+$ ppLlvmGlobals globals $+$ newLine $+$ ppLlvmFunctionDecls decls $+$ newLine $+$ ppLlvmFunctions funcs @@ -88,7 +91,32 @@ ppLlvmAliases tys = vcat $ map ppLlvmAlias tys -- | Print out an LLVM type alias. ppLlvmAlias :: LlvmAlias -> Doc ppLlvmAlias (name, ty) - = text "%" <> ftext name <+> equals <+> text "type" <+> texts ty $+$ newLine + = text "%" <> ftext name <+> equals <+> text "type" <+> texts ty + + +-- | Print out a list of LLVM metadata. +ppLlvmMetas :: [LlvmMeta] -> Doc +ppLlvmMetas metas = vcat $ map ppLlvmMeta metas + +-- | Print out an LLVM metadata definition. +ppLlvmMeta :: LlvmMeta -> Doc +ppLlvmMeta (MetaUnamed (LMMetaUnamed u) metas) + = exclamation <> int u <> text " = metadata !{" <> + hcat (intersperse comma $ map ppLlvmMetaVal metas) <> text "}" + +ppLlvmMeta (MetaNamed n metas) + = exclamation <> ftext n <> text " = !{" <> + hcat (intersperse comma $ map pprNode munq) <> text "}" + where + munq = map (\(LMMetaUnamed u) -> u) metas + pprNode n = exclamation <> int n + +-- | Print out an LLVM metadata value. +ppLlvmMetaVal :: LlvmMetaVal -> Doc +ppLlvmMetaVal (MetaStr s) = text "metadata !" <> doubleQuotes (ftext s) +ppLlvmMetaVal (MetaVar v) = texts v +ppLlvmMetaVal (MetaNode (LMMetaUnamed u)) + = text "metadata !" <> int u -- | Print out a list of function definitions. @@ -168,29 +196,33 @@ ppLlvmBlock (LlvmBlock blockId stmts) Just id2' -> go id2' rest Nothing -> empty in ppLlvmBlockLabel id - $+$ nest 4 (vcat $ map ppLlvmStatement block) + $+$ (vcat $ map ppLlvmStatement block) $+$ newLine $+$ ppRest +-- | Print out an LLVM block label. +ppLlvmBlockLabel :: LlvmBlockId -> Doc +ppLlvmBlockLabel id = (llvmSDoc $ pprUnique id) <> colon + + -- | Print out an LLVM statement. ppLlvmStatement :: LlvmStatement -> Doc -ppLlvmStatement stmt - = case stmt of - Assignment dst expr -> ppAssignment dst (ppLlvmExpression expr) - Branch target -> ppBranch target - BranchIf cond ifT ifF -> ppBranchIf cond ifT ifF - Comment comments -> ppLlvmComments comments +ppLlvmStatement stmt = + let ind = (text " " <>) + in case stmt of + Assignment dst expr -> ind $ ppAssignment dst (ppLlvmExpression expr) + Branch target -> ind $ ppBranch target + BranchIf cond ifT ifF -> ind $ ppBranchIf cond ifT ifF + Comment comments -> ind $ ppLlvmComments comments MkLabel label -> ppLlvmBlockLabel label - Store value ptr -> ppStore value ptr - Switch scrut def tgs -> ppSwitch scrut def tgs - Return result -> ppReturn result - Expr expr -> ppLlvmExpression expr - Unreachable -> text "unreachable" + Store value ptr -> ind $ ppStore value ptr + Switch scrut def tgs -> ind $ ppSwitch scrut def tgs + Return result -> ind $ ppReturn result + Expr expr -> ind $ ppLlvmExpression expr + Unreachable -> ind $ text "unreachable" Nop -> empty + MetaStmt meta s -> ppMetaStatement meta s --- | Print out an LLVM block label. -ppLlvmBlockLabel :: LlvmBlockId -> Doc -ppLlvmBlockLabel id = (llvmSDoc $ pprUnique id) <> colon -- | Print out an LLVM expression. ppLlvmExpression :: LlvmExpression -> Doc @@ -206,6 +238,7 @@ ppLlvmExpression expr Malloc tp amount -> ppMalloc tp amount Phi tp precessors -> ppPhi tp precessors Asm asm c ty v se sk -> ppAsm asm c ty v se sk + MetaExpr meta expr -> ppMetaExpr meta expr -------------------------------------------------------------------------------- @@ -341,6 +374,21 @@ ppAsm asm constraints rty vars sideeffect alignstack = <+> cons <> vars' +ppMetaStatement :: [MetaData] -> LlvmStatement -> Doc +ppMetaStatement meta stmt = ppLlvmStatement stmt <> ppMetas meta + + +ppMetaExpr :: [MetaData] -> LlvmExpression -> Doc +ppMetaExpr meta expr = ppLlvmExpression expr <> ppMetas meta + + +ppMetas :: [MetaData] -> Doc +ppMetas meta = hcat $ map ppMeta meta + where + ppMeta (name, (LMMetaUnamed n)) + = comma <+> exclamation <> ftext name <+> exclamation <> int n + + -------------------------------------------------------------------------------- -- * Misc functions -------------------------------------------------------------------------------- @@ -362,3 +410,7 @@ texts = (text . show) newLine :: Doc newLine = text "" +-- | Exclamation point. +exclamation :: Doc +exclamation = text "!" + diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs index 101342606d..07e53fb731 100644 --- a/compiler/llvmGen/Llvm/Types.hs +++ b/compiler/llvmGen/Llvm/Types.hs @@ -70,12 +70,49 @@ instance Show LlvmType where show (LMAlias (s,_)) = "%" ++ unpackFS s +-- | LLVM metadata values. Used for representing debug and optimization +-- information. +data LlvmMetaVal + -- | Metadata string + = MetaStr LMString + -- | Metadata node + | MetaNode LlvmMetaUnamed + -- | Normal value type as metadata + | MetaVar LlvmVar + deriving (Eq) + +-- | LLVM metadata nodes. +data LlvmMeta + -- | Unamed metadata + = MetaUnamed LlvmMetaUnamed [LlvmMetaVal] + -- | Named metadata + | MetaNamed LMString [LlvmMetaUnamed] + deriving (Eq) + +-- | Unamed metadata variable. +newtype LlvmMetaUnamed = LMMetaUnamed Int + +instance Eq LlvmMetaUnamed where + (==) (LMMetaUnamed n) (LMMetaUnamed m) = n == m + +instance Show LlvmMetaVal where + show (MetaStr s) = "metadata !\"" ++ unpackFS s ++ "\"" + show (MetaNode n) = "metadata " ++ show n + show (MetaVar v) = show v + +instance Show LlvmMetaUnamed where + show (LMMetaUnamed u) = "!" ++ show u + +instance Show LlvmMeta where + show (MetaUnamed m _) = show m + show (MetaNamed m _) = "!" ++ unpackFS m + -- | An LLVM section definition. If Nothing then let LLVM decide the section type LMSection = Maybe LMString type LMAlign = Maybe Int type LMConst = Bool -- ^ is a variable constant or not --- | Llvm Variables +-- | LLVM Variables data LlvmVar -- | Variables with a global scope. = LMGlobalVar LMString LlvmType LlvmLinkageType LMSection LMAlign LMConst diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 07ccbb1348..4309dcdae1 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -550,7 +550,7 @@ genStore env addr@(CmmMachOp (MO_Sub _) [ = genStore_fast env addr r (negate $ fromInteger n) val -- generic case -genStore env addr val = genStore_slow env addr val +genStore env addr val = genStore_slow env addr val [top] -- | CmmStore operation -- This is a special case for storing to a global register pointer @@ -558,8 +558,9 @@ genStore env addr val = genStore_slow env addr val genStore_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmExpr -> UniqSM StmtData genStore_fast env addr r n val - = let gr = lmGlobalRegVar r - grt = (pLower . getVarType) gr + = let gr = lmGlobalRegVar r + meta = [getTBAA r] + grt = (pLower . getVarType) gr (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8) in case isPointer grt && rem == 0 of True -> do @@ -570,7 +571,7 @@ genStore_fast env addr r n val case pLower grt == getVarType vval of -- were fine True -> do - let s3 = Store vval ptr + let s3 = MetaStmt meta $ Store vval ptr return (env', stmts `snocOL` s1 `snocOL` s2 `snocOL` s3, top) @@ -578,19 +579,19 @@ genStore_fast env addr r n val False -> do let ty = (pLift . getVarType) vval (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty - let s4 = Store vval ptr' + let s4 = MetaStmt meta $ Store vval ptr' return (env', stmts `snocOL` s1 `snocOL` s2 `snocOL` s3 `snocOL` s4, top) -- If its a bit type then we use the slow method since -- we can't avoid casting anyway. - False -> genStore_slow env addr val + False -> genStore_slow env addr val meta -- | CmmStore operation -- Generic case. Uses casts and pointer arithmetic if needed. -genStore_slow :: LlvmEnv -> CmmExpr -> CmmExpr -> UniqSM StmtData -genStore_slow env addr val = do +genStore_slow :: LlvmEnv -> CmmExpr -> CmmExpr -> [MetaData] -> UniqSM StmtData +genStore_slow env addr val meta = do (env1, vaddr, stmts1, top1) <- exprToVar env addr (env2, vval, stmts2, top2) <- exprToVar env1 val @@ -599,17 +600,17 @@ genStore_slow env addr val = do -- sometimes we need to cast an int to a pointer before storing LMPointer ty@(LMPointer _) | getVarType vval == llvmWord -> do (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty - let s2 = Store v vaddr + let s2 = MetaStmt meta $ Store v vaddr return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) LMPointer _ -> do - let s1 = Store vval vaddr + let s1 = MetaStmt meta $ Store vval vaddr return (env2, stmts `snocOL` s1, top1 ++ top2) i@(LMInt _) | i == llvmWord -> do let vty = pLift $ getVarType vval (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty - let s2 = Store vval vptr + let s2 = MetaStmt meta $ Store vval vptr return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) other -> @@ -841,8 +842,8 @@ genMachOp env opt op e = genMachOp_slow env opt op e genMachOp_fast :: LlvmEnv -> EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr] -> UniqSM ExprData genMachOp_fast env opt op r n e - = let gr = lmGlobalRegVar r - grt = (pLower . getVarType) gr + = let gr = lmGlobalRegVar r + grt = (pLower . getVarType) gr (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8) in case isPointer grt && rem == 0 of True -> do @@ -1031,7 +1032,7 @@ genLoad env e@(CmmMachOp (MO_Sub _) [ = genLoad_fast env e r (negate $ fromInteger n) ty -- generic case -genLoad env e ty = genLoad_slow env e ty +genLoad env e ty = genLoad_slow env e ty [top] -- | Handle CmmLoad expression. -- This is a special case for loading from a global register pointer @@ -1039,9 +1040,10 @@ genLoad env e ty = genLoad_slow env e ty genLoad_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmType -> UniqSM ExprData genLoad_fast env e r n ty = - let gr = lmGlobalRegVar r - grt = (pLower . getVarType) gr - ty' = cmmToLlvmType ty + let gr = lmGlobalRegVar r + meta = [getTBAA r] + grt = (pLower . getVarType) gr + ty' = cmmToLlvmType ty (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8) in case isPointer grt && rem == 0 of True -> do @@ -1051,7 +1053,7 @@ genLoad_fast env e r n ty = case grt == ty' of -- were fine True -> do - (var, s3) <- doExpr ty' $ Load ptr + (var, s3) <- doExpr ty' (MetaExpr meta $ Load ptr) return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3, []) @@ -1059,29 +1061,31 @@ genLoad_fast env e r n ty = False -> do let pty = pLift ty' (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty - (var, s4) <- doExpr ty' $ Load ptr' + (var, s4) <- doExpr ty' (MetaExpr meta $ Load ptr') return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3 `snocOL` s4, []) -- If its a bit type then we use the slow method since -- we can't avoid casting anyway. - False -> genLoad_slow env e ty + False -> genLoad_slow env e ty meta -- | Handle Cmm load expression. -- Generic case. Uses casts and pointer arithmetic if needed. -genLoad_slow :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData -genLoad_slow env e ty = do +genLoad_slow :: LlvmEnv -> CmmExpr -> CmmType -> [MetaData] -> UniqSM ExprData +genLoad_slow env e ty meta = do (env', iptr, stmts, tops) <- exprToVar env e case getVarType iptr of LMPointer _ -> do - (dvar, load) <- doExpr (cmmToLlvmType ty) $ Load iptr + (dvar, load) <- doExpr (cmmToLlvmType ty) + (MetaExpr meta $ Load iptr) return (env', dvar, stmts `snocOL` load, tops) i@(LMInt _) | i == llvmWord -> do let pty = LMPointer $ cmmToLlvmType ty (ptr, cast) <- doExpr pty $ Cast LM_Inttoptr iptr pty - (dvar, load) <- doExpr (cmmToLlvmType ty) $ Load ptr + (dvar, load) <- doExpr (cmmToLlvmType ty) + (MetaExpr meta $ Load ptr) return (env', dvar, stmts `snocOL` cast `snocOL` load, tops) other -> pprPanic "exprToVar: CmmLoad expression is not right type!" @@ -1099,7 +1103,6 @@ genLoad_slow env e ty = do getCmmReg :: LlvmEnv -> CmmReg -> ExprData getCmmReg env r@(CmmLocal (LocalReg un _)) = let exists = varLookup un env - (newv, stmts) = allocReg r nenv = varInsert un (pLower $ getVarType newv) env in case exists of @@ -1204,7 +1207,7 @@ funEpilogue Nothing = do return (vars, concatOL stmts) where loadExpr r = do - let reg = lmGlobalRegVar r + let reg = lmGlobalRegVar r (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg return (v, unitOL s) @@ -1214,7 +1217,7 @@ funEpilogue (Just live) = do return (vars, concatOL stmts) where loadExpr r | r `elem` alwaysLive || r `elem` live = do - let reg = lmGlobalRegVar r + let reg = lmGlobalRegVar r (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg return (v, unitOL s) loadExpr r = do diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs index e0cebe5f21..187d1ecf03 100644 --- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs +++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs @@ -11,6 +11,7 @@ module LlvmCodeGen.Ppr ( import Llvm import LlvmCodeGen.Base import LlvmCodeGen.Data +import LlvmCodeGen.Regs import CLabel import OldCmm @@ -25,6 +26,16 @@ import Unique -- * Top level -- +-- | Header code for LLVM modules +pprLlvmHeader :: Doc +pprLlvmHeader = + moduleLayout + $+$ text "" + $+$ ppLlvmFunctionDecls (map snd ghcInternalFunctions) + $+$ ppLlvmMetas stgTBAA + $+$ text "" + + -- | LLVM module layout description for the host target moduleLayout :: Doc moduleLayout = @@ -64,11 +75,6 @@ moduleLayout = #endif --- | Header code for LLVM modules -pprLlvmHeader :: Doc -pprLlvmHeader = - moduleLayout $+$ ppLlvmFunctionDecls (map snd ghcInternalFunctions) - -- | Pretty print LLVM data code pprLlvmData :: LlvmData -> Doc pprLlvmData (globals, types) = diff --git a/compiler/llvmGen/LlvmCodeGen/Regs.hs b/compiler/llvmGen/LlvmCodeGen/Regs.hs index ecce7a317b..55b2e0db80 100644 --- a/compiler/llvmGen/LlvmCodeGen/Regs.hs +++ b/compiler/llvmGen/LlvmCodeGen/Regs.hs @@ -3,7 +3,8 @@ -- module LlvmCodeGen.Regs ( - lmGlobalRegArg, lmGlobalRegVar, alwaysLive + lmGlobalRegArg, lmGlobalRegVar, alwaysLive, + stgTBAA, top, base, stack, heap, rx, tbaa, getTBAA ) where #include "HsVersions.h" @@ -11,8 +12,8 @@ module LlvmCodeGen.Regs ( import Llvm import CmmExpr -import Outputable ( panic ) import FastString +import Outputable ( panic ) -- | Get the LlvmVar function variable storing the real register lmGlobalRegVar :: GlobalReg -> LlvmVar @@ -49,6 +50,8 @@ lmGlobalReg suf reg DoubleReg 2 -> doubleGlobal $ "D2" ++ suf _other -> panic $ "LlvmCodeGen.Reg: GlobalReg (" ++ (show reg) ++ ") not supported!" + -- LongReg, HpLim, CCSS, CurrentTSO, CurrentNusery, HpAlloc + -- EagerBlackholeInfo, GCEnter1, GCFun, BaseReg, PicBaseReg where wordGlobal name = LMNLocalVar (fsLit name) llvmWord ptrGlobal name = LMNLocalVar (fsLit name) llvmWordPtr @@ -59,3 +62,41 @@ lmGlobalReg suf reg alwaysLive :: [GlobalReg] alwaysLive = [BaseReg, Sp, Hp, SpLim, HpLim, node] +-- | STG Type Based Alias Analysis metadata +stgTBAA :: [LlvmMeta] +stgTBAA + = [ MetaUnamed topN [MetaStr (fsLit "top")] + , MetaUnamed stackN [MetaStr (fsLit "stack"), MetaNode topN] + , MetaUnamed heapN [MetaStr (fsLit "heap"), MetaNode topN] + , MetaUnamed rxN [MetaStr (fsLit "rx"), MetaNode heapN] + , MetaUnamed baseN [MetaStr (fsLit "base"), MetaNode topN] + ] + +-- | Id values +topN, stackN, heapN, rxN, baseN :: LlvmMetaUnamed +topN = LMMetaUnamed 0 +stackN = LMMetaUnamed 1 +heapN = LMMetaUnamed 2 +rxN = LMMetaUnamed 3 +baseN = LMMetaUnamed 4 + +-- | The various TBAA types +top, heap, stack, rx, base :: MetaData +top = (tbaa, topN) +heap = (tbaa, heapN) +stack = (tbaa, stackN) +rx = (tbaa, rxN) +base = (tbaa, baseN) + +-- | The TBAA metadata identifier +tbaa :: LMString +tbaa = fsLit "tbaa" + +-- | Get the correct TBAA metadata information for this register type +getTBAA :: GlobalReg -> MetaData +getTBAA BaseReg = base +getTBAA Sp = stack +getTBAA Hp = heap +getTBAA (VanillaReg _ _) = rx +getTBAA _ = top + 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 |