refactoring for lineSeparator.
This commit is contained in:
parent
b2c2d1a443
commit
3d03cff06b
@ -18,6 +18,7 @@ import HscTypes (SourceError, srcErrorMessages)
|
||||
import Language.Haskell.GhcMod.Doc (showPage, getStyle)
|
||||
import qualified Language.Haskell.GhcMod.Gap as Gap
|
||||
import Language.Haskell.GhcMod.Types (LineSeparator(..), Options(..), convert)
|
||||
import Language.Haskell.GhcMod.Utils (replace)
|
||||
import Outputable (PprStyle, SDoc)
|
||||
import System.FilePath (normalise)
|
||||
|
||||
@ -41,9 +42,9 @@ readAndClearLogRef opt (LogRef ref) = do
|
||||
writeIORef ref id
|
||||
return $! convert opt (b [])
|
||||
|
||||
appendLogRef :: DynFlags -> LineSeparator -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
|
||||
appendLogRef df ls (LogRef ref) _ sev src style msg = do
|
||||
let !l = ppMsg src sev df ls style msg
|
||||
appendLogRef :: DynFlags -> Options -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
|
||||
appendLogRef df opt (LogRef ref) _ sev src style msg = do
|
||||
let !l = ppMsg src sev df opt style msg
|
||||
modifyIORef ref (\b -> b . (l:))
|
||||
|
||||
----------------------------------------------------------------
|
||||
@ -54,10 +55,8 @@ setLogger False df _ = return (newdf, undefined)
|
||||
newdf = Gap.setLogAction df $ \_ _ _ _ _ -> return ()
|
||||
setLogger True df opt = do
|
||||
logref <- newLogRef
|
||||
let newdf = Gap.setLogAction df $ appendLogRef df ls logref
|
||||
let newdf = Gap.setLogAction df $ appendLogRef df opt logref
|
||||
return (newdf, readAndClearLogRef opt logref)
|
||||
where
|
||||
ls = lineSeparator opt
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
@ -66,27 +65,25 @@ handleErrMsg :: Options -> SourceError -> Ghc String
|
||||
handleErrMsg opt err = do
|
||||
dflag <- G.getSessionDynFlags
|
||||
style <- getStyle
|
||||
let ret = convert opt . errBagToStrList dflag ls style . srcErrorMessages $ err
|
||||
let ret = convert opt . errBagToStrList dflag opt style . srcErrorMessages $ err
|
||||
return ret
|
||||
where
|
||||
ls = lineSeparator opt
|
||||
|
||||
errBagToStrList :: DynFlags -> LineSeparator -> PprStyle -> Bag ErrMsg -> [String]
|
||||
errBagToStrList dflag ls style = map (ppErrMsg dflag ls style) . reverse . bagToList
|
||||
errBagToStrList :: DynFlags -> Options -> PprStyle -> Bag ErrMsg -> [String]
|
||||
errBagToStrList dflag opt style = map (ppErrMsg dflag opt style) . reverse . bagToList
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
ppErrMsg :: DynFlags -> LineSeparator -> PprStyle -> ErrMsg -> String
|
||||
ppErrMsg dflag ls style err = ppMsg spn SevError dflag ls style msg ++ ext
|
||||
ppErrMsg :: DynFlags -> Options -> PprStyle -> ErrMsg -> String
|
||||
ppErrMsg dflag opt style err = ppMsg spn SevError dflag opt style msg ++ ext
|
||||
where
|
||||
spn = Gap.errorMsgSpan err
|
||||
msg = errMsgShortDoc err
|
||||
ext = showMsg dflag ls style (errMsgExtraInfo err)
|
||||
ext = showMsg dflag opt style (errMsgExtraInfo err)
|
||||
|
||||
ppMsg :: SrcSpan -> Severity-> DynFlags -> LineSeparator -> PprStyle -> SDoc -> String
|
||||
ppMsg spn sev dflag ls style msg = prefix ++ cts
|
||||
ppMsg :: SrcSpan -> Severity-> DynFlags -> Options -> PprStyle -> SDoc -> String
|
||||
ppMsg spn sev dflag opt style msg = prefix ++ cts
|
||||
where
|
||||
cts = showMsg dflag ls style msg
|
||||
cts = showMsg dflag opt style msg
|
||||
defaultPrefix
|
||||
| dopt Gap.dumpSplicesFlag dflag = ""
|
||||
| otherwise = "Dummy:0:0:Error:"
|
||||
@ -98,9 +95,7 @@ ppMsg spn sev dflag ls style msg = prefix ++ cts
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
showMsg :: DynFlags -> LineSeparator -> PprStyle -> SDoc -> String
|
||||
showMsg dflag (LineSeparator lsep) style sdoc = replaceNull $ showPage dflag style sdoc
|
||||
showMsg :: DynFlags -> Options -> PprStyle -> SDoc -> String
|
||||
showMsg dflag opt style sdoc = replace '\n' lsep $ showPage dflag style sdoc
|
||||
where
|
||||
replaceNull [] = []
|
||||
replaceNull ('\n':xs) = lsep ++ replaceNull xs
|
||||
replaceNull (x:xs) = x : replaceNull xs
|
||||
LineSeparator lsep = lineSeparator opt
|
||||
|
@ -1,8 +1,8 @@
|
||||
module Language.Haskell.GhcMod.Lint where
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Data.List (intercalate)
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Utils (replace)
|
||||
import Language.Haskell.HLint (hlint)
|
||||
|
||||
-- | Checking syntax of a target file using hlint.
|
||||
@ -10,8 +10,8 @@ import Language.Haskell.HLint (hlint)
|
||||
lintSyntax :: Options
|
||||
-> FilePath -- ^ A target file.
|
||||
-> IO String
|
||||
lintSyntax opt file = pack . map show <$> hlint (file : "--quiet" : hopts)
|
||||
lintSyntax opt file = pack <$> hlint (file : "--quiet" : hopts)
|
||||
where
|
||||
LineSeparator lsep = lineSeparator opt
|
||||
pack = convert opt . map (intercalate lsep . lines)
|
||||
pack = convert opt . map (replace '\n' lsep . init . show)
|
||||
hopts = hlintOpts opt
|
||||
|
@ -2,7 +2,8 @@
|
||||
|
||||
module Language.Haskell.GhcMod.Types where
|
||||
|
||||
import Data.List
|
||||
import Data.List (intercalate)
|
||||
import Language.Haskell.GhcMod.Utils (replace)
|
||||
|
||||
-- | Output style.
|
||||
data OutputStyle = LispStyle -- ^ S expression style.
|
||||
@ -98,11 +99,7 @@ tupToString ((a,b,c,d),s) = show a ++ " "
|
||||
++ quote s -- fixme: quote is not necessary
|
||||
|
||||
quote :: String -> String
|
||||
quote x = "\"" ++ escape x ++ "\""
|
||||
where
|
||||
escape [] = []
|
||||
escape ('"':ys) = '\\':'\"':escape ys
|
||||
escape (y:ys) = y:escape ys
|
||||
quote x = "\"" ++ replace '"' "\\\"" x ++ "\""
|
||||
|
||||
addNewLine :: String -> String
|
||||
addNewLine = (++ "\n")
|
||||
|
@ -3,3 +3,13 @@ module Language.Haskell.GhcMod.Utils where
|
||||
-- dropWhileEnd is not provided prior to base 4.5.0.0.
|
||||
dropWhileEnd :: (a -> Bool) -> [a] -> [a]
|
||||
dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) []
|
||||
|
||||
-- |
|
||||
--
|
||||
-- >>> replace '"' "\\\"" "foo\"bar"
|
||||
-- "foo\\\"bar"
|
||||
replace :: Char -> String -> String -> String
|
||||
replace _ _ [] = []
|
||||
replace c cs (x:xs)
|
||||
| x == c = cs ++ replace c cs xs
|
||||
| otherwise = x : replace c cs xs
|
||||
|
Loading…
Reference in New Issue
Block a user