Commit 07ace5c2 authored by GregWeber's avatar GregWeber Committed by Austin Seipp

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
parent 0fa42402
......@@ -154,3 +154,11 @@ _darcs/
.tm_properties
VERSION
GIT_COMMIT_ID
# -------------------------------------------------------------------------------------
# when using a docker image, one can mount the source code directory as the home folder
# -------------------------------------------------------------------------------------
.arcrc
.ghc
.bash_history
.gitconfig
......@@ -287,6 +287,7 @@ data DumpFlag
| Opt_D_dump_if_trace
| Opt_D_dump_vt_trace
| Opt_D_dump_splices
| Opt_D_th_dec_file
| Opt_D_dump_BCOs
| Opt_D_dump_vect
| Opt_D_dump_ticked
......@@ -1685,6 +1686,7 @@ dopt f dflags = (fromEnum f `IntSet.member` dumpFlags dflags)
enableIfVerbose Opt_D_verbose_core2core = False
enableIfVerbose Opt_D_verbose_stg2stg = False
enableIfVerbose Opt_D_dump_splices = False
enableIfVerbose Opt_D_th_dec_file = False
enableIfVerbose Opt_D_dump_rule_firings = False
enableIfVerbose Opt_D_dump_rule_rewrites = False
enableIfVerbose Opt_D_dump_simpl_trace = False
......@@ -2477,6 +2479,8 @@ dynamic_flags = [
setDumpFlag' Opt_D_dump_cs_trace))
, defGhcFlag "ddump-vt-trace" (setDumpFlag Opt_D_dump_vt_trace)
, defGhcFlag "ddump-splices" (setDumpFlag Opt_D_dump_splices)
, defGhcFlag "dth-dec-file" (setDumpFlag Opt_D_th_dec_file)
, defGhcFlag "ddump-rn-stats" (setDumpFlag Opt_D_dump_rn_stats)
, defGhcFlag "ddump-opt-cmm" (setDumpFlag Opt_D_dump_opt_cmm)
, defGhcFlag "ddump-simpl-stats" (setDumpFlag Opt_D_dump_simpl_stats)
......
......@@ -301,7 +301,7 @@ dumpSDoc dflags print_unqual flag hdr doc
chooseDumpFile :: DynFlags -> DumpFlag -> Maybe String
chooseDumpFile dflags flag
| gopt Opt_DumpToFile dflags
| gopt Opt_DumpToFile dflags || flag == Opt_D_th_dec_file
, Just prefix <- getPrefix
= Just $ setDir (prefix ++ (beautifyDumpName flag))
......@@ -325,6 +325,7 @@ chooseDumpFile dflags flag
-- | Build a nice file name from name of a GeneralFlag constructor
beautifyDumpName :: DumpFlag -> String
beautifyDumpName Opt_D_th_dec_file = "th.hs"
beautifyDumpName flag
= let str = show flag
suff = case stripPrefix "Opt_D_" str of
......
......@@ -16,6 +16,7 @@ import TcRnMonad
import Kind
#ifdef GHCI
import ErrUtils ( dumpIfSet_dyn_printer )
import Control.Monad ( unless, when )
import DynFlags
import DsMeta ( decsQTyConName, expQTyConName, patQTyConName, typeQTyConName )
......@@ -274,8 +275,11 @@ rnTopSpliceDecls (HsSplice _ expr'')
-- Run the expression
; decls <- runMetaD zonked_q_expr
; showSplice "declarations" expr'
(ppr (getLoc expr) $$ (vcat (map ppr decls)))
; traceSplice $ SpliceInfo True
"declarations"
(Just (getLoc expr))
(Just $ ppr expr')
(vcat (map ppr decls))
; return (decls,fvs) }
......@@ -404,12 +408,55 @@ showSplice :: String -> LHsExpr Name -> SDoc -> TcM ()
-- (b) data constructors after type checking have been
-- changed to their *wrappers*, and that makes them
-- print always fully qualified
showSplice what before after
= do { loc <- getSrcSpanM
; traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what,
nest 2 (sep [nest 2 (ppr before),
text "======>",
nest 2 after])]) }
showSplice what before after =
traceSplice $ SpliceInfo False what Nothing (Just $ ppr before) after
-- | The splice data to be logged
--
-- duplicates code in TcSplice.lhs
data SpliceInfo
= SpliceInfo
{ spliceIsDeclaration :: Bool
, spliceDescription :: String
, spliceLocation :: Maybe SrcSpan
, spliceSource :: Maybe SDoc
, spliceGenerated :: SDoc
}
-- | outputs splice information for 2 flags which have different output formats:
-- `-ddump-splices` and `-dth-dec-file`
--
-- This duplicates code in TcSplice.lhs
traceSplice :: SpliceInfo -> TcM ()
traceSplice sd = do
loc <- case sd of
SpliceInfo { spliceLocation = Nothing } -> getSrcSpanM
SpliceInfo { spliceLocation = Just loc } -> return loc
traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc sd)
when (spliceIsDeclaration sd) $ do
dflags <- getDynFlags
liftIO $ dumpIfSet_dyn_printer alwaysQualify dflags Opt_D_th_dec_file
(spliceCodeDoc loc sd)
where
-- `-ddump-splices`
spliceDebugDoc :: SrcSpan -> SpliceInfo -> SDoc
spliceDebugDoc loc sd
= let code = case spliceSource sd of
Nothing -> ending
Just b -> nest 2 b : ending
ending = [ text "======>", nest 2 (spliceGenerated sd) ]
in (vcat [ ppr loc <> colon
<+> text "Splicing" <+> text (spliceDescription sd)
, nest 2 (sep code)
])
-- `-dth-dec-file`
spliceCodeDoc :: SrcSpan -> SpliceInfo -> SDoc
spliceCodeDoc loc sd
= (vcat [ text "--" <+> ppr loc <> colon
<+> text "Splicing" <+> text (spliceDescription sd)
, sep [spliceGenerated sd]
])
illegalBracket :: SDoc
illegalBracket = ptext (sLit "Template Haskell brackets cannot be nested (without intervening splices)")
......
......@@ -24,7 +24,7 @@ module TcRnDriver (
) where
#ifdef GHCI
import {-# SOURCE #-} TcSplice ( runQuasi )
import {-# SOURCE #-} TcSplice ( runQuasi, traceSplice, SpliceInfo(..) )
import RnSplice ( rnTopSpliceDecls )
#endif
......@@ -567,9 +567,12 @@ tc_rn_src_decls boot_details ds
rnTopSrcDecls extra_deps th_group
-- Dump generated top-level declarations
; loc <- getSrcSpanM
; traceSplice (vcat [ppr loc <> colon <+> text "Splicing top-level declarations added with addTopDecls ",
nest 2 (nest 2 (ppr th_rn_decls))])
; let msg = "top-level declarations added with addTopDecls"
; traceSplice $ SpliceInfo True
msg
Nothing
Nothing
(ppr th_rn_decls)
; return (tcg_env, appendGroups rn_decls th_rn_decls)
}
......
......@@ -502,15 +502,12 @@ traceTc herald doc = traceTcN 1 (hang (text herald) 2 doc)
-- | Typechecker trace
traceTcN :: Int -> SDoc -> TcRn ()
traceTcN level doc
= do { dflags <- getDynFlags
; when (level <= traceLevel dflags) $
traceOptTcRn Opt_D_dump_tc_trace doc }
= do dflags <- getDynFlags
when (level <= traceLevel dflags && not opt_NoDebugOutput) $
traceOptTcRn Opt_D_dump_tc_trace doc
traceRn :: SDoc -> TcRn ()
traceRn doc = traceOptTcRn Opt_D_dump_rn_trace doc
traceSplice :: SDoc -> TcRn ()
traceSplice doc = traceOptTcRn Opt_D_dump_splices doc
traceRn = traceOptTcRn Opt_D_dump_rn_trace -- Renamer Trace
-- | Output a doc if the given 'DumpFlag' is set.
--
......
......@@ -21,7 +21,7 @@ module TcSplice(
-- These ones are defined only in stage2, and are
-- called only in stage2 (ie GHCI is on)
runMetaE, runMetaP, runMetaT, runMetaD, runQuasi,
tcTopSpliceExpr, lookupThName_maybe,
tcTopSpliceExpr, lookupThName_maybe, traceSplice, SpliceInfo(..),
defaultRunMeta, runMeta'
#endif
) where
......@@ -460,7 +460,7 @@ tcTopSplice expr res_ty
-- Run the expression
; expr2 <- runMetaE zonked_q_expr
; showSplice "expression" expr (ppr expr2)
; showSplice False "expression" expr (ppr expr2)
-- Rename and typecheck the spliced-in expression,
-- making sure it has type res_ty
......@@ -660,7 +660,7 @@ runQuasiQuote (HsQuasiQuote quoter q_span quote) quote_selector meta_ty descr me
-- Run the expression
; result <- runMeta meta_req zonked_q_expr
; showSplice descr quoteExpr (ppr result)
; showSplice (descr == "declarations") descr quoteExpr (ppr result)
; return result }
......@@ -967,18 +967,61 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
************************************************************************
-}
showSplice :: String -> LHsExpr Name -> SDoc -> TcM ()
-- Note that 'before' is *renamed* but not *typechecked*
-- Reason (a) less typechecking crap
-- (b) data constructors after type checking have been
-- changed to their *wrappers*, and that makes them
-- print always fully qualified
showSplice what before after
= do { loc <- getSrcSpanM
; traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what,
nest 2 (sep [nest 2 (ppr before),
text "======>",
nest 2 after])]) }
showSplice :: Bool -> String -> LHsExpr Name -> SDoc -> TcM ()
showSplice isDec what before after =
traceSplice $ SpliceInfo isDec what Nothing (Just $ ppr before) after
-- | The splice data to be logged
--
-- duplicates code in RnSplice.lhs
data SpliceInfo
= SpliceInfo
{ spliceIsDeclaration :: Bool
, spliceDescription :: String
, spliceLocation :: Maybe SrcSpan
, spliceSource :: Maybe SDoc
, spliceGenerated :: SDoc
}
-- | outputs splice information for 2 flags which have different output formats:
-- `-ddump-splices` and `-dth-dec-file`
--
-- This duplicates code in RnSplice.lhs
traceSplice :: SpliceInfo -> TcM ()
traceSplice sd = do
loc <- case sd of
SpliceInfo { spliceLocation = Nothing } -> getSrcSpanM
SpliceInfo { spliceLocation = Just loc } -> return loc
traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc sd)
when (spliceIsDeclaration sd) $ do
dflags <- getDynFlags
liftIO $ dumpIfSet_dyn_printer alwaysQualify dflags Opt_D_th_dec_file
(spliceCodeDoc loc sd)
where
-- `-ddump-splices`
spliceDebugDoc :: SrcSpan -> SpliceInfo -> SDoc
spliceDebugDoc loc sd
= let code = case spliceSource sd of
Nothing -> ending
Just b -> nest 2 b : ending
ending = [ text "======>", nest 2 (spliceGenerated sd) ]
in (vcat [ ppr loc <> colon
<+> text "Splicing" <+> text (spliceDescription sd)
, nest 2 (sep code)
])
-- `-dth-dec-file`
spliceCodeDoc :: SrcSpan -> SpliceInfo -> SDoc
spliceCodeDoc loc sd
= (vcat [ text "--" <+> ppr loc <> colon
<+> text "Splicing" <+> text (spliceDescription sd)
, sep [spliceGenerated sd]
])
{-
************************************************************************
......
......@@ -11,8 +11,10 @@ import TcType ( TcRhoType )
import Annotations ( Annotation, CoreAnnTarget )
#ifdef GHCI
import Id ( Id )
import Id ( Id )
import qualified Language.Haskell.TH as TH
import Outputable (SDoc)
import SrcLoc (SrcSpan)
#endif
tcSpliceExpr :: HsSplice Name
......@@ -43,4 +45,14 @@ runMetaD :: LHsExpr Id -> TcM [LHsDecl RdrName]
lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
runQuasi :: TH.Q a -> TcM a
data SpliceInfo
= SpliceInfo
{ spliceIsDeclaration :: Bool
, spliceDescription :: String
, spliceLocation :: Maybe SrcSpan
, spliceSource :: Maybe SDoc
, spliceGenerated :: SDoc
}
traceSplice :: SpliceInfo -> TcM ()
#endif
......@@ -42,8 +42,11 @@
<itemizedlist>
<listitem>
<para>
TODO FIXME.
</para>
Added the option <option>-dth-dec-file</option>.
This dumps out a .th.hs file of all Template Haskell declarations in a corresponding .hs file. The idea is that application developers can check this into their repository so that they can grep for identifiers used elsewhere that were defined in Template Haskell.
This is similar to using <option>-ddump-to-file</option> with <option>-ddump-splices</option> but it always generates a file instead of being coupled to <option>-ddump-to-file</option> and only outputs code that does not exist in the .hs file and a comment for the splice location in the original file.
</para>
</listitem>
</itemizedlist>
</sect3>
......
......@@ -3100,6 +3100,12 @@
<entry>dynamic</entry>
<entry>-</entry>
</row>
<row>
<entry><option>-dth-dec-file</option></entry>
<entry>Show evaluated TH declarations in a .th.hs file</entry>
<entry>dynamic</entry>
<entry>-</entry>
</row>
<row>
<entry><option>-ddump-types</option></entry>
<entry>Dump type signatures</entry>
......
......@@ -9330,9 +9330,6 @@ Typed expression splices and quotations are supported.)
The reason should be clear: to run B we must compile and run A, but we are currently type-checking A.
</para></listitem>
<listitem><para>
The flag <literal>-ddump-splices</literal> shows the expansion of all top-level splices as they happen.
</para></listitem>
<listitem><para>
If you are building GHC from source, you need at least a stage-2 bootstrap compiler to
run Template Haskell. A stage-1 compiler will reject the TH constructs. Reason: TH
......@@ -9348,6 +9345,45 @@ Typed expression splices and quotations are supported.)
</para>
</sect2>
<sect2 id="th-view-gen-code"> <title> Viewing Template Haskell generated code </title>
<para>
The flag <literal>-ddump-splices</literal> shows the expansion of all top-level declaration splices, both typed and untyped, as they happen.
As with all dump flags, the default is for this output to be sent to stdout.
For a non-trivial program, you may be interested in combining this with the <literal>-ddump-to-file flag</literal> (see <xref linkend="dumping-output"/>.
For each file using Template Haskell, this will show the output in a <literal>.dump-splices</literal> file.
</para>
<para>
The flag <literal>-dth-dec-file</literal> shows the expansions of all top-level TH declaration splices, both typed and untyped, in the file <literal>M.th.hs</literal> where M is the name of the module being compiled.
Note that other types of splices (expressions, types, and patterns) are not shown.
Application developers can check this into their repository so that they can grep for identifiers that were defined in Template Haskell.
This is similar to using <option>-ddump-to-file</option> with <option>-ddump-splices</option> but it always generates a file instead of being coupled to <option>-ddump-to-file</option>. The format is also different: it does not show code from the original file, instead it only shows generated code and has a comment for the splice location of the original file.
</para>
<para>
Below is a sample output of <literal>-ddump-splices</literal>
</para>
<programlisting>
TH_pragma.hs:(6,4)-(8,26): Splicing declarations
[d| foo :: Int -> Int
foo x = x + 1 |]
======>
foo :: Int -> Int
foo x = (x + 1)
</programlisting>
<para>
Below is the output of the same sample using <literal>-dth-dec-file</literal>
</para>
<programlisting>
-- TH_pragma.hs:(6,4)-(8,26): Splicing declarations
foo :: Int -> Int
foo x = (x + 1)
</programlisting>
</sect2>
<sect2 id="th-example"> <title> A Template Haskell Worked Example </title>
<para>To help you get over the confidence barrier, try out this skeletal worked example.
First cut and paste the two modules below into "Main.hs" and "Printf.hs":</para>
......
Could not deduce (C x0 (F x0))
Could not deduce (C x0 (F x0))
......@@ -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
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.()
T3600.hs:1:1: Splicing declarations
T3600.hs:5:3-6: Splicing declarations
test
======>
T3600.hs:5:3-6
myFunction = (testFun1 [], testFun2 [], testFun2 "x")
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 |
......
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
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.()
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 #-}
......
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
......@@ -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
......
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -dth-dec-file #-}
module T8624 (THDec(..)) where
import Language.Haskell.TH
$(return [DataD [] (mkName "THDec") [] [NormalC (mkName "THDec") []] []])
-- T8624.hs:7:3-72: Splicing declarations
data THDec = THDec
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
......@@ -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#
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.()
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
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)
......@@ -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'])
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment