chore: allow impure interpolation

2 files changed, 64 insertions, 36 deletions

diff --git a/src/Process/Shell.hs b/src/Process/Shell.hs
index 10b85b5..6df6a4f 100644
--- a/src/Process/Shell.hs
+++ b/src/Process/Shell.hs
@@ -74,48 +74,49 @@ instance Outputable T.Text where
 instance Outputable LT.Text where
   fromLBS = LT.decodeUtf8
 
-class Quotable a where
-  squote :: a -> String
-  squote = squote . toString
+class Quotable m a where
+  toStringM :: (Monad m) => a -> m String
+  default toStringM :: (Show a, Monad m) => a -> m String
+  toStringM = pure . show
 
-  dquote :: a -> String
-  dquote = dquote . toString
+instance Quotable m String where
+  toStringM = pure
 
-  toString :: a -> String
-  default toString :: (Show a) => a -> String
-  toString = show
+instance (Monad m, Quotable m a) => Quotable m (m a) where
+  toStringM mkA = toStringM =<< mkA
 
-instance Quotable String where
-  squote s = "'" <> quote' s <> "'"
-    where
-      quote' [] = []
-      quote' ('\'' : cs) = '\'' : '\\' : '\'' : '\'' : quote' cs
-      quote' (c : cs) = c : quote' cs
+instance Quotable m Int
 
-  dquote s = "\"" <> quote' s <> "\""
-    where
-      quote' [] = []
-      quote' ('\\' : c : cs) = c : quote' cs
-      quote' ('"' : cs) = '\\' : '"' : quote' cs
-      quote' (c : cs) = c : quote' cs
+instance Quotable m B.ByteString where
+  toStringM = pure . B.toString
 
-instance Quotable Int
+instance Quotable m LB.ByteString where
+  toStringM = pure . LB.toString
 
-instance Quotable B.ByteString where
-  toString = B.toString
+instance Quotable m T.Text where
+  toStringM = pure . T.unpack
 
-instance Quotable LB.ByteString where
-  toString = LB.toString
+instance Quotable m LT.Text where
+  toStringM = pure . LT.unpack
 
-instance Quotable T.Text where
-  toString = T.unpack
+squote :: String -> String
+squote s = "'" <> quote' s <> "'"
+  where
+    quote' [] = []
+    quote' ('\'' : cs) = '\'' : '\\' : '\'' : '\'' : quote' cs
+    quote' (c : cs) = c : quote' cs
 
-instance Quotable LT.Text where
-  toString = LT.unpack
+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
+data Expr a
   = Lit String
-  | Var Bool (Q Exp)
+  | Var Bool a
 
 sh :: QuasiQuoter
 sh = QuasiQuoter quoteExp undefined undefined undefined
@@ -125,7 +126,7 @@ sh = QuasiQuoter quoteExp undefined undefined undefined
       either (fail . errorBundlePretty) makeExp
         . parse (parser <* eof) ""
 
-    parser :: ParsecT Void String Identity [Expr]
+    parser :: ParsecT Void String Identity [Expr (Q Exp)]
     parser =
       many . choice $
         [ do
@@ -144,8 +145,31 @@ sh = QuasiQuoter quoteExp undefined undefined undefined
             Lit <$> takeWhile1P Nothing ((&&) <$> (/= '#') <*> (/= '\''))
         ]
 
-    makeExp exprs =
-      [|sh_ $(foldr (\a b -> [|$a ++ $b|]) [|""|] (map toExp exprs))|]
-
+    makeExp exprs = do
+      exprs' <-
+        sequence
+          [ case expr of
+              Lit s -> pure (Lit s)
+              Var q _ -> Var q <$> newName "arg"
+            | expr <- exprs
+          ]
+      doE $
+        [ BindS <$> (varP nam) <*> [|toStringM $exp|]
+          | (Var _ exp, Var _ nam) <- zip exprs exprs'
+        ]
+          ++ [ fmap
+                 NoBindS
+                 [|
+                   sh_
+                     $( foldr
+                          (\a b -> [|$a ++ $b|])
+                          [|""|]
+                          (map toExp exprs')
+                      )
+                   |]
+             ]
+
+    toExp :: Expr Name -> Q Exp
     toExp (Lit s) = [|s|]
-    toExp (Var q exp) = [|(if q then squote else dquote) $exp|]
+    toExp (Var q nam) =
+      [|(if q then squote else dquote) $(varE nam)|]
diff --git a/test/Main.hs b/test/Main.hs
index 9bde55e..0d00db3 100644
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -40,6 +40,10 @@ main = hspec do
       (`shouldBe` "foobar") =<< let x = LB.pack "foobar" in [sh|echo -n '#{x}'|]
     it "interpolates expressions" do
       (`shouldBe` "1") =<< let x = 1 :: Int in [sh|echo -n '#{show x}'|]
+    it "interpolates monadic expressions" do
+      (`shouldBe` "1") =<< let x = 1 :: Int in [sh|echo -n '#{pure @IO x}'|]
+    it "preserves argument order" do
+      (`shouldBe` "1 2") =<< let x = "1"; y = "2"; in [sh|echo -n '#{x}' '#{y}'|]
   describe "quoting" do
     it "preserves arguments" do
       (`shouldBe` "foo\\ bar")