hammer in some software engineering

1 files changed, 118 insertions, 151 deletions

diff --git a/git-deli b/git-deli
index cbd35f8..1044b2b 100755
--- a/git-deli
+++ b/git-deli
@@ -20,12 +20,40 @@ import Debug.Trace
 gitProg :: IO String
 gitProg = fromMaybe "git" <$> lookupEnv "DELI_GIT"
 
-setGitRef :: String -> String -> IO ()
-setGitRef refname tgt = do
+gitCmd :: [String] -> IO ()
+gitCmd args = do
+  git <- gitProg
+  st <- rawSystem git args
+  unless (st == ExitSuccess) . fail $ "git command failed: " ++ show args
+
+gitCmdOutput :: [String] -> IO String
+gitCmdOutput args = do
+  git <- gitProg
+  (out, st) <-
+    withCreateProcess (proc git args) {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p ->
+      (,) <$> hGetContents' oh <*> waitForProcess p
+  unless (st == ExitSuccess) . fail
+    $ "git output command failed on: " ++ show args
+  pure out
+
+gitCmdFilter :: [String] -> String -> IO String
+gitCmdFilter args input = do
   git <- gitProg
-  st <- rawSystem git ["update-ref", refname, tgt]
+  (out, st) <-
+    withCreateProcess
+      (proc git args) {std_in = CreatePipe, std_out = CreatePipe} $ \(Just ih) (Just oh) _ p ->
+      (,)
+        <$> (hPutStr ih input >> hClose ih >> hGetContents' oh)
+        <*> waitForProcess p
   unless (st == ExitSuccess) . fail
-    $ "git-update-ref failed for " ++ show (refname, tgt)
+    $ "git filter command failed on: " ++ show args
+  pure out
+
+singleLine what = singleObj what . lines
+
+singleObj :: MonadFail m => String -> [a] -> m a
+singleObj _ [x] = pure x
+singleObj what _ = fail $ "didn't get a single " ++ what
 
 split :: (Char -> Bool) -> String -> [String]
 split p [] = []
@@ -45,7 +73,7 @@ data SourceItem
 itemPath (SourceFile p) = p
 itemPath (SourceRange p _ _) = p
 
-sourceItems = start . map words
+sourceItems = start . map words . traceShowId
   where
     start (("diff":"--git":(a':'/':path):_):ls) = go (SourceFile path) ls
     start (_:ls) = start ls
@@ -63,94 +91,59 @@ sourceItems = start . map words
     go _ [] = []
 
 blameItem :: FilePath -> SourceItem -> IO [String]
-blameItem base (SourceFile path) = do
-  git <- gitProg
-  (out, st) <-
-    withCreateProcess
-      (proc git ["log", "-1", "--full-history", "--format=%H", base, "--", path])
-        {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p ->
-      (,) <$> hGetContents' oh <*> waitForProcess p
-  unless (st == ExitSuccess) . fail $ "git-log failed on " ++ show (base, path)
-  pure $ lines out
-blameItem base (SourceRange path r0 r1) = do
-  git <- gitProg
-  (out, st) <-
-    withCreateProcess
-      (proc
-         git
-         ["annotate", "-l", "-L", show r0 ++ "," ++ show r1, base, "--", path])
-        {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p ->
-      (,) <$> hGetContents' oh <*> waitForProcess p
-  unless (st == ExitSuccess) . fail
-    $ "git-annotate failed on " ++ show (r0, r1, base, path)
-  pure . concatMap (take 1 . words) $ lines out
+blameItem base (SourceFile path) =
+  lines
+    <$> gitCmdOutput
+          ["log", "-1", "--full-history", "--format=%H", base, "--", path]
+blameItem base (SourceRange path r0 r1) =
+  concatMap (take 1 . words) . lines
+    <$> gitCmdOutput
+          [ "annotate"
+          , "-l"
+          , "-L"
+          , show r0 ++ "," ++ show (r0 + r1 - 1)
+          , base
+          , "--"
+          , path
+          ]
 
 indepCommits :: [String] -> IO [String]
 indepCommits = go []
   where
     batch = 32
     go acc [] = pure acc
-    go acc xs = do
-      git <- gitProg
-      (out, st) <-
-        withCreateProcess
-          (proc git
-             $ concat [["merge-base", "--independent"], acc, take batch xs])
-            {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p ->
-          (,) <$> hGetContents' oh <*> waitForProcess p
-      unless (st == ExitSuccess) . fail
-        $ "git-merge-base failed on " ++ show (acc, take batch xs)
-      go (lines out) (drop batch xs)
+    go acc xs =
+      gitCmdOutput (["merge-base", "--independent"] ++ acc ++ take batch xs)
+        >>= (`go` drop batch xs) . lines
 
 diffToSources :: String -> String -> String -> IO [String]
 diffToSources base commit bottom = do
-  git <- gitProg
-  (out, st) <-
-    withCreateProcess
-      (proc git ["diff", "-p", "--no-renames", base, commit])
-        {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p ->
-      (,) <$> hGetContents' oh <*> waitForProcess p
-  unless (st == ExitSuccess) . fail
-    $ "git-diff failed on " ++ show (base, commit)
+  -- TODO: looks quite like this sometimes selects the head, which is ofc an issue
+  out <- lines <$> gitCmdOutput ["diff", "-p", "--no-renames", base, commit]
   bis <-
-    fmap (uniq . sort . uniq . concat) . traverse (blameItem base) . sourceItems
-      $ lines out
-  indepCommits (bottom:bis)
+    fmap (uniq . sort . uniq . concat) . traverse (blameItem base)
+      $ sourceItems out
+  indepCommits (bottom : bis)
 
 makeEmptyTree :: IO String
-makeEmptyTree = do
-  git <- gitProg
-  (out, st) <-
-    withCreateProcess
-      (proc git ["hash-object", "-w", "-t", "tree", "--stdin"])
-        {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p ->
-      (,) <$> hGetContents' oh <*> waitForProcess p
-  unless (st == ExitSuccess) . fail $ "git-hash-object tree failed"
-  case lines out of
-    [x] -> pure x
-    _ -> fail "hash-object tree output?"
+makeEmptyTree =
+  gitCmdOutput ["hash-object", "-w", "-t", "tree", "--stdin"]
+    >>= singleLine "hash-object tree output"
 
 makeEmptyCommit :: IO String
 makeEmptyCommit = do
   et <- makeEmptyTree
-  git <- gitProg
-  let writeCommit h = do
-        hPutStrLn h $ "tree " ++ et
-        hPutStrLn h $ "author git-deli <git-deli@localhost> 1777294464 +0000"
-        hPutStrLn h $ "committer git-deli <git-deli@localhost> 1777294464 +0000"
-        hPutStrLn h $ ""
-        hPutStrLn h $ "git-deli head commit"
-        hClose h
-  (out, st) <-
-    withCreateProcess
-      (proc git ["hash-object", "-w", "-t", "commit", "--stdin"])
-        {std_in = CreatePipe, std_out = CreatePipe} $ \(Just ih) (Just oh) _ p ->
-      (,) <$> (writeCommit ih >> hGetContents' oh) <*> waitForProcess p
-  unless (st == ExitSuccess) . fail $ "git-hash-object commit failed"
+  let commitObj =
+        unlines
+          [ "tree " ++ et
+          , "author git-deli <git-deli@localhost> 1777294464 +0000"
+          , "committer git-deli <git-deli@localhost> 1777294464 +0000"
+          , ""
+          , "git-deli head commit"
+          ]
   ec <-
-    case lines out of
-      [x] -> pure x
-      _ -> fail "hash-object commit output?"
+    gitCmdFilter ["hash-object", "-w", "-t", "commit", "--stdin"] commitObj
+      >>= singleLine "empty commit hash"
   pure ec
 
 mergedCommitsTree [] = makeEmptyTree
@@ -158,29 +151,17 @@ mergedCommitsTree (c:cs) = go c c cs
   where
     go _ t [] = pure t
     go b t (c1:cs) = do
-      git <- gitProg
-      (out, st) <-
-        withCreateProcess
-          (proc git ["merge-base", b, c1])
-            {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p ->
-          (,) <$> hGetContents' oh <*> waitForProcess p
-      unless (st == ExitSuccess) . fail
-        $ "git-merge-base failed with" ++ show (b, c1)
-      b' <-
-        case lines out of
-          [x] -> pure x
-          _ -> fail "merge base output?"
-      (out, st) <-
-        withCreateProcess
-          (proc git ["merge-tree", "--write-tree", "-Xno-renames", "--merge-base=" ++ b', t, c1])
-            {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p ->
-          (,) <$> hGetContents' oh <*> waitForProcess p
-      unless (st == ExitSuccess) . fail
-        $ "git-merge-btree failed with" ++ show (t, c1, b')
+      b' <- gitCmdOutput ["merge-base", b, c1] >>= singleLine "merge base"
       t' <-
-        case lines out of
-          [x] -> pure x
-          _ -> fail "merge-tree output??"
+        gitCmdOutput
+          [ "merge-tree"
+          , "--write-tree"
+          , "-Xno-renames"
+          , "--merge-base=" ++ b'
+          , t
+          , c1
+          ]
+          >>= singleLine "merged tree hash"
       go b' t' cs
 
 delinearize :: String -> String -> String -> IO String
@@ -189,71 +170,57 @@ delinearize head commit bottom = do
   t <- mergedCommitsTree parents
   git <- gitProg
   -- create a new tree which is essentially commit-head+mergedtree
-  (out, st) <-
-    withCreateProcess
-      (proc
-         git
-         ["merge-tree", "--write-tree", "-Xno-renames", "--merge-base=" ++ head, t, commit])
-        {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p ->
-      (,) <$> hGetContents' oh <*> waitForProcess p
-  unless (st == ExitSuccess) . fail $ "final git-merge-tree failed" ++ show (head,t,commit)
   t' <-
-    case lines out of
-      [x] -> pure x
-      _ -> fail "final merge-tree returned what?"
+    gitCmdOutput
+      [ "merge-tree"
+      , "--write-tree"
+      , "-Xno-renames"
+      , "--merge-base=" ++ head
+      , t
+      , commit
+      ]
+      >>= singleLine "transplanted tree hash"
   -- now let's get all the data from the original commit and change parents
-  (commitMsg', st) <-
-    withCreateProcess
-      (proc git ["cat-file", "commit", commit])
-        {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p ->
-      (,) <$> hGetContents' oh <*> waitForProcess p
-  unless (st == ExitSuccess) . fail $ "git-cat-file failed"
+  commitMsg' <- gitCmdOutput ["cat-file", "commit", commit]
   let (msgHead, msgBody) = break null $ lines commitMsg'
       commitMsg =
-        unlines $ concat
-          [["tree " ++ t'],
-              map ("parent " ++) parents
-              , filter (not . flip elem [["parent"], ["tree"]] . take 1 . words) msgHead
-              , msgBody ]
+        unlines
+          $ concat
+              [ ["tree " ++ t']
+              , map ("parent " ++) parents
+              , filter
+                  (not . flip elem [["parent"], ["tree"]] . take 1 . words)
+                  msgHead
+              , msgBody
+              ]
   -- label the stuff with a proper commit
-  (out, st) <-
-    withCreateProcess
-      (proc git ["hash-object", "-w", "-t", "commit", "--stdin"])
-        {std_in = CreatePipe, std_out = CreatePipe} $ \(Just ih) (Just oh) _ p ->
-      (,) <$> (hPutStr ih commitMsg >> hClose ih >> hGetContents' oh) <*> waitForProcess p
-  unless (st == ExitSuccess) . fail $ "git-hash-object final commit failed"
   commit' <-
-    case lines out of
-      [x] -> pure x
-      _ -> fail "final has-object returned what?"
+    gitCmdFilter ["hash-object", "-w", "-t", "commit", "--stdin"] commitMsg
+      >>= singleLine "transplanted commit hash-object"
   -- take the old head
-  (headMsg',st) <-
-    withCreateProcess
-      (proc git ["cat-file", "commit", head])
-        {std_in = CreatePipe, std_out = CreatePipe} $ \(Just ih) (Just oh) _ p ->
-      (,) <$> (hPutStr ih commitMsg >> hClose ih >> hGetContents' oh) <*> waitForProcess p
-  unless (st == ExitSuccess) . fail $ "git-cat-file old head failed"
+  headMsg' <- gitCmdOutput ["cat-file", "commit", head]
   -- make a new one
   let (hHead, hBody) = break null $ lines headMsg'
-      getP ["parent",x] = [x]
+      getP ["parent", x] = [x]
       getP _ = []
-  hParents <- indepCommits . (commit':) $ concatMap (getP.words) hHead
-  let headMsg = unlines $ concat
-          [ filter ((==["tree"]) . take 1 . words) msgHead
-          , map ("parent "++) hParents
-          , filter (not . flip elem [["parent"], ["tree"]] . take 1 . words) hHead
-          , hBody ]
+  hParents <- indepCommits . (commit' :) $ concatMap (getP . words) hHead
+  let headMsg =
+        unlines
+          $ concat
+              [ filter ((== ["tree"]) . take 1 . words) msgHead
+              , map ("parent " ++) hParents
+              , filter
+                  (not . flip elem [["parent"], ["tree"]] . take 1 . words)
+                  hHead
+              , hBody
+              ]
   -- write the new head
-  (out, st) <-
-    withCreateProcess
-      (proc git ["hash-object", "-w", "-t", "commit", "--stdin"])
-        {std_in = CreatePipe, std_out = CreatePipe} $ \(Just ih) (Just oh) _ p ->
-      (,) <$> (hPutStr ih headMsg >> hClose ih >> hGetContents' oh) <*> waitForProcess p
-  unless (st == ExitSuccess) . fail $ "git-hash-object new head commit failed"
   hcommit' <-
-    case lines out of
-      [x] -> pure x
-      _ -> fail "hash-object new head returned what?"
+    gitCmdFilter ["hash-object", "-w", "-t", "commit", "--stdin"] headMsg
+      >>= singleLine "new head hash-object"
   pure hcommit'
 
+setGitRef :: String -> String -> IO ()
+setGitRef refname tgt = gitCmd ["update-ref", refname, tgt]
+
 main = undefined