adding LineSeparator.
This commit is contained in:
parent
cd3e4989e1
commit
ed5ac820d6
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
|
@ -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.
|
||||
|
@ -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"
|
||||
}
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
Loading…
Reference in New Issue
Block a user