Add typed holes support in Template Haskell.
authorJan Stolarek <jan.stolarek@p.lodz.pl>
Tue, 8 Sep 2015 17:19:44 +0000 (19:19 +0200)
committerJan Stolarek <jan.stolarek@p.lodz.pl>
Fri, 16 Oct 2015 18:15:44 +0000 (20:15 +0200)
Fixes #10267. Typed holes in typed Template Haskell currently don't work.
See #10945 and #10946.

24 files changed:
compiler/basicTypes/Lexeme.hs
compiler/deSugar/DsMeta.hs
compiler/hsSyn/Convert.hs
compiler/hsSyn/HsExpr.hs
compiler/prelude/THNames.hs
compiler/rename/RnExpr.hs
compiler/rename/RnSource.hs
compiler/rename/RnSplice.hs
compiler/rename/RnTypes.hs
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcRnTypes.hs
compiler/typecheck/TcSplice.hs
compiler/typecheck/TcSplice.hs-boot
docs/users_guide/7.12.1-notes.rst
docs/users_guide/glasgow_exts.rst
libraries/template-haskell/Language/Haskell/TH/Lib.hs
libraries/template-haskell/Language/Haskell/TH/Ppr.hs
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
testsuite/tests/th/T10267.hs [new file with mode: 0644]
testsuite/tests/th/T10267.stderr [new file with mode: 0644]
testsuite/tests/th/T10267a.hs [new file with mode: 0644]
testsuite/tests/th/T1476b.hs
testsuite/tests/th/T1476b.stderr
testsuite/tests/th/all.T

index 2049e00..bce3061 100644 (file)
@@ -140,7 +140,9 @@ okTcOcc _ = False
 -- with an acceptable letter?
 okVarIdOcc :: String -> Bool
 okVarIdOcc str = okIdOcc str &&
-                 not (str `Set.member` reservedIds)
+                 -- admit "_" as a valid identifier.  Required to support typed
+                 -- holes in Template Haskell.  See #10267
+                 (str == "_" || not (str `Set.member` reservedIds))
 
 -- | Is this an acceptable symbolic variable name, assuming it starts
 -- with an acceptable character?
@@ -224,6 +226,7 @@ okSymChar c
       OtherSymbol          -> True
       _                    -> False
 
+
 -- | All reserved identifiers. Taken from section 2.4 of the 2010 Report.
 reservedIds :: Set.Set String
 reservedIds = Set.fromList [ "case", "class", "data", "default", "deriving"
index 4c060de..df2eaf2 100644 (file)
@@ -1167,6 +1167,11 @@ repE (ArithSeq _ _ aseq) =
 
 repE (HsSpliceE splice)    = repSplice splice
 repE (HsStatic e)          = repLE e >>= rep2 staticEName . (:[]) . unC
+repE (HsUnboundVar name)   = do
+                               occ   <- occNameLit name
+                               sname <- repNameS occ
+                               repUnboundVar sname
+
 repE e@(PArrSeq {})        = notHandled "Parallel arrays" (ppr e)
 repE e@(HsCoreAnn {})      = notHandled "Core annotations" (ppr e)
 repE e@(HsSCC {})          = notHandled "Cost centres" (ppr e)
@@ -1572,10 +1577,10 @@ globalVar name
   | isExternalName name
   = do  { MkC mod <- coreStringLit name_mod
         ; MkC pkg <- coreStringLit name_pkg
-        ; MkC occ <- occNameLit name
+        ; MkC occ <- nameLit name
         ; rep2 mk_varg [pkg,mod,occ] }
   | otherwise
-  = do  { MkC occ <- occNameLit name
+  = do  { MkC occ <- nameLit name
         ; MkC uni <- coreIntLit (getKey (getUnique name))
         ; rep2 mkNameLName [occ,uni] }
   where
@@ -1612,13 +1617,16 @@ wrapGenSyms binds body@(MkC b)
     go _ [] = return body
     go var_ty ((name,id) : binds)
       = do { MkC body'  <- go var_ty binds
-           ; lit_str    <- occNameLit name
+           ; lit_str    <- nameLit name
            ; gensym_app <- repGensym lit_str
            ; repBindQ var_ty elt_ty
                       gensym_app (MkC (Lam id body')) }
 
-occNameLit :: Name -> DsM (Core String)
-occNameLit n = coreStringLit (occNameString (nameOccName n))
+nameLit :: Name -> DsM (Core String)
+nameLit n = coreStringLit (occNameString (nameOccName n))
+
+occNameLit :: OccName -> DsM (Core String)
+occNameLit name = coreStringLit (occNameString name)
 
 
 -- %*********************************************************************
@@ -2136,6 +2144,9 @@ mk_lit (HsIntegral _ i)   = mk_integer  i
 mk_lit (HsFractional f)   = mk_rational f
 mk_lit (HsIsString _ s)   = mk_string   s
 
+repNameS :: Core String -> DsM (Core TH.Name)
+repNameS (MkC name) = rep2 mkNameSName [name]
+
 --------------- Miscellaneous -------------------
 
 repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
@@ -2150,6 +2161,9 @@ repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
 repSequenceQ ty_a (MkC list)
   = rep2 sequenceQName [Type ty_a, list]
 
+repUnboundVar :: Core TH.Name -> DsM (Core TH.ExpQ)
+repUnboundVar (MkC name) = rep2 unboundVarEName [name]
+
 ------------ Lists -------------------
 -- turn a list of patterns into a single pattern matching a list
 
index 10d7e04..90fcfbc 100644 (file)
@@ -715,6 +715,7 @@ cvtl e = wrapL (cvt e)
                               ; return $ RecordUpd e' flds'
                                           PlaceHolder PlaceHolder PlaceHolder }
     cvt (StaticE e)      = fmap HsStatic $ cvtl e
+    cvt (UnboundVarE s)  = do { s' <- vName s; return $ HsVar s' }
 
 {- Note [Dropping constructors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
index 84ddd88..e51ca98 100644 (file)
@@ -1673,7 +1673,7 @@ pprQuals quals = interpp'SP quals
 -}
 
 data HsSplice id
-   = HsTypedSplice       --  $z  or $(f 4)
+   = HsTypedSplice       --  $$z  or $$(f 4)
         id               -- A unique name to identify this splice point
         (LHsExpr id)     -- See Note [Pending Splices]
 
index 9c39564..062f957 100644 (file)
@@ -27,6 +27,7 @@ templateHaskellNames :: [Name]
 templateHaskellNames = [
     returnQName, bindQName, sequenceQName, newNameName, liftName,
     mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
+    mkNameSName,
     liftStringName,
     unTypeName,
     unTypeQName,
@@ -52,7 +53,7 @@ templateHaskellNames = [
     tupEName, unboxedTupEName,
     condEName, multiIfEName, letEName, caseEName, doEName, compEName,
     fromEName, fromThenEName, fromToEName, fromThenToEName,
-    listEName, sigEName, recConEName, recUpdEName, staticEName,
+    listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName,
     -- FieldExp
     fieldExpName,
     -- Body
@@ -184,7 +185,7 @@ kindTyConName     = thTc (fsLit "Kind")           kindTyConKey
 
 returnQName, bindQName, sequenceQName, newNameName, liftName,
     mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
-    mkNameLName, liftStringName, unTypeName, unTypeQName,
+    mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeQName,
     unsafeTExpCoerceName :: Name
 returnQName    = thFun (fsLit "returnQ")   returnQIdKey
 bindQName      = thFun (fsLit "bindQ")     bindQIdKey
@@ -197,6 +198,7 @@ mkNameG_vName  = thFun (fsLit "mkNameG_v")  mkNameG_vIdKey
 mkNameG_dName  = thFun (fsLit "mkNameG_d")  mkNameG_dIdKey
 mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey
 mkNameLName    = thFun (fsLit "mkNameL")    mkNameLIdKey
+mkNameSName    = thFun (fsLit "mkNameS")    mkNameSIdKey
 unTypeName     = thFun (fsLit "unType")     unTypeIdKey
 unTypeQName    = thFun (fsLit "unTypeQ")    unTypeQIdKey
 unsafeTExpCoerceName = thFun (fsLit "unsafeTExpCoerce") unsafeTExpCoerceIdKey
@@ -252,7 +254,7 @@ clauseName = libFun (fsLit "clause") clauseIdKey
 varEName, conEName, litEName, appEName, infixEName, infixAppName,
     sectionLName, sectionRName, lamEName, lamCaseEName, tupEName,
     unboxedTupEName, condEName, multiIfEName, letEName, caseEName,
-    doEName, compEName, staticEName :: Name
+    doEName, compEName, staticEName, unboundVarEName :: Name
 varEName        = libFun (fsLit "varE")        varEIdKey
 conEName        = libFun (fsLit "conE")        conEIdKey
 litEName        = libFun (fsLit "litE")        litEIdKey
@@ -284,6 +286,7 @@ sigEName        = libFun (fsLit "sigE")        sigEIdKey
 recConEName     = libFun (fsLit "recConE")     recConEIdKey
 recUpdEName     = libFun (fsLit "recUpdE")     recUpdEIdKey
 staticEName     = libFun (fsLit "staticE")     staticEIdKey
+unboundVarEName = libFun (fsLit "unboundVarE") unboundVarEIdKey
 
 -- type FieldExp = ...
 fieldExpName :: Name
@@ -576,7 +579,8 @@ kindTyConKey            = mkPreludeTyConUnique 232
 
 returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
     mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
-    mkNameLIdKey, unTypeIdKey, unTypeQIdKey, unsafeTExpCoerceIdKey :: Unique
+    mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeQIdKey,
+    unsafeTExpCoerceIdKey :: Unique
 returnQIdKey        = mkPreludeMiscIdUnique 200
 bindQIdKey          = mkPreludeMiscIdUnique 201
 sequenceQIdKey      = mkPreludeMiscIdUnique 202
@@ -587,9 +591,10 @@ mkNameG_vIdKey       = mkPreludeMiscIdUnique 206
 mkNameG_dIdKey       = mkPreludeMiscIdUnique 207
 mkNameG_tcIdKey      = mkPreludeMiscIdUnique 208
 mkNameLIdKey         = mkPreludeMiscIdUnique 209
-unTypeIdKey          = mkPreludeMiscIdUnique 210
-unTypeQIdKey         = mkPreludeMiscIdUnique 211
-unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 212
+mkNameSIdKey         = mkPreludeMiscIdUnique 210
+unTypeIdKey          = mkPreludeMiscIdUnique 211
+unTypeQIdKey         = mkPreludeMiscIdUnique 212
+unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 213
 
 
 -- data Lit = ...
@@ -647,7 +652,8 @@ varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
     unboxedTupEIdKey, condEIdKey, multiIfEIdKey,
     letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
     fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
-    listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey :: Unique
+    listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey,
+    unboundVarEIdKey :: Unique
 varEIdKey         = mkPreludeMiscIdUnique 270
 conEIdKey         = mkPreludeMiscIdUnique 271
 litEIdKey         = mkPreludeMiscIdUnique 272
@@ -675,6 +681,7 @@ sigEIdKey         = mkPreludeMiscIdUnique 293
 recConEIdKey      = mkPreludeMiscIdUnique 294
 recUpdEIdKey      = mkPreludeMiscIdUnique 295
 staticEIdKey      = mkPreludeMiscIdUnique 296
+unboundVarEIdKey  = mkPreludeMiscIdUnique 297
 
 -- type FieldExp = ...
 fieldExpIdKey :: Unique
index ade117c..da6bf58 100644 (file)
@@ -83,19 +83,15 @@ finishHsVar name
 
 rnUnboundVar :: RdrName -> RnM (HsExpr Name, FreeVars)
 rnUnboundVar v
- = do { stage <- getStage
-      ; if isUnqual v && not (in_untyped_bracket stage)
+ = do { if isUnqual v
         then -- Treat this as a "hole"
              -- Do not fail right now; instead, return HsUnboundVar
              -- and let the type checker report the error
              return (HsUnboundVar (rdrNameOcc v), emptyFVs)
 
-        else -- Fail immediately (qualified name, or in untyped bracket)
+        else -- Fail immediately (qualified name)
              do { n <- reportUnboundName v
                 ; return (HsVar n, emptyFVs) } }
-  where
-    in_untyped_bracket (Brack _ (RnPendingUntyped {})) = True
-    in_untyped_bracket _ = False
 
 rnExpr (HsVar v)
   = do { mb_name <- lookupOccRn_overloaded False v
index f89f1b2..286b431 100644 (file)
@@ -177,7 +177,7 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
       -- Haddock docs; no free vars
    rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
 
-    last_tcg_env <- getGblEnv ;
+   last_tcg_env <- getGblEnv ;
    -- (I) Compute the results and return
    let {rn_group = HsGroup { hs_valds   = rn_val_decls,
                              hs_splcds  = rn_splice_decls,
@@ -351,7 +351,7 @@ rnAnnDecl :: AnnDecl RdrName -> RnM (AnnDecl Name, FreeVars)
 rnAnnDecl ann@(HsAnnotation s provenance expr)
   = addErrCtxt (annCtxt ann) $
     do { (provenance', provenance_fvs) <- rnAnnProvenance provenance
-       ; (expr', expr_fvs) <- setStage (Splice False) $
+       ; (expr', expr_fvs) <- setStage (Splice Untyped) $
                               rnLExpr expr
        ; return (HsAnnotation s provenance' expr',
                  provenance_fvs `plusFV` expr_fvs) }
index 073ddaa..b78d4c7 100644 (file)
@@ -27,7 +27,6 @@ import Outputable
 import Module
 import SrcLoc
 import DynFlags
-import FastString
 import RnTypes          ( rnLHsType )
 
 import Control.Monad    ( unless, when )
@@ -39,6 +38,7 @@ import TcEnv            ( checkWellStaged )
 import THNames          ( liftName )
 
 #ifdef GHCI
+import FastString
 import ErrUtils         ( dumpIfSet_dyn_printer )
 import TcEnv            ( tcMetaTy )
 import Hooks
@@ -66,29 +66,36 @@ rnBracket e br_body
     do { -- Check that Template Haskell is enabled and available
          thEnabled <- xoptM Opt_TemplateHaskell
        ; unless thEnabled $
-           failWith ( vcat [ ptext (sLit "Syntax error on") <+> ppr e
-                           , ptext (sLit "Perhaps you intended to use TemplateHaskell") ] )
+           failWith ( vcat
+                      [ text "Syntax error on" <+> ppr e
+                      , text "Perhaps you intended to use TemplateHaskell" ] )
 
          -- Check for nested brackets
        ; cur_stage <- getStage
        ; case cur_stage of
-           { Splice True  -> checkTc (isTypedBracket br_body) illegalUntypedBracket
-           ; Splice False -> checkTc (not (isTypedBracket br_body)) illegalTypedBracket
-           ; Comp         -> return ()
-           ; Brack {}     -> failWithTc illegalBracket
+           { Splice Typed   -> checkTc (isTypedBracket br_body)
+                                       illegalUntypedBracket
+           ; Splice Untyped -> checkTc (not (isTypedBracket br_body))
+                                       illegalTypedBracket
+           ; Comp           -> return ()
+           ; Brack {}       -> failWithTc illegalBracket
            }
 
          -- Brackets are desugared to code that mentions the TH package
        ; recordThUse
 
        ; case isTypedBracket br_body of
-            True  -> do { (body', fvs_e) <- setStage (Brack cur_stage RnPendingTyped) $
-                                            rn_bracket cur_stage br_body
+            True  -> do { traceRn (text "Renaming typed TH bracket")
+                        ; (body', fvs_e) <-
+                          setStage (Brack cur_stage RnPendingTyped) $
+                                   rn_bracket cur_stage br_body
                         ; return (HsBracket body', fvs_e) }
 
-            False -> do { ps_var <- newMutVar []
-                        ; (body', fvs_e) <- setStage (Brack cur_stage (RnPendingUntyped ps_var)) $
-                                            rn_bracket cur_stage br_body
+            False -> do { traceRn (text "Renaming untyped TH bracket")
+                        ; ps_var <- newMutVar []
+                        ; (body', fvs_e) <-
+                          setStage (Brack cur_stage (RnPendingUntyped ps_var)) $
+                                   rn_bracket cur_stage br_body
                         ; pendings <- readMutVar ps_var
                         ; return (HsRnBracketOut body' pendings, fvs_e) }
        }
@@ -157,22 +164,26 @@ rn_bracket _ (TExpBr e) = do { (e', fvs) <- rnLExpr e
 
 quotationCtxtDoc :: HsBracket RdrName -> SDoc
 quotationCtxtDoc br_body
-  = hang (ptext (sLit "In the Template Haskell quotation"))
+  = hang (text "In the Template Haskell quotation")
          2 (ppr br_body)
 
 illegalBracket :: SDoc
-illegalBracket = ptext (sLit "Template Haskell brackets cannot be nested (without intervening splices)")
+illegalBracket =
+    text "Template Haskell brackets cannot be nested" <+>
+    text "(without intervening splices)"
 
 illegalTypedBracket :: SDoc
-illegalTypedBracket = ptext (sLit "Typed brackets may only appear in typed slices.")
+illegalTypedBracket =
+    text "Typed brackets may only appear in typed splices."
 
 illegalUntypedBracket :: SDoc
-illegalUntypedBracket = ptext (sLit "Untyped brackets may only appear in untyped slices.")
+illegalUntypedBracket =
+    text "Untyped brackets may only appear in untyped splices."
 
 quotedNameStageErr :: HsBracket RdrName -> SDoc
 quotedNameStageErr br
-  = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr br
-        , ptext (sLit "must be used at the same stage at which is is bound")]
+  = sep [ text "Stage error: the non-top-level quoted name" <+> ppr br
+        , text "must be used at the same stage at which is is bound" ]
 
 #ifndef GHCI
 rnTopSpliceDecls :: HsSplice RdrName -> RnM ([LHsDecl RdrName], FreeVars)
@@ -253,7 +264,7 @@ rnSpliceGen run_splice pend_splice splice
                 ; return (result, fvs) }
 
         _ ->  do { (splice', fvs1) <- checkNoErrs $
-                                      setStage (Splice is_typed_splice) $
+                                      setStage (Splice splice_type) $
                                       rnSplice splice
                    -- checkNoErrs: don't attempt to run the splice if
                    -- renaming it failed; otherwise we get a cascade of
@@ -262,6 +273,9 @@ rnSpliceGen run_splice pend_splice splice
                  ; return (result, fvs1 `plusFV` fvs2) } }
    where
      is_typed_splice = isTypedSplice splice
+     splice_type = if is_typed_splice
+                   then Typed
+                   else Untyped
 
 ------------------
 runRnSplice :: UntypedSpliceFlavour
@@ -280,7 +294,7 @@ runRnSplice flavour run_meta ppr_res splice
 
              -- Typecheck the expression
        ; meta_exp_ty   <- tcMetaTy meta_ty_name
-       ; zonked_q_expr <- tcTopSpliceExpr False $
+       ; zonked_q_expr <- tcTopSpliceExpr Untyped $
                           tcMonoExpr the_expr meta_exp_ty
 
              -- Run the expression
@@ -396,7 +410,8 @@ rnSpliceExpr splice
     run_expr_splice rn_splice
       | isTypedSplice rn_splice   -- Run it later, in the type checker
       = do {  -- Ugh!  See Note [Splices] above
-             lcl_rdr <- getLocalRdrEnv
+             traceRn (text "rnSpliceExpr: typed expression splice")
+           ; lcl_rdr <- getLocalRdrEnv
            ; gbl_rdr <- getGlobalRdrEnv
            ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr
                                                      , isLocalGRE gre]
@@ -405,7 +420,8 @@ rnSpliceExpr splice
            ; return (HsSpliceE rn_splice, lcl_names `plusFV` gbl_names) }
 
       | otherwise  -- Run it here
-      = do { rn_expr <- runRnSplice UntypedExpSplice runMetaE ppr rn_splice
+      = do { traceRn (text "rnSpliceExpr: untyped expression splice")
+           ; rn_expr <- runRnSplice UntypedExpSplice runMetaE ppr rn_splice
            ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr)
            ; return (HsPar lexpr3, fvs)  }
 
@@ -419,7 +435,8 @@ rnSpliceType splice k
        = (makePending UntypedTypeSplice rn_splice, HsSpliceTy rn_splice k)
 
     run_type_splice rn_splice
-      = do { hs_ty2 <- runRnSplice UntypedTypeSplice runMetaT ppr rn_splice
+      = do { traceRn (text "rnSpliceType: untyped type splice")
+           ; hs_ty2 <- runRnSplice UntypedTypeSplice runMetaT ppr rn_splice
            ; (hs_ty3, fvs) <- do { let doc = SpliceTypeCtx hs_ty2
                                  ; checkValidPartialTypeSplice doc hs_ty2
                                     -- See Note [Partial Type Splices]
@@ -497,7 +514,8 @@ rnSplicePat splice
       = (makePending UntypedPatSplice rn_splice, Right (SplicePat rn_splice))
 
     run_pat_splice rn_splice
-      = do { pat <- runRnSplice UntypedPatSplice runMetaP ppr rn_splice
+      = do { traceRn (text "rnSplicePat: untyped pattern splice")
+           ; pat <- runRnSplice UntypedPatSplice runMetaP ppr rn_splice
            ; return (Left (ParPat pat), emptyFVs) }
               -- Wrap the result of the quasi-quoter in parens so that we don't
               -- lose the outermost location set by runQuasiQuote (#7918)
@@ -515,8 +533,9 @@ rnSpliceDecl (SpliceDecl (L loc splice) flg)
 rnTopSpliceDecls :: HsSplice RdrName -> RnM ([LHsDecl RdrName], FreeVars)
 -- Declaration splice at the very top level of the module
 rnTopSpliceDecls splice
-   = do  { (rn_splice, fvs) <- setStage (Splice False) $
+   = do  { (rn_splice, fvs) <- setStage (Splice Untyped) $
                                rnSplice splice
+         ; traceRn (text "rnTopSpliceDecls: untyped declaration splice")
          ; decls <- runRnSplice UntypedDeclSplice runMetaD ppr_decls rn_splice
          ; return (decls,fvs) }
    where
@@ -538,8 +557,10 @@ the CpsRn monad.
 The problem is that if we're renaming a splice within a bracket, we
 *don't* want to run the splice now. We really do just want to rename
 it to an HsSplice Name. Of course, then we can't know what variables
-are bound within the splice, so pattern splices within brackets aren't
-all that useful.
+are bound within the splice. So we accept any unbound variables and
+rename them again when the bracket is spliced in.  If a variable is brought
+into scope by a pattern splice all is fine.  If it is not then an error is
+reported.
 
 In any case, when we're done in rnSplicePat, we'll either have a
 Pat RdrName (the result of running a top-level splice) or a Pat Name
index 69eebd4..37a972a 100644 (file)
@@ -868,7 +868,7 @@ mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
 
 ----------------------------
 get_op :: LHsExpr Name -> Name
--- An unbound name could be either HsVar or HsUnboundVra
+-- An unbound name could be either HsVar or HsUnboundVar
 -- See RnExpr.rnUnboundVar
 get_op (L _ (HsVar n))          = n
 get_op (L _ (HsUnboundVar occ)) = mkUnboundName (mkRdrUnqual occ)
index 35ac44f..dfeffb9 100644 (file)
@@ -1089,9 +1089,9 @@ rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
 -- Fails if there are any errors
 rnTopSrcDecls group
  = do { -- Rename the source decls
-        traceTc "rn12" empty ;
+        traceRn (text "rn12") ;
         (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ;
-        traceTc "rn13" empty ;
+        traceRn (text "rn13") ;
 
         -- save the renamed syntax, if we want it
         let { tcg_env'
index d1f3c0d..1ff3bda 100644 (file)
@@ -47,7 +47,8 @@ module TcRnTypes(
         DsMetaEnv, DsMetaVal(..),
 
         -- Template Haskell
-        ThStage(..), PendingStuff(..), topStage, topAnnStage, topSpliceStage,
+        ThStage(..), SpliceType(..), PendingStuff(..),
+        topStage, topAnnStage, topSpliceStage,
         ThLevel, impLevel, outerLevel, thLevel,
 
         -- Arrows
@@ -734,12 +735,13 @@ instance Outputable TcIdBinder where
 -- Template Haskell stages and levels
 ---------------------------
 
+data SpliceType = Typed | Untyped
+
 data ThStage    -- See Note [Template Haskell state diagram] in TcSplice
-  = Splice      -- Inside a top-level splice splice
-                -- This code will be run *at compile time*;
-                --   the result replaces the splice
-                -- Binding level = 0
-      Bool      -- True if in a typed splice, False otherwise
+  = Splice SpliceType -- Inside a top-level splice
+                      -- This code will be run *at compile time*;
+                      --   the result replaces the splice
+                      -- Binding level = 0
 
   | Comp        -- Ordinary Haskell code
                 -- Binding level = 1
@@ -760,8 +762,8 @@ data PendingStuff
 
 topStage, topAnnStage, topSpliceStage :: ThStage
 topStage       = Comp
-topAnnStage    = Splice False
-topSpliceStage = Splice False
+topAnnStage    = Splice Untyped
+topSpliceStage = Splice Untyped
 
 instance Outputable ThStage where
    ppr (Splice _)  = text "Splice"
index 1dbe7a8..12f28a5 100644 (file)
@@ -452,7 +452,7 @@ tcTopSplice expr res_ty
   = do { -- Typecheck the expression,
          -- making sure it has type Q (T res_ty)
          meta_exp_ty <- tcTExpTy res_ty
-       ; zonked_q_expr <- tcTopSpliceExpr True $
+       ; zonked_q_expr <- tcTopSpliceExpr Typed $
                           tcMonoExpr expr meta_exp_ty
 
          -- Run the expression
@@ -490,7 +490,7 @@ spliceResultDoc expr
         , ptext (sLit "To see what the splice expanded to, use -ddump-splices")]
 
 -------------------
-tcTopSpliceExpr :: Bool -> TcM (LHsExpr Id) -> TcM (LHsExpr Id)
+tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr Id) -> TcM (LHsExpr Id)
 -- Note [How top-level splices are handled]
 -- Type check an expression that is the body of a top-level splice
 --   (the caller will compile and run it)
@@ -536,7 +536,7 @@ runAnnotation target expr = do
     -- Check the instances we require live in another module (we want to execute it..)
     -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr
     -- also resolves the LIE constraints to detect e.g. instance ambiguity
-    zonked_wrapped_expr' <- tcTopSpliceExpr False $
+    zonked_wrapped_expr' <- tcTopSpliceExpr Untyped $
            do { (expr', expr_ty) <- tcInferRhoNC expr
                 -- We manually wrap the typechecked expression in a call to toAnnotationWrapper
                 -- By instantiating the call >here< it gets registered in the
index b683fe6..50b7aac 100644 (file)
@@ -11,6 +11,7 @@ import Annotations ( Annotation, CoreAnnTarget )
 #ifdef GHCI
 import HsSyn      ( LHsType, LPat, LHsDecl )
 import RdrName    ( RdrName )
+import TcRnTypes  ( SpliceType )
 import qualified Language.Haskell.TH as TH
 #endif
 
@@ -29,7 +30,7 @@ tcTypedBracket :: HsBracket Name
 runAnnotation     :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation
 
 #ifdef GHCI
-tcTopSpliceExpr :: Bool -> TcM (LHsExpr TcId) -> TcM (LHsExpr TcId)
+tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr TcId) -> TcM (LHsExpr TcId)
 
 runMetaE :: LHsExpr TcId -> TcM (LHsExpr RdrName)
 runMetaP :: LHsExpr TcId -> TcM (LPat RdrName)
index 14b0bef..05ab2e2 100644 (file)
@@ -128,6 +128,10 @@ Template Haskell
 -  Partial type signatures can now be used in splices, see
    :ref:`pts-where`.
 
+-  ``Template Haskell`` now fully supports typed holes and quoting unbound
+   variables.  This means it is now possible to use pattern splices nested
+   inside quotation brackets.
+
 -  ``Template Haskell`` now supports the use of ``UInfixT`` in types to
    resolve infix operator fixities, in the same vein as ``UInfixP`` and
    ``UInfixE`` in patterns and expressions. ``ParensT`` and ``InfixT``
index 0ad41cf..5f7a4dc 100644 (file)
@@ -9349,42 +9349,28 @@ on.
    This abbreviation makes top-level declaration slices quieter and less
    intimidating.
 
--  Outermost pattern splices may bind variables. By "outermost" here, we
-   refer to a pattern splice that occurs outside of any quotation
-   brackets. For example,
+-  Pattern splices introduce variable binders but scoping of variables in
+   expressions inside the pattern's scope is only checked when a splice is
+   run.  Note that pattern splices that occur outside of any quotation
+   brackets are run at compile time.  Pattern splices occurring inside a
+   quotation bracket are *not* run at compile time; they are run when the
+   bracket is spliced in, sometime later.  For example,
 
    ::
 
-       mkPat :: Bool -> Q Pat
-       mkPat True  = [p| (x, y) |]
-       mkPat False = [p| (y, x) |]
+       mkPat :: Q Pat
+       mkPat = [p| (x, y) |]
 
        -- in another module:
        foo :: (Char, String) -> String
-       foo $(mkPat True) = x : y
+       foo $(mkPat) = x : z
 
-       bar :: (String, Char) -> String
-       bar $(mkPat False) = x : y
+       bar :: Q Exp
+       bar = [| \ $(mkPat) -> x : w |]
 
--  Nested pattern splices do *not* bind variables. By "nested" here, we
-   refer to a pattern splice occurring within a quotation bracket.
-   Continuing the example from the last bullet:
-
-   ::
-
-       baz :: Bool -> Q Exp
-       baz b = [| quux $(mkPat b) = x + y |]
-
-   would fail with ``x`` and ``y`` being out of scope.
-
-   The difference in treatment of outermost and nested pattern splices
-   is because outermost splices are run at compile time. GHC can then
-   use the result of running the splice when analysing the expressions
-   within the pattern's scope. Nested splices, on the other hand, are
-   *not* run at compile time; they are run when the bracket is spliced
-   in, sometime later. Since nested pattern splices may refer to local
-   variables, there is no way for GHC to know, at splice compile time,
-   what variables are bound, so it binds none.
+   will fail with ``z`` being out of scope in the definition of ``foo`` but it
+   will *not* fail with ``w`` being out of scope in the definition of ``bar``.
+   That will only happen when ``bar`` is spliced.
 
 -  A pattern quasiquoter *may* generate binders that scope over the
    right-hand side of a definition because these binders are in scope
index fd5dd70..f38f36f 100644 (file)
@@ -300,6 +300,9 @@ fieldExp s e = do { e' <- e; return (s,e') }
 staticE :: ExpQ -> ExpQ
 staticE = fmap StaticE
 
+unboundVarE :: Name -> ExpQ
+unboundVarE s = return (UnboundVarE s)
+
 -- ** 'arithSeqE' Shortcuts
 fromE :: ExpQ -> ExpQ
 fromE x = do { a <- x; return (ArithSeqE (FromR a)) }
index 589382a..1768b15 100644 (file)
@@ -172,6 +172,7 @@ pprExp _ (RecConE nm fs) = ppr nm <> braces (pprFields fs)
 pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs)
 pprExp i (StaticE e) = parensIf (i >= appPrec) $
                          text "static"<+> pprExp appPrec e
+pprExp _ (UnboundVarE v) = pprName' Applied v
 
 pprFields :: [(Name,Exp)] -> Doc
 pprFields = sep . punctuate comma . map (\(s,e) -> ppr s <+> equals <+> ppr e)
index 97c379d..8d56a98 100644 (file)
@@ -1032,6 +1032,9 @@ mkNameG :: NameSpace -> String -> String -> String -> Name
 mkNameG ns pkg modu occ
   = Name (mkOccName occ) (NameG ns (mkPkgName pkg) (mkModName modu))
 
+mkNameS :: String -> Name
+mkNameS n = Name (mkOccName n) NameS
+
 mkNameG_v, mkNameG_tc, mkNameG_d :: String -> String -> String -> Name
 mkNameG_v  = mkNameG VarName
 mkNameG_tc = mkNameG TcClsName
@@ -1415,6 +1418,7 @@ data Exp
   | RecConE Name [FieldExp]            -- ^ @{ T { x = y, z = w } }@
   | RecUpdE Exp [FieldExp]             -- ^ @{ (f x) { z = w } }@
   | StaticE Exp                        -- ^ @{ static e }@
+  | UnboundVarE Name                   -- ^ @{ _x }@ (hole)
   deriving( Show, Eq, Ord, Data, Typeable, Generic )
 
 type FieldExp = (Name,Exp)
diff --git a/testsuite/tests/th/T10267.hs b/testsuite/tests/th/T10267.hs
new file mode 100644 (file)
index 0000000..009d0f0
--- /dev/null
@@ -0,0 +1,33 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module T10267 where
+
+import Language.Haskell.TH
+import T10267a
+
+[d| i :: a -> a
+    i = _foo
+
+    j :: a -> a
+    j x = _ |]
+
+$(return [
+   SigD (mkName "k")
+        (ForallT [PlainTV (mkName "a")]
+                 []
+                 (AppT (AppT ArrowT (VarT (mkName "a"))) (VarT (mkName "a"))))
+ , FunD (mkName "k")
+        [Clause [] (NormalB (UnboundVarE (mkName "_foo"))) []]
+ ])
+
+$(return [
+   SigD (mkName "l")
+        (ForallT [PlainTV (mkName "a")]
+                 []
+                 (AppT (AppT ArrowT (VarT (mkName "a"))) (VarT (mkName "a"))))
+ , FunD (mkName "l")
+        [Clause [VarP (mkName "x")] (NormalB (UnboundVarE (mkName "_"))) []]
+ ])
+
+foo :: a -> a
+foo x = $varX
diff --git a/testsuite/tests/th/T10267.stderr b/testsuite/tests/th/T10267.stderr
new file mode 100644 (file)
index 0000000..442a779
--- /dev/null
@@ -0,0 +1,46 @@
+
+T10267.hs:8:1: error:
+    Found hole: _ :: a0
+    Where: ‘a0’ is a rigid type variable bound by
+                the type signature for:
+                  j :: a0 -> a0
+                at T10267.hs:8:1
+    Relevant bindings include
+      x :: a0 (bound at T10267.hs:8:1)
+      j :: a0 -> a0 (bound at T10267.hs:8:1)
+    In the expression: _
+    In an equation for ‘j’: j x = _
+
+T10267.hs:8:1: error:
+    Found hole: _foo :: a0 -> a0
+    Where: ‘a0’ is a rigid type variable bound by
+                the type signature for:
+                  i :: a0 -> a0
+                at T10267.hs:8:1
+    Or perhaps ‘_foo’ is mis-spelled, or not in scope
+    Relevant bindings include i :: a0 -> a0 (bound at T10267.hs:8:1)
+    In the expression: _foo
+    In an equation for ‘i’: i = _foo
+
+T10267.hs:14:3: error:
+    Found hole: _foo :: a -> a
+    Where: ‘a’ is a rigid type variable bound by
+               the type signature for:
+                 k :: a -> a
+               at T10267.hs:14:3
+    Or perhaps ‘_foo’ is mis-spelled, or not in scope
+    Relevant bindings include k :: a -> a (bound at T10267.hs:14:3)
+    In the expression: _foo
+    In an equation for ‘k’: k = _foo
+
+T10267.hs:23:3: error:
+    Found hole: _ :: a
+    Where: ‘a’ is a rigid type variable bound by
+               the type signature for:
+                 l :: a -> a
+               at T10267.hs:23:3
+    Relevant bindings include
+      x :: a (bound at T10267.hs:23:3)
+      l :: a -> a (bound at T10267.hs:23:3)
+    In the expression: _
+    In an equation for ‘l’: l x = _
diff --git a/testsuite/tests/th/T10267a.hs b/testsuite/tests/th/T10267a.hs
new file mode 100644 (file)
index 0000000..cabe97e
--- /dev/null
@@ -0,0 +1,8 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module T10267a where
+
+import Language.Haskell.TH
+
+varX :: Q Exp
+varX = [| x |]
index 918a397..7d62850 100644 (file)
@@ -6,5 +6,3 @@ import Language.Haskell.TH
 
 baz = [| \ $( return $ VarP $ mkName "x" ) -> x |]
 
--- If this test starts passing, nested pattern splices scope correctly.
--- Good for you! Now, update the TH manual accordingly.
index 65b0814..e69de29 100644 (file)
@@ -1,5 +0,0 @@
-
-T1476b.hs:7:47:
-    Not in scope: ‘x’
-    In the Template Haskell quotation
-      [| \ $(return $ VarP $ mkName "x") -> x |]
index 9ded810..1e05d72 100644 (file)
@@ -340,12 +340,15 @@ test('T9064', normal, compile, ['-v0'])
 test('T9209', normal, compile_fail, ['-v0'])
 test('T7484', normal, compile_fail, ['-v0'])
 test('T1476', normal, compile, ['-v0'])
-test('T1476b', normal, compile_fail, ['-v0'])
+test('T1476b', normal, compile, ['-v0'])
 test('T8031', normal, compile, ['-v0'])
 test('T8624', normal, run_command, ['$MAKE -s --no-print-directory T8624'])
 test('TH_Lift', normal, compile, ['-v0'])
 test('T10047', normal, ghci_script, ['T10047.script'])
 test('T10019', normal, ghci_script, ['T10019.script'])
+test('T10267', extra_clean(['T10267a.hi', 'T10267a.o']),
+               multimod_compile_fail,
+               ['T10267', '-dsuppress-uniques -v0'])
 test('T10279', normal, compile_fail, ['-v0'])
 test('T10306', normal, compile, ['-v0'])
 test('T10596', normal, compile, ['-v0'])