{-|
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 <https://github.com/cho45/String_random.js/blob/master/lib/String_random.js String_random.js>

As with this package, there are <https://hackage.haskell.org/package/random-strings random-strings>
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 :: Text -> IO Text
stringRandomIO Text
txt = do
  StdGen
g <- IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
Random.newStdGen
  Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ StdGen -> Text -> Text
forall g. RandomGen g => g -> Text -> Text
stringRandom StdGen
g Text
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 -> Text -> Text
stringRandom g
g Text
txt = case g -> Text -> Either String Text
forall g. RandomGen g => g -> Text -> Either String Text
stringRandomWithError g
g Text
txt of
                       Left  String
l -> String -> Text
forall a. HasCallStack => String -> a
error String
l
                       Right Text
r -> Text
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 -> Text -> Either String Text
stringRandomWithError g
g Text
txt = do
  Parsed
parsed <- Text -> Either String Parsed
Parser.processParse Text
txt
  -- 10 : max length of a* or a+
  let (Text
ret, ()
_) = RWS Int () (g, IntMap Text) Text
-> Int -> (g, IntMap Text) -> (Text, ())
forall r w s a. RWS r w s a -> r -> s -> (a, w)
RWS.evalRWS (Parsed -> RWS Int () (g, IntMap Text) Text
forall g. RandomGen g => Parsed -> GenRWS g Text
str Parsed
parsed) Int
10 (g
g, IntMap Text
forall a. IntMap a
Map.empty)
  Text -> Either String Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
ret

withGen :: Random.RandomGen g => (g -> (a, g)) -> GenRWS g a
withGen :: (g -> (a, g)) -> GenRWS g a
withGen g -> (a, g)
f = do
  (g
gen, IntMap Text
m) <- RWST Int () (g, IntMap Text) Identity (g, IntMap Text)
forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
RWS.get
  let (a
a, g
gen') = g -> (a, g)
f g
gen
  (g, IntMap Text) -> RWST Int () (g, IntMap Text) Identity ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
s -> RWST r w s m ()
RWS.put (g
gen', IntMap Text
m)
  a -> GenRWS g a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

randomRM :: (Random.RandomGen g, Random.Random a) => (a, a) -> GenRWS g a
randomRM :: (a, a) -> GenRWS g a
randomRM = (g -> (a, g)) -> GenRWS g a
forall g a. RandomGen g => (g -> (a, g)) -> GenRWS g a
withGen ((g -> (a, g)) -> GenRWS g a)
-> ((a, a) -> g -> (a, g)) -> (a, a) -> GenRWS g a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, a) -> g -> (a, g)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
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 :: [a] -> GenRWS g a
choice [a]
xs = do
  Int
i <- (Int, Int) -> GenRWS g Int
forall g a. (RandomGen g, Random a) => (a, a) -> GenRWS g a
randomRM (Int
0, [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  a -> GenRWS g a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> GenRWS g a) -> a -> GenRWS g a
forall a b. (a -> b) -> a -> b
$ [a]
xs [a] -> Int -> a
forall a. [a] -> Int -> a
!! Int
i

putGroup :: Int -> Text.Text -> GenRWS g ()
putGroup :: Int -> Text -> GenRWS g ()
putGroup Int
n Text
v = do
  (g
gen, IntMap Text
m) <- RWST Int () (g, IntMap Text) Identity (g, IntMap Text)
forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
RWS.get
  let m' :: IntMap Text
m' = Int -> Text -> IntMap Text -> IntMap Text
forall a. Int -> a -> IntMap a -> IntMap a
Map.insert Int
n Text
v IntMap Text
m
  (g, IntMap Text) -> GenRWS g ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
s -> RWST r w s m ()
RWS.put (g
gen, IntMap Text
m')

getGroup :: Int -> GenRWS g Text.Text
getGroup :: Int -> GenRWS g Text
getGroup Int
n = do
  IntMap Text
m <- ((g, IntMap Text) -> IntMap Text)
-> RWST Int () (g, IntMap Text) Identity (IntMap Text)
forall w (m :: * -> *) s a r.
(Monoid w, Monad m) =>
(s -> a) -> RWST r w s m a
RWS.gets (g, IntMap Text) -> IntMap Text
forall a b. (a, b) -> b
snd
  let maybeV :: Maybe Text
maybeV = Int -> IntMap Text -> Maybe Text
forall a. Int -> IntMap a -> Maybe a
Map.lookup Int
n IntMap Text
m
  case Maybe Text
maybeV of
    Maybe Text
Nothing -> Text -> GenRWS g Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
""
    Just Text
v  -> Text -> GenRWS g Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
v

size :: GenRWS g Int
size :: GenRWS g Int
size = GenRWS g Int
forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m r
RWS.ask

str :: Random.RandomGen g => Parser.Parsed -> GenRWS g Text.Text
str :: Parsed -> GenRWS g Text
str (Parser.PClass String
cs) = Char -> Text
Text.singleton (Char -> Text)
-> RWST Int () (g, IntMap Text) Identity Char -> GenRWS g Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> RWST Int () (g, IntMap Text) Identity Char
forall g a. RandomGen g => [a] -> GenRWS g a
choice String
cs
str (Parser.PRange Int
s Maybe Int
me Parsed
p) = do
  Int
e <- case Maybe Int
me of
    Just Int
e' -> Int -> RWST Int () (g, IntMap Text) Identity Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
e'
    Maybe Int
Nothing -> RWST Int () (g, IntMap Text) Identity Int
forall g. GenRWS g Int
size
  Int
n <- (Int, Int) -> RWST Int () (g, IntMap Text) Identity Int
forall g a. (RandomGen g, Random a) => (a, a) -> GenRWS g a
randomRM (Int
s, Int
e)
  [Text] -> Text
Text.concat ([Text] -> Text)
-> RWST Int () (g, IntMap Text) Identity [Text] -> GenRWS g Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> GenRWS g Text)
-> [Int] -> RWST Int () (g, IntMap Text) Identity [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (GenRWS g Text -> Int -> GenRWS g Text
forall a b. a -> b -> a
const (GenRWS g Text -> Int -> GenRWS g Text)
-> GenRWS g Text -> Int -> GenRWS g Text
forall a b. (a -> b) -> a -> b
$ Parsed -> GenRWS g Text
forall g. RandomGen g => Parsed -> GenRWS g Text
str Parsed
p) [Int
1 .. Int
n]
str (Parser.PConcat [Parsed]
ps) = [Text] -> Text
Text.concat ([Text] -> Text)
-> RWST Int () (g, IntMap Text) Identity [Text] -> GenRWS g Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parsed -> GenRWS g Text)
-> [Parsed] -> RWST Int () (g, IntMap Text) Identity [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Parsed -> GenRWS g Text
forall g. RandomGen g => Parsed -> GenRWS g Text
str [Parsed]
ps
str (Parser.PSelect [Parsed]
ps) = Parsed -> GenRWS g Text
forall g. RandomGen g => Parsed -> GenRWS g Text
str (Parsed -> GenRWS g Text)
-> RWST Int () (g, IntMap Text) Identity Parsed -> GenRWS g Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Parsed] -> RWST Int () (g, IntMap Text) Identity Parsed
forall g a. RandomGen g => [a] -> GenRWS g a
choice [Parsed]
ps
str (Parser.PGrouped Int
n Parsed
p) = do
  Text
v <- Parsed -> GenRWS g Text
forall g. RandomGen g => Parsed -> GenRWS g Text
str Parsed
p
  Int -> Text -> GenRWS g ()
forall g. Int -> Text -> GenRWS g ()
putGroup Int
n Text
v
  Text -> GenRWS g Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
v
str (Parser.PBackward Int
n) = Int -> GenRWS g Text
forall g. Int -> GenRWS g Text
getGroup Int
n
str (Parsed
Parser.PIgnored) = Text -> GenRWS g Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
""