From 2c69ee4c8ad9bbefce41f47f1170e15c11a18c66 Mon Sep 17 00:00:00 2001
From: Kazu Yamamoto <kazu@iij.ad.jp>
Date: Mon, 27 Feb 2012 11:23:56 +0900
Subject: [PATCH] ghc-mod "expand" to expand TH.

---
 Check.hs  |  4 +++-
 GHCApi.hs | 10 +++++++---
 GHCMod.hs | 11 +++--------
 Types.hs  | 18 ++++++++++++++----
 4 files changed, 27 insertions(+), 16 deletions(-)

diff --git a/Check.hs b/Check.hs
index 6d0baf6..6ce246f 100644
--- a/Check.hs
+++ b/Check.hs
@@ -25,4 +25,6 @@ check opt fileName = withGHC $ checkIt `gcatch` handleErrMsg
         setTargetFile file
         load LoadAllTargets
         liftIO readLog
-    options = ["-Wall","-fno-warn-unused-do-bind"] ++ ghcOpts opt
+    options
+      | expandSplice opt = ghcOpts opt
+      | otherwise        = ["-Wall","-fno-warn-unused-do-bind"] ++ ghcOpts opt
diff --git a/GHCApi.hs b/GHCApi.hs
index d5ff73f..f525036 100644
--- a/GHCApi.hs
+++ b/GHCApi.hs
@@ -31,20 +31,24 @@ initSession opt cmdOpts idirs logging = do
     dflags <- getSessionDynFlags
     let opts = map noLoc cmdOpts
     (dflags',_,_) <- parseDynamicFlags dflags opts
-    (dflags'',readLog) <- liftIO . (>>= setLogger logging) . setGhcFlags opt . setFlags dflags' $ idirs
+    (dflags'',readLog) <- liftIO . (>>= setLogger logging) . setGhcFlags opt . setFlags opt dflags' $ idirs
     setSessionDynFlags dflags''
     return readLog
 
 ----------------------------------------------------------------
 
-setFlags :: DynFlags -> [FilePath] -> DynFlags
-setFlags d idirs = d'
+setFlags :: Options -> DynFlags -> [FilePath] -> DynFlags
+setFlags opt d idirs = d'
   where
     d' = d {
         packageFlags = ghcPackage : packageFlags d
       , importPaths = idirs
       , ghcLink = NoLink
       , hscTarget = HscInterpreted
+      , flags = if expandSplice opt then
+                    flags d ++ [Opt_D_dump_splices]
+                else
+                    flags d
       }
 
 ghcPackage :: PackageFlag
diff --git a/GHCMod.hs b/GHCMod.hs
index 814445e..4eeef7a 100644
--- a/GHCMod.hs
+++ b/GHCMod.hs
@@ -35,6 +35,7 @@ usage =    "ghc-mod version " ++ showVersion version ++ "\n"
         ++ "\t ghc-mod flag [-l]\n"
         ++ "\t ghc-mod browse" ++ ghcOptHelp ++ "[-l] [-o] <module> [<module> ...]\n"
         ++ "\t ghc-mod check" ++ ghcOptHelp ++ "<HaskellFile>\n"
+        ++ "\t ghc-mod expand" ++ ghcOptHelp ++ "<HaskellFile>\n"
         ++ "\t ghc-mod info" ++ ghcOptHelp ++ "<HaskellFile> <module> <expression>\n"
         ++ "\t ghc-mod type" ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
         ++ "\t ghc-mod lint [-h opt] <HaskellFile>\n"
@@ -43,14 +44,6 @@ usage =    "ghc-mod version " ++ showVersion version ++ "\n"
 
 ----------------------------------------------------------------
 
-defaultOptions :: Options
-defaultOptions = Options {
-    outputStyle = PlainStyle
-  , hlintOpts = []
-  , ghcOpts = []
-  , operators = False
-  }
-
 argspec :: [OptDescr (Options -> Options)]
 argspec = [ Option "l" ["tolisp"]
             (NoArg (\opts -> opts { outputStyle = LispStyle }))
@@ -91,6 +84,8 @@ main = flip catches handlers $ do
       "browse" -> concat <$> mapM (browseModule opt) (tail cmdArg)
       "list"   -> listModules opt
       "check"  -> withFile (checkSyntax opt) (safelist cmdArg 1)
+      "expand" -> withFile (checkSyntax opt { expandSplice = True }) 
+                           (safelist cmdArg 1)
       "type"  -> withFile (typeExpr opt (safelist cmdArg 2) (read $ safelist cmdArg 3) (read $ safelist cmdArg 4)) (safelist cmdArg 1)
       "info"   -> withFile (infoExpr opt (safelist cmdArg 2) (safelist cmdArg 3)) (safelist cmdArg 1)
       "lint"   -> withFile (lintSyntax opt)  (safelist cmdArg 1)
diff --git a/Types.hs b/Types.hs
index c0a36b0..0be01be 100644
--- a/Types.hs
+++ b/Types.hs
@@ -5,10 +5,20 @@ module Types where
 data OutputStyle = LispStyle | PlainStyle
 
 data Options = Options {
-    outputStyle :: OutputStyle
-  , hlintOpts   :: [String]
-  , ghcOpts     :: [String]
-  , operators   :: Bool
+    outputStyle  :: OutputStyle
+  , hlintOpts    :: [String]
+  , ghcOpts      :: [String]
+  , operators    :: Bool
+  , expandSplice :: Bool
+  }
+
+defaultOptions :: Options
+defaultOptions = Options {
+    outputStyle  = PlainStyle
+  , hlintOpts    = []
+  , ghcOpts      = []
+  , operators    = False
+  , expandSplice = False
   }
 
 ----------------------------------------------------------------