[commit: ghc] master: Reject top-level typed TH splices. Fixes #10945 (1750ebc)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/1750ebc2e40bab85246717326d3d5c60f132e652/ghc

>---------------------------------------------------------------

commit 1750ebc2e40bab85246717326d3d5c60f132e652
Author: Jan Stolarek <jan.stolarek at p.lodz.pl>
Date:   Tue Oct 20 14:09:13 2015 +0200

    Reject top-level typed TH splices. Fixes #10945
    
    When TemplateHaskell language extension is enabled it is valid to have
    top-level expressions.  Each such expression is treated as a contents
    of a splice.  The problem arises with typed splices.  They are not valid
    at the top level and therefore we should interpret them not as a splice
    but as a top-level expression (aka. implicit splice).  So saying:
    
    $$foo
    
    is equivalent of:
    
    $( $$foo )
    
    This patch makes sure that this is indeed the case.  Until now we
    incorrectly treated typed splices as explicit splices.


>---------------------------------------------------------------

1750ebc2e40bab85246717326d3d5c60f132e652
 compiler/parser/RdrHsSyn.hs      | 15 +++++++++++----
 testsuite/tests/th/T10945.stderr | 29 +++++++++++++++++++++++++++++
 testsuite/tests/th/all.T         |  2 +-
 3 files changed, 41 insertions(+), 5 deletions(-)

diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 8bc4f6c..e64a575 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -263,11 +263,18 @@ mkSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
 -- but if she wrote, say,
 --      f x            then behave as if she'd written $(f x)
 --                     ie a SpliceD
+--
+-- Typed splices are not allowed at the top level, thus we do not represent them
+-- as spliced declaration.  See #10945
 mkSpliceDecl lexpr@(L loc expr)
-  | HsSpliceE splice <- expr = SpliceD (SpliceDecl (L loc splice) ExplicitSplice)
-  | otherwise                = SpliceD (SpliceDecl (L loc splice) ImplicitSplice)
-  where
-    splice = mkUntypedSplice lexpr
+  | HsSpliceE splice@(HsUntypedSplice {}) <- expr
+  = SpliceD (SpliceDecl (L loc splice) ExplicitSplice)
+
+  | HsSpliceE splice@(HsQuasiQuote {}) <- expr
+  = SpliceD (SpliceDecl (L loc splice) ExplicitSplice)
+
+  | otherwise
+  = SpliceD (SpliceDecl (L loc (mkUntypedSplice lexpr)) ImplicitSplice)
 
 mkRoleAnnotDecl :: SrcSpan
                 -> Located RdrName                   -- type being annotated
diff --git a/testsuite/tests/th/T10945.stderr b/testsuite/tests/th/T10945.stderr
new file mode 100644
index 0000000..0c1d949
--- /dev/null
+++ b/testsuite/tests/th/T10945.stderr
@@ -0,0 +1,29 @@
+
+T10945.hs:7:11:
+    Couldn't match expected type ‘TExp DecsQ’ with actual type ‘[Dec]’
+    In the first argument of ‘return’, namely
+      ‘[SigD
+          (mkName "m")
+          (ForallT
+             [PlainTV (mkName "a")]
+             []
+             (AppT (AppT ArrowT (VarT (mkName "a"))) (VarT (mkName "a")))),
+        FunD (mkName "m") [Clause [...] (NormalB (VarE (mkName "x"))) []]]’
+    In the expression:
+      return
+        [SigD
+           (mkName "m")
+           (ForallT
+              [PlainTV (mkName "a")]
+              []
+              (AppT (AppT ArrowT (VarT (mkName "a"))) (VarT (mkName "a")))),
+         FunD (mkName "m") [Clause [...] (NormalB (VarE (mkName "x"))) []]]
+    In the Template Haskell splice
+      $$(return
+           [SigD
+              (mkName "m")
+              (ForallT
+                 [PlainTV (mkName "a")]
+                 []
+                 (AppT (AppT ArrowT (VarT (mkName "a"))) (VarT (mkName "a")))),
+            FunD (mkName "m") [Clause [...] (NormalB (VarE (mkName "x"))) []]])
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 1e05d72..3d08f36 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -366,5 +366,5 @@ test('T10796b', normal, compile_fail, ['-v0'])
 test('T10811', normal, compile, ['-v0'])
 test('T10810', normal, compile, ['-v0'])
 test('T10891', normal, compile, ['-v0'])
-test('T10945', expect_broken(10945), compile, ['-v0'])
+test('T10945', normal, compile_fail, ['-v0'])
 test('T10946', expect_broken(10946), compile, ['-v0'])