diff options
| -rw-r--r-- | anissue.cabal | 1 | ||||
| -rw-r--r-- | app/History.hs | 35 | ||||
| -rw-r--r-- | app/Process.hs | 70 |
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 [] |