chore: use `${{..}}` for impure interpolation

3 files changed, 63 insertions, 57 deletions

diff --git a/sh.cabal b/sh.cabal
index 316619c..d5fce58 100644
--- a/sh.cabal
+++ b/sh.cabal
@@ -34,5 +34,6 @@ test-suite sh-test
         base,
         bytestring,
         hspec,
+        mtl,
         sh,
         text
diff --git a/src/Process/Shell.hs b/src/Process/Shell.hs
index 06c9dbe..87d22df 100644
--- a/src/Process/Shell.hs
+++ b/src/Process/Shell.hs
@@ -1,8 +1,10 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE OverlappingInstances #-}
+{-# LANGUAGE IncoherentInstances #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module Process.Shell
   ( sh,
@@ -11,7 +13,7 @@ module Process.Shell
 where
 
 import Control.Monad
-import Control.Monad.Trans
+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
@@ -25,33 +27,27 @@ 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
+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 r where
-  sh_ :: String -> r
+class Processable m r where
+  sh_ :: m String -> m r
 
-instance (MonadIO m) => Processable (m ()) where
-  sh_ s = do
-    liftIO (runProcess_ (fromString s))
+instance (MonadIO m) => Processable m () where
+  sh_ = (liftIO . runProcess_ . fromString =<<)
 
-instance (MonadIO m, Outputable a) => Processable (m a) where
-  sh_ s = do
-    fromLBS <$> liftIO (readProcessInterleaved_ (fromString s))
+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_ s = do
-    (\(out, err) -> (fromLBS out, fromLBS err))
-      <$> liftIO (readProcess_ (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 =<<)
 
-instance (MonadIO m, Outputable stdout, Outputable stderr) => Processable (m (ExitCode, stdout, stderr)) where
-  sh_ s = do
-    (\(exitCode, out, err) -> (exitCode, fromLBS out, fromLBS 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 =<<)
 
 class Outputable a where
   fromLBS :: LB.ByteString -> a
@@ -71,30 +67,27 @@ instance Outputable T.Text where
 instance Outputable LT.Text where
   fromLBS = LT.decodeUtf8
 
-class Quotable m a where
-  toStringM :: (Monad m) => a -> m String
-  default toStringM :: (Show a, Monad m) => a -> m String
-  toStringM = pure . show
+class Quotable a where
+  toString :: a -> String
+  default toString :: (Show a) => a -> String
+  toString = show
 
-instance Quotable m String where
-  toStringM = pure
+instance Quotable String where
+  toString = id
 
-instance (Monad m, Quotable m a) => Quotable m (m a) where
-  toStringM mkA = toStringM =<< mkA
+instance Quotable Int
 
-instance Quotable m Int
+instance Quotable B.ByteString where
+  toString = B.toString
 
-instance Quotable m B.ByteString where
-  toStringM = pure . B.toString
+instance Quotable LB.ByteString where
+  toString = LB.toString
 
-instance Quotable m LB.ByteString where
-  toStringM = pure . LB.toString
+instance Quotable T.Text where
+  toString = T.unpack
 
-instance Quotable m T.Text where
-  toStringM = pure . T.unpack
-
-instance Quotable m LT.Text where
-  toStringM = pure . LT.unpack
+instance Quotable LT.Text where
+  toString = LT.unpack
 
 squote :: String -> String
 squote s = "'" <> quote' s <> "'"
@@ -128,12 +121,24 @@ sh = QuasiQuoter quoteExp undefined undefined undefined
       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 pure . parseExp
+            Var True . either fail (appE [|pure|] . pure) . parseExp
               <$> ( string "'#{"
                       *> takeWhile1P Nothing (/= '}')
                       <* string "}'"
@@ -144,31 +149,27 @@ sh = QuasiQuoter quoteExp undefined undefined undefined
             Lit . (: []) <$> satisfy ((||) <$> (== '\'') <*> (== '#'))
         ]
 
+    makeExp :: [Expr (Q Exp)] -> Q Exp
     makeExp exprs = do
-      exprs' <-
+      exprs' :: [(Expr Name)] <-
         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')
-                      )
-                   |]
-             ]
+      [|
+        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 q nam) =
-      [|(if q then squote else dquote) $(varE nam)|]
+    toExp (Var True nam) = [|squote $(varE nam)|]
+    toExp (Var False nam) = [|dquote $(varE nam)|]
diff --git a/test/Main.hs b/test/Main.hs
index 71723c3..e00ccf6 100644
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -1,8 +1,10 @@
 {-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE QuasiQuotes #-}
 
 module Main (main) where
 
+import Control.Monad.Reader
 import Data.ByteString.Char8 qualified as B
 import Data.ByteString.Lazy.Char8 qualified as LB
 import Data.Text qualified as T
@@ -41,7 +43,9 @@ main = hspec do
     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}'|]
+      (`shouldBe` "1") =<< let x = 1 :: Int in [sh|echo -n '#{{pure @IO x}}'|]
+    it "interpolates monadic expressions" do
+      (`shouldBe` "1") =<< runReaderT [sh|echo -n '#{{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}'|]
   describe "quoting" do