diff options
Diffstat (limited to 'src/Process')
| -rw-r--r-- | src/Process/Shell.hs | 53 |
1 files changed, 26 insertions, 27 deletions
diff --git a/src/Process/Shell.hs b/src/Process/Shell.hs index 63d2f8a..2d254ad 100644 --- a/src/Process/Shell.hs +++ b/src/Process/Shell.hs @@ -24,11 +24,13 @@ import Data.Text.Encoding qualified as T 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.Quote import System.Process.Typed import Text.Megaparsec import Text.Megaparsec.Char +import Prelude hiding (exp) class Processable a r where sh_ :: a -> r @@ -111,18 +113,9 @@ instance Quotable T.Text where instance Quotable LT.Text where toString = LT.unpack -data Expr a +data Expr = Lit String - | Var Bool a - deriving (Show) - -expr :: (String -> b) -> (Bool -> a -> b) -> Expr a -> b -expr f _ (Lit a) = f a -expr _ g (Var q a) = g q a - -unVar :: Expr a -> Maybe a -unVar (Lit _) = Nothing -unVar (Var _ a) = Just a + | Var Bool (Q Exp) sh :: QuasiQuoter sh = QuasiQuoter quoteExp undefined undefined undefined @@ -132,25 +125,31 @@ 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] parser = many . choice $ - [ const (Lit "%") <$> string "%%", - const (Var True ()) <$> string "'%'", - const (Var False ()) <$> satisfy (== '%'), - Lit <$> takeWhile1P Nothing (not . (`elem` "'%")), - Lit <$> string "'%", - Lit <$> string "'" + [ do + Var False . either fail pure . parseExp + <$> ( string "#{" + *> takeWhile1P Nothing (/= '}') + <* string "}" + ), + do + Var True . either fail pure . parseExp + <$> ( string "'#{" + *> takeWhile1P Nothing (/= '}') + <* string "}'" + ), + do + Lit <$> takeWhile1P Nothing ((&&) <$> (/= '#') <*> (/= '\'')) ] - makeExp :: [Expr ()] -> Q Exp - makeExp exprs' = do - exprs <- - mapM - (expr (pure . Lit) (\q _ -> Var q <$> newName "x")) - exprs' - lamE (map varP (mapMaybe unVar exprs)) . appE [|sh_|] $ - flip (foldM (flip go)) exprs =<< [|""|] + makeExp :: [Expr] -> Q Exp + makeExp exprs = do + appE [|sh_|] $ flip (foldM (flip go)) exprs =<< [|""|] go (Lit s) = appE [|flip (++) s|] . pure - go (Var q n) = appE (appE [|flip (++)|] (appE [|if q then squote else dquote|] (varE n))) . pure + go (Var q exp) = + appE + (appE [|flip (++)|] (appE [|if q then squote else dquote|] exp)) + . pure |