ghc-mod/core/Language/Haskell/GhcMod/Logging.hs

116 lines
3.5 KiB
Haskell
Raw Normal View History

2017-03-06 23:19:57 +00:00
-- ghc-mod: Happy Haskell Hacking
2015-03-03 19:28:34 +00:00
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
2015-03-28 01:33:42 +00:00
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Language.Haskell.GhcMod.Logging (
module Language.Haskell.GhcMod.Logging
, module Language.Haskell.GhcMod.Pretty
, GmLogLevel(..)
, module Data.Monoid
, module Pretty
) where
2015-03-28 01:33:42 +00:00
import Control.Applicative hiding (empty)
import Control.Monad
2015-03-28 01:33:42 +00:00
import Control.Monad.Trans.Class
2015-03-06 13:04:49 +00:00
import Data.List
import Data.Char
import Data.Monoid
import Data.Maybe
import System.IO
import System.FilePath
2015-08-03 01:09:56 +00:00
import Prelude
import Pretty hiding (style, (<>))
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Pretty
import Language.Haskell.GhcMod.Output
gmSetLogLevel :: GmLog m => GmLogLevel -> m ()
gmSetLogLevel level =
gmlJournal $ GhcModLog (Just level) (Last Nothing) []
2016-01-09 22:22:27 +00:00
gmGetLogLevel :: forall m. GmLog m => m GmLogLevel
2015-10-31 17:22:05 +00:00
gmGetLogLevel = do
GhcModLog { gmLogLevel = Just level } <- gmlHistory
return level
2016-01-09 22:22:27 +00:00
gmSetDumpLevel :: GmLog m => Bool -> m ()
gmSetDumpLevel level =
gmlJournal $ GhcModLog Nothing (Last (Just level)) []
increaseLogLevel :: GmLogLevel -> GmLogLevel
increaseLogLevel l | l == maxBound = l
increaseLogLevel l = succ l
2015-03-06 18:46:56 +00:00
decreaseLogLevel :: GmLogLevel -> GmLogLevel
decreaseLogLevel l | l == minBound = l
2015-04-29 16:41:28 +00:00
decreaseLogLevel l = pred l
2015-03-06 18:46:56 +00:00
-- |
-- >>> Just GmDebug <= Nothing
-- False
-- >>> Just GmException <= Just GmDebug
-- True
-- >>> Just GmDebug <= Just GmException
-- False
gmLog :: (MonadIO m, GmLog m, GmOut m) => GmLogLevel -> String -> Doc -> m ()
gmLog level loc' doc = do
2015-05-06 14:13:08 +00:00
GhcModLog { gmLogLevel = Just level' } <- gmlHistory
let loc | loc' == "" = empty
2015-05-05 14:09:54 +00:00
| otherwise = text loc' <+>: empty
2016-01-09 22:22:27 +00:00
msgDoc = sep [loc, doc]
msg = dropWhileEnd isSpace $ render $ gmLogLevelDoc level <+>: msgDoc
when (level <= level') $ gmErrStrLn msg
2016-01-09 22:22:27 +00:00
gmLogQuiet level loc' doc
2015-05-06 14:13:08 +00:00
2016-01-09 22:22:27 +00:00
gmLogQuiet :: GmLog m => GmLogLevel -> String -> Doc -> m ()
gmLogQuiet level loc doc =
gmlJournal (GhcModLog Nothing (Last Nothing) [(level, loc, doc)])
2016-01-09 22:22:27 +00:00
gmAppendLogQuiet :: GmLog m => GhcModLog -> m ()
gmAppendLogQuiet GhcModLog { gmLogMessages } =
forM_ gmLogMessages $ \(level, loc, doc) -> gmLogQuiet level loc doc
2015-10-31 11:34:30 +00:00
gmVomit :: (MonadIO m, GmLog m, GmOut 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
2015-03-28 01:33:42 +00:00
newtype LogDiscardT m a = LogDiscardT { runLogDiscard :: m a }
deriving (Functor, Applicative, Monad)
instance MonadTrans LogDiscardT where
lift = LogDiscardT
instance Monad m => GmLog (LogDiscardT m) where
gmlJournal = const $ return ()
gmlHistory = return mempty
gmlClear = return ()