{-# 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
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