{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BangPatterns #-}

module Annotator (defaultMain) where

import System.Environment (getArgs)
import System.IO
import System.Exit
import System.Console.GetOpt
import System.Directory (doesFileExist)
import System.Posix.Files
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
import Control.Exception (evaluate)
import Data.Function (on)
import Data.List (delete, intercalate, foldl', sortBy, nub)
import Data.Char (isSpace)
import Data.Either (rights)
import Data.Ord
import Data.Monoid
import Data.Maybe (fromMaybe, catMaybes)
import qualified Data.Version as Vsn
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty (NonEmpty(..))

import Annotator.Rule
import Annotator.Annotation

version :: Vsn.Version
version = Vsn.makeVersion [0,0,4,1]

type App a = ReaderT Options IO a

data Verbosity = Silent | Low | Chatty
  deriving (Show, Enum, Eq, Ord, Bounded)

data ShowVersion = FullVersion | ShortVersion
  deriving (Show, Eq)

increaseVerbosity :: Verbosity -> Verbosity
increaseVerbosity v
  | v == maxBound = v
  | otherwise = succ v

data Options = Options
  { inplace :: Bool
  , verbosity :: Verbosity
  , showVersion :: Maybe ShowVersion
  , showHelp :: Bool
  , batchMode :: Bool
  , contextLines :: Int
  , onlyNewest :: Bool
  , annotationFiles :: [FilePath]
  , autoAnnotations :: [Annotation]
  , todoMarker :: String
  }
  deriving (Show, Eq)

defaultOptions :: Options
defaultOptions = Options
  { inplace = False
  , verbosity = Silent
  , showVersion = Nothing
  , showHelp = False
  , batchMode = False
  , contextLines = 0
  , onlyNewest = True
  , annotationFiles = []
  , autoAnnotations = []
  , todoMarker = "TODO"
  }

options :: [OptDescr (Options -> Options)]
options =
  [ Option ['v'] ["verbose"]
    (NoArg (\opts -> opts { verbosity = increaseVerbosity (verbosity opts)}))
    "be more verbose, pass multiple times to increase verbosity"
  , Option ['i'] ["inplace"]
    (NoArg (\opts -> opts { inplace = True}))
    "replace source-file after inserting annotations"
  , Option ['V'] ["version"]
    (NoArg (\opts -> opts { showVersion = Just FullVersion }))
    "show full version information"
  , Option [] ["short-version"]
    (NoArg (\opts -> opts { showVersion = Just ShortVersion }))
    "show just the version number"
  , Option ['h'] ["help"]
    (NoArg (\opts -> opts { showHelp = True }))
    "show usage information"
  , Option ['b'] ["batch"]
    (NoArg (\opts -> opts { batchMode = True }))
    "run in batch mode, i.e. do not ask any questions"
  , Option ['a'] ["all"]
    (NoArg (\opts -> opts { onlyNewest = False}))
    "handle all defects not just Newest"
  , Option ['C'] ["context"]
    (OptArg (\f opts -> opts { contextLines = fromMaybe 0 (f >>= readMaybe) }) "NUM")
    "specify how much context should be shown around a violation"
  , Option ['t'] ["todo-marker"]
    (ReqArg (\f opts -> opts { todoMarker = f }) "STRING")
    "override the default TODO marker with a custom string"
  , Option ['A'] ["annotations"]
    (ReqArg (\f opts -> opts { annotationFiles = (nub $ annotationFiles opts ++ [f]) }) "FILE")
    (unlines  [ "load automatic annotation rules"
              , "  some examples:"
              , "     " <> show (Intentional (Rule "rule_1") "some reason")
              , "     " <> show (FalsePositive (Rule "rule_1") "some reason")
              , "     " <> show (ToDo (Rule "rule_1"))
              , "     # a comment"
              , "     -- another comment"
              ]
    )
  ]

readMaybe :: (Read a) => String -> Maybe a
readMaybe s = case reads s of
  [(n,[])] -> Just n
  _ -> Nothing

parseOptions :: [String] -> IO (Options, [String])
parseOptions argv =
  case getOpt Permute options argv of
    (o, n, []) -> pure (foldl' (flip id) defaultOptions o, n)
    (_, _, errs) -> ioError (userError (concat errs ++ usageInfo header options))
  where
    header = "Usage: annotator [OPTIONS] files..."

verbose :: Verbosity -> String -> App ()
verbose v s = do
  opts <- ask
  liftIO $ when (verbosity opts >= v) $ hPutStrLn stderr s

defaultMain :: IO ()
defaultMain = do
  (opts, defects) <- getArgs >>= parseOptions
  let fn = case defects of
        [f] -> f
        _ -> "defects.err"

  case showVersion opts of
    Just FullVersion -> do
      putStr $ unlines
        [
          "Annotator v" <> (Vsn.showVersion version)
        , "Copyright (c) 2022 Alexander Kobjolke <alexander.kobjolke@atlas-elektronik.com>"
        ]
      exitWith ExitSuccess
    Just ShortVersion -> do
      putStrLn $ Vsn.showVersion version
      exitWith ExitSuccess
    Nothing -> pure ()

  when (showHelp opts) $ do
    putStr $ usageInfo header options
    exitWith ExitSuccess

  automaticAnnotations <- rights . concat <$> (filterM fileExist (annotationFiles opts) >>= mapM fromFile)

  let opts' = opts { autoAnnotations = automaticAnnotations }

  runReaderT (genericMain fn) opts'

  where
    header = unlines $
      [
        "Usage: annotator [OPTIONS] files..."
      , ""
      , "A tool to semi-automatically add Coverity source-code annotations based on found defects."
      , ""
      ]

data Age = Old | New | Newest
  deriving (Show, Eq)

data Violation = Violation {
  filename :: !FilePath,
  line :: !Int,
  age :: !Age,
  rule :: !Rule,
  description :: !String
  }
  deriving (Show, Eq)

split :: Int -> (a -> Bool) -> [a] -> [[a]]
split _ _ [] = []
split n p xs
  | n > 0 = case break p xs of
              (match, []) -> [match]
              (match, (_ : rest)) -> match : split (n-1) p rest
  | otherwise = [xs]

parseViolations :: String -> [Violation]
parseViolations = map parseViolation . lines

removeSuffix :: String -> String -> String
removeSuffix suffix text = stripped
  where
    (p, s) = splitAt (length text - length suffix) text
    stripped = if s == suffix then p else text

parseViolation :: String -> Violation
parseViolation s = case split 4 (== ':') s of
  (file:line:_error:rule':desc) -> violation
    where
      violation = Violation file (read line) a (Rule (removeSuffix "_violation" r)) (dropWhile isSpace $ concat desc)
      (_:age':r:_) = split 2 (== ' ') rule'
      a = case (delete ',' age') of
        "Newest" -> Newest
        "New" -> New
        _ -> Old
  _ -> error "incorrectly formatted defect line"

genericMain :: FilePath -> App ()
genericMain file = do
  opts <- ask
  verbose Chatty $ show opts
  liftIO $ hSetBuffering stdin NoBuffering
  violations' <- liftIO $ filter (isRelevant (onlyNewest opts)) . parseViolations <$> readFile file
  _ <- liftIO $ evaluate (length violations') -- ensure file is completely read

  let mviolations = NE.nonEmpty violations'

  case mviolations of
    Just violations -> do
      let sortedViolations = NE.sortBy compareLocation violations
          groupedViolations = NE.groupBy ((==) `on` filename) sortedViolations
      verbose Chatty $ "all violations: " <> show sortedViolations
      forM_ groupedViolations handleViolations

    Nothing -> do
      liftIO $ hPutStrLn stderr "Defects file is empty"

  where
    compareLocation :: Violation -> Violation -> Ordering
    compareLocation = comparing filename <> comparing line

    isRelevant :: Bool -> Violation -> Bool
    isRelevant newestOnly v
      | newestOnly = age v == Newest
      | otherwise = True

-- | handle violations within a single file
handleViolations :: NonEmpty Violation -> App ()
handleViolations violations = do
  opts <- ask
  let fname = filename $ NE.head violations
      fname' = fname <> ".fix"
      todo = todoMarker opts
      header' = "Processing " <> (show $ NE.length violations) <> " violation(s) in file " <> fname
      header = unlines
        [ header'
        , take (length header') $ repeat '='
        , ""
        ]

  fileExists <- liftIO $ doesFileExist fname

  if fileExists
    then do
      liftIO $ hPutStrLn stderr header

      verbose Chatty $ show violations

      content <- liftIO $ readFile fname
      _ <- liftIO $ evaluate (length content) -- ensure file is completely read

      let numberedContent = zip [1..] . lines $ content

      annotations <- (catMaybes . NE.toList) <$> mapM (handleViolation content) violations

      let annotatedLines = sortBy (comparing fst) $ fmap (annotationToLine todo) annotations
          newContent = unlines . map snd $ mergeLines annotatedLines numberedContent

      liftIO $ writeFile fname' newContent

      liftIO $ when (inplace opts) $ rename fname' fname
    else do
      verbose Low $ "skipping non-existent file " <> fname
  where
    annotationToLine :: String -> AnnotatedViolation -> (Int, String)
    annotationToLine todo (AnnotatedViolation Violation{..} a indent) =
      (line, indent ++ showAnnotation todo a description)

    showAnnotation :: String -> Annotation -> String -> String
    showAnnotation _ (Intentional (Rule rule) reason) _ = mconcat ["// ", "coverity[", rule, "_violation", "] ", reason]
    showAnnotation _ (FalsePositive (Rule rule) reason) _ = mconcat ["// ", "coverity[", rule, "_violation", " : FALSE", "] ", reason]
    showAnnotation todo (ToDo (Rule rule)) description = "// " <> todo <> " " <> rule <> ": " <> description

data UserChoice = Abort
                | Annotate Annotation
                | Skip
                | Help
                deriving (Show, Eq)

-- | let the user decide what to do with a violation
getUserChoice :: Violation -> App UserChoice
getUserChoice Violation{..} = do
  liftIO $ queryUser
    where queryUser = do
            putStr $ "> What shall we do [s/t/i/f/q/?]: "
            hFlush stdout
            c <- getChar
            putStrLn ""
            case c of
              's' -> do
                pure Skip
              't' -> do
                pure $ Annotate (ToDo rule)
              'i' -> do
                excuse <- getExcuse
                pure $ Annotate (FalsePositive rule excuse)
              'f' -> do
                excuse <- getExcuse
                pure $ Annotate (Intentional rule excuse)
              'q' -> pure Abort
              '?' -> do
                putStrLn $ unlines [ "t - add TODO marker to fix this issue"
                                   , "s - skip this violation"
                                   , "f - false positive"
                                   , "i - intentional"
                                   , "q - quit without changing the current file"
                                   , "? - show this help"
                                   ]
                queryUser

              _ -> queryUser

          getExcuse = do
            putStr $ "What's your excuse? "
            hFlush stdout
            mode <- hGetBuffering stdin
            hSetBuffering stdin LineBuffering
            excuse <- getLine
            hSetBuffering stdin mode
            pure excuse

type Content = String
type NumberedLine = (Int, String)

-- | merge lines together
--
-- It is assumed that both lists are sorted according to their line number
-- @
-- mergeLines [(1, "blah"), (2,"foo"), (2, "baz"), (3, "bam")] [(2,"bar")]
-- [(1,"blah"),(2,"foo"),(2,"baz"),(2,"bar"),(3,"bam")]
-- @
mergeLines :: [NumberedLine] -> [NumberedLine] -> [NumberedLine]
mergeLines [] r = r
mergeLines l [] = l
mergeLines !lhs@(left@(nl,_):ls) !rhs@(right@(nr,_):rs)
  | nl <= nr = left : mergeLines ls rhs
  | otherwise = right : mergeLines lhs rs

data AnnotatedViolation = AnnotatedViolation Violation Annotation String
  deriving (Eq, Show)

-- | handle a single violation
--
-- The function gets the current content of the file and should result in the
-- new content of the file
handleViolation :: Content -> Violation -> App (Maybe AnnotatedViolation)
handleViolation content v@Violation{..} = do
  verbose Low $ show v
  opts <- ask

  let (before, after) = splitAt (line-1) . zip [1..] . lines $ content
      context = getContext (contextLines opts) before after
      indent = takeWhile isSpace (snd . head $ after)

  case lookupAnnotation rule (autoAnnotations opts) of
    Just a -> do
      verbose Low $ "automatically annotated violation of rule " <> show rule
      pure $ Just (AnnotatedViolation v a indent)
    _ -> do
      verbose Chatty $ "indentation: " <> show indent

      -- print some context
      liftIO $ forM_ context (\(n, code) -> do
                        let marker = ">>>>"
                        when (n == line) $ putStrLn (intercalate " " [ marker
                                                                    , show age
                                                                    , "violation of rule"
                                                                    , show rule
                                                                    , "in line"
                                                                    , show line <> ":"
                                                                    , description
                                                                    ])
                        putStrLn (code))
      if batchMode opts
        then pure $ Nothing
        else do
          choice <- getUserChoice v
          case choice of
            Abort -> liftIO $ exitSuccess
            Annotate annotation -> pure $ Just (AnnotatedViolation v annotation indent)
            Skip -> pure Nothing
            Help -> handleViolation content v
  where
    lookupAnnotation :: Rule -> [Annotation] -> Maybe Annotation
    lookupAnnotation _ [] = Nothing
    lookupAnnotation r (a:as)
      | r == annotationRule a = Just a
      | otherwise = lookupAnnotation r as

    annotationRule :: Annotation -> Rule
    annotationRule (Intentional r _) = r
    annotationRule (FalsePositive r _) = r
    annotationRule (ToDo r) = r

-- | Get some context around some line
--
-- the function receives the number of lines to show before and after a given line and the whole content split into lines before
getContext :: Int -> [(Int, String)] -> [(Int, String)] -> [(Int, String)]
getContext n before after = before' ++ after'
  where before' = reverse . take n . reverse $ before
        after'  = take (n+1) after