diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,10 +1,11 @@ -## [*Unreleased*](https://github.com/pbrisbin/hs-shellwords/compare/v0.1.2.2...master) +## [*Unreleased*](https://github.com/pbrisbin/hs-shellwords/compare/v0.1.3.0...main) None -## [v0.1.2.2](https://github.com/pbrisbin/hs-shellwords/compare/v0.1.2.1...v0.1.2.2) +## [v0.1.3.0](https://github.com/pbrisbin/hs-shellwords/compare/v0.1.2.1...v0.1.3.0) -- Require megaparsec-7.0.0 (LTS-13.6/GHC-8.6) +- Define reserved characters, to enable delimited parsing `$(=4.7 && <5 - , megaparsec >=7.0.0 - , text - exposed-modules: - ShellWords - other-modules: - Paths_shellwords - default-language: Haskell2010 + exposed-modules: + ShellWords + Text.Megaparsec.Compat + hs-source-dirs: src + other-modules: Paths_shellwords + default-language: Haskell2010 + default-extensions: NoImplicitPrelude + ghc-options: + -Weverything -Wno-missing-exported-signatures + -Wno-missing-import-lists -Wno-missing-local-signatures + -Wno-monomorphism-restriction -Wno-unsafe -Wno-safe + + build-depends: + base >=4.7 && <5, + megaparsec >=6.5.0, + text >=1.2.3.1 + + if impl(ghc >=9.2) + ghc-options: -Wno-missing-kind-signatures + + if impl(ghc >=8.10) + ghc-options: + -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module + test-suite hspec - type: exitcode-stdio-1.0 - main-is: Spec.hs - hs-source-dirs: - test - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N - build-depends: - base >=4.7 && <5 - , hspec - , shellwords - other-modules: - ShellWordsSpec - Paths_shellwords - default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + other-modules: + ShellWordsSpec + Paths_shellwords + + default-language: Haskell2010 + default-extensions: NoImplicitPrelude + ghc-options: + -Weverything -Wno-missing-exported-signatures + -Wno-missing-import-lists -Wno-missing-local-signatures + -Wno-monomorphism-restriction -Wno-unsafe -Wno-safe -threaded + -rtsopts -with-rtsopts=-N + + build-depends: + base >=4.7 && <5, + hspec >=2.5.5, + megaparsec >=6.5.0, + shellwords -any + + if impl(ghc >=9.2) + ghc-options: -Wno-missing-kind-signatures + + if impl(ghc >=8.10) + ghc-options: + -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module diff --git a/src/ShellWords.hs b/src/ShellWords.hs --- a/src/ShellWords.hs +++ b/src/ShellWords.hs @@ -3,34 +3,48 @@ module ShellWords ( parse , parseText + + -- * Low-level parser + , Parser + , runParser + , parser ) where +import Prelude + import Data.Bifunctor (first) import Data.Char +import Data.List (dropWhileEnd) import Data.Maybe (fromMaybe) -import Data.Semigroup ((<>)) -import Data.Text (Text) -import qualified Data.Text as T +import Data.Text (Text, pack, unpack) import Data.Void (Void) -import Text.Megaparsec hiding (parse) import qualified Text.Megaparsec as Megaparsec import Text.Megaparsec.Char +import Text.Megaparsec.Compat hiding (parse, runParser) type Parser = Parsec Void String parse :: String -> Either String [String] -parse = first errorBundlePretty . Megaparsec.parse parser "" . strip - where strip = let f = reverse . dropWhile isSpace in f . f +parse = runParser parser +runParser :: Parser a -> String -> Either String a +runParser p = first errorBundlePretty . Megaparsec.parse p "" + -- | Parse and return @'Text'@ values parseText :: Text -> Either String [Text] -parseText = fmap (map T.pack) . parse . T.unpack +parseText = fmap (map pack) . parse . unpack parser :: Parser [String] -parser = shellword `sepBy` space1 +parser = fmap (dropWhileEnd null) $ space *> shellword `sepEndBy1` space1 shellword :: Parser String -shellword = choice [quoted, shelloption, value] +shellword = + choice + [ quoted "quoted string" + , shelloption "shell option" + , value "bare value" + ] + "shell word" -- | A balanced, single- or double-quoted string quoted :: Parser String @@ -49,7 +63,7 @@ flag = (<>) <$> (string "--" <|> string "-") - <*> (quoted <|> many (nonSpaceOr '=')) + <*> (quoted <|> value) -- | The argument to a flag like @=foo@, or @=\"baz bat\"@ argument :: Parser String @@ -57,21 +71,32 @@ -- | A plain value, here till an (unescaped) space value :: Parser String -value = many nonSpace +value = many nonSpaceNonReserved escaped :: Char -> Parser Char -escaped c = c <$ string ("\\" <> [c]) +escaped c = c <$ (escapedSatisfy (== c) "escaped" <> show c) +escapedSpace :: Parser Char +escapedSpace = escapedSatisfy isSpace "escaped white space" + +escapedAnyOf :: [Char] -> Parser Char +escapedAnyOf cs = escapedSatisfy (`elem` cs) "escaped one of " <> cs + +escapedSatisfy :: (Char -> Bool) -> Parser Char +escapedSatisfy p = try $ string "\\" *> satisfy p + anyToken :: Parser Char anyToken = satisfy $ const True -nonSpace :: Parser Char -nonSpace = escaped ' ' <|> satisfy (not . isSpace) +nonSpaceNonReserved :: Parser Char +nonSpaceNonReserved = + escapedSpace + <|> escapedAnyOf reserved + <|> satisfy (\c -> not $ isSpace c || isReserved c) + "non white space / non reserved character" -nonSpaceOr :: Char -> Parser Char -nonSpaceOr c = escaped ' ' <|> escaped c <|> satisfy (not . isSpaceOrChar) - where - isSpaceOrChar c' - | isSpace c' = True - | c' == c = True - | otherwise = False +isReserved :: Char -> Bool +isReserved = (`elem` reserved) + +reserved :: [Char] +reserved = "();=" diff --git a/src/Text/Megaparsec/Compat.hs b/src/Text/Megaparsec/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Text/Megaparsec/Compat.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE CPP #-} + +module Text.Megaparsec.Compat + ( module X +#if !MIN_VERSION_megaparsec(7,0,0) + , errorBundlePretty +#endif + ) where + +import Text.Megaparsec as X + +#if !MIN_VERSION_megaparsec(7,0,0) +import Prelude + +errorBundlePretty :: Show a => a -> String +errorBundlePretty = show +#endif diff --git a/test/ShellWordsSpec.hs b/test/ShellWordsSpec.hs --- a/test/ShellWordsSpec.hs +++ b/test/ShellWordsSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -- | @@ -10,10 +11,13 @@ ( spec ) where +import Prelude + import Data.Foldable (for_) -import Data.Semigroup ((<>)) import ShellWords import Test.Hspec +import Text.Megaparsec.Char (string) +import Text.Megaparsec.Compat (between) testCases :: [(String, [String])] testCases = @@ -72,27 +76,58 @@ ] spec :: Spec -spec = describe "parse" $ do +spec = describe "parser" $ do for_ testCases $ \(input, expected) -> do it ("parses |" <> input <> "| correctly") $ do - parse input `shouldBe` Right expected + runParser parser input `shouldBeParsed` expected for_ errorCases $ \input -> do it ("errors on |" <> input <> "|") $ do - parse input `shouldSatisfy` isLeft + expectParseError $ runParser parser input it "fixes #3" $ do - let input = "-LC:/Users/Vitor\\ Coimbra/AppData/Local/Programs/stack/x86_64-windows/msys2-20150512/mingw64/lib -ltag\n" + let input + = "-LC:/Users/Vitor\\ Coimbra/AppData/Local/Programs/stack/x86_64-windows/msys2-20150512/mingw64/lib -ltag\n" expected = [ "-LC:/Users/Vitor Coimbra/AppData/Local/Programs/stack/x86_64-windows/msys2-20150512/mingw64/lib" , "-ltag" ] - parse input `shouldBe` Right expected + runParser parser input `shouldBeParsed` expected -isLeft :: Either a b -> Bool -isLeft (Left _) = True -isLeft _ = False + context "delimited" $ do + let + parseDelimited input = + runParser (between (string "FOO=$(") (string ")") parser) + $ "FOO=$(" + <> input + <> ")" + + it "parses within delimiters" $ do + parseDelimited "echo \"hi\"" `shouldBeParsed` ["echo", "hi"] + + it "handles quoted delimiter" $ do + parseDelimited "echo \"hi (quietly)\")" + `shouldBeParsed` ["echo", "hi (quietly)"] + + it "works with white space" $ do + parseDelimited " echo \n\"hi\" " `shouldBeParsed` ["echo", "hi"] + + it "works with newlines" $ do + parseDelimited "echo \n\"hi\"" `shouldBeParsed` ["echo", "hi"] + + it "works with final newline" $ do + parseDelimited "echo \n\"hi\"\n" `shouldBeParsed` ["echo", "hi"] + +expectParseError :: Show a => Either String a -> Expectation +expectParseError = \case + Left{} -> pure () + Right a' -> expectationFailure $ "Expected parse error, got:" <> show a' + +shouldBeParsed :: (Show a, Eq a) => Either String a -> a -> Expectation +a `shouldBeParsed` b = case a of + Left e -> expectationFailure e + Right a' -> a' `shouldBe` b {- Features I'm not sure I'll be porting, certainly not yet. diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,1 +1,1 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +{-# OPTIONS_GHC -F -pgmF hspec-discover -Wno-missing-export-lists #-}