From 1790c5f327deb8dd49f54c043c6f4ed0c4f7acd8 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 24 Aug 2011 16:50:26 +0900 Subject: [PATCH] ErrMsg module. --- Cabal.hs | 1 + Check.hs | 21 ++++++------- ErrMsg.hs | 85 +++++++++++++++++++++++++++++++++++++++++++++++++++ Types.hs | 48 +---------------------------- ghc-mod.cabal | 2 +- 5 files changed, 98 insertions(+), 59 deletions(-) create mode 100644 ErrMsg.hs diff --git a/Cabal.hs b/Cabal.hs index 89c442b..0f562f0 100644 --- a/Cabal.hs +++ b/Cabal.hs @@ -8,6 +8,7 @@ import Data.Attoparsec.Enumerator import Data.Enumerator (run, ($$)) import Data.Enumerator.Binary (enumFile) import Data.List +import ErrMsg import GHC import System.Directory import System.FilePath diff --git a/Check.hs b/Check.hs index fb5940c..9f1db92 100644 --- a/Check.hs +++ b/Check.hs @@ -3,6 +3,8 @@ module Check (checkSyntax) where import Cabal import Control.Applicative import CoreMonad +import ErrMsg +import Exception import GHC import Prelude hiding (catch) import Types @@ -15,15 +17,12 @@ checkSyntax opt file = unlines <$> check opt file ---------------------------------------------------------------- check :: Options -> String -> IO [String] -check opt fileName = withGHC $ do - (file,readLog) <- initializeGHC opt fileName options True - setTargetFile file - load LoadAllTargets -- `gcatch` handleParseError ref xxx - liftIO readLog +check opt fileName = withGHC $ checkIt `gcatch` handleErrMsg where - options = ["-Wall","-fno-warn-unused-do-bind"] ++ map ("-i" ++) (checkIncludes opt) - {- - handleParseError ref e = do - liftIO . writeIORef ref $ errBagToStrList . srcErrorMessages $ e - return Succeeded - -} \ No newline at end of file + checkIt = do + (file,readLog) <- initializeGHC opt fileName options True + setTargetFile file + load LoadAllTargets + liftIO readLog + options = ["-Wall","-fno-warn-unused-do-bind"] + ++ map ("-i" ++) (checkIncludes opt) diff --git a/ErrMsg.hs b/ErrMsg.hs new file mode 100644 index 0000000..f3abb42 --- /dev/null +++ b/ErrMsg.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE CPP #-} + +module ErrMsg ( + LogReader + , setLogger + , handleErrMsg + ) where + +import Bag +import Control.Applicative +import Data.IORef +import DynFlags +import ErrUtils +import FastString +import GHC +import HscTypes +import Outputable +import System.FilePath + +#if __GLASGOW_HASKELL__ < 702 +import Pretty +#endif + +---------------------------------------------------------------- + +type LogReader = IO [String] + +---------------------------------------------------------------- + +setLogger :: Bool -> DynFlags -> IO (DynFlags, LogReader) +setLogger False df = return (newdf, undefined) + where + newdf = df { log_action = \_ _ _ _ -> return () } +setLogger True df = do + ref <- newIORef [] :: IO (IORef [String]) + let newdf = df { log_action = appendLog ref } + return (newdf, reverse <$> readIORef ref) + where + appendLog ref _ src _ msg = modifyIORef ref (\ls -> ppMsg src msg : ls) + +---------------------------------------------------------------- + +handleErrMsg :: SourceError -> Ghc [String] +handleErrMsg = return . errBagToStrList . srcErrorMessages + +errBagToStrList :: Bag ErrMsg -> [String] +errBagToStrList = map ppErrMsg . reverse . bagToList + +---------------------------------------------------------------- + +ppErrMsg :: ErrMsg -> String +ppErrMsg err = ppMsg spn msg ++ ext + where + spn = head (errMsgSpans err) + msg = errMsgShortDoc err + ext = showMsg (errMsgExtraInfo err) + +ppMsg :: SrcSpan -> Message -> String +#if __GLASGOW_HASKELL__ >= 702 +ppMsg (UnhelpfulSpan _) _ = undefined +ppMsg (RealSrcSpan src) msg +#else +ppMsg src msg +#endif + = file ++ ":" ++ line ++ ":" ++ col ++ ":" ++ cts ++ "\0" + where + file = takeFileName $ unpackFS (srcSpanFile src) + line = show (srcSpanStartLine src) + col = show (srcSpanStartCol src) + cts = showMsg msg + +---------------------------------------------------------------- + +style :: PprStyle +style = mkUserStyle neverQualify AllTheWay + +showMsg :: SDoc -> String +#if __GLASGOW_HASKELL__ >= 702 +showMsg d = map toNull $ renderWithStyle d style +#else +showMsg d = map toNull . Pretty.showDocWith PageMode $ d style +#endif + where + toNull '\n' = '\0' + toNull x = x diff --git a/Types.hs b/Types.hs index 647dc34..929d51a 100644 --- a/Types.hs +++ b/Types.hs @@ -1,20 +1,12 @@ -{-# LANGUAGE CPP #-} - module Types where -import Control.Applicative import Control.Monad import CoreMonad -import Data.IORef import DynFlags -import ErrUtils +import ErrMsg import Exception -import FastString import GHC import GHC.Paths (libdir) -import Outputable -import System.FilePath -import Pretty ---------------------------------------------------------------- @@ -76,44 +68,6 @@ setPackageConfFlags ---------------------------------------------------------------- -type LogReader = IO [String] - -setLogger :: Bool -> DynFlags -> IO (DynFlags, LogReader) -setLogger False df = return (newdf, undefined) - where - newdf = df { log_action = \_ _ _ _ -> return () } -setLogger True df = do - ref <- newIORef [] :: IO (IORef [String]) - let newdf = df { log_action = appendLog ref } - return (newdf, reverse <$> readIORef ref) - where - appendLog ref _ src _ msg = modifyIORef ref (\ls -> ppMsg src msg : ls) - -ppMsg :: SrcSpan -> Message -> String -#if __GLASGOW_HASKELL__ >= 702 -ppMsg (UnhelpfulSpan _) _ = undefined -ppMsg (RealSrcSpan src) msg -#else -ppMsg src msg -#endif - = file ++ ":" ++ line ++ ":" ++ col ++ ":" ++ cts ++ "\0" -- xxx - where - file = takeFileName $ unpackFS (srcSpanFile src) - line = show (srcSpanStartLine src) - col = show (srcSpanStartCol src) - cts = showMsg msg - -style :: PprStyle -style = mkUserStyle neverQualify AllTheWay - -showMsg :: SDoc -> String -showMsg d = map toNull . Pretty.showDocWith PageMode $ d style - where - toNull '\n' = '\0' - toNull x = x - ----------------------------------------------------------------- - setTargetFile :: (GhcMonad m) => String -> m () setTargetFile file = do target <- guessTarget file Nothing diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 0fcc72f..3dcb94e 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -23,7 +23,7 @@ Data-Files: Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el ghc-flymake.el ghc-command.el ghc-info.el Executable ghc-mod Main-Is: GHCMod.hs - Other-Modules: List Browse Cabal Check Info Lang Lint Types + Other-Modules: List Browse Cabal Check Info Lang Lint Types ErrMsg if impl(ghc >= 6.12) GHC-Options: -Wall -fno-warn-unused-do-bind else