module Text.Spintax where
import Control.Applicative ((<|>))
import Data.Attoparsec.Text
import Data.Either
import Data.List.Extra as E
import Data.Text as T
import System.Random.MWC
spintax :: T.Text -> IO (Either T.Text T.Text)
spintax template =
createSystemRandom >>= \gen -> runParse gen template
where
runParse gen input =
getText gen "" [] input 0
where
getText gen output alters input nestlev
| nestlev < 0 = return failure
| nestlev == 0 =
case parse spinSyntax input of
Done rest match ->
case match of
"{" -> getText gen output alters rest (nestlev+1)
"}" -> return failure
"|" -> return failure
_ -> getText gen (output `append` match) alters rest nestlev
Partial _ -> return $ Right $ output `append` input
Fail {} -> return failure
| nestlev == 1 =
case parse spinSyntax input of
Done rest match ->
case match of
"{" -> getText gen output (addToLast alters match) rest (nestlev+1)
"}" -> do result <- runParse gen =<< randAlter gen alters
case result of
Left _ -> return failure
Right text -> getText gen (output `append` text) [] rest (nestlev1)
"|" -> if E.null alters
then getText gen output ["",""] rest nestlev
else getText gen output (E.snoc alters "") rest nestlev
_ -> getText gen output (addToLast alters match) rest nestlev
Partial _ -> return failure
Fail {} -> return failure
| nestlev > 1 =
case parse spinSyntax input of
Done rest match ->
case match of
"{" -> getText gen output (addToLast alters match) rest (nestlev+1)
"}" -> getText gen output (addToLast alters match) rest (nestlev1)
_ -> getText gen output (addToLast alters match) rest nestlev
Partial _ -> return failure
Fail {} -> return failure
where
failure = Left "Spintax template parsing failure"
addToLast l t =
case E.unsnoc l of
Just (xs,x) -> E.snoc xs $ x `append` t
Nothing -> [t]
randAlter g as = uniformR (1,E.length as) g >>= \r -> return $ (!!) as (r1)
spinSyntax =
openBrace <|> closeBrace <|> pipe <|> content
where
pipe = string "|"
openBrace = string "{"
closeBrace = string "}"
content =
takeWhile1 ctt
where
ctt '{' = False
ctt '}' = False
ctt '|' = False
ctt _ = True