{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}

module Text.Spintax (spintax) where

import           Control.Applicative  ((<|>))
import           Control.Monad.Reader (ask, runReaderT)
import           Data.Attoparsec.Text
import qualified Data.List.Extra      as E
import qualified Data.Text            as T
import           System.Random.MWC

-- | Generate random texts based on a spinning syntax template, with nested alternatives and empty options.
--
-- >λ> spintax "{{Oh my God|Awesome|Can't believe that}, {a|the}|A|The} {quick {and dirty |||}||}{brown |pink |grey |black |yellow }{fox|flea|elephant|panther|bear} jumps over {the|a} {lazy |smelly |sleepy |grouchy }{dog|cat|whale}{|||, that's {really |||}amazing}{.|!|...}"
-- > Right "Awesome, the quick pink fox jumps over a sleepy whale."
--
spintax :: T.Text -> IO (Either String T.Text)
spintax :: Text -> IO (Either String Text)
spintax Text
template =
  IO (Gen RealWorld)
IO GenIO
createSystemRandom IO (Gen RealWorld)
-> (Gen RealWorld -> IO (Either String Text))
-> IO (Either String Text)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReaderT (Gen RealWorld) IO (Either String Text)
-> Gen RealWorld -> IO (Either String Text)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Text -> ReaderT (Gen RealWorld) IO (Either String Text)
forall {m :: * -> *} {a}.
(MonadFail m, PrimMonad m, MonadReader (Gen (PrimState m)) m) =>
Text -> m (Either a Text)
spin Text
template)
  where
    spin :: Text -> m (Either a Text)
spin Text
t = Text -> [Text] -> Text -> Int -> m (Either a Text)
forall {a} {a}.
(Ord a, Num a) =>
Text -> [Text] -> Text -> a -> m (Either a Text)
go Text
T.empty [] Text
t (Int
0::Int)
      where

        go :: Text -> [Text] -> Text -> a -> m (Either a Text)
go Text
o [Text]
as Text
i a
l
          | a
l a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0  = m (Either a Text)
forall {a}. m a
parseFail
          | a
l a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 =
            case Parser Text -> Text -> Result Text
forall a. Parser a -> Text -> Result a
parse Parser Text
spinSyntax Text
i of
              Done Text
r Text
m  ->
                case Text
m of
                  Text
"{"                      -> Text -> [Text] -> Text -> a -> m (Either a Text)
go Text
o [Text]
as Text
r (a
la -> a -> a
forall a. Num a => a -> a -> a
+a
1)
                  Text
n | Text
n Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"}" Bool -> Bool -> Bool
|| Text
n Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"|" -> m (Either a Text)
forall {a}. m a
parseFail
                  Text
_                        -> Text -> [Text] -> Text -> a -> m (Either a Text)
go (Text
o Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
m) [Text]
as Text
r a
l
              Partial Text -> Result Text
_ -> Either a Text -> m (Either a Text)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Either a Text
forall a b. b -> Either a b
Right (Text -> Either a Text) -> Text -> Either a Text
forall a b. (a -> b) -> a -> b
$ Text
o Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
i)
              Fail {}   -> m (Either a Text)
forall {a}. m a
parseFail
          | a
l a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1 =
            case Parser Text -> Text -> Result Text
forall a. Parser a -> Text -> Result a
parse Parser Text
spinSyntax Text
i of
              Done Text
r Text
m ->
                case Text
m of
                  Text
"{" -> Text -> [Text] -> Text -> a -> m (Either a Text)
go Text
o (Text -> [Text]
addAlter Text
m) Text
r (a
la -> a -> a
forall a. Num a => a -> a -> a
+a
1)
                  Text
"}" -> do
                    Either a Text
a <- Text -> m (Either a Text)
spin (Text -> m (Either a Text)) -> m Text -> m (Either a Text)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Gen (PrimState m) -> m Text
forall {f :: * -> *}. PrimMonad f => Gen (PrimState f) -> f Text
randAlter (Gen (PrimState m) -> m Text) -> m (Gen (PrimState m)) -> m Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Gen (PrimState m))
forall r (m :: * -> *). MonadReader r m => m r
ask
                    case Either a Text
a of
                      Right Text
