diff --git a/Data/Git/Delta.hs b/Data/Git/Delta.hs --- a/Data/Git/Delta.hs +++ b/Data/Git/Delta.hs @@ -5,6 +5,7 @@ -- Stability : experimental -- Portability : unix -- +{-# LANGUAGE BangPatterns #-} module Data.Git.Delta ( Delta(..) , DeltaCmd(..) @@ -22,13 +23,13 @@ import Data.Git.Imports -- | a delta is a source size, a destination size and a list of delta cmd -data Delta = Delta Word64 Word64 [DeltaCmd] +data Delta = Delta !Word64 !Word64 ![DeltaCmd] deriving (Show,Eq) -- | possible commands in a delta data DeltaCmd = - DeltaCopy ByteString -- command to insert this bytestring - | DeltaSrc Word64 Word64 -- command to copy from source (offset, size) + DeltaCopy !ByteString -- command to insert this bytestring + | DeltaSrc !Word64 !Word64 -- command to copy from source (offset, size) deriving (Show,Eq) -- | parse a delta. @@ -62,8 +63,9 @@ let size = s1 .|. s2 .|. s3 return $ DeltaSrc offset (if size == 0 then 0x10000 else size) | otherwise = DeltaCopy <$> P.take (fromIntegral cmd) - word8cond cond sh = - if cond then (flip shiftL sh . fromIntegral) <$> P.anyByte else return 0 + + word8cond False _ = return 0 + word8cond True sh = flip shiftL sh . fromIntegral <$> P.anyByte -- | read one delta from a lazy bytestring. deltaRead :: [ByteString] -> Maybe Delta diff --git a/Data/Git/Diff.hs b/Data/Git/Diff.hs --- a/Data/Git/Diff.hs +++ b/Data/Git/Diff.hs @@ -36,8 +36,9 @@ import Data.ByteString.Lazy.Char8 as L import Data.Typeable -import Data.Algorithm.Patience as AP (Item(..), diff) +import Data.Git.Diff.Patience (Item(..), diff) + -- | represents a blob's content (i.e., the content of a file at a given -- reference). data BlobContent = FileContent [L.ByteString] -- ^ Text file's lines @@ -257,22 +258,21 @@ let (_, _, filteredDiff) = Prelude.foldr filterContext (0, AccuBottom, []) list theList = removeTrailingBoth filteredDiff in case Prelude.head theList of - (NormalLine (Both l1 _)) -> if (lineNumber l1) > 1 then Separator:theList - else theList + (NormalLine (Both l _)) -> if lineNumber l > 1 then Separator:theList else theList _ -> theList where -- only keep 'context'. The file is annalyzed from the bottom to the top. -- The accumulator here is a tuple3 with (the line counter, the -- direction and the list of elements) filterContext :: (Item TextLine) -> (Int, GitAccu, [FilteredDiff]) -> (Int, GitAccu, [FilteredDiff]) - filterContext (Both l1 l2) (c, AccuBottom, acc) = - if c < context then (c+1, AccuBottom, (NormalLine (Both l1 l2)):acc) - else (c , AccuBottom, (NormalLine (Both l1 l2)) + filterContext b@(Both {}) (c, AccuBottom, acc) = + if c < context then (c+1, AccuBottom, (NormalLine b):acc) + else (c , AccuBottom, (NormalLine b) :((Prelude.take (context-1) acc) ++ [Separator] ++ (Prelude.drop (context+1) acc))) - filterContext (Both l1 l2) (c, AccuTop, acc) = - if c < context then (c+1, AccuTop , (NormalLine (Both l1 l2)):acc) - else (0 , AccuBottom, (NormalLine (Both l1 l2)):acc) + filterContext b@(Both {}) (c, AccuTop, acc) = + if c < context then (c+1, AccuTop , (NormalLine b):acc) + else (0 , AccuBottom, (NormalLine b):acc) filterContext element (_, _, acc) = (0, AccuTop, (NormalLine element):acc) @@ -281,8 +281,8 @@ startWithSeparator (Separator:_) = True startWithSeparator ((NormalLine l):xs) = case l of - (Both _ _) -> startWithSeparator xs - _ -> False + Both {} -> startWithSeparator xs + _ -> False removeTrailingBoth :: [FilteredDiff] -> [FilteredDiff] removeTrailingBoth diffList = diff --git a/Data/Git/Diff/Patience.hs b/Data/Git/Diff/Patience.hs new file mode 100644 --- /dev/null +++ b/Data/Git/Diff/Patience.hs @@ -0,0 +1,108 @@ +-- loosely based on the patience-0.1.1 package which is: +-- +-- Copyright (c) Keegan McAllister 2011 +-- +module Data.Git.Diff.Patience + ( Item(..) + , diff + ) where + +import Data.List +import Data.Function (on) +import qualified Data.Map as M +import qualified Data.IntMap as IM + +data Card a = Card !Int a !(Maybe (Card a)) + +-- sort using patience making stack of card with the list of elements, +-- then take the highest stack (maxView) and flatten the path back into a list +-- to get the longest increasing path +longestIncreasing :: [(Int,a)] -> [(Int,a)] +longestIncreasing = + maybe [] (flatten . head . fst) + . IM.maxView + . foldl' ins IM.empty + where + ins :: IM.IntMap [Card a] -> (Int, a) -> IM.IntMap [Card a] + ins m (x,a) = + case IM.minViewWithKey gt of + Nothing -> IM.insert x [new] m + Just ((k,_),_) -> + case IM.updateLookupWithKey (\_ _ -> Nothing) k m of + (Just v, mm) -> IM.insert x (new : v) mm + (Nothing, _) -> m + where + (lt, gt) = IM.split x m + prev = (head . fst) `fmap` IM.maxView lt + new = Card x a prev + + flatten :: Card a -> [(Int, a)] + flatten (Card x a c) = (x,a) : maybe [] flatten c + +-- Type for decomposing a diff problem. We either have two +-- lines that match, or a recursive subproblem. +data Piece a = + Match !a !a + | Diff [a] [a] + deriving (Show) + +-- Get the longest common subsequence +lcs :: Ord t => [t] -> [t] -> [Piece t] +lcs ma mb = + chop ma mb + $ longestIncreasing + $ sortBy (compare `on` snd) + $ M.elems + $ M.intersectionWith (,) (unique ma) (unique mb) + where + unique = M.mapMaybe id . foldr ins M.empty . zip [0..] + where + ins (a,x) = M.insertWith (\_ _ -> Nothing) x (Just a) + + -- Subdivides a diff problem according to the indices of matching lines. + chop :: [t] -> [t] -> [(Int,Int)] -> [Piece t] + chop xs ys [] + | null xs && null ys = [] + | otherwise = [Diff xs ys] + chop xs ys ((nx,ny):ns) = + let (xsr, (x : xse)) = splitAt nx xs + (ysr, (y : yse)) = splitAt ny ys + in Diff xse yse : Match x y : chop xsr ysr ns + +-- | An element of a computed difference. +data Item t = + Old !t + | New !t + | Both !t !t + deriving (Show,Eq) + +instance Functor Item where + fmap f (Old x) = Old (f x) + fmap f (New x) = New (f x) + fmap f (Both x y) = Both (f x) (f y) + +-- | The difference between two lists using the patience algorithm +diff :: Ord t => [t] -> [t] -> [Item t] +diff = matchPrefix [] + where + -- match the prefix between old and new document + matchPrefix acc (x:xs) (y:ys) + | x == y = Both x y : matchPrefix acc xs ys + matchPrefix acc l r = matchSuffix acc (reverse l) (reverse r) + + -- match the suffix between old and new document, accumulating the + -- matched item in a reverse accumulator to keep TCO + matchSuffix acc (x:xs) (y:ys) + | x == y = matchSuffix (Both x y : acc) xs ys + matchSuffix acc l r = diffInner (reverse acc) (reverse l) (reverse r) + + -- prefix and suffix are striped, and now do the LCS + diffInner acc l r = + case lcs l r of + -- If we fail to subdivide, just record the chunk as is. + [Diff _ _] -> fmap Old l ++ fmap New r ++ acc + ps -> recur acc ps + + recur acc [] = acc + recur acc (Match x y : ps) = recur (Both x y : acc) ps + recur acc (Diff xs ys : ps) = recur [] ps ++ matchPrefix acc xs ys diff --git a/Data/Git/Monad.hs b/Data/Git/Monad.hs --- a/Data/Git/Monad.hs +++ b/Data/Git/Monad.hs @@ -581,8 +581,8 @@ -- -- Example: -- --- > withCurrentRepo $ --- > (r, ()) <- withNewCommit person Nothing $ do +-- > withCurrentRepo $ do +-- > (r, ()) <- withNewCommit person (Nothing :: Maybe (Ref SHA1)) $ do -- > setMessage "inital commit" -- > setFile ["README.md"] "# My awesome project\n\nthis is a new project\n" -- > branchWrite "master" r @@ -592,7 +592,7 @@ -- parent is already set to the Reference associated to the revision. -- You can, change the parents if you wish to erase, or replace, this value. -- --- > withCurrentRepo $ +-- > withCurrentRepo $ do -- > readmeContent <- withCommit (Just "master") $ getFile ["README.md"] -- > (r, ()) <- withNewCommit person (Just "master") $ do -- > setMessage "update the README" diff --git a/Data/Git/Named.hs b/Data/Git/Named.hs --- a/Data/Git/Named.hs +++ b/Data/Git/Named.hs @@ -142,7 +142,7 @@ getRefsRecursively dir acc (x:xs) = do isDir <- isDirectory x extra <- if isDir - then listRefsAcc [] dir + then listRefsAcc [] x else let r = UTF8.toString $ localPathEncode $ stripRoot x in if isValidRefName r then return [fromString r] diff --git a/Data/Git/Repository.hs b/Data/Git/Repository.hs --- a/Data/Git/Repository.hs +++ b/Data/Git/Repository.hs @@ -42,7 +42,7 @@ import Control.Exception (Exception, throw) import Data.Maybe (fromMaybe) -import Data.List (find) +import Data.List (find, stripPrefix) import Data.Data import Data.IORef @@ -129,7 +129,11 @@ "HEAD" -> [ RefHead ] "ORIG_HEAD" -> [ RefOrigHead ] "FETCH_HEAD" -> [ RefFetchHead ] - _ -> map (flip ($) (RefName prefix)) [RefTag,RefBranch,RefRemote] + _ -> + maybe (map (flip ($) (RefName prefix)) [RefTag,RefBranch,RefRemote]) (:[]) $ + (RefBranch . RefName <$> stripPrefix "refs/heads/" prefix) + <|> (RefTag . RefName <$> stripPrefix "refs/tags/" prefix) + <|> (RefRemote . RefName <$> stripPrefix "refs/remotes/" prefix) tryResolvers :: HashAlgorithm hash => [IO (Maybe (Ref hash))] -> IO (Maybe (Ref hash)) tryResolvers [] = return $ if (isHexString prefix) diff --git a/Data/Git/Storage/Object.hs b/Data/Git/Storage/Object.hs --- a/Data/Git/Storage/Object.hs +++ b/Data/Git/Storage/Object.hs @@ -45,7 +45,6 @@ import Data.Git.Imports import qualified Data.Git.Parser as P -import Data.Byteable (toBytes) import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC @@ -265,7 +264,7 @@ where writeTreeEnt (ModePerm perm,name,ref) = [ string7 (printf "%o" perm) , string7 " " - , byteString $ toBytes name + , byteString $ getEntNameBytes name , string7 "\0" , byteString $ toBinary ref ] diff --git a/Data/Git/Types.hs b/Data/Git/Types.hs --- a/Data/Git/Types.hs +++ b/Data/Git/Types.hs @@ -19,6 +19,7 @@ , Person(..) , EntName , entName + , getEntNameBytes , EntPath , entPathAppend -- * modeperm type @@ -40,7 +41,6 @@ import Data.Word import Data.Bits -import Data.Byteable import Data.String import Data.ByteString (ByteString) import qualified Data.ByteString as B @@ -147,14 +147,12 @@ type Perm = Word8 -- | Entity name -newtype EntName = EntName ByteString +newtype EntName = EntName { getEntNameBytes :: ByteString } deriving (Eq,Ord) instance Show EntName where show (EntName e) = UTF8.toString e instance IsString EntName where fromString s = entName $ UTF8.fromString s -instance Byteable EntName where - toBytes (EntName n) = n entName :: ByteString -> EntName entName bs diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2010-2016 Vincent Hanquez +Copyright (c) 2010-2019 Vincent Hanquez All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -7,13 +7,14 @@ git is a reimplementation of git storage and protocol in pure haskell. -what it does do: +What it does do: * read loose objects, and packed objects. * write new loose objects * git like operations available: commit, cat-file, verify-pack, rev-list, ls-tree. +* diff between commits -what is doesn't do: +What is doesn't do: * reimplement the whole of git. * checkout's index reading/writing, fetching, merging, diffing. diff --git a/git.cabal b/git.cabal --- a/git.cabal +++ b/git.cabal @@ -1,5 +1,5 @@ Name: git -Version: 0.2.2 +Version: 0.3.0 Synopsis: Git operations in haskell Description: . @@ -29,7 +29,6 @@ Build-Depends: base >= 4 && < 5 , basement , bytestring >= 0.9 - , byteable , containers , memory >= 0.13 , cryptonite >= 0.22 @@ -40,7 +39,6 @@ , hourglass >= 0.2 , unix-compat , utf8-string - , patience -- to remove , system-filepath , system-fileio @@ -58,6 +56,7 @@ Data.Git.Revision Data.Git.Repository Data.Git.Diff + Data.Git.Diff.Patience Other-modules: Data.Git.Internal Data.Git.Imports Data.Git.OS