Add Vomit log level and dumping to disk

This commit is contained in:
Daniel Gröber 2015-08-03 08:09:24 +02:00
parent 614522644b
commit c9b6e95a30
6 changed files with 39 additions and 10 deletions

View File

@ -29,17 +29,25 @@ import Control.Monad
import Control.Monad.Trans.Class import Control.Monad.Trans.Class
import Data.List import Data.List
import Data.Char import Data.Char
import Data.Monoid (mempty, mappend, mconcat, (<>)) import Data.Monoid
import Data.Maybe
import System.IO import System.IO
import System.FilePath
import Text.PrettyPrint hiding (style, (<>)) import Text.PrettyPrint hiding (style, (<>))
import Prelude import Prelude
import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Pretty import Language.Haskell.GhcMod.Pretty
gmSetLogLevel :: GmLog m => GmLogLevel -> m () gmSetLogLevel :: GmLog m => GmLogLevel -> m ()
gmSetLogLevel level = 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 :: GmLogLevel -> GmLogLevel
increaseLogLevel l | l == maxBound = l increaseLogLevel l | l == maxBound = l
@ -67,7 +75,19 @@ gmLog level loc' doc = do
when (level <= level') $ liftIO $ hPutStrLn stderr msg 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 } newtype LogDiscardT m a = LogDiscardT { runLogDiscard :: m a }
deriving (Functor, Applicative, Monad) deriving (Functor, Applicative, Monad)

View File

@ -113,13 +113,14 @@ data GhcModEnv = GhcModEnv {
data GhcModLog = GhcModLog { data GhcModLog = GhcModLog {
gmLogLevel :: Maybe GmLogLevel, gmLogLevel :: Maybe GmLogLevel,
gmLogVomitDump :: Last Bool,
gmLogMessages :: [(GmLogLevel, String, Doc)] gmLogMessages :: [(GmLogLevel, String, Doc)]
} deriving (Show) } deriving (Show)
instance Monoid GhcModLog where 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 { data GmGhcSession = GmGhcSession {
gmgsOptions :: ![GHCOption], gmgsOptions :: ![GHCOption],

View File

@ -45,6 +45,7 @@ gmLogLevelDoc GmError = text "ERROR"
gmLogLevelDoc GmWarning = text "Warning" gmLogLevelDoc GmWarning = text "Warning"
gmLogLevelDoc GmInfo = text "info" gmLogLevelDoc GmInfo = text "info"
gmLogLevelDoc GmDebug = text "DEBUG" gmLogLevelDoc GmDebug = text "DEBUG"
gmLogLevelDoc GmVomit = text "VOMIT"
infixl 6 <+>: infixl 6 <+>:
(<+>:) :: Doc -> Doc -> Doc (<+>:) :: Doc -> Doc -> Doc

View File

@ -150,6 +150,11 @@ runGmlTWith efnmns' mdf wrapper action = do
opts <- targetGhcOptions crdl serfnmn opts <- targetGhcOptions crdl serfnmn
let opts' = opts ++ ["-O0"] ++ ghcUserOptions let opts' = opts ++ ["-O0"] ++ ghcUserOptions
gmVomit
"session-ghc-options"
(strDoc "Initializing GHC session with following options")
(show opts')
initSession opts' $ initSession opts' $
setModeSimple >>> setEmptyLogger >>> mdf setModeSimple >>> setEmptyLogger >>> mdf
@ -220,7 +225,8 @@ resolvedComponentsCache = Cached {
(False, Just mcs) -> gmsGet >>= \s -> gmsPut s { gmComponents = mcs } (False, Just mcs) -> gmsGet >>= \s -> gmsPut s { gmComponents = mcs }
_ -> return () _ -> 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 mcs <- resolveGmComponents mums comps
return (setupConfigPath:flatten mcs , mcs) return (setupConfigPath:flatten mcs , mcs)

View File

@ -170,6 +170,7 @@ data GmLogLevel =
| GmWarning | GmWarning
| GmInfo | GmInfo
| GmDebug | GmDebug
| GmVomit
deriving (Eq, Ord, Enum, Bounded, Show, Read) deriving (Eq, Ord, Enum, Bounded, Show, Read)
-- | Collection of packages -- | Collection of packages

View File

@ -237,7 +237,7 @@ intToLogLevel = toEnum
globalArgSpec :: [OptDescr (Options -> Options)] globalArgSpec :: [OptDescr (Options -> Options)]
globalArgSpec = 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 { optArg "LEVEL" $ \ml o -> o {
logLevel = case ml of logLevel = case ml of
Nothing -> increaseLogLevel (logLevel o) Nothing -> increaseLogLevel (logLevel o)