module Text.Ogmarkup.Private.Parser where
import Text.Megaparsec
import Control.Monad.State
import Data.String
import qualified Text.Ogmarkup.Private.Ast as Ast
data ParserState = ParserState {
parseWithEmph :: Bool
, parseWithStrongEmph :: Bool
, parseWithinQuote :: Bool
}
type OgmarkupParser a = StateT ParserState (Parsec Dec a)
enterEmph :: Stream a
=> OgmarkupParser a ()
enterEmph = do st <- get
if parseWithEmph st
then fail "guard against nested emphasis"
else do put st { parseWithEmph = True }
return ()
leaveEmph :: Stream a
=> OgmarkupParser a ()
leaveEmph = do st <- get
if parseWithEmph st
then do put st { parseWithEmph = False }
return ()
else fail "cannot leave emphasis when you did not enter"
enterStrongEmph :: Stream a
=> OgmarkupParser a ()
enterStrongEmph = do st <- get
if parseWithStrongEmph st
then fail "guard against nested strong emphasis"
else do put st { parseWithStrongEmph = True }
return ()
leaveStrongEmph :: Stream a
=> OgmarkupParser a ()
leaveStrongEmph = do st <- get
if parseWithStrongEmph st
then do put st { parseWithStrongEmph = False }
return ()
else fail "cannot leave strong emphasis when you did not enter"
enterQuote :: Stream a
=> OgmarkupParser a ()
enterQuote = do st <- get
if parseWithinQuote st
then fail "guard against nested quotes"
else do put st { parseWithinQuote = True }
return ()
leaveQuote :: Stream a
=> OgmarkupParser a ()
leaveQuote = do st <- get
if parseWithinQuote st
then do put st { parseWithinQuote = False }
return ()
else fail "cannot leave quote when you did not enter"
initParserState :: ParserState
initParserState = ParserState False False False
parse :: (Stream a, Token a ~ Char)
=> OgmarkupParser a b
-> String
-> a
-> Either (ParseError (Token a) Dec) b
parse ogma file = runParser (evalStateT ogma initParserState) file
document :: (Stream a, Token a ~ Char, IsString b)
=> OgmarkupParser a (Ast.Document b)
document = doc []
where doc :: (Stream a, Token a ~ Char, IsString b)
=> Ast.Document b
-> OgmarkupParser a (Ast.Document b)
doc ast = do space
sects <- many (try section)
let ast' = ast `mappend` sects
(eof >> return ast') <|> (recover ast' >>= doc)
recover :: (Stream a, Token a ~ Char, IsString b)
=> Ast.Document b
-> OgmarkupParser a (Ast.Document b)
recover ast = do failure <- someTill anyChar (char '\n')
return $ ast `mappend` [Ast.Failing $ fromString failure]
section :: (Stream a, Token a ~ Char, IsString b)
=> OgmarkupParser a (Ast.Section b)
section = aside <|> story
aside :: (Stream a, Token a ~ Char, IsString b)
=> OgmarkupParser a (Ast.Section b)
aside = do asideSeparator
cls <- optional asideClass
space
ps <- some (paragraph <* space)
asideSeparator
manyTill space (skip (char '\n') <|> eof)
space
return $ Ast.Aside cls ps
where
asideClass :: (Stream a, Token a ~ Char, IsString b)
=> OgmarkupParser a b
asideClass = do cls <- some letterChar
asideSeparator
return $ fromString cls
story :: (Stream a, Token a ~ Char, IsString b)
=> OgmarkupParser a (Ast.Section b)
story = Ast.Story `fmap` some (paragraph <* space)
paragraph :: (Stream a, Token a ~ Char, IsString b)
=> OgmarkupParser a (Ast.Paragraph b)
paragraph = some component <* blank
component :: (Stream a, Token a ~ Char, IsString b)
=> OgmarkupParser a (Ast.Component b)
component = try (dialogue <|> thought <|> teller) <|> illformed
illformed :: (Stream a, Token a ~ Char, IsString b)
=> OgmarkupParser a (Ast.Component b)
illformed = Ast.IllFormed `fmap` restOfParagraph
restOfParagraph :: (Stream a, Token a ~ Char, IsString b)
=> OgmarkupParser a b
restOfParagraph = do lookAhead anyChar
notFollowedBy endOfParagraph
str <- manyTill anyChar (lookAhead $ try endOfParagraph)
return $ fromString str
teller :: (Stream a, Token a ~ Char, IsString b)
=> OgmarkupParser a (Ast.Component b)
teller = Ast.Teller `fmap` some format
dialogue :: (Stream a, Token a ~ Char, IsString b)
=> OgmarkupParser a (Ast.Component b)
dialogue = talk '[' ']' Ast.Dialogue
thought :: (Stream a, Token a ~ Char, IsString b)
=> OgmarkupParser a (Ast.Component b)
thought = talk '<' '>' Ast.Thought
talk :: (Stream a, Token a ~ Char, IsString b)
=> Char
-> Char
-> (Ast.Reply b -> Maybe b -> Ast.Component b)
-> OgmarkupParser a (Ast.Component b)
talk c c' constructor = do
rep <- reply c c'
auth <- optional characterName
blank
return $ constructor rep auth
characterName :: (Stream a, Token a ~ Char, IsString b)
=> OgmarkupParser a b
characterName = do
char '('
notFollowedBy (char ')') <?> "Empty character names are not allowed"
auth <- manyTill anyChar (char ')') <?> "Missing closing )"
return $ fromString auth
reply :: (Stream a, Token a ~ Char, IsString b)
=> Char
-> Char
-> OgmarkupParser a (Ast.Reply b)
reply c c' = do char c
blank
p1 <- some format
x <- oneOf ['|', c']
case x of '|' -> do blank
ws <- some format
char '|' <?> "Missing | to close the with say"
blank
p2 <- many format
char c'
return $ Ast.WithSay p1 ws p2
_ -> return $ Ast.Simple p1
format :: (Stream a, Token a ~ Char, IsString b)
=> OgmarkupParser a (Ast.Format b)
format = choice [ raw
, emph
, strongEmph
, quote
]
raw :: (Stream a, Token a ~ Char, IsString b)
=> OgmarkupParser a (Ast.Format b)
raw = Ast.Raw `fmap` some atom
emph :: (Stream a, Token a ~ Char, IsString b)
=> OgmarkupParser a (Ast.Format b)
emph = do char '*'
blank
enterEmph
f <- format
fs <- manyTill format (char '*' >> blank)
leaveEmph
return . Ast.Emph $ (f:fs)
strongEmph :: (Stream a, Token a ~ Char, IsString b)
=> OgmarkupParser a (Ast.Format b)
strongEmph = do char '+'
blank
enterStrongEmph
f <- format
fs <- manyTill format (char '+' >> blank)
leaveStrongEmph
return . Ast.StrongEmph $ (f:fs)
quote :: (Stream a, Token a ~ Char, IsString b)
=> OgmarkupParser a (Ast.Format b)
quote = do openQuote
enterQuote
f <- format
fs <- manyTill format closeQuote
leaveQuote
return . Ast.Quote $ (f:fs)
atom :: (Stream a, Token a ~ Char, IsString b)
=> OgmarkupParser a (Ast.Atom b)
atom = (mark <|> longword <|> word) <* blank
word :: (Stream a, Token a ~ Char, IsString b)
=> OgmarkupParser a (Ast.Atom b)
word = do notFollowedBy endOfWord
str <- manyTill anyChar (lookAhead $ try endOfWord)
return $ Ast.Word (fromString str)
where
endOfWord :: (Stream a, Token a ~ Char)
=> OgmarkupParser a ()
endOfWord = eof <|> (skip spaceChar) <|> (skip $ oneOf specChar) <|> (skip mark)
specChar = "\"«»`+*[]<>|_\'’"
longword :: (Stream a, Token a ~ Char, IsString b)
=> OgmarkupParser a (Ast.Atom b)
longword = do char '`'
notFollowedBy (char '`') <?> "empty raw string are not accepted"
str <- manyTill anyChar (char '`')
return $ Ast.Word (fromString str)
mark :: (Stream a, Token a ~ Char)
=> OgmarkupParser a (Ast.Atom b)
mark = Ast.Punctuation `fmap` (semicolon
<|> colon
<|> question
<|> exclamation
<|> try longDash
<|> try dash
<|> hyphen
<|> comma
<|> apostrophe
<|> try suspensionPoints
<|> point)
where
parseMark p m = p >> return m
semicolon = parseMark (char ';') Ast.Semicolon
colon = parseMark (char ':') Ast.Colon
question = parseMark (char '?') Ast.Question
exclamation = parseMark (char '!') Ast.Exclamation
longDash = parseMark (string "—" <|> string "---") Ast.LongDash
dash = parseMark (string "–" <|> string "--") Ast.Dash
hyphen = parseMark (char '-') Ast.Hyphen
comma = parseMark (char ',') Ast.Comma
point = parseMark (char '.') Ast.Point
apostrophe = parseMark (char '\'' <|> char '’') Ast.Apostrophe
suspensionPoints = parseMark (string ".." >> many (char '.')) Ast.SuspensionPoints
openQuote :: (Stream a, Token a ~ Char)
=> OgmarkupParser a ()
openQuote = do char '«' <|> char '"'
blank
closeQuote :: (Stream a, Token a ~ Char)
=> OgmarkupParser a ()
closeQuote = do char '»' <|> char '"'
blank
asideSeparator :: (Stream a, Token a ~ Char)
=> OgmarkupParser a ()
asideSeparator = do string "__"
some (char '_')
return ()
endOfParagraph :: (Stream a, Token a ~ Char)
=> OgmarkupParser a ()
endOfParagraph = try betweenTwoSections
<|> asideSeparator
<|> eof
where
betweenTwoSections :: (Stream a, Token a ~ Char)
=> OgmarkupParser a ()
betweenTwoSections = do count 2 $ manyTill spaceChar (eof <|> skip (char '\n'))
space
blank :: (Stream a, Token a ~ Char)
=> OgmarkupParser a ()
blank = do skip $ optional (notFollowedBy endOfParagraph >> space)
skip :: (Stream a)
=> OgmarkupParser a b
-> OgmarkupParser a ()
skip = (>> return ())