Add Vomit log level and dumping to disk

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)

Language/Haskell/GhcMod/Monad/Types.hs

@@ -113,13 +113,14 @@ data GhcModEnv = GhcModEnv {
 
 data GhcModLog = GhcModLog {
       gmLogLevel     :: Maybe GmLogLevel,
+      gmLogVomitDump :: Last Bool,
       gmLogMessages  :: [(GmLogLevel, String, Doc)]
     } deriving (Show)
 
 instance Monoid GhcModLog where
-    mempty = GhcModLog (Just GmPanic) mempty
+    mempty = GhcModLog (Just GmPanic) (Last Nothing) mempty
-    GhcModLog ml a `mappend` GhcModLog ml' b =
+    GhcModLog ml vd ls `mappend` GhcModLog ml' vd' ls' =
-        GhcModLog (ml' `mplus` ml) (a `mappend` b)
+        GhcModLog (ml' `mplus` ml) (vd `mappend` vd') (ls `mappend` ls')
 
 data GmGhcSession = GmGhcSession {
       gmgsOptions :: ![GHCOption],

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

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)

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

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)