{-# LANGUAGE NoImplicitPrelude, FlexibleContexts, ViewPatterns, CPP #-}

module IHaskell.Eval.Lint (lint) where

import           IHaskellPrelude


import           Data.Maybe (mapMaybe)
import           System.IO.Unsafe (unsafePerformIO)

#if MIN_VERSION_hlint(3,1,1)
import           Language.Haskell.HLint
#elif MIN_VERSION_hlint(3,0,0)
import           Language.Haskell.HLint
import           SrcLoc (SrcSpan(..), srcSpanStartLine)
#else
import           Language.Haskell.Exts hiding (Module)
import           Language.Haskell.HLint as HLint
import           Language.Haskell.HLint3
#endif

import           IHaskell.CSS (ihaskellCSS)
import           IHaskell.Display
import           IHaskell.Eval.Parser hiding (line)
import           StringUtils (replace)

#if MIN_VERSION_hlint(2,1,18)

#else

import           Prelude (last)
import qualified Language.Haskell.Exts.Syntax as SrcExts
import           Language.Haskell.Exts (parseFileContentsWithMode)

#endif

data LintSuggestion =
       Suggest
         { LintSuggestion -> LineNumber
line :: LineNumber
         , LintSuggestion -> String
found :: String
         , LintSuggestion -> String
whyNot :: String
         , LintSuggestion -> Severity
severity :: Severity
         , LintSuggestion -> String
suggestion :: String
         }
  deriving (LintSuggestion -> LintSuggestion -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LintSuggestion -> LintSuggestion -> Bool
$c/= :: LintSuggestion -> LintSuggestion -> Bool
== :: LintSuggestion -> LintSuggestion -> Bool
$c== :: LintSuggestion -> LintSuggestion -> Bool
Eq, LineNumber -> LintSuggestion -> String -> String
[LintSuggestion] -> String -> String
LintSuggestion -> String
forall a.
(LineNumber -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [LintSuggestion] -> String -> String
$cshowList :: [LintSuggestion] -> String -> String
show :: LintSuggestion -> String
$cshow :: LintSuggestion -> String
showsPrec :: LineNumber -> LintSuggestion -> String -> String
$cshowsPrec :: LineNumber -> LintSuggestion -> String -> String
Show)

-- Store settings for Hlint once it's initialized.
{-# NOINLINE hlintSettings #-}
hlintSettings :: MVar (ParseFlags, [Classify], Hint)
hlintSettings :: MVar (ParseFlags, [Classify], Hint)
hlintSettings = forall a. IO a -> a
unsafePerformIO forall a. IO (MVar a)
newEmptyMVar

-- | Identifier used when one is needed for proper context.
lintIdent :: String
lintIdent :: String
lintIdent = String
"lintIdentAEjlkQeh"

#if MIN_VERSION_hlint(2,1,18)

-- | Given code chunks, perform linting and output a displayable report on linting warnings
-- and errors.
lint :: String -> [Located CodeBlock] -> IO Display
lint :: String -> [Located CodeBlock] -> IO Display
lint String
code [Located CodeBlock]
_blocks = do
  -- Initialize hlint settings
  Bool
initialized <- Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. MVar a -> IO Bool
isEmptyMVar MVar (ParseFlags, [Classify], Hint)
hlintSettings
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
initialized forall a b. (a -> b) -> a -> b
$
    IO (ParseFlags, [Classify], Hint)
autoSettings' forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. MVar a -> a -> IO ()
putMVar MVar (ParseFlags, [Classify], Hint)
hlintSettings

  -- Get hlint settings
  (ParseFlags
flags, [Classify]
classify, Hint
hint) <- forall a. MVar a -> IO a
readMVar MVar (ParseFlags, [Classify], Hint)
hlintSettings

  Either ParseError ModuleEx
parsed <- ParseFlags
-> String -> Maybe String -> IO (Either ParseError ModuleEx)
parseModuleEx ParseFlags
flags String
"-" (forall a. a -> Maybe a
Just String
code)

  -- create 'suggestions'
  let ideas :: [Idea]
ideas = case Either ParseError ModuleEx
parsed of
        Left ParseError
_ -> []
        Right ModuleEx
mods -> [Classify] -> Hint -> [ModuleEx] -> [Idea]
applyHints [Classify]
classify Hint
hint [ModuleEx
mods]
      suggestions :: [LintSuggestion]
suggestions = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Idea -> Maybe LintSuggestion
showIdea forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Idea -> Bool
ignoredIdea) [Idea]
ideas

  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [DisplayData] -> Display
Display forall a b. (a -> b) -> a -> b
$
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LintSuggestion]
suggestions
      then []
      else [
        String -> DisplayData
plain forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LintSuggestion -> String
plainSuggestion [LintSuggestion]
suggestions
        , Maybe Text -> String -> DisplayData
html' (forall a. a -> Maybe a
Just Text
ihaskellCSS) ([LintSuggestion] -> String
htmlSuggestions [LintSuggestion]
suggestions)
        ]
  where
    autoSettings' :: IO (ParseFlags, [Classify], Hint)
