hit 0.5.4 → 0.5.5
raw patch · 10 files changed
+332/−150 lines, 10 files
Files
- Data/Git.hs +7/−0
- Data/Git/Diff.hs +147/−63
- Data/Git/Named.hs +68/−36
- Data/Git/Path.hs +3/−3
- Data/Git/Repository.hs +2/−3
- Data/Git/Storage/Object.hs +7/−4
- Data/Git/Types.hs +45/−1
- Hit/Hit.hs +49/−39
- Tests/Tests.hs +3/−0
- hit.cabal +1/−1
Data/Git.hs view
@@ -16,6 +16,13 @@ , Blob(..) , Tag(..) , GitTime(..)+ , ModePerm(..)++ -- * Helper & type related to ModePerm+ , ObjectFileType(..)+ , FilePermissions(..)+ , getPermission+ , getFiletype -- * Revision , Revision
Data/Git/Diff.hs view
@@ -16,14 +16,16 @@ , BlobStateDiff(..) , getDiffWith -- * Default helpers- , HitDiffContent(..) , HitDiff(..)+ , HitFileContent(..)+ , FilteredDiff(..)+ , HitFileRef(..)+ , HitFileMode(..)+ , TextLine(..) , defaultDiff , getDiff ) where -import Control.Applicative ((<$>))- import Data.List (find, filter) import Data.Char (ord) import Data.Git@@ -44,7 +46,7 @@ -- | This is a blob description at a given state (revision) data BlobState = BlobState { bsFilename :: BS.ByteString- , bsMode :: Int+ , bsMode :: ModePerm , bsRef :: Ref , bsContent :: BlobContent }@@ -65,21 +67,6 @@ | OnlyNew BlobState | OldAndNew BlobState BlobState -getBinaryStat :: L.ByteString -> Double-getBinaryStat bs = L.foldl' (\acc w -> acc + if isBin $ ord w then 1 else 0) 0 bs / (fromIntegral $ L.length bs)- where- isBin :: Int -> Bool- isBin i- | i >= 0 && i <= 8 = True- | i == 12 = True- | i >= 14 && i <= 31 = True- | otherwise = False--isBinaryFile :: L.ByteString -> Bool-isBinaryFile file =- let bs = L.take 512 file- in getBinaryStat bs > 0.0- buildListForDiff :: Git -> Ref -> IO [BlobState] buildListForDiff git ref = do commit <- getCommit git ref@@ -109,7 +96,20 @@ case mobj of Nothing -> error "not a valid object" Just obj -> return $ oiData obj+ getBinaryStat :: L.ByteString -> Double+ getBinaryStat bs = L.foldl' (\acc w -> acc + if isBin $ ord w then 1 else 0) 0 bs / (fromIntegral $ L.length bs)+ where+ isBin :: Int -> Bool+ isBin i+ | i >= 0 && i <= 8 = True+ | i == 12 = True+ | i >= 14 && i <= 31 = True+ | otherwise = False + isBinaryFile :: L.ByteString -> Bool+ isBinaryFile file = let bs = L.take 512 file+ in getBinaryStat bs > 0.0+ -- | generate a diff list between two revisions with a given diff helper. -- -- Useful to extract any kind of information from two different revisions.@@ -146,57 +146,141 @@ in (OldAndNew bs1 bs2):(doDiffWith xs1 subxs2) Nothing -> (OnlyOld bs1):(doDiffWith xs1 xs2) --- | This is an example of how you can use Hit to get all of information--- between different revision.-data HitDiffContent = HitDiffAddition BlobState- | HitDiffDeletion BlobState- | HitDiffChange [AP.Item L.ByteString]- | HitDiffBinChange- | HitDiffMode Int Int- | HitDiffRefs Ref Ref- deriving (Show)+data TextLine = TextLine+ { lineNumber :: Integer+ , lineContent :: L.ByteString+ }+instance Eq TextLine where+ a == b = (lineContent a) == (lineContent b)+ a /= b = not (a == b)+instance Ord TextLine where+ compare a b = compare (lineContent a) (lineContent b)+ a < b = (lineContent a) < (lineContent b)+ a <= b = (lineContent a) <= (lineContent b)+ a > b = b < a+ a >= b = b <= a --- | This represents a diff.+data FilteredDiff = NormalLine (Item TextLine) | Separator++data HitFileContent = NewBinaryFile+ | OldBinaryFile+ | NewTextFile [TextLine]+ | OldTextFile [TextLine]+ | ModifiedBinaryFile+ | ModifiedFile [FilteredDiff]+ | UnModifiedFile++data HitFileMode = NewMode ModePerm+ | OldMode ModePerm+ | ModifiedMode ModePerm ModePerm+ | UnModifiedMode ModePerm++data HitFileRef = NewRef Ref+ | OldRef Ref+ | ModifiedRef Ref Ref+ | UnModifiedRef Ref++-- | This is a proposed diff records for a given file.+-- It contains useful information:+-- * the filename (with its path in the root project)+-- * a file diff (with the Data.Algorythm.Patience method)+-- * the file's mode (i.e. the file priviledge)+-- * the file's ref data HitDiff = HitDiff- { hitFilename :: BS.ByteString- , hitDiff :: [HitDiffContent]- } deriving (Show)+ { hFileName :: BS.ByteString+ , hFileContent :: HitFileContent+ , hFileMode :: HitFileMode+ , hFileRef :: HitFileRef+ } -- | A default Diff getter which returns all diff information (Mode, Content--- and Binary).+-- and Binary) with a context of 5 lines. ----- > getDiff = getDiffWith defaultDiff-getDiff :: Ref -- ^ commit ref- -> Ref -- ^ commit ref- -> Git -- ^ repository+-- > getDiff = getDiffWith (defaultDiff 5) []+getDiff :: Ref+ -> Ref+ -> Git -> IO [HitDiff]-getDiff = getDiffWith defaultDiff []+getDiff = getDiffWith (defaultDiff 5) [] -- | A default diff helper. It is an example about how you can write your own -- diff helper or you can use it if you want to get all of differences.-defaultDiff :: BlobStateDiff -> [HitDiff] -> [HitDiff]-defaultDiff (OnlyOld old ) acc = (HitDiff (bsFilename old) ([HitDiffDeletion old])):acc-defaultDiff (OnlyNew new) acc = (HitDiff (bsFilename new) ([HitDiffAddition new])):acc-defaultDiff (OldAndNew old new) acc =- let theDiffMode = if (bsMode old) == (bsMode new) then [] else [HitDiffMode (bsMode old) (bsMode new)] in- case ((bsRef old) == (bsRef new)) of- -- If the reference is the same, then there is no difference- True -> if Prelude.null theDiffMode- then acc- else (HitDiff (bsFilename old) theDiffMode):acc- False -> let theDiff = createANewDiff (bsContent old) (bsContent new) in- if (onlyBothDiff $ Prelude.head theDiff)- then (HitDiff (bsFilename old) ((HitDiffRefs (bsRef old) (bsRef new)):theDiffMode)):acc- else (HitDiff (bsFilename old) ( theDiff ++ ((HitDiffRefs (bsRef old) (bsRef new)):theDiffMode))):acc- where- createANewDiff :: BlobContent -> BlobContent -> [HitDiffContent]- createANewDiff (FileContent a) (FileContent b) = [HitDiffChange (diff a b)]- createANewDiff (BinaryContent a) (BinaryContent b) = if a /= b then [HitDiffBinChange] else []- createANewDiff _ _ = [HitDiffBinChange]+defaultDiff :: Int -- ^ Number of line for context+ -> BlobStateDiff+ -> [HitDiff] -- ^ Accumulator+ -> [HitDiff] -- ^ Accumulator with a new content+defaultDiff _ (OnlyOld old ) acc =+ let oldMode = OldMode (bsMode old)+ oldRef = OldRef (bsRef old)+ oldContent = case bsContent old of+ BinaryContent _ -> OldBinaryFile+ FileContent l -> OldTextFile (Prelude.zipWith TextLine [1..] l)+ in (HitDiff (bsFilename old) oldContent oldMode oldRef):acc+defaultDiff _ (OnlyNew new) acc =+ let newMode = NewMode (bsMode new)+ newRef = NewRef (bsRef new)+ newContent = case bsContent new of+ BinaryContent _ -> NewBinaryFile+ FileContent l -> NewTextFile (Prelude.zipWith TextLine [1..] l)+ in (HitDiff (bsFilename new) newContent newMode newRef):acc+defaultDiff context (OldAndNew old new) acc =+ let mode = if (bsMode old) /= (bsMode new) then ModifiedMode (bsMode old) (bsMode new)+ else UnModifiedMode (bsMode new)+ ref = if (bsRef old) == (bsRef new) then UnModifiedRef (bsRef new)+ else ModifiedRef (bsRef old) (bsRef new)+ in case (mode, ref) of+ ((UnModifiedMode _), (UnModifiedRef _)) -> acc+ _ -> (HitDiff (bsFilename new) (content ref) mode ref):acc+ where content :: HitFileRef -> HitFileContent+ content (UnModifiedRef _) = UnModifiedFile+ content _ = createDiff (bsContent old) (bsContent new) - onlyBothDiff :: HitDiffContent -> Bool- onlyBothDiff (HitDiffBinChange) = False- onlyBothDiff (HitDiffChange l) = Prelude.all predicate l- where predicate (Both _ _) = True- predicate _ = False- onlyBothDiff _ = True+ createDiff :: BlobContent -> BlobContent -> HitFileContent+ createDiff (FileContent a) (FileContent b) =+ let linesA = Prelude.zipWith TextLine [1..] a+ linesB = Prelude.zipWith TextLine [1..] b+ in ModifiedFile $ diffGetContext context (diff linesA linesB)+ createDiff _ _ = ModifiedBinaryFile++-- Used by diffGetContext+data HitwebAccu = AccuBottom | AccuTop++-- Context filter+diffGetContext :: Int -> [Item TextLine] -> [FilteredDiff]+diffGetContext 0 list = fmap NormalLine list+diffGetContext context list =+ 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+ _ -> 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, HitwebAccu, [FilteredDiff]) -> (Int, HitwebAccu, [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))+ :((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 element (_, _, acc) =+ (0, AccuTop, (NormalLine element):acc)++ startWithSeparator :: [FilteredDiff] -> Bool+ startWithSeparator [] = False+ startWithSeparator (Separator:_) = True+ startWithSeparator ((NormalLine l):xs) =+ case l of+ (Both _ _) -> startWithSeparator xs+ _ -> False++ removeTrailingBoth :: [FilteredDiff] -> [FilteredDiff]+ removeTrailingBoth diffList =+ let test = startWithSeparator diffList+ in if test then Prelude.tail $ Prelude.dropWhile (\a -> not $ startWithSeparator [a]) diffList+ else diffList
Data/Git/Named.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Data.Git.Named -- License : BSD-style@@ -7,20 +5,31 @@ -- Stability : experimental -- Portability : unix --+-- Manipulation of named references+-- * reading packed-refs file+-- * reading single heads/tags/remote file+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} module Data.Git.Named ( RefSpecTy(..) , RefContentTy(..)+ , RefName(..) , readPackedRefs+ -- * manipulating loosed name references , existsRefFile , writeRefFile , readRefFile+ -- * listings looses name references+ , headsList+ , tagsList+ , remotesList ) where import Control.Applicative ((<$>)) import qualified Filesystem as F import qualified Filesystem.Path.Rules as FP (posix, decode, encode, encodeString, decodeString)-import Filesystem.Path.CurrentOS+import Filesystem.Path.CurrentOS hiding (root) import Data.String import Data.Git.Path@@ -34,9 +43,9 @@ data RefSpecTy = RefHead | RefOrigHead | RefFetchHead- | RefBranch String- | RefTag String- | RefRemote String+ | RefBranch RefName+ | RefTag RefName+ | RefRemote RefName | RefPatches String | RefStash | RefOther String@@ -48,6 +57,25 @@ | RefContentUnknown B.ByteString deriving (Show,Eq) +newtype RefName = RefName { refNameRaw :: String }+ deriving (Show,Eq,Ord)++instance IsString RefName where+ fromString s+ | isValidRefName s = RefName s+ | otherwise = error ("invalid RefName " ++ show s)++isValidRefName :: String -> Bool+isValidRefName s = not (or $ map isBadChar s)+ where isBadChar :: Char -> Bool+ isBadChar c = c <= ' ' || c >= toEnum 0x7f || c `elem` badAscii+ badAscii = [ '~', '^', ':', '\\', '*', '?', '[' ]++isValidRefFilepath :: FilePath -> Bool+isValidRefFilepath f+ | valid f = isValidRefName $ encodeString f+ | otherwise = False+ -- FIXME BC.unpack/pack should be probably be utf8.toString, -- however i don't know if encoding is consistant. -- it should probably be overridable.@@ -59,9 +87,9 @@ toRefTy :: String -> RefSpecTy toRefTy s- | "refs/tags/" `isPrefixOf` s = RefTag $ drop 10 s- | "refs/heads/" `isPrefixOf` s = RefBranch $ drop 11 s- | "refs/remotes/" `isPrefixOf` s = RefRemote $ drop 13 s+ | "refs/tags/" `isPrefixOf` s = RefTag $ RefName $ drop 10 s+ | "refs/heads/" `isPrefixOf` s = RefBranch $ RefName $ drop 11 s+ | "refs/remotes/" `isPrefixOf` s = RefRemote $ RefName $ drop 13 s | "refs/patches/" `isPrefixOf` s = RefPatches $ drop 13 s | "refs/stash" == s = RefStash | "HEAD" == s = RefHead@@ -70,9 +98,9 @@ | otherwise = RefOther $ s fromRefTy :: RefSpecTy -> String-fromRefTy (RefBranch h) = "refs/heads/" ++ h-fromRefTy (RefTag h) = "refs/tags/" ++ h-fromRefTy (RefRemote h) = "refs/remotes/" ++ h+fromRefTy (RefBranch h) = "refs/heads/" ++ refNameRaw h+fromRefTy (RefTag h) = "refs/tags/" ++ refNameRaw h+fromRefTy (RefRemote h) = "refs/remotes/" ++ refNameRaw h fromRefTy (RefPatches h) = "refs/patches/" ++ h fromRefTy RefStash = "refs/stash" fromRefTy RefHead = "HEAD"@@ -81,9 +109,9 @@ fromRefTy (RefOther h) = h toPath :: FilePath -> RefSpecTy -> FilePath-toPath gitRepo (RefBranch h) = gitRepo </> "refs" </> "heads" </> fromString h-toPath gitRepo (RefTag h) = gitRepo </> "refs" </> "tags" </> fromString h-toPath gitRepo (RefRemote h) = gitRepo </> "refs" </> "remotes" </> fromString h+toPath gitRepo (RefBranch h) = gitRepo </> "refs" </> "heads" </> fromString (refNameRaw h)+toPath gitRepo (RefTag h) = gitRepo </> "refs" </> "tags" </> fromString (refNameRaw h)+toPath gitRepo (RefRemote h) = gitRepo </> "refs" </> "remotes" </> fromString (refNameRaw h) toPath gitRepo (RefPatches h) = gitRepo </> "refs" </> "patches" </> fromString h toPath gitRepo RefStash = gitRepo </> "refs" </> "stash" toPath gitRepo RefHead = gitRepo </> "HEAD"@@ -91,6 +119,7 @@ toPath gitRepo RefFetchHead = gitRepo </> "FETCH_HEAD" toPath gitRepo (RefOther h) = gitRepo </> fromString h +readPackedRefs :: FilePath -> IO [(RefSpecTy, Ref)] readPackedRefs gitRepo = do exists <- F.isFile (packedRefsPath gitRepo) if exists then readLines else return []@@ -101,16 +130,32 @@ name = FP.encodeString FP.posix $ pathDecode $ B.tail r in (toRefTy name, fromHex ref) : a -{--headsList gitRepo = getDirectoryContentNoDots (headsPath gitRepo)-tagsList gitRepo = getDirectoryContentNoDots (tagsPath gitRepo)-remotesList gitRepo = getDirectoryContentNoDots (remotesPath gitRepo)-remoteList gitRepo remote = getDirectoryContentNoDots (remotePath gitRepo remote)+listRefs :: FilePath -> IO [RefName]+listRefs root = listRefsAcc [] root+ where listRefsAcc acc dir = do+ files <- F.listDirectory dir+ getRefsRecursively dir acc files+ getRefsRecursively _ acc [] = return acc+ getRefsRecursively dir acc (x:xs) = do+ isDir <- F.isDirectory x+ extra <- if isDir+ then listRefsAcc [] dir+ else let r = stripRoot x+ in if isValidRefFilepath r+ then return [fromString $ encodeString r]+ else return []+ getRefsRecursively dir (extra ++ acc) xs+ stripRoot p = maybe (error "stripRoot invalid") id $ stripPrefix root p -writeRef path ref = B.writeFile path (B.concat [toHex ref, B.singleton 0xa])-readRef path = fromHex . B.take 40 <$> B.readFile path--}+headsList :: FilePath -> IO [RefName]+headsList gitRepo = listRefs (headsPath gitRepo) +tagsList :: FilePath -> IO [RefName]+tagsList gitRepo = listRefs (tagsPath gitRepo)++remotesList :: FilePath -> IO [RefName]+remotesList gitRepo = listRefs (remotesPath gitRepo)+ existsRefFile :: FilePath -> RefSpecTy -> IO Bool existsRefFile gitRepo specty = F.isFile $ toPath gitRepo specty @@ -128,16 +173,3 @@ | "ref: " `B.isPrefixOf` content = RefLink $ toRefTy $ FP.encodeString FP.posix $ pathDecode $ head $ BC.lines $ B.drop 5 content | B.length content < 42 = RefDirect $ fromHex $ B.take 40 content | otherwise = RefContentUnknown content--{--headExists gitRepo name = doesFileExist (headPath gitRepo name)-headRead gitRepo name = readRef (headPath gitRepo name)-headWrite gitRepo name ref = writeRef (headPath gitRepo name) ref--tagExists gitRepo name = doesFileExist (tagPath gitRepo name)-tagRead gitRepo name = readRef (tagPath gitRepo name)-tagWrite gitRepo name ref = writeRef (tagPath gitRepo name) ref--specialRead gitRepo name = readRefAndFollow gitRepo (specialPath gitRepo name)-specialExists gitRepo name = doesFileExist (specialPath gitRepo name)--}
Data/Git/Path.hs view
@@ -14,9 +14,9 @@ import Data.Git.Ref import Data.String -headsPath gitRepo = gitRepo </> "refs" </> "heads"-tagsPath gitRepo = gitRepo </> "refs" </> "tags"-remotesPath gitRepo = gitRepo </> "refs" </> "remotes"+headsPath gitRepo = gitRepo </> "refs" </> "heads" </> ""+tagsPath gitRepo = gitRepo </> "refs" </> "tags" </> ""+remotesPath gitRepo = gitRepo </> "refs" </> "remotes" </> "" packedRefsPath gitRepo = gitRepo </> "packed-refs" headPath gitRepo name = headsPath gitRepo </> fromString name
Data/Git/Repository.hs view
@@ -48,7 +48,7 @@ -- | hierarchy tree, either a reference to a blob (file) or a tree (directory). data HTreeEnt = TreeDir Ref HTree | TreeFile Ref-type HTree = [(Int,ByteString,HTreeEnt)]+type HTree = [(ModePerm,ByteString,HTreeEnt)] -- | Exception when trying to convert an object pointed by 'Ref' to -- a type that is different@@ -108,8 +108,7 @@ "HEAD" -> [ RefHead ] "ORIG_HEAD" -> [ RefOrigHead ] "FETCH_HEAD" -> [ RefFetchHead ]- _ -> [ RefTag prefix, RefBranch prefix, RefRemote prefix ]-+ _ -> map (flip ($) (RefName prefix)) [RefTag,RefBranch,RefRemote] tryResolvers :: [IO (Maybe Ref)] -> IO Ref tryResolvers [] = return $ fromHexString prefix
Data/Git/Storage/Object.hs view
@@ -161,10 +161,13 @@ objectToBlob _ = Nothing octal :: Parser Int-octal = B.foldl' step 0 `fmap` takeWhile1 isOct where- isOct w = w >= 0x30 && w <= 0x37+octal = B.foldl' step 0 `fmap` takeWhile1 isOct+ where isOct w = w >= 0x30 && w <= 0x37 step a w = a * 8 + fromIntegral (w - 0x30) +modeperm :: Parser ModePerm+modeperm = ModePerm . fromIntegral <$> octal+ tillEOL :: Parser ByteString tillEOL = PC.takeWhile ((/= '\n')) @@ -179,7 +182,7 @@ -- | parse a tree content treeParse = Tree <$> parseEnts where parseEnts = atEnd >>= \end -> if end then return [] else liftM2 (:) parseEnt parseEnts- parseEnt = liftM3 (,,) octal (PC.char ' ' >> takeTill ((==) 0)) (word8 0 >> referenceBin)+ parseEnt = liftM3 (,,) modeperm (PC.char ' ' >> takeTill ((==) 0)) (word8 0 >> referenceBin) -- | parse a blob content blobParse = (Blob <$> takeLazyByteString)@@ -250,7 +253,7 @@ objectWrite _ = error "delta cannot be marshalled" treeWrite (Tree ents) = toLazyByteString $ mconcat $ concatMap writeTreeEnt ents- where writeTreeEnt (perm,name,ref) =+ where writeTreeEnt (ModePerm perm,name,ref) = [ string7 (printf "%o" perm) , string7 " " , byteString name
Data/Git/Types.hs view
@@ -17,6 +17,12 @@ , Blob(..) , Tag(..) , Person(..)+ -- * modeperm type+ , ModePerm(..)+ , FilePermissions(..)+ , ObjectFileType(..)+ , getPermission+ , getFiletype -- * time type , GitTime(..) , toUTCTime@@ -30,6 +36,7 @@ ) where import Data.Word+import Data.Bits import Data.Monoid import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as L@@ -41,6 +48,7 @@ import Data.Time.Clock.POSIX import Data.Data + -- | type of a git object. data ObjectType = TypeTree@@ -86,10 +94,46 @@ toEnum 0x7 = TypeDeltaRef toEnum n = error ("not a valid object: " ++ show n) +newtype ModePerm = ModePerm Word32+ deriving (Show,Eq)++getPermission :: ModePerm -> FilePermissions+getPermission (ModePerm modeperm) =+ let owner = (modeperm .&. 0x700) `shiftR` 6+ group = (modeperm .&. 0x70) `shiftR` 3+ other = modeperm .&. 0x7+ in FilePermissions (fromIntegral owner) (fromIntegral group) (fromIntegral other)++getFiletype :: ModePerm -> ObjectFileType+getFiletype (ModePerm modeperm) =+ case modeperm `shiftR` 12 of+ _ -> error "filetype unknown"++-- | Git object file type+data ObjectFileType =+ FileTypeDirectory+ | FileTypeRegularFile+ | FileTypeSymbolicLink+ | FileTypeGitLink+ deriving (Show,Eq)++-- | traditional unix permission for owner, group and permissions+data FilePermissions = FilePermissions+ { getOwnerPerm :: {-# UNPACK #-} !Perm+ , getGroupPerm :: {-# UNPACK #-} !Perm+ , getOtherPerm :: {-# UNPACK #-} !Perm+ } deriving (Show,Eq)++-- | a bitfield representing a typical unix permission:+-- * bit 0 represents the read permission+-- * bit 1 represents the write permission+-- * bit 2 represents the execute permission+type Perm = Word8+ -- | represent one entry in the tree -- (permission,file or directory name,blob or tree ref) -- name should maybe a filepath, but not sure about the encoding.-type TreeEnt = (Int,ByteString,Ref)+type TreeEnt = (ModePerm,ByteString,Ref) -- | an author or committer line -- has the format: name <email> time timezone
Hit/Hit.hs view
@@ -19,6 +19,7 @@ import Data.Git.Types import Data.Git.Ref import Data.Git.Repository+import Data.Git.Named import Data.Git.Revision import Data.Git.Diff import Data.Word@@ -132,8 +133,8 @@ mapM_ (showTreeEnt) htree _ -> error "cannot build a tree from this reference" where- showTreeEnt (p,n,TreeDir r _) = printf "%06o tree %s %s\n" p (show r) (BC.unpack n)- showTreeEnt (p,n,TreeFile r) = printf "%06o blob %s %s\n" p (show r) (BC.unpack n)+ showTreeEnt (ModePerm p,n,TreeDir r _) = printf "%06o tree %s %s\n" p (show r) (BC.unpack n)+ showTreeEnt (ModePerm p,n,TreeFile r) = printf "%06o blob %s %s\n" p (show r) (BC.unpack n) revList revision git = do ref <- maybe (error "revision cannot be found") id <$> resolveRevision git revision@@ -166,53 +167,61 @@ showDiff rev1 rev2 git = do ref1 <- maybe (error "revision cannot be found") id <$> resolveRevision git rev1 ref2 <- maybe (error "revision cannot be found") id <$> resolveRevision git rev2- diffList <- getDiff ref1 ref2 git+ diffList <- getDiffWith (defaultDiff 5) ([]) ref1 ref2 git mapM_ showADiff diffList where showADiff :: HitDiff -> IO () showADiff hd = do- let filename = BC.unpack $ hitFilename hd- putStrLn $ "Diff --hit old/" ++ filename ++ " new/" ++ filename- ppHitMode $ hitDiff hd- ppHitRefs $ hitDiff hd- ppHitDiff $ hitDiff hd+ printFileName $ hFileName hd+ printFileMode $ hFileMode hd+ printFileRef $ hFileRef hd+ printFileDiff $ hFileContent hd - ppHitMode :: [HitDiffContent] -> IO ()- ppHitMode [] = return ()- ppHitMode ((HitDiffMode old new):_ ) = printf "old mode %06o\nnew mode %06o\n" old new- ppHitMode (_ :xs) = ppHitMode xs+ printFileName :: BC.ByteString -> IO ()+ printFileName filename = putStrLn $ "Hit.Diff on file: " ++ (BC.unpack filename) - ppHitRefs :: [HitDiffContent] -> IO ()- ppHitRefs [] = return ()- ppHitRefs ((HitDiffRefs old new):_ ) = printf "--- old: %s\n+++ new: %s\n" (show old) (show new)- ppHitRefs ((HitDiffAddition new):_ ) = printf "--- old: dev/null\n+++ new: %s\n" (show $ bsRef new)- ppHitRefs ((HitDiffDeletion old):_ ) = printf "--- old: %s\n+++ new: dev/null\n" (show $ bsRef old)- ppHitRefs (_ :xs) = ppHitRefs xs+ printFileMode :: HitFileMode -> IO ()+ printFileMode (NewMode (ModePerm m)) = printf "new file mode: %06o\n" m+ printFileMode (OldMode (ModePerm m)) = printf "old file mode: %06o\n" m+ printFileMode (UnModifiedMode (ModePerm m)) = printf "current file mode: %06o\n" m+ printFileMode (ModifiedMode (ModePerm o) (ModePerm n)) = printf "file mode: %06o -> %06o\n" o n - ppHitDiff :: [HitDiffContent] -> IO ()- ppHitDiff [] = return ()- ppHitDiff ((HitDiffAddition new):_ ) =- case bsContent new of- FileContent content -> printf "%s" (LC.unpack $ LC.concat $ doPPDiffLine "+" content)- _ -> return ()- ppHitDiff ((HitDiffDeletion old):_ ) =- case bsContent old of- FileContent content -> printf "%s" (LC.unpack $ LC.concat $ doPPDiffLine "-" content)- _ -> return ()- ppHitDiff ((HitDiffChange l ):_ ) = printf "%s" (LC.unpack $ LC.concat $ doPPDiff l)- ppHitDiff ((HitDiffBinChange ):_ ) = putStrLn "Binary files differ"- ppHitDiff (_ :xs) = ppHitDiff xs+ printFileRef :: HitFileRef -> IO ()+ printFileRef (NewRef r) = putStrLn $ "+++ new/" ++ (show r)+ printFileRef (OldRef r) = putStrLn $ "--- old/" ++ (show r)+ printFileRef (UnModifiedRef r) = putStrLn $ "=== cur/" ++ (show r)+ printFileRef (ModifiedRef o n) = do putStrLn $ "+++ new/" ++ (show n)+ putStrLn $ "--- old/" ++ (show o) - doPPDiff :: [Item LC.ByteString] -> [LC.ByteString]- doPPDiff [] = []- doPPDiff ((Both a _):xs) = (doPPDiffLine " " [a]) ++ (doPPDiff xs)- doPPDiff ((Old a ):xs) = (doPPDiffLine "-" [a]) ++ (doPPDiff xs)- doPPDiff ((New b):xs) = (doPPDiffLine "+" [b]) ++ (doPPDiff xs)+ printFileDiff :: HitFileContent -> IO ()+ printFileDiff NewBinaryFile = putStrLn "Binary file created"+ printFileDiff OldBinaryFile = putStrLn "Binary file deleted"+ printFileDiff ModifiedBinaryFile = putStrLn "Binary file modified"+ printFileDiff UnModifiedFile = putStrLn "No changes in the file's content"+ printFileDiff (NewTextFile l) = mapM_ (printFileLine "+") l+ printFileDiff (OldTextFile l) = mapM_ (printFileLine "-") l+ printFileDiff (ModifiedFile fDiff) = mapM_ printFilteredDiff fDiff - doPPDiffLine :: String -> [LC.ByteString] -> [LC.ByteString]- doPPDiffLine _ [] = []- doPPDiffLine prefix (a:xs) = (LC.concat [LC.pack prefix,a,LC.pack "\n"]):(doPPDiffLine prefix xs)+ printFilteredDiff :: FilteredDiff -> IO ()+ printFilteredDiff (NormalLine l) =+ case l of+ (Both (TextLine on ol) (TextLine nn _ )) -> printf "%4d %4d %s\n" on nn (LC.unpack ol)+ (New (TextLine nn nl)) -> printf " %4d +%s\n" nn (LC.unpack nl)+ (Old (TextLine on ol) ) -> printf "%4d -%s\n" on (LC.unpack ol)+ printFilteredDiff _ = putStrLn " [...]" + printFileLine :: String -> TextLine -> IO ()+ printFileLine prefix (TextLine _ line) = putStrLn $ prefix ++ (LC.unpack line)+++showRefs git = do+ putStrLn "[HEADS]"+ heads <- headsList (gitRepoPath git)+ mapM_ (putStrLn . show) heads+ putStrLn "[TAGS]"+ tags <- tagsList (gitRepoPath git)+ mapM_ (putStrLn . show) tags+ main = do args <- getArgs case args of@@ -223,6 +232,7 @@ ["rev-list",rev] -> withCurrentRepo $ revList (fromString rev) ["log",rev] -> withCurrentRepo $ getLog (fromString rev) ["diff",rev1,rev2] -> withCurrentRepo $ showDiff (fromString rev1) (fromString rev2)+ ["show-refs"] -> withCurrentRepo $ showRefs cmd : [] -> error ("unknown command: " ++ cmd) [] -> error "no args" _ -> error "unknown command line arguments"
Tests/Tests.hs view
@@ -61,6 +61,9 @@ m <- (* 30) <$> choose (0,1) return (h * 100 + m - 1200) +instance Arbitrary ModePerm where+ arbitrary = ModePerm <$> elements [ 0o644, 0o664, 0o755, 0 ]+ arbitraryName = liftM3 Person (arbitraryBSnoangle 16) (arbitraryBSnoangle 16) arbitrary
hit.cabal view
@@ -1,5 +1,5 @@ Name: hit-Version: 0.5.4+Version: 0.5.5 Synopsis: Git operations in haskell Description: .