chore: strip trailing newlines by default

Can be disabled by ending the quasi quotation template with a single
backslash.

2 files changed, 79 insertions, 67 deletions

diff --git a/src/Process/Shell.hs b/src/Process/Shell.hs
index 24bea95..41a15af 100644
--- a/src/Process/Shell.hs
+++ b/src/Process/Shell.hs
@@ -18,8 +18,8 @@ import Control.Exception (Exception, throw)
 import Control.Monad
 import Control.Monad.Reader
 import Data.Aeson
-import Data.ByteString qualified as B
-import Data.ByteString.Lazy qualified as LB
+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
@@ -38,20 +38,22 @@ 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 String -> m r
+  sh_ :: m Script -> m r
 
 instance (MonadIO m) => Processable m () where
-  sh_ = (liftIO . runProcess_ . fromString =<<)
+  sh_ = ((\(Script _ s) -> liftIO (runProcess_ (fromString s))) =<<)
 
 instance (MonadIO m, Outputable a) => Processable m a where
-  sh_ = (fmap fromLBS . liftIO . readProcessInterleaved_ . fromString =<<)
+  sh_ = ((\(Script strip s) -> fmap (fromLBS . strip) (liftIO (readProcessInterleaved_ (fromString s)))) =<<)
 
 instance (MonadIO m, Outputable stdout, Outputable stderr) => Processable m (stdout, stderr) where
-  sh_ = (fmap (\(out, err) -> (fromLBS out, fromLBS err)) . liftIO . readProcess_ . fromString =<<)
+  sh_ = ((\(Script stripNL s) -> fmap (\(out, err) -> (fromLBS (stripNL out), fromLBS (stripNL err))) (liftIO (readProcess_ (fromString s)))) =<<)
 
 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 =<<)
+  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
@@ -125,41 +127,50 @@ sh = QuasiQuoter quoteExp undefined undefined undefined
   where
     quoteExp :: String -> Q Exp
     quoteExp =
-      either (fail . errorBundlePretty) makeExp
+      either (fail . errorBundlePretty) makeExp'
         . parse (parser <* eof) ""
 
-    parser :: ParsecT Void String Identity [Expr (Q Exp)]
+    parser :: ParsecT Void String Identity ([Expr (Q Exp)], Bool)
     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 ((||) <$> (== '\'') <*> (== '#'))
-        ]
+      (,)
+        <$> ( many . choice . map try $
+                [ 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 (\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
@@ -170,18 +181,17 @@ sh = QuasiQuoter quoteExp undefined undefined undefined
               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'))|]
-                    ]
-           )
-        |]
+      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)
diff --git a/test/Main.hs b/test/Main.hs
index e00ccf6..96612dc 100644
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -16,38 +16,40 @@ main :: IO ()
 main = hspec do
   describe "output" do
     it "capture stdout" do
-      (`shouldBe` "stdout") . fst @String @String =<< [sh|echo -n stdout|]
+      (`shouldBe` "stdout") . fst @String @String =<< [sh|echo stdout|]
     it "capture stderr" do
-      (`shouldBe` "stderr") . snd @String =<< [sh|>&2 echo -n stderr|]
-    it "capture stdout and stderr interleaved" do
+      (`shouldBe` "stderr") . snd @String =<< [sh|>&2 echo stderr|]
+    it "capture stdout and stderr" do
       (`shouldBe` ("stdout", "stderr"))
         =<< [sh|
-        echo -n stdout
-        >&2 echo -n stderr
+        echo stdout
+        >&2 echo stderr
         |]
-    it "capture interleaved" do
-      (`shouldBe` "stdout\nstderr\n")
+    it "capture stdout and stderr interleaved" do
+      (`shouldBe` "stdout\nstderr")
         =<< [sh|
         echo stdout
         >&2 echo stderr
         |]
+    it "preserve trailing newline" do
+      (`shouldBe` "stdout\n") . fst @String @String =<< [sh|echo stdout \|]
   describe "arguments" do
     it "passes `Int`" do
-      (`shouldBe` "1") =<< let x = 1 :: Int in [sh|echo -n '#{x}'|]
+      (`shouldBe` "1") =<< let x = 1 :: Int in [sh|echo '#{x}'|]
     it "passes `Text`" do
-      (`shouldBe` "foobar") =<< let x = T.pack "foobar" in [sh|echo -n '#{x}'|]
-      (`shouldBe` "foobar") =<< let x = LT.pack "foobar" in [sh|echo -n '#{x}'|]
+      (`shouldBe` "foobar") =<< let x = T.pack "foobar" in [sh|echo '#{x}'|]
+      (`shouldBe` "foobar") =<< let x = LT.pack "foobar" in [sh|echo '#{x}'|]
     it "passes `ByteString`" do
-      (`shouldBe` "foobar") =<< let x = B.pack "foobar" in [sh|echo -n '#{x}'|]
-      (`shouldBe` "foobar") =<< let x = LB.pack "foobar" in [sh|echo -n '#{x}'|]
+      (`shouldBe` "foobar") =<< let x = B.pack "foobar" in [sh|echo '#{x}'|]
+      (`shouldBe` "foobar") =<< let x = LB.pack "foobar" in [sh|echo '#{x}'|]
     it "interpolates expressions" do
-      (`shouldBe` "1") =<< let x = 1 :: Int in [sh|echo -n '#{show x}'|]
+      (`shouldBe` "1") =<< let x = 1 :: Int in [sh|echo '#{show x}'|]
     it "interpolates monadic expressions" do
-      (`shouldBe` "1") =<< let x = 1 :: Int in [sh|echo -n '#{{pure @IO x}}'|]
+      (`shouldBe` "1") =<< let x = 1 :: Int in [sh|echo '#{{pure @IO x}}'|]
     it "interpolates monadic expressions" do
-      (`shouldBe` "1") =<< runReaderT [sh|echo -n '#{{asks fst}}'|] (1 :: Int, 2 :: Int)
+      (`shouldBe` "1") =<< runReaderT [sh|echo '#{{asks fst}}'|] (1 :: Int, 2 :: Int)
     it "preserves argument order" do
-      (`shouldBe` "1 2") =<< let x = "1"; y = "2" in [sh|echo -n '#{x}' '#{y}'|]
+      (`shouldBe` "1 2") =<< let x = "1"; y = "2" in [sh|echo '#{x}' '#{y}'|]
   describe "quoting" do
     it "preserves arguments" do
       (`shouldBe` "foo\\ bar")
@@ -63,6 +65,6 @@ main = hspec do
       (`shouldBe` "''") =<< let x = "" in [sh|printf %q '#{x}'|]
   describe "parsing" do
     it "parses shell quotes" do
-      (`shouldBe` "foobar") =<< [sh|echo -n 'foobar'|]
+      (`shouldBe` "foobar") =<< [sh|echo 'foobar'|]
     it "parses double cross" do
-      (`shouldBe` "0") =<< [sh|echo -n $#|]
+      (`shouldBe` "0") =<< [sh|echo $#|]