lineSeparator are only used in toList/toPlain.
This commit is contained in:
Kazu Yamamoto
parent
3d03cff06b
commit
8983cf2d88
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue