add -th-file which generates a th.hs file

Summary:
see Trac #8624

similar functionality is now available
with -ddump-to-file -ddump-splices

However, users are already accustomed to -ddump-splices
having a particular format, and this format is not completely valid code
The goal of -th-file is to dump valid Haskell code

Additionally, the convention of -ddump-to-file is to name the file after
the flag, so the file is .dump-splices
Given that the goal of the new flag is to generate valid Haskell,
The extension should be .hs

Additionally, -ddump-to-file effects all other dump flags

Test Plan:
look at the output of using the -th-file flag
and compare it to the output of using -ddump-to-file and -ddump-splices
I want to add test cases, but just need some pointers on getting started there

Reviewers: thomie, goldfire, simonpj, austin

Reviewed By: simonpj, austin

Subscribers: thomie, carter

Differential Revision: https://phabricator.haskell.org/D518

GHC Trac Issues: #8624

18 files changed, 31 insertions, 30 deletions

diff --git a/testsuite/tests/th/Makefile b/testsuite/tests/th/Makefile
index b06042bd40..d10476ee2c 100644
--- a/testsuite/tests/th/Makefile
+++ b/testsuite/tests/th/Makefile
@@ -37,3 +37,9 @@ TH_Depends:
 
 T8333:
 	'$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) --interactive -v0 T8333.hs < /dev/null
+
+# This was an easy way to re-use the stdout testing
+# to check the contents of a generated file.
+T8624:
+	'$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) -v0 -c T8624.hs && cat T8624.th.hs
+	 $(RM) T8624.th.hs
diff --git a/testsuite/tests/th/T3319.stderr b/testsuite/tests/th/T3319.stderr
index f325ffb8dc..b7e3411d41 100644
--- a/testsuite/tests/th/T3319.stderr
+++ b/testsuite/tests/th/T3319.stderr
@@ -1,8 +1,7 @@
-T3319.hs:1:1: Splicing declarations

+T3319.hs:8:3-93: Splicing declarations

     return

       [ForeignD

          (ImportF

             CCall Unsafe "&" (mkName "foo") (AppT (ConT ''Ptr) (ConT ''())))]

   ======>

-    T3319.hs:8:3-93

     foreign import ccall unsafe "static &foo" foo :: Ptr GHC.Tuple.()

diff --git a/testsuite/tests/th/T3600.stderr b/testsuite/tests/th/T3600.stderr
index a7f988416e..615be3ba25 100644
--- a/testsuite/tests/th/T3600.stderr
+++ b/testsuite/tests/th/T3600.stderr
@@ -1,5 +1,4 @@
-T3600.hs:1:1: Splicing declarations

+T3600.hs:5:3-6: Splicing declarations

     test

   ======>

-    T3600.hs:5:3-6

     myFunction = (testFun1 [], testFun2 [], testFun2 "x")

diff --git a/testsuite/tests/th/T5217.stderr b/testsuite/tests/th/T5217.stderr
index a749282710..f69875b31f 100644
--- a/testsuite/tests/th/T5217.stderr
+++ b/testsuite/tests/th/T5217.stderr
@@ -1,4 +1,4 @@
-T5217.hs:1:1: Splicing declarations

+T5217.hs:(6,3)-(9,53): Splicing declarations

     [d| data T a b

           where

             T1 :: Int -> T Int Char

@@ -6,7 +6,6 @@ T5217.hs:1:1: Splicing declarations
             T3 :: a -> T [a] a

             T4 :: a -> b -> T b [a] |]

   ======>

-    T5217.hs:(6,3)-(9,53)

     data T a b

       = (b ~ Char, a ~ Int) => T1 Int |

         b ~ a => T2 a |

diff --git a/testsuite/tests/th/T5290.stderr b/testsuite/tests/th/T5290.stderr
index 9f7067be06..2b4275d842 100644
--- a/testsuite/tests/th/T5290.stderr
+++ b/testsuite/tests/th/T5290.stderr
@@ -1,6 +1,5 @@
-T5290.hs:1:1: Splicing declarations
+T5290.hs:(7,4)-(8,67): Splicing declarations
     let n = mkName "T"
     in return [DataD [] n [] [NormalC n [(Unpacked, ConT ''Int)]] []]
   ======>
