git-mediate-1.0.9: src/Conflict.hs

{-# LANGUAGE FlexibleContexts, NoImplicitPrelude, DeriveTraversable, NamedFieldPuns, DerivingVia, DeriveGeneric, OverloadedRecordDot #-}

module Conflict
    ( Conflict(..), Sides(..), SrcContent(..)
    , setEachBody, setStrings
    , pretty, prettyLines
    , parse
    ) where

import Control.Monad.State (MonadState, state, evalStateT)
import Control.Monad.Writer (runWriter, tell)
import Data.Maybe (fromMaybe)
import Generic.Data (Generically1(..))
import GHC.Generics (Generic1)

import Prelude.Compat

data Sides a = Sides
    { sideA :: a
    , sideBase :: a
    , sideB :: a
    } deriving (Functor, Foldable, Traversable, Show, Eq, Ord, Generic1)
    deriving Applicative via Generically1 Sides

data SrcContent = SrcContent
    { lineNo :: Int
    , content :: String
    } deriving Show

data Conflict = Conflict
    { markers   :: Sides SrcContent -- The markers at the beginning of sections
    , markerEnd :: SrcContent       -- The ">>>>>>>...." marker at the end of the conflict
    , bodies    :: Sides [String]
    } deriving Show

setBodies :: (Sides [String] -> Sides [String]) -> Conflict -> Conflict
setBodies f c = c{bodies = f c.bodies}

setEachBody :: ([String] -> [String]) -> Conflict -> Conflict
setEachBody = setBodies . fmap

setStrings :: (String -> String) -> Conflict -> Conflict
setStrings = setEachBody . map

prettyLines :: Conflict -> [String]
prettyLines c =
    concat ((:) <$> ((.content) <$> c.markers) <*> c.bodies) <> [c.markerEnd.content]

pretty :: Conflict -> String
pretty = unlines . prettyLines

breakUpToMarker ::
    MonadState [SrcContent] m =>
    Char -> Maybe Int -> m [SrcContent]
breakUpToMarker c mCount =
    state (break cond)
    where
        count = fromMaybe 7 mCount
        prefix = replicate count c
        cond l =
            pre == prefix && rightCount
            where
                (pre, post) = splitAt count l.content
                rightCount =
                    case (mCount, post) of
                    (Just{}, x:_) -> c /= x
                    _ -> True

readHead :: MonadState [a] m => m (Maybe a)
readHead = state f
    where
        f [] = (Nothing, [])
        f (l:ls) = (Just l, ls)

tryReadUpToMarker ::
    MonadState [SrcContent] m =>
    Char -> Maybe Int -> m ([SrcContent], Maybe SrcContent)
tryReadUpToMarker c mCount =
    (,) <$> breakUpToMarker c mCount <*> readHead

readUpToMarker ::
    MonadState [SrcContent] m =>
    Char -> Maybe Int -> m ([SrcContent], SrcContent)
readUpToMarker c mCount = do
    res <- tryReadUpToMarker c mCount
    case res of
        (ls, Just h)  -> pure (ls, h)
        (ls, Nothing) ->
            error $ concat
            [ "Parse error: failed reading up to marker: "
            , show c, ", got:"
            , concatMap (\l -> "\n" ++ show l.lineNo ++ "\t" ++ l.content) $ take 5 ls
            ]

parseConflict :: MonadState [SrcContent] m => SrcContent -> m Conflict
parseConflict markerA =
    do  (linesA   , markerBase) <- readUpToMarker '|' markerCount
        (linesBase, markerB)    <- readUpToMarker '=' markerCount
        (linesB   , markerEnd)  <- readUpToMarker '>' markerCount
        pure Conflict
            { markers    = Sides markerA markerBase markerB
            , markerEnd
            , bodies     = fmap (.content) <$> Sides linesA linesBase linesB
            }
    where
        markerCount = Just (length (takeWhile (== '<') markerA.content))

parseFromNumberedLines :: [SrcContent] -> [Either String Conflict]
parseFromNumberedLines =
    snd . runWriter . evalStateT loop
    where
        loop =
            do  (ls, mMarkerA) <- tryReadUpToMarker '<' Nothing
                tell $ map (Left . (.content)) ls
                case mMarkerA of
                    Nothing -> pure ()
                    Just markerA ->
                        do  tell . pure . Right =<< parseConflict markerA
                            loop

parse :: String -> [Either String Conflict]
parse = parseFromNumberedLines . zipWith SrcContent [1..] . lines