content: {-# LANGUAGE NoImplicitPrelude, BangPatterns, DerivingVia, DeriveGeneric, OverloadedRecordDot #-}
  
  module Resolution
      ( Result(..)
      , NewContent(..)
      , resolveContent
      , fullySuccessful
      ) where
  
  import           Conflict (Conflict(..), Sides(..))
  import qualified Conflict
  import           Control.Monad (guard)
  import           Data.Foldable (Foldable(..))
  import           Data.List (isPrefixOf)
  import           Data.List.Split (splitWhen)
  import           Generic.Data (Generic, Generically(..))
  import           ResolutionOpts
  
  import           Prelude.Compat
  
  data Resolution
      = NoResolution Conflict
      | Resolution String
      | PartialResolution String
  
  resolveGen :: Eq a => Sides a -> Maybe a
  resolveGen (Sides a base b)
      | a == base = Just b
      | b == base = Just a
      | a == b = Just a
      | otherwise = Nothing
  
  resolveGenLines :: Eq a => ResolutionOptions -> Sides [a] -> Maybe [a]
  resolveGenLines opts sides@(Sides a base b) =
      case guard opts.trivial >> resolveGen sides of
      Just x -> Just x
      _ | opts.addedLines ->
          case addedBothSides a b <> addedBothSides b a of
          [x] -> Just x
          _ -> Nothing
      _ -> Nothing
      where
          n = length base
          addedBothSides x y = [x <> drop n y | drop (length x - n) x == base && take n y == base]
  
  resolveReduced :: ResolutionOptions -> Sides [String] -> Maybe [String]
  resolveReduced opts sides
      | opts.indentation =
          map . (<>) <$> resolveGen prefixes <*> resolveGenLines opts unprefixed
      | otherwise = resolveGenLines opts sides
      where
          prefixes = takeWhile (== ' ') . commonPrefix <$> sides
          unprefixed = map . drop . length <$> prefixes <*> sides
  
  commonPrefix :: Eq a => [[a]] -> [a]
  commonPrefix [] = []
  commonPrefix [x] = x
  commonPrefix (x:xs) = map fst . takeWhile (uncurry (==)) . zip x $ commonPrefix xs
  
  resolveConflict :: ResolutionOptions -> Conflict -> Resolution
  resolveConflict opts c
      | matchTop == 0 && matchBottom == 0 || not opts.reduce =
          maybe (NoResolution c) (Resolution . unlines) (resolveReduced opts c.bodies)
      | otherwise =
          case resolveGenLines opts reduced.bodies of
          Just x -> Resolution $ formatRes x
          Nothing -> PartialResolution $ formatRes $ Conflict.prettyLines reduced
      where
          formatRes mid = unlines $ take matchTop c.bodies.sideA <> mid <> takeEnd matchBottom c.bodies.sideA
          match base a b
              | null base = lengthOfCommonPrefix a b
              | otherwise = minimum $ map (lengthOfCommonPrefix base) [a, b]
          matchTop = match c.bodies.sideBase c.bodies.sideA c.bodies.sideB
          revBottom = reverse . drop matchTop
          matchBottom = match (revBottom c.bodies.sideBase) (revBottom c.bodies.sideA) (revBottom c.bodies.sideB)
          dropEnd count xs = take (length xs - count) xs
          takeEnd count xs = drop (length xs - count) xs
          unmatched xs = drop matchTop $ dropEnd matchBottom xs
          reduced = Conflict.setEachBody unmatched c
  
  lengthOfCommonPrefix :: Eq a => [a] -> [a] -> Int
  lengthOfCommonPrefix x y = length $ takeWhile id $ zipWith (==) x y
  
  data Result = Result
      { resolvedSuccessfully :: !Int
      , reducedConflicts :: !Int
      , failedToResolve :: !Int
      }
  
  fullySuccessful :: Result -> Bool
  fullySuccessful (Result _ reduced failed) = reduced == 0 && failed == 0
  
  instance Semigroup Result where
      Result x0 y0 z0 <> Result x1 y1 z1 = Result (x0+x1) (y0+y1) (z0+z1)
  
  instance Monoid Result where mempty = Result 0 0 0
  
  data NewContent = NewContent
      { result :: !Result
      , newContent :: !String
      }
      deriving Generic
      deriving (Semigroup, Monoid) via Generically NewContent
  
  untabifyStr :: Int -> String -> String
  untabifyStr size =
      go 0
      where
          cyclicInc col
              | col >= size - 1 = 0
              | otherwise = col + 1
          go !col ('\t':rest) = replicate (size - col) ' ' ++ go 0 rest
          go !col (x:rest) = x : go (cyclicInc col) rest
          go _ [] = []
  
  untabifyConflict :: Int -> Conflict -> Conflict
  untabifyConflict = Conflict.setStrings . untabifyStr
  
  data LineEnding = LF | CRLF | Mixed
      deriving (Eq, Ord)
  
  lineEnding :: String -> LineEnding
  lineEnding x@(_:_) | last x == '\r' = CRLF
  lineEnding _ = LF
  
  inferLineEndings :: [String] -> LineEnding
  inferLineEndings [] = Mixed
  inferLineEndings xs =
      foldl1 f (map lineEnding xs)
      where
          f Mixed _ = Mixed
          f x c
              | x == c = x
              | otherwise = Mixed
  
  allSame :: Eq a => [a] -> Bool
  allSame (x:y:rest) = x == y && allSame (y:rest)
  allSame _ = True
  
  lineBreakFix :: Conflict -> Conflict
  lineBreakFix c
      | any null c.bodies
      || allSame (toList endings) = c
      | otherwise =
          case resolveGen endings of
          Just LF -> Conflict.setStrings removeCr c
          Just CRLF -> Conflict.setStrings makeCr c
          _ -> c
      where
          endings = fmap inferLineEndings c.bodies
          removeCr x@(_:_) | last x == '\r' = init x
          removeCr x = x
          makeCr x@(_:_) | last x == '\r' = x
          makeCr x = x <> "\r"
  
  formatResolution :: Resolution -> NewContent
  formatResolution (NoResolution c) = NewContent (Result 0 0 1) (Conflict.pretty c)
  formatResolution (Resolution trivialLines) = NewContent (Result 1 0 0) trivialLines
  formatResolution (PartialResolution newLines) = NewContent (Result 0 1 0) newLines
  
  resolveContent :: ResolutionOptions -> [Either String Conflict] -> NewContent
  resolveContent opts =
      foldMap go
      where
          go (Left line) = NewContent mempty (unlines [line])
          go (Right conflict) =
              r
              { result =
                  case parts of
                  [_] -> r.result
                  _ | r.result.failedToResolve + r.result.reducedConflicts > 0 ->
                          mempty {reducedConflicts = 1} -- The split is a reduction
                      | otherwise -> mempty {resolvedSuccessfully = 1}
              }
              where
                  parts
                      | opts.splitMarkers = splitConflict conflict
                      | otherwise = [conflict]
                  r = foldMap resolve parts
          resolve conflict =
              formatResolution $ resolveConflict opts $
              (if opts.lineEndings then lineBreakFix else id) $
              maybe id untabifyConflict opts.untabify conflict
  
  splitConflict :: Conflict -> [Conflict]
  splitConflict c =
      maybe [c] ((\s -> c{bodies=s}) <$>) $
      matchSplits $ splitWhen (isPrefixOf "~~~~~~~") <$> c.bodies
  
  matchSplits :: Sides [a] -> Maybe [Sides a]
  matchSplits (Sides (a:as) (b:bs) (c:cs)) =
      (Sides a b c :) <$> matchSplits (Sides as bs cs)
  matchSplits (Sides [] [] []) = Just []
  matchSplits _ = Nothing
  