From 88e897fa21d0de229700862b11761b8e33752dba Mon Sep 17 00:00:00 2001 From: Alexander Foremny Date: Thu, 7 Mar 2024 06:01:47 +0100 Subject: chore: allow impure interpolation --- src/Process/Shell.hs | 96 ++++++++++++++++++++++++++++++++-------------------- 1 file changed, 60 insertions(+), 36 deletions(-) (limited to 'src/Process/Shell.hs') 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)|] -- cgit v1.2.3