From 667c93f06d45df0515e7ade4dec14bbc85dd4d64 Mon Sep 17 00:00:00 2001
From: Alexander Foremny <aforemny@posteo.de>
Date: Mon, 16 Oct 2023 10:46:05 +0200
Subject: 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 "%".
---
 app/Process.hs | 70 ++++++++++++++++++++++++++++++++++++++++++++++------------
 1 file changed, 56 insertions(+), 14 deletions(-)

(limited to 'app/Process.hs')

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 []
-- 
cgit v1.2.3