diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright hiratara (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither hiratara nor Masahiro Honma + may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Text/StringRandom.hs b/src/Text/StringRandom.hs new file mode 100644 --- /dev/null +++ b/src/Text/StringRandom.hs @@ -0,0 +1,130 @@ +{-| +Module : Text.StringRandom +Description : generating random string from a regexp +Copyright : Copyright (C) 2016- hiratara +License : GPL-3 +Maintainer : hiratara@cpan.org +Stability : experimental + +Generate a random character string that matches the given regular expression. +This library ported String_random.js to Haskell. + +@ + {-# LANGUAGE OverloadedStrings #-} + import Text.StringRandom + + main = do + ymd <- stringRandomIO "20\\d\\d-(1[0-2]|0[1-9])-(0[1-9]|1\\d|2[0-8])" + print ymd -- "2048-12-08" etc. +@ + +See + +As with this package, there are +in packages that generate random strings, but this module is superior in the +following respects. + + * The format of the string to be generated using regular expressions + * You can change the random number generator (e.g. tf-random package) + * With pure calculation without using IO monad. +-} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Strict #-} +module Text.StringRandom + ( stringRandomIO + , stringRandom + , stringRandomWithError + ) where + +import qualified Data.IntMap.Strict as Map +import qualified Data.Text as Text +import qualified System.Random as Random +import qualified Text.StringRandom.Parser as Parser +import qualified Control.Monad.Trans.RWS.Strict as RWS + +-- Int: size, g: generater, IntMap: Record backrefs +type GenRWS g = RWS.RWS Int () (g, Map.IntMap Text.Text) + +{-| +The 'stringRandomIO' function generates random strings that match the given +regular expression. Regular expression is specified by 'Text' type. This +function internally uses the random number generator generated by 'newStdGen'. +-} +stringRandomIO :: Text.Text -> IO Text.Text +stringRandomIO txt = do + g <- Random.newStdGen + return $ stringRandom g txt + +{-| +The 'stringRandom' function uses a specified random number generator to +generate a random string that matches a given regular expression. +An exception is raised if the regular expression can not be parsed. +-} +stringRandom :: Random.RandomGen g => g -> Text.Text -> Text.Text +stringRandom g txt = case stringRandomWithError g txt of + Left l -> error l + Right r -> r + +{-| +The 'stringRandomWithError' function behaves like the 'stringRandom' +function, but notifies the error through the Either monad. +-} +stringRandomWithError :: Random.RandomGen g => g -> Text.Text -> Either String Text.Text +stringRandomWithError g txt = do + parsed <- Parser.processParse txt + -- 10 : max length of a* or a+ + let (ret, _) = RWS.evalRWS (str parsed) 10 (g, Map.empty) + return ret + +withGen :: Random.RandomGen g => (g -> (a, g)) -> GenRWS g a +withGen f = do + (gen, m) <- RWS.get + let (a, gen') = f gen + RWS.put (gen', m) + return a + +randomRM :: (Random.RandomGen g, Random.Random a) => (a, a) -> GenRWS g a +randomRM = withGen . Random.randomR + +-- randomM :: (Random.RandomGen g, Random.Random a) => GenRWS g a +-- randomM = withGen Random.random + +choice :: Random.RandomGen g => [a] -> GenRWS g a +choice xs = do + i <- randomRM (0, length xs - 1) + return $ xs !! i + +putGroup :: Int -> Text.Text -> GenRWS g () +putGroup n v = do + (gen, m) <- RWS.get + let m' = Map.insert n v m + RWS.put (gen, m') + +getGroup :: Int -> GenRWS g Text.Text +getGroup n = do + m <- RWS.gets snd + let maybeV = Map.lookup n m + case maybeV of + Nothing -> return "" + Just v -> return v + +size :: GenRWS g Int +size = RWS.ask + +str :: Random.RandomGen g => Parser.Parsed -> GenRWS g Text.Text +str (Parser.PClass cs) = Text.singleton <$> choice cs +str (Parser.PRange s me p) = do + e <- case me of + Just e' -> return e' + Nothing -> size + n <- randomRM (s, e) + Text.concat <$> mapM (const $ str p) [1 .. n] +str (Parser.PConcat ps) = Text.concat <$> mapM str ps +str (Parser.PSelect ps) = str =<< choice ps +str (Parser.PGrouped n p) = do + v <- str p + putGroup n v + return v +str (Parser.PBackward n) = getGroup n +str (Parser.PIgnored) = return "" diff --git a/src/Text/StringRandom/Parser.hs b/src/Text/StringRandom/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Text/StringRandom/Parser.hs @@ -0,0 +1,161 @@ +{-| +Module : Text.StringRandom.Parser +Description : Simple regular expression parser +Copyright : Copyright (C) 2016- hiratara +License : GPL-3 +Maintainer : hiratara@cpan.org +Stability : experimental + +Parse the regular expression so that it can be used with the +"Text.StringRandom" module. + +See +-} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Strict #-} +module Text.StringRandom.Parser + ( Parsed(..) + , processParse + ) where + +import qualified Data.Attoparsec.Text as Attoparsec +import Data.Attoparsec.Text + ( char + , anyChar + , satisfy + , string + , digit + , many1 + , endOfInput + ) +import Data.List ((\\)) +import qualified Data.Text as Text +import Control.Applicative ((<|>), optional, many) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.State.Strict (evalStateT, StateT, gets, put) + +-- Int :: A sequence number of groups (X) +type RegParser a = StateT Int Attoparsec.Parser a + +-- | Abstract syntax tree of parsed regular expression +data Parsed = PClass [Char] -- ^ [abc], \d, [^abc] + | PRange Int (Maybe Int) Parsed -- ^ X*, X{1,2}, X+, X? + | PConcat [Parsed] -- ^ XYZ + | PSelect [Parsed] -- ^ X|Y|Z + | PGrouped Int Parsed -- ^ (X) + | PBackward Int -- ^ \1, \2, ..., \9 + | PIgnored -- ^ ^, $, \b + deriving (Show, Eq) + +pConcat :: [Parsed] -> Parsed +pConcat [x] = x +pConcat xs = PConcat xs + +pSelect :: [Parsed] -> Parsed +pSelect [x] = x +pSelect xs = PSelect xs + +{-| +'processParse' parses the regular expression string and returns an abstract +syntax tree. If there is an error in the regular expression, it returns the +'Left' value. +-} +processParse :: Text.Text -> Either String Parsed +processParse = let p = evalStateT selectParser 0 + in Attoparsec.parseOnly (p <* endOfInput) + +selectParser :: RegParser Parsed +selectParser = do + p0 <- concats + ps <- many (lift (char '|') *> concats) + return $ pSelect (p0:ps) + where + concats = pConcat <$> many rangedParser + +rangedParser :: RegParser Parsed +rangedParser = do + p <- groupingParser + let opt = char '?' *> return (PRange 0 (Just 1) p) + star = char '*' *> return (PRange 0 Nothing p) + plus = char '+' *> return (PRange 1 Nothing p) + rep = do + char '{' + min <- read <$> many1 digit + max' <- optional $ char ',' *> many digit + let max = case max' of + Nothing -> Just min + Just [] -> Nothing + Just ds -> Just $ read ds + char '}' + return $ PRange min max p + lift $ opt <|> star <|> plus <|> rep <|> return p + +groupingParser :: RegParser Parsed +groupingParser = ngroup <|> group <|> classParser <|> escaped <|> dot <|> ignored <|> others + where + ngroup = lift (string "(?:") *> selectParser <* lift (char ')') + group = do + n <- gets (+ 1) + put n + p <- lift (char '(') *> selectParser <* lift (char ')') + return $ PGrouped n p + escaped = lift $ do + ch <- char '\\' *> anyChar + return $ case ch of + _ | ch == 'b' -> PIgnored -- Don't support \b + | ch `elem` ['1' .. '9'] -> PBackward (read [ch]) + | otherwise -> PClass (classes ch) + dot = lift $ char '.' *> return (PClass allC) + ignored = lift $ satisfy (`elem` ['^', '$']) *> return PIgnored + others = lift $ PClass . (: []) <$> satisfy (`notElem` reservedChars) + +classParser :: RegParser Parsed +classParser = lift $ + PClass . (allC \\) <$> (string "[^" *> p <* char ']') + <|> PClass <$> (char '[' *> p <* char ']') + where + p :: Attoparsec.Parser [Char] + p = concat <$> many p1 + p1 = do + ch <- onechar + r <- optional (char '-' *> onechar) + return $ case r of + Just rch + | length ch == 1 && length rch == 1 + -> enumFromTo (head ch) (head rch) + -- Handle the case of [^\w-\d] + | otherwise + -> ch ++ '-' : rch + Nothing -> ch + onechar = classes <$> (char '\\' *> anyChar) + <|> (: []) <$> satisfy (`notElem` classReservedChars) + +uppersC, lowersC, digitsC, spacesC, othersC, allC :: [Char] +uppersC = ['A'..'Z'] +lowersC = ['a'..'z'] +digitsC = ['0'..'9'] +spacesC = " \n\t" +othersC = "!\"#$%&'()*+,-./:;<=>?@[\\]^`{|}~" +allC = concat [uppersC, lowersC, digitsC, " ", othersC, "_"] + +classes :: Char -> [Char] +classes 'd' = digitsC +classes 'D' = concat [uppersC, lowersC, spacesC, othersC, "_"] +classes 'w' = concat [uppersC, lowersC, digitsC, "_"] +classes 'W' = concat [spacesC, othersC] +classes 't' = "\t" +classes 'n' = "\n" +classes 'v' = "\x000b" +classes 'f' = "\x000c" +classes 'r' = "\r" +classes 's' = spacesC +classes 'S' = concat [uppersC, lowersC, digitsC, othersC, "_"] +classes '0' = "\0" +classes c = [c] + +reservedChars :: [Char] +reservedChars = "\\()|^$*+{?[." -- ] + +classReservedChars :: [Char] +classReservedChars = "\\]" -- -^ diff --git a/string-random.cabal b/string-random.cabal new file mode 100644 --- /dev/null +++ b/string-random.cabal @@ -0,0 +1,60 @@ +name: string-random +version: 0.1.0.0 +synopsis: A library for generating random string from a regular experession +description: With this package you can generate random strings from + regular expressions. If you are using QuickCheck, you can + also check the quickcheck-string-random package. +homepage: https://github.com/hiratara/hs-string-random#readme +license: BSD3 +license-file: LICENSE +author: Masahiro Honma +maintainer: hiratara@cpan.org +copyright: Copyright (C) 2016- hiratara +category: Text +build-type: Simple +cabal-version: >=1.10 +tested-with: GHC ==8.0.1 + +library + hs-source-dirs: src + exposed-modules: Text.StringRandom + , Text.StringRandom.Parser + build-depends: base >= 4.9 && < 5 + , attoparsec >=0.13.1 && <0.14 + , containers >=0.5.7.1 && <0.6 + , random >=1.1 && <1.2 + , text >=1.2.2.1 && <1.3 + , transformers >=0.5.2.0 && <0.6 + default-language: Haskell2010 + +test-suite string-random-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: string-random-test.hs + build-depends: base + , bytestring + , pcre-heavy + , string-random + , tasty + , tasty-hunit + , text + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +test-suite string-random-quickcheck + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: string-random-quickcheck.hs + build-depends: base + , pcre-heavy + , QuickCheck + , string-random + , tasty + , tasty-quickcheck + , text + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/hiratara/hs-string-random diff --git a/test/string-random-quickcheck.hs b/test/string-random-quickcheck.hs new file mode 100644 --- /dev/null +++ b/test/string-random-quickcheck.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Strict #-} +import Data.Monoid ((<>)) +import qualified Data.Text as Text +import Data.Text.Encoding (encodeUtf8) +import qualified Test.QuickCheck as QC +import qualified Test.QuickCheck.Gen as QC +import qualified Test.QuickCheck.Random as QC +import qualified Text.StringRandom as StringRandom +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.QuickCheck as TastyQC +import Text.Regex.PCRE.Heavy (compileM, (=~)) + +regexp :: QC.Gen Text.Text +regexp = QC.MkGen $ \(QC.QCGen g) _ -> StringRandom.stringRandom g regregexp + where regregexp = "((\\w|" <> classes <> "|\\(\\w+\\))(\\{[0-4],[5-9]\\}|\\*|\\+|))*" + classes = "\\[^?(\\w|" <> escaped <> "|a-z)+-?\\]" + escaped = "\\\\[dDwWsSnr\\[\\]|.(){}^$-]" + +main :: IO () +main = Tasty.defaultMain (TastyQC.testProperty + "by quickcheck" prop_stringRandom) + +prop_stringRandom :: QC.Property +prop_stringRandom = QC.forAll regexp $ \pat -> QC.ioProperty $ do + let pat' = "^" <> fixBS pat <> "$" + (Right reg) = compileM pat' [] + randbs <- fixBS <$> StringRandom.stringRandomIO pat + return $ randbs =~ reg + + where + -- Seems that PCRE can't handle strings generated by encodeUtf8 + fixBS = (<> "") . encodeUtf8 diff --git a/test/string-random-test.hs b/test/string-random-test.hs new file mode 100644 --- /dev/null +++ b/test/string-random-test.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE FlexibleContexts #-} +import Data.Monoid ((<>)) +import qualified Data.ByteString as ByteString +import qualified Data.Text.Encoding as Encoding +import Control.Monad (forM_) +import qualified Text.StringRandom as StringRandom +import qualified Text.StringRandom.Parser as Parser +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.HUnit as HUnit +import Test.Tasty.HUnit ((@?=), (@?)) +import qualified Text.Regex.PCRE.Heavy as PCRE + +main :: IO () +main = Tasty.defaultMain allTests + +allTests :: Tasty.TestTree +allTests = Tasty.testGroup "All tests of random-string" + [ testParser + , testStringRandom + ] + +testParser :: Tasty.TestTree +testParser = HUnit.testCase "Test parsers" $ do + Parser.processParse "" @?= Right (Parser.PConcat []) + Parser.processParse "a" @?= Right (Parser.PClass "a") + Parser.processParse "[a-c]" @?= Right (Parser.PClass "abc") + Parser.processParse "\\d" @?= Right (Parser.PClass "0123456789") + Parser.processParse "[^\\w\\W]" @?= Right (Parser.PClass "") + + Parser.processParse "a*" @?= Right (Parser.PRange + 0 Nothing (Parser.PClass "a")) + Parser.processParse "a+" @?= Right (Parser.PRange + 1 Nothing (Parser.PClass "a")) + Parser.processParse "a{3}" @?= Right (Parser.PRange + 3 (Just 3) (Parser.PClass "a")) + Parser.processParse "a{1,}" @?= Right (Parser.PRange + 1 Nothing (Parser.PClass "a")) + Parser.processParse "a{1,3}" @?= Right (Parser.PRange + 1 (Just 3) (Parser.PClass "a")) + + Parser.processParse "abc" @?= Right (Parser.PConcat + [ Parser.PClass "a" + , Parser.PClass "b" + , Parser.PClass "c" + ]) + + Parser.processParse "a|b|c" @?= Right (Parser.PSelect + [ Parser.PClass "a" + , Parser.PClass "b" + , Parser.PClass "c" + ]) + + Parser.processParse "((a)(?:b)(c))" @?= + Right (Parser.PGrouped 1 + ( Parser.PConcat + [ Parser.PGrouped 2 (Parser.PClass "a") + , Parser.PClass "b" + , Parser.PGrouped 3 (Parser.PClass "c") + ] + ) + ) + + Parser.processParse "\\5" @?= Right (Parser.PBackward 5) + + Parser.processParse "^a\\b$" @?= Right (Parser.PConcat + [ Parser.PIgnored + , Parser.PClass "a" + , Parser.PIgnored + , Parser.PIgnored + ]) + +testStringRandom :: Tasty.TestTree +testStringRandom = HUnit.testCase "Test stringRandomIO" $ do + e <- StringRandom.stringRandomIO "" + e @?= "" + + e' <- StringRandom.stringRandomIO "a{0}" + e' @?= "" + + let patterns = + [ "" + , "a" + , "[a-c]" + , "\\d" + , "[^\\W]" + , "a*" + , "a+" + , "a{4}" + , "a{2,}" + , "a{2,4}" + , "abc" + , "a|b|c" + , "((a)(?:b)(c))" + , "(.*)\\1" + ] + forM_ patterns $ \pat -> do + let pat' = "^" <> fixBS pat <> "$" + (Right reg) = PCRE.compileM pat' [] + randbs <- fixBS <$> StringRandom.stringRandomIO pat + randbs PCRE.=~ reg @? ("check regexp: " ++ show pat' + ++ ", string: " ++ show randbs) + + where + -- Seems that PCRE can't handle strings generated by encodeUtf8 + fixBS = (<> "") . Encoding.encodeUtf8