Commit 8a9a7a8c authored by Simon Peyton Jones's avatar Simon Peyton Jones
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").
parent b0db9308
......@@ -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)
......
......@@ -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]
......
......@@ -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 [])) _ _ _)
......
......@@ -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]
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
This diff is collapsed.
......@@ -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}
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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