{-# 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) []