Commit 677144b8 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Add support for *named* holes; an extension of -XTypeHoles

The idea is that you can use "_foo" rather than just "_"
as a "hole" in an expression, and this name shows up in
type errors etc.

The changes are very straightforward.
Thanks for Thijs Alkemade for making the running here.
parent 9c661e07
......@@ -576,7 +576,7 @@ addTickHsExpr (HsWrap w e) =
(addTickHsExpr e) -- explicitly no tick on inside
addTickHsExpr e@(HsType _) = return e
addTickHsExpr HsHole = panic "addTickHsExpr.HsHole"
addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar"
-- Others dhould never happen in expression content.
addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e)
......
......@@ -213,7 +213,7 @@ dsExpr (HsLamCase arg matches)
dsExpr (HsApp fun arg)
= mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg
dsExpr HsHole = panic "dsExpr: HsHole"
dsExpr (HsUnboundVar _) = panic "dsExpr: HsUnboundVar"
\end{code}
Note [Desugaring vars]
......
......@@ -21,6 +21,7 @@ import HsBinds
import TcEvidence
import CoreSyn
import Var
import RdrName
import Name
import BasicTypes
import DataCon
......@@ -309,7 +310,7 @@ data HsExpr id
| HsWrap HsWrapper -- TRANSLATION
(HsExpr id)
| HsHole
| HsUnboundVar RdrName
deriving (Data, Typeable)
-- HsTupArg is used for tuple sections
......@@ -575,8 +576,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 "_"
ppr_expr (HsUnboundVar nm)
= ppr nm
\end{code}
......@@ -612,7 +613,7 @@ hsExprNeedsParens (PArrSeq {}) = False
hsExprNeedsParens (HsLit {}) = False
hsExprNeedsParens (HsOverLit {}) = False
hsExprNeedsParens (HsVar {}) = False
hsExprNeedsParens (HsHole {}) = False
hsExprNeedsParens (HsUnboundVar {}) = False
hsExprNeedsParens (HsIPVar {}) = False
hsExprNeedsParens (ExplicitTuple {}) = False
hsExprNeedsParens (ExplicitList {}) = False
......@@ -631,7 +632,7 @@ isAtomicHsExpr (HsVar {}) = True
isAtomicHsExpr (HsLit {}) = True
isAtomicHsExpr (HsOverLit {}) = True
isAtomicHsExpr (HsIPVar {}) = True
isAtomicHsExpr (HsHole {}) = True
isAtomicHsExpr (HsUnboundVar {}) = True
isAtomicHsExpr (HsWrap _ e) = isAtomicHsExpr e
isAtomicHsExpr (HsPar e) = isAtomicHsExpr (unLoc e)
isAtomicHsExpr _ = False
......
......@@ -7,7 +7,7 @@
module RnEnv (
newTopSrcBinder,
lookupLocatedTopBndrRn, lookupTopBndrRn,
lookupLocatedOccRn, lookupOccRn,
lookupLocatedOccRn, lookupOccRn, lookupOccRn_maybe,
lookupLocalOccRn_maybe,
lookupTypeOccRn, lookupKindOccRn,
lookupGlobalOccRn, lookupGlobalOccRn_maybe,
......
......@@ -108,8 +108,14 @@ finishHsVar name
; return (e, unitFV name) } }
rnExpr (HsVar v)
= do name <- lookupOccRn v
finishHsVar name
= do { opt_TypeHoles <- xoptM Opt_TypeHoles
; if opt_TypeHoles && startsWithUnderscore (rdrNameOcc v)
then do { mb_name <- lookupOccRn_maybe v
; case mb_name of
Nothing -> return (HsUnboundVar v, emptyFVs)
Just n -> finishHsVar n }
else do { name <- lookupOccRn v
; finishHsVar name } }
rnExpr (HsIPVar v)
= return (HsIPVar v, emptyFVs)
......@@ -300,9 +306,6 @@ 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.
......@@ -312,7 +315,7 @@ We return a (bogus) EWildPat in each case.
\begin{code}
rnExpr e@EWildPat = do { holes <- xoptM Opt_TypeHoles
; if holes
then return (HsHole, emptyFVs)
then return (hsHoleExpr, emptyFVs)
else patSynErr e
}
rnExpr e@(EAsPat {}) = patSynErr e
......@@ -340,13 +343,16 @@ rnExpr e@(HsArrForm {}) = arrowFail e
rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
-- HsWrap
hsHoleExpr :: HsExpr Name
hsHoleExpr = HsUnboundVar (mkRdrUnqual (mkVarOcc "_"))
arrowFail :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
arrowFail e
= do { addErr (vcat [ ptext (sLit "Arrow command found where an expression was expected:")
, nest 2 (ppr e) ])
-- Return a place-holder hole, so that we can carry on
-- to report other errors
; return (HsHole, emptyFVs) }
; return (hsHoleExpr, emptyFVs) }
----------------------
-- See Note [Parsing sections] in Parser.y.pp
......
......@@ -23,6 +23,7 @@ import TyCon
import TypeRep
import Var
import VarEnv
import OccName( OccName )
import Outputable
import Control.Monad ( when )
import TysWiredIn ( eqTyCon )
......@@ -192,8 +193,8 @@ canonicalize (CFunEqCan { cc_loc = d
canonicalize (CIrredEvCan { cc_ev = ev
, cc_loc = d })
= canIrred d ev
canonicalize (CHoleCan { cc_ev = ev, cc_loc = d })
= canHole d ev
canonicalize (CHoleCan { cc_ev = ev, cc_loc = d, cc_occ = occ })
= canHole d ev occ
canEvNC :: CtLoc -> CtEvidence -> TcS StopOrContinue
-- Called only for non-canonical EvVars
......@@ -401,13 +402,13 @@ canIrred d ev
Just new_ev -> canEvNC d new_ev -- Re-classify and try again
Nothing -> return Stop } } -- Found a cached copy
canHole :: CtLoc -> CtEvidence -> TcS StopOrContinue
canHole d ev
canHole :: CtLoc -> CtEvidence -> OccName -> TcS StopOrContinue
canHole d ev occ
= do { let ty = ctEvPred ev
; (xi,co) <- flatten d FMFullFlatten (ctEvFlavour ev) ty -- co :: xi ~ ty
; mb <- rewriteCtFlavor ev xi co
; case mb of
Just new_ev -> emitInsoluble (CHoleCan { cc_ev = new_ev, cc_loc = d})
Just new_ev -> emitInsoluble (CHoleCan { cc_ev = new_ev, cc_loc = d, cc_occ = occ })
Nothing -> return () -- Found a cached copy; won't happen
; return Stop }
\end{code}
......
......@@ -472,19 +472,19 @@ mkIrredErr ctxt cts
----------------
mkHoleError :: ReportErrCtxt -> Ct -> TcM ErrMsg
mkHoleError ctxt ct@(CHoleCan {})
mkHoleError ctxt ct@(CHoleCan { cc_occ = occ })
= do { let tyvars = varSetElems (tyVarsOfCt ct)
tyvars_msg = map loc_msg tyvars
msg = (text "Found hole" <+> quotes (text "_")
<+> text "with type") <+> pprType (ctEvPred (cc_ev ct))
$$ (if null tyvars_msg then empty else text "Where:" <+> vcat tyvars_msg)
msg = vcat [ hang (ptext (sLit "Found hole") <+> quotes (ppr occ))
2 (ptext (sLit "with type:") <+> pprType (ctEvPred (cc_ev ct)))
, ppUnless (null tyvars_msg) (ptext (sLit "Where:") <+> vcat tyvars_msg) ]
; (ctxt, binds_doc) <- relevantBindings ctxt ct
; mkErrorMsg ctxt ct (msg $$ binds_doc) }
where
loc_msg tv
= case tcTyVarDetails tv of
SkolemTv {} -> quotes (ppr tv) <+> skol_msg
MetaTv {} -> quotes (ppr tv) <+> text "is an ambiguous type variable"
MetaTv {} -> quotes (ppr tv) <+> ptext (sLit "is an ambiguous type variable")
det -> pprTcTyVarDetails det
where
skol_msg = pprSkol (getSkolemInfo (cec_encl ctxt) tv) (getSrcLoc tv)
......
......@@ -43,6 +43,7 @@ import TcType
import DsMonad hiding (Splice)
import Id
import DataCon
import RdrName
import Name
import TyCon
import Type
......@@ -133,6 +134,16 @@ tcInfExpr (HsPar e) = do { (e', ty) <- tcInferRhoNC e
; return (HsPar e', ty) }
tcInfExpr (HsApp e1 e2) = tcInferApp e1 [e2]
tcInfExpr e = tcInfer (tcExpr e)
tcHole :: OccName -> TcRhoType -> TcM (HsExpr TcId)
tcHole occ res_ty
= do { ty <- newFlexiTyVarTy liftedTypeKind
; name <- newSysName occ
; let ev = mkLocalId name ty
; loc <- getCtLoc HoleOrigin
; let can = CHoleCan { cc_ev = CtWanted ty ev, cc_loc = loc, cc_occ = occ }
; emitInsoluble can
; tcWrapResult (HsVar ev) ty res_ty }
\end{code}
......@@ -231,15 +242,8 @@ 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 ty ev, cc_loc = loc }
; traceTc "tcExpr.HsHole emitting" (ppr can)
; emitInsoluble can
; tcWrapResult (HsVar ev) ty res_ty }
tcExpr (HsUnboundVar v) res_ty
= tcHole (rdrNameOcc v) res_ty
\end{code}
......
......@@ -709,8 +709,8 @@ zonkExpr env (HsWrap co_fn expr)
zonkExpr env1 expr `thenM` \ new_expr ->
return (HsWrap new_co_fn new_expr)
zonkExpr _ HsHole
= return HsHole
zonkExpr _ (HsUnboundVar v)
= return (HsUnboundVar v)
zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
......
......@@ -923,7 +923,8 @@ data Ct
| CHoleCan {
cc_ev :: CtEvidence,
cc_loc :: CtLoc
cc_loc :: CtLoc,
cc_occ :: OccName -- The name of this hole
}
\end{code}
......@@ -1541,6 +1542,7 @@ data CtOrigin
| AnnOrigin -- An annotation
| FunDepOrigin
| HoleOrigin
| UnboundOccurrenceOf RdrName
pprO :: CtOrigin -> SDoc
pprO (GivenOrigin sk) = ppr sk
......@@ -1576,7 +1578,8 @@ pprO (TypeEqOrigin t1 t2) = ptext (sLit "a type equality") <+> sep [ppr t1, cha
pprO (KindEqOrigin t1 t2 _) = ptext (sLit "a kind equality arising from") <+> sep [ppr t1, char '~', ppr t2]
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 "_")
pprO HoleOrigin = ptext (sLit "a use of") <+> quotes (ptext $ sLit "_")
pprO (UnboundOccurrenceOf name) = hsep [ptext (sLit "an undeclared identifier"), quotes (ppr name)]
instance Outputable CtOrigin where
ppr = pprO
......
......@@ -7082,12 +7082,20 @@ the term you're about to write.
</para>
<para>
This extension allows special placeholders, written as "<literal>_</literal>", to be used as an expression.
During compilation these holes will generate an error message describing what type is expected there.
The error includes helpful information about the origin of type variables and a list of local bindings
This extension allows special placeholders, written with a leading underscore (e.g. "<literal>_</literal>",
"<literal>_foo</literal>", "<literal>_bar</literal>"), to be used as an expression.
During compilation these holes will generate an error message describing what type is expected there,
information about the origin of any free type variables, and a list of local bindings
that might help fill the hole with actual code.
</para>
<para>
Holes work together well with <link linkend="defer-type-errors">deferring type errors to runtime</link>:
with <literal>-fdefer-type-errors</literal>, the error from a hole is also deferred, effctively making the hole
typecheck just like <literal>undefined</literal>, but with the added benefit that it will show its warning message
if it gets evaluated. This way, other parts of the code can still be executed and tested.
</para>
<para>
For example, compiling the following module with GHC:
<programlisting>
......@@ -7097,7 +7105,7 @@ f x = _
will fail with the following error:
<programlisting>
hole.hs:2:7:
Found hole `_' with type a
Found hole `_' with type: a
Where: `a' is a rigid type variable bound by
the type signature for f :: a -> a at hole.hs:1:6
Relevant bindings include
......@@ -7112,38 +7120,56 @@ hole.hs:2:7:
Multiple type holes can be used to find common type variables between expressions. For example:
<programlisting>
sum :: [Int] -> Int
sum x = foldr _ _ _
sum xx = foldr _f _z xs
</programlisting>
Shows:
<programlisting>
holes.hs:2:15:
Found hole `_' with type a0 -> Int -> Int
Where: `a0' is an ambiguous type variable
Found hole `_f' with type: Int-> Int -> Int
In the first argument of `foldr', namely `_'
In the expression: foldr _ _ _
In an equation for `sum': sum x = foldr _ _ _
In the expression: foldr _a _b _c
In an equation for `sum': sum x = foldr _a _b _c
holes.hs:2:17:
Found hole `_' with type Int
Found hole `_z' with type: Int
In the second argument of `foldr', namely `_'
In the expression: foldr _ _ _
In an equation for `sum': sum x = foldr _ _ _
holes.hs:2:19:
Found hole `_' with type [a0]
Where: `a0' is an ambiguous type variable
In the third argument of `foldr', namely `_'
In the expression: foldr _ _ _
In an equation for `sum': sum x = foldr _ _ _
In the expression: foldr _a _b _c
In an equation for `sum': sum x = foldr _a _b _c
</programlisting>
</para>
<para>
Holes work together well with <link linkend="defer-type-errors">deferring type errors to runtime</link>:
with <literal>-fdefer-type-errors</literal>, the error from a hole is also deferred, effctively making the hole
typecheck just like <literal>undefined</literal>, but with the added benefit that it will show its warning message
if it gets evaluated. This way, other parts of the code can still be executed and tested.
Unbound identifiers with the same name are never unified, even within the same function, but always printed individually.
For example:
<programlisting>
cons = _x : _x
</programlisting>
results in the following errors:
<programlisting>
unbound.hs:1:8:
Found hole '_x' with type: a
Where: `a' is a rigid type variable bound by
the inferred type of cons :: [a] at unbound.hs:1:1
Relevant bindings include cons :: [a] (bound at unbound.hs:1:1)
In the first argument of `(:)', namely `_x'
In the expression: _x : _x
In an equation for `cons': cons = _x : _x
unbound.hs:1:13:
Found hole '_x' with type: [a]
Arising from: an undeclared identifier `_x' at unbound.hs:1:13-14
Where: `a' is a rigid type variable bound by
the inferred type of cons :: [a] at unbound.hs:1:1
Relevant bindings include cons :: [a] (bound at unbound.hs:1:1)
In the second argument of `(:)', namely `_x'
In the expression: _x : _x
In an equation for `cons': cons = _x : _x
Failed, modules loaded: none.
</programlisting>
This ensures that an unbound identifier is never reported with a too polymorphic type, like
<literal>forall a. a</literal>, when used multiple times for types that can not be unified.
</para>
</sect2>
</sect1>
<!-- ==================== End of type system extensions ================= -->
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment