content: {-
      Copyright 2019 Vidar 'koala_man' Holen
  
      This file is part of ShellCheck.
      https://www.shellcheck.net
  
      ShellCheck is free software: you can redistribute it and/or modify
      it under the terms of the GNU General Public License as published by
      the Free Software Foundation, either version 3 of the License, or
      (at your option) any later version.
  
      ShellCheck is distributed in the hope that it will be useful,
      but WITHOUT ANY WARRANTY; without even the implied warranty of
      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
      GNU General Public License for more details.
  
      You should have received a copy of the GNU General Public License
      along with this program.  If not, see <https://www.gnu.org/licenses/>.
  -}
  {-# LANGUAGE TemplateHaskell #-}
  module ShellCheck.Formatter.Diff (format, ShellCheck.Formatter.Diff.runTests) where
  
  import ShellCheck.Interface
  import ShellCheck.Fixer
  import ShellCheck.Formatter.Format
  
  import Control.Monad
  import Data.Algorithm.Diff
  import Data.Array
  import Data.IORef
  import Data.List
  import qualified Data.Monoid as Monoid
  import Data.Maybe
  import qualified Data.Map as M
  import GHC.Exts (sortWith)
  import System.IO
  import System.FilePath
  
  import Test.QuickCheck
  
  format :: FormatterOptions -> IO Formatter
  format options = do
      foundIssues <- newIORef False
      reportedIssues <- newIORef False
      shouldColor <- shouldOutputColor (foColorOption options)
      let color = if shouldColor then colorize else nocolor
      return Formatter {
          header = return (),
          footer = checkFooter foundIssues reportedIssues color,
          onFailure = reportFailure color,
          onResult  = reportResult foundIssues reportedIssues color
      }
  
  
  contextSize = 3
  red = 31
  green = 32
  yellow = 33
  cyan = 36
  bold = 1
  
  nocolor n = id
  colorize n s = (ansi n) ++ s ++ (ansi 0)
  ansi n = "\x1B[" ++ show n ++ "m"
  
  printErr :: ColorFunc -> String -> IO ()
  printErr color = hPutStrLn stderr . color bold . color red
  reportFailure color file msg = printErr color $ file ++ ": " ++ msg
  
  checkFooter foundIssues reportedIssues color = do
      found <- readIORef foundIssues
      output <- readIORef reportedIssues
      when (found && not output) $
              printErr color "Issues were detected, but none were auto-fixable. Use another format to see them."
  
  type ColorFunc = (Int -> String -> String)
  data LFStatus = LinefeedMissing | LinefeedOk
  data DiffDoc a = DiffDoc String LFStatus [DiffRegion a]
  data DiffRegion a = DiffRegion (Int, Int) (Int, Int) [Diff a]
  
  reportResult :: (IORef Bool) -> (IORef Bool) -> ColorFunc -> CheckResult -> SystemInterface IO -> IO ()
  reportResult foundIssues reportedIssues color result sys = do
      let comments = crComments result
      unless (null comments) $ writeIORef foundIssues True
      let suggestedFixes = mapMaybe pcFix comments
      let fixmap = buildFixMap suggestedFixes
      mapM_ output $ M.toList fixmap
    where
      output (name, fix) = do
          file <- siReadFile sys (Just True) name
          case file of
              Right contents -> do
                  putStrLn $ formatDoc color $ makeDiff name contents fix
                  writeIORef reportedIssues True
              Left msg -> reportFailure color name msg
  
  hasTrailingLinefeed str =
      case str of
          [] -> True
          _ -> last str == '\n'
  
  coversLastLine regions =
      case regions of
          [] -> False
          _ -> (fst $ last regions)
  
  -- TODO: Factor this out into a unified diff library because we're doing a lot
  -- of the heavy lifting anyways.
  makeDiff :: String -> String -> Fix -> DiffDoc String
  makeDiff name contents fix = do
      let hunks = groupDiff $ computeDiff contents fix
      let lf = if coversLastLine hunks && not (hasTrailingLinefeed contents)
               then LinefeedMissing
               else LinefeedOk
      DiffDoc name lf $ findRegions hunks
  
  computeDiff :: String -> Fix -> [Diff String]
  computeDiff contents fix =
      let old = lines contents
          array = listArray (1, fromIntegral $ (length old)) old
          new = applyFix fix array
      in getDiff old new
  
  -- Group changes into hunks
  groupDiff :: [Diff a] -> [(Bool, [Diff a])]
  groupDiff = filter (\(_, l) -> not (null l)) . hunt []
    where
      -- Churn through 'Both's until we find a difference
      hunt current [] = [(False, reverse current)]
      hunt current (x@Both {}:rest) = hunt (x:current) rest
      hunt current list =
          let (context, previous) = splitAt contextSize current
          in (False, reverse previous) : gather context 0 list
  
      -- Pick out differences until we find a run of Both's
      gather current n [] =
          let (extras, patch) = splitAt (max 0 $ n - contextSize) current
          in [(True, reverse patch), (False, reverse extras)]
  
      gather current n list@(Both {}:_) | n == contextSize*2 =
          let (context, previous) = splitAt contextSize current
          in (True, reverse previous) : hunt context list
  
      gather current n (x@Both {}:rest) = gather (x:current) (n+1) rest
      gather current n (x:rest) = gather (x:current) 0 rest
  
  -- Get line numbers for hunks
  findRegions :: [(Bool, [Diff String])] -> [DiffRegion String]
  findRegions = find' 1 1
    where
      find' _ _ [] = []
      find' left right ((output, run):rest) =
          let (dl, dr) = countDelta run
              remainder = find' (left+dl) (right+dr) rest
          in
              if output
              then DiffRegion (left, dl) (right, dr) run : remainder
              else remainder
  
  -- Get left/right line counts for a hunk
  countDelta :: [Diff a] -> (Int, Int)
  countDelta = count' 0 0
    where
      count' left right [] = (left, right)
      count' left right (x:rest) =
          case x of
              Both {} -> count' (left+1) (right+1) rest
              First {} -> count' (left+1) right rest
              Second {} -> count' left (right+1) rest
  
  formatRegion :: ColorFunc -> LFStatus -> DiffRegion String -> String
  formatRegion color lf (DiffRegion left right diffs) =
      let header = color cyan ("@@ -" ++ (tup left) ++ " +" ++ (tup right) ++" @@")
      in
          unlines $ header : reverse (getStrings lf (reverse diffs))
    where
      noLF = "\\ No newline at end of file"
  
      getStrings LinefeedOk list = map format list
      getStrings LinefeedMissing list@((Both _ _):_) = noLF : map format list
      getStrings LinefeedMissing list@((First _):_) = noLF : map format list
      getStrings LinefeedMissing (last:rest) = format last : getStrings LinefeedMissing rest
  
      tup (a,b) = (show a) ++ "," ++ (show b)
      format (Both x _) = ' ':x
      format (First x) = color red $ '-':x
      format (Second x) = color green $ '+':x
  
  splitLast [] = ([], [])
  splitLast x =
      let (last, rest) = splitAt 1 $ reverse x
      in (reverse rest, last)
  
  -- git patch does not like `\` on Windows
  normalizePath path =
      case path of
          c:rest -> (if c == pathSeparator then '/' else c) : normalizePath rest
          [] -> []
  
  formatDoc color (DiffDoc name lf regions) =
      let (most, last) = splitLast regions
      in
            (color bold $ "--- " ++ (normalizePath $ "a" </> name)) ++ "\n" ++
            (color bold $ "+++ " ++ (normalizePath $ "b" </> name)) ++ "\n" ++
            concatMap (formatRegion color LinefeedOk) most ++
            concatMap (formatRegion color lf) last
  
  -- Create a Map from filename to Fix
  buildFixMap :: [Fix] -> M.Map String Fix
  buildFixMap fixes = perFile
    where
      splitFixes = splitFixByFile $ mconcat fixes
      perFile = groupByMap (posFile . repStartPos . head . fixReplacements) splitFixes
  
  splitFixByFile :: Fix -> [Fix]
  splitFixByFile fix = map makeFix $ groupBy sameFile (fixReplacements fix)
    where
      sameFile rep1 rep2 = (posFile $ repStartPos rep1) == (posFile $ repStartPos rep2)
      makeFix reps = newFix { fixReplacements = reps }
  
  groupByMap :: (Ord k, Monoid v) => (v -> k) -> [v] -> M.Map k v
  groupByMap f = M.fromListWith Monoid.mappend . map (\x -> (f x, x))
  
  -- For building unit tests
  b n = Both n n
  l = First
  r = Second
  
  prop_identifiesProperContext = groupDiff [b 1, b 2, b 3, b 4, l 5, b 6, b 7, b 8, b 9] ==
      [(False, [b 1]), -- Omitted
      (True, [b 2, b 3, b 4, l 5, b 6, b 7, b 8]), -- A change with three lines of context
      (False, [b 9])]  -- Omitted
  
  prop_includesContextFromStartIfNecessary = groupDiff [b 4, l 5, b 6, b 7, b 8, b 9] ==
      [ -- Nothing omitted
      (True, [b 4, l 5, b 6, b 7, b 8]), -- A change with three lines of context
      (False, [b 9])]  -- Omitted
  
  prop_includesContextUntilEndIfNecessary = groupDiff [b 4, l 5] ==
      [ -- Nothing omitted
          (True, [b 4, l 5])
      ] -- Nothing Omitted
  
  prop_splitsIntoMultipleHunks = groupDiff [l 1, b 1, b 2, b 3, b 4, b 5, b 6, b 7, r 8] ==
      [ -- Nothing omitted
          (True, [l 1, b 1, b 2, b 3]),
          (False, [b 4]),
          (True, [b 5, b 6, b 7, r 8])
      ] -- Nothing Omitted
  
  prop_splitsIntoMultipleHunksUnlessTouching = groupDiff [l 1, b 1, b 2, b 3, b 4, b 5, b 6, r 7] ==
      [
          (True, [l 1, b 1, b 2, b 3, b 4, b 5, b 6, r 7])
      ]
  
  prop_countDeltasWorks = countDelta [b 1, l 2, r 3, r 4, b 5] == (3,4)
  prop_countDeltasWorks2 = countDelta [] == (0,0)
  
  return []
  runTests = $quickCheckAll
  