module Filediff
(
diffLists
, applyListDiff
, diffFiles
, applyFileDiff
, diffDirectories
, diffDirectoriesWithIgnoredSubdirs
, applyDirectoryDiff
) where
import Debug.Trace
import qualified Data.HashMap as HMap
import Control.Concurrent (forkIO)
import Control.Concurrent.Thread as Thread (Result(..), result)
import Control.Concurrent.Thread.Group as ThreadGroup (new, forkIO, wait)
import qualified System.IO as IO
import qualified System.Directory as D
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import qualified Data.MemoCombinators as Memo
import Data.Either.Combinators
import Data.Maybe (isJust, fromJust, catMaybes)
import Data.List ((\\), intersect)
import Data.Monoid
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Either
import Control.Monad.IO.Class (liftIO)
import Filediff.Types
import Filediff.Utils
( (</>)
, (<.>)
, getFileDirectory
, removeDotDirs
, createFileWithContents
, dropUntil
, removeFirstPathComponent
, removePathComponents
, getDirectoryContentsRecursiveSafe
, isPrefix
, dropPrefix
, dropInitialSlash
, dropTrailingSlash )
diffFiles :: FilePath -> FilePath -> IO Filediff
diffFiles a b = do
aIsDir <- D.doesDirectoryExist a
bIsDir <- D.doesDirectoryExist b
when (aIsDir || bIsDir) $ error $ "One or both of " ++ a ++ " and " ++ b ++ "is not a file, but a directory."
aExists <- D.doesFileExist a
bExists <- D.doesFileExist b
case (aExists, bExists) of
(False, False) -> return $ Filediff a b mempty
(False, True ) -> addCase
(True , False) -> delCase
(True , True ) -> modCase
where
addCase :: IO Filediff
addCase = do
let aLines = []
bLines <- T.lines <$> TIO.readFile b
return Filediff
{ base = a
, comp = b
, change = Add $ diffLists aLines bLines }
delCase :: IO Filediff
delCase = do
aLines <- T.lines <$> TIO.readFile a
let bLines = []
return Filediff
{ base = a
, comp = b
, change = Del $ diffLists aLines bLines }
modCase :: IO Filediff
modCase = do
aLines <- T.lines <$> TIO.readFile a
bLines <- T.lines <$> TIO.readFile b
return Filediff
{ base = a
, comp = b
, change = Mod $ diffLists aLines bLines }
diffDirectories :: FilePath -> FilePath -> IO Diff
diffDirectories a b = diffDirectoriesWithIgnoredSubdirs a b [] []
diffDirectoriesWithIgnoredSubdirs :: FilePath -> FilePath -> [FilePath] -> [FilePath] -> IO Diff
diffDirectoriesWithIgnoredSubdirs a' b' aToIgnore bToIgnore = do
aIsFile <- D.doesFileExist a
bIsFile <- D.doesFileExist b
when (aIsFile || bIsFile) $ error $ "One or both of " ++ a ++ " and " ++ b ++ "is not a directory, but a file."
aContents' <- getDirectoryContentsRecursiveSafe a
bContents' <- getDirectoryContentsRecursiveSafe b
let aContents = filter (not . shouldIgnore aToIgnore) aContents'
let bContents = filter (not . shouldIgnore bToIgnore) bContents'
intersectionDiffs <- getDiffs $ intersect aContents bContents
aOnlyDiffs <- getDiffs $ aContents \\ bContents
bOnlyDiffs <- getDiffs $ bContents \\ aContents
let allDiffs = map makeRelative $ intersectionDiffs ++ aOnlyDiffs ++ bOnlyDiffs
return $ Diff allDiffs
where
a :: FilePath
a = dropTrailingSlash a'
b :: FilePath
b = dropTrailingSlash b'
getDiffs :: [FilePath] -> IO [Filediff]
getDiffs filepaths
= filter (not . isIdentityFileDiff)
<$> mapM (\fp -> diffFiles (a </> fp) (b </> fp)) filepaths
isIdentityFileDiff :: Filediff -> Bool
isIdentityFileDiff = (==) mempty . change
makeRelative :: Filediff -> Filediff
makeRelative (Filediff base comp change) =
Filediff
(dropInitialSlash $ dropPrefix a base)
(dropInitialSlash $ dropPrefix b comp)
change
shouldIgnore :: [FilePath] -> FilePath -> Bool
shouldIgnore toIgnore filepath = any (flip isPrefix $ filepath) toIgnore
applyFileDiff :: Filediff -> FilePath -> EitherT Error IO [Line]
applyFileDiff (Filediff _ _ change) filepath = do
case change of
Del _ -> delCase
Mod listdiff -> modCase listdiff
Add listdiff -> addCase listdiff
where
delCase :: EitherT Error IO [Line]
delCase = liftIO (D.removeFile filepath) >> right []
addCase :: ListDiff Line -> EitherT Error IO [Line]
addCase listDiff = liftIO (createFileWithContents filepath "") >> modCase listDiff
modCase :: ListDiff Line -> EitherT Error IO [Line]
modCase listDiff = do
file <- liftIO (TIO.readFile filepath)
result <- hoistEither (applyListDiff listDiff . T.lines $ file)
liftIO (TIO.writeFile filepath (safeInit . T.unlines $ result))
right result
safeInit :: T.Text -> T.Text
safeInit x = if T.null x then x else T.init x
applyDirectoryDiff :: Diff -> FilePath -> EitherT Error IO [[Line]]
applyDirectoryDiff (Diff filediffs) filepath
= EitherT
. fmap sequence
$ mapMParallelWaitForAll (runEitherT . apply) filediffs >>= mapM Thread.result
where
apply :: Filediff -> EitherT Error IO [Line]
apply diff@(Filediff base compare _)
= applyFileDiff diff (filepath </> base)
mapMParallelWaitForAll :: (a -> IO b) -> [a] -> IO [Thread.Result b]
mapMParallelWaitForAll f list = do
group <- ThreadGroup.new
ioResults <- mapM (fmap snd . ThreadGroup.forkIO group . f) list
ThreadGroup.wait group
sequence ioResults
diffLists :: forall a. (Eq a) => [a] -> [a] -> ListDiff a
diffLists a b = ListDiff
(map (\i -> (i, a !! i)) $ nonSubsequenceIndices common a)
(getProgressiveIndicesToAdd common b)
where
common :: [a]
common = longestCommonSubsequenceWrapper a b
getProgressiveIndicesToAdd :: [a] -> [a] -> [(Int, a)]
getProgressiveIndicesToAdd sub super =
map (\i -> (i, super !! i)) $ nonSubsequenceIndices sub super
applyListDiff :: forall a. (Eq a) => ListDiff a -> [a] -> Either Error [a]
applyListDiff l@(ListDiff dels adds) list =
removeAtIndices dels list >>= insertAtProgressiveIndices adds
insertAtProgressiveIndices :: [(Int, a)] -> [a] -> Either Error [a]
insertAtProgressiveIndices = insertAtProgressiveIndices' 0
insertAtProgressiveIndices' :: Int -> [(Int, a)] -> [a] -> Either Error [a]
insertAtProgressiveIndices' _ [] dest = Right dest
insertAtProgressiveIndices' curr src@((i,s):src') dest =
if i == curr
then (:) s <$> insertAtProgressiveIndices' (succ curr) src' dest
else case dest of
(d:dest') -> (:) d <$> insertAtProgressiveIndices' (succ curr) src dest'
[] -> Left "Fatal: couldn't apply list diff (application requires inserting at an index larger than the length of the list to which to apply the diff)."
longestCommonSubsequenceWrapper :: forall a. (Eq a) => [a] -> [a] -> [a]
longestCommonSubsequenceWrapper xs ys =
if xs == ys
then xs
else commonPrefix
++ longestCommonSubsequence (getMiddle xs) (getMiddle ys)
++ commonSuffix
where
commonPrefix :: [a]
commonPrefix = getCommonPrefix xs ys
commonSuffix :: [a]
commonSuffix = reverse
(getCommonPrefix
(reverse (drop (length commonPrefix) xs))
(reverse (drop (length commonPrefix) ys)))
getCommonPrefix :: [a] -> [a] -> [a]
getCommonPrefix as bs = map fst . takeWhile (uncurry (==)) $ zip as bs
getMiddle :: [a] -> [a]
getMiddle elems = take (length elems length commonPrefix length commonSuffix) . drop (length commonPrefix) $ elems
longestCommonSubsequence :: forall a. (Eq a) => [a] -> [a] -> [a]
longestCommonSubsequence xs ys = longestCommonSubsequence' 0 0
where
xs' :: HMap.Map Int a
xs' = foldl update HMap.empty (zip [0..] xs)
ys' :: HMap.Map Int a
ys' = foldl update HMap.empty (zip [0..] ys)
update :: HMap.Map Int a -> (Int, a) -> HMap.Map Int a
update hmap (i, a) = HMap.insert i a hmap
xsLength :: Int
xsLength = length xs
ysLength :: Int
ysLength = length ys
longestCommonSubsequence' :: Int -> Int -> [a]
longestCommonSubsequence' = Memo.memo2 Memo.integral Memo.integral longestCommonSubsequence''
longestCommonSubsequence'' :: Int -> Int -> [a]
longestCommonSubsequence'' i j
| i == xsLength = []
| j == ysLength = []
| x == y = x : longestCommonSubsequence' (i + 1) (j + 1)
| length caseX > length caseY = caseX
| otherwise = caseY
where
x :: a
x = xs' HMap.! i
y :: a
y = ys' HMap.! j
caseX :: [a]
caseX = longestCommonSubsequence' (i + 1) j
caseY :: [a]
caseY = longestCommonSubsequence' i (j + 1)
subsequenceIndices :: (Eq a) => [a] -> [a] -> [Int]
subsequenceIndices [] _ = []
subsequenceIndices _ [] = error "`sub` was not a subsequence of `super`"
subsequenceIndices sub@(a:sub') super@(b:super') =
if a == b
then 0 : map succ (subsequenceIndices sub' super')
else map succ (subsequenceIndices sub super')
nonSubsequenceIndices :: (Eq a) => [a] -> [a] -> [Int]
nonSubsequenceIndices sub super =
[0..(length super 1)] \\ (subsequenceIndices sub super)
removeAtIndices :: forall a. (Eq a) => [(Int, a)] -> [a] -> Either Error [a]
removeAtIndices dels list = if not matches
then Left "Fatal: couldn't apply list diff (application requires removing an element where the diff calls for a different element residing at that index)."
else Right (removeAtIndices' 0 (map fst dels) list)
where
matches :: Bool
matches = all (< length list) (map fst dels)
&& all (\(i, ch) -> (list !! i) == ch) dels
removeAtIndices' :: Int -> [Int] -> [a] -> [a]
removeAtIndices' _ [] xs = xs
removeAtIndices' curr (i:is) (x:xs) =
if curr == i
then removeAtIndices' (succ curr) is xs
else x : removeAtIndices' (succ curr) (i:is) xs