add Process.proc

Adds type-trickery akin to `Text.printf` to provide

- (1) an abstraction over `fromString (printf ".." ..)` for
  `ProcessConfig`s,
- (2) have arguments be quoted automatically.

As string is the only argument type that Shell knows, the formatting
character is simply "%".

3 files changed, 70 insertions, 36 deletions

diff --git a/anissue.cabal b/anissue.cabal
index 7259422..fd051cc 100644
--- a/anissue.cabal
+++ b/anissue.cabal
@@ -112,4 +112,5 @@ executable anissue
       OverloadedRecordDot
       OverloadedStrings
       PartialTypeSignatures
+      TypeFamilies
       ViewPatterns
diff --git a/app/History.hs b/app/History.hs
index 0e7465c..f436672 100644
--- a/app/History.hs
+++ b/app/History.hs
@@ -5,16 +5,15 @@ import Data.Aeson (eitherDecode)
 import Data.Binary (Binary, decodeFileOrFail, encodeFile)
 import Data.ByteString.Lazy.Char8 qualified as L8
 import Data.Function ((&))
-import Data.List (foldl', intercalate)
+import Data.List (foldl')
 import Data.Maybe (catMaybes, mapMaybe)
-import Data.String (fromString)
 import Data.Text (Text, append, isPrefixOf, lines, pack, unpack)
 import Data.Text.Encoding (decodeUtf8)
 import GHC.Generics (Generic)
 import Issue (Issue (..), fromMatch, id)
 import Issue.Filter (Filter, applyFilter)
 import Parallel (parMapM)
-import Process (quote, sh, sh_)
+import Process (proc, sh, sh_)
 import System.Directory (createDirectoryIfMissing, doesFileExist, getCurrentDirectory)
 import System.Exit (ExitCode (ExitFailure), exitWith)
 import System.FilePath (takeExtension, (</>))
@@ -39,9 +38,9 @@ listIssues filters paths = do
       -- contain the full issue title and description.  For a fast
       -- lookup it may already be enough to only store the issue's
       --
-      -- * filename
-      -- * start position
-      -- * end position
+      -- \* filename
+      -- \* start position
+      -- \* end position
       --
       -- With this information we can use git to quickly look up the
       -- complete issue text and parse it.
@@ -216,7 +215,7 @@ getIssuesCommitAll hash = do
   withSystemTempDirectory "history" $ \tmp -> do
     cwd <- do
       let cwd = tmp </> unpack hash
-      sh_ $ fromString $ printf "git worktree add --detach %s %s" (quote cwd) (quote $ unpack hash)
+      sh_ $ proc "git worktree add --detach % %" cwd (unpack hash)
       pure cwd
     files <- gitLsFilesAll cwd
     concat <$> catch (getIssuesPar cwd files) (dieOfInvalidTreeGrepperResult)
@@ -228,7 +227,7 @@ getIssuesAndFilesCommitChanged hash = do
   withSystemTempDirectory "history" $ \tmp -> do
     cwd <- do
       let cwd = tmp </> unpack hash
-      sh_ $ fromString $ printf "git worktree add --detach %s %s" (quote cwd) (quote $ unpack hash)
+      sh_ $ proc "git worktree add --detach % %" cwd (unpack hash)
       pure cwd
     files <- gitShowChanged cwd
     issues <- concat <$> catch (getIssuesPar cwd files) (dieOfInvalidTreeGrepperResult)
@@ -248,13 +247,7 @@ gitLsFilesModifiedIn :: FilePath -> [FilePath] -> IO [FilePath]
 gitLsFilesModifiedIn cwd paths =
   Prelude.lines . L8.unpack
     <$> sh
-      ( fromString
-          ( (printf "git ls-files --modified%s")
-              ( case paths of
-                  [] -> ""
-                  _ -> " -- " ++ intercalate " " (map quote paths)
-              )
-          )
+      ( proc "git ls-files --modified %" ("--" : paths)
           & setWorkingDir cwd
       )
 
@@ -317,13 +310,11 @@ getIssues cwd filename = do
       . map fixTreeGrepper
       . decode
       <$> sh
-        ( fromString
-            ( printf
-                "tree-grepper --query %s %s --format json %s"
-                (quote treeGrepperLanguage)
-                (quote treeGrepperQuery)
-                (quote filename)
-            )
+        ( proc
+            "tree-grepper --query % % --format json %"
+            (treeGrepperLanguage :: String)
+            (treeGrepperQuery :: String)
+            filename
             & setWorkingDir cwd
         )
 
diff --git a/app/Process.hs b/app/Process.hs
index ecc9cd3..8ad4346 100644
--- a/app/Process.hs
+++ b/app/Process.hs
@@ -1,7 +1,20 @@
-module Process (sh, sh_, quote) where
+{-# LANGUAGE ImpredicativeTypes #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+
+module Process
+  ( sh,
+    sh_,
+    ProcessType,
+    Quotable (..),
+    proc,
+  )
+where
 
 import Control.Exception (Exception, throwIO)
 import Data.ByteString.Lazy (ByteString)
+import Data.List (intercalate)
+import Data.String (fromString)
+import Data.Text (Text, unpack)
 import System.Exit (ExitCode (ExitSuccess))
 import System.Process.Typed (ProcessConfig, readProcess, readProcessStderr)
 
@@ -11,22 +24,51 @@ data ProcessException = ProcessException String ExitCode ByteString
 instance Exception ProcessException
 
 sh :: ProcessConfig stdin stdoutIgnored stderr -> IO ByteString
-sh proc = do
-  (exitCode, out, err) <- readProcess proc
+sh processConfig = do
+  (exitCode, out, err) <- readProcess processConfig
   if exitCode == ExitSuccess
     then pure out
-    else throwIO $ ProcessException (show proc) exitCode err
+    else throwIO $ ProcessException (show processConfig) exitCode err
 
 sh_ :: ProcessConfig stdin stdoutIgnored stderr -> IO ()
-sh_ proc = do
-  (exitCode, err) <- readProcessStderr proc
+sh_ processConfig = do
+  (exitCode, err) <- readProcessStderr processConfig
   if exitCode == ExitSuccess
     then pure ()
-    else throwIO $ ProcessException (show proc) exitCode err
-
-quote :: String -> String
-quote s = "'" ++ escape s ++ "'"
-  where
-    escape [] = []
-    escape ('\'' : cs) = '\'' : '\\' : '\'' : '\'' : escape cs
-    escape (c : cs) = c : escape cs
+    else throwIO $ ProcessException (show processConfig) exitCode err
+
+class Quotable a where
+  quote :: a -> String
+
+instance {-# OVERLAPPING #-} Quotable String where
+  quote s = "'" ++ escape s ++ "'"
+    where
+      escape [] = []
+      escape ('\'' : cs) = '\'' : '\\' : '\'' : '\'' : escape cs
+      escape (c : cs) = c : escape cs
+
+instance Quotable Text where
+  quote = quote . unpack
+
+instance {-# OVERLAPPABLE #-} Quotable a => Quotable [a] where
+  quote = intercalate " " . map quote
+
+class ProcessType r where
+  spr :: String -> [String] -> r
+
+instance (Quotable a, ProcessType r) => ProcessType (a -> r) where
+  spr fmt as = \a -> spr fmt (quote a : as)
+
+instance (() ~ stdin, () ~ stdoutIgnored, () ~ stderr) => ProcessType (ProcessConfig stdin stdoutIgnored stderr) where
+  spr fmt args = fromString (interp (reverse args) fmt)
+
+interp :: [String] -> String -> String
+interp (_ : _) "" = error "sh: extra arguments"
+interp [] "" = ""
+interp as ('%' : '%' : cs) = '%' : interp as cs
+interp [] ('%' : _) = error "sh: insufficient arguments"
+interp (a : as) ('%' : cs) = a ++ interp as cs
+interp as (c : cs) = c : interp as cs
+
+proc :: ProcessType r => String -> r
+proc fmt = spr fmt []