chore: init

1 files changed, 153 insertions, 0 deletions

diff --git a/src/Process/Shell.hs b/src/Process/Shell.hs
new file mode 100644
index 0000000..94ba3c9
--- /dev/null
+++ b/src/Process/Shell.hs
@@ -0,0 +1,153 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE OverlappingInstances #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Process.Shell
+  ( sh,
+    Quotable (..),
+  )
+where
+
+import Control.Monad
+import Data.ByteString qualified as B
+import Data.ByteString.Lazy qualified as LB
+import Data.ByteString.Lazy.UTF8 qualified as LB
+import Data.ByteString.UTF8 qualified as B
+import Data.Functor.Identity
+import Data.Maybe
+import Data.String
+import Data.Text qualified as T
+import Data.Text.Encoding qualified as T
+import Data.Text.Lazy qualified as LT
+import Data.Text.Lazy.Encoding qualified as LT
+import Data.Void
+import Language.Haskell.TH
+import Language.Haskell.TH.Quote
+import System.Process.Typed
+import Text.Megaparsec
+import Text.Megaparsec.Char
+
+class Processable a r where
+  sh_ :: a -> r
+
+instance (Processable a r) => Processable (String -> a) (String -> r) where
+  sh_ f x = sh_ (f x)
+
+instance Processable String (IO ()) where
+  sh_ s = do
+    runProcess_ (fromString s)
+
+instance (Outputable a) => Processable String (IO a) where
+  sh_ s = do
+    fromLBS <$> readProcessInterleaved_ (fromString s)
+
+instance (Outputable stdout, Outputable stderr) => Processable String (IO (stdout, stderr)) where
+  sh_ s = do
+    (\(out, err) -> (fromLBS out, fromLBS err)) <$> readProcess_ (fromString s)
+
+instance (Outputable stdout, Outputable stderr) => Processable String (IO (ExitCode, stdout, stderr)) where
+  sh_ s = do
+    (\(exitCode, out, err) -> (exitCode, fromLBS out, fromLBS err)) <$> readProcess (fromString s)
+
+class Outputable a where
+  fromLBS :: LB.ByteString -> a
+
+instance Outputable String where
+  fromLBS = LB.toString
+
+instance Outputable B.ByteString where
+  fromLBS = LB.toStrict
+
+instance Outputable LB.ByteString where
+  fromLBS = id
+
+instance Outputable T.Text where
+  fromLBS = T.decodeUtf8 . fromLBS
+
+instance Outputable LT.Text where
+  fromLBS = LT.decodeUtf8
+
+class Quotable a where
+  squote :: a -> String
+  squote = squote . toString
+
+  dquote :: a -> String
+  dquote = dquote . toString
+
+  toString :: a -> String
+  default toString :: (Show a) => a -> String
+  toString = show
+
+instance Quotable String where
+  squote s = "'" <> quote' s <> "'"
+    where
+      quote' [] = []
+      quote' ('\'' : cs) = '\'' : '\\' : '\'' : '\'' : quote' cs
+      quote' (c : cs) = c : quote' cs
+
+  dquote s = "\"" <> quote' s <> "\""
+    where
+      quote' [] = []
+      quote' ('\\' : c : cs) = c : quote' cs
+      quote' ('"' : cs) = '\\' : '"' : quote' cs
+      quote' (c : cs) = c : quote' cs
+
+instance Quotable Int
+
+instance Quotable B.ByteString where
+  toString = B.toString
+
+instance Quotable LB.ByteString where
+  toString = LB.toString
+
+instance Quotable T.Text where
+  toString = T.unpack
+
+instance Quotable LT.Text where
+  toString = LT.unpack
+
+data Expr a
+  = Lit String
+  | Var Bool a
+  deriving (Show)
+
+expr :: (String -> b) -> (Bool -> a -> b) -> Expr a -> b
+expr f _ (Lit a) = f a
+expr _ g (Var q a) = g q a
+
+unVar :: Expr a -> Maybe a
+unVar (Lit _) = Nothing
+unVar (Var _ a) = Just a
+
+sh :: QuasiQuoter
+sh = QuasiQuoter quoteExp undefined undefined undefined
+  where
+    quoteExp :: String -> Q Exp
+    quoteExp =
+      either (fail . errorBundlePretty) makeExp
+        . parse (parser <* eof) ""
+
+    parser :: ParsecT Void String Identity [Expr ()]
+    parser =
+      many . choice $
+        [ const (Lit "%") <$> string "%%",
+          const (Var True ()) <$> string "'%'",
+          const (Var False ()) <$> satisfy (== '%'),
+          Lit <$> takeWhile1P Nothing (not . (`elem` "'%")),
+          Lit <$> string "'%",
+          Lit <$> string "'"
+        ]
+
+    makeExp :: [Expr ()] -> Q Exp
+    makeExp exprs' = do
+      exprs <-
+        mapM
+          (expr (pure . Lit) (\q _ -> Var q <$> newName "x"))
+          exprs'
+      lamE (map varP (mapMaybe unVar exprs)) . appE [|sh_|] $
+        flip (foldM (flip go)) exprs =<< [|""|]
+
+    go (Lit s) = appE [|flip (++) s|] . pure
+    go (Var q n) = appE (appE [|flip (++)|] (appE [|if q then squote else dquote|] (varE n))) . pure