-    T5290.hs:(7,4)-(8,67)
     data T = T {-# UNPACK #-} !Int
diff --git a/testsuite/tests/th/T5700.stderr b/testsuite/tests/th/T5700.stderr
index dd1ece7583..729a36604f 100644
--- a/testsuite/tests/th/T5700.stderr
+++ b/testsuite/tests/th/T5700.stderr
@@ -1,7 +1,6 @@
-T5700.hs:1:1: Splicing declarations
+T5700.hs:8:3-9: Splicing declarations
     mkC ''D
   ======>
-    T5700.hs:8:3-9
     instance C D where
       {-# INLINE inlinable #-}
       inlinable _ = GHC.Tuple.()
diff --git a/testsuite/tests/th/T5883.stderr b/testsuite/tests/th/T5883.stderr
index 0b0f705823..aa87a41052 100644
--- a/testsuite/tests/th/T5883.stderr
+++ b/testsuite/tests/th/T5883.stderr
@@ -1,11 +1,10 @@
-T5883.hs:1:1: Splicing declarations
+T5883.hs:(7,4)-(12,4): Splicing declarations
     [d| data Unit = Unit
         
         instance Show Unit where
           show _ = ""
           {-# INLINE show #-} |]
   ======>
-    T5883.hs:(7,4)-(12,4)
     data Unit = Unit
     instance Show Unit where
       {-# INLINE show #-}
diff --git a/testsuite/tests/th/T5984.stderr b/testsuite/tests/th/T5984.stderr
index 50c7cbfdd0..2e612c7e9e 100644
--- a/testsuite/tests/th/T5984.stderr
+++ b/testsuite/tests/th/T5984.stderr
@@ -1,10 +1,8 @@
-T5984.hs:1:1: Splicing declarations
+T5984.hs:7:1-3: Splicing declarations
     nt
   ======>
-    T5984.hs:7:1-3
     newtype Foo = Foo Int
-T5984.hs:1:1: Splicing declarations
+T5984.hs:8:1-3: Splicing declarations
     dt
   ======>
-    T5984.hs:8:1-3
     data Bar = Bar Int
diff --git a/testsuite/tests/th/T7532.stderr b/testsuite/tests/th/T7532.stderr
index 0890ae2f89..3e57bb8955 100644
--- a/testsuite/tests/th/T7532.stderr
+++ b/testsuite/tests/th/T7532.stderr
@@ -3,10 +3,9 @@
 instance C Bool where
   data D Bool = T7532.MkD
 
-T7532.hs:1:1: Splicing declarations
+T7532.hs:11:3-6: Splicing declarations
     bang
   ======>
-    T7532.hs:11:3-6
     instance C Int where
       data D Int = T
 
diff --git a/testsuite/tests/th/T8624.hs b/testsuite/tests/th/T8624.hs
new file mode 100644
index 0000000000..49f67d5a33
--- /dev/null
+++ b/testsuite/tests/th/T8624.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -dth-dec-file #-}
+module T8624 (THDec(..)) where
+
+import Language.Haskell.TH
+
+$(return [DataD [] (mkName "THDec") [] [NormalC (mkName "THDec") []] []])
diff --git a/testsuite/tests/th/T8624.stderr b/testsuite/tests/th/T8624.stderr
new file mode 100644
index 0000000000..e69de29bb2
--- /dev/null
+++ b/testsuite/tests/th/T8624.stderr
diff --git a/testsuite/tests/th/T8624.stdout b/testsuite/tests/th/T8624.stdout
new file mode 100644
index 0000000000..82ea19598c
--- /dev/null
+++ b/testsuite/tests/th/T8624.stdout
@@ -0,0 +1,2 @@
+-- T8624.hs:7:3-72: Splicing declarations
+data THDec = THDec
diff --git a/testsuite/tests/th/TH_TyInstWhere1.stderr b/testsuite/tests/th/TH_TyInstWhere1.stderr
index 5a830aa792..971b7eed24 100644
--- a/testsuite/tests/th/TH_TyInstWhere1.stderr
+++ b/testsuite/tests/th/TH_TyInstWhere1.stderr
@@ -1,9 +1,8 @@
-TH_TyInstWhere1.hs:1:1: Splicing declarations
+TH_TyInstWhere1.hs:(5,3)-(7,24): Splicing declarations
     [d| type family F (a :: k) (b :: k) :: Bool where
           F a a = True
           F a b = False |]
   ======>
-    TH_TyInstWhere1.hs:(5,3)-(7,24)
     type family F (a :: k) (b :: k) :: Bool where
       F a a = True
       F a b = False
diff --git a/testsuite/tests/th/TH_foreignCallingConventions.stderr b/testsuite/tests/th/TH_foreignCallingConventions.stderr
index bf1f8b81f5..1ff81a4fc8 100644
--- a/testsuite/tests/th/TH_foreignCallingConventions.stderr
+++ b/testsuite/tests/th/TH_foreignCallingConventions.stderr
@@ -8,7 +8,7 @@ foreign import stdcall safe "bay" bay :: (GHC.Types.Int ->
                                          GHC.Types.IO GHC.Types.Int
 foreign import javascript unsafe "bax" bax :: GHC.Ptr.Ptr GHC.Types.Int ->
                                               GHC.Types.IO GHC.Base.String
-TH_foreignCallingConventions.hs:1:1: Splicing declarations
+TH_foreignCallingConventions.hs:(13,4)-(23,25): Splicing declarations
     do { let fi cconv safety lbl name ty
                = ForeignD (ImportF cconv safety lbl name ty);
          dec1 <- fi CCall Interruptible "&" (mkName "foo")
@@ -25,6 +25,5 @@ TH_foreignCallingConventions.hs:1:1: Splicing declarations
            >> hFlush stdout;
          return [dec1, dec2] }
   ======>
-    TH_foreignCallingConventions.hs:(13,4)-(23,25)
     foreign import ccall interruptible "static &foo" foo :: Ptr ()
     foreign import prim safe "static bar" bar :: Int# -> Int#
diff --git a/testsuite/tests/th/TH_foreignInterruptible.stderr b/testsuite/tests/th/TH_foreignInterruptible.stderr
index 6893d0a773..9cbf34ac87 100644
--- a/testsuite/tests/th/TH_foreignInterruptible.stderr
+++ b/testsuite/tests/th/TH_foreignInterruptible.stderr
@@ -1,4 +1,4 @@
-TH_foreignInterruptible.hs:1:1: Splicing declarations
+TH_foreignInterruptible.hs:8:3-100: Splicing declarations
     return
       [ForeignD
          (ImportF
@@ -8,6 +8,5 @@ TH_foreignInterruptible.hs:1:1: Splicing declarations
             (mkName "foo")
             (AppT (ConT ''Ptr) (ConT ''())))]
   ======>
-    TH_foreignInterruptible.hs:8:3-100
     foreign import ccall interruptible "static &foo" foo
       :: Ptr GHC.Tuple.()
diff --git a/testsuite/tests/th/TH_genEx.stderr b/testsuite/tests/th/TH_genEx.stderr
index 843959f693..8f2d5926e9 100644
--- a/testsuite/tests/th/TH_genEx.stderr
+++ b/testsuite/tests/th/TH_genEx.stderr
@@ -1,6 +1,5 @@
-TH_genEx.hs:1:1: Splicing declarations
+TH_genEx.hs:13:3-30: Splicing declarations
     genAny (reify ''MyInterface)
   ======>
-    TH_genEx.hs:13:3-30
     data AnyMyInterface1111
         = forall a. MyInterface a => AnyMyInterface1111 a
diff --git a/testsuite/tests/th/TH_pragma.stderr b/testsuite/tests/th/TH_pragma.stderr
index 15feece963..0fcd167aa4 100644
--- a/testsuite/tests/th/TH_pragma.stderr
+++ b/testsuite/tests/th/TH_pragma.stderr
@@ -1,18 +1,16 @@
-TH_pragma.hs:1:1: Splicing declarations
+TH_pragma.hs:(6,4)-(8,26): Splicing declarations
     [d| foo :: Int -> Int
         {-# NOINLINE foo #-}
         foo x = x + 1 |]
   ======>
-    TH_pragma.hs:(6,4)-(8,26)
     foo :: Int -> Int
     {-# NOINLINE foo #-}
     foo x = (x + 1)
-TH_pragma.hs:1:1: Splicing declarations
+TH_pragma.hs:(10,4)-(12,31): Splicing declarations
     [d| bar :: Num a => a -> a
         {-# SPECIALIZE INLINE[~1] bar :: Float -> Float #-}
         bar x = x * 10 |]
   ======>
-    TH_pragma.hs:(10,4)-(12,31)
     bar :: forall a. Num a => a -> a
     {-# SPECIALIZE INLINE[~1] bar :: Float -> Float #-}
     bar x = (x * 10)
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 021afd9554..2b4c37a4af 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -354,4 +354,5 @@ test('T1476', normal, compile, ['-v0'])
 test('T1476b', normal, compile_fail, ['-v0'])
 test('T9824', 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'])