refactoring for lineSeparator.

This commit is contained in:
Kazu Yamamoto 2014-04-21 14:58:25 +09:00
parent b2c2d1a443
commit 3d03cff06b
4 changed files with 33 additions and 31 deletions

View File

@ -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

View File

@ -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

View File

@ -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")

View File

@ -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