ByteString Ref continued

Attoparsec parser for diff-tree.

Changed fromRef back to producing a String, to avoid needing to convert
every use of it. However, this does mean I'm going to miss some
opportunities where fromRef is used and the result converted back to a
ByteString. Would be worth revisiting that at some point maybe.

Git.hs

@@ -14,6 +14,7 @@ module Git (
 	Repo(..),
 	Ref(..),
 	fromRef,
+	fromRef',
 	Branch,
 	Sha,
 	Tag,

Git/DiffTree.hs

@@ -1,6 +1,6 @@
 {- git diff-tree interface
  -
- - Copyright 2012 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2020 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -18,6 +18,9 @@ module Git.DiffTree (
 ) where
 
 import Numeric
+import qualified Data.ByteString.Lazy as L
+import qualified Data.Attoparsec.ByteString.Lazy as A
+import qualified Data.Attoparsec.ByteString.Char8 as A8
 
 import Common
 import Git
@@ -27,6 +30,7 @@ import Git.FilePath
 import Git.DiffTreeItem
 import qualified Git.Filename
 import qualified Git.Ref
+import Utility.Attoparsec
 
 {- Checks if the DiffTreeItem modifies a file with a given name
  - or under a directory by that name. -}
@@ -89,7 +93,7 @@ commitDiff ref = getdiff (Param "show")
 getdiff :: CommandParam -> [CommandParam] -> Repo -> IO ([DiffTreeItem], IO Bool)
 getdiff command params repo = do
 	(diff, cleanup) <- pipeNullSplit ps repo
-	return (parseDiffRaw (map decodeBL diff), cleanup)
+	return (parseDiffRaw diff, cleanup)
   where
 	ps = 
 		command :
@@ -100,26 +104,28 @@ getdiff command params repo = do
 		params
 
 {- Parses --raw output used by diff-tree and git-log. -}
-parseDiffRaw :: [String] -> [DiffTreeItem]
+parseDiffRaw :: [L.ByteString] -> [DiffTreeItem]
 parseDiffRaw l = go l
   where
 	go [] = []
-	go (info:f:rest) = mk info f : go rest
-	go (s:[]) = error $ "diff-tree parse error near \"" ++ s ++ "\""
+	go (info:f:rest) = case A.parse (parserDiffRaw (L.toStrict f)) info of
+		A.Done _ r -> r : go rest
+		A.Fail _ _ err -> error $ "diff-tree parse error: " ++ err
+	go (s:[]) = error $ "diff-tree parse error near \"" ++ decodeBL' s ++ "\""
 
-	mk info f = DiffTreeItem
-		{ srcmode = readmode srcm
-		, dstmode = readmode dstm
-		, srcsha = fromMaybe (error "bad srcsha") $ extractSha ssha
-		, dstsha = fromMaybe (error "bad dstsha") $ extractSha dsha
-		, status = s
-		, file = asTopFilePath $ fromInternalGitPath $ Git.Filename.decode $ toRawFilePath f
-		}
-	  where
-		readmode = fst . Prelude.head . readOct
-
-		-- info = :<srcmode> SP <dstmode> SP <srcsha> SP <dstsha> SP <status>
-		(srcm, past_srcm) = splitAt 7 $ drop 1 info
-		(dstm, past_dstm) = splitAt 7 past_srcm
-		(ssha, past_ssha) = separate (== ' ') past_dstm
-		(dsha, s) = separate (== ' ') past_ssha
+-- :<srcmode> SP <dstmode> SP <srcsha> SP <dstsha> SP <status>
+parserDiffRaw :: RawFilePath -> A.Parser DiffTreeItem
+parserDiffRaw f = DiffTreeItem
+	<$ A8.char ':'
+	<*> octal
+	<* A8.char ' '
+	<*> octal
+	<* A8.char ' '
+	<*> (maybe (fail "bad srcsha") return . extractSha =<< nextword)
+	<* A8.char ' '
+	<*> (maybe (fail "bad dstsha") return . extractSha =<< nextword)
+	<* A8.char ' '
+	<*> A.takeByteString
+	<*> pure (asTopFilePath $ fromInternalGitPath $ Git.Filename.decode f)
+  where
+	nextword = A8.takeTill (== ' ')

Git/DiffTreeItem.hs

@@ -10,6 +10,7 @@ module Git.DiffTreeItem (
 ) where
 
 import System.Posix.Types
+import qualified Data.ByteString as S
 
 import Git.FilePath
 import Git.Types
@@ -19,6 +20,6 @@ data DiffTreeItem = DiffTreeItem
 	, dstmode :: FileMode
 	, srcsha :: Sha -- null sha if file was added
 	, dstsha :: Sha -- null sha if file was deleted
-	, status :: String
+	, status :: S.ByteString
 	, file :: TopFilePath
 	} deriving Show

Git/FilePath.hs

@@ -50,7 +50,7 @@ data BranchFilePath = BranchFilePath Ref TopFilePath
 {- Git uses the branch:file form to refer to a BranchFilePath -}
 descBranchFilePath :: BranchFilePath -> S.ByteString
 descBranchFilePath (BranchFilePath b f) =
-	fromRef b <> ":" <> getTopFilePath f
+	fromRef' b <> ":" <> getTopFilePath f
 
 {- Path to a TopFilePath, within the provided git repo. -}
 fromTopFilePath :: TopFilePath -> Git.Repo -> RawFilePath

Git/LsTree.hs

@@ -96,7 +96,7 @@ parserLsTree = TreeItem
 	<*> A8.takeTill (== ' ')
 	<* A8.char ' '
 	-- sha
-	<*> (Ref . decodeBS' <$> A8.takeTill (== '\t'))
+	<*> (Ref <$> A8.takeTill (== '\t'))
 	<* A8.char '\t'
 	-- file
 	<*> (asTopFilePath . Git.Filename.decode <$> A.takeByteString)
@@ -106,6 +106,6 @@ formatLsTree :: TreeItem -> String
 formatLsTree ti = unwords
 	[ showOct (mode ti) ""
 	, decodeBS (typeobj ti)
-	, decodeBS' (fromRef (sha ti))
+	, fromRef (sha ti)
 	, fromRawFilePath (getTopFilePath (file ti))
 	]

Git/Objects.hs

@@ -32,7 +32,7 @@ listLooseObjectShas r = catchDefaultIO [] $
 looseObjectFile :: Repo -> Sha -> FilePath
 looseObjectFile r sha = objectsDir r </> prefix </> rest
   where
-	(prefix, rest) = splitAt 2 (decodeBS' (fromRef sha))
+	(prefix, rest) = splitAt 2 (fromRef sha)
 
 listAlternates :: Repo -> IO [FilePath]
 listAlternates r = catchDefaultIO [] (lines <$> readFile alternatesfile)

Git/Ref.hs

@@ -17,6 +17,7 @@ import Git.Types
 
 import Data.Char (chr, ord)
 import qualified Data.ByteString as S
+import qualified Data.ByteString.Char8 as S8
 
 headRef :: Ref
 headRef = Ref "HEAD"
@@ -41,10 +42,11 @@ base = removeBase "refs/heads/" . removeBase "refs/remotes/"
 {- Removes a directory such as "refs/heads/master" from a
  - fully qualified ref. Any ref not starting with it is left as-is. -}
 removeBase :: String -> Ref -> Ref
-removeBase dir (Ref r)
-	| prefix `isPrefixOf` r = Ref (drop (length prefix) r)
-	| otherwise = Ref r
+removeBase dir r
+	| prefix `isPrefixOf` rs = Ref $ encodeBS $ drop (length prefix) rs
+	| otherwise = r
   where
+	rs = fromRef r
 	prefix = case end dir of
 		['/'] -> dir
 		_ -> dir ++ "/"
@@ -53,7 +55,7 @@ removeBase dir (Ref r)
  - refs/heads/master, yields a version of that ref under the directory,
  - such as refs/remotes/origin/master. -}
 underBase :: String -> Ref -> Ref
-underBase dir r = Ref $ dir ++ "/" ++ fromRef (base r)
+underBase dir r = Ref $ encodeBS' $ dir ++ "/" ++ fromRef (base r)
 
 {- Convert a branch such as "master" into a fully qualified ref. -}
 branchRef :: Branch -> Ref
@@ -66,21 +68,25 @@ branchRef = underBase "refs/heads"
  - of a repo.
  -}
 fileRef :: RawFilePath -> Ref
-fileRef f = Ref $ ":./" ++ fromRawFilePath f
+fileRef f = Ref $ ":./" <> f
 
 {- Converts a Ref to refer to the content of the Ref on a given date. -}
 dateRef :: Ref -> RefDate -> Ref
-dateRef (Ref r) (RefDate d) = Ref $ r ++ "@" ++ d
+dateRef r (RefDate d) = Ref $ fromRef' r <> "@" <> encodeBS' d
 
 {- A Ref that can be used to refer to a file in the repository as it
  - appears in a given Ref. -}
 fileFromRef :: Ref -> RawFilePath -> Ref
-fileFromRef (Ref r) f = let (Ref fr) = fileRef f in Ref (r ++ fr)
+fileFromRef r f = let (Ref fr) = fileRef f in Ref (fromRef' r <> fr)
 
 {- Checks if a ref exists. -}
 exists :: Ref -> Repo -> IO Bool
 exists ref = runBool
-	[Param "show-ref", Param "--verify", Param "-q", Param $ fromRef ref]
+	[ Param "show-ref"
+	, Param "--verify"
+	, Param "-q"
+	, Param $ fromRef ref
+	]
 
 {- The file used to record a ref. (Git also stores some refs in a
  - packed-refs file.) -}
@@ -107,26 +113,26 @@ sha branch repo = process <$> showref repo
 		]
 	process s
 		| S.null s = Nothing
-		| otherwise = Just $ Ref $ decodeBS' $ firstLine' s
+		| otherwise = Just $ Ref $ firstLine' s
 
 headSha :: Repo -> IO (Maybe Sha)
 headSha = sha headRef
 
 {- List of (shas, branches) matching a given ref or refs. -}
 matching :: [Ref] -> Repo -> IO [(Sha, Branch)]
-matching refs repo =  matching' (map fromRef refs) repo
+matching = matching' []
 
 {- Includes HEAD in the output, if asked for it. -}
 matchingWithHEAD :: [Ref] -> Repo -> IO [(Sha, Branch)]
-matchingWithHEAD refs repo = matching' ("--head" : map fromRef refs) repo
+matchingWithHEAD = matching' [Param "--head"]
 
-{- List of (shas, branches) matching a given ref spec. -}
-matching' :: [String] -> Repo -> IO [(Sha, Branch)]
-matching' ps repo = map gen . lines . decodeBS' <$> 
-	pipeReadStrict (Param "show-ref" : map Param ps) repo
+matching' :: [CommandParam] -> [Ref] -> Repo -> IO [(Sha, Branch)]
+matching' ps rs repo = map gen . S8.lines <$> 
+	pipeReadStrict (Param "show-ref" : ps ++ rps) repo
   where
-	gen l = let (r, b) = separate (== ' ') l
+	gen l = let (r, b) = separate' (== fromIntegral (ord ' ')) l
 		in (Ref r, Ref b)
+	rps = map (Param . fromRef) rs
 
 {- List of (shas, branches) matching a given ref.
  - Duplicate shas are filtered out. -}
@@ -137,7 +143,7 @@ matchingUniq refs repo = nubBy uniqref <$> matching refs repo
 
 {- List of all refs. -}
 list :: Repo -> IO [(Sha, Ref)]
-list = matching' []
+list = matching' [] []
 
 {- Deletes a ref. This can delete refs that are not branches, 
  - which git branch --delete refuses to delete. -}
@@ -145,8 +151,8 @@ delete :: Sha -> Ref -> Repo -> IO ()
 delete oldvalue ref = run
 	[ Param "update-ref"
 	, Param "-d"
-	, Param $ decodeBS' (fromRef ref)
-	, Param $ decodeBS' (fromRef oldvalue)
+	, Param $ fromRef ref
+	, Param $ fromRef oldvalue
 	]
 
 {- Gets the sha of the tree a ref uses. 

Git/RefLog.hs

@@ -21,7 +21,7 @@ get b = getMulti [b]
 
 {- Gets reflogs for multiple branches. -}
 getMulti :: [Branch] -> Repo -> IO [Sha]
-getMulti bs = get' (map (Param . decodeBS' . fromRef) bs)
+getMulti bs = get' (map (Param . fromRef) bs)
 
 get' :: [CommandParam] -> Repo -> IO [Sha]
 get' ps = mapMaybe (extractSha . S.copy) . S8.lines <$$> pipeReadStrict ps'