t' -> Text -> [Text] -> Text -> a -> m (Either a Text)
go (Text
o Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t') [] Text
r (a
la -> a -> a
forall a. Num a => a -> a -> a
-a
1)
                      Left a
_   -> m (Either a Text)
forall {a}. m a
parseFail
                  Text
"|" ->
                    if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
E.null [Text]
as
                      then Text -> [Text] -> Text -> a -> m (Either a Text)
go Text
o [Text
"",Text
""] Text
r a
l
                      else Text -> [Text] -> Text -> a -> m (Either a Text)
go Text
o ([Text] -> Text -> [Text]
forall a. [a] -> a -> [a]
E.snoc [Text]
as Text
"") Text
r a
l
                  Text
_   -> Text -> [Text] -> Text -> a -> m (Either a Text)
go Text
o (Text -> [Text]
addAlter Text
m) Text
r a
l
              Partial Text -> Result Text
_ -> m (Either a Text)
forall {a}. m a
parseFail
              Fail {} -> m (Either a Text)
forall {a}. m a
parseFail
          | a
l a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
1 =
            case Parser Text -> Text -> Result Text
forall a. Parser a -> Text -> Result a
parse Parser Text
spinSyntax Text
i of
              Done Text
r Text
m ->
                case Text
m of
                  Text
"{" -> Text -> [Text] -> Text -> a -> m (Either a Text)
go Text
o (Text -> [Text]
addAlter Text
m) Text
r (a
la -> a -> a
forall a. Num a => a -> a -> a
+a
1)
                  Text
"}" -> Text -> [Text] -> Text -> a -> m (Either a Text)
go Text
o (Text -> [Text]
addAlter Text
m) Text
r (a
la -> a -> a
forall a. Num a => a -> a -> a
-a
1)
                  Text
_   -> Text -> [Text] -> Text -> a -> m (Either a Text)
go Text
o (Text -> [Text]
addAlter Text
m) Text
r a
l
              Partial Text -> Result Text
_ -> m (Either a Text)
forall {a}. m a
parseFail
              Fail {}   -> m (Either a Text)
forall {a}. m a
parseFail
          where
            addAlter :: Text -> [Text]
addAlter Text
n =
                case [Text] -> Maybe ([Text], Text)
forall a. [a] -> Maybe ([a], a)
E.unsnoc [Text]
as of
                  Just ([Text]
xs,Text
x) -> [Text] -> Text -> [Text]
forall a. [a] -> a -> [a]
E.snoc [Text]
xs (Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n)
                  Maybe ([Text], Text)
Nothing     -> Text -> [Text]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
n
            randAlter :: Gen (PrimState f) -> f Text
randAlter Gen (PrimState f)
g =
              (\Int
r -> [Text] -> Int -> Text
forall a. HasCallStack => [a] -> Int -> a
(!!) [Text]
as (Int
rInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)) (Int -> Text) -> f Int -> f Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> Gen (PrimState f) -> f Int
forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
(a, a) -> Gen (PrimState m) -> m a
forall (m :: * -> *).
PrimMonad m =>
(Int, Int) -> Gen (PrimState m) -> m Int
uniformR (Int
1,[Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
E.length [Text]
as) Gen (PrimState f)
g
        go Text
_ [Text]
_ Text
_ a
_ = m (Either a Text)
forall {a}. m a
parseFail

        parseFail :: m a
parseFail = String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Spintax template parsing failure"

        spinSyntax :: Parser Text
spinSyntax =
          Parser Text
openBrace Parser Text -> Parser Text -> Parser Text
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
closeBrace Parser Text -> Parser Text -> Parser Text
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
pipe Parser Text -> Parser Text -> Parser Text
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
content
            where
              openBrace :: Parser Text
openBrace = Text -> Parser Text
string Text
"{"
              closeBrace :: Parser Text
closeBrace = Text -> Parser Text
string Text
"}"
              pipe :: Parser Text
pipe = Text -> Parser Text
string Text
"|"
              content :: Parser Text
content =
                (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
ctt
                  where
                    ctt :: Char -> Bool
ctt Char
'{' = Bool
False
                    ctt Char
'}' = Bool
False
                    ctt Char
'|' = Bool
False
                    ctt Char
_   = Bool
True