Replace mapped names with original ones in output

This commit is contained in:
Nikolay Yakimov 2015-06-16 13:49:53 +03:00
parent f8a0325617
commit 2504f643e9
3 changed files with 85 additions and 51 deletions

View File

@ -242,21 +242,22 @@ updateHomeModuleGraph' env smp0 = do
$ map unLoc hsmodImports
liftIO $ Set.fromList . catMaybes <$> mapM (findModulePath env) mns
preprocessFile :: MonadIO m =>
preprocessFile :: (IOish m, GmEnv m, GmState m) =>
HscEnv -> FilePath -> m (Either [String] ([String], (DynFlags, FilePath)))
preprocessFile env file =
liftIO $ withLogger' env $ \setDf -> do
withLogger' env $ \setDf -> do
let env' = env { hsc_dflags = setDf (hsc_dflags env) }
preprocess env' (file, Nothing)
liftIO $ preprocess env' (file, Nothing)
fileModuleName ::
HscEnv -> FilePath -> IO (Either [String] (Maybe ModuleName))
fileModuleName env fn = handle (\(_ :: SomeException) -> return $ Right Nothing) $ do
fileModuleName :: (IOish m, GmEnv m, GmState m) =>
HscEnv -> FilePath -> m (Either [String] (Maybe ModuleName))
fileModuleName env fn = do
let handler = liftIO . handle (\(_ :: SomeException) -> return $ Right Nothing)
ep <- preprocessFile env fn
case ep of
Left errs -> do
return $ Left errs
Right (_warns, (dflags, procdFile)) -> do
Right (_warns, (dflags, procdFile)) -> handler $ do
src <- readFile procdFile
case parseModuleHeader src dflags procdFile of
Left errs -> do

View File

