diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +# 0.4.0.0 + +- Add: `matchAll` function to make the given parser to collect all matching substrings. + # 0.3.0.0 - Add: `takeMatch` function to make the given parser match partially, by returning the prefixed string with parsed value diff --git a/src/Text/Parser/Substring.hs b/src/Text/Parser/Substring.hs --- a/src/Text/Parser/Substring.hs +++ b/src/Text/Parser/Substring.hs @@ -1,5 +1,6 @@ module Text.Parser.Substring - ( replaceFileOnceWithParser + ( matchAll + , replaceFileOnceWithParser , replaceOnceWithParser , onceReplacify , takeMatch @@ -7,6 +8,7 @@ import Control.Applicative ((<|>), optional) import Data.Attoparsec.Text +import qualified Data.DList as DList import Data.Maybe (isJust) import Data.Monoid ((<>)) import Data.Text (Text) @@ -31,6 +33,20 @@ $ flip feed "" $ traceId "parsed" $ parse (onceReplacify p) t + + +-- | ref: https://stackoverflow.com/questions/29549435/parsec-how-to-find-matches-within-a-string +{-# INLINE matchAll #-} +matchAll :: Parser a -> Parser [a] +matchAll p = DList.toList <$> loop DList.empty + where + loop xs = do + mMatched <- optional p + case mMatched of + Just matched -> + loop (xs `DList.snoc` matched) + _ -> + (anyChar *> loop xs) <|> pure xs onceReplacify :: Parser Text -> Parser Builder diff --git a/substring-parser.cabal b/substring-parser.cabal --- a/substring-parser.cabal +++ b/substring-parser.cabal @@ -1,16 +1,18 @@ --- This file has been generated from package.yaml by hpack version 0.17.1. +-- This file has been generated from package.yaml by hpack version 0.20.0. -- -- see: https://github.com/sol/hpack +-- +-- hash: 2cb8b595a4b640dae99a8172a9c884e27964461afec3041f5cfbadfdf4d648d4 name: substring-parser -version: 0.3.0.0 +version: 0.4.0.0 synopsis: Match / replace substrings with a parser combinators. description: See README.md category: Text, Parsing homepage: https://gitlab.com/igrep/substring-parser author: Yuji Yamamoto maintainer: whosekiteneverfly@gmail.com -copyright: 2017 Yuji Yamamoto +copyright: 2018 Yuji Yamamoto license: Apache-2.0 license-file: LICENSE build-type: Simple @@ -25,9 +27,10 @@ src default-extensions: OverloadedStrings build-depends: - base >= 4.7 && < 5 - , NoTrace + NoTrace , attoparsec + , base >=4.7 && <5 + , dlist , text exposed-modules: Text.Parser.Substring @@ -42,11 +45,13 @@ test default-extensions: OverloadedStrings build-depends: - base >= 4.7 && < 5 - , NoTrace + NoTrace + , QuickCheck , attoparsec - , text - , substring-parser - , containers + , base >=4.7 && <5 , hspec + , substring-parser + , text + other-modules: + Paths_substring_parser default-language: Haskell2010 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,19 +1,55 @@ import Test.Hspec import Test.Hspec.QuickCheck +import Test.QuickCheck (Gen, Arbitrary, arbitrary, forAll, vectorOf, elements) import Text.Parser.Substring import Control.Applicative ((*>)) -import Data.Attoparsec.Text +import Data.Attoparsec.Text (Result, IResult(Done), parse, feed, many1, digit, string) import Data.Monoid ((<>)) -import qualified Data.Set as Set -import Data.Set ((\\)) +import Data.Text (Text) import qualified Data.Text as Text +import Debug.NoTrace (traceM) +subsetTextOf :: String -> Gen Text +subsetTextOf = fmap Text.pack . vectorOf 2 . elements + + +newtype NonDigits = NonDigits { unNonDigits :: Text } deriving (Eq, Show) + +instance Arbitrary NonDigits where + arbitrary = NonDigits <$> subsetTextOf ['A'..'z'] + +newtype Digits = Digits { unDigits :: Text } deriving (Eq, Show) + +instance Arbitrary Digits where + arbitrary = Digits <$> subsetTextOf ['0'..'9'] + + +genSameLength :: Gen a -> Gen b -> Gen ([a], [b]) +genSameLength x y = + (,) <$> (vectorOf 2) x <*> vectorOf 2 y + + +-- Ref: https://stackoverflow.com/questions/8470606/haskell-alternating-elements-from-two-lists +alternate :: [Text] -> [Text] -> [Text] +alternate (x:xs) (ys) = x : alternate ys xs +alternate _ ys = [Text.concat ys] + + +shouldBeDoneWith :: (Show a, Eq a) => Result a -> (a, Text) -> Expectation +shouldBeDoneWith actual (expected, expectedLeft) = + case feed actual "" of + Done left result -> do + (result, left) `shouldBe` (expected, expectedLeft) + other -> + fail $ "Not done: " <> show other + + main :: IO () main = hspec $ do - describe "replaceWithParser" $ do + describe "replaceOnceWithParser" $ do it "replace first matching text by parser" $ replaceOnceWithParser (string "abc" *> pure "def") "--abc-abc-" `shouldBe` "--def-abc-" @@ -22,16 +58,29 @@ let src = "--abc-abc-" replaceOnceWithParser mempty src `shouldBe` src + describe "matchAll" $ + prop "extract all parsed data in the string" $ forAll (genSameLength arbitrary arbitrary) $ \(ndss', dss') -> do + let ndss = map unNonDigits ndss' + dss = map unDigits dss' + caseStart = Text.concat $ ndss ++ dss + caseMiddle1 = Text.concat $ alternate ndss dss + caseMiddle2 = Text.concat $ alternate dss ndss + caseEnd = Text.concat $ dss ++ ndss + caseOnly = Text.concat dss + caseNone = Text.concat ndss + myDigit = do { d <- digit; traceM $ "d: " ++ show d ; pure d } + dsString = Text.unpack $ Text.concat dss + + parse (matchAll $ many1 myDigit) caseStart `shouldBeDoneWith` ([dsString], "") + parse (matchAll $ many1 myDigit) caseMiddle1 `shouldBeDoneWith` (map Text.unpack dss, "") + parse (matchAll $ many1 myDigit) caseMiddle2 `shouldBeDoneWith` (map Text.unpack dss, "") + parse (matchAll $ many1 myDigit) caseEnd `shouldBeDoneWith` ([dsString], "") + parse (matchAll $ many1 myDigit) caseOnly `shouldBeDoneWith` ([dsString], "") + parse (matchAll $ many1 myDigit) caseNone `shouldBeDoneWith` ([], "") + + describe "takeMatch" $ prop "take any string before the given parser and parse the data with the parser." $ - \(cs1, i, cs2) -> do - let s1 = Text.pack $ Set.toList $ cs1 \\ Set.fromList ['0'..'9'] - s2 = Text.pack $ Set.toList $ cs2 \\ Set.fromList ['0'..'9'] - ds = show (abs i :: Integer) - input = s1 <> Text.pack ds <> s2 - case feed (parse (takeMatch $ many1 digit) input) "" of - Done left result -> do - result `shouldBe` (s1, ds) - left `shouldBe` s2 - other -> - fail $ "Not done: " <> show other + \(NonDigits s1, Digits ds, NonDigits s2) -> do + let input = s1 <> ds <> s2 + parse (takeMatch $ many1 digit) input `shouldBeDoneWith` ((s1, Text.unpack ds), s2)