{-# 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')
import Data.Char (isSpace)
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,2,0]

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
  , contextLines :: Int
  , onlyNewest :: Bool
  , annotationFiles :: [FilePath]
  }
  deriving (Show, Eq)

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

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 ['a'] ["all"]
    (NoArg (\opts -> opts { onlyNewest = False}))
    "handle all defects not just Newest"
  , Option ['C'] ["context"]
    (OptArg ((\f opts -> opts { contextLines = fromMaybe 0 $ readMaybe f }) . fromMaybe "0") "NUM")
    "specify how much context should be shown around a violation"
  -- , Option ['A'] ["annotations"]
  --   (ReqArg (\f opts -> opts { annotationFiles = (nub $ annotationFiles opts ++ [f]) }) "FILE")
  --   "load automatic annotation rules"
  ]

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

  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 reverseOccurrences 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
    reverseOccurrences :: Violation -> Violation -> Ordering
    reverseOccurrences = comparing filename <> flip (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"
      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
      contents <- liftIO $ readFile fname
      _ <- liftIO $ evaluate (length contents) -- ensure file is completely read

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

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

      let annotatedLines = fmap annotationToLine 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 :: AnnotatedViolation -> (Int, String)
    annotationToLine (AnnotatedViolation Violation{..} a indent) =
      (line, indent ++ showAnnotation a 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)

  -- 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))


  choice <- getUserChoice v
  case choice of
    Abort -> liftIO $ exitSuccess
    Annotate annotation -> pure $ Just (AnnotatedViolation v annotation indent)
    Skip -> pure Nothing
    Help -> handleViolation content v

-- | 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