module Text.Madlibs.Ana.Parse (
parseTok
, parseTokF
, parseInclusions
, parseTree
, parseTreeF
, parseTokM ) where
import Control.Composition
import Control.Monad
import Control.Monad.State
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid
import qualified Data.Text as T
import Data.Void
import Text.Madlibs.Ana.ParseUtils
import Text.Madlibs.Cata.SemErr
import Text.Madlibs.Internal.Types
import Text.Madlibs.Internal.Utils
import Text.Megaparsec
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L
lexeme :: Parser a -> Parser a
lexeme = L.lexeme spaceConsumer
spaceOnly :: Parser ()
spaceOnly = L.space (void . some $ oneOf ("\t " :: String)) (L.skipLineComment "#") (L.skipBlockComment "{#" "#}")
spaceConsumer :: Parser ()
spaceConsumer = L.space (void . some $ spaceChar) (L.skipLineComment "#") (L.skipBlockComment "{#" "#}")
symbol :: T.Text -> Parser T.Text
symbol = L.symbol spaceConsumer
float :: Parser Prob
float = lexeme L.float <|> (fromIntegral <$> integer) <?> "Number"
integer :: Parser Integer
integer = lexeme L.decimal <?> "Integer"
nonIndented :: Parser a -> Parser a
nonIndented = L.nonIndented spaceConsumer
indentGuard :: Parser Pos
indentGuard = L.indentGuard spaceConsumer GT (mkPos 4)
quote :: Parser a -> Parser a
quote = between .$ char '"'
keyword :: T.Text -> Parser T.Text
keyword str = char ':' >> symbol str <?> "keyword"
var :: Parser Int
var = fromIntegral <$> do
char '$'
integer <?> "variable"
define :: Parser ()
define = void (nonIndented (keyword "define"))
<?> "define block"
cat :: Parser ()
cat = void (nonIndented (keyword "category"))
<?> "category block"
include :: Parser ()
include = void (nonIndented (keyword "include"))
<?> "include"
main :: Parser ()
main = void (nonIndented (keyword "return"))
<?> "return block"
name :: Parser T.Text
name = (lexeme . fmap T.pack) (some (letterChar <|> oneOf ("-/" :: String))) <?> "template name"
modifier :: Parser (T.Text -> T.Text)
modifier = do
char '.'
str <- foldr ((<|>) . try . string) (pure "") ["to_upper", "to_lower", "reverse", "reverse_words", "oulipo", "capitalize", "titlecase"]
pure (fromMaybe id (M.lookup (T.unpack str) modifierList)) <?> "modifier"
preStr :: [T.Text] -> Parser PreTok
preStr ins = do {
n <- name ;
mod' <- many modifier ;
spaceOnly ;
pure $ Name n (foldr (.) id mod')
} <|>
do {
v <- var ;
mod' <- many modifier ;
spaceOnly ;
pure . PreTok . foldr (.) id mod' $ ins `access` (v1)
} <|>
do {
s <- quote (many $ noneOf ("\n\"" :: String)) ;
mod' <- many modifier ;
spaceOnly ;
pure . PreTok . foldr (.) id mod' . T.pack $ s
}
<?> "string or function name"
pair :: [T.Text] -> Parser (Prob, [PreTok])
pair ins = lexeme $ do
indentGuard
p <- float
str <- some (preStr ins)
pure (p, str) <?> "Probability-text pair"
function :: Parser (Prob, [PreTok])
function = lexeme $ do
indentGuard
char '|'
spaceOnly
str <- some (preStr mempty)
pure (1.0, str) <?> "Function name"
inclusions :: Parser [T.Text]
inclusions = many . try $ do
include
str <- name
string ".mad"
pure (str <> ".mad") <?> "Include statement"
definition :: [T.Text] -> Parser (Key, [(Prob, [PreTok])])
definition ins = do
define
str <- name
val <- fmap normalize . some $ pair ins
pure (str, val) <?> "define block"
category :: Parser (Key, [(Prob, [PreTok])])
category = do
cat
str <- name
val <- fmap normalize . some $ function
pure (str, val) <?> "category 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) <|> try category <|> ((,) "Return" <$> 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 (ErrorFancy Void)) [(Key, RandTok)]
parseTokF filename state' ins f = flip execState (filterTemplate state') <$> runParser (parseTokM ins) filename f
where filterTemplate = map (\(i,j) -> if i == "Return" then (strip filename, j) else (i,j))
parseTreeF :: FilePath -> [(Key, RandTok)] -> [T.Text] -> T.Text -> Either (ParseError Char (ErrorFancy Void)) [(Key, RandTok)]
parseTreeF filename state' ins f = flip execState (filterTemplate state') <$> runParser (parseTreeM ins) filename f
where filterTemplate = map (\(i,j) -> if i == "Return" then (strip filename, j) else (i,j))
parseTok :: FilePath
-> [(Key, RandTok)]
-> [T.Text]
-> T.Text
-> Either (ParseError Char (ErrorFancy Void)) RandTok
parseTok = fmap takeTemplate .*** parseTokF
parseTree :: FilePath -> [(Key, RandTok)] -> [T.Text] -> T.Text -> Either (ParseError Char (ErrorFancy Void)) RandTok
parseTree = fmap takeTemplate .*** parseTreeF
parseInclusions :: FilePath -> T.Text -> Either (ParseError Char (ErrorFancy Void)) [T.Text]
parseInclusions = runParser inclusions