diff options
Diffstat (limited to 'src/Process')
| -rw-r--r-- | src/Process/Shell.hs | 113 |
1 files changed, 57 insertions, 56 deletions
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)|] |