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
import Control.Exception hiding (try)
import Data.Composition
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 <|> (fromIntegral <$> integer) <?> "Float"
integer :: Parser Integer
integer = lexeme (L.integer ) <?> "Integer"
nonIndented = L.nonIndented spaceConsumer
indentGuard = L.indentGuard spaceConsumer GT (unsafePos 4)
quote :: Parser a -> Parser a
quote = between (char '"') (char '"')
keyword :: String -> Parser String
keyword str = (char ':') >> (symbol str) <?> "keyword"
var :: Parser Int
var = fromIntegral <$> do
char '$'
integer <?> "variable"
define :: Parser ()
define = void (nonIndented (keyword "define"))
<?> "define block"
include :: Parser ()
include = void (nonIndented (keyword "include"))
<?> "include"
main :: Parser ()
main = void (nonIndented (keyword "return"))
<?> "return block"
name :: Parser String
name = lexeme (some (letterChar <|> oneOf ("-/" :: String))) <?> "template name"
preStr :: [T.Text] -> Parser PreTok
preStr ins = (fmap (Name . T.pack) name) <|>
do {
v <- var ;
pure . PreTok $ ins `access` (v1)
} <|>
do {
s <- quote (many $ noneOf ("\n\"" :: String)) ;
spaceConsumer ;
pure $ PreTok . T.pack $ s
}
<?> "string or function name"
pair :: [T.Text] -> Parser (Prob, [PreTok])
pair ins = do
indentGuard
p <- float
str <- some (preStr ins)
pure (p, str) <?> "Probability/text pair"
inclusions :: Parser [String]
inclusions = many . try $ do
include
str <- name
string ".mad"
pure (str ++ ".mad")
definition :: [T.Text] -> Parser (Key, [(Prob, [PreTok])])
definition ins = do
define
str <- name
val <- fmap normalize . some $ pair ins
pure (T.pack str, val) <?> "define block"
final :: [T.Text] -> Parser [(Prob, [PreTok])]
final ins = do
main
val <- fmap normalize . some $ pair ins
pure val
program :: [T.Text] -> Parser [(Key, [(Prob, [PreTok])])]
program ins = sortKeys <$> (checkSemantics =<< do
inclusions
p <- many (try (definition ins) <|> ((,) "Template" <$> final ins))
lexeme eof
pure p)
parseTokM :: [T.Text] -> Parser (Context RandTok)
parseTokM ins = build <$> program ins
parseTreeM :: [T.Text] -> Parser (Context RandTok)
parseTreeM ins = buildTree <$> program ins
parseTokF :: FilePath -> [(Key, RandTok)] -> [T.Text] -> T.Text -> Either (ParseError Char Dec) [(Key, RandTok)]
parseTokF filename state ins f = (flip execState (filterTemplate state)) <$> runParser (parseTokM ins) filename f
where filterTemplate = map (\(i,j) -> if i == "Template" then (strip filename, j) else (i,j))
parseTreeF :: FilePath -> [(Key, RandTok)] -> [T.Text] -> T.Text -> Either (ParseError Char Dec) [(Key, RandTok)]
parseTreeF filename state ins f = (flip execState (filterTemplate state)) <$> runParser (parseTreeM ins) filename f
where filterTemplate = map (\(i,j) -> if i == "Template" then (strip filename, j) else (i,j))
parseTok :: FilePath -> [(Key, RandTok)] -> [T.Text] -> T.Text -> Either (ParseError Char Dec) RandTok
parseTok = (fmap takeTemplate) .*** parseTokF
parseTree :: FilePath -> [(Key, RandTok)] -> [T.Text] -> T.Text -> Either (ParseError Char Dec) RandTok
parseTree = (fmap takeTemplate) .*** parseTreeF
parseInclusions :: FilePath -> T.Text -> Either (ParseError Char Dec) [String]
parseInclusions = runParser inclusions