Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Add type "holes", enabled by -XTypeHoles, Trac #5910

This single commit combines a lot of work done by
Thijs Alkemade <thijsalkemade@gmail.com>, plus a slew
of subsequent refactoring by Simon PJ.

The basic idea is
* Add a new expression form "_", a hole, standing for a not-yet-written expression
* Give a useful error message that
   (a) gives the type of the hole
   (b) gives the types of some enclosing value bindings that
       mention the hole

Driven by this goal I did a LOT of refactoring in TcErrors, which in turn
allows us to report enclosing value bindings for other errors, not just
holes.  (Thijs rightly did not attempt this!)

The major data type change is a new form of constraint
  data Ct = ...
    	  | CHoleCan {
    	      cc_ev       :: CtEvidence,
    	      cc_hole_ty  :: TcTauType,
    	      cc_depth    :: SubGoalDepth }

I'm still in two minds about whether this is the best plan. Another
possibility would be to have a predicate type for holes, somthing like
   class Hole a where
     holeValue :: a

It works the way it is, but there are some annoying special cases for
CHoleCan (just grep for "CHoleCan").
  • Loading branch information...
commit 8a9a7a8c42da3adb603f319a74e304af5e1b2128 1 parent b0db930
@simonpj simonpj authored
View
1  compiler/deSugar/Coverage.lhs
@@ -576,6 +576,7 @@ addTickHsExpr (HsWrap w e) =
(addTickHsExpr e) -- explicitly no tick on inside
addTickHsExpr e@(HsType _) = return e
+addTickHsExpr HsHole = panic "addTickHsExpr.HsHole"
-- Others dhould never happen in expression content.
addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e)
View
2  compiler/deSugar/DsExpr.lhs
@@ -216,6 +216,8 @@ dsExpr (HsLamCase arg matches@(MatchGroup _ rhs_ty))
dsExpr (HsApp fun arg)
= mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg
+
+dsExpr HsHole = panic "dsExpr: HsHole"
\end{code}
Note [Desugaring vars]
View
3  compiler/hsSyn/HsExpr.lhs
@@ -294,6 +294,7 @@ data HsExpr id
| HsWrap HsWrapper -- TRANSLATION
(HsExpr id)
+ | HsHole
deriving (Data, Typeable)
-- HsTupArg is used for tuple sections
@@ -559,6 +560,8 @@ ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2])
ppr_expr (HsArrForm op _ args)
= hang (ptext (sLit "(|") <> ppr_lexpr op)
4 (sep (map (pprCmdArg.unLoc) args) <> ptext (sLit "|)"))
+ppr_expr HsHole
+ = ptext $ sLit "_"
pprCmdArg :: OutputableBndr id => HsCmdTop id -> SDoc
pprCmdArg (HsCmdTop cmd@(L _ (HsArrForm _ Nothing [])) _ _ _)
View
4 compiler/main/DynFlags.hs
@@ -507,6 +507,7 @@ data ExtensionFlag
| Opt_TraditionalRecordSyntax
| Opt_LambdaCase
| Opt_MultiWayIf
+ | Opt_TypeHoles
deriving (Eq, Enum, Show)
-- | Contains not only a collection of 'DynFlag's but also a plethora of
@@ -2449,7 +2450,8 @@ xFlags = [
( "OverlappingInstances", Opt_OverlappingInstances, nop ),
( "UndecidableInstances", Opt_UndecidableInstances, nop ),
( "IncoherentInstances", Opt_IncoherentInstances, nop ),
- ( "PackageImports", Opt_PackageImports, nop )
+ ( "PackageImports", Opt_PackageImports, nop ),
+ ( "TypeHoles", Opt_TypeHoles, nop )
]
defaultFlags :: Platform -> [DynFlag]
View
11 compiler/rename/RnExpr.lhs
@@ -34,7 +34,7 @@ import HsSyn
import TcRnMonad
import TcEnv ( thRnBrack )
import RnEnv
-import RnTypes
+import RnTypes
import RnPat
import DynFlags
import BasicTypes ( FixityDirection(..) )
@@ -299,6 +299,9 @@ rnExpr (ArithSeq _ seq)
rnExpr (PArrSeq _ seq)
= rnArithSeq seq `thenM` \ (new_seq, fvs) ->
return (PArrSeq noPostTcExpr new_seq, fvs)
+
+rnExpr HsHole
+ = return (HsHole, emptyFVs)
\end{code}
These three are pattern syntax appearing in expressions.
@@ -306,7 +309,11 @@ Since all the symbols are reservedops we can simply reject them.
We return a (bogus) EWildPat in each case.
\begin{code}
-rnExpr e@EWildPat = patSynErr e
+rnExpr e@EWildPat = do { holes <- xoptM Opt_TypeHoles
+ ; if holes
+ then return (HsHole, emptyFVs)
+ else patSynErr e
+ }
rnExpr e@(EAsPat {}) = patSynErr e
rnExpr e@(EViewPat {}) = patSynErr e
rnExpr e@(ELazyPat {}) = patSynErr e
View
31 compiler/typecheck/Inst.lhs
@@ -356,14 +356,14 @@ tcSyntaxName orig ty (std_nm, user_nm_expr) = do
syntaxNameCtxt :: HsExpr Name -> CtOrigin -> Type -> TidyEnv
-> TcRn (TidyEnv, SDoc)
-syntaxNameCtxt name orig ty tidy_env = do
- inst_loc <- getCtLoc orig
- let
- msg = vcat [ptext (sLit "When checking that") <+> quotes (ppr name) <+>
- ptext (sLit "(needed by a syntactic construct)"),
- nest 2 (ptext (sLit "has the required type:") <+> ppr (tidyType tidy_env ty)),
- nest 2 (pprArisingAt inst_loc)]
- return (tidy_env, msg)
+syntaxNameCtxt name orig ty tidy_env
+ = do { inst_loc <- getCtLoc orig
+ ; let msg = vcat [ ptext (sLit "When checking that") <+> quotes (ppr name)
+ <+> ptext (sLit "(needed by a syntactic construct)")
+ , nest 2 (ptext (sLit "has the required type:")
+ <+> ppr (tidyType tidy_env ty))
+ , nest 2 (pprArisingAt inst_loc) ]
+ ; return (tidy_env, msg) }
\end{code}
@@ -523,6 +523,7 @@ tyVarsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) = extendVarSet (tyVarsOf
tyVarsOfCt (CFunEqCan { cc_tyargs = tys, cc_rhs = xi }) = tyVarsOfTypes (xi:tys)
tyVarsOfCt (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys
tyVarsOfCt (CIrredEvCan { cc_ty = ty }) = tyVarsOfType ty
+tyVarsOfCt (CHoleCan { cc_hole_ty = ty }) = tyVarsOfType ty
tyVarsOfCt (CNonCanonical { cc_ev = fl }) = tyVarsOfType (ctEvPred fl)
tyVarsOfCts :: Cts -> TcTyVarSet
@@ -551,8 +552,10 @@ tidyCt :: TidyEnv -> Ct -> Ct
-- Used only in error reporting
-- Also converts it to non-canonical
tidyCt env ct
- = CNonCanonical { cc_ev = tidy_flavor env (cc_ev ct)
- , cc_depth = cc_depth ct }
+ = case ct of
+ CHoleCan {} -> ct { cc_ev = tidy_flavor env (cc_ev ct) }
+ _ -> CNonCanonical { cc_ev = tidy_flavor env (cc_ev ct)
+ , cc_depth = cc_depth ct }
where
tidy_flavor :: TidyEnv -> CtEvidence -> CtEvidence
-- NB: we do not tidy the ctev_evtm/var field because we don't
@@ -569,8 +572,8 @@ tidyEvVar :: TidyEnv -> EvVar -> EvVar
tidyEvVar env var = setVarType var (tidyType env (varType var))
tidyGivenLoc :: TidyEnv -> GivenLoc -> GivenLoc
-tidyGivenLoc env (CtLoc skol span ctxt)
- = CtLoc (tidySkolemInfo env skol) span ctxt
+tidyGivenLoc env (CtLoc skol lcl)
+ = CtLoc (tidySkolemInfo env skol) lcl
tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo
tidySkolemInfo env (SigSkol cx ty) = SigSkol cx (tidyType env ty)
@@ -635,8 +638,8 @@ substFlavor subst ctev@(CtDerived { ctev_pred = pty })
= ctev { ctev_pred = substTy subst pty }
substGivenLoc :: TvSubst -> GivenLoc -> GivenLoc
-substGivenLoc subst (CtLoc skol span ctxt)
- = CtLoc (substSkolemInfo subst skol) span ctxt
+substGivenLoc subst (CtLoc skol lcl)
+ = CtLoc (substSkolemInfo subst skol) lcl
substSkolemInfo :: TvSubst -> SkolemInfo -> SkolemInfo
substSkolemInfo subst (SigSkol cx ty) = SigSkol cx (substTy subst ty)
View
90 compiler/typecheck/TcBinds.lhs
@@ -6,7 +6,7 @@
\begin{code}
module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
- tcHsBootSigs, tcPolyBinds, tcPolyCheck,
+ tcHsBootSigs, tcPolyCheck,
PragFun, tcSpecPrags, tcVectDecls, mkPragFun,
TcSigInfo(..), TcSigFun,
instTcTySig, instTcTySigFromId,
@@ -274,7 +274,8 @@ tcValBinds top_lvl binds sigs thing_inside
-- Extend the envt right away with all
-- the Ids declared with type signatures
- ; (binds', thing) <- tcExtendIdEnv poly_ids $
+ -- Use tcExtendIdEnv2 to avoid extending the TcIdBinder stack
+ ; (binds', thing) <- tcExtendIdEnv2 [(idName id, id) | id <- poly_ids] $
tcBindGroups top_lvl sig_fn prag_fn
binds thing_inside
@@ -336,7 +337,8 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, [TcId], thing)
go (scc:sccs) = do { (binds1, ids1, closed) <- tc_scc scc
- ; (binds2, ids2, thing) <- tcExtendLetEnv closed ids1 $ go sccs
+ ; (binds2, ids2, thing) <- tcExtendLetEnv closed ids1 $
+ go sccs
; return (binds1 `unionBags` binds2, ids1 ++ ids2, thing) }
go [] = do { thing <- thing_inside; return (emptyBag, [], thing) }
@@ -397,20 +399,15 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
{ traceTc "------------------------------------------------" empty
; traceTc "Bindings for {" (ppr binder_names)
-
--- -- Instantiate the polytypes of any binders that have signatures
--- -- (as determined by sig_fn), returning a TcSigInfo for each
--- ; tc_sig_fn <- tcInstSigs sig_fn binder_names
-
; dflags <- getDynFlags
; type_env <- getLclTypeEnv
; let plan = decideGeneralisationPlan dflags type_env
binder_names bind_list sig_fn
; traceTc "Generalisation plan" (ppr plan)
; result@(tc_binds, poly_ids, _) <- case plan of
- NoGen -> tcPolyNoGen sig_fn prag_fn rec_tc bind_list
- InferGen mn cl -> tcPolyInfer mn cl sig_fn prag_fn rec_tc bind_list
- CheckGen sig -> tcPolyCheck sig prag_fn rec_tc bind_list
+ NoGen -> tcPolyNoGen top_lvl rec_tc prag_fn sig_fn bind_list
+ InferGen mn cl -> tcPolyInfer top_lvl rec_tc prag_fn sig_fn mn cl bind_list
+ CheckGen sig -> tcPolyCheck top_lvl rec_tc prag_fn sig bind_list
-- Check whether strict bindings are ok
-- These must be non-recursive etc, and are not generalised
@@ -429,17 +426,18 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
-- span that includes them all
------------------
-tcPolyNoGen
- :: TcSigFun -> PragFun
+tcPolyNoGen -- No generalisation whatsoever
+ :: TopLevelFlag
-> RecFlag -- Whether it's recursive after breaking
-- dependencies based on type signatures
+ -> PragFun -> TcSigFun
-> [LHsBind Name]
-> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
--- No generalisation whatsoever
-tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list
- = do { (binds', mono_infos) <- tcMonoBinds tc_sig_fn (LetGblBndr prag_fn)
- rec_tc bind_list
+tcPolyNoGen top_lvl rec_tc prag_fn tc_sig_fn bind_list
+ = do { (binds', mono_infos) <- tcMonoBinds top_lvl rec_tc tc_sig_fn
+ (LetGblBndr prag_fn)
+ bind_list
; mono_ids' <- mapM tc_mono_info mono_infos
; return (binds', mono_ids', NotTopLevel) }
where
@@ -455,17 +453,19 @@ tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list
-- So we can safely ignore _specs
------------------
-tcPolyCheck :: TcSigInfo -> PragFun
+tcPolyCheck :: TopLevelFlag
-> RecFlag -- Whether it's recursive after breaking
-- dependencies based on type signatures
+ -> PragFun -> TcSigInfo
-> [LHsBind Name]
-> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
-- There is just one binding,
-- it binds a single variable,
-- it has a signature,
-tcPolyCheck sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped
+tcPolyCheck top_lvl rec_tc prag_fn
+ sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped
, sig_theta = theta, sig_tau = tau, sig_loc = loc })
- prag_fn rec_tc bind_list
+ bind_list
= do { ev_vars <- newEvVars theta
; let skol_info = SigSkol (FunSigCtxt (idName poly_id)) (mkPhiTy theta tau)
prag_sigs = prag_fn (idName poly_id)
@@ -474,7 +474,7 @@ tcPolyCheck sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped
<- setSrcSpan loc $
checkConstraints skol_info tvs ev_vars $
tcExtendTyVarEnv2 [(n,tv) | (Just n, tv) <- tvs_w_scoped] $
- tcMonoBinds (\_ -> Just sig) LetLclBndr rec_tc bind_list
+ tcMonoBinds top_lvl rec_tc (\_ -> Just sig) LetLclBndr bind_list
; spec_prags <- tcSpecPrags poly_id prag_sigs
; poly_id <- addInlinePrags poly_id prag_sigs
@@ -494,17 +494,18 @@ tcPolyCheck sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped
------------------
tcPolyInfer
- :: Bool -- True <=> apply the monomorphism restriction
- -> Bool -- True <=> free vars have closed types
- -> TcSigFun -> PragFun
+ :: TopLevelFlag
-> RecFlag -- Whether it's recursive after breaking
-- dependencies based on type signatures
+ -> PragFun -> TcSigFun
+ -> Bool -- True <=> apply the monomorphism restriction
+ -> Bool -- True <=> free vars have closed types
-> [LHsBind Name]
-> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
-tcPolyInfer mono closed tc_sig_fn prag_fn rec_tc bind_list
+tcPolyInfer top_lvl rec_tc prag_fn tc_sig_fn mono closed bind_list
= do { ((binds', mono_infos), wanted)
<- captureConstraints $
- tcMonoBinds tc_sig_fn LetLclBndr rec_tc bind_list
+ tcMonoBinds top_lvl rec_tc tc_sig_fn LetLclBndr bind_list
; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos]
; (qtvs, givens, mr_bites, ev_binds) <-
@@ -524,10 +525,8 @@ tcPolyInfer mono closed tc_sig_fn prag_fn rec_tc bind_list
; traceTc "Binding:" (ppr final_closed $$
ppr (poly_ids `zip` map idType poly_ids))
- ; return (unitBag abs_bind, poly_ids, final_closed)
+ ; return (unitBag abs_bind, poly_ids, final_closed) }
-- poly_ids are guaranteed zonked by mkExport
- }
-
--------------
mkExport :: PragFun
@@ -937,14 +936,15 @@ should not typecheck because
will not typecheck.
\begin{code}
-tcMonoBinds :: TcSigFun -> LetBndrSpec
+tcMonoBinds :: TopLevelFlag
-> RecFlag -- Whether the binding is recursive for typechecking purposes
-- i.e. the binders are mentioned in their RHSs, and
-- we are not rescued by a type signature
+ -> TcSigFun -> LetBndrSpec
-> [LHsBind Name]
-> TcM (LHsBinds TcId, [MonoBindInfo])
-tcMonoBinds sig_fn no_gen is_rec
+tcMonoBinds top_lvl is_rec sig_fn no_gen
[ L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf,
fun_matches = matches, bind_fvs = fvs })]
-- Single function binding,
@@ -956,15 +956,17 @@ tcMonoBinds sig_fn no_gen is_rec
-- e.g. f = \(x::forall a. a->a) -> <body>
-- We want to infer a higher-rank type for f
setSrcSpan b_loc $
- do { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name inf matches)
-
+ do { rhs_ty <- newFlexiTyVarTy openTypeKind
; mono_id <- newNoSigLetBndr no_gen name rhs_ty
+ ; (co_fn, matches') <- tcExtendIdBndrs [TcIdBndr mono_id top_lvl] $
+ tcMatchesFun name inf matches rhs_ty
+
; return (unitBag (L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf,
fun_matches = matches', bind_fvs = fvs,
fun_co_fn = co_fn, fun_tick = Nothing })),
[(name, Nothing, mono_id)]) }
-tcMonoBinds sig_fn no_gen _ binds
+tcMonoBinds top_lvl _ sig_fn no_gen binds
= do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds
-- Bring the monomorphic Ids, into scope for the RHSs
@@ -973,10 +975,10 @@ tcMonoBinds sig_fn no_gen _ binds
-- A monomorphic binding for each term variable that lacks
-- a type sig. (Ones with a sig are already in scope.)
- ; binds' <- tcExtendIdEnv2 rhs_id_env $ do
- traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id)
- | (n,id) <- rhs_id_env]
- mapM (wrapLocM tcRhs) tc_binds
+ ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id)
+ | (n,id) <- rhs_id_env]
+ ; binds' <- tcExtendIdEnv2 rhs_id_env $
+ mapM (wrapLocM (tcRhs top_lvl)) tc_binds
; return (listToBag binds', mono_info) }
------------------------
@@ -1032,13 +1034,14 @@ tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
-- AbsBind, VarBind impossible
-------------------
-tcRhs :: TcMonoBind -> TcM (HsBind TcId)
+tcRhs :: TopLevelFlag -> TcMonoBind -> TcM (HsBind TcId)
-- When we are doing pattern bindings, or multiple function bindings at a time
-- we *don't* bring any scoped type variables into scope
-- Wny not? They are not completely rigid.
-- That's why we have the special case for a single FunBind in tcMonoBinds
-tcRhs (TcFunBind (_,_,mono_id) loc inf matches)
- = do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
+tcRhs top_lvl (TcFunBind (_,_,mono_id) loc inf matches)
+ = tcExtendIdBndrs [TcIdBndr mono_id top_lvl] $
+ do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
; (co_fn, matches') <- tcMatchesFun (idName mono_id) inf
matches (idType mono_id)
; return (FunBind { fun_id = L loc mono_id, fun_infix = inf
@@ -1046,8 +1049,9 @@ tcRhs (TcFunBind (_,_,mono_id) loc inf matches)
, fun_co_fn = co_fn
, bind_fvs = placeHolderNames, fun_tick = Nothing }) }
-tcRhs (TcPatBind _ pat' grhss pat_ty)
- = do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)
+tcRhs top_lvl (TcPatBind infos pat' grhss pat_ty)
+ = tcExtendIdBndrs [ TcIdBndr mono_id top_lvl | (_,_,mono_id) <- infos ] $
+ do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)
; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
tcGRHSsPat grhss pat_ty
; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty
View
9 compiler/typecheck/TcCanonical.lhs
@@ -195,7 +195,9 @@ canonicalize (CIrredEvCan { cc_ev = fl
, cc_depth = d
, cc_ty = xi })
= canIrred d fl xi
-
+canonicalize ct@(CHoleCan {})
+ = do { emitInsoluble ct
+ ; return Stop }
canEvNC :: SubGoalDepth
-> CtEvidence
@@ -227,7 +229,6 @@ canTuple d fl tys
; canEvVarsCreated d ctevs }
\end{code}
-
%************************************************************************
%* *
%* Class Canonicalization
@@ -818,7 +819,9 @@ canEqAppTy d fl s1 t1 s2 t2
; canEvVarsCreated d ctevs }
canEqFailure :: SubGoalDepth -> CtEvidence -> TcS StopOrContinue
-canEqFailure d fl = do { emitFrozenError fl d; return Stop }
+canEqFailure d fl
+ = do { emitInsoluble (CNonCanonical { cc_ev = fl, cc_depth = d })
+ ; return Stop }
------------------------
emitKindConstraint :: Ct -> TcS StopOrContinue
View
21 compiler/typecheck/TcEnv.lhs
@@ -25,6 +25,8 @@ module TcEnv(
tcExtendTyVarEnv, tcExtendTyVarEnv2,
tcExtendGhciEnv, tcExtendLetEnv,
tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
+ tcExtendIdBndrs,
+
tcLookup, tcLookupLocated, tcLookupLocalIds,
tcLookupId, tcLookupTyVar,
tcLookupLcl_maybe,
@@ -375,27 +377,36 @@ tcExtendLetEnv closed ids thing_inside
; tc_extend_local_env [ (idName id, ATcId { tct_id = id
, tct_closed = closed
, tct_level = thLevel stage })
- | id <- ids]
- thing_inside }
+ | id <- ids] $
+ tcExtendIdBndrs [TcIdBndr id closed | id <- ids] thing_inside }
tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
tcExtendIdEnv ids thing_inside
- = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside
+ = tcExtendIdEnv2 [(idName id, id) | id <- ids] $
+ tcExtendIdBndrs [TcIdBndr id NotTopLevel | id <- ids]
+ thing_inside
tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
tcExtendIdEnv1 name id thing_inside
- = tcExtendIdEnv2 [(name,id)] thing_inside
+ = tcExtendIdEnv2 [(name,id)] $
+ tcExtendIdBndrs [TcIdBndr id NotTopLevel]
+ thing_inside
tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
+-- Do *not* extend the tcl_bndrs stack
+-- The tct_closed flag really doesn't matter
-- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above)
tcExtendIdEnv2 names_w_ids thing_inside
= do { stage <- getStage
; tc_extend_local_env [ (name, ATcId { tct_id = id
, tct_closed = NotTopLevel
, tct_level = thLevel stage })
- | (name,id) <- names_w_ids]
+ | (name,id) <- names_w_ids] $
thing_inside }
+tcExtendIdBndrs :: [TcIdBinder] -> TcM a -> TcM a
+tcExtendIdBndrs bndrs = updLclEnv (\env -> env { tcl_bndrs = bndrs ++ tcl_bndrs env })
+
tcExtendGhciEnv :: [TcId] -> TcM a -> TcM a
-- Used to bind Ids for GHCi identifiers bound earlier in the user interaction
-- Note especially that we bind them at
View
443 compiler/typecheck/TcErrors.lhs
@@ -8,7 +8,7 @@
-- for details
module TcErrors(
- reportUnsolved, ErrEnv,
+ reportUnsolved, reportAllUnsolved,
warnDefaulting,
flattenForAllErrorTcS,
@@ -30,15 +30,14 @@ import InstEnv
import TyCon
import TcEvidence
import Name
-import NameEnv
-import Id ( idType )
+import Id
import Var
import VarSet
import VarEnv
import Bag
import Maybes
import ErrUtils ( ErrMsg, makeIntoWarning, pprLocErrMsg )
-import SrcLoc ( noSrcSpan )
+import BasicTypes
import Util
import FastString
import Outputable
@@ -56,18 +55,66 @@ ToDo: for these error messages, should we note the location as coming
from the insts, or just whatever seems to be around in the monad just
now?
-\begin{code}
--- We keep an environment mapping coercion ids to the error messages they
--- trigger; this is handy for -fwarn--type-errors
-type ErrEnv = VarEnv [ErrMsg]
+Note [Deferring coercion errors to runtime]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+While developing, sometimes it is desirable to allow compilation to succeed even
+if there are type errors in the code. Consider the following case:
+
+ 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
-reportUnsolved :: Bool -> WantedConstraints -> TcM (Bag EvBind)
+ 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. 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}
+reportUnsolved :: WantedConstraints -> TcM (Bag EvBind)
+reportUnsolved wanted
+ = do { binds_var <- newTcEvBinds
+ ; defer <- doptM Opt_DeferTypeErrors
+ ; report_unsolved (Just binds_var) defer wanted
+ ; getTcEvBinds binds_var }
+
+reportAllUnsolved :: WantedConstraints -> TcM ()
+-- Report all unsolved goals, even if -fdefer-type-errors is on
+-- See Note [Deferring coercion errors to runtime]
+reportAllUnsolved wanted
+ = report_unsolved Nothing (panic "reportAllUnsolved") wanted
+
+report_unsolved :: Maybe EvBindsVar -- cec_binds
+ -> Bool -- cec_defer
+ -> WantedConstraints -> TcM ()
-- Important precondition:
-- WantedConstraints are fully zonked and unflattened, that is,
-- zonkWC has already been applied to these constraints.
-reportUnsolved runtimeCoercionErrors wanted
+report_unsolved mb_binds_var defer wanted
| isEmptyWC wanted
- = return emptyBag
+ = return ()
| otherwise
= do { traceTc "reportUnsolved (before unflattening)" (ppr wanted)
@@ -75,11 +122,6 @@ reportUnsolved runtimeCoercionErrors wanted
-- If we are deferring we are going to need /all/ evidence around,
-- including the evidence produced by unflattening (zonkWC)
- ; defer <- if runtimeCoercionErrors
- then do { ev_binds_var <- newTcEvBinds
- ; return (Just ev_binds_var) }
- else return Nothing
-
; errs_so_far <- ifErrsM (return True) (return False)
; let tidy_env = tidyFreeTyVars env0 free_tvs
free_tvs = tyVarsOfWC wanted
@@ -90,17 +132,14 @@ reportUnsolved runtimeCoercionErrors wanted
-- to report
, cec_extra = empty
, cec_tidy = tidy_env
- , cec_defer = defer }
+ , cec_defer = defer
+ , cec_binds = mb_binds_var }
; traceTc "reportUnsolved (after unflattening):" $
vcat [ pprTvBndrs (varSetElems free_tvs)
, ppr wanted ]
- ; reportWanteds err_ctxt wanted
-
- ; case defer of
- Nothing -> return emptyBag
- Just ev_binds_var -> getTcEvBinds ev_binds_var }
+ ; reportWanteds err_ctxt wanted }
--------------------------------------------
-- Internal functions
@@ -114,10 +153,14 @@ data ReportErrCtxt
, cec_extra :: SDoc -- Add this to each error message
, 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
+
+ , cec_binds :: Maybe EvBindsVar
+ -- Nothinng <=> Report all errors, including holes; no bindings
+ -- Just ev <=> make some errors (depending on cec_defer)
+ -- into warnings, and emit evidence bindings
+ -- into 'ev' for unsolved constraints
+ , cec_defer :: Bool -- True <=> -fdefer-type-errors
+ -- Irrelevant if cec_binds = Nothing
}
reportImplic :: ReportErrCtxt -> Implication -> TcM ()
@@ -139,40 +182,49 @@ reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given
, ic_loc = tidyGivenLoc env1 loc }
ctxt' = ctxt { cec_tidy = env1
, cec_encl = implic' : cec_encl ctxt
- , cec_defer = case cec_defer ctxt of
+ , cec_binds = case cec_binds 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_all implics
+ = do { reportOrDefer ctxt tidy_cts
+ ; mapBagM_ (reportImplic ctxt) implics }
where
env = cec_tidy ctxt
- tidy_all = mapBag (tidyCt env) (insols `unionBags` flats)
+ tidy_cts = mapBag (tidyCt env) (insols `unionBags` flats)
-- All the Derived ones have been filtered out alrady
-- by the constraint solver. This is ok; we don't want
-- to report unsolved Derived goals as error
-- See Note [Do not report derived but soluble errors]
-reportTidyWanteds :: ReportErrCtxt -> Cts -> Bag Implication -> TcM ()
-reportTidyWanteds ctxt 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
- ; mapBagM_ (reportImplic ctxt) implics }
-
- | otherwise
- = do { reportFlats ctxt flats
- ; mapBagM_ (reportImplic ctxt) implics }
-
+reportOrDefer :: ReportErrCtxt -> Cts -> TcM ()
+reportOrDefer ctxt@(CEC { cec_binds = mb_binds_var
+ , cec_defer = defer_errs }) cts
+ | Just ev_binds_var <- mb_binds_var
+ , defer_errs -- -fdefer-type-errors: Defer all
+ -- See Note [Deferring coercion errors to runtime]
+ = mapBagM_ (deferToRuntime ev_binds_var ctxt mkFlatErr) cts
+
+ | Just ev_binds_var <- mb_binds_var
+ -- No -fdefer-type-errors: Defer only holes
+ -- See Note [Deferring coercion errors to runtime]
+ = do { let (holes, non_holes) = partitionBag isHoleCt cts
+ ; reportFlats ctxt non_holes
+ ; mapBagM_ (deferToRuntime ev_binds_var ctxt mkFlatErr) holes }
+ -- Thijs had something about extending the tidy-env, but I don't know why
+
+ | otherwise -- Defer nothing
+ = reportFlats ctxt cts
deferToRuntime :: EvBindsVar -> ReportErrCtxt -> (ReportErrCtxt -> Ct -> TcM ErrMsg)
-> Ct -> TcM ()
+-- See Note [Deferring coercion errors to runtime]
deferToRuntime ev_binds_var ctxt mk_err_msg ct
| CtWanted { ctev_wloc = loc, ctev_pred = pred, ctev_evar = ev_id } <- cc_ev ct
- = do { err <- setCtLoc loc $
- mk_err_msg ctxt ct
+ = do { ctxt' <- relevantBindings ctxt ct
+ ; err <- setCtLoc loc $
+ mk_err_msg ctxt' ct
; dflags <- getDynFlags
; let err_msg = pprLocErrMsg err
err_fs = mkFastString $ showSDoc dflags $
@@ -193,22 +245,24 @@ reportFlats ctxt flats -- Here 'flats' includes insolble goals
[ -- 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))
+ ("Utterly wrong", utterly_wrong, mkGroupReporter mkEqErr)
+ , ("Holes", is_hole, mkUniReporter mkHoleError)
-- 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 flats)
+ , ("Skolem equalities", skolem_eq, mkUniReporter mkEqErr1)
+ , ("Unambiguous", unambiguous, reportFlatErrs) ]
+ reportAmbigErrs
+ ctxt (bagToList flats)
where
utterly_wrong, skolem_eq, unambiguous :: Ct -> PredTree -> Bool
utterly_wrong _ (EqPred ty1 ty2) = isRigid ty1 && isRigid ty2
utterly_wrong _ _ = False
+ is_hole ct _ = isHoleCt ct
+
skolem_eq _ (EqPred ty1 ty2) = isRigidOrSkol ty1 && isRigidOrSkol ty2
skolem_eq _ _ = False
@@ -238,63 +292,38 @@ isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of
_ -> 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_ev ct) $
- mk_err ct;
- ; reportError err })
-
-tryReporters :: [(String, Ct -> PredTree -> Bool, Reporter)] -> Reporter -> Reporter
--- Use the first reporter in the list whose predicate says True
-tryReporters reporters deflt cts
- = do { traceTc "tryReporters {" (ppr cts)
- ; go reporters cts
- ; traceTc "tryReporters }" empty }
- where
- 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
- | isIPPred (ctPred ct) = mkIPErr ctxt [ct]
+ | isHoleCt ct
+ = mkHoleError ctxt ct
| otherwise
= case classifyPredType (ctPred ct) of
- ClassPred {} -> mkDictErr ctxt [ct]
+ ClassPred cls _ | isIPClass cls -> mkIPErr ctxt [ct]
+ | otherwise -> mkDictErr ctxt [ct]
IrredPred {} -> mkIrredErr ctxt [ct]
EqPred {} -> mkEqErr1 ctxt ct
TuplePred {} -> panic "mkFlat"
-reportAmbigErrs :: ReportErrCtxt -> Reporter
+reportAmbigErrs :: 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
+reportFlatErrs :: 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
+reportFlatErrs
= 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
+ [ ("Equalities", is_equality, mkGroupReporter mkEqErr) ]
+ (\ctxt cts -> do { let (dicts, ips, irreds) = go cts [] [] []
+ ; mkGroupReporter mkIPErr ctxt ips
+ ; mkGroupReporter mkIrredErr ctxt irreds
+ ; mkGroupReporter mkDictErr ctxt dicts })
where
is_equality _ (EqPred {}) = True
is_equality _ _ = False
@@ -307,28 +336,41 @@ reportFlatErrs ctxt cts
= case classifyPredType (ctPred ct) of
ClassPred {} -> go cts (ct:dicts) ips irreds
IrredPred {} -> go cts dicts ips (ct:irreds)
- _ -> panic "mkFlat"
+ _ -> panic "reportFlatErrs"
-- 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
+-- Reporters
--------------------------------------------
-groupErrs :: ([Ct] -> TcM ErrMsg) -- Deal with one group
- -> [Ct] -- Unsolved wanteds
- -> TcM ()
+type Reporter = ReportErrCtxt -> [Ct] -> TcM ()
+
+mkUniReporter :: (ReportErrCtxt -> Ct -> TcM ErrMsg) -> Reporter
+-- Reports errors one at a time
+mkUniReporter mk_err ctxt
+ = mapM_ $ \ct ->
+ do { ctxt' <- relevantBindings ctxt ct
+ ; err <- setCtFlavorLoc (cc_ev ct) $
+ mk_err ctxt' ct;
+ ; reportError err }
+
+mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg)
+ -- Make error message for a group
+ -> Reporter -- Deal with lots of constraints
-- Group together insts from same location
-- We want to report them together in error messages
-groupErrs _ []
+mkGroupReporter _ _ []
= return ()
-groupErrs mk_err (ct1 : rest)
- = do { err <- setCtFlavorLoc flavor $ mk_err cts
- ; reportError err
- ; groupErrs mk_err others }
+mkGroupReporter mk_err ctxt (ct1 : rest)
+ = do { ctxt' <- relevantBindings ctxt ct1
+ ; err <- setCtFlavorLoc flavor $
+ mk_err ctxt' cts
+ ; reportError err
+ ; mkGroupReporter mk_err ctxt others }
where
flavor = cc_ev ct1
cts = ct1 : friends
@@ -342,7 +384,26 @@ groupErrs mk_err (ct1 : rest)
same_group _ _ = False
same_loc :: CtLoc o -> CtLoc o -> Bool
- same_loc (CtLoc _ s1 _) (CtLoc _ s2 _) = s1==s2
+ same_loc l1 l2 = ctLocSpan l1 == ctLocSpan l2
+
+
+tryReporters :: [(String, Ct -> PredTree -> Bool, Reporter)]
+ -> Reporter -> Reporter
+-- Use the first reporter in the list whose predicate says True
+tryReporters reporters deflt ctxt cts
+ = do { traceTc "tryReporters {" (ppr cts)
+ ; go reporters cts
+ ; traceTc "tryReporters }" empty }
+ where
+ go [] cts = deflt ctxt 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 ctxt yeses
+ where
+ yeses = filter keep_me cts
+ keep_me ct = pred ct (classifyPredType (ctPred ct))
-- Add the "arising from..." part to a message about bunch of dicts
addArising :: CtOrigin -> SDoc -> SDoc
@@ -447,6 +508,47 @@ mkIrredErr ctxt cts
msg = couldNotDeduce givens (map ctPred cts, orig)
\end{code}
+\begin{code}
+mkHoleError :: ReportErrCtxt -> Ct -> TcM ErrMsg
+mkHoleError ctxt ct@(CHoleCan {})
+ = do { let env0 = cec_tidy ctxt
+ ; let vars = tyVarsOfCt ct
+
+ ; zonked_vars <- zonkTyVarsAndFV vars
+
+ ; (env1, zonked_ty) <- zonkTidyTcType env0 (cc_hole_ty ct)
+
+ ; let (env2, tyvars) = tidyOpenTyVars env1 (varSetElems zonked_vars)
+
+ ; tyvars_msg <- mapM loc_msg tyvars
+
+ ; traceTc "mkHoleError" (ppr env2)
+
+ ; let msg = (text "Found hole" <+> quotes (text "_") <+> text "with type") <+> pprType zonked_ty
+ $$ (if null tyvars_msg then empty else text "Where:" <+> vcat tyvars_msg)
+
+ ; mkErrorReport ctxt msg
+ }
+ where
+ loc_msg tv = case tcTyVarDetails tv of
+ SkolemTv {} -> return $ (quotes $ ppr tv) <+> skol_msg
+ MetaTv {} -> do { tyvar <- readMetaTyVar tv
+ ; return $ case tyvar of
+ (Indirect ty) -> (quotes $ pprType ty) <+> skol_msg
+ Flexi -> (quotes $ ppr tv) <+> text "is a free type variable"
+ }
+ det -> return $ pprTcTyVarDetails det
+ where skol_msg = ppr_skol (getSkolemInfo (cec_encl ctxt) tv) (getSrcLoc tv)
+
+ ppr_skol given_loc tv_loc = case skol_info of
+ UnkSkol -> ptext (sLit "is an unknown type variable")
+ _ -> sep [ ptext (sLit "is a rigid type variable bound by"),
+ sep [ppr skol_info, ptext (sLit "at") <+> ppr tv_loc]]
+ where
+ skol_info = ctLocOrigin given_loc
+
+mkHoleError _ ct = pprPanic "mkHoleError" (ppr ct)
+\end{code}
%************************************************************************
%* *
@@ -541,6 +643,12 @@ reportEqErr ctxt ct oriented ty1 ty2
mkTyVarEqErr :: ReportErrCtxt -> Ct -> Bool -> TcTyVar -> TcType -> TcM ErrMsg
-- tv1 and ty2 are already tidied
mkTyVarEqErr ctxt ct oriented tv1 ty2
+ -- Occurs check
+ | isNothing (occurCheckExpand tv1 ty2)
+ = let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2
+ (sep [ppr ty1, char '~', ppr ty2])
+ in mkErrorReport ctxt occCheckMsg
+
| 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)
@@ -552,12 +660,6 @@ mkTyVarEqErr ctxt ct oriented tv1 ty2
| not (k2 `tcIsSubKind` k1) -- Kind error
= mkErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2)
- -- Occurs check
- | isNothing (occurCheckExpand tv1 ty2)
- = let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2
- (sep [ppr ty1, char '=', ppr ty2])
- in mkErrorReport ctxt occCheckMsg
-
-- Check for skolem escape
| (implic:_) <- cec_encl ctxt -- Get the innermost context
, let esc_skols = filter (`elemVarSet` (tyVarsOfType ty2)) (ic_skols implic)
@@ -565,8 +667,7 @@ mkTyVarEqErr ctxt ct oriented tv1 ty2
, not (null esc_skols)
= setCtLoc implic_loc $ -- Override the error message location from the
-- place the equality arose to the implication site
- do { (ctxt', env_sigs) <- findGlobals ctxt (unitVarSet tv1)
- ; let msg = misMatchMsg oriented ty1 ty2
+ do { let msg = misMatchMsg oriented ty1 ty2
esc_doc = sep [ ptext (sLit "because type variable") <> plural esc_skols
<+> pprQuotedList esc_skols
, ptext (sLit "would escape") <+>
@@ -578,7 +679,7 @@ mkTyVarEqErr ctxt ct oriented tv1 ty2
else ptext (sLit "These (rigid, skolem) type variables are"))
<+> ptext (sLit "bound by")
, nest 2 $ ppr (ctLocOrigin implic_loc) ] ]
- ; mkErrorReport ctxt' (msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) }
+ ; mkErrorReport ctxt (msg $$ extra1) }
-- Nastiest case: attempt to unify an untouchable variable
| (implic:_) <- cec_encl ctxt -- Get the innermost context
@@ -628,7 +729,7 @@ misMatchOrCND :: ReportErrCtxt -> Ct -> Bool -> TcType -> TcType -> SDoc
misMatchOrCND ctxt ct oriented ty1 ty2
| null givens ||
(isRigid ty1 && isRigid ty2) ||
- isGiven (cc_ev ct)
+ isGivenCt ct
-- If the equality is unconditionally insoluble
-- or there is no context, don't report the context
= misMatchMsg oriented ty1 ty2
@@ -979,9 +1080,19 @@ mkAmbigMsg ctxt cts
= return (ctxt, False, empty)
| otherwise
= do { dflags <- getDynFlags
- ; (ctxt', gbl_docs) <- findGlobals ctxt ambig_tv_set
- ; return (ctxt', True, mk_msg dflags gbl_docs) }
+
+ ; prs <- mapSndM zonkTcType $
+ [ (id, idType id) | TcIdBndr id top_lvl <- ct1_bndrs
+ , isTopLevel top_lvl ]
+ ; let ambig_ids = [id | (id, zonked_ty) <- prs
+ , tyVarsOfType zonked_ty `intersectsVarSet` ambig_tv_set]
+ ; return (ctxt, True, mk_msg dflags ambig_ids) }
where
+ ct1_bndrs = case cts of
+ (ct1:_) -> ASSERT( not (isGivenCt ct1) )
+ tcl_bndrs (ctLocEnv (ctWantedLoc ct1))
+ [] -> panic "mkAmbigMsg"
+
ambig_tv_set = foldr (unionVarSet . filterVarSet isAmbiguousTyVar . tyVarsOfCt)
emptyVarSet cts
ambig_tvs = varSetElems ambig_tv_set
@@ -989,7 +1100,7 @@ mkAmbigMsg ctxt cts
is_or_are | isSingleton ambig_tvs = text "is"
| otherwise = text "are"
- mk_msg dflags docs
+ mk_msg dflags ambig_ids
| any isRuntimeUnkSkol ambig_tvs -- See Note [Runtime skolems]
= vcat [ ptext (sLit "Cannot resolve unknown runtime type") <> plural ambig_tvs
<+> pprQuotedList ambig_tvs
@@ -998,17 +1109,17 @@ mkAmbigMsg ctxt cts
= 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 ambig_ids ]
- mk_extra_msg dflags docs
- | null docs
+ mk_extra_msg dflags ambig_ids
+ | null ambig_ids
= 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)
+ = vcat [ hang (ptext (sLit "Possible cause: the monomorphism restriction applied to:"))
+ 2 (pprWithCommas (quotes . ppr) ambig_ids)
, ptext (sLit "Probable fix:") <+> vcat
[ ptext (sLit "give these definition(s) an explicit type signature")
, if xopt Opt_MonomorphismRestriction dflags
@@ -1021,77 +1132,63 @@ getSkolemInfo :: [Implication] -> TcTyVar -> GivenLoc
-- 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 )
- CtLoc UnkSkol noSrcSpan []
+ = pprPanic "No skolem info:" (ppr tv)
getSkolemInfo (implic:implics) tv
| tv `elem` ic_skols implic = ic_loc implic
| otherwise = getSkolemInfo implics tv
-----------------------
--- findGlobals looks at the value environment and finds values whose
+-- relevantBindings looks at the value environment and finds values whose
-- types mention any of the offending type variables. It has to be
-- careful to zonk the Id's type first, so it has to be in the monad.
-- We must be careful to pass it a zonked type variable, too.
-mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
-mkEnvSigMsg what env_sigs
- | null env_sigs = empty
- | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
- , nest 2 (vcat env_sigs) ]
-
-findGlobals :: ReportErrCtxt
- -> TcTyVarSet
- -> TcM (ReportErrCtxt, [SDoc])
-
-findGlobals ctxt tvs
- = do { lcl_ty_env <- case cec_encl ctxt of
- [] -> getLclTypeEnv
- (i:_) -> return (ic_env i)
- ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
+relevantBindings :: ReportErrCtxt
+ -> Ct
+ -> TcM ReportErrCtxt
+ -- cec_extra includes info about relevant bindings
+relevantBindings ctxt ct
+ = do { (tidy_env', docs) <- go (cec_tidy ctxt) (6, emptyVarSet)
+ (reverse (tcl_bndrs lcl_env))
+ -- The 'reverse' makes us work from outside in
+ -- Blargh; maybe have a flag for this "6"
+
+ ; traceTc "relevantBindings" (ppr [id | TcIdBndr id _ <- tcl_bndrs lcl_env])
+ ; let doc = hang (ptext (sLit "Relevant bindings include"))
+ 2 (vcat docs)
+ ; if null docs
+ then return ctxt
+ else return (ctxt { cec_tidy = tidy_env'
+ , cec_extra = doc $$ cec_extra ctxt }) }
where
- 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
+ lcl_env = ctEvEnv (cc_ev ct)
+ ct_tvs = tyVarsOfCt ct
+
+ go :: TidyEnv -> (Int, TcTyVarSet)
+ -> [TcIdBinder] -> TcM (TidyEnv, [SDoc])
+ go tidy_env (_,_) []
+ = return (tidy_env, [])
+ go tidy_env (n_left,tvs_seen) (TcIdBndr id _ : tc_bndrs)
+ | n_left <= 0, ct_tvs `subVarSet` tvs_seen
+ = -- We have run out of n_left, and we
+ -- already have bindings mentioning all of ct_tvs
+ go tidy_env (n_left,tvs_seen) tc_bndrs
+ | otherwise
+ = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id)
+ ; let id_tvs = tyVarsOfType tidy_ty
+ doc = sep [ ppr id <+> dcolon <+> ppr tidy_ty
+ , nest 2 (parens (ptext (sLit "bound at")
+ <+> ppr (getSrcLoc id)))]
+ ; if id_tvs `intersectsVarSet` ct_tvs
+ && (n_left > 0 || not (id_tvs `subVarSet` tvs_seen))
+ -- Either we n_left is big enough,
+ -- or this binding mentions a new type variable
+ then do { (env', docs) <- go tidy_env' (n_left - 1, tvs_seen `unionVarSet` id_tvs) tc_bndrs
+ ; return (env', doc:docs) }
+ else go tidy_env (n_left, tvs_seen) tc_bndrs }
-----------------------
-find_thing :: TidyEnv -> (TcType -> Bool)
- -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
-find_thing tidy_env ignore_it (ATcId { tct_id = id })
- = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id)
- ; if ignore_it tidy_ty then
- return (tidy_env, Nothing)
- else do
- { let msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
- , nest 2 (parens (ptext (sLit "bound at") <+>
- ppr (getSrcLoc id)))]
- ; return (tidy_env', Just msg) } }
-
-find_thing tidy_env ignore_it (ATyVar name tv)
- = do { ty <- zonkTcTyVar tv
- ; let (tidy_env1, tidy_ty) = tidyOpenType tidy_env ty
- ; if ignore_it tidy_ty then
- return (tidy_env, Nothing)
- else do
- { let -- The name tv is scoped, so we don't need to tidy it
- msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr name) <+> eq_stuff
- , nest 2 bound_at]
-
- eq_stuff | Just tv' <- tcGetTyVar_maybe tidy_ty
- , getOccName name == getOccName tv' = empty
- | otherwise = equals <+> ppr tidy_ty
- -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
- bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc name)
-
- ; return (tidy_env1, Just msg) } }
-
-find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
-
warnDefaulting :: Cts -> Type -> TcM ()
warnDefaulting wanteds default_ty
= do { warn_default <- woptM Opt_WarnTypeDefaults
View
9 compiler/typecheck/TcExpr.lhs
@@ -231,6 +231,15 @@ tcExpr (HsType ty) _
-- so it's not enabled yet.
-- Can't eliminate it altogether from the parser, because the
-- same parser parses *patterns*.
+tcExpr HsHole res_ty
+ = do { ty <- newFlexiTyVarTy liftedTypeKind
+ ; traceTc "tcExpr.HsHole" (ppr ty)
+ ; ev <- mkSysLocalM (mkFastString "_") ty
+ ; loc <- getCtLoc HoleOrigin
+ ; let can = CHoleCan { cc_ev = CtWanted loc ty ev, cc_hole_ty = ty, cc_depth = 0 }
+ ; traceTc "tcExpr.HsHole emitting" (ppr can)
+ ; emitInsoluble can
+ ; tcWrapResult (HsVar ev) ty res_ty }
\end{code}
View
3  compiler/typecheck/TcHsSyn.lhs
@@ -713,6 +713,9 @@ zonkExpr env (HsWrap co_fn expr)
zonkExpr env1 expr `thenM` \ new_expr ->
return (HsWrap new_co_fn new_expr)
+zonkExpr _ HsHole
+ = return HsHole
+
zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
View
14 compiler/typecheck/TcMType.lhs
@@ -725,12 +725,14 @@ zonkWC function an evidence variable to collect all the extra
variables.
\begin{code}
-
zonkCt :: Ct -> TcM Ct
zonkCt ct
- = do { fl' <- zonkCtEvidence (cc_ev ct)
- ; return (CNonCanonical { cc_ev = fl'
- , cc_depth = cc_depth ct }) }
+ | isHoleCt ct = do { fl' <- zonkCtEvidence (cc_ev ct)
+ ; return $ ct { cc_ev = fl' } }
+ | otherwise = do { fl' <- zonkCtEvidence (cc_ev ct)
+ ; return $
+ CNonCanonical { cc_ev = fl'
+ , cc_depth = cc_depth ct } }
zonkCtEvidence :: CtEvidence -> TcM CtEvidence
zonkCtEvidence ctev@(CtGiven { ctev_gloc = loc, ctev_pred = pred })
@@ -746,9 +748,9 @@ zonkCtEvidence ctev@(CtDerived { ctev_pred = pred })
zonkGivenLoc :: GivenLoc -> TcM GivenLoc
-- GivenLocs may have unification variables inside them!
-zonkGivenLoc (CtLoc skol_info span ctxt)
+zonkGivenLoc (CtLoc skol_info lcl)
= do { skol_info' <- zonkSkolemInfo skol_info
- ; return (CtLoc skol_info' span ctxt) }
+ ; return (CtLoc skol_info' lcl) }
zonkSkolemInfo :: SkolemInfo -> TcM SkolemInfo
zonkSkolemInfo (SigSkol cx ty) = do { ty' <- zonkTcType ty
View
35 compiler/typecheck/TcRnMonad.lhs
@@ -146,6 +146,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
tcl_th_ctxt = topStage,
tcl_arrow_ctxt = NoArrowCtxt,
tcl_env = emptyNameEnv,
+ tcl_bndrs = [],
tcl_tidy = emptyTidyEnv,
tcl_tyvars = tvs_var,
tcl_lie = lie_var,
@@ -366,15 +367,8 @@ newUniqueSupply
writeMutVar u_var us1 ;
return us2 }}}
-newLocalName :: Name -> TcRnIf gbl lcl Name
-newLocalName name -- Make a clone
- = do { uniq <- newUnique
- ; return (mkInternalName uniq (nameOccName name) (getSrcSpan name)) }
-
-newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
-newSysLocalIds fs tys
- = do { us <- newUniqueSupply
- ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) }
+newLocalName :: Name -> TcM Name
+newLocalName name = newName (nameOccName name)
newName :: OccName -> TcM Name
newName occ
@@ -382,6 +376,11 @@ newName occ
; loc <- getSrcSpanM
; return (mkInternalName uniq occ loc) }
+newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
+newSysLocalIds fs tys
+ = do { us <- newUniqueSupply
+ ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) }
+
instance MonadUnique (IOEnv (Env gbl lcl)) where
getUniqueM = newUnique
getUniqueSupplyM = newUniqueSupply
@@ -818,12 +817,15 @@ popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
getCtLoc :: orig -> TcM (CtLoc orig)
getCtLoc origin
- = do { loc <- getSrcSpanM ; env <- getLclEnv ;
- return (CtLoc origin loc (tcl_ctxt env)) }
+ = do { env <- getLclEnv ; return (CtLoc origin env) }
setCtLoc :: CtLoc orig -> TcM a -> TcM a
-setCtLoc (CtLoc _ src_loc ctxt) thing_inside
- = setSrcSpan src_loc (setErrCtxt ctxt thing_inside)
+-- Set the SrcSpan and error context from the CtLoc
+setCtLoc (CtLoc _ lcl) thing_inside
+ = updLclEnv (\env -> env { tcl_loc = tcl_loc lcl
+ , tcl_bndrs = tcl_bndrs lcl
+ , tcl_ctxt = tcl_ctxt lcl })
+ thing_inside
\end{code}
%************************************************************************
@@ -1024,6 +1026,13 @@ emitImplications ct
= do { lie_var <- getConstraintVar ;
updTcRef lie_var (`addImplics` ct) }
+emitInsoluble :: Ct -> TcM ()
+emitInsoluble ct
+ = do { lie_var <- getConstraintVar ;
+ updTcRef lie_var (`addInsols` unitBag ct) ;
+ v <- readTcRef lie_var ;
+ traceTc "emitInsoluble" (ppr v) }
+
captureConstraints :: TcM a -> TcM (a, WantedConstraints)
-- (captureConstraints m) runs m, and returns the type constraints it generates
captureConstraints thing_inside
View
96 compiler/typecheck/TcRnTypes.lhs
@@ -38,7 +38,7 @@ module TcRnTypes(
WhereFrom(..), mkModDeps,
-- Typechecker types
- TcTypeEnv, TcTyThing(..), PromotionErr(..),
+ TcTypeEnv, TcIdBinder(..), TcTyThing(..), PromotionErr(..),
pprTcTyThingCategory, pprPECategory,
-- Template Haskell
@@ -53,16 +53,16 @@ module TcRnTypes(
singleCt, extendCts, isEmptyCts, isCTyEqCan, isCFunEqCan,
isCDictCan_Maybe, isCFunEqCan_Maybe,
isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt,
- isGivenCt,
+ isGivenCt, isHoleCt,
ctWantedLoc, ctEvidence,
SubGoalDepth, mkNonCanonical, mkNonCanonicalCt,
- ctPred, ctEvPred, ctEvTerm, ctEvId,
+ ctPred, ctEvPred, ctEvTerm, ctEvId, ctEvEnv,
WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC,
- andWC, addFlats, addImplics, mkFlatWC,
+ andWC, unionsWC, addFlats, addImplics, mkFlatWC, addInsols,
Implication(..),
- CtLoc(..), ctLocSpan, ctLocOrigin, setCtLocOrigin,
+ CtLoc(..), ctLocSpan, ctLocEnv, ctLocOrigin, setCtLocOrigin,
CtOrigin(..), EqOrigin(..),
WantedLoc, GivenLoc, pushErrCtxt,
pushErrCtxtSameOrigin,
@@ -121,7 +121,6 @@ import FastString
import Util
import Data.Set (Set)
-
\end{code}
@@ -408,12 +407,11 @@ Why? Because they are now Ids not TcIds. This final GlobalEnv is
data TcLclEnv -- Changes as we move inside an expression
-- Discarded after typecheck/rename; not passed on to desugarer
= TcLclEnv {
- tcl_loc :: SrcSpan, -- Source span
- tcl_ctxt :: [ErrCtxt], -- Error context, innermost on top
- tcl_errs :: TcRef Messages, -- Place to accumulate errors
-
- tcl_th_ctxt :: ThStage, -- Template Haskell context
- tcl_arrow_ctxt :: ArrowCtxt, -- Arrow-notation context
+ tcl_loc :: SrcSpan, -- Source span
+ tcl_ctxt :: [ErrCtxt], -- Error context, innermost on top
+ tcl_untch :: Untouchables, -- Birthplace for new unification variables
+ tcl_th_ctxt :: ThStage, -- Template Haskell context
+ tcl_arrow_ctxt :: ArrowCtxt, -- Arrow-notation context
tcl_rdr :: LocalRdrEnv, -- Local name envt
-- Maintained during renaming, of course, but also during
@@ -427,8 +425,11 @@ data TcLclEnv -- Changes as we move inside an expression
-- We still need the unsullied global name env so that
-- we can look up record field names
- tcl_env :: TcTypeEnv, -- The local type environment: Ids and
- -- TyVars defined in this module
+ tcl_env :: TcTypeEnv, -- The local type environment:
+ -- Ids and TyVars defined in this module
+
+ tcl_bndrs :: [TcIdBinder], -- Stack of locally-bound Ids, innermost on top
+ -- Used only for error reporting
tcl_tidy :: TidyEnv, -- Used for tidying types; contains all
-- in-scope type variables (but not term variables)
@@ -439,12 +440,12 @@ data TcLclEnv -- Changes as we move inside an expression
-- in tcl_lenv.
-- Why mutable? see notes with tcGetGlobalTyVars
- tcl_lie :: TcRef WantedConstraints, -- Place to accumulate type constraints
- tcl_untch :: Untouchables
+ tcl_lie :: TcRef WantedConstraints, -- Place to accumulate type constraints
+ tcl_errs :: TcRef Messages -- Place to accumulate errors
}
type TcTypeEnv = NameEnv TcTyThing
-
+data TcIdBinder = TcIdBndr TcId TopLevelFlag
{- Note [Given Insts]
~~~~~~~~~~~~~~~~~~
@@ -900,6 +901,13 @@ data Ct
cc_ev :: CtEvidence,
cc_depth :: SubGoalDepth
}
+
+ | CHoleCan {
+ cc_ev :: CtEvidence,
+ cc_hole_ty :: TcTauType, -- Not a Xi! See same not as above
+ cc_depth :: SubGoalDepth -- See Note [WorkList]
+ }
+
\end{code}
Note [Ct/evidence invariant]
@@ -979,6 +987,11 @@ isCFunEqCan _ = False
isCNonCanonical :: Ct -> Bool
isCNonCanonical (CNonCanonical {}) = True
isCNonCanonical _ = False
+
+isHoleCt:: Ct -> Bool
+isHoleCt (CHoleCan {}) = True
+isHoleCt _ = False
+
\end{code}
\begin{code}
@@ -991,6 +1004,7 @@ instance Outputable Ct where
CNonCanonical {} -> "CNonCanonical"
CDictCan {} -> "CDictCan"
CIrredEvCan {} -> "CIrredEvCan"
+ CHoleCan {} -> "CHoleCan"
\end{code}
\begin{code}
@@ -1057,6 +1071,9 @@ andWC (WC { wc_flat = f1, wc_impl = i1, wc_insol = n1 })
, wc_impl = i1 `unionBags` i2
, wc_insol = n1 `unionBags` n2 }
+unionsWC :: [WantedConstraints] -> WantedConstraints
+unionsWC = foldr andWC emptyWC
+
addFlats :: WantedConstraints -> Bag Ct -> WantedConstraints
addFlats wc cts
= wc { wc_flat = wc_flat wc `unionBags` cts }
@@ -1064,6 +1081,10 @@ addFlats wc cts
addImplics :: WantedConstraints -> Bag Implication -> WantedConstraints
addImplics wc implic = wc { wc_impl = wc_impl wc `unionBags` implic }
+addInsols :: WantedConstraints -> Bag Ct -> WantedConstraints
+addInsols wc cts
+ = wc { wc_insol = wc_insol wc `unionBags` cts }
+
instance Outputable WantedConstraints where
ppr (WC {wc_flat = f, wc_impl = i, wc_insol = n})
= ptext (sLit "WC") <+> braces (vcat
@@ -1090,11 +1111,6 @@ data Implication
= Implic {
ic_untch :: Untouchables, -- Untouchables: unification variables
-- free in the environment
- ic_env :: TcTypeEnv, -- The type environment
- -- Used only when generating error messages
- -- Generally, ic_untch is a superset of tvsof(ic_env)
- -- However, we don't zonk ic_env when zonking the Implication
- -- Instead we do that when generating a skolem-escape error message
ic_skols :: [TcTyVar], -- Introduced skolems
-- See Note [Skolems in an implication]
@@ -1260,6 +1276,11 @@ ctEvTerm (CtWanted { ctev_evar = ev }) = EvId ev
ctEvTerm ctev@(CtDerived {}) = pprPanic "ctEvTerm: derived constraint cannot have id"
(ppr ctev)
+ctEvEnv :: CtEvidence -> TcLclEnv
+ctEvEnv (CtWanted { ctev_wloc = loc }) = ctLocEnv loc
+ctEvEnv (CtDerived { ctev_wloc = loc }) = ctLocEnv loc
+ctEvEnv (CtGiven { ctev_gloc = loc }) = ctLocEnv loc
+
ctEvId :: CtEvidence -> TcId
ctEvId (CtWanted { ctev_evar = ev }) = ev
ctEvId ctev = pprPanic "ctEvId:" (ppr ctev)
@@ -1339,26 +1360,35 @@ dictionaries don't appear in the original source code.
type will evolve...
\begin{code}
-data CtLoc orig = CtLoc orig SrcSpan [ErrCtxt]
+data CtLoc orig = CtLoc orig TcLclEnv
+ -- The TcLclEnv includes particularly
+ -- source location: tcl_loc :: SrcSpan
+ -- context: tcl_ctxt :: [ErrCtxt]
+ -- binder stack: tcl_bndrs :: [TcIdBinders]
+
+type WantedLoc = CtLoc CtOrigin -- Instantiation for wanted constraints
+type GivenLoc = CtLoc SkolemInfo -- Instantiation for given constraints
-type WantedLoc = CtLoc CtOrigin -- Instantiation for wanted constraints
-type GivenLoc = CtLoc SkolemInfo -- Instantiation for given constraints
+ctLocEnv :: CtLoc o -> TcLclEnv
+ctLocEnv (CtLoc _ lcl) = lcl
ctLocSpan :: CtLoc o -> SrcSpan
-ctLocSpan (CtLoc _ s _) = s
+ctLocSpan (CtLoc _ lcl) = tcl_loc lcl
ctLocOrigin :: CtLoc o -> o
-ctLocOrigin (CtLoc o _ _) = o
+ctLocOrigin (CtLoc o _) = o
setCtLocOrigin :: CtLoc o -> o' -> CtLoc o'
-setCtLocOrigin (CtLoc _ s c) o = CtLoc o s c
+setCtLocOrigin (CtLoc _ lcl) o = CtLoc o lcl
pushErrCtxt :: orig -> ErrCtxt -> CtLoc orig -> CtLoc orig
-pushErrCtxt o err (CtLoc _ s errs) = CtLoc o s (err:errs)
+pushErrCtxt o err (CtLoc _ lcl)
+ = CtLoc o (lcl { tcl_ctxt = err : tcl_ctxt lcl })
pushErrCtxtSameOrigin :: ErrCtxt -> CtLoc orig -> CtLoc orig
-- Just add information w/o updating the origin!
-pushErrCtxtSameOrigin err (CtLoc o s errs) = CtLoc o s (err:errs)
+pushErrCtxtSameOrigin err (CtLoc o lcl)
+ = CtLoc o (lcl { tcl_ctxt = err : tcl_ctxt lcl })
pprArising :: CtOrigin -> SDoc
-- Used for the main, top-level error message
@@ -1368,8 +1398,8 @@ pprArising FunDepOrigin = empty
pprArising orig = text "arising from" <+> ppr orig
pprArisingAt :: Outputable o => CtLoc o -> SDoc
-pprArisingAt (CtLoc o s _) = sep [ text "arising from" <+> ppr o
- , text "at" <+> ppr s]
+pprArisingAt (CtLoc o lcl) = sep [ text "arising from" <+> ppr o
+ , text "at" <+> ppr (tcl_loc lcl)]
\end{code}
%************************************************************************
@@ -1496,6 +1526,7 @@ data CtOrigin
| ProcOrigin -- Arising from a proc expression
| AnnOrigin -- An annotation
| FunDepOrigin
+ | HoleOrigin
data EqOrigin
= UnifyOrigin
@@ -1533,6 +1564,7 @@ pprO ProcOrigin = ptext (sLit "a proc expression")
pprO (TypeEqOrigin eq) = ptext (sLit "an equality") <+> ppr eq
pprO AnnOrigin = ptext (sLit "an annotation")
pprO FunDepOrigin = ptext (sLit "a functional dependency")
+pprO HoleOrigin = ptext (sLit "a use of the hole") <+> quotes (ptext $ sLit "_")
instance Outputable EqOrigin where
ppr (UnifyOrigin t1 t2) = ppr t1 <+> char '~' <+> ppr t2
View
28 compiler/typecheck/TcRules.lhs
@@ -26,7 +26,6 @@ import TcEnv
import TcEvidence( TcEvBinds(..) )
import Type
import Id
-import NameEnv( emptyNameEnv )
import Name
import Var
import VarSet
@@ -139,10 +138,10 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
-- Note [Typechecking rules]
; vars <- tcRuleBndrs hs_bndrs
- ; let (id_bndrs, tv_bndrs) = partition (isId . snd) vars
+ ; let (id_bndrs, tv_bndrs) = partition isId vars
; (lhs', lhs_wanted, rhs', rhs_wanted, rule_ty)
- <- tcExtendTyVarEnv2 tv_bndrs $
- tcExtendIdEnv2 id_bndrs $
+ <- tcExtendTyVarEnv tv_bndrs $
+ tcExtendIdEnv id_bndrs $
do { ((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs)
; (rhs', rhs_wanted) <- captureConstraints (tcMonoExpr rhs rule_ty)
; return (lhs', lhs_wanted, rhs', rhs_wanted, rule_ty) }
@@ -161,7 +160,7 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
-- the LHS, lest they otherwise get defaulted to Any; but we do that
-- during zonking (see TcHsSyn.zonkRule)
- ; let tpl_ids = lhs_evs ++ map snd id_bndrs
+ ; let tpl_ids = lhs_evs ++ id_bndrs
forall_tvs = tyVarsOfTypes (rule_ty : map idType tpl_ids)
; zonked_forall_tvs <- zonkTyVarsAndFV forall_tvs
; gbl_tvs <- tcGetGlobalTyVars -- Already zonked
@@ -181,7 +180,6 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
; loc <- getCtLoc (RuleSkol name)
; rhs_binds_var <- newTcEvBinds
; emitImplication $ Implic { ic_untch = noUntouchables
- , ic_env = emptyNameEnv
, ic_skols = qtkvs
, ic_fsks = []
, ic_given = lhs_evs
@@ -195,7 +193,6 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
-- (b) so that we bind any soluble ones
; lhs_binds_var <- newTcEvBinds
; emitImplication $ Implic { ic_untch = noUntouchables
- , ic_env = emptyNameEnv
, ic_skols = qtkvs
, ic_fsks = []
, ic_given = lhs_evs
@@ -209,25 +206,30 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
(mkHsDictLet (TcEvBinds lhs_binds_var) lhs') fv_lhs
(mkHsDictLet (TcEvBinds rhs_binds_var) rhs') fv_rhs) }
-tcRuleBndrs :: [RuleBndr Name] -> TcM [(Name, Var)]
+tcRuleBndrs :: [RuleBndr Name] -> TcM [Var]
tcRuleBndrs []
= return []
tcRuleBndrs (RuleBndr (L _ name) : rule_bndrs)
= do { ty <- newFlexiTyVarTy openTypeKind
; vars <- tcRuleBndrs rule_bndrs
- ; return ((name, mkLocalId name ty) : vars) }
+ ; return (mkLocalId name ty : vars) }
tcRuleBndrs (RuleBndrSig (L _ name) rn_ty : rule_bndrs)
-- e.g x :: a->a
-- The tyvar 'a' is brought into scope first, just as if you'd written
-- a::*, x :: a->a
= do { let ctxt = RuleSigCtxt name
- ; (id_ty, skol_tvs) <- tcHsPatSigType ctxt rn_ty
- ; let id = mkLocalId name id_ty
+ ; (id_ty, tv_prs) <- tcHsPatSigType ctxt rn_ty
+ ; let id = mkLocalId name id_ty
+ tvs = map snd tv_prs
+ -- tcHsPatSigType returns (Name,TyVar) pairs
+ -- for for RuleSigCtxt their Names are not
+ -- cloned, so we get (n, tv-with-name-n) pairs
+ -- See Note [Pattern signature binders] in TcHsType
-- The type variables scope over subsequent bindings; yuk
- ; vars <- tcExtendTyVarEnv2 skol_tvs $
+ ; vars <- tcExtendTyVarEnv tvs $
tcRuleBndrs rule_bndrs
- ; return (skol_tvs ++ (name, id) : vars) }
+ ; return (tvs ++ id : vars) }
ruleCtxt :: FastString -> SDoc
ruleCtxt name = ptext (sLit "When checking the transformation rule") <+>
View
36 compiler/typecheck/TcSMonad.lhs
@@ -22,7 +22,7 @@ module TcSMonad (
updTcSImplics,
Ct(..), Xi, tyVarsOfCt, tyVarsOfCts,
- emitFrozenError,
+ emitInsoluble,
isWanted, isDerived,
isGivenCt, isWantedCt, isDerivedCt, pprFlavorArising,
@@ -88,7 +88,6 @@ module TcSMonad (
matchClass, matchFam, MatchInstResult (..),
checkWellStagedDFun,
- warnTcS,
pprEq -- Smaller utils, re-exported from TcM
-- TODO (DV): these are only really used in the
-- instance matcher in TcSimplify. I am wondering
@@ -306,6 +305,9 @@ data CCanMap a
keepGivenCMap :: CCanMap a -> CCanMap a
keepGivenCMap cc = emptyCCanMap { cts_given = cts_given cc }
+instance Outputable (CCanMap a) where
+ ppr (CCanMap given derived wanted) = ptext (sLit "CCanMap") <+> (ppr given) <+> (ppr derived) <+> (ppr wanted)
+
cCanMapToBag :: CCanMap a -> Cts
cCanMapToBag cmap = foldUFM unionBags rest_wder (cts_given cmap)
where rest_wder = foldUFM unionBags rest_der (cts_wanted cmap)
@@ -592,8 +594,6 @@ insertInertItem :: Ct -> InertSet -> InertSet
-- Add a new inert element to the inert set.
insertInertItem item is
= -- A canonical Given, Wanted, or Derived
- ASSERT2( not (isCNonCanonical item), ppr item )
- -- Can't be CNonCanonical, because they only land in inert_insols
is { inert_cans = upd_inert_cans (inert_cans is) item }
where upd_inert_cans :: InertCans -> Ct -> InertCans
@@ -626,7 +626,9 @@ insertInertItem item is
(unFamHeadMap $ inert_funeqs ics)) }
| otherwise
= pprPanic "upd_inert set: can't happen! Inserting " $
- ppr item
+ ppr item -- Can't be CNonCanonical, CHoleCan,
+ -- because they only land in inert_insols
+
insertInertItemTcS :: Ct -> TcS ()
-- Add a new item in the inerts of the monad
@@ -813,6 +815,10 @@ extractRelevantInerts wi
where
fam_head = mkTyConApp (cc_fun ct) (cc_tyargs ct)
+ extract_ics_relevants (CHoleCan {}) ics
+ = pprPanic "extractRelevantInerts" (ppr wi)
+ -- Holes are put straight into inert_frozen, so never get here
+
extract_ics_relevants (CIrredEvCan { }) ics =
let cts = inert_irreds ics
in (cts, ics { inert_irreds = emptyCts })
@@ -1138,21 +1144,20 @@ updTcSImplics f
; wrapTcS $ do { implics <- TcM.readTcRef impl_ref
; TcM.writeTcRef impl_ref (f implics) } }
-emitFrozenError :: CtEvidence -> SubGoalDepth -> TcS ()
+emitInsoluble :: Ct -> TcS ()
-- Emits a non-canonical constraint that will stand for a frozen error in the inerts.
-emitFrozenError fl depth
- = do { traceTcS "Emit frozen error" (ppr (ctEvPred fl))
+emitInsoluble ct
+ = do { traceTcS "Emit insoluble" (ppr ct)
; updInertTcS add_insol }
where
add_insol is@(IS { inert_cans = ics@(IC { inert_insols = old_insols }) })
| already_there = is
- | otherwise = is { inert_cans = ics { inert_insols = extendCts old_insols insol_ct } }
+ | otherwise = is { inert_cans = ics { inert_insols = extendCts old_insols ct } }
where
- already_there = not (isWanted fl) && anyBag (eqType this_pred . ctPred) old_insols
+ already_there = not (isWantedCt ct) && anyBag (eqType this_pred . ctPred) old_insols
-- See Note [Do not add duplicate derived insolubles]
- insol_ct = CNonCanonical { cc_ev = fl, cc_depth = depth }
- this_pred = ctEvPred fl
+ this_pred = ctPred ct
getTcSImplicsRef :: TcS (IORef (Bag Implication))
getTcSImplicsRef = TcS (return . tcs_implics)
@@ -1195,11 +1200,6 @@ setWantedTyBind tv ty
\end{code}
\begin{code}
-warnTcS :: CtLoc orig -> Bool -> SDoc -> TcS ()
-warnTcS loc warn_if doc
- | warn_if = wrapTcS $ TcM.setCtLoc loc $ TcM.addWarnTc doc
- | otherwise = return ()
-
getDefaultInfo :: TcS ([Type], (Bool, Bool))
getDefaultInfo = wrapTcS TcM.tcGetDefaultTys
@@ -1613,13 +1613,11 @@ deferTcSForAllEq (loc,orig_ev) (tvs1,body1) (tvs2,body2)
new_ct = mkNonCanonical ctev
new_co = evTermCoercion (ctEvTerm ctev)
new_untch = pushUntouchables untch
- ; lcl_env <- wrapTcS $ TcM.getLclTypeEnv
; loc <- wrapTcS $ TcM.getCtLoc skol_info
; let wc = WC { wc_flat = singleCt new_ct
, wc_impl = emptyBag
, wc_insol = emptyCts }
imp = Implic { ic_untch = new_untch
- , ic_env = lcl_env
, ic_skols = skol_tvs
, ic_fsks = []
, ic_given = []
View
110 compiler/typecheck/TcSimplify.lhs
@@ -39,11 +39,9 @@ import PrelInfo
import PrelNames
import Class ( classKey )
import BasicTypes ( RuleName )
-import Control.Monad ( when )
import Outputable
import FastString
import TrieMap () -- DV: for now
-import DynFlags
\end{code}
@@ -67,9 +65,7 @@ simplifyTop wanteds
; traceTc "End simplifyTop }" empty
; traceTc "reportUnsolved {" empty
- -- See Note [Deferring coercion errors to runtime]
- ; runtimeCoercionErrors <- doptM Opt_DeferTypeErrors
- ; binds2 <- reportUnsolved runtimeCoercionErrors zonked_final_wc
+ ; binds2 <- reportUnsolved zonked_final_wc
; traceTc "reportUnsolved }" empty
; return (binds1 `unionBags` binds2) }
@@ -162,11 +158,10 @@ simplifyDefault theta
; traceTc "reportUnsolved {" empty
-- See Note [Deferring coercion errors to runtime]
- ; runtimeCoercionErrors <- doptM Opt_DeferTypeErrors
+ ; reportAllUnsolved unsolved
-- Postcondition of solveWantedsTcM is that returned
-- constraints are zonked. So Precondition of reportUnsolved
-- is true.
- ; _ <- reportUnsolved runtimeCoercionErrors unsolved
; traceTc "reportUnsolved }" empty
; return () }
@@ -220,7 +215,7 @@ simplifyDeriv orig pred tvs theta
-- 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 })
+ ; reportAllUnsolved (residual_wanted { wc_flat = bad })
; let min_theta = mkMinimalBySCs (bagToList good)
; return (substTheta subst_skol min_theta) }
@@ -343,17 +338,13 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds
; return (qtvs, [], False, emptyTcEvBinds) }
| otherwise
- = do { runtimeCoercionErrors <- doptM Opt_DeferTypeErrors
- ; gbl_tvs <- tcGetGlobalTyVars
- ; zonked_tau_tvs <- zonkTyVarsAndFV (tyVarsOfTypes (map snd name_taus))
+ = do { zonked_tau_tvs <- zonkTyVarsAndFV (tyVarsOfTypes (map snd name_taus))
; ev_binds_var <- newTcEvBinds
-
; traceTc "simplifyInfer {" $ vcat
[ ptext (sLit "names =") <+> ppr (map fst name_taus)
, ptext (sLit "taus =") <+> ppr (map snd name_taus)
, ptext (sLit "tau_tvs (zonked) =") <+> ppr zonked_tau_tvs
- , ptext (sLit "gbl_tvs =") <+> ppr gbl_tvs
, ptext (sLit "closed =") <+> ppr _top_lvl
, ptext (sLit "apply_mr =") <+> ppr apply_mr
, ptext (sLit "(unzonked) wanted =") <+> ppr wanteds
@@ -377,11 +368,6 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds
solve_wanteds_and_drop
-- Post: wanted_transformed are zonked
- -- Step 3) Fail fast if there is an insoluble constraint,
- -- unless we are deferring errors to runtime
- ; when (not runtimeCoercionErrors && insolubleWC wanted_transformed) $
- do { _ev_binds <- reportUnsolved False wanted_transformed; failM }
-
-- Step 4) Candidates for quantification are an approximation of wanted_transformed
-- NB: Already the fixpoint of any unifications that may have happened
-- NB: We do not do any defaulting when inferring a type, this can lead
@@ -393,18 +379,21 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds
-- care aout it
; (quant_pred_candidates, _extra_binds)
- <- runTcS $ do { let quant_candidates = approximateWC wanted_transformed
- ; traceTcS "simplifyWithApprox" $
- text "quant_candidates = " <+> ppr quant_candidates
- ; promoteTyVars quant_candidates
- ; _implics <- solveInteract quant_candidates
- ; (flats, _insols) <- getInertUnsolved
- -- NB: Dimitrios is slightly worried that we will get
- -- family equalities (F Int ~ alpha) in the quantification
- -- candidates, as we have performed no further unflattening
- -- at this point. Nothing bad, but inferred contexts might
- -- look complicated.
- ; return (map ctPred $ filter isWantedCt (bagToList flats)) }
+ <- if insolubleWC wanted_transformed
+ then return ([], emptyBag) -- See Note [Quantification with errors]
+ else runTcS $
+ do { let quant_candidates = approximateWC wanted_transformed
+ ; traceTcS "simplifyWithApprox" $
+ text "quant_candidates = " <+> ppr quant_candidates
+ ; promoteTyVars quant_candidates
+ ; _implics <- solveInteract quant_candidates
+ ; (flats, _insols) <- getInertUnsolved
+ -- NB: Dimitrios is slightly worried that we will get
+ -- family equalities (F Int ~ alpha) in the quantification
+ -- candidates, as we have performed no further unflattening
+ -- at this point. Nothing bad, but inferred contexts might
+ -- look complicated.
+ ; return (map ctPred $ filter isWantedCt (bagToList flats)) }
-- NB: quant_pred_candidates is already the fixpoint of any
-- unifications that may have happened
@@ -456,11 +445,9 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds
-- Step 7) Emit an implication
; minimal_bound_ev_vars <- mapM TcMType.newEvVar minimal_flat_preds
- ; lcl_env <- getLclTypeEnv
; gloc <- getCtLoc skol_info
; untch <- TcRnMonad.getUntouchables
; let implic = Implic { ic_untch = pushUntouchables untch
- , ic_env = lcl_env
, ic_skols = qtvs_to_return
, ic_fsks = [] -- wanted_tansformed arose only from solveWanteds
-- hence no flatten-skolems (which come from givens)
@@ -482,6 +469,15 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds
, mr_bites, TcEvBinds ev_binds_var) } }
\end{code}
+Note [Quantification with errors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we find that the RHS of the definition has some absolutely-insoluble
+constraints, we abandon all attempts to find a context to quantify
+over, and instead make the function fully-polymorphic in whatever
+type we have found. For two reasons
+ a) Minimise downstream errors
+ b) Avoid spurious errors from this function
+
Note [Default while Inferring]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -846,6 +842,9 @@ floatEqualities skols can_given wanteds@(WC { wc_flat = flats })
pred = ctPred ct
promoteTyVars :: Cts -> TcS ()
+-- When we float a constraint out of an implication we
+-- must restore (MetaTvInv) in Note [Untouchable type variables]
+-- in TcType
promoteTyVars cts
= do { untch <- TcSMonad.getUntouchables
; mapM_ (promote_tv untch) (varSetElems (tyVarsOfCts cts)) }
@@ -938,10 +937,15 @@ Consequence: classes with functional dependencies don't matter (since there is
no evidence for a fundep equality), but equality superclasses do matter (since
they carry evidence).
-Notice that, due to Note [Extra TcSTv Untouchables], the free unification variables
-of an equality that is floated out of an implication become effectively untouchables
-for the leftover implication. This is absolutely necessary. Consider the following
-example. We start with two implications and a class with a functional dependency.
+Note [Promoting unification variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we float an equality out of an implication we must "promote" free
+unification variables of the equality, in order to maintain Invariant
+(MetaTvInv) from Note [Untouchable type variables] in TcType. for the
+leftover implication.
+
+This is absolutely necessary. Consider the following example. We start
+with two implications and a class with a functional dependency.
class C x y | x -> y
instance C [a] [a]
@@ -975,40 +979,6 @@ beta! Concrete example is in indexed_types/should_fail/ExtraTcsUntch.hs:
g2 z = case z of TEx y -> (h [[undefined]], op x [y])
in (g1 '3', g2 undefined)
-Note [Extra TcsTv untouchables]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Whenever we are solving a bunch of flat constraints, they may contain
-the following sorts of 'touchable' unification variables:
-
- (i) Born-touchables in that scope
-
- (ii) Simplifier-generated unification variables, such as unification
- flatten variables
-
- (iii) Touchables that have been floated out from some nested
- implications, see Note [Float Equalities out of Implications].
-
-Now, once we are done with solving these flats and have to move inwards to
-the nested implications (perhaps for a second time), we must consider all the
-extra variables (categories (ii) and (iii) above) as untouchables for the
-implication. Otherwise we have the danger or double unifications, as well
-as the danger of not ``seeing'' some unification. Example (from Trac #4494):
-
- (F Int ~ uf) /\ [untch=beta](forall a. C a => F Int ~ beta)
-
-In this example, beta is touchable inside the implication. The
-first solveInteract step leaves 'uf' ununified. Then we move inside
-the implication where a new constraint
- uf ~ beta
-emerges. We may spontaneously solve it to get uf := beta, so the whole
-implication disappears but when we pop out again we are left with (F
-Int ~ uf) which will be unified by our final solveCTyFunEqs stage and
-uf will get unified *once more* to (F Int).
-
-The solution is to record the unification variables of the flats,
-and make them untouchables for the nested implication. In the
-example above uf would become untouchable, so beta would be forced
-to be unified as beta := uf.
Note [Solving Family Equations]
View
2  compiler/typecheck/TcUnify.lhs
@@ -439,10 +439,8 @@ newImplication skol_info skol_tvs given thing_inside
return (emptyTcEvBinds, result)
else do
{ ev_binds_var <- newTcEvBinds
- ; lcl_env <- getLclTypeEnv
; loc <- getCtLoc skol_info
; emitImplication $ Implic { ic_untch = untch
- , ic_env = lcl_env
, ic_skols = skol_tvs
, ic_fsks = []
, ic_given = given
View
18 compiler/types/Type.lhs
@@ -54,7 +54,8 @@ module Type (
isDictLikeTy,
mkEqPred, mkPrimEqPred,
mkClassPred,
- noParenPred, isClassPred, isEqPred, isIPPred, isIPPred_maybe,
+ noParenPred, isClassPred, isEqPred,
+ isIPPred, isIPPred_maybe, isIPTyCon, isIPClass,
-- Deconstructing predicate types
PredTree(..), predTreePredType, classifyPredType,
@@ -152,7 +153,7 @@ import Class
import TyCon
import TysPrim
import {-# SOURCE #-} TysWiredIn ( eqTyCon, mkBoxedTupleTy )
-import PrelNames ( eqTyConKey, ipClassName )
+import PrelNames ( eqTyConKey, ipClassNameKey )
-- others
import Unique ( Unique, hasKey )
@@ -857,13 +858,20 @@ isEqPred ty = case tyConAppTyCon_maybe ty of
_ -> False
isIPPred ty = case tyConAppTyCon_maybe ty of
- Just tyCon -> tyConName tyCon == ipClassName
- _ -> False
+ Just tc -> isIPTyCon tc
+ _ -> False
+
+isIPTyCon :: TyCon -> Bool
+isIPTyCon tc = tc `hasKey` ipClassNameKey
+
+isIPClass :: Class -> Bool
+isIPClass cls = cls `hasKey` ipClassNameKey
+ -- Class and it corresponding TyCon have the same Unique
isIPPred_maybe :: Type -> Maybe (FastString, Type)
isIPPred_maybe ty =
do (tc,[t1,t2]) <- splitTyConApp_maybe ty
- guard (tyConName tc == ipClassName)
+ guard (isIPTyCon tc)
x <- isStrLitTy t1
return (x,t2)
\end{code}
Please sign in to comment.
Something went wrong with that request. Please try again.