Add support for *named* holes; an extension of -XTypeHoles
authorSimon Peyton Jones <simonpj@microsoft.com>
Wed, 30 Jan 2013 12:39:07 +0000 (12:39 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Wed, 30 Jan 2013 12:39:07 +0000 (12:39 +0000)
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.

compiler/deSugar/Coverage.lhs
compiler/deSugar/DsExpr.lhs
compiler/hsSyn/HsExpr.lhs
compiler/rename/RnEnv.lhs
compiler/rename/RnExpr.lhs
compiler/typecheck/TcCanonical.lhs
compiler/typecheck/TcErrors.lhs
compiler/typecheck/TcExpr.lhs
compiler/typecheck/TcHsSyn.lhs
compiler/typecheck/TcRnTypes.lhs
docs/users_guide/glasgow_exts.xml

index c4afc5b..133f0e1 100644 (file)
@@ -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)
index d0b71ed..6df618c 100644 (file)
@@ -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]
index 2acc34e..c6f8bf1 100644 (file)
@@ -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
index 5e466c9..452025b 100644 (file)
@@ -7,7 +7,7 @@
 module RnEnv (
         newTopSrcBinder,
         lookupLocatedTopBndrRn, lookupTopBndrRn,
-        lookupLocatedOccRn, lookupOccRn,
+        lookupLocatedOccRn, lookupOccRn, lookupOccRn_maybe,
         lookupLocalOccRn_maybe,
         lookupTypeOccRn, lookupKindOccRn,
         lookupGlobalOccRn, lookupGlobalOccRn_maybe,
index 01004e3..2a8e7ab 100644 (file)
@@ -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
index a7533ed..c300b62 100644 (file)
@@ -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}
index fd716f8..0124028 100644 (file)
@@ -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)
index e87ff6d..60faae7 100644 (file)
@@ -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}
 
 
index 41a65c0..d6bcc41 100644 (file)
@@ -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)
 
index 3d53203..50c9d5c 100644 (file)
@@ -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
index 1191a16..e1d21c3 100644 (file)
@@ -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 =================  -->