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
|
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Process.Shell
( sh,
Quotable (..),
)
where
import Control.Monad
import Control.Monad.Reader
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.Meta.Parse
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)
class Processable m r where
sh_ :: m String -> m r
instance (MonadIO m) => Processable m () where
sh_ = (liftIO . runProcess_ . fromString =<<)
instance (MonadIO m, Outputable a) => Processable m a where
sh_ = (fmap fromLBS . liftIO . readProcessInterleaved_ . fromString =<<)
instance (MonadIO m, Outputable stdout, Outputable stderr) => Processable m (stdout, stderr) where
sh_ = (fmap (\(out, err) -> (fromLBS out, fromLBS err)) . liftIO . readProcess_ . fromString =<<)
instance (MonadIO m, Outputable stdout, Outputable stderr) => Processable m (ExitCode, stdout, stderr) where
sh_ = (fmap (\(exitCode, out, err) -> (exitCode, fromLBS out, fromLBS err)) . liftIO . readProcess . fromString =<<)
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
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)]
parser =
many . choice $
[ do
Var False . either fail pure . parseExp
<$> ( string "#{{"
*> takeWhile1P Nothing (/= '}')
<* string "}}"
),
do
Var True . either fail pure . parseExp
<$> ( string "'#{{"
*> takeWhile1P Nothing (/= '}')
<* string "}}'"
),
do
Var False . either fail (appE [|pure|] . pure) . parseExp
<$> ( string "#{"
*> takeWhile1P Nothing (/= '}')
<* string "}"
),
do
Var True . either fail (appE [|pure|] . pure) . parseExp
<$> ( string "'#{"
*> takeWhile1P Nothing (/= '}')
<* string "}'"
),
do
Lit <$> takeWhile1P Nothing ((&&) <$> (/= '#') <*> (/= '\'')),
do
Lit . (: []) <$> satisfy ((||) <$> (== '\'') <*> (== '#'))
]
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
]
[|
sh_ $
$( 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)|]
|