Git/Types.hs

@@ -84,8 +84,11 @@ type RemoteName = String
 newtype Ref = Ref S.ByteString
 	deriving (Eq, Ord, Read, Show)
 
-fromRef :: Ref -> S.ByteString
-fromRef (Ref s) = s
+fromRef :: Ref -> String
+fromRef = decodeBS' . fromRef'
+
+fromRef' :: Ref -> S.ByteString
+fromRef' (Ref s) = s
 
 {- Aliases for Ref. -}
 type Branch = Ref

Git/UpdateIndex.hs

@@ -90,7 +90,7 @@ updateIndexLine :: Sha -> TreeItemType -> TopFilePath -> L.ByteString
 updateIndexLine sha treeitemtype file = L.fromStrict $
 	fmtTreeItemType treeitemtype
 	<> " blob "
-	<> fromRef sha
+	<> fromRef' sha
 	<> "\t"
 	<> indexPath file
 
@@ -108,7 +108,7 @@ unstageFile file repo = do
 unstageFile' :: TopFilePath -> Streamer
 unstageFile' p = pureStreamer $ L.fromStrict $
 	"0 "
-	<> fromRef deleteSha
+	<> fromRef' deleteSha
 	<> "\t"
 	<> indexPath p
 

Types/RefSpec.hs

