module IHaskell.Eval.Lint (
lint
) where
import Data.String.Utils (replace, startswith, strip, split)
import Prelude (head, tail, last)
import ClassyPrelude hiding (last)
import Control.Monad
import Data.List (findIndex)
import Text.Printf
import Data.String.Here
import Data.Char
import Data.Monoid
import Data.Maybe (mapMaybe)
import System.IO.Unsafe (unsafePerformIO)
import Language.Haskell.Exts.Annotated.Syntax hiding (Module)
import qualified Language.Haskell.Exts.Annotated.Syntax as SrcExts
import Language.Haskell.Exts.Annotated (parseFileContentsWithMode)
import Language.Haskell.Exts.Annotated.Build (doE)
import Language.Haskell.Exts.Annotated hiding (Module)
import Language.Haskell.Exts.SrcLoc
import Language.Haskell.HLint as HLint
import Language.Haskell.HLint2
import IHaskell.Types
import IHaskell.Display
import IHaskell.IPython
import IHaskell.Eval.Parser hiding (line)
type ExtsModule = SrcExts.Module SrcSpanInfo
data LintSuggestion
= Suggest {
line :: LineNumber,
found :: String,
whyNot :: String,
severity :: Severity,
suggestion :: String
}
deriving (Eq, Show)
hlintSettings :: MVar (ParseFlags, [Classify], Hint)
hlintSettings = unsafePerformIO newEmptyMVar
lintIdent :: String
lintIdent = "lintIdentAEjlkQeh"
lint :: [Located CodeBlock] -> IO Display
lint blocks = do
initialized <- not <$> isEmptyMVar hlintSettings
unless initialized $
autoSettings >>= putMVar hlintSettings
(flags, classify, hint) <- readMVar hlintSettings
let mode = hseFlags flags
let modules = mapMaybe (createModule mode) blocks
ideas = applyHints classify hint (map (\m->(m,[])) modules)
suggestions = mapMaybe showIdea ideas
return $ Display $
if null suggestions
then []
else
[plain $ concatMap plainSuggestion suggestions,
html $ htmlSuggestions suggestions]
showIdea :: Idea -> Maybe LintSuggestion
showIdea idea =
case ideaTo idea of
Nothing -> Nothing
Just whyNot -> Just Suggest {
line = srcSpanStartLine $ ideaSpan idea,
found = showSuggestion $ ideaFrom idea,
whyNot = showSuggestion whyNot,
severity = ideaSeverity idea,
suggestion = ideaHint idea
}
createModule :: ParseMode -> Located CodeBlock -> Maybe ExtsModule
createModule mode (Located line block) =
case block of
Expression expr -> unparse $ exprToModule expr
Declaration decl -> unparse $ declToModule decl
Statement stmt -> unparse $ stmtToModule stmt
Import impt -> unparse $ imptToModule impt
Module mod -> unparse $ parseModule mod
_ -> Nothing
where
blockStr =
case block of
Expression expr -> expr
Declaration decl -> decl
Statement stmt -> stmt
Import impt -> impt
Module mod -> mod
unparse :: ParseResult a -> Maybe a
unparse (ParseOk a) = Just a
unparse _ = Nothing
srcSpan :: SrcSpan
srcSpan = SrcSpan {
srcSpanFilename = "<interactive>",
srcSpanStartLine = line,
srcSpanStartColumn = 0,
srcSpanEndLine = line + length (lines blockStr),
srcSpanEndColumn = length $ last $ lines blockStr
}
loc :: SrcSpanInfo
loc = SrcSpanInfo srcSpan []
moduleWithDecls :: Decl SrcSpanInfo -> ExtsModule
moduleWithDecls decl = SrcExts.Module loc Nothing [] [] [decl]
parseModule :: String -> ParseResult ExtsModule
parseModule = parseFileContentsWithMode mode
declToModule :: String -> ParseResult ExtsModule
declToModule decl = moduleWithDecls <$> parseDeclWithMode mode decl
exprToModule :: String -> ParseResult ExtsModule
exprToModule exp = moduleWithDecls <$> SpliceDecl loc <$> parseExpWithMode mode exp
stmtToModule :: String -> ParseResult ExtsModule
stmtToModule stmtStr = case parseStmtWithMode mode stmtStr of
ParseOk stmt -> ParseOk mod
ParseFailed a b -> ParseFailed a b
where
mod = moduleWithDecls decl
decl :: Decl SrcSpanInfo
decl = SpliceDecl loc expr
expr :: Exp SrcSpanInfo
expr = doE loc [stmt, ret]
stmt :: Stmt SrcSpanInfo
ParseOk stmt = parseStmtWithMode mode stmtStr
ret :: Stmt SrcSpanInfo
ParseOk ret = Qualifier loc <$> parseExp lintIdent
imptToModule :: String -> ParseResult ExtsModule
imptToModule = parseFileContentsWithMode mode
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:" ++
styleId "highlight-code" "haskell" (found suggest),
floating "left" $ style severityClass "Why Not:" ++
styleId "highlight-code" "haskell" (whyNot suggest)
]
where
severityClass = case severity suggest of
Error -> "error"
Warning -> "warning"
_ -> "warning"
style :: String -> String -> String
style cls thing = [i| <div class="suggestion-${cls}">${thing}</div> |]
named :: String -> String
named thing = [i| <div class="suggestion-name" style="clear:both;">${thing}</div> |]
styleId :: String -> String -> String -> String
styleId cls id thing = [i| <div class="${cls}" id="${id}">${thing}</div> |]
floating :: String -> String -> String
floating dir thing = [i| <div class="suggestion-row" style="float: ${dir};">${thing}</div> |]
showSuggestion :: String -> String
showSuggestion = remove lintIdent . dropDo
where
remove str = replace str ""
dropDo :: String -> String
dropDo string =
if lintIdent `isInfixOf` string
then unlines . clean . lines $ string
else string
clean :: [String] -> [String]
clean ((stripPrefix " do " -> Just a) : as) =
let unindented = catMaybes
$ takeWhile isJust
$ map (stripPrefix " ") as
fullDo = a:unindented
afterDo = drop (length unindented) as
in
fullDo ++ clean afterDo
clean (x:xs) = x : clean xs
clean [] = []