Add a HsExplicitFlag to SpliceDecl, to improve Trac #4042

The issue here is that

    g :: A -> A
    f
    data A = A

is treated as if you'd written $(f); that is the call of
f is a top-level Template Haskell splice.  This patch
makes sure that we *first* check the -XTemplateHaskellFlag
and bleat about a parse error if it's off.  Othewise we
get strange seeing "A is out of scope" errors.

diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index 0038ebe..baf6eca 100644 (file)
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -232,11 +232,15 @@ instance OutputableBndr name => Outputable (HsGroup name) where
          ppr_ds [] = empty
          ppr_ds ds = blankLine $$ vcat (map ppr ds)
 
          ppr_ds [] = empty
          ppr_ds ds = blankLine $$ vcat (map ppr ds)
 

-data SpliceDecl id = SpliceDecl (Located (HsExpr id))  -- Top level splice
+data SpliceDecl id 
+  = SpliceDecl                 -- Top level splice
+        (Located (HsExpr id))
+        HsExplicitFlag         -- Explicit <=> $(f x y)
+                               -- Implicit <=> f x y,  i.e. a naked top level expression

     deriving (Data, Typeable)
 
 instance OutputableBndr name => Outputable (SpliceDecl name) where
     deriving (Data, Typeable)
 
 instance OutputableBndr name => Outputable (SpliceDecl name) where

-   ppr (SpliceDecl e) = ptext (sLit "$") <> parens (pprExpr (unLoc e))
+   ppr (SpliceDecl e _) = ptext (sLit "$") <> parens (pprExpr (unLoc e))

 \end{code}
 
 
 \end{code}
 
 

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index ae4a15a..ef761e6 100644 (file)
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -231,8 +231,8 @@ mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
 --      f x            then behave as if she'd written $(f x)
 --                    ie a SpliceD
 mkTopSpliceDecl (L _ (HsQuasiQuoteE qq))            = QuasiQuoteD qq
 --      f x            then behave as if she'd written $(f x)
 --                    ie a SpliceD
 mkTopSpliceDecl (L _ (HsQuasiQuoteE qq))            = QuasiQuoteD qq

-mkTopSpliceDecl (L _ (HsSpliceE (HsSplice _ expr))) = SpliceD (SpliceDecl expr)
-mkTopSpliceDecl other_expr                          = SpliceD (SpliceDecl other_expr)
+mkTopSpliceDecl (L _ (HsSpliceE (HsSplice _ expr))) = SpliceD (SpliceDecl expr       Explicit)
+mkTopSpliceDecl other_expr                          = SpliceD (SpliceDecl other_expr Implicit)

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 48f1e6f..490faec 100644 (file)
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -605,7 +605,7 @@ rnBracket (DecBrL decls)
   = do { (group, mb_splice) <- findSplice decls
        ; case mb_splice of
            Nothing -> return ()
   = do { (group, mb_splice) <- findSplice decls
        ; case mb_splice of
            Nothing -> return ()

-           Just (SpliceDecl (L loc _), _)  
+           Just (SpliceDecl (L loc _) _, _)  

               -> setSrcSpan loc $
                  addErr (ptext (sLit "Declaration splices are not permitted inside declaration brackets"))
                -- Why not?  See Section 7.3 of the TH paper.  
               -> setSrcSpan loc $
                  addErr (ptext (sLit "Declaration splices are not permitted inside declaration brackets"))
                -- Why not?  See Section 7.3 of the TH paper.  

diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 6dce034..5d23110 100644 (file)
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -1119,7 +1119,18 @@ addl gp (L l d : ds) = add gp l d ds
 add :: HsGroup RdrName -> SrcSpan -> HsDecl RdrName -> [LHsDecl RdrName]
     -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
 
 add :: HsGroup RdrName -> SrcSpan -> HsDecl RdrName -> [LHsDecl RdrName]
     -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
 

-add gp _ (SpliceD e) ds = return (gp, Just (e, ds))
+add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds 
+  = do { -- We've found a top-level splice.  If it is an *implicit* one 
+         -- (i.e. a naked top level expression)
+         case flag of
+           Explicit -> return ()
+           Implicit -> do { th_on <- doptM Opt_TemplateHaskell
+                          ; unless th_on $ setSrcSpan loc $
+                            failWith badImplicitSplice }
+
+       ; return (gp, Just (splice, ds)) }
+  where
+    badImplicitSplice = ptext (sLit "Parse error: naked expression at top level")

 
 #ifndef GHCI
 add _ _ (QuasiQuoteD qq) _
 
 #ifndef GHCI
 add _ _ (QuasiQuoteD qq) _

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index c06d4e0..262bd73 100644 (file)
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -433,7 +433,7 @@ tc_rn_src_decls boot_details ds
        failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
 #else
        -- If there's a splice, we must carry on
        failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
 #else
        -- If there's a splice, we must carry on

-          Just (SpliceDecl splice_expr, rest_ds) -> do {
+          Just (SpliceDecl splice_expr _, rest_ds) -> do {

 
        -- Rename the splice expression, and get its supporting decls
        (rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ;
 
        -- Rename the splice expression, and get its supporting decls
        (rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ;

@@ -477,8 +477,8 @@ tcRnHsBootDecls decls
 
                -- Check for illegal declarations
        ; case group_tail of
 
                -- Check for illegal declarations
        ; case group_tail of

-            Just (SpliceDecl d, _) -> badBootDecl "splice" d
-            Nothing                -> return ()
+            Just (SpliceDecl d _, _) -> badBootDecl "splice" d
+            Nothing                  -> return ()

        ; mapM_ (badBootDecl "foreign") for_decls
        ; mapM_ (badBootDecl "default") def_decls
        ; mapM_ (badBootDecl "rule")    rule_decls
        ; mapM_ (badBootDecl "foreign") for_decls
        ; mapM_ (badBootDecl "default") def_decls
        ; mapM_ (badBootDecl "rule")    rule_decls