adding LineSeparator.
This commit is contained in:
parent
cd3e4989e1
commit
ed5ac820d6
@ -28,7 +28,7 @@ check :: Options
|
|||||||
-> Cradle
|
-> Cradle
|
||||||
-> FilePath -- ^ A target file
|
-> FilePath -- ^ A target file
|
||||||
-> Ghc [String]
|
-> Ghc [String]
|
||||||
check opt cradle fileName = checkIt `gcatch` handleErrMsg
|
check opt cradle fileName = checkIt `gcatch` handleErrMsg ls
|
||||||
where
|
where
|
||||||
checkIt = do
|
checkIt = do
|
||||||
readLog <- initializeFlagsWithCradle opt cradle options True
|
readLog <- initializeFlagsWithCradle opt cradle options True
|
||||||
@ -39,3 +39,4 @@ check opt cradle fileName = checkIt `gcatch` handleErrMsg
|
|||||||
options
|
options
|
||||||
| expandSplice opt = "-w:" : ghcOpts opt
|
| expandSplice opt = "-w:" : ghcOpts opt
|
||||||
| otherwise = "-Wall" : ghcOpts opt
|
| otherwise = "-Wall" : ghcOpts opt
|
||||||
|
ls = lineSeparator opt
|
||||||
|
@ -15,6 +15,7 @@ import ErrUtils
|
|||||||
import GHC
|
import GHC
|
||||||
import HscTypes
|
import HscTypes
|
||||||
import Language.Haskell.GhcMod.Doc (showUnqualifiedPage)
|
import Language.Haskell.GhcMod.Doc (showUnqualifiedPage)
|
||||||
|
import Language.Haskell.GhcMod.Types (LineSeparator(..))
|
||||||
import qualified Language.Haskell.GhcMod.Gap as Gap
|
import qualified Language.Haskell.GhcMod.Gap as Gap
|
||||||
import Outputable
|
import Outputable
|
||||||
import System.FilePath (normalise)
|
import System.FilePath (normalise)
|
||||||
@ -26,42 +27,42 @@ type LogReader = IO [String]
|
|||||||
|
|
||||||
----------------------------------------------------------------
|
----------------------------------------------------------------
|
||||||
|
|
||||||
setLogger :: Bool -> DynFlags -> IO (DynFlags, LogReader)
|
setLogger :: Bool -> DynFlags -> LineSeparator -> IO (DynFlags, LogReader)
|
||||||
setLogger False df = return (newdf, undefined)
|
setLogger False df _ = return (newdf, undefined)
|
||||||
where
|
where
|
||||||
newdf = Gap.setLogAction df $ \_ _ _ _ _ -> return ()
|
newdf = Gap.setLogAction df $ \_ _ _ _ _ -> return ()
|
||||||
setLogger True df = do
|
setLogger True df ls = do
|
||||||
ref <- newIORef [] :: IO (IORef [String])
|
ref <- newIORef [] :: IO (IORef [String])
|
||||||
let newdf = Gap.setLogAction df $ appendLog ref
|
let newdf = Gap.setLogAction df $ appendLog ref
|
||||||
return (newdf, reverse <$> readIORef ref)
|
return (newdf, reverse <$> readIORef ref)
|
||||||
where
|
where
|
||||||
appendLog ref _ sev src _ msg = do
|
appendLog ref _ sev src _ msg = do
|
||||||
let !l = ppMsg src sev df msg
|
let !l = ppMsg src sev df ls msg
|
||||||
modifyIORef ref (\ls -> l : ls)
|
modifyIORef ref (l:)
|
||||||
|
|
||||||
----------------------------------------------------------------
|
----------------------------------------------------------------
|
||||||
|
|
||||||
handleErrMsg :: SourceError -> Ghc [String]
|
handleErrMsg :: LineSeparator -> SourceError -> Ghc [String]
|
||||||
handleErrMsg err = do
|
handleErrMsg ls err = do
|
||||||
dflag <- getSessionDynFlags
|
dflag <- getSessionDynFlags
|
||||||
return . errBagToStrList dflag . srcErrorMessages $ err
|
return . errBagToStrList dflag ls . srcErrorMessages $ err
|
||||||
|
|
||||||
errBagToStrList :: DynFlags -> Bag ErrMsg -> [String]
|
errBagToStrList :: DynFlags -> LineSeparator -> Bag ErrMsg -> [String]
|
||||||
errBagToStrList dflag = map (ppErrMsg dflag) . reverse . bagToList
|
errBagToStrList dflag ls = map (ppErrMsg dflag ls) . reverse . bagToList
|
||||||
|
|
||||||
----------------------------------------------------------------
|
----------------------------------------------------------------
|
||||||
|
|
||||||
ppErrMsg :: DynFlags -> ErrMsg -> String
|
ppErrMsg :: DynFlags -> LineSeparator -> ErrMsg -> String
|
||||||
ppErrMsg dflag err = ppMsg spn SevError dflag msg ++ ext
|
ppErrMsg dflag ls err = ppMsg spn SevError dflag ls msg ++ ext
|
||||||
where
|
where
|
||||||
spn = head (errMsgSpans err)
|
spn = head (errMsgSpans err)
|
||||||
msg = errMsgShortDoc err
|
msg = errMsgShortDoc err
|
||||||
ext = showMsg dflag (errMsgExtraInfo err)
|
ext = showMsg dflag ls (errMsgExtraInfo err)
|
||||||
|
|
||||||
ppMsg :: SrcSpan -> Severity-> DynFlags -> SDoc -> String
|
ppMsg :: SrcSpan -> Severity-> DynFlags -> LineSeparator -> SDoc -> String
|
||||||
ppMsg spn sev dflag msg = prefix ++ cts ++ "\0"
|
ppMsg spn sev dflag ls@(LineSeparator lsep) msg = prefix ++ cts ++ lsep
|
||||||
where
|
where
|
||||||
cts = showMsg dflag msg
|
cts = showMsg dflag ls msg
|
||||||
defaultPrefix
|
defaultPrefix
|
||||||
| dopt Opt_D_dump_splices dflag = ""
|
| dopt Opt_D_dump_splices dflag = ""
|
||||||
| otherwise = "Dummy:0:0:"
|
| otherwise = "Dummy:0:0:"
|
||||||
@ -73,8 +74,15 @@ ppMsg spn sev dflag msg = prefix ++ cts ++ "\0"
|
|||||||
|
|
||||||
----------------------------------------------------------------
|
----------------------------------------------------------------
|
||||||
|
|
||||||
showMsg :: DynFlags -> SDoc -> String
|
showMsg :: DynFlags -> LineSeparator -> SDoc -> String
|
||||||
showMsg dflag sdoc = map toNull $ showUnqualifiedPage dflag sdoc
|
showMsg dflag (LineSeparator [s]) sdoc = replaceNull $ showUnqualifiedPage dflag sdoc
|
||||||
where
|
where
|
||||||
toNull '\n' = '\0'
|
replaceNull :: String -> String
|
||||||
toNull x = x
|
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
|
_ <- setSessionDynFlags dflags1
|
||||||
return readLog
|
return readLog
|
||||||
where
|
where
|
||||||
|
ls = lineSeparator opt
|
||||||
setupDynamicFlags df0 = do
|
setupDynamicFlags df0 = do
|
||||||
df1 <- modifyFlagsWithOpts df0 cmdOpts
|
df1 <- modifyFlagsWithOpts df0 cmdOpts
|
||||||
let df2 = modifyFlags df1 idirs mDepPkgs (expandSplice opt) build
|
let df2 = modifyFlags df1 idirs mDepPkgs (expandSplice opt) build
|
||||||
df3 <- modifyFlagsWithOpts df2 $ ghcOpts opt
|
df3 <- modifyFlagsWithOpts df2 $ ghcOpts opt
|
||||||
liftIO $ setLogger logging df3
|
liftIO $ setLogger logging df3 ls
|
||||||
|
|
||||||
----------------------------------------------------------------
|
----------------------------------------------------------------
|
||||||
|
|
||||||
|
@ -12,7 +12,8 @@ lintSyntax :: Options
|
|||||||
-> IO String
|
-> IO String
|
||||||
lintSyntax opt file = pack <$> lint opt file
|
lintSyntax opt file = pack <$> lint opt file
|
||||||
where
|
where
|
||||||
pack = unlines . map (intercalate "\0" . lines)
|
LineSeparator lsep = lineSeparator opt
|
||||||
|
pack = unlines . map (intercalate lsep . lines)
|
||||||
|
|
||||||
lint :: Options
|
lint :: Options
|
||||||
-> FilePath -- ^ A target file.
|
-> FilePath -- ^ A target file.
|
||||||
|
@ -6,29 +6,33 @@ module Language.Haskell.GhcMod.Types where
|
|||||||
data OutputStyle = LispStyle -- ^ S expression style
|
data OutputStyle = LispStyle -- ^ S expression style
|
||||||
| PlainStyle -- ^ Plain textstyle
|
| PlainStyle -- ^ Plain textstyle
|
||||||
|
|
||||||
|
newtype LineSeparator = LineSeparator String
|
||||||
|
|
||||||
data Options = Options {
|
data Options = Options {
|
||||||
outputStyle :: OutputStyle
|
outputStyle :: OutputStyle
|
||||||
, hlintOpts :: [String]
|
, hlintOpts :: [String]
|
||||||
, ghcOpts :: [String]
|
, ghcOpts :: [String]
|
||||||
, operators :: Bool
|
, operators :: Bool
|
||||||
-- | If 'True', 'browse' also returns types.
|
-- | If 'True', 'browse' also returns types.
|
||||||
, detailed :: Bool
|
, detailed :: Bool
|
||||||
-- | Whether or not Template Haskell should be expanded.
|
-- | Whether or not Template Haskell should be expanded.
|
||||||
, expandSplice :: Bool
|
, expandSplice :: Bool
|
||||||
-- | The sandbox directory.
|
-- | The sandbox directory.
|
||||||
, sandbox :: Maybe FilePath
|
, sandbox :: Maybe FilePath
|
||||||
|
, lineSeparator :: LineSeparator
|
||||||
}
|
}
|
||||||
|
|
||||||
-- | A default 'Options'.
|
-- | A default 'Options'.
|
||||||
defaultOptions :: Options
|
defaultOptions :: Options
|
||||||
defaultOptions = Options {
|
defaultOptions = Options {
|
||||||
outputStyle = PlainStyle
|
outputStyle = PlainStyle
|
||||||
, hlintOpts = []
|
, hlintOpts = []
|
||||||
, ghcOpts = []
|
, ghcOpts = []
|
||||||
, operators = False
|
, operators = False
|
||||||
, detailed = False
|
, detailed = False
|
||||||
, expandSplice = False
|
, expandSplice = False
|
||||||
, sandbox = Nothing
|
, sandbox = Nothing
|
||||||
|
, lineSeparator = LineSeparator "\0"
|
||||||
}
|
}
|
||||||
|
|
||||||
----------------------------------------------------------------
|
----------------------------------------------------------------
|
||||||
|
Loading…
Reference in New Issue
Block a user