From c9b6e95a30bd41331674134fe857a0839e35221a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= <dxld@darkboxed.org>
Date: Mon, 3 Aug 2015 08:09:24 +0200
Subject: [PATCH] Add Vomit log level and dumping to disk

---
 Language/Haskell/GhcMod/Logging.hs     | 26 +++++++++++++++++++++++---
 Language/Haskell/GhcMod/Monad/Types.hs | 11 ++++++-----
 Language/Haskell/GhcMod/Pretty.hs      |  1 +
 Language/Haskell/GhcMod/Target.hs      |  8 +++++++-
 Language/Haskell/GhcMod/Types.hs       |  1 +
 src/GHCMod.hs                          |  2 +-
 6 files changed, 39 insertions(+), 10 deletions(-)

diff --git a/Language/Haskell/GhcMod/Logging.hs b/Language/Haskell/GhcMod/Logging.hs
index b6052c2..8f42b83 100644
--- a/Language/Haskell/GhcMod/Logging.hs
+++ b/Language/Haskell/GhcMod/Logging.hs
@@ -29,17 +29,25 @@ import Control.Monad
 import Control.Monad.Trans.Class
 import Data.List
 import Data.Char
-import Data.Monoid (mempty, mappend, mconcat, (<>))
+import Data.Monoid
+import Data.Maybe
 import System.IO
+import System.FilePath
 import Text.PrettyPrint hiding (style, (<>))
 import Prelude
 
 import Language.Haskell.GhcMod.Monad.Types
+import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Pretty
 
 gmSetLogLevel :: GmLog m => GmLogLevel -> m ()
 gmSetLogLevel level =
-    gmlJournal $ GhcModLog (Just level) []
+    gmlJournal $ GhcModLog (Just level) (Last Nothing) []
+
+gmSetDumpLevel :: GmLog m => Bool -> m ()
+gmSetDumpLevel level =
+    gmlJournal $ GhcModLog Nothing (Last (Just level)) []
+
 
 increaseLogLevel :: GmLogLevel -> GmLogLevel
 increaseLogLevel l | l == maxBound = l
@@ -67,7 +75,19 @@ gmLog level loc' doc = do
 
   when (level <= level') $ liftIO $ hPutStrLn stderr msg
 
-  gmlJournal (GhcModLog Nothing [(level, loc', msgDoc)])
+  gmlJournal (GhcModLog Nothing (Last Nothing) [(level, loc', msgDoc)])
+
+gmVomit :: (MonadIO m, GmLog m, GmEnv m) => String -> Doc -> String -> m ()
+gmVomit filename doc content = do
+  gmLog GmVomit "" $ doc <+> text content
+
+  GhcModLog { gmLogVomitDump = Last mdump }
+      <- gmlHistory
+
+  dir <- cradleTempDir `liftM` cradle
+  when (fromMaybe False mdump) $
+       liftIO $ writeFile (dir </> filename) content
+
 
 newtype LogDiscardT m a = LogDiscardT { runLogDiscard :: m a }
     deriving (Functor, Applicative, Monad)
diff --git a/Language/Haskell/GhcMod/Monad/Types.hs b/Language/Haskell/GhcMod/Monad/Types.hs
index 88519b3..e9343e7 100644
--- a/Language/Haskell/GhcMod/Monad/Types.hs
+++ b/Language/Haskell/GhcMod/Monad/Types.hs
@@ -112,14 +112,15 @@ data GhcModEnv = GhcModEnv {
     }
 
 data GhcModLog = GhcModLog {
-      gmLogLevel    :: Maybe GmLogLevel,
-      gmLogMessages :: [(GmLogLevel, String, Doc)]
+      gmLogLevel     :: Maybe GmLogLevel,
+      gmLogVomitDump :: Last Bool,
+      gmLogMessages  :: [(GmLogLevel, String, Doc)]
     } deriving (Show)
 
 instance Monoid GhcModLog where
-    mempty = GhcModLog (Just GmPanic) mempty
-    GhcModLog ml a `mappend` GhcModLog ml' b =
-        GhcModLog (ml' `mplus` ml) (a `mappend` b)
+    mempty = GhcModLog (Just GmPanic) (Last Nothing) mempty
+    GhcModLog ml vd ls `mappend` GhcModLog ml' vd' ls' =
+        GhcModLog (ml' `mplus` ml) (vd `mappend` vd') (ls `mappend` ls')
 
 data GmGhcSession = GmGhcSession {
       gmgsOptions :: ![GHCOption],
diff --git a/Language/Haskell/GhcMod/Pretty.hs b/Language/Haskell/GhcMod/Pretty.hs
index d14512a..5526772 100644
--- a/Language/Haskell/GhcMod/Pretty.hs
+++ b/Language/Haskell/GhcMod/Pretty.hs
@@ -45,6 +45,7 @@ gmLogLevelDoc GmError     = text "ERROR"
 gmLogLevelDoc GmWarning   = text "Warning"
 gmLogLevelDoc GmInfo      = text "info"
 gmLogLevelDoc GmDebug     = text "DEBUG"
+gmLogLevelDoc GmVomit     = text "VOMIT"
 
 infixl 6 <+>:
 (<+>:) :: Doc -> Doc -> Doc
diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs
index 74b1f6c..163adba 100644
--- a/Language/Haskell/GhcMod/Target.hs
+++ b/Language/Haskell/GhcMod/Target.hs
@@ -150,6 +150,11 @@ runGmlTWith efnmns' mdf wrapper action = do
     opts <- targetGhcOptions crdl serfnmn
     let opts' = opts ++ ["-O0"] ++ ghcUserOptions
 
+    gmVomit
+      "session-ghc-options"
+      (strDoc "Initializing GHC session with following options")
+      (show opts')
+
     initSession opts' $
         setModeSimple >>> setEmptyLogger >>> mdf
 
@@ -220,7 +225,8 @@ resolvedComponentsCache = Cached {
           (False, Just mcs) -> gmsGet >>= \s -> gmsPut s { gmComponents = mcs }
           _ -> return ()
 
---        liftIO $ print ("changed files", mums :: Maybe [Either FilePath ()])
+        gmLog GmDebug "resolvedComponentsCache" $
+              strDoc "files changed" <+>: text (show (mums :: Maybe [Either FilePath ()]))
 
         mcs <- resolveGmComponents mums comps
         return (setupConfigPath:flatten mcs , mcs)
diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs
index 416c04c..1fb7230 100644
--- a/Language/Haskell/GhcMod/Types.hs
+++ b/Language/Haskell/GhcMod/Types.hs
@@ -170,6 +170,7 @@ data GmLogLevel =
   | GmWarning
   | GmInfo
   | GmDebug
+  | GmVomit
     deriving (Eq, Ord, Enum, Bounded, Show, Read)
 
 -- | Collection of packages
diff --git a/src/GHCMod.hs b/src/GHCMod.hs
index 50be2b1..cf4cfe4 100644
--- a/src/GHCMod.hs
+++ b/src/GHCMod.hs
@@ -237,7 +237,7 @@ intToLogLevel = toEnum
 
 globalArgSpec :: [OptDescr (Options -> Options)]
 globalArgSpec =
-      [ option "v" ["verbose"] "Increase or set log level. (0-6)" $
+      [ option "v" ["verbose"] "Increase or set log level. (0-7)" $
                optArg "LEVEL" $ \ml o -> o {
                    logLevel = case ml of
                                 Nothing -> increaseLogLevel (logLevel o)