{-# LANGUAGE FlexibleContexts  #-}

module Text.Spintax where

import           Control.Applicative  ((<|>))
import           Control.Monad.Reader (ask, runReaderT)
import           Data.Attoparsec.Text
import           Data.List            as L (intersperse)
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

-- * Utils

-- | Write a spintax alternative
--
-- >λ>  writeSpintaxAlternative ["apple","apricot","banana","coconut"]
-- "{apple|apricot|banana|coconut}"
writeSpintaxAlternative :: [T.Text] -> T.Text
writeSpintaxAlternative :: [Text] -> Text
writeSpintaxAlternative = Text -> [Text] -> Text
writeSpintaxExpression Text
"|"

writeSpintaxExpression :: T.Text -> [T.Text] -> T.Text
writeSpintaxExpression :: Text -> [Text] -> Text
writeSpintaxExpression Text
s [Text]
l = Text
"{" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.concat (Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
L.intersperse Text
s [Text]
l) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}"