@ -9,9 +9,11 @@ module Language.Haskell.GhcMod.Logger (
import Control.Arrow
import Control.Applicative
import Data.List (isPrefixOf)
import Data.Maybe (fromMaybe)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, mapMaybe)
import Control.Monad.Reader (Reader, asks, runReader)
import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
import System.FilePath (normalise)
import System.FilePath (normalise, makeRelative)
import Text.PrettyPrint
import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo)
@ -26,6 +28,7 @@ import Language.Haskell.GhcMod.Doc (showPage)
import Language.Haskell.GhcMod.DynFlags (withDynFlags)
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.Types
import qualified Language.Haskell.GhcMod.Gap as Gap
import Prelude
@ -35,6 +38,13 @@ data Log = Log [String] Builder
newtype LogRef = LogRef (IORef Log)
data ReaderState = ReaderState { rsDynFlags :: DynFlags
, rsPprStyle :: PprStyle
, rsMapFile :: FilePath -> FilePath
}
type ReaderM a = Reader ReaderState a
emptyLog :: Log
emptyLog = Log [] id
@ -47,10 +57,10 @@ readAndClearLogRef (LogRef ref) = do
writeIORef ref emptyLog
return $ b []
appendLogRef :: DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
appendLogRef df (LogRef ref) _ sev src st msg = modifyIORef ref update
appendLogRef :: ReaderState -> DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
appendLogRef rs df (LogRef ref) _ sev src st msg = modifyIORef ref update
where
l = ppMsg src sev df st msg
l = runReader (ppMsg src sev msg) rs{rsDynFlags=df, rsPprStyle=st}
update lg@(Log ls b)
| l `elem` ls = lg
| otherwise = Log (l:ls) (b . (l:))
@ -60,7 +70,7 @@ appendLogRef df (LogRef ref) _ sev src st msg = modifyIORef ref update
-- | Set the session flag (e.g. "-Wall" or "-w:") then
-- executes a body. Logged messages are returned as 'String'.
-- Right is success and Left is failure.
withLogger :: (GmGhc m, GmEnv m)
withLogger :: (GmGhc m, GmEnv m, GmState m)
=> (DynFlags -> DynFlags)
-> m a
-> m (Either String (String, a))
@ -72,74 +82,97 @@ withLogger f action = do
withDynFlags (f . setDf) action
return $ either (Left . conv) (Right . first conv) eres
withLogger' :: IOish m
withLogger' :: (IOish m, GmState m, GmEnv m)
=> HscEnv -> ((DynFlags -> DynFlags) -> m a) -> m (Either [String] ([String], a))
withLogger' env action = do
logref <- liftIO $ newLogRef
rfm <- do
mm <- Map.toList <$> getMMappedFiles
let
mf :: FilePath -> FileMapping -> Maybe (FilePath, FilePath)
mf from (RedirectedMapping to)
= Just (to, from)
mf _ _ = Nothing
return $ Map.fromList $ mapMaybe (uncurry mf) mm
crdl <- cradle
let dflags = hsc_dflags env
pu = icPrintUnqual dflags (hsc_IC env)
st = mkUserStyle pu AllTheWay
stl = mkUserStyle pu AllTheWay
st = ReaderState {
rsDynFlags = dflags
, rsPprStyle = stl
, rsMapFile = \key ->
fromMaybe key
$ makeRelative (cradleRootDir crdl)
<$> Map.lookup key rfm
}
fn df = setLogger logref df
setLogger df = Gap.setLogAction df $ appendLogRef st df logref
handlers = [
GHandler $ \ex -> return $ Left $ runReader (sourceError ex) st,
GHandler $ \ex -> return $ Left [render $ ghcExceptionDoc ex]
]
a <- gcatches (Right <$> action fn) (handlers dflags st)
a <- gcatches (Right <$> action setLogger) handlers
ls <- liftIO $ readAndClearLogRef logref
return $ ((,) ls <$> a)
where
setLogger logref df = Gap.setLogAction df $ appendLogRef df logref
handlers df st = [
GHandler $ \ex -> return $ Left $ sourceError df st ex,
GHandler $ \ex -> return $ Left [render $ ghcExceptionDoc ex]
]
return ((,) ls <$> a)
errBagToStrList :: HscEnv -> Bag ErrMsg -> [String]
errBagToStrList env errs = let
dflags = hsc_dflags env
pu = icPrintUnqual dflags (hsc_IC env)
st = mkUserStyle pu AllTheWay
in errsToStr dflags st $ bagToList errs
in runReader (errsToStr (bagToList errs)) ReaderState{rsDynFlags=dflags, rsPprStyle=st}
----------------------------------------------------------------
-- | Converting 'SourceError' to 'String'.
sourceError :: DynFlags -> PprStyle -> SourceError -> [String]
sourceError df st src_err = errsToStr df st $ reverse $ bagToList $ srcErrorMessages src_err
sourceError :: SourceError -> ReaderM [String]
sourceError = errsToStr . reverse . bagToList . srcErrorMessages
errsToStr :: DynFlags -> PprStyle -> [ErrMsg] -> [String]
errsToStr df st = map (ppErrMsg df st)
errsToStr :: [ErrMsg] -> ReaderM [String]
errsToStr = mapM ppErrMsg
----------------------------------------------------------------
ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String
ppErrMsg dflag st err =
ppMsg spn SevError dflag st msg ++ (if null ext then "" else "\n" ++ ext)
ppErrMsg :: ErrMsg -> ReaderM String
ppErrMsg err = do
dflag <- asks rsDynFlags
st <- asks rsPprStyle
let ext = showPage dflag st (errMsgExtraInfo err)
m <- ppMsg spn SevError msg
return $ m ++ (if null ext then "" else "\n" ++ ext)
where
spn = Gap.errorMsgSpan err
msg = errMsgShortDoc err
ext = showPage dflag st (errMsgExtraInfo err)
ppMsg :: SrcSpan -> Severity-> DynFlags -> PprStyle -> SDoc -> String
ppMsg spn sev dflag st msg = prefix ++ cts
where
cts = showPage dflag st msg
prefix = ppMsgPrefix spn sev dflag st cts
ppMsg :: SrcSpan -> Severity-> SDoc -> ReaderM String
ppMsg spn sev msg = do
dflag <- asks rsDynFlags
st <- asks rsPprStyle
let cts = showPage dflag st msg
prefix <- ppMsgPrefix spn sev cts
return $ prefix ++ cts
ppMsgPrefix :: SrcSpan -> Severity-> DynFlags -> PprStyle -> String -> String
ppMsgPrefix spn sev dflag _st cts =
ppMsgPrefix :: SrcSpan -> Severity -> String -> ReaderM String
ppMsgPrefix spn sev cts = do
dflag <- asks rsDynFlags
mr <- asks rsMapFile
let defaultPrefix
| Gap.isDumpSplices dflag = ""
| otherwise = checkErrorPrefix
in fromMaybe defaultPrefix $ do
(line,col,_,_) <- Gap.getSrcSpan spn
file <- normalise <$> Gap.getSrcFile spn
let severityCaption = Gap.showSeverityCaption sev
pref0 | or (map (\x -> x `isPrefixOf` cts) warningAsErrorPrefixes)
= file ++ ":" ++ show line ++ ":" ++ show col ++ ":"
| otherwise = file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption
return pref0
return $ fromMaybe defaultPrefix $ do
(line,col,_,_) <- Gap.getSrcSpan spn
file <- mr <$> normalise <$> Gap.getSrcFile spn
let severityCaption = Gap.showSeverityCaption sev
pref0 | or (map (\x -> x `isPrefixOf` cts) warningAsErrorPrefixes)
= file ++ ":" ++ show line ++ ":" ++ show col ++ ":"
| otherwise = file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption
return pref0
checkErrorPrefix :: String
checkErrorPrefix = "Dummy:0:0:Error:"

View File

@ -382,7 +382,7 @@ chModToMod :: ChModuleName -> ModuleName
chModToMod (ChModuleName mn) = mkModuleName mn
resolveModule :: (MonadIO m, GmEnv m, GmLog m, GmState m) =>
resolveModule :: (IOish m, GmEnv m, GmLog m, GmState m) =>
HscEnv -> [FilePath] -> CompilationUnit -> m (Maybe ModulePath)
resolveModule env _srcDirs (Right mn) =
liftIO $ traverse canonicalizeModulePath =<< findModulePath env mn
@ -392,7 +392,7 @@ resolveModule env srcDirs (Left fn') = do
Nothing -> return Nothing
Just fn'' -> do
fn <- liftIO $ canonicalizePath fn''
emn <- liftIO $ fileModuleName env fn
emn <- fileModuleName env fn
case emn of
Left errs -> do
gmLog GmWarning ("resolveModule " ++ show fn) $