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

module Text.Spintax (spintax) where

import           Control.Applicative  ((<|>))
import           Control.Monad.Reader (runReaderT, ask)
import           Data.Attoparsec.Text
import qualified Data.List.Extra      as E
import           Data.Monoid          ((<>))
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}, {a|the}|A|The} {quick {and dirty |||}||}{brown |pink |grey |}{fox|flea|elephant} jumps over {the|a} {lazy |smelly |sleepy |}{dog|cat|whale}{.|!|...}"
-- > 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 (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 (m :: * -> *) a. Monad m => a -> m a
return (Either a Text -> m (Either a Text))
-> Either a Text -> m (Either a Text)
forall a b. (a -> b) -> a -> b
$ 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 -> [Text]
forall a. Semigroup a => [a] -> a -> [a]
add [Text]
as 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
=<< [Text] -> Gen (PrimState m) -> m Text
forall (f :: * -> *) (t :: * -> *) a.
(PrimMonad f, Foldable t) =>
t a -> Gen (PrimState f) -> f Text
randAlter [Text]
as (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
                      Left a
_   -> m (Either a Text)
forall a. m a
parseFail
                      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)
                  Text
"|" ->
                    if [Text] -> 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 -> [Text]
forall a. Semigroup a => [a] -> a -> [a]
add [Text]
as 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 -> [Text]
forall a. Semigroup a => [a] -> a -> [a]
add [Text]
as 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 -> [Text]
forall a. Semigroup a => [a] -> a -> [a]
add [Text]
as 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 -> [Text]
forall a. Semigroup a => [a] -> a -> [a]
add [Text]
as 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
            add :: [a] -> a -> [a]
add [a]
_l a
_t =
              case [a] -> Maybe ([a], a)
forall a. [a] -> Maybe ([a], a)
E.unsnoc [a]
_l of
                Just ([a]
xs,a
x) -> [a] -> a -> [a]
forall a. [a] -> a -> [a]
E.snoc [a]
xs (a -> [a]) -> a -> [a]
forall a b. (a -> b) -> a -> b
$ a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
_t
                Maybe ([a], a)
Nothing     -> [a
_t]
            randAlter :: t a -> Gen (PrimState f) -> f Text
randAlter t a
_as Gen (PrimState f)
_g =
              (\Int
r -> [Text] -> Int -> Text
forall a. [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
uniformR (Int
1,t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
E.length t a
_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 (m :: * -> *) a. MonadFail m => String -> m a
fail String
msg
        msg :: String
msg = String
"Spintax template parsing failure"
        spinSyntax :: Parser Text
spinSyntax =
          Parser Text
openBrace Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
closeBrace Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
pipe Parser Text -> Parser Text -> Parser Text
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