HLint.hs

{-# LANGUAGE CPP #-}

module HsDev.Tools.HLint (
	hlint,
	hlintSupported,

	module Control.Monad.Except
	) where

import Control.Monad.Except
import Data.Text (Text)

import HsDev.Tools.Base

#ifndef NOHLINT
import Control.Arrow
import Control.Lens (over, view, _Just)
import Data.Char
import Data.List
import Data.Maybe (mapMaybe)
import qualified Data.Text as T
import Data.Ord
import Data.String (fromString)
import Language.Haskell.Exts.SrcLoc
import Language.Haskell.HLint3 (argsSettings, parseModuleEx, applyHints, Idea(..), parseErrorMessage, ParseFlags(..), CppFlags(..))
import qualified Language.Haskell.HLint3 as HL (Severity(..))

import System.Directory.Paths
import HsDev.Symbols.Location
import HsDev.Util (readFileUtf8)
#endif

hlint :: [String] -> FilePath -> Maybe Text -> ExceptT String IO [Note OutputMessage]
#ifndef NOHLINT
hlint opts file msrc = do
	file' <- liftIO $ canonicalize file
	cts <- maybe (liftIO $ readFileUtf8 file') return msrc
	(flags, classify, hint) <- liftIO $ argsSettings opts
	p <- liftIO $ parseModuleEx (flags { cppFlags = CppSimple }) file' (Just $ T.unpack cts)
	m <- either (throwError . parseErrorMessage) return p
	return $ map (recalcTabs cts 8 . indentIdea cts . fromIdea) $
		filter (not . ignoreIdea) $
		applyHints classify hint [m]
#else
hlint _ _ _ = throwError "Compiled with no hlint support"
#endif

#ifndef NOHLINT
ignoreIdea :: Idea -> Bool
ignoreIdea idea = ideaSeverity idea == HL.Ignore

fromIdea :: Idea -> Note OutputMessage
fromIdea idea = Note {
	_noteSource = FileModule (fromFilePath $ srcSpanFilename src) Nothing,
	_noteRegion = Region (Position (srcSpanStartLine src) (srcSpanStartColumn src)) (Position (srcSpanEndLine src) (srcSpanEndColumn src)),
	_noteLevel = Just $ case ideaSeverity idea of
		HL.Warning -> Warning
		HL.Error -> Error
		_ -> Hint,
	_note = OutputMessage {
		_message = fromString $ ideaHint idea,
		_messageSuggestion = fmap fromString $ ideaTo idea } }
	where
		src = ideaSpan idea

indentIdea :: Text -> Note OutputMessage -> Note OutputMessage
indentIdea cts idea = case analyzeIndent cts of
	Nothing -> idea
	Just i -> over (note . messageSuggestion . _Just) (indent' i) idea
	where
		indent' i' = T.intercalate (fromString "\n") . indentTail . map (uncurry T.append . first ((`T.replicate` i') . (`div` 2) . T.length) . T.span isSpace) . T.split (== '\n')
		indentTail [] = []
		indentTail (h : hs) = h : map (firstIndent `T.append`) hs
		firstIndent = T.takeWhile isSpace firstLine
		firstLine = regionStr (Position firstLineNum 1 `region` Position (succ firstLineNum) 1) cts
		firstLineNum = view (noteRegion . regionFrom . positionLine) idea

-- | Indent in source
data Indent = Spaces Int | Tabs deriving (Eq, Ord)

instance Show Indent where
	show (Spaces n) = replicate n ' '
	show Tabs = "\t"

-- | Analyze source indentation to convert suggestion to same indentation
-- Returns one indent
analyzeIndent :: Text -> Maybe Text
analyzeIndent =
	fmap (fromString . show) . selectIndent . map fst . dropUnusual .
	sortBy (comparing $ negate . snd) .
	map (head &&& length) .
	group . sort .
	mapMaybe (guessIndent . T.takeWhile isSpace) . T.lines
	where
		selectIndent :: [Indent] -> Maybe Indent
		selectIndent [] = Nothing
		selectIndent (Tabs : _) = Just Tabs
		selectIndent indents = Just $ Spaces $ foldr1 gcd $ mapMaybe spaces indents where
			spaces :: Indent -> Maybe Int
			spaces Tabs = Nothing
			spaces (Spaces n) = Just n
		dropUnusual :: [(Indent, Int)] -> [(Indent, Int)]
		dropUnusual [] = []
		dropUnusual is@((_, freq):_) = takeWhile ((> freq `div` 5) . snd) is

-- | Guess indent of one line
guessIndent :: Text -> Maybe Indent
guessIndent s
	| T.all (== ' ') s = Just $ Spaces $ T.length s
	| T.all (== '\t') s = Just Tabs
	| otherwise = Nothing
#endif

hlintSupported :: Bool
#ifndef NOHLINT
hlintSupported = True
#else
hlintSupported = False
#endif