content: {-# 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
           { line :: LineNumber
           , found :: String
           , whyNot :: String
           , severity :: Severity
           , suggestion :: String
           }
    deriving (Eq, Show)
  
  -- Store settings for Hlint once it's initialized.
  {-# NOINLINE hlintSettings #-}
  hlintSettings :: MVar (ParseFlags, [Classify], Hint)
  hlintSettings = unsafePerformIO newEmptyMVar
  
  -- | Identifier used when one is needed for proper context.
  lintIdent :: String
  lintIdent = "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 code _blocks = do
    -- Initialize hlint settings
    initialized <- not <$> isEmptyMVar hlintSettings
    unless initialized $
      autoSettings' >>= putMVar hlintSettings
  
    -- Get hlint settings
    (flags, classify, hint) <- readMVar hlintSettings
  
    parsed <- parseModuleEx flags "-" (Just code)
  
    -- create 'suggestions'
    let ideas = case parsed of
          Left _ -> []
          Right mods -> applyHints classify hint [mods]
        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
  
  #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 =
    case ideaTo idea of
      Nothing -> Nothing
      Just wn ->
        Just
          Suggest
            { line = getSrcSpanStartLine $ ideaSpan idea
            , found = showSuggestion $ ideaFrom idea
            , whyNot = showSuggestion wn
            , severity = ideaSeverity idea
            , suggestion = ideaHint idea
            }
    where
      getSrcSpanStartLine span =
  #if MIN_VERSION_hlint(3,1,1)
        case unpackSrcSpan span of
          Just (_, (startLine, _), _) -> startLine
          Nothing -> 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 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" $ styl severityClass "Found:" ++
                                             -- Things that look like this get highlighted.
                                             styleId "highlight-code" "haskell" (found suggest)
                         , floating "left" $ styl severityClass "Why Not:" ++
                                             -- Things that look like this get highlighted.
                                             styleId "highlight-code" "haskell" (whyNot suggest)
                         ]
        where
          severityClass =
            case severity suggest of
              Error -> "error"
              Warning -> "warning"
  
              -- Should not occur
              _ -> "warning"
  
      styl :: String -> String -> String
      styl = printf "<div class=\"suggestion-%s\">%s</div>"
  
      named :: String -> String
      named = printf "<div class=\"suggestion-name\" style=\"clear:both;\">%s</div>"
  
      styleId :: String -> String -> String -> String
      styleId = printf "<div class=\"%s\" id=\"%s\">%s</div>"
  
      floating :: String -> String -> String
      floating = printf "<div class=\"suggestion-row\" style=\"float: %s;\">%s</div>"
  
  showSuggestion :: String -> String
  showSuggestion = remove lintIdent . dropDo
    where
      remove str = replace str ""
  
      -- Drop leading '  do ', and blank spaces following.
      dropDo :: String -> String
      dropDo string =
        -- If this is not a statement, we don't need to drop the do statement.
        if lintIdent `isInfixOf` string
          then unlines . clean . lines $ string
          else string
  
      clean :: [String] -> [String]
      -- If the first line starts with a `do`... Note that hlint always indents by two spaces in its
      -- output.
      clean ((stripPrefix "  do " -> Just a):as) =
        -- Take all indented lines and unindent them.
        let unindented = catMaybes $ takeWhile isJust $ map (stripPrefix "     ") as
            fullDo = a : unindented
            afterDo = drop (length unindented) as
        in fullDo ++ clean afterDo
  
      -- Ignore other list elements - just proceed onwards.
      clean (x:xs) = x : clean xs
      clean [] = []
  