adding LineSeparator.

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

View File

@ -28,7 +28,7 @@ check :: Options
-> Cradle
-> FilePath -- ^ A target file
-> Ghc [String]
check opt cradle fileName = checkIt `gcatch` handleErrMsg
check opt cradle fileName = checkIt `gcatch` handleErrMsg ls
where
checkIt = do
readLog <- initializeFlagsWithCradle opt cradle options True
@ -39,3 +39,4 @@ check opt cradle fileName = checkIt `gcatch` handleErrMsg
options
| expandSplice opt = "-w:" : ghcOpts opt
| otherwise = "-Wall" : ghcOpts opt
ls = lineSeparator opt

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

View File

@ -87,11 +87,12 @@ initSession build opt cmdOpts idirs mDepPkgs logging = do
_ <- setSessionDynFlags dflags1
return readLog
where
ls = lineSeparator opt
setupDynamicFlags df0 = do
df1 <- modifyFlagsWithOpts df0 cmdOpts
let df2 = modifyFlags df1 idirs mDepPkgs (expandSplice opt) build
df3 <- modifyFlagsWithOpts df2 $ ghcOpts opt
liftIO $ setLogger logging df3
liftIO $ setLogger logging df3 ls
----------------------------------------------------------------

View File

@ -12,7 +12,8 @@ lintSyntax :: Options
-> IO String
lintSyntax opt file = pack <$> lint opt file
where
pack = unlines . map (intercalate "\0" . lines)
LineSeparator lsep = lineSeparator opt
pack = unlines . map (intercalate lsep . lines)
lint :: Options
-> FilePath -- ^ A target file.

View File

@ -6,29 +6,33 @@ module Language.Haskell.GhcMod.Types where
data OutputStyle = LispStyle -- ^ S expression style
| PlainStyle -- ^ Plain textstyle
newtype LineSeparator = LineSeparator String
data Options = Options {
outputStyle :: OutputStyle
, hlintOpts :: [String]
, ghcOpts :: [String]
, operators :: Bool
outputStyle :: OutputStyle
, hlintOpts :: [String]
, ghcOpts :: [String]
, operators :: Bool
-- | If 'True', 'browse' also returns types.
, detailed :: Bool
, detailed :: Bool
-- | Whether or not Template Haskell should be expanded.
, expandSplice :: Bool
, expandSplice :: Bool
-- | The sandbox directory.
, sandbox :: Maybe FilePath
, sandbox :: Maybe FilePath
, lineSeparator :: LineSeparator
}
-- | A default 'Options'.
defaultOptions :: Options
defaultOptions = Options {
outputStyle = PlainStyle
, hlintOpts = []
, ghcOpts = []
, operators = False
, detailed = False
, expandSplice = False
, sandbox = Nothing
outputStyle = PlainStyle
, hlintOpts = []
, ghcOpts = []
, operators = False
, detailed = False
, expandSplice = False
, sandbox = Nothing
, lineSeparator = LineSeparator "\0"
}
----------------------------------------------------------------