module Text.Madlibs.Ana.Parse where
import Text.Madlibs.Internal.Types
import Text.Madlibs.Internal.Utils
import Text.Madlibs.Ana.ParseUtils
import Text.Madlibs.Cata.SemErr
import qualified Data.Text as T
import Text.Megaparsec
import Text.Megaparsec.Text
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Lexer as L
import Data.Monoid
import Control.Monad
import Control.Monad.State
lexeme :: Parser a -> Parser a
lexeme = L.lexeme spaceConsumer
spaceConsumer :: Parser ()
spaceConsumer = L.space (void . some $ spaceChar) (L.skipLineComment "#") (L.skipBlockComment "{#" "#}")
symbol :: String -> Parser String
symbol = L.symbol spaceConsumer
float :: Parser Prob
float = lexeme L.float
nonIndented = L.nonIndented spaceConsumer
quote :: Parser a -> Parser a
quote = between .$ (symbol "\"")
keyword :: String -> Parser String
keyword str = (pure <$> char ':') <> (symbol str) <?> "keyword"
define :: Parser ()
define = (void $ nonIndented (keyword "define"))
<?> "define block"
main :: Parser ()
main = (void $ nonIndented (keyword "return"))
<?> "return block"
name :: Parser String
name = lexeme (some letterChar) <?> "template name"
preStr :: Parser PreTok
preStr = (fmap (Name . T.pack) name) <|>
do {
s <- quote (many $ noneOf ("\"\'" :: String)) ;
pure $ PreTok . T.pack $ s
}
<?> "string or function name"
pair :: Parser (Prob, [PreTok])
pair = do
--indentGuard
p <- float
str <- some $ preStr
pure (p, str)
definition :: Parser (Key, [(Prob, [PreTok])])
definition = do
define
str <- name
val <- some pair
--linebreak
pure (T.pack str, val)
final :: Parser [(Prob, [PreTok])]
final = do
main
val <- some pair
pure val
program :: Parser [(Key, [(Prob, [PreTok])])]
program = sortKeys . checkSemantics <$> do
p <- many (try definition <|> ((,) "Template" <$> final))
pure p
parseTokM :: Parser (Context RandTok)
parseTokM = fmap build program
parseTok :: T.Text -> Either (ParseError Char Dec) RandTok
parseTok f = snd . head . (filter (\(i,j) -> i == "Template")) . (flip execState []) <$> runParser parseTokM "" f