autoSettings' = do
      (ParseFlags
fixts, [Classify]
classify, Hint
hints) <- IO (ParseFlags, [Classify], Hint)
autoSettings
      let hidingIgnore :: Classify
hidingIgnore = Severity -> String -> String -> String -> Classify
Classify Severity
Ignore String
"Unnecessary hiding" String
"" String
""
      let pragmaIgnore :: Classify
pragmaIgnore = Severity -> String -> String -> String -> Classify
Classify Severity
Ignore String
"Unused LANGUAGE pragma" String
"" String
""
      forall (m :: * -> *) a. Monad m => a -> m a
return (ParseFlags
fixts, Classify
pragmaIgnoreforall a. a -> [a] -> [a]
:Classify
hidingIgnoreforall a. a -> [a] -> [a]
:[Classify]
classify, Hint
hints)
    ignoredIdea :: Idea -> Bool
ignoredIdea Idea
idea = Idea -> Severity
ideaSeverity Idea
idea forall a. Eq a => a -> a -> Bool
== Severity
Ignore

#else

type ExtsModule = SrcExts.Module SrcSpanInfo

-- | Given parsed code chunks, perform linting and output a displayable report on linting warnings
-- and errors.
lint :: String -> [Located CodeBlock] -> IO Display
lint _code blocks = do
  -- Initialize hlint settings
  initialized <- not <$> isEmptyMVar hlintSettings
  unless initialized $
    autoSettings' >>= putMVar hlintSettings

  -- Get hlint settings
  (flags, classify, hint) <- readMVar hlintSettings

  -- create 'suggestions'
  let modules = mapMaybe (createModule (hseFlags flags)) blocks
      ideas = applyHints classify hint (map (\m -> (m, [])) modules)
      suggestions = mapMaybe showIdea $ filter (not . ignoredIdea) ideas

  return $ Display $
    if null suggestions
      then []
      else [plain $ concatMap plainSuggestion suggestions, html' (Just ihaskellCSS) $ htmlSuggestions suggestions]
  where
    autoSettings' = do
      (fixts, classify, hints) <- autoSettings
      let hidingIgnore = Classify Ignore "Unnecessary hiding" "" ""
      let pragmaIgnore = Classify Ignore "Unused LANGUAGE pragma" "" ""
      return (fixts, pragmaIgnore:hidingIgnore:classify, hints)
    ignoredIdea idea = ideaSeverity idea == Ignore

createModule :: ParseMode -> Located CodeBlock -> Maybe ExtsModule
createModule md (Located ln 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 mdl       -> unparse $ pModule mdl
    _                -> Nothing
  where
    blockStr =
      case block of
        Expression expr  -> expr
        Declaration decl -> decl
        Statement stmt   -> stmt
        Import impt      -> impt
        Module mdl       -> mdl

        -- TODO: Properly handle the other constructors
        _ -> []

    unparse :: ParseResult a -> Maybe a
    unparse (ParseOk a) = Just a
    unparse _ = Nothing

    srcSpan :: SrcSpan
    srcSpan = SrcSpan
      { srcSpanFilename = "<interactive>"
      , srcSpanStartLine = ln
      , srcSpanStartColumn = 0
      , srcSpanEndLine = ln + length (lines blockStr)
      , srcSpanEndColumn = length $ last $ lines blockStr
      }

    lcn :: SrcSpanInfo
    lcn = SrcSpanInfo srcSpan []

    moduleWithDecls :: Decl SrcSpanInfo -> ExtsModule
    moduleWithDecls decl = SrcExts.Module lcn Nothing [] [] [decl]

    pModule :: String -> ParseResult ExtsModule
    pModule = parseFileContentsWithMode md

    declToModule :: String -> ParseResult ExtsModule
    declToModule decl = moduleWithDecls <$> parseDeclWithMode md decl

    exprToModule :: String -> ParseResult ExtsModule
    exprToModule exp = moduleWithDecls <$> SpliceDecl lcn <$> parseExpWithMode md exp

    stmtToModule :: String -> ParseResult ExtsModule
    stmtToModule stmtStr =
      case parseStmtWithMode md stmtStr of
        ParseOk _       -> ParseOk $ moduleWithDecls decl
        ParseFailed a b -> ParseFailed a b
      where
        decl :: Decl SrcSpanInfo
        decl = SpliceDecl lcn expr

        expr :: Exp SrcSpanInfo
        expr = Do lcn [stmt, ret]

        stmt :: Stmt SrcSpanInfo
        ParseOk stmt = parseStmtWithMode md stmtStr

        ret :: Stmt SrcSpanInfo
        ParseOk ret = Qualifier lcn <$> parseExp lintIdent

    imptToModule :: String -> ParseResult ExtsModule
    imptToModule = parseFileContentsWithMode md

#endif

showIdea :: Idea -> Maybe LintSuggestion
showIdea :: Idea -> Maybe LintSuggestion
showIdea Idea
idea =
  case Idea -> Maybe String
ideaTo Idea
idea of
    Maybe String
Nothing -> forall a. Maybe a
Nothing
    Just String
wn ->
      forall a. a -> Maybe a
Just
        Suggest
          { line :: LineNumber
line = SrcSpan -> LineNumber
getSrcSpanStartLine forall a b. (a -> b) -> a -> b
$ Idea -> SrcSpan
ideaSpan Idea
idea
          , found :: String
found = String -> String
showSuggestion forall a b. (a -> b) -> a -> b
$ Idea -> String
ideaFrom Idea
idea
          , whyNot :: String
whyNot = String -> String
showSuggestion String
wn
          , severity :: Severity
severity = Idea -> Severity
ideaSeverity Idea
idea
          , suggestion :: String
suggestion = Idea -> String
ideaHint Idea
idea
          }
  where
    getSrcSpanStartLine :: SrcSpan -> LineNumber
getSrcSpanStartLine SrcSpan
span =
#if MIN_VERSION_hlint(3,1,1)
      case SrcSpan
-> Maybe
     (String, (LineNumber, LineNumber), (LineNumber, LineNumber))
unpackSrcSpan SrcSpan
span of
        Just (String
_, (LineNumber
startLine, LineNumber
_), (LineNumber, LineNumber)
_) -> LineNumber
startLine
        Maybe (String, (LineNumber, LineNumber), (LineNumber, LineNumber))
Nothing -> LineNumber
1
#elif MIN_VERSION_hlint(3,0,0)
      case span of
        RealSrcSpan realSpan -> srcSpanStartLine realSpan
        UnhelpfulSpan _ -> 1
#else
      srcSpanStartLine span
#endif



plainSuggestion :: LintSuggestion -> String
plainSuggestion :: LintSuggestion -> String
plainSuggestion LintSuggestion
suggest =
  forall r. PrintfType r => String -> r
printf String
"Line %d: %s\nFound:\n%s\nWhy not:\n%s" (LintSuggestion -> LineNumber
line LintSuggestion
suggest) (LintSuggestion -> String
suggestion LintSuggestion
suggest) (LintSuggestion -> String
found LintSuggestion
suggest)
    (LintSuggestion -> String
whyNot LintSuggestion
suggest)

htmlSuggestions :: [LintSuggestion] -> String
htmlSuggestions :: [LintSuggestion] -> String
htmlSuggestions = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LintSuggestion -> String
toHtml
  where
    toHtml :: LintSuggestion -> String
    toHtml :: LintSuggestion -> String
toHtml LintSuggestion
suggest = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                       [ String -> String
named forall a b. (a -> b) -> a -> b
$ LintSuggestion -> String
suggestion LintSuggestion
suggest
                       , String -> String -> String
floating String
"left" forall a b. (a -> b) -> a -> b
$ String -> String -> String
styl String
severityClass String
"Found:" forall a. [a] -> [a] -> [a]
++
                                           -- Things that look like this get highlighted.
                                           String -> String -> String -> String
styleId String
"highlight-code" String
"haskell" (LintSuggestion -> String
found LintSuggestion
suggest)
                       , String -> String -> String
floating String
"left" forall a b. (a -> b) -> a -> b
$ String -> String -> String
styl String
severityClass String
"Why Not:" forall a. [a] -> [a] -> [a]
++
                                           -- Things that look like this get highlighted.
                                           String -> String -> String -> String
styleId String
"highlight-code" String
"haskell" (LintSuggestion -> String
whyNot LintSuggestion
suggest)
                       ]
      where
        severityClass :: String
severityClass =
          case LintSuggestion -> Severity
severity LintSuggestion
suggest of
            Severity
Error -> String
"error"
            Severity
Warning -> String
"warning"

            -- Should not occur
            Severity
_ -> String
"warning"

    styl :: String -> String -> String
    styl :: String -> String -> String
styl = forall r. PrintfType r => String -> r
printf String
"<div class=\"suggestion-%s\">%s</div>"

    named :: String -> String
    named :: String -> String
named = forall r. PrintfType r => String -> r
printf String
"<div class=\"suggestion-name\" style=\"clear:both;\">%s</div>"

    styleId :: String -> String -> String -> String
    styleId :: String -> String -> String -> String
styleId = forall r. PrintfType r => String -> r
printf String
"<div class=\"%s\" id=\"%s\">%s</div>"

    floating :: String -> String -> String
    floating :: String -> String -> String
floating = forall r. PrintfType r => String -> r
printf String
"<div class=\"suggestion-row\" style=\"float: %s;\">%s</div>"

showSuggestion :: String -> String
showSuggestion :: String -> String
showSuggestion = String -> String -> String
remove String
lintIdent forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
dropDo
  where
    remove :: String -> String -> String
remove String
str = String -> String -> String -> String
replace String
str String
""

    -- Drop leading '  do ', and blank spaces following.
    dropDo :: String -> String
    dropDo :: String -> String
dropDo String
string =
      -- If this is not a statement, we don't need to drop the do statement.
      if String
lintIdent forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
string
        then [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
clean forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines forall a b. (a -> b) -> a -> b
$ String
string
        else String
string

    clean :: [String] -> [String]
    -- If the first line starts with a `do`... Note that hlint always indents by two spaces in its
    -- output.
    clean :: [String] -> [String]
clean ((forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"  do " -> Just String
a):[String]
as) =
      -- Take all indented lines and unindent them.
      let unindented :: [String]
unindented = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
takeWhile forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"     ") [String]
as
          fullDo :: [String]
fullDo = String
a forall a. a -> [a] -> [a]
: [String]
unindented
          afterDo :: [String]
afterDo = forall a. LineNumber -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> LineNumber
length [String]
unindented) [String]
as
      in [String]
fullDo forall a. [a] -> [a] -> [a]
++ [String] -> [String]
clean [String]
afterDo

    -- Ignore other list elements - just proceed onwards.
    clean (String
x:[String]
xs) = String
x forall a. a -> [a] -> [a]
: [String] -> [String]
clean [String]
xs
    clean [] = []