summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/deSugar/Coverage.lhs2
-rw-r--r--compiler/deSugar/DsExpr.lhs2
-rw-r--r--compiler/hsSyn/HsExpr.lhs11
-rw-r--r--compiler/rename/RnEnv.lhs2
-rw-r--r--compiler/rename/RnExpr.lhs20
-rw-r--r--compiler/typecheck/TcCanonical.lhs11
-rw-r--r--compiler/typecheck/TcErrors.lhs10
-rw-r--r--compiler/typecheck/TcExpr.lhs22
-rw-r--r--compiler/typecheck/TcHsSyn.lhs4
-rw-r--r--compiler/typecheck/TcRnTypes.lhs7
-rw-r--r--docs/users_guide/glasgow_exts.xml72
11 files changed, 102 insertions, 61 deletions
diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index c4afc5b9e5..133f0e1e06 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -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)
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index d0b71ed2d0..6df618c645 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -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]
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index 2acc34e30f..c6f8bf17ac 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -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
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index 5e466c9a32..452025b7cc 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -7,7 +7,7 @@
module RnEnv (
newTopSrcBinder,
lookupLocatedTopBndrRn, lookupTopBndrRn,
- lookupLocatedOccRn, lookupOccRn,
+ lookupLocatedOccRn, lookupOccRn, lookupOccRn_maybe,
lookupLocalOccRn_maybe,
lookupTypeOccRn, lookupKindOccRn,
lookupGlobalOccRn, lookupGlobalOccRn_maybe,
diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 01004e3b0d..2a8e7ab589 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -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
diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs
index a7533ed8b8..c300b62a22 100644
--- a/compiler/typecheck/TcCanonical.lhs
+++ b/compiler/typecheck/TcCanonical.lhs
@@ -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}
diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index fd716f8dfb..01240288af 100644
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -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)
diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index e87ff6d2f4..60faae75fb 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -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}
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 41a65c0fd1..d6bcc41e3d 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -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)
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 3d53203e6e..50c9d5c3ba 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -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
diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml
index 1191a1637f..e1d21c3506 100644
--- a/docs/users_guide/glasgow_exts.xml
+++ b/docs/users_guide/glasgow_exts.xml
@@ -7082,13 +7082,21 @@ 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>
f :: a -> a
@@ -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 ================= -->
View Lorry Controller Status