module IDE.HLint (
hlintSettings
, scheduleHLint
, packageHLint
, resolveActiveHLint
) where
import Control.Applicative
import Prelude hiding(getChar, getLine)
import IDE.Core.Types
(logRefFullFilePath, Prefs(..), LogRef(..), LogRefType(..),
wsAllPackages, ipdBuildDir, IDEM, IDEAction, IDE(..),
IDEPackage(..), PackageAction)
import Control.Monad.Reader (asks, MonadReader(..))
import IDE.Core.State
(postSyncIDE, catchIDE, MessageLevel(..), ideMessage,
leksahSubDir, reflectIDE, modifyIDE_, readIDE)
import Control.Concurrent.STM.TVar
(newTVarIO, writeTVar, readTVar)
import Control.Concurrent (forkIO)
import Control.Monad
(void, when, foldM, forM_, forM, unless, forever)
import Control.Monad.STM (retry, atomically)
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.IO.Class (MonadIO(..))
import Language.Haskell.HLint3
(Note(..), Idea(..), Severity(..), applyHints, ParseError(..),
parseModuleEx, CppFlags(..), defaultParseFlags,
parseFlagsAddFixities, resolveHints, readSettingsFile,
findSettings, Hint(..), Classify(..), ParseFlags(..))
import System.FilePath.Windows (makeRelative, equalFilePath, (</>))
import System.Directory (doesFileExist)
import qualified System.IO.Strict as S (readFile)
import Language.Preprocessor.Cpphs
(defaultCpphsOptions, runCpphsReturningSymTab, CpphsOptions(..))
import System.Log.Logger (debugM)
import Data.Monoid ((<>))
import Data.List (sortBy, intercalate, find)
import qualified Data.Map as M (keys, lookup)
import qualified Data.Text as T
(replicate, init, unlines, reverse, take, drop, lines, unpack,
pack)
import Control.Exception (SomeException(..))
import Data.Maybe (isJust, mapMaybe, catMaybes)
import Distribution.Package (PackageIdentifier(..))
import Distribution.ModuleName (ModuleName)
import IDE.Core.CTypes
(SrcSpan(..), mdMbSourcePath, pdModules, mdModuleId, modu,
PackScope(..), GenScope(..), GenScope)
import IDE.Metainfo.Provider (getWorkspaceInfo)
import qualified Language.Haskell.Exts.SrcLoc as HSE
(SrcLoc(..), SrcSpan(..))
import IDE.Pane.SourceBuffer
(useCandyFor, selectSourceBuf, fileSave, inActiveBufContext,
addLogRef, belongsToPackage, removeLintLogRefs)
import qualified Data.Text.IO as T (readFile)
import Data.Text (Text)
import IDE.TextEditor (TextEditor(..))
import IDE.SourceCandy
(getCandylessPart, positionToCandy, stringToCandy)
import IDE.BufferMode (IDEBuffer(..), editInsertCode)
import Data.Ord (comparing)
import qualified Data.Foldable as F (toList)
packageHLint :: PackageAction
packageHLint = asks ipdCabalFile >>= (lift . lift . scheduleHLint . Left)
scheduleHLint :: Either FilePath FilePath -> IDEAction
scheduleHLint what = do
liftIO $ debugM "leksah" "scheduleHLint"
mbQueue <- readIDE hlintQueue
queue <- case mbQueue of
Nothing -> do
ideR <- ask
queue <- liftIO $ newTVarIO []
modifyIDE_ $ \ide -> ide { hlintQueue = Just queue }
liftIO . forkIO . forever $ do
x <- atomically $ do
schedule <- readTVar queue
case schedule of
(x:xs) -> do
writeTVar queue xs
return x
[] -> retry
reflectIDE (runHLint x) ideR
return queue
Just queue -> return queue
liftIO . atomically $ do
scheduled <- readTVar queue
unless (what `elem` scheduled) $
writeTVar queue $ scheduled ++ [what]
runHLint :: Either FilePath FilePath -> IDEAction
runHLint (Right sourceFile) = do
liftIO . debugM "leksah" $ "runHLint"
packages <- maybe [] wsAllPackages <$> readIDE workspace
case sortBy (flip (comparing (length . ipdBuildDir))) $ filter (belongsToPackage sourceFile) packages of
(package:_) -> runHLint' package (Just sourceFile)
_ -> liftIO . debugM "leksah" $ "runHLint package not found for " <> sourceFile
runHLint (Left cabalFile) = do
liftIO . debugM "leksah" $ "runHLint"
packages <- maybe [] wsAllPackages <$> readIDE workspace
case find ((== cabalFile) . ipdCabalFile) packages of
Just package -> runHLint' package Nothing
_ -> liftIO . debugM "leksah" $ "runHLint package not found for " <> cabalFile
runHLint' :: IDEPackage -> Maybe FilePath -> IDEAction
runHLint' package mbSourceFile = do
liftIO . debugM "leksah" $ "runHLint'"
ideR <- ask
(flags, classify, hint) <- hlintSettings package
let modules = M.keys (ipdModules package)
paths <- case mbSourceFile of
Just f -> return [f]
Nothing -> getSourcePaths (ipdPackageId package) modules
res <- forM paths $ \ full -> do
let file = makeRelative (ipdBuildDir package) full
postSyncIDE $ removeLintLogRefs (ipdBuildDir package) file
text <- liftIO $ T.readFile full
liftIO . debugM "leksah" $ "runHLint parsing " <> full
do result <- liftIO $ parseModuleEx flags full (Just (T.unpack text))
case result of
Left e -> logHLintError (isJust mbSourceFile) package e >> return Nothing
Right r -> do
liftIO . debugM "leksah" $ "runHLint parsed " <> full
return $ Just (r, (full, text))
`catchIDE` (\(e :: SomeException) -> do
reflectIDE (ideMessage Normal . T.pack $ "HLint Exception : " <> show e) ideR
return Nothing)
liftIO $ debugM "leksah" "runHLint parse complete"
let results = catMaybes res
ideas = map fst results
texts = map snd results
getText f = maybe "" snd $ find (equalFilePath f . fst) texts
logHLintResult (isJust mbSourceFile) package (applyHints classify hint ideas) getText
getSourcePaths :: PackageIdentifier -> [ModuleName] -> IDEM [FilePath]
getSourcePaths packId names = do
mbWorkspaceInfo <- getWorkspaceInfo
case mbWorkspaceInfo of
Nothing -> return []
Just (sc, _) -> return (mapMaybe (sourcePathFromScope sc) names)
where
sourcePathFromScope :: GenScope -> ModuleName -> Maybe FilePath
sourcePathFromScope (GenScopeC (PackScope l _)) mn =
case packId `M.lookup` l of
Just pack ->
case filter (\md -> modu (mdModuleId md) == mn)
(pdModules pack) of
(mod : tl) -> mdMbSourcePath mod
[] -> Nothing
Nothing -> Nothing
hlintSettings :: IDEPackage -> IDEM (ParseFlags, [Classify], Hint)
hlintSettings package = do
mbHlintDir <- liftIO $ leksahSubDir "hlint"
let cabalMacros = ipdBuildDir package </> "dist/build/autogen/cabal_macros.h"
cabalMacrosExist <- liftIO $ doesFileExist cabalMacros
defines <- liftIO $ if cabalMacrosExist
then do
raw <- S.readFile cabalMacros
map (\(a, b) -> (a, concat (lines b))) . snd <$> runCpphsReturningSymTab defaultCpphsOptions cabalMacros raw
else return []
(fixities, classify, hints) <- liftIO $ findSettings (readSettingsFile mbHlintDir) Nothing
let hint = resolveHints hints
flags = parseFlagsAddFixities fixities defaultParseFlags{ cppFlags = Cpphs defaultCpphsOptions
{ defines = defines } }
liftIO . debugM "leksah" $ "hlintSettings defines = " <> show defines
return (flags, classify, hint)
logHLintResult :: Bool -> IDEPackage -> [Idea] -> (FilePath -> Text) -> IDEAction
logHLintResult fileScope package allIdeas getText = do
let ideas = filter (\Idea{..} -> ideaSeverity /= Ignore) allIdeas
forM_ ideas $ \ idea@Idea{..} -> do
let text = getText (HSE.srcSpanFilename ideaSpan)
fixColumn c = max 0 (c 1)
srcSpan = SrcSpan (makeRelative (ipdBuildDir package) $ HSE.srcSpanFilename ideaSpan)
(HSE.srcSpanStartLine ideaSpan)
(HSE.srcSpanStartColumn ideaSpan 1)
(HSE.srcSpanEndLine ideaSpan)
(HSE.srcSpanEndColumn ideaSpan 1)
fromLines = drop (HSE.srcSpanStartLine ideaSpan 1)
. take (HSE.srcSpanEndLine ideaSpan) $ T.lines text
fixHead [] = []
fixHead (x:xs) = T.drop (HSE.srcSpanStartColumn ideaSpan 1) x : xs
fixTail [] = []
fixTail (x:xs) = T.take (HSE.srcSpanEndColumn ideaSpan 1) x : xs
from = T.reverse . T.drop 1 . T.reverse
. T.unlines . fixHead . reverse . fixTail $ reverse fromLines
ref = LogRef srcSpan package (T.pack $ showHLint idea)
(Just (from, idea)) Nothing LintRef
postSyncIDE $ addLogRef fileScope fileScope ref
return ()
logHLintError :: Bool -> IDEPackage -> ParseError -> IDEAction
logHLintError fileScope package error = do
let loc = parseErrorLocation error
srcSpan = SrcSpan (makeRelative (ipdBuildDir package) $ HSE.srcFilename loc)
(HSE.srcLine loc)
(HSE.srcColumn loc 1)
(HSE.srcLine loc)
(HSE.srcColumn loc 1)
ref = LogRef srcSpan package ("Hlint Parse Error: " <> T.pack (parseErrorMessage error)) Nothing Nothing LintRef
postSyncIDE $ addLogRef fileScope fileScope ref
showHLint :: Idea -> String
showHLint Idea{..} = intercalate "\n" $
[if ideaHint == "" then "" else show ideaSeverity ++ ": " ++ ideaHint] ++
f "Found" (if ideaHint == "Reduce duplication" then Just ideaFrom else Nothing) ++
f "Why not" ideaTo ++
["Note: " ++ n | let n = showNotes ideaNote, n /= ""]
where
f msg Nothing = []
f msg (Just x) | null x = [msg ++ " remove it."]
| otherwise = (msg ++ ":") : map (" "++) (lines x)
showNotes :: [Note] -> String
showNotes = intercalate ", " . map show . filter use
where use ValidInstance{} = False
use _ = True
resolveActiveHLint :: IDEM Bool
resolveActiveHLint = inActiveBufContext False $ \_ _ ebuf ideBuf _ -> do
liftIO $ debugM "leksah" "resolveActiveHLint"
allLogRefs <- readIDE allLogRefs
(iStart, iEnd) <- getSelectionBounds ebuf
lStart <- getLine iStart
cStart <- getLineOffset iStart
lEnd <- getLine iEnd
cEnd <- getLineOffset iEnd
let fn = fileName ideBuf
let selectedRefs = [ref | ref@LogRef{..} <- F.toList allLogRefs,
logRefType == LintRef
&& fn == Just (logRefFullFilePath ref)
&& maybe "" (ideaHint . snd) logRefIdea /= "Reduce duplication"
&& (lStart+1, cStart) <= (srcSpanEndLine logRefSrcSpan,
srcSpanEndColumn logRefSrcSpan)
&& (lEnd+1, cEnd) >= (srcSpanStartLine logRefSrcSpan,
srcSpanStartColumn logRefSrcSpan)]
safeRefs = takeWhileNotOverlapping selectedRefs
(changed, _) <- foldM replaceHLintSource (False, 0) . catMaybes $ map logRefIdea safeRefs
prefs <- readIDE prefs
when changed $ if backgroundBuild prefs
then setModified ebuf True
else void $ fileSave False
return changed
where
takeWhileNotOverlapping = takeWhileNotOverlapping' (1)
takeWhileNotOverlapping' _ [] = []
takeWhileNotOverlapping' line (ref:refs)
| srcSpanEndLine (logRefSrcSpan ref) > line = ref : takeWhileNotOverlapping' (srcSpanEndLine $ logRefSrcSpan ref) refs
| otherwise = takeWhileNotOverlapping' line refs
indentHLintText :: Int -> Text -> Text
indentHLintText startColumn text =
T.init $ T.unlines (take 1 lines <> drop 1 (map (indent <>) lines))
where
lines = T.lines text
indent = T.replicate startColumn " "
replaceHLintSource :: (Bool, Int) -> (Text, Idea) -> IDEM (Bool, Int)
replaceHLintSource (changed, delta) (from, Idea{ideaSpan = ideaSpan, ideaTo = Just ideaTo}) = do
let HSE.SrcSpan{..} = ideaSpan
to = indentHLintText (srcSpanStartColumn1) (T.pack ideaTo)
liftIO . debugM "leksah" $ "replaceHLintSource From: " <> show from <> "\nreplaceHLintSource To: " <> show to
mbBuf <- selectSourceBuf srcSpanFilename
case mbBuf of
Just buf -> inActiveBufContext (changed, delta) $ \_ sv ebuf _ _ -> do
useCandy <- useCandyFor buf
candy' <- readIDE candy
realString <- if useCandy then stringToCandy candy' to else return to
(lineS', columnS', lineE', columnE') <- if useCandy
then do
(_,e1) <- positionToCandy candy' ebuf (srcSpanStartLine + delta, srcSpanStartColumn 1)
(_,e2) <- positionToCandy candy' ebuf (srcSpanEndLine + delta, srcSpanEndColumn 1)
return (srcSpanStartLine1 + delta,e1,srcSpanEndLine1 + delta,e2)
else return (srcSpanStartLine1 + delta,srcSpanStartColumn1,srcSpanEndLine1 + delta,srcSpanEndColumn1)
i1 <- getIterAtLine ebuf lineS'
i1' <- forwardCharsC i1 columnS'
i2 <- getIterAtLine ebuf lineE'
i2' <- forwardCharsC i2 columnE'
candy <- readIDE candy
check <- getCandylessPart candy ebuf i1' i2'
if check == from
then do
beginUserAction ebuf
delete ebuf i1' i2'
editInsertCode ebuf i1' realString
endUserAction ebuf
return (True, delta + length (T.lines to) length (T.lines from))
else return (changed, delta)
_ -> return (changed, delta)
replaceHLintSource x _ = return x