From 3d03cff06b20ae511b96542b7a887f8ec0c2f0aa Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Mon, 21 Apr 2014 14:58:25 +0900 Subject: [PATCH] refactoring for lineSeparator. --- Language/Haskell/GhcMod/ErrMsg.hs | 39 ++++++++++++++----------------- Language/Haskell/GhcMod/Lint.hs | 6 ++--- Language/Haskell/GhcMod/Types.hs | 9 +++---- Language/Haskell/GhcMod/Utils.hs | 10 ++++++++ 4 files changed, 33 insertions(+), 31 deletions(-) diff --git a/Language/Haskell/GhcMod/ErrMsg.hs b/Language/Haskell/GhcMod/ErrMsg.hs index 50c9f69..b8de77b 100644 --- a/Language/Haskell/GhcMod/ErrMsg.hs +++ b/Language/Haskell/GhcMod/ErrMsg.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Lint.hs b/Language/Haskell/GhcMod/Lint.hs index 6336844..8a86020 100644 --- a/Language/Haskell/GhcMod/Lint.hs +++ b/Language/Haskell/GhcMod/Lint.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 3e99e78..bb92d0b 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -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") diff --git a/Language/Haskell/GhcMod/Utils.hs b/Language/Haskell/GhcMod/Utils.hs index 33af425..3beb981 100644 --- a/Language/Haskell/GhcMod/Utils.hs +++ b/Language/Haskell/GhcMod/Utils.hs @@ -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