{-# LANGUAGE NoImplicitPrelude, QuasiQuotes, ViewPatterns #-} module IHaskell.Eval.Lint ( lint ) where import Data.String.Utils (replace, startswith, strip, split) import Prelude (head, tail) import Language.Haskell.HLint as HLint import ClassyPrelude import Control.Monad import Data.List (findIndex) import Text.Printf import Data.String.Here import Data.Char import Data.Monoid import IHaskell.Types import IHaskell.Display import IHaskell.IPython import IHaskell.Eval.Parser hiding (line) data LintSeverity = LintWarning | LintError deriving (Eq, Show) data LintSuggestion = Suggest { line :: LineNumber, chunkNumber :: Int, found :: String, whyNot :: String, severity :: LintSeverity, suggestion :: String } deriving (Eq, Show) -- | Identifier used when one is needed for proper context. lintIdent :: String lintIdent = "lintIdentAEjlkQeh" -- | Given parsed code chunks, perform linting and output a displayable -- report on linting warnings and errors. lint :: [Located CodeBlock] -> IO Display lint blocks = do let validBlocks = map makeValid blocks fileContents = joinBlocks validBlocks -- Get a temporarly location to store this file. ihaskellDir <- getIHaskellDir let filename = ihaskellDir ++ "/.hlintFile.hs" writeFile (fromString filename) fileContents suggestions <- catMaybes <$> map parseSuggestion <$> hlint [filename, "--quiet"] return $ Display $ if null suggestions then [] else [plain $ concatMap plainSuggestion suggestions, html $ htmlSuggestions suggestions] where -- Join together multiple valid file blocks into a single file. -- However, join them with padding so that the line numbers are -- correct. joinBlocks :: [Located String] -> String joinBlocks = unlines . zipWith addPragma [1 .. ] addPragma :: Int -> Located String -> String addPragma i (Located desiredLine str) = linePragma desiredLine i ++ str linePragma = printf "{-# LINE %d \"%d\" #-}\n" plainSuggestion :: LintSuggestion -> String plainSuggestion suggest = printf "Line %d: %s\nFound:\n%s\nWhy not:\n%s" (line suggest) (suggestion suggest) (found suggest) (whyNot suggest) htmlSuggestions :: [LintSuggestion] -> String htmlSuggestions = concatMap toHtml where toHtml :: LintSuggestion -> String toHtml suggest = concat [ named $ suggestion suggest, floating "left" $ style severityClass "Found:" ++ -- Things that look like this get highlighted. styleId "highlight-code" "haskell" (found suggest), floating "left" $ style severityClass "Why Not:" ++ -- Things that look like this get highlighted. styleId "highlight-code" "haskell" (whyNot suggest) ] where severityClass = case severity suggest of LintWarning -> "warning" LintError -> "error" style :: String -> String -> String style cls thing = [i|