{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Darcs.Patch.Prim.V1.Mangle () where

import Darcs.Prelude

import qualified Data.ByteString.Char8 as BC (pack, last)
import qualified Data.ByteString as B (null, ByteString)
import Data.Maybe ( isJust, listToMaybe )
import Data.List ( sort, intercalate, nub )

import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk(..) )
import Darcs.Patch.Inspect ( PatchInspect(listTouchedFiles) )
import Darcs.Patch.Invert ( Invert(..) )
import Darcs.Patch.Prim.Class
    ( PrimConstruct(primFromHunk)
    , PrimMangleUnravelled(..)
    )
import Darcs.Patch.Prim.V1.Core ( Prim )
import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+), mapFL_FL_M )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal, unseal )

import Darcs.Util.Path ( AnchoredPath )

-- | The state of a single file as far as we know it. 'Nothing'
-- means we don't know the content of a particular line.
newtype FileState wX = FileState { FileState wX -> [Maybe ByteString]
content :: [Maybe B.ByteString] }

-- | An infinite list of undefined lines.
unknownFileState :: FileState wX
unknownFileState :: FileState wX
unknownFileState = [Maybe ByteString] -> FileState wX
forall wX. [Maybe ByteString] -> FileState wX
FileState (Maybe ByteString -> [Maybe ByteString]
forall a. a -> [a]
repeat Maybe ByteString
forall a. Maybe a
Nothing)

-- | Note that @applyHunk p . applyHunk (invert p) /= id@: it converts
-- undefined lines ('Nothing') to defined ones ('Just' the old content of @p@).
applyHunk :: FileHunk wX wY -> FileState wX -> FileState wY
applyHunk :: FileHunk wX wY -> FileState wX -> FileState wY
applyHunk (FileHunk AnchoredPath
_ Int
line [ByteString]
old [ByteString]
new) = [Maybe ByteString] -> FileState wY
forall wX. [Maybe ByteString] -> FileState wX
FileState ([Maybe ByteString] -> FileState wY)
-> (FileState wX -> [Maybe ByteString])
-> FileState wX
-> FileState wY
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe ByteString] -> [Maybe ByteString]
go ([Maybe ByteString] -> [Maybe ByteString])
-> (FileState wX -> [Maybe ByteString])
-> FileState wX
-> [Maybe ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileState wX -> [Maybe ByteString]
forall wX. FileState wX -> [Maybe ByteString]
content
  where
    go :: [Maybe ByteString] -> [Maybe ByteString]
go [Maybe ByteString]
mls =
      case Int
-> [Maybe ByteString] -> ([Maybe ByteString], [Maybe ByteString])
forall a. Int -> [a] -> ([a], [a])
splitAt (Int
line Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Maybe ByteString]
mls of
        ([Maybe ByteString]
before, [Maybe ByteString]
rest) ->
          [[Maybe ByteString]] -> [Maybe ByteString]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Maybe ByteString]
before, (ByteString -> Maybe ByteString)
-> [ByteString] -> [Maybe ByteString]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just [ByteString]
new, Int -> [Maybe ByteString] -> [Maybe ByteString]
forall a. Int -> [a] -> [a]
drop ([ByteString] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
old) [Maybe ByteString]
rest]

-- | Iterate 'applyHunk'.
applyHunks :: FL FileHunk wX wY -> FileState wX -> FileState wY
applyHunks :: FL FileHunk wX wY -> FileState wX -> FileState wY
applyHunks FL FileHunk wX wY
NilFL = FileState wX -> FileState wY
forall a. a -> a
id
applyHunks (FileHunk wX wY
p:>:FL FileHunk wY wY
ps) = FL FileHunk wY wY -> FileState wY -> FileState wY
forall wX wY. FL FileHunk wX wY -> FileState wX -> FileState wY
applyHunks FL FileHunk wY wY
ps (FileState wY -> FileState wY)
-> (FileState wX -> FileState wY) -> FileState wX -> FileState wY
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileHunk wX wY -> FileState wX -> FileState wY
forall wX wY. FileHunk wX wY -> FileState wX -> FileState wY
applyHunk FileHunk wX wY
p


instance PrimMangleUnravelled Prim where
  mangleUnravelled :: Unravelled Prim wX -> Maybe (Mangled Prim wX)
mangleUnravelled Unravelled Prim wX
pss = do
      [Sealed (FL FileHunk wX)]
hunks <- Unravelled Prim wX -> Maybe [Sealed (FL FileHunk wX)]
forall (prim :: * -> * -> *) wX.
IsHunk prim =>
[Sealed (FL prim wX)] -> Maybe [Sealed (FL FileHunk wX)]
onlyHunks Unravelled Prim wX
pss
      AnchoredPath
filename <- [AnchoredPath] -> Maybe AnchoredPath
forall a. [a] -> Maybe a
listToMaybe (Unravelled Prim wX -> [AnchoredPath]
forall wX. [Sealed (FL Prim wX)] -> [AnchoredPath]
filenames Unravelled Prim wX
pss)
      Mangled Prim wX -> Maybe (Mangled Prim wX)
forall (m :: * -> *) a. Monad m => a -> m a
return (Mangled Prim wX -> Maybe (Mangled Prim wX))
-> Mangled Prim wX -> Maybe (Mangled Prim wX)
forall a b. (a -> b) -> a -> b
$ (forall wX. FileHunk wX wX -> FL Prim wX wX)
-> Sealed (FileHunk wX) -> Mangled Prim wX
forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal ((Prim wX wX -> FL Prim wX wX -> FL Prim wX wX
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL Prim wX wX
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL) (Prim wX wX -> FL Prim wX wX)
-> (FileHunk wX wX -> Prim wX wX)
-> FileHunk wX wX
-> FL Prim wX wX
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileHunk wX wX -> Prim wX wX
forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
FileHunk wX wY -> prim wX wY
primFromHunk) (Sealed (FileHunk wX) -> Mangled Prim wX)
-> Sealed (FileHunk wX) -> Mangled Prim wX
forall a b. (a -> b) -> a -> b
$ AnchoredPath -> [Sealed (FL FileHunk wX)] -> Sealed (FileHunk wX)
forall wX.
AnchoredPath -> [Sealed (FL FileHunk wX)] -> Sealed (FileHunk wX)
mangleHunks AnchoredPath
filename [Sealed (FL FileHunk wX)]
hunks
    where
      -- | The names of all touched files.
      filenames :: [Sealed (FL Prim wX)] -> [AnchoredPath]
filenames = [AnchoredPath] -> [AnchoredPath]
forall a. Eq a => [a] -> [a]
nub ([AnchoredPath] -> [AnchoredPath])
-> ([Sealed (FL Prim wX)] -> [AnchoredPath])
-> [Sealed (FL Prim wX)]
-> [AnchoredPath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Sealed (FL Prim wX) -> [AnchoredPath])
-> [Sealed (FL Prim wX)] -> [AnchoredPath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((forall wX. FL Prim wX wX -> [AnchoredPath])
-> Sealed (FL Prim wX) -> [AnchoredPath]
forall (a :: * -> *) b. (forall wX. a wX -> b) -> Sealed a -> b
unseal forall wX. FL Prim wX wX -> [AnchoredPath]
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [AnchoredPath]
listTouchedFiles)

      -- | Convert every prim in the input to a 'FileHunk', or fail.
      onlyHunks :: forall prim wX. IsHunk prim
                => [Sealed (FL prim wX)]
                -> Maybe [Sealed (FL FileHunk wX)]
      onlyHunks :: [Sealed (FL prim wX)] -> Maybe [Sealed (FL FileHunk wX)]
onlyHunks = (Sealed (FL prim wX) -> Maybe (Sealed (FL FileHunk wX)))
-> [Sealed (FL prim wX)] -> Maybe [Sealed (FL FileHunk wX)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Sealed (FL prim wX) -> Maybe (Sealed (FL FileHunk wX))
forall wA. Sealed (FL prim wA) -> Maybe (Sealed (FL FileHunk wA))
toHunk where
        toHunk :: Sealed (FL prim wA) -> Maybe (Sealed (FL FileHunk wA))
        toHunk :: Sealed (FL prim wA) -> Maybe (Sealed (FL FileHunk wA))
toHunk (Sealed FL prim wA wX
ps) = (FL FileHunk wA wX -> Sealed (FL FileHunk wA))
-> Maybe (FL FileHunk wA wX) -> Maybe (Sealed (FL FileHunk wA))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FL FileHunk wA wX -> Sealed (FL FileHunk wA)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed (Maybe (FL FileHunk wA wX) -> Maybe (Sealed (FL FileHunk wA)))
-> Maybe (FL FileHunk wA wX) -> Maybe (Sealed (FL FileHunk wA))
forall a b. (a -> b) -> a -> b
$ (forall wW wY. prim wW wY -> Maybe (FileHunk wW wY))
-> FL prim wA wX -> Maybe (FL FileHunk wA wX)
forall (m :: * -> *) (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
Monad m =>
(forall wW wY. a wW wY -> m (b wW wY))
-> FL a wX wZ -> m (FL b wX wZ)
mapFL_FL_M forall wW wY. prim wW wY -> Maybe (FileHunk wW wY)
forall (p :: * -> * -> *) wX wY.
IsHunk p =>
p wX wY -> Maybe (FileHunk wX wY)
isHunk FL prim wA wX
ps

      -- | Mangle a list of hunks, returning a single hunk.
      -- Note: the input list consists of 'FL's because when commuting conflicts
      -- to the head we may accumulate dependencies. In fact, the patches in all
      -- of the given (mutually conflicting) 'FL's should coalesce to a single hunk.
      mangleHunks :: AnchoredPath -> [Sealed (FL FileHunk wX)] -> Sealed (FileHunk wX)
      mangleHunks :: AnchoredPath -> [Sealed (FL FileHunk wX)] -> Sealed (FileHunk wX)
mangleHunks AnchoredPath
_ [] = [Char] -> Sealed (FileHunk wX)
forall a. HasCallStack => [Char] -> a
error [Char]
"mangleHunks called with empty list of alternatives"
      mangleHunks AnchoredPath
path [Sealed (FL FileHunk wX)]
ps = FileHunk wX Any -> Sealed (FileHunk wX)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed (AnchoredPath
-> Int -> [ByteString] -> [ByteString] -> FileHunk wX Any
forall wX wY.
AnchoredPath
-> Int -> [ByteString] -> [ByteString] -> FileHunk wX wY
FileHunk AnchoredPath
path Int
l [ByteString]
old [ByteString]
new)
        where
          oldf :: FileState wX
oldf    = (FileState wX -> Sealed (FL FileHunk wX) -> FileState wX)
-> FileState wX -> [Sealed (FL FileHunk wX)] -> FileState wX
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl FileState wX -> Sealed (FL FileHunk wX) -> FileState wX
forall wX. FileState wX -> Sealed (FL FileHunk wX) -> FileState wX
oldFileState FileState wX
forall wX. FileState wX
unknownFileState [Sealed (FL FileHunk wX)]
ps
          newfs :: [Sealed FileState]
newfs   = (Sealed (FL FileHunk wX) -> Sealed FileState)
-> [Sealed (FL FileHunk wX)] -> [Sealed FileState]
forall a b. (a -> b) -> [a] -> [b]
map (FileState wX -> Sealed (FL FileHunk wX) -> Sealed FileState
forall wX.
FileState wX -> Sealed (FL FileHunk wX) -> Sealed FileState
newFileState FileState wX
oldf) [Sealed (FL FileHunk wX)]
ps
          l :: Int
l       = [Sealed FileState] -> Int
getHunkline (FileState wX -> Sealed FileState
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed FileState wX
oldf Sealed FileState -> [Sealed FileState] -> [Sealed FileState]
forall a. a -> [a] -> [a]
: [Sealed FileState]
newfs)
          nchs :: [[ByteString]]
nchs    = [[ByteString]] -> [[ByteString]]
forall a. Ord a => [a] -> [a]
sort ((Sealed FileState -> [ByteString])
-> [Sealed FileState] -> [[ByteString]]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Sealed FileState -> [ByteString]
makeChunk Int
l) [Sealed FileState]
newfs)
          old :: [ByteString]
old     = Int -> Sealed FileState -> [ByteString]
makeChunk Int
l (FileState wX -> Sealed FileState
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed FileState wX
oldf)
          new :: [ByteString]
new     = [ByteString
top] [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString]
old [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString
initial] [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString] -> [[ByteString]] -> [ByteString]
forall a. [a] -> [[a]] -> [a]
intercalate [ByteString
middle] [[ByteString]]
nchs [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString
bottom]
          top :: ByteString
top     = [Char] -> ByteString
BC.pack ([Char]
"v v v v v v v" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
eol_c)
          initial :: ByteString
initial = [Char] -> ByteString
BC.pack ([Char]
"=============" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
eol_c)
          middle :: ByteString
middle  = [Char] -> ByteString
BC.pack ([Char]
"*************" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
eol_c)
          bottom :: ByteString
bottom  = [Char] -> ByteString
BC.pack ([Char]
"^ ^ ^ ^ ^ ^ ^" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
eol_c)
          -- simple heuristic to infer the line ending convention from patch contents
          eol_c :: [Char]
eol_c   =
            if (ByteString -> Bool) -> [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ByteString
line -> Bool -> Bool
not (ByteString -> Bool
B.null ByteString
line) Bool -> Bool -> Bool
&& ByteString -> Char
BC.last ByteString
line Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r') [ByteString]
old
              then [Char]
"\r"
              else [Char]
""

      -- | Apply the patches and their inverse. This turns all lines touched
      -- by the 'FL' of patches into defined lines with their "old" values.
      oldFileState :: FileState wX -> Sealed (FL FileHunk wX) -> FileState wX
      oldFileState :: FileState wX -> Sealed (FL FileHunk wX) -> FileState wX
oldFileState FileState wX
mls (Sealed FL FileHunk wX wX
ps) = FL FileHunk wX wX -> FileState wX -> FileState wX
forall wX wY. FL FileHunk wX wY -> FileState wX -> FileState wY
applyHunks (FL FileHunk wX wX
ps FL FileHunk wX wX -> FL FileHunk wX wX -> FL FileHunk wX wX
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL FileHunk wX wX -> FL FileHunk wX wX
forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert FL FileHunk wX wX
ps) FileState wX
mls

      -- | This is @flip 'applyHunks'@ under 'Sealed'.
      newFileState :: FileState wX -> Sealed (FL FileHunk wX) -> Sealed FileState
      newFileState :: FileState wX -> Sealed (FL FileHunk wX) -> Sealed FileState
newFileState FileState wX
mls (Sealed FL FileHunk wX wX
ps) = FileState wX -> Sealed FileState
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed (FL FileHunk wX wX -> FileState wX -> FileState wX
forall wX wY. FL FileHunk wX wY -> FileState wX -> FileState wY
applyHunks FL FileHunk wX wX
ps FileState wX
mls)

      -- Index of the first line touched by any of the FileStates (1-based).
      getHunkline :: [Sealed FileState] -> Int
      getHunkline :: [Sealed FileState] -> Int
getHunkline = Int -> [[Maybe ByteString]] -> Int
forall t a. Num t => t -> [[Maybe a]] -> t
go Int
1 ([[Maybe ByteString]] -> Int)
-> ([Sealed FileState] -> [[Maybe ByteString]])
-> [Sealed FileState]
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Sealed FileState -> [Maybe ByteString])
-> [Sealed FileState] -> [[Maybe ByteString]]
forall a b. (a -> b) -> [a] -> [b]
map ((forall wX. FileState wX -> [Maybe ByteString])
-> Sealed FileState -> [Maybe ByteString]
forall (a :: * -> *) b. (forall wX. a wX -> b) -> Sealed a -> b
unseal forall wX. FileState wX -> [Maybe ByteString]
content)
        where
          -- head and tail are safe here because all inner lists are infinite
          go :: t -> [[Maybe a]] -> t
go t
n [[Maybe a]]
pps =
            if ([Maybe a] -> Bool) -> [[Maybe a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Maybe a -> Bool
forall a. Maybe a -> Bool
isJust (Maybe a -> Bool) -> ([Maybe a] -> Maybe a) -> [Maybe a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe a] -> Maybe a
forall a. [a] -> a
head) [[Maybe a]]
pps
              then t
n
              else t -> [[Maybe a]] -> t
go (t
n t -> t -> t
forall a. Num a => a -> a -> a
+ t
1) ([[Maybe a]] -> t) -> [[Maybe a]] -> t
forall a b. (a -> b) -> a -> b
$ ([Maybe a] -> [Maybe a]) -> [[Maybe a]] -> [[Maybe a]]
forall a b. (a -> b) -> [a] -> [b]
map [Maybe a] -> [Maybe a]
forall a. [a] -> [a]
tail [[Maybe a]]
pps

      -- | The chunk of defined lines starting at the given position (1-based).
      makeChunk :: Int -> Sealed FileState -> [B.ByteString]
      makeChunk :: Int -> Sealed FileState -> [ByteString]
makeChunk Int
n = [Maybe ByteString] -> [ByteString]
forall a. [Maybe a] -> [a]
takeWhileJust ([Maybe ByteString] -> [ByteString])
-> (Sealed FileState -> [Maybe ByteString])
-> Sealed FileState
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Maybe ByteString] -> [Maybe ByteString]
forall a. Int -> [a] -> [a]
drop (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ([Maybe ByteString] -> [Maybe ByteString])
-> (Sealed FileState -> [Maybe ByteString])
-> Sealed FileState
-> [Maybe ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall wX. FileState wX -> [Maybe ByteString])
-> Sealed FileState -> [Maybe ByteString]
forall (a :: * -> *) b. (forall wX. a wX -> b) -> Sealed a -> b
unseal forall wX. FileState wX -> [Maybe ByteString]
content
        where
          -- stolen from utility-ht, thanks Henning!
          takeWhileJust :: [Maybe a] -> [a]
takeWhileJust = (Maybe a -> [a] -> [a]) -> [a] -> [Maybe a] -> [a]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Maybe a
x [a]
acc -> [a] -> (a -> [a]) -> Maybe a -> [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
acc) Maybe a
x) []