{-# 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 { forall wX. FileState wX -> [Maybe ByteString]
content :: [Maybe B.ByteString] }

-- | An infinite list of undefined lines.
unknownFileState :: FileState wX
unknownFileState :: forall wX. FileState wX
unknownFileState = forall wX. [Maybe ByteString] -> FileState wX
FileState (forall a. a -> [a]
repeat 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 :: forall wX wY. FileHunk wX wY -> FileState wX -> FileState wY
applyHunk (FileHunk AnchoredPath
_ Int
line [ByteString]
old [ByteString]
new) = forall wX. [Maybe ByteString] -> FileState wX
FileState forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe ByteString] -> [Maybe ByteString]
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall wX. FileState wX -> [Maybe ByteString]
content
  where
    go :: [Maybe ByteString] -> [Maybe ByteString]
go [Maybe ByteString]
mls =
      case forall a. Int -> [a] -> ([a], [a])
splitAt (Int
line forall a. Num a => a -> a -> a
- Int
1) [Maybe ByteString]
mls of
        ([Maybe ByteString]
before, [Maybe ByteString]
rest) ->
          forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Maybe ByteString]
before, forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Maybe a
Just [ByteString]
new, forall a. Int -> [a] -> [a]
drop (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 :: forall wX wY. FL FileHunk wX wY -> FileState wX -> FileState wY
applyHunks FL FileHunk wX wY
NilFL = forall a. a -> a
id
applyHunks (FileHunk wX wY
p:>:FL FileHunk wY wY
ps) = forall wX wY. FL FileHunk wX wY -> FileState wX -> FileState wY
applyHunks FL FileHunk wY wY
ps forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall wX wY. FileHunk wX wY -> FileState wX -> FileState wY
applyHunk FileHunk wX wY
p


instance PrimMangleUnravelled Prim where
  mangleUnravelled :: forall wX. Unravelled Prim wX -> Maybe (Mangled Prim wX)
mangleUnravelled Unravelled Prim wX
pss = do
      [Sealed (FL FileHunk wX)]
hunks <- forall (prim :: * -> * -> *) wX.
IsHunk prim =>
[Sealed (FL prim wX)] -> Maybe [Sealed (FL FileHunk wX)]
onlyHunks Unravelled Prim wX
pss
      AnchoredPath
filename <- forall a. [a] -> Maybe a
listToMaybe (forall {wX}. [Sealed (FL Prim wX)] -> [AnchoredPath]
filenames Unravelled Prim wX
pss)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal ((forall (a :: * -> * -> *) wX wX wZ.
a wX wX -> FL a wX wZ -> FL a wX wZ
:>: forall (a :: * -> * -> *) wX. FL a wX wX
NilFL) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (prim :: * -> * -> *) wX wY.
PrimConstruct prim =>
FileHunk wX wY -> prim wX wY
primFromHunk) forall a b. (a -> b) -> a -> b
$ 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 = forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall (a :: * -> *) b. (forall wX. a wX -> b) -> Sealed a -> b
unseal 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 :: forall (prim :: * -> * -> *) wX.
IsHunk prim =>
[Sealed (FL prim wX)] -> Maybe [Sealed (FL FileHunk wX)]
onlyHunks = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall wA. Sealed (FL prim wA) -> Maybe (Sealed (FL FileHunk wA))
toHunk where
        toHunk :: Sealed (FL prim wA) -> Maybe (Sealed (FL FileHunk wA))
        toHunk :: forall wA. Sealed (FL prim wA) -> Maybe (Sealed (FL FileHunk wA))
toHunk (Sealed FL prim wA wX
ps) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (a :: * -> *) wX. a wX -> Sealed a
Sealed forall a b. (a -> b) -> a -> b
$ 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 (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 :: forall wX.
AnchoredPath -> [Sealed (FL FileHunk wX)] -> Sealed (FileHunk wX)
mangleHunks AnchoredPath
_ [] = forall a. HasCallStack => [Char] -> a
error [Char]
"mangleHunks called with empty list of alternatives"
      mangleHunks AnchoredPath
path [Sealed (FL FileHunk wX)]
ps = forall (a :: * -> *) wX. a wX -> Sealed a
Sealed (forall wX wY.
AnchoredPath
-> Int -> [ByteString] -> [ByteString] -> FileHunk wX wY
FileHunk AnchoredPath
path Int
l [ByteString]
old [ByteString]
new)
        where
          oldf :: FileState wX
oldf    = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall wX. FileState wX -> Sealed (FL FileHunk wX) -> FileState wX
oldFileState forall wX. FileState wX
unknownFileState [Sealed (FL FileHunk wX)]
ps
          newfs :: [Sealed FileState]
newfs   = forall a b. (a -> b) -> [a] -> [b]
map (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 (forall (a :: * -> *) wX. a wX -> Sealed a
Sealed FileState wX
oldf forall a. a -> [a] -> [a]
: [Sealed FileState]
newfs)
          nchs :: [[ByteString]]
nchs    = forall a. Ord a => [a] -> [a]
sort (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 (forall (a :: * -> *) wX. a wX -> Sealed a
Sealed FileState wX
oldf)
          new :: [ByteString]
new     = [ByteString
top] forall a. [a] -> [a] -> [a]
++ [ByteString]
old forall a. [a] -> [a] -> [a]
++ [ByteString
initial] forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate [ByteString
middle] [[ByteString]]
nchs forall a. [a] -> [a] -> [a]
++ [ByteString
bottom]
          top :: ByteString
top     = [Char] -> ByteString
BC.pack ([Char]
"v v v v v v v" forall a. [a] -> [a] -> [a]
++ [Char]
eol_c)
          initial :: ByteString
initial = [Char] -> ByteString
BC.pack ([Char]
"=============" forall a. [a] -> [a] -> [a]
++ [Char]
eol_c)
          middle :: ByteString
middle  = [Char] -> ByteString
BC.pack ([Char]
"*************" forall a. [a] -> [a] -> [a]
++ [Char]
eol_c)
          bottom :: ByteString
bottom  = [Char] -> ByteString
BC.pack ([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 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 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 :: forall wX. FileState wX -> Sealed (FL FileHunk wX) -> FileState wX
oldFileState FileState wX
mls (Sealed FL FileHunk wX wX
ps) = forall wX wY. FL FileHunk wX wY -> FileState wX -> FileState wY
applyHunks (FL FileHunk wX wX
ps forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ 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 :: forall wX.
FileState wX -> Sealed (FL FileHunk wX) -> Sealed FileState
newFileState FileState wX
mls (Sealed FL FileHunk wX wX
ps) = forall (a :: * -> *) wX. a wX -> Sealed a
Sealed (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 = forall {t} {a}. Num t => t -> [[Maybe a]] -> t
go Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (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 forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head) [[Maybe a]]
pps
              then t
n
              else t -> [[Maybe a]] -> t
go (t
n forall a. Num a => a -> a -> a
+ t
1) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map 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 = forall {a}. [Maybe a] -> [a]
takeWhileJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop (Int
n forall a. Num a => a -> a -> a
- Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Maybe a
x [a]
acc -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a. a -> [a] -> [a]
:[a]
acc) Maybe a
x) []