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
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
|
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Process.Shell
( sh,
Quotable (..),
ExitCodeException (..),
DecodeException (..),
)
where
import Control.Exception (Exception, throw)
import Control.Monad
import Control.Monad.Reader
import Data.Aeson
import Data.ByteString.Char8 qualified as B
import Data.ByteString.Lazy.Char8 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 hiding (Type)
import Language.Haskell.TH.Quote
import System.Process.Typed
import Text.Megaparsec
import Text.Megaparsec.Char
import Prelude hiding (exp)
data Script = Script (LB.ByteString -> LB.ByteString) String
class Processable m r where
sh_ :: m Script -> m r
instance (MonadIO m) => Processable m () where
sh_ = ((\(Script _ s) -> liftIO (runProcess_ (fromString s))) =<<)
instance (MonadIO m, Outputable a) => Processable m a where
sh_ = ((\(Script strip s) -> fmap (fromLBS . strip) (liftIO (readProcessInterleaved_ (fromString s)))) =<<)
instance (MonadIO m, Outputable stdout, Outputable stderr) => Processable m (stdout, stderr) where
sh_ = ((\(Script stripNL s) -> fmap (\(out, err) -> (fromLBS (stripNL out), fromLBS (stripNL err))) (liftIO (readProcess_ (fromString s)))) =<<)
instance (MonadIO m) => Processable m ExitCode where
sh_ = ((\(Script _ s) -> liftIO (runProcess (fromString s))) =<<)
instance (MonadIO m, Outputable stdout, Outputable stderr) => Processable m (ExitCode, stdout, stderr) where
sh_ = ((\(Script stripNL s) -> fmap (\(exitCode, out, err) -> (exitCode, fromLBS (stripNL out), fromLBS (stripNL 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
data DecodeException = DecodeException String
deriving (Show)
instance Exception DecodeException
instance (FromJSON a) => Outputable a where
fromLBS = either (throw . DecodeException) id . eitherDecode
class Quotable a where
toString :: a -> String
default toString :: (Show a) => a -> String
toString = show
instance Quotable String where
toString = id
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
squote :: String -> String
squote s = "'" <> quote' s <> "'"
where
quote' [] = []
quote' ('\'' : cs) = '\'' : '\\' : '\'' : '\'' : quote' cs
quote' (c : cs) = c : quote' cs
dquote :: String -> String
dquote s = "\"" <> quote' s <> "\""
where
quote' [] = []
quote' ('\\' : c : cs) = c : quote' cs
quote' ('"' : cs) = '\\' : '"' : quote' cs
quote' (c : cs) = c : quote' cs
data Expr a
= Lit String
| Var Bool 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 (Q Exp)], Bool)
parser =
(,)
<$> ( many . choice . map try $
[ do
-- TODO Splice arbitrary Haskell expressions
Var False . varE . mkName
<$> ( string "#{{"
*> takeWhile1P Nothing (/= '}')
<* string "}}"
),
do
Var True . varE . mkName
<$> ( string "'#{{"
*> takeWhile1P Nothing (/= '}')
<* string "}}'"
),
do
Var False . appE [|pure|] . varE . mkName
<$> ( string "#{"
*> takeWhile1P Nothing (/= '}')
<* string "}"
),
do
Var True . appE [|pure|] . varE . mkName
<$> ( string "'#{"
*> takeWhile1P Nothing (/= '}')
<* string "}'"
),
do
Lit <$> takeWhile1P Nothing (\c -> all (c /=) ['\'', '#', '\\']),
do
Lit . (: []) <$> satisfy ((||) <$> (== '\'') <*> (== '#')),
do
Lit . (: []) <$> satisfy (== '\\') <* lookAhead (satisfy (const True))
]
)
<*> (isNothing <$> optional (string "\\"))
makeExp' :: ([Expr (Q Exp)], Bool) -> Q Exp
makeExp' (exprs, False) = [|sh_ (Script id <$> $(makeExp exprs))|]
makeExp' (exprs, True) = [|sh_ (Script stripTrailingNLs <$> $(makeExp exprs))|]
makeExp :: [Expr (Q Exp)] -> Q Exp
makeExp exprs = do
exprs' :: [(Expr Name)] <-
sequence
[ case expr of
Lit s -> pure (Lit s)
Var q _ -> Var q <$> newName "arg"
| expr <- exprs
]
doE $
[ BindS <$> (varP nam) <*> [|toString <$> $exp|]
| (Var _ exp, Var _ nam) <- zip exprs exprs'
]
++ [ NoBindS <$> [|pure $(foldr (\a b -> [|$a ++ $b|]) [|""|] (map toExp exprs'))|]
]
toExp :: Expr Name -> Q Exp
toExp (Lit s) = [|s|]
toExp (Var True nam) = [|squote $(varE nam)|]
toExp (Var False nam) = [|dquote $(varE nam)|]
stripTrailingNLs :: LB.ByteString -> LB.ByteString
stripTrailingNLs s = maybe s (stripTrailingNLs) (LB.stripSuffix (LB.pack "\n") s)
|
