1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
|
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Process.Shell
( sh,
Quotable (..),
)
where
import Control.Monad
import Control.Monad.Trans
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 (MonadIO m) => Processable String (m ()) where
sh_ s = do
liftIO (runProcess_ (fromString s))
instance (MonadIO m, Outputable a) => Processable String (m a) where
sh_ s = do
fromLBS <$> liftIO (readProcessInterleaved_ (fromString s))
instance (MonadIO m, Outputable stdout, Outputable stderr) => Processable String (m (stdout, stderr)) where
sh_ s = do
(\(out, err) -> (fromLBS out, fromLBS err))
<$> liftIO (readProcess_ (fromString s))
instance (MonadIO m, Outputable stdout, Outputable stderr) => Processable String (m (ExitCode, stdout, stderr)) where
sh_ s = do
(\(exitCode, out, err) -> (exitCode, fromLBS out, fromLBS err))
<$> liftIO (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
|
