hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

adding LineSeparator.

Browse Source
This commit is contained in:
Kazu Yamamoto
2013-09-03 14:40:51 +09:00
parent cd3e4989e1
commit ed5ac820d6
5 changed files with 52 additions and 37 deletions
Download Patch File Download Diff File Expand all files Collapse all files

48
Language/Haskell/GhcMod/ErrMsg.hs
View File

@@ -15,6 +15,7 @@ import ErrUtils
import GHC
import HscTypes
import Language.Haskell.GhcMod.Doc (showUnqualifiedPage)
import Language.Haskell.GhcMod.Types (LineSeparator(..))
import qualified Language.Haskell.GhcMod.Gap as Gap
import Outputable
import System.FilePath (normalise)
@@ -26,42 +27,42 @@ type LogReader = IO [String]
----------------------------------------------------------------
setLogger :: Bool -> DynFlags -> IO (DynFlags, LogReader)
setLogger False df = return (newdf, undefined)
setLogger :: Bool -> DynFlags -> LineSeparator -> IO (DynFlags, LogReader)
setLogger False df _ = return (newdf, undefined)
where
newdf = Gap.setLogAction df $ \_ _ _ _ _ -> return ()
setLogger True df = do
setLogger True df ls = do
ref <- newIORef [] :: IO (IORef [String])
let newdf = Gap.setLogAction df $ appendLog ref
return (newdf, reverse <$> readIORef ref)
where
appendLog ref _ sev src _ msg = do
let !l = ppMsg src sev df msg
modifyIORef ref (\ls -> l : ls)
let !l = ppMsg src sev df ls msg
modifyIORef ref (l:)
----------------------------------------------------------------
handleErrMsg :: SourceError -> Ghc [String]
handleErrMsg err = do
handleErrMsg :: LineSeparator -> SourceError -> Ghc [String]
handleErrMsg ls err = do
dflag <- getSessionDynFlags
return . errBagToStrList dflag . srcErrorMessages $ err
return . errBagToStrList dflag ls . srcErrorMessages $ err
errBagToStrList :: DynFlags -> Bag ErrMsg -> [String]
errBagToStrList dflag = map (ppErrMsg dflag) . reverse . bagToList
errBagToStrList :: DynFlags -> LineSeparator -> Bag ErrMsg -> [String]
errBagToStrList dflag ls = map (ppErrMsg dflag ls) . reverse . bagToList
----------------------------------------------------------------
ppErrMsg :: DynFlags -> ErrMsg -> String
ppErrMsg dflag err = ppMsg spn SevError dflag msg ++ ext
ppErrMsg :: DynFlags -> LineSeparator -> ErrMsg -> String
ppErrMsg dflag ls err = ppMsg spn SevError dflag ls msg ++ ext
where
spn = head (errMsgSpans err)
msg = errMsgShortDoc err
ext = showMsg dflag (errMsgExtraInfo err)
ext = showMsg dflag ls (errMsgExtraInfo err)
ppMsg :: SrcSpan -> Severity-> DynFlags -> SDoc -> String
ppMsg spn sev dflag msg = prefix ++ cts ++ "\0"
ppMsg :: SrcSpan -> Severity-> DynFlags -> LineSeparator -> SDoc -> String
ppMsg spn sev dflag ls@(LineSeparator lsep) msg = prefix ++ cts ++ lsep
where
cts = showMsg dflag msg
cts = showMsg dflag ls msg
defaultPrefix
| dopt Opt_D_dump_splices dflag = ""
| otherwise = "Dummy:0:0:"
@@ -73,8 +74,15 @@ ppMsg spn sev dflag msg = prefix ++ cts ++ "\0"
----------------------------------------------------------------
showMsg :: DynFlags -> SDoc -> String
showMsg dflag sdoc = map toNull $ showUnqualifiedPage dflag sdoc
showMsg :: DynFlags -> LineSeparator -> SDoc -> String
showMsg dflag (LineSeparator [s]) sdoc = replaceNull $ showUnqualifiedPage dflag sdoc
where
toNull '\n' = '\0'
toNull x = x
replaceNull :: String -> String
replaceNull [] = []
replaceNull ('\n':xs) = s : replaceNull xs
replaceNull (x:xs) = x : replaceNull xs
showMsg dflag (LineSeparator lsep) sdoc = replaceNull $ showUnqualifiedPage dflag sdoc
where
replaceNull [] = []
replaceNull ('\n':xs) = lsep ++ replaceNull xs
replaceNull (x:xs) = x : replaceNull xs