From 8983cf2d888ede1da291bf796670814a539e754a Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Mon, 21 Apr 2014 15:58:36 +0900 Subject: [PATCH] lineSeparator are only used in toList/toPlain. --- Language/Haskell/GhcMod/ErrMsg.hs | 35 ++++++------- Language/Haskell/GhcMod/Lint.hs | 4 +- Language/Haskell/GhcMod/Types.hs | 85 +++++++++++++++++-------------- src/GHCModi.hs | 5 +- 4 files changed, 67 insertions(+), 62 deletions(-) diff --git a/Language/Haskell/GhcMod/ErrMsg.hs b/Language/Haskell/GhcMod/ErrMsg.hs index b8de77b..6b2133d 100644 --- a/Language/Haskell/GhcMod/ErrMsg.hs +++ b/Language/Haskell/GhcMod/ErrMsg.hs @@ -17,8 +17,7 @@ import qualified GHC as G 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 Language.Haskell.GhcMod.Types (Options, convert) import Outputable (PprStyle, SDoc) import System.FilePath (normalise) @@ -42,9 +41,9 @@ readAndClearLogRef opt (LogRef ref) = do writeIORef ref id return $! convert opt (b []) -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 +appendLogRef :: DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO () +appendLogRef df (LogRef ref) _ sev src style msg = do + let !l = ppMsg src sev df style msg modifyIORef ref (\b -> b . (l:)) ---------------------------------------------------------------- @@ -55,7 +54,7 @@ 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 opt logref + let newdf = Gap.setLogAction df $ appendLogRef df logref return (newdf, readAndClearLogRef opt logref) ---------------------------------------------------------------- @@ -65,25 +64,25 @@ handleErrMsg :: Options -> SourceError -> Ghc String handleErrMsg opt err = do dflag <- G.getSessionDynFlags style <- getStyle - let ret = convert opt . errBagToStrList dflag opt style . srcErrorMessages $ err + let ret = convert opt . errBagToStrList dflag style . srcErrorMessages $ err return ret -errBagToStrList :: DynFlags -> Options -> PprStyle -> Bag ErrMsg -> [String] -errBagToStrList dflag opt style = map (ppErrMsg dflag opt style) . reverse . bagToList +errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String] +errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList ---------------------------------------------------------------- -ppErrMsg :: DynFlags -> Options -> PprStyle -> ErrMsg -> String -ppErrMsg dflag opt style err = ppMsg spn SevError dflag opt style msg ++ ext +ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String +ppErrMsg dflag style err = ppMsg spn SevError dflag style msg ++ ext where spn = Gap.errorMsgSpan err msg = errMsgShortDoc err - ext = showMsg dflag opt style (errMsgExtraInfo err) + ext = showMsg dflag style (errMsgExtraInfo err) -ppMsg :: SrcSpan -> Severity-> DynFlags -> Options -> PprStyle -> SDoc -> String -ppMsg spn sev dflag opt style msg = prefix ++ cts +ppMsg :: SrcSpan -> Severity-> DynFlags -> PprStyle -> SDoc -> String +ppMsg spn sev dflag style msg = prefix ++ cts where - cts = showMsg dflag opt style msg + cts = showMsg dflag style msg defaultPrefix | dopt Gap.dumpSplicesFlag dflag = "" | otherwise = "Dummy:0:0:Error:" @@ -95,7 +94,5 @@ ppMsg spn sev dflag opt style msg = prefix ++ cts ---------------------------------------------------------------- -showMsg :: DynFlags -> Options -> PprStyle -> SDoc -> String -showMsg dflag opt style sdoc = replace '\n' lsep $ showPage dflag style sdoc - where - LineSeparator lsep = lineSeparator opt +showMsg :: DynFlags -> PprStyle -> SDoc -> String +showMsg dflag style sdoc = showPage dflag style sdoc diff --git a/Language/Haskell/GhcMod/Lint.hs b/Language/Haskell/GhcMod/Lint.hs index 8a86020..c285fb5 100644 --- a/Language/Haskell/GhcMod/Lint.hs +++ b/Language/Haskell/GhcMod/Lint.hs @@ -2,7 +2,6 @@ module Language.Haskell.GhcMod.Lint where import Control.Applicative ((<$>)) import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Utils (replace) import Language.Haskell.HLint (hlint) -- | Checking syntax of a target file using hlint. @@ -12,6 +11,5 @@ lintSyntax :: Options -> IO String lintSyntax opt file = pack <$> hlint (file : "--quiet" : hopts) where - LineSeparator lsep = lineSeparator opt - pack = convert opt . map (replace '\n' lsep . init . show) + pack = convert opt . map (init . show) -- init drops the last \n. hopts = hlintOpts opt diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index bb92d0b..eb18ee4 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -47,62 +47,73 @@ defaultOptions = Options { ---------------------------------------------------------------- convert :: ToString a => Options -> a -> String -convert Options{ outputStyle = LispStyle } = toLisp -convert Options{ outputStyle = PlainStyle } = toPlain + -- fixme: builder +convert opt@Options { outputStyle = LispStyle } x = toLisp opt x ++ "\n" +convert opt@Options { outputStyle = PlainStyle } x = toPlain opt x ++ "\n" class ToString a where - toLisp :: a -> String - toPlain :: a -> String + toLisp :: Options -> a -> String + toPlain :: Options -> a -> String + +lineSep :: Options -> String +lineSep opt = lsep + where + LineSeparator lsep = lineSeparator opt -- | -- --- >>> toLisp "fo\"o" --- "\"fo\\\"o\"\n" --- >>> toPlain "foo" --- "foo\n" +-- >>> toLisp defaultOptions "fo\"o" +-- "\"fo\\\"o\"" +-- >>> toPlain defaultOptions "foo" +-- "foo" instance ToString String where - toLisp = addNewLine . quote - toPlain = addNewLine + toLisp opt = quote opt + toPlain opt = replace '\n' (lineSep opt) -- | -- --- >>> toLisp ["foo", "bar", "ba\"z"] --- "(\"foo\" \"bar\" \"ba\\\"z\")\n" --- >>> toPlain ["foo", "bar", "baz"] --- "foo\nbar\nbaz\n" +-- >>> toLisp defaultOptions ["foo", "bar", "ba\"z"] +-- "(\"foo\" \"bar\" \"ba\\\"z\")" +-- >>> toPlain defaultOptions ["foo", "bar", "baz"] +-- "foo\nbar\nbaz" instance ToString [String] where - toLisp = addNewLine . toSexp True - toPlain = unlines + toLisp opt = toSexp opt True + toPlain opt = intercalate "\n" . map (toPlain opt) -- | -- -- >>> let inp = [((1,2,3,4),"foo"),((5,6,7,8),"bar")] :: [((Int,Int,Int,Int),String)] --- >>> toLisp inp --- "((1 2 3 4 \"foo\") (5 6 7 8 \"bar\"))\n" --- >>> toPlain inp --- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\"\n" +-- >>> toLisp defaultOptions inp +-- "((1 2 3 4 \"foo\") (5 6 7 8 \"bar\"))" +-- >>> toPlain defaultOptions inp +-- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\"" instance ToString [((Int,Int,Int,Int),String)] where - toLisp = addNewLine . toSexp False . map toS + toLisp opt = toSexp opt False . map toS where - toS x = "(" ++ tupToString x ++ ")" - toPlain = unlines . map tupToString + toS x = "(" ++ tupToString opt x ++ ")" + toPlain opt = intercalate "\n" . map (tupToString opt) -toSexp :: Bool -> [String] -> String -toSexp False ss = "(" ++ unwords ss ++ ")" -toSexp True ss = "(" ++ unwords (map quote ss) ++ ")" +toSexp :: Options -> Bool -> [String] -> String +toSexp _ False ss = "(" ++ unwords ss ++ ")" +toSexp opt True ss = "(" ++ unwords (map (quote opt) ss) ++ ")" -tupToString :: ((Int,Int,Int,Int),String) -> String -tupToString ((a,b,c,d),s) = show a ++ " " - ++ show b ++ " " - ++ show c ++ " " - ++ show d ++ " " - ++ quote s -- fixme: quote is not necessary +tupToString :: Options -> ((Int,Int,Int,Int),String) -> String +tupToString opt ((a,b,c,d),s) = show a ++ " " + ++ show b ++ " " + ++ show c ++ " " + ++ show d ++ " " + ++ quote opt s -- fixme: quote is not necessary -quote :: String -> String -quote x = "\"" ++ replace '"' "\\\"" x ++ "\"" - -addNewLine :: String -> String -addNewLine = (++ "\n") +quote :: Options -> String -> String +quote opt str = "\"" ++ quote' str ++ "\"" -- fixme: builder + where + lsep = lineSep opt + quote' [] = [] + quote' (x:xs) + | x == '\n' = lsep ++ quote' xs + | x == '\\' = "\\\\" ++ quote' xs + | x == '"' = "\\\"" ++ quote' xs + | otherwise = x : quote' xs ---------------------------------------------------------------- diff --git a/src/GHCModi.hs b/src/GHCModi.hs index 21d8074..d770e95 100644 --- a/src/GHCModi.hs +++ b/src/GHCModi.hs @@ -180,12 +180,11 @@ checkStx opt set file readLog = do mdel <- removeMainTarget when add $ addTargetFiles [file] void $ G.load LoadAllTargets - msgs <- liftIO readLog + ret <- liftIO readLog let set1 = if add then S.insert file set else set set2 = case mdel of Nothing -> set1 Just delfl -> S.delete delfl set1 - let ret = convert opt msgs return (ret, True, set2) where handler :: SourceError -> Ghc (String, Bool, Set FilePath) @@ -213,7 +212,7 @@ findSym :: Options -> Set FilePath -> String -> MVar DB -> Ghc (String, Bool, Set FilePath) findSym opt set sym mvar = do db <- liftIO $ readMVar mvar - let ret = convert opt $ fromMaybe [] (M.lookup sym db) + let ret = convert opt $ fromMaybe [] (M.lookup sym db) -- fixme return (ret, True, set) lintStx :: Options -> Set FilePath -> FilePath