From b0f442b78a6b2c7d8978ae958bcadcc23ff82199 Mon Sep 17 00:00:00 2001
From: Alexander Foremny <aforemny@posteo.de>
Date: Fri, 8 Mar 2024 05:00:53 +0100
Subject: chore: use `${{..}}` for impure interpolation
---
sh.cabal | 1 +
src/Process/Shell.hs | 113 ++++++++++++++++++++++++++-------------------------
test/Main.hs | 6 ++-
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
--
cgit v1.2.3