diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Process/Shell.hs | 108 |
1 files changed, 59 insertions, 49 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) |