From 5cbf1643d52d0b83323687bf9339064afafd20a5 Mon Sep 17 00:00:00 2001 From: Ranjeet Kumar Ranjan Date: Thu, 15 Jun 2023 11:39:49 +0530 Subject: [PATCH 1/3] Add a cmd quasiquoter --- src/Streamly/Internal/System.hs | 134 ++++++++++++++++++++++++++++++++ streamly-process.cabal | 4 + 2 files changed, 138 insertions(+) create mode 100644 src/Streamly/Internal/System.hs diff --git a/src/Streamly/Internal/System.hs b/src/Streamly/Internal/System.hs new file mode 100644 index 0000000..7e58a81 --- /dev/null +++ b/src/Streamly/Internal/System.hs @@ -0,0 +1,134 @@ +-- | +-- Module : Streamly.Internal.System +-- Copyright : (c) 2022 Composewell Technologies +-- License : Apache-2.0 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +{-# LANGUAGE TemplateHaskell #-} + +module Streamly.Internal.System +(cmd) +where + +import Control.Applicative (Alternative(..)) +import Control.Exception (displayException) +import Data.Functor.Identity (runIdentity) +import Streamly.Internal.Data.Parser (Parser) + +import Language.Haskell.TH +import Language.Haskell.TH.Quote + +import qualified Streamly.Data.Fold as Fold +import qualified Streamly.Internal.Data.Parser as Parser + (some, many, takeWhile1) +import qualified Streamly.Data.Stream as Stream (fromList, parse) +import qualified Streamly.Internal.Unicode.Parser as Parser + +data StrSegment + = StrText String + | StrVar String + deriving (Show, Eq) + +formatSpace :: String -> String +formatSpace = foldr go "" + where + go x acc = x:if x == ' ' then dropWhile (' ' ==) acc else acc + +-- | Replace a newline by a space and convert multiple spaces to single space +-- +-- >>> trim " abc \n bbb \n ccc " +-- "abc bbb ccc" +-- +trim :: String -> String +trim = formatSpace <$> (unwords . fmap formatSpace . lines) + +haskellIdentifier :: Monad m => Parser Char m String +haskellIdentifier = + let p = Parser.alphaNum <|> Parser.char '\'' <|> Parser.char '_' + in Parser.some p Fold.toList + +strParser :: Monad m => Parser Char m [StrSegment] +strParser = Parser.many content Fold.toList + + where + + plainText = StrText . trim <$> Parser.takeWhile1 (/= '#') Fold.toList + escHash = StrText . (: []) <$> (Parser.char '#' *> Parser.char '#') + lineCont = StrText [] <$ (Parser.char '#' *> Parser.char '\n') + var = StrVar <$> + ( Parser.char '#' + *> Parser.char '{' + *> haskellIdentifier + <* Parser.char '}' + ) + plainHash = StrText . (: []) <$> Parser.char '#' + + -- order is important + content = plainText <|> escHash <|> lineCont <|> var <|> plainHash + +strSegmentExp :: StrSegment -> Q Exp +strSegmentExp (StrText text) = stringE text +strSegmentExp (StrVar name) = do + valueName <- lookupValueName name + case valueName of + Just vn -> varE vn + Nothing -> + fail + $ "cmd quote: Haskell symbol `" ++ name + ++ "` is not in scope" + +strExp :: [StrSegment] -> Q Exp +strExp xs = appE [| concat |] $ listE $ map strSegmentExp xs + +expandVars :: String -> Q Exp +expandVars ln = + case runIdentity $ Stream.parse strParser (Stream.fromList ln) of + Left e -> + fail $ "cmd QuasiQuoter parse error: " ++ displayException e + Right x -> + strExp x + +-- | A QuasiQuoter that treats the input as a string literal: +-- +-- >>> [cmd|x|] +-- "x" +-- +-- Any @#{symbol}@ is replaced by the value of the Haskell symbol @symbol@ +-- which is in scope: +-- +-- >>> x = "hello" +-- >>> [cmd|#{x} world!|] +-- "hello world!" +-- +-- @##@ means a literal @#@ without the special meaning for referencing +-- haskell symbols: +-- +-- >>> [cmd|##{x} world!|] +-- "#{x} world!" +-- +-- A @#@ at the end of line means the line continues to the next line without +-- introducing a newline character: +-- +-- >>> :{ +-- [cmd|hello# +-- world!|] +-- :} +-- "hello world!" +-- +-- Bugs: because of a bug in parsers, a lone # at the end of input gets +-- removed. +-- +cmd :: QuasiQuoter +cmd = + QuasiQuoter + { quoteExp = expandVars + , quotePat = notSupported + , quoteType = notSupported + , quoteDec = notSupported + } + + where + + notSupported = error "cmd: Not supported." diff --git a/streamly-process.cabal b/streamly-process.cabal index 29c4548..c7c0732 100644 --- a/streamly-process.cabal +++ b/streamly-process.cabal @@ -83,8 +83,10 @@ library import: compile-options, optimization-options hs-source-dirs: src exposed-modules: + Streamly.System.Process Streamly.System.Command + Streamly.Internal.System Streamly.Internal.System.Process Streamly.Internal.System.Command if flag (use-native) && !os(windows) @@ -96,6 +98,8 @@ library -- Uses internal APIs , streamly == 0.9.0.* , streamly-core == 0.1.0 + , template-haskell >= 2.14 && < 2.21 + if !flag(use-native) build-depends: process >= 1.0 && < 1.7 else From d62f076e99de1a6e07f00287653ff0ab9131ec19 Mon Sep 17 00:00:00 2001 From: Ranjeet Kumar Ranjan Date: Thu, 15 Jun 2023 12:08:20 +0530 Subject: [PATCH 2/3] Fix up --- src/Streamly/Internal/System.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Streamly/Internal/System.hs b/src/Streamly/Internal/System.hs index 7e58a81..f85e96c 100644 --- a/src/Streamly/Internal/System.hs +++ b/src/Streamly/Internal/System.hs @@ -38,8 +38,10 @@ formatSpace = foldr go "" -- | Replace a newline by a space and convert multiple spaces to single space -- +-- >>> :set -XQuasiQuotes +-- >>> import Streamly.Internal.System -- >>> trim " abc \n bbb \n ccc " --- "abc bbb ccc" +-- " abc bbb ccc " -- trim :: String -> String trim = formatSpace <$> (unwords . fmap formatSpace . lines) From 15a810eb0749809d3ca9bfda2e604cad0193185b Mon Sep 17 00:00:00 2001 From: Ranjeet Kumar Ranjan Date: Thu, 15 Jun 2023 13:22:36 +0530 Subject: [PATCH 3/3] Fix up --- src/Streamly/Internal/System.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Streamly/Internal/System.hs b/src/Streamly/Internal/System.hs index f85e96c..6dd9080 100644 --- a/src/Streamly/Internal/System.hs +++ b/src/Streamly/Internal/System.hs @@ -9,7 +9,9 @@ {-# LANGUAGE TemplateHaskell #-} module Streamly.Internal.System -(cmd) +( cmd +, trim +) where import Control.Applicative (Alternative(..))