module Text.Ogmarkup.Private.Parser where
import Control.Monad
import Data.String
import Text.ParserCombinators.Parsec hiding (parse)
import qualified Text.Ogmarkup.Private.Ast as Ast
data ParserState = ParserState {
parseWithEmph :: Bool
, parseWithStrongEmph :: Bool
, parseWithinQuote :: Bool
}
enterEmph :: OgmarkupParser ()
enterEmph = do st <- getState
if parseWithEmph st
then fail "guard against nested emphasis"
else do setState st { parseWithEmph = True }
return ()
leaveEmph :: OgmarkupParser ()
leaveEmph = do st <- getState
if parseWithEmph st
then do setState st { parseWithEmph = False }
return ()
else fail "cannot leave emphasis when you did not enter"
enterStrongEmph :: OgmarkupParser ()
enterStrongEmph = do st <- getState
if parseWithStrongEmph st
then fail "guard against nested strong emphasis"
else do setState st { parseWithStrongEmph = True }
return ()
leaveStrongEmph :: OgmarkupParser ()
leaveStrongEmph = do st <- getState
if parseWithStrongEmph st
then do setState st { parseWithStrongEmph = False }
return ()
else fail "cannot leave strong emphasis when you did not enter"
enterQuote :: OgmarkupParser ()
enterQuote = do st <- getState
if parseWithinQuote st
then fail "guard against nested quotes"
else do setState st { parseWithinQuote = True }
return ()
leaveQuote :: OgmarkupParser ()
leaveQuote = do st <- getState
if parseWithinQuote st
then do setState st { parseWithinQuote = False }
return ()
else fail "cannot leave quote when you did not enter"
initParserState :: ParserState
initParserState = ParserState False False False
type OgmarkupParser = GenParser Char ParserState
parse :: OgmarkupParser a -> String -> String -> Either ParseError a
parse ogma = runParser ogma initParserState
document :: IsString a
=> OgmarkupParser (Ast.Document a, String)
document = do spaces
sects <- many (try section)
input <- getInput
return (sects, input)
section :: IsString a
=> OgmarkupParser (Ast.Section a)
section = aside <|> story
aside :: IsString a
=> OgmarkupParser (Ast.Section a)
aside = do asideSeparator
cls <- optionMaybe asideClass
spaces
ps <- many1 (paragraph <* spaces)
asideSeparator
manyTill space (skip (char '\n') <|> eof)
spaces
return $ Ast.Aside cls ps
where
asideClass :: IsString a
=> OgmarkupParser a
asideClass = do a <- many1 letter
asideSeparator
return $ fromString a
story :: IsString a
=> OgmarkupParser (Ast.Section a)
story = Ast.Story `fmap` many1 (paragraph <* spaces)
paragraph :: IsString a
=> OgmarkupParser (Ast.Paragraph a)
paragraph = many1 component <* blank
component :: IsString a
=> OgmarkupParser (Ast.Component a)
component = try (dialogue <|> thought <|> teller) <|> illformed
illformed :: IsString a
=> OgmarkupParser (Ast.Component a)
illformed = Ast.IllFormed `fmap` restOfParagraph
restOfParagraph :: IsString a
=> OgmarkupParser a
restOfParagraph = do lookAhead anyToken
notFollowedBy endOfParagraph
str <- manyTill anyToken (lookAhead $ try endOfParagraph)
return $ fromString str
teller :: IsString a
=> OgmarkupParser (Ast.Component a)
teller = Ast.Teller `fmap` many1 format
dialogue :: IsString a
=> OgmarkupParser (Ast.Component a)
dialogue = talk '[' ']' Ast.Dialogue
thought :: IsString a
=> OgmarkupParser (Ast.Component a)
thought = talk '<' '>' Ast.Thought
talk :: IsString a
=> Char
-> Char
-> (Ast.Reply a -> Maybe a -> Ast.Component a)
-> OgmarkupParser (Ast.Component a)
talk c c' constructor = do
rep <- reply c c'
auth <- optionMaybe characterName
blank
return $ constructor rep auth
characterName :: IsString a
=> OgmarkupParser a
characterName = do
char '('
notFollowedBy (char ')') <?> "Empty character names are not allowed"
auth <- manyTill anyToken (char ')') <?> "Missing closing )"
return $ fromString auth
reply :: IsString a
=> Char
-> Char
-> OgmarkupParser (Ast.Reply a)
reply c c' = do char c
blank
p1 <- many1 format
x <- oneOf ['|', c']
case x of '|' -> do blank
ws <- many1 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 :: IsString a
=> OgmarkupParser (Ast.Format a)
format = choice [ raw
, emph
, strongEmph
, quote
]
raw :: IsString a
=> OgmarkupParser (Ast.Format a)
raw = Ast.Raw `fmap` many1 atom
emph :: IsString a
=> OgmarkupParser (Ast.Format a)
emph = do char '*'
blank
enterEmph
f <- format
fs <- manyTill format (char '*' >> blank)
leaveEmph
return . Ast.Emph $ (f:fs)
strongEmph :: IsString a
=> OgmarkupParser (Ast.Format a)
strongEmph = do char '+'
blank
enterStrongEmph
f <- format
fs <- manyTill format (char '+' >> blank)
leaveStrongEmph
return . Ast.StrongEmph $ (f:fs)
quote :: IsString a
=> OgmarkupParser (Ast.Format a)
quote = do char '"'
blank
enterQuote
f <- format
fs <- manyTill format (char '"' >> blank)
leaveQuote
return . Ast.Quote $ (f:fs)
atom :: IsString a
=> OgmarkupParser (Ast.Atom a)
atom = (mark <|> longword <|> word) <* blank
word :: IsString a
=> OgmarkupParser (Ast.Atom a)
word = do lookAhead anyToken
notFollowedBy endOfWord
str <- manyTill anyToken (lookAhead $ try endOfWord)
return $ Ast.Word (fromString str)
where
specChar = "\"«»`+*[]<>|_\'’"
endOfWord :: OgmarkupParser ()
endOfWord = eof <|> skip space <|> skip (oneOf specChar) <|> skip mark
longword :: IsString a
=> OgmarkupParser (Ast.Atom a)
longword = do char '`'
notFollowedBy (char '`') <?> "empty raw string are not accepted"
str <- manyTill anyToken (char '`')
return $ Ast.Word (fromString str)
mark :: OgmarkupParser (Ast.Atom a)
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 :: OgmarkupParser ()
openQuote = do char '«' <|> char '"'
blank
closeQuote :: OgmarkupParser ()
closeQuote = do char '»' <|> char '"'
blank
asideSeparator :: OgmarkupParser ()
asideSeparator = do string "__"
many1 (char '_')
return ()
endOfParagraph :: OgmarkupParser ()
endOfParagraph = try betweenTwoSections
<|> asideSeparator
<|> eof
where
betweenTwoSections :: OgmarkupParser ()
betweenTwoSections = do count 2 $ manyTill space (eof <|> skip (char '\n'))
spaces
blank :: OgmarkupParser ()
blank = optional (notFollowedBy endOfParagraph >> spaces)
skip :: OgmarkupParser a -> OgmarkupParser ()
skip = void