hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

lineSeparator are only used in toList/toPlain.

Browse Source
This commit is contained in:
Kazu Yamamoto 2014-04-21 15:58:36 +09:00
parent 3d03cff06b
commit 8983cf2d88
4 changed files with 67 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
Language/Haskell/GhcMod/ErrMsg.hs
View File

@ -17,8 +17,7 @@ import qualified GHC as G
import HscTypes (SourceError, srcErrorMessages) import HscTypes (SourceError, srcErrorMessages)
import Language.Haskell.GhcMod.Doc (showPage, getStyle) import Language.Haskell.GhcMod.Doc (showPage, getStyle)
import qualified Language.Haskell.GhcMod.Gap as Gap import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Types (LineSeparator(..), Options(..), convert) import Language.Haskell.GhcMod.Types (Options, convert)
import Language.Haskell.GhcMod.Utils (replace)
import Outputable (PprStyle, SDoc) import Outputable (PprStyle, SDoc)
import System.FilePath (normalise) import System.FilePath (normalise)
@ -42,9 +41,9 @@ readAndClearLogRef opt (LogRef ref) = do
writeIORef ref id writeIORef ref id
return $! convert opt (b []) return $! convert opt (b [])
appendLogRef :: DynFlags -> Options -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO () appendLogRef :: DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
appendLogRef df opt (LogRef ref) _ sev src style msg = do appendLogRef df (LogRef ref) _ sev src style msg = do
let !l = ppMsg src sev df opt style msg let !l = ppMsg src sev df style msg
modifyIORef ref (\b -> b . (l:)) modifyIORef ref (\b -> b . (l:))
---------------------------------------------------------------- ----------------------------------------------------------------
@ -55,7 +54,7 @@ setLogger False df _ = return (newdf, undefined)
newdf = Gap.setLogAction df $ \_ _ _ _ _ -> return () newdf = Gap.setLogAction df $ \_ _ _ _ _ -> return ()
setLogger True df opt = do setLogger True df opt = do
logref <- newLogRef logref <- newLogRef
let newdf = Gap.setLogAction df $ appendLogRef df opt logref let newdf = Gap.setLogAction df $ appendLogRef df logref
return (newdf, readAndClearLogRef opt logref) return (newdf, readAndClearLogRef opt logref)
---------------------------------------------------------------- ----------------------------------------------------------------
@ -65,25 +64,25 @@ handleErrMsg :: Options -> SourceError -> Ghc String
handleErrMsg opt err = do handleErrMsg opt err = do
dflag <- G.getSessionDynFlags dflag <- G.getSessionDynFlags
style <- getStyle style <- getStyle
let ret = convert opt . errBagToStrList dflag opt style . srcErrorMessages $ err let ret = convert opt . errBagToStrList dflag style . srcErrorMessages $ err
return ret return ret
errBagToStrList :: DynFlags -> Options -> PprStyle -> Bag ErrMsg -> [String] errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String]
errBagToStrList dflag opt style = map (ppErrMsg dflag opt style) . reverse . bagToList errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList
---------------------------------------------------------------- ----------------------------------------------------------------
ppErrMsg :: DynFlags -> Options -> PprStyle -> ErrMsg -> String ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String
ppErrMsg dflag opt style err = ppMsg spn SevError dflag opt style msg ++ ext ppErrMsg dflag style err = ppMsg spn SevError dflag style msg ++ ext
where where
spn = Gap.errorMsgSpan err spn = Gap.errorMsgSpan err
msg = errMsgShortDoc 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 :: SrcSpan -> Severity-> DynFlags -> PprStyle -> SDoc -> String
ppMsg spn sev dflag opt style msg = prefix ++ cts ppMsg spn sev dflag style msg = prefix ++ cts
where where
cts = showMsg dflag opt style msg cts = showMsg dflag style msg
defaultPrefix defaultPrefix
| dopt Gap.dumpSplicesFlag dflag = "" | dopt Gap.dumpSplicesFlag dflag = ""
| otherwise = "Dummy:0:0:Error:" | 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 :: DynFlags -> PprStyle -> SDoc -> String
showMsg dflag opt style sdoc = replace '\n' lsep $ showPage dflag style sdoc showMsg dflag style sdoc = showPage dflag style sdoc
where
LineSeparator lsep = lineSeparator opt

4
Language/Haskell/GhcMod/Lint.hs
View File

@ -2,7 +2,6 @@ module Language.Haskell.GhcMod.Lint where
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils (replace)
import Language.Haskell.HLint (hlint) import Language.Haskell.HLint (hlint)
-- | Checking syntax of a target file using hlint. -- | Checking syntax of a target file using hlint.
@ -12,6 +11,5 @@ lintSyntax :: Options
-> IO String -> IO String
lintSyntax opt file = pack <$> hlint (file : "--quiet" : hopts) lintSyntax opt file = pack <$> hlint (file : "--quiet" : hopts)
where where
LineSeparator lsep = lineSeparator opt pack = convert opt . map (init . show) -- init drops the last \n.
pack = convert opt . map (replace '\n' lsep . init . show)
hopts = hlintOpts opt hopts = hlintOpts opt

85
Language/Haskell/GhcMod/Types.hs
View File

@ -47,62 +47,73 @@ defaultOptions = Options {
---------------------------------------------------------------- ----------------------------------------------------------------
convert :: ToString a => Options -> a -> String convert :: ToString a => Options -> a -> String
convert Options{ outputStyle = LispStyle } = toLisp -- fixme: builder
convert Options{ outputStyle = PlainStyle } = toPlain convert opt@Options { outputStyle = LispStyle } x = toLisp opt x ++ "\n"
convert opt@Options { outputStyle = PlainStyle } x = toPlain opt x ++ "\n"
class ToString a where class ToString a where
toLisp :: a -> String toLisp :: Options -> a -> String
toPlain :: a -> String toPlain :: Options -> a -> String
lineSep :: Options -> String
lineSep opt = lsep
where
LineSeparator lsep = lineSeparator opt
-- | -- |
-- --
-- >>> toLisp "fo\"o" -- >>> toLisp defaultOptions "fo\"o"
-- "\"fo\\\"o\"\n" -- "\"fo\\\"o\""
-- >>> toPlain "foo" -- >>> toPlain defaultOptions "foo"
-- "foo\n" -- "foo"
instance ToString String where instance ToString String where
toLisp = addNewLine . quote toLisp opt = quote opt
toPlain = addNewLine toPlain opt = replace '\n' (lineSep opt)
-- | -- |
-- --
-- >>> toLisp ["foo", "bar", "ba\"z"] -- >>> toLisp defaultOptions ["foo", "bar", "ba\"z"]
-- "(\"foo\" \"bar\" \"ba\\\"z\")\n" -- "(\"foo\" \"bar\" \"ba\\\"z\")"
-- >>> toPlain ["foo", "bar", "baz"] -- >>> toPlain defaultOptions ["foo", "bar", "baz"]
-- "foo\nbar\nbaz\n" -- "foo\nbar\nbaz"
instance ToString [String] where instance ToString [String] where
toLisp = addNewLine . toSexp True toLisp opt = toSexp opt True
toPlain = unlines toPlain opt = intercalate "\n" . map (toPlain opt)
-- | -- |
-- --
-- >>> let inp = [((1,2,3,4),"foo"),((5,6,7,8),"bar")] :: [((Int,Int,Int,Int),String)] -- >>> let inp = [((1,2,3,4),"foo"),((5,6,7,8),"bar")] :: [((Int,Int,Int,Int),String)]
-- >>> toLisp inp -- >>> toLisp defaultOptions inp
-- "((1 2 3 4 \"foo\") (5 6 7 8 \"bar\"))\n" -- "((1 2 3 4 \"foo\") (5 6 7 8 \"bar\"))"
-- >>> toPlain inp -- >>> toPlain defaultOptions inp
-- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\"\n" -- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\""
instance ToString [((Int,Int,Int,Int),String)] where instance ToString [((Int,Int,Int,Int),String)] where
toLisp = addNewLine . toSexp False . map toS toLisp opt = toSexp opt False . map toS
where where
toS x = "(" ++ tupToString x ++ ")" toS x = "(" ++ tupToString opt x ++ ")"
toPlain = unlines . map tupToString toPlain opt = intercalate "\n" . map (tupToString opt)
toSexp :: Bool -> [String] -> String toSexp :: Options -> Bool -> [String] -> String
toSexp False ss = "(" ++ unwords ss ++ ")" toSexp _ False ss = "(" ++ unwords ss ++ ")"
toSexp True ss = "(" ++ unwords (map quote ss) ++ ")" toSexp opt True ss = "(" ++ unwords (map (quote opt) ss) ++ ")"
tupToString :: ((Int,Int,Int,Int),String) -> String tupToString :: Options -> ((Int,Int,Int,Int),String) -> String
tupToString ((a,b,c,d),s) = show a ++ " " tupToString opt ((a,b,c,d),s) = show a ++ " "
++ show b ++ " " ++ show b ++ " "
++ show c ++ " " ++ show c ++ " "
++ show d ++ " " ++ show d ++ " "
++ quote s -- fixme: quote is not necessary ++ quote opt s -- fixme: quote is not necessary
quote :: String -> String quote :: Options -> String -> String
quote x = "\"" ++ replace '"' "\\\"" x ++ "\"" quote opt str = "\"" ++ quote' str ++ "\"" -- fixme: builder
where
addNewLine :: String -> String lsep = lineSep opt
addNewLine = (++ "\n") quote' [] = []
quote' (x:xs)
| x == '\n' = lsep ++ quote' xs
| x == '\\' = "\\\\" ++ quote' xs
| x == '"' = "\\\"" ++ quote' xs
| otherwise = x : quote' xs
---------------------------------------------------------------- ----------------------------------------------------------------

5
src/GHCModi.hs
View File

@ -180,12 +180,11 @@ checkStx opt set file readLog = do
mdel <- removeMainTarget mdel <- removeMainTarget
when add $ addTargetFiles [file] when add $ addTargetFiles [file]
void $ G.load LoadAllTargets void $ G.load LoadAllTargets
msgs <- liftIO readLog ret <- liftIO readLog
let set1 = if add then S.insert file set else set let set1 = if add then S.insert file set else set
set2 = case mdel of set2 = case mdel of
Nothing -> set1 Nothing -> set1
Just delfl -> S.delete delfl set1 Just delfl -> S.delete delfl set1
let ret = convert opt msgs
return (ret, True, set2) return (ret, True, set2)
where where
handler :: SourceError -> Ghc (String, Bool, Set FilePath) handler :: SourceError -> Ghc (String, Bool, Set FilePath)
@ -213,7 +212,7 @@ findSym :: Options -> Set FilePath -> String -> MVar DB
-> Ghc (String, Bool, Set FilePath) -> Ghc (String, Bool, Set FilePath)
findSym opt set sym mvar = do findSym opt set sym mvar = do
db <- liftIO $ readMVar mvar 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) return (ret, True, set)
lintStx :: Options -> Set FilePath -> FilePath lintStx :: Options -> Set FilePath -> FilePath