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 &&
 -- 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?
 
 -- | Is this an acceptable symbolic variable name, assuming it starts
 -- with an acceptable character?
@@ -224,6 +226,7 @@ okSymChar c
       OtherSymbol          -> True
       _                    -> False
 
       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"
 -- | 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 (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)
 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
   | 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
         ; 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
         ; 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
     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')) }
 
            ; 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
 
 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))
 --------------- 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]
 
 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
 
 ------------ 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
                               ; 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]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 {- Note [Dropping constructors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
index 84ddd88..e51ca98 100644 (file)
@@ -1673,7 +1673,7 @@ pprQuals quals = interpp'SP quals
 -}
 
 data HsSplice id
 -}
 
 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]
 
         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,
 templateHaskellNames = [
     returnQName, bindQName, sequenceQName, newNameName, liftName,
     mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
+    mkNameSName,
     liftStringName,
     unTypeName,
     unTypeQName,
     liftStringName,
     unTypeName,
     unTypeQName,
@@ -52,7 +53,7 @@ templateHaskellNames = [
     tupEName, unboxedTupEName,
     condEName, multiIfEName, letEName, caseEName, doEName, compEName,
     fromEName, fromThenEName, fromToEName, fromThenToEName,
     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
     -- FieldExp
     fieldExpName,
     -- Body
@@ -184,7 +185,7 @@ kindTyConName     = thTc (fsLit "Kind")           kindTyConKey
 
 returnQName, bindQName, sequenceQName, newNameName, liftName,
     mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
 
 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
     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
 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
 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,
 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
 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
 recConEName     = libFun (fsLit "recConE")     recConEIdKey
 recUpdEName     = libFun (fsLit "recUpdE")     recUpdEIdKey
 staticEName     = libFun (fsLit "staticE")     staticEIdKey
+unboundVarEName = libFun (fsLit "unboundVarE") unboundVarEIdKey
 
 -- type FieldExp = ...
 fieldExpName :: Name
 
 -- type FieldExp = ...
 fieldExpName :: Name
@@ -576,7 +579,8 @@ kindTyConKey            = mkPreludeTyConUnique 232
 
 returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
     mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
 
 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
 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
 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 = ...
 
 
 -- data Lit = ...
@@ -647,7 +652,8 @@ varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
     unboxedTupEIdKey, condEIdKey, multiIfEIdKey,
     letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
     fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
     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
 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
 recConEIdKey      = mkPreludeMiscIdUnique 294
 recUpdEIdKey      = mkPreludeMiscIdUnique 295
 staticEIdKey      = mkPreludeMiscIdUnique 296
+unboundVarEIdKey  = mkPreludeMiscIdUnique 297
 
 -- type FieldExp = ...
 fieldExpIdKey :: Unique
 
 -- type FieldExp = ...
 fieldExpIdKey :: Unique
index ade117c..da6bf58 100644 (file)
@@ -83,19 +83,15 @@ finishHsVar name
 
 rnUnboundVar :: RdrName -> RnM (HsExpr Name, FreeVars)
 rnUnboundVar v
 
 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)
 
         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) } }
              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
 
 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 ;
 
       -- 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,
    -- (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
 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) }
                               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 Module
 import SrcLoc
 import DynFlags
-import FastString
 import RnTypes          ( rnLHsType )
 
 import Control.Monad    ( unless, when )
 import RnTypes          ( rnLHsType )
 
 import Control.Monad    ( unless, when )
@@ -39,6 +38,7 @@ import TcEnv            ( checkWellStaged )
 import THNames          ( liftName )
 
 #ifdef GHCI
 import THNames          ( liftName )
 
 #ifdef GHCI
+import FastString
 import ErrUtils         ( dumpIfSet_dyn_printer )
 import TcEnv            ( tcMetaTy )
 import Hooks
 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 $
     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
 
          -- 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
            }
 
          -- 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) }
 
                         ; 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) }
        }
                         ; 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
 
 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
          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 :: 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 :: 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
 
 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)
 
 #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 $
                 ; 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
                                       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
                  ; return (result, fvs1 `plusFV` fvs2) } }
    where
      is_typed_splice = isTypedSplice splice
+     splice_type = if is_typed_splice
+                   then Typed
+                   else Untyped
 
 ------------------
 runRnSplice :: UntypedSpliceFlavour
 
 ------------------
 runRnSplice :: UntypedSpliceFlavour
@@ -280,7 +294,7 @@ runRnSplice flavour run_meta ppr_res splice
 
              -- Typecheck the expression
        ; meta_exp_ty   <- tcMetaTy meta_ty_name
 
              -- 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
                           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
     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]
            ; 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
            ; 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)  }
 
            ; (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
        = (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]
            ; (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
       = (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)
            ; 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
 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
                                rnSplice splice
+         ; traceRn (text "rnTopSpliceDecls: untyped declaration splice")
          ; decls <- runRnSplice UntypedDeclSplice runMetaD ppr_decls rn_splice
          ; return (decls,fvs) }
    where
          ; 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
 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
 
 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
 
 ----------------------------
 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)
 -- 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
 -- 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 ;
         (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ;
-        traceTc "rn13" empty ;
+        traceRn (text "rn13") ;
 
         -- save the renamed syntax, if we want it
         let { tcg_env'
 
         -- 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
         DsMetaEnv, DsMetaVal(..),
 
         -- Template Haskell
-        ThStage(..), PendingStuff(..), topStage, topAnnStage, topSpliceStage,
+        ThStage(..), SpliceType(..), PendingStuff(..),
+        topStage, topAnnStage, topSpliceStage,
         ThLevel, impLevel, outerLevel, thLevel,
 
         -- Arrows
         ThLevel, impLevel, outerLevel, thLevel,
 
         -- Arrows
@@ -734,12 +735,13 @@ instance Outputable TcIdBinder where
 -- Template Haskell stages and levels
 ---------------------------
 
 -- Template Haskell stages and levels
 ---------------------------
 
+data SpliceType = Typed | Untyped
+
 data ThStage    -- See Note [Template Haskell state diagram] in TcSplice
 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
 
   | Comp        -- Ordinary Haskell code
                 -- Binding level = 1
@@ -760,8 +762,8 @@ data PendingStuff
 
 topStage, topAnnStage, topSpliceStage :: ThStage
 topStage       = Comp
 
 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"
 
 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
   = 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
                           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")]
 
 -------------------
         , 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)
 -- 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
     -- 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
            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 )
 #ifdef GHCI
 import HsSyn      ( LHsType, LPat, LHsDecl )
 import RdrName    ( RdrName )
+import TcRnTypes  ( SpliceType )
 import qualified Language.Haskell.TH as TH
 #endif
 
 import qualified Language.Haskell.TH as TH
 #endif
 
@@ -29,7 +30,7 @@ tcTypedBracket :: HsBracket Name
 runAnnotation     :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation
 
 #ifdef GHCI
 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)
 
 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`.
 
 -  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``
 -  ``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.
 
    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
 
        -- 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
 
 -  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
 
 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)) }
 -- ** '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 _ (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)
 
 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))
 
 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
 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 }@
   | 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)
   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 |]
 
 
 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('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('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'])
 test('T10279', normal, compile_fail, ['-v0'])
 test('T10306', normal, compile, ['-v0'])
 test('T10596', normal, compile, ['-v0'])