@@ -43,10 +43,10 @@ applyRefSpec refspec rs getreflog = go [] refspec
 	go c [] = return (reverse c)
 	go c (AddRef r : rest) = go (r:c) rest
 	go c (AddMatching g : rest) =
-		let add = filter (matchGlob g . decodeBS' . fromRef) rs
+		let add = filter (matchGlob g . fromRef) rs
 		in go (add ++ c) rest
 	go c (AddRefLog : rest) = do
 		reflog <- getreflog
 		go (reflog ++ c) rest
 	go c (RemoveMatching g : rest) = 
-		go (filter (not . matchGlob g . decodeBS' . fromRef) c) rest
+		go (filter (not . matchGlob g . fromRef) c) rest

Utility/Misc.hs

@@ -11,6 +11,7 @@ module Utility.Misc (
 	hGetContentsStrict,
 	readFileStrict,
 	separate,
+	separate',
 	firstLine,
 	firstLine',
 	segment,
@@ -54,6 +55,13 @@ separate c l = unbreak $ break c l
 		| null b = r
 		| otherwise = (a, tail b)
 
+separate' :: (Word8 -> Bool) -> S.ByteString -> (S.ByteString, S.ByteString)
+separate' c l = unbreak $ S.break c l
+  where
+	unbreak r@(a, b)
+		| S.null b = r
+		| otherwise = (a, S.tail b)
+
 {- Breaks out the first line. -}
 firstLine :: String -> String
 firstLine = takeWhile (/= '\n')