typst-0.6.2: src/Typst/Parse.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Typst.Parse
( parseTypst,
)
where
import Data.List (sortOn)
import Control.Applicative (some)
import Control.Monad (MonadPlus (mzero), guard, void, when)
import Control.Monad.Identity (Identity)
import Data.Char hiding (Space)
import Data.Maybe (isJust, isNothing)
import Data.Text (Text)
import qualified Data.Text as T
import Text.Parsec hiding (string)
import qualified Text.Parsec as P
import Text.Parsec.Expr
import Text.Read (readMaybe)
import Typst.Syntax
import Typst.Shorthands (mathSymbolShorthands)
-- import Debug.Trace
-- | Parse text into a list of 'Markup' (or a Parsec @ParseError@).
parseTypst ::
-- | Filepath to Typst source text, only used for error messages
FilePath ->
-- | The Typst source text
Text ->
Either ParseError [Markup]
parseTypst fp inp =
case runParser (spaces *> many pMarkup <* pEndOfContent) initialState fp inp of
Left e -> Left e
Right r -> Right r
data PState = PState
{ stIndent :: [Int],
stLineStartCol :: !Int,
stAllowNewlines :: !Int, -- allow newlines if > 0
stSpaceBefore :: Maybe (SourcePos, Text),
stLastMathTok :: Maybe (SourcePos, Markup),
stContentBlockNesting :: Int
}
deriving (Show)
initialState :: PState
initialState =
PState
{ stIndent = [],
stLineStartCol = 1,
stAllowNewlines = 0,
stSpaceBefore = Nothing,
stLastMathTok = Nothing,
stContentBlockNesting = 0
}
type P = Parsec Text PState
string :: String -> P String
string = try . P.string
ws :: P ()
ws = do
p1 <- getPosition
inp <- getInput
allowNewlines <- stAllowNewlines <$> getState
let isSp c
| allowNewlines > 0 = isSpace c
| otherwise = isSpace c && c /= '\r' && c /= '\n'
( skipMany1 (void (satisfy isSp) <|> void pComment)
*> updateState (\st -> st {stSpaceBefore = Just (p1, inp)})
)
<|> updateState (\st -> st {stSpaceBefore = Nothing})
lexeme :: P a -> P a
lexeme pa = pa <* ws
sym :: String -> P String
sym = lexeme . string
op :: String -> P ()
op s = try $ lexeme $ do
void $ string s
when
( s == "+"
|| s == "-"
|| s == "*"
|| s == "/"
|| s == "="
|| s == "<"
|| s == ">"
|| s == "!"
)
$ notFollowedBy (char '=')
when (s == "-") $
notFollowedBy (char '>') -- arrows
when (s == "<") $
notFollowedBy (char '-' <|> char '=') -- arrows
when (s == "=") $
notFollowedBy (char '>' <|> char '=')
withNewlines :: P a -> P a
withNewlines pa = do
updateState $ \st -> st {stAllowNewlines = stAllowNewlines st + 1}
res <- pa
updateState $ \st -> st {stAllowNewlines = stAllowNewlines st - 1}
pure res
inParens :: P a -> P a
inParens pa = withNewlines (between (sym "(") (char ')') pa) <* ws
inBraces :: P a -> P a
inBraces pa = withNewlines (between (sym "{") (char '}') pa) <* ws
pMarkup :: P Markup
pMarkup =
pSpace
<|> pHeading
<|> pComment
<|> pEol
<|> pHardbreak
<|> pStrong
<|> pEmph
<|> pEquation
<|> pListItem
<|> pUrl
<|> pText
<|> pRawBlock
<|> pRawInline
<|> pEscaped
<|> pNbsp
<|> pDash
<|> pEllipsis
<|> pQuote
<|> pLabelInContent
<|> pRef
<|> pHash
<|> pBracketed
<|> pSymbol
-- We need to group paired brackets or the closing bracketed may be
-- taken to close a pContent block:
pBracketed :: P Markup
pBracketed =
Bracketed <$> try (between (char '[') (char ']') (many pMarkup))
pSymbol :: P Markup
pSymbol = do
blockNesting <- stContentBlockNesting <$> getState
let isSpecial' c = isSpecial c && (c /= ']' || blockNesting == 0)
Text . T.singleton <$> satisfy isSpecial'
-- equation ::= ('$' math* '$') | ('$ ' math* ' $')
pEquation :: P Markup
pEquation = do
void $ char '$'
withNewlines $ do
display <- option False $ True <$ lookAhead space
ws
maths <- many pMath
void $ char '$'
pure $ Equation display maths
mathOperatorTable :: [[Operator Text PState Identity Markup]]
mathOperatorTable =
[ -- precedence 7 -- attachment with number, e.g. a_1 (#17), or (..) group
[ Infix (attachBottom <$ (try (op "_" *> lookAhead (mNumber <|> mGroup))))
AssocLeft,
Infix (attachTop <$ (try (op "^" *> lookAhead (mNumber <|> mGroup))))
AssocLeft
],
-- precedence 6
[ Postfix
( try $ do
getState >>= guard . isNothing . stSpaceBefore
-- NOTE: can't have space before () or [] arg in a
-- function call! to prevent bugs with e.g. 'if 2<3 [...]'.
pos <- getPosition
lastMathTok <- stLastMathTok <$> getState
-- 1(a) is not a function
-- !(a) is not a function
-- f(a) is a function
-- "alpha"(a) is a function
-- alpha(a) is a function
-- see #55
-- but we still don't match typst for "!"(a), which typst DOES consider
-- a function
guard $ case lastMathTok of
Just (pos', MGroup _ (Just t) _)
| pos == pos' -> T.all isLetter t
Just (pos', Text t)
| pos == pos'
-> case T.unsnoc t of
Nothing -> True
Just (_,c) -> isLetter c
_ -> True
args <- mGrouped '(' ')' True
pure $ \expr -> MGroup Nothing Nothing [expr, args]
)
],
-- precedence 5 -- factorial needs to take precedence over fraction
[ Postfix (try $ do
mbBeforeSpace <- stSpaceBefore <$> getState
guard $ isNothing mbBeforeSpace
lexeme $ char '!' *> notFollowedBy (char '=')
pure (\expr -> MGroup Nothing Nothing [expr, Text "!"]))
],
-- precedence 4 -- attachment with non-number, e.g. a_x
[ Infix (attachBottom <$ op "_") AssocLeft,
Infix (attachTop <$ op "^") AssocLeft
],
-- precedence 3
[ Infix (makeFrac <$ op "/") AssocLeft
]
]
-- MAttach (Maybe bottom) (Maybe top) base
attachBottom :: Markup -> Markup -> Markup
attachBottom (MAttach Nothing y x) z = MAttach (Just (hideOuterParens z)) y x
attachBottom z (MAttach Nothing y x) = MAttach (Just (hideOuterParens x)) y z
attachBottom base x = MAttach (Just (hideOuterParens x)) Nothing base
attachTop :: Markup -> Markup -> Markup
attachTop (MAttach x Nothing y) z = MAttach x (Just (hideOuterParens z)) y
attachTop z (MAttach x Nothing y) = MAttach x (Just (hideOuterParens y)) z
attachTop base x = MAttach Nothing (Just (hideOuterParens x)) base
makeFrac :: Markup -> Markup -> Markup
makeFrac x y = MFrac x (hideOuterParens y)
hideOuterParens :: Markup -> Markup
hideOuterParens (MGroup (Just "(") (Just ")") x) = MGroup Nothing Nothing x
hideOuterParens x = x
mathExpressionTable :: [[Operator Text PState Identity Expr]]
mathExpressionTable = take 16 (cycle [[mathFieldAccess], [mathFunctionCall]])
mathFieldAccess :: Operator Text PState Identity Expr
mathFieldAccess =
Postfix (FieldAccess <$> try (sym "." *> (Ident <$> pMathField)))
where
pMathField = lexeme $ do
d <- satisfy (\c -> isIdentStart c && c /= '_')
ds <- many $ satisfy (\c -> isIdentContinue c && c /= '_' && c /= '-')
pure $ Identifier $ T.pack (d : ds)
mathFunctionCall :: Operator Text PState Identity Expr
mathFunctionCall =
Postfix
( do
mbBeforeSpace <- stSpaceBefore <$> getState
-- NOTE: can't have space before () or [] arg in a
-- function call! to prevent bugs with e.g. 'if 2<3 [...]'.
guard $ isNothing mbBeforeSpace
args <- mArgs
pure $ \expr -> FuncCall expr args
)
mExpr :: P Markup
mExpr = Code <$> getPosition <*> pMathExpr
pMathExpr :: P Expr
pMathExpr = buildExpressionParser mathExpressionTable
(pMathIdent <|> pMathLiteral)
where
pMathLiteral :: P Expr
pMathLiteral = Block . Content
<$> many1 (mLiteral <|> mEscaped <|> mShorthand)
pMathIdent :: P Expr
pMathIdent =
(Ident <$> pMathIdentifier)
<|> ( do
void $ char '√'
(Ident (Identifier "root") <$ lookAhead (char '('))
<|> ( do
x <- pMath
pure $
FuncCall
(Ident (Identifier "root"))
[NormalArg (Block (Content [x]))]
)
)
pMathIdentifier :: P Identifier
pMathIdentifier = lexeme $ try $ do
d <- satisfy (\c -> isIdentStart c && c /= '_')
ds <- many1 $ satisfy (\c -> isIdentContinue c && c /= '_' && c /= '-')
pure $ Identifier $ T.pack (d : ds)
pMath :: P Markup
pMath = buildExpressionParser mathOperatorTable pBaseMath
pBaseMath :: P Markup
pBaseMath = do
tok <- mNumber
<|> mLiteral
<|> mEscaped
<|> mShorthand
<|> mBreak
<|> mAlignPoint
<|> mExpr
<|> mGroup
<|> mCode
<|> mMid
<|> mSymbol
pos <- getPosition
updateState $ \s -> s{ stLastMathTok = Just (pos, tok) }
pure tok
mGroup :: P Markup
mGroup = mGrouped '(' ')' False
<|> mGrouped '{' '}' False
<|> mGrouped '[' ']' False
mGrouped :: Char -> Char -> Bool -> P Markup
mGrouped op' cl requireMatch = withNewlines $ try $ do
void $ sym [op']
res <- many (notFollowedBy (char cl) *> pMath)
(MGroup (Just (T.singleton op')) (Just (T.singleton cl)) res <$ void (sym [cl]))
<|> (MGroup (Just (T.singleton op')) Nothing res <$ guard (not requireMatch))
mNumber :: P Markup
mNumber = lexeme $ do
ds <- T.pack <$> many1 digit
opt <-
option
mempty
( do
e <- char '.'
es <- many digit
pure $ T.pack (e : es)
)
pure $ Text (ds <> opt)
mLiteral :: P Markup
mLiteral = do
mbBeforeSpace <- stSpaceBefore <$> getState
String t <- pStr
-- ensure space in e.g. x "is natural":
mbAfterSpace <- stSpaceBefore <$> getState
pure $
Text $
(maybe "" (const " ") mbBeforeSpace)
<> t
<> (maybe "" (const " ") mbAfterSpace)
mEscaped :: P Markup
mEscaped = Text . T.singleton <$> lexeme (try pEsc)
mBreak :: P Markup
mBreak = HardBreak <$ lexeme (char '\\' *> skipMany (satisfy (isSpace)))
-- we don't need to check for following whitespace, because
-- anything else would have been parsed by mEsc.
-- but we do skip following whitespace, since \160 wouldn't be gobbled by lexeme...
mAlignPoint :: P Markup
mAlignPoint = MAlignPoint <$ sym "&"
-- Math args can't have a content block; they can use semicolons
-- to separate array args.
mArgs :: P [Arg]
mArgs =
inParens $
many (mKeyValArg <|> mArrayArg <|> mNormArg <|> mMathArg)
where
sep = void (sym ",") <|> void (lookAhead (char ')'))
mNormArg = try $ NormalArg <$> (char '#' *> pExpr <* sep)
mKeyValArg = do
ident <- try $ pIdentifier <* sym ":"
KeyValArg ident
<$> ( (char '#' *> pExpr <* sep)
<|> Block . Content <$> mathContent
)
mathContent = do
xs <- maths
if null xs
then void $ sym ","
else sep
pure xs
mMathArg = BlockArg <$> mathContent
mArrayArg = try $ do
let pRow = sepBy' (toGroup <$> maths) (sym ",")
rows <- many1 $ try (pRow <* sym ";")
-- parse any regular items and form a last row
lastrow <- many (toGroup <$> mathContent)
let rows' =
if null lastrow
then rows
else rows ++ [lastrow]
pure $ ArrayArg rows'
maths = many (notFollowedBy (oneOf ",;)") *> notFollowedBy mKeyValArg *> pMath)
toGroup [m] = m
toGroup ms = MGroup Nothing Nothing ms
-- special sepBy' with an added try:
sepBy' p s = sepBy1' p s <|> pure []
sepBy1' p s = do
x <- p
xs <- many (try (s *> p))
pure (x : xs)
mCode :: P Markup
mCode = lexeme $ char '#' *> (Code <$> getPosition <*> pBasicExpr)
mMid :: P Markup
mMid = try $ do
getState >>= guard . isJust . stSpaceBefore
void $ char '|' *> space *> ws
pure $ MGroup Nothing Nothing [Nbsp, Text "|", Nbsp]
mShorthand :: P Markup
mShorthand =
getPosition >>= \pos ->
lexeme (Code pos <$> choice (map toShorthandParser shorthands))
where
shorthands = reverse (sortOn (T.length . fst) mathSymbolShorthands)
toShorthandParser (short, symname) =
toSym symname <$ try (string (T.unpack short))
toSym name =
case map (Ident . Identifier) $ T.split (== '.') name of
[] -> Literal None
[i] -> i
(i:is) -> foldr FieldAccess i is
mSymbol :: P Markup
mSymbol =
lexeme ( Text . T.singleton
<$> satisfy (\c -> not (isSpace c) && c /= '$' && c /= '\\'))
withIndent :: Int -> P a -> P a
withIndent indent pa = do
oldIndent <- stIndent <$> getState
updateState $ \st -> st {stIndent = indent : oldIndent}
ms <- pa
updateState $ \st -> st {stIndent = oldIndent}
pure ms
-- list ::= '-' space markup
-- enum ::= (digit+ '.' | '+') space markup
-- desc ::= '/' space markup ':' space markup
pListItem :: P Markup
pListItem = do
col <- sourceColumn <$> getPosition
startLine <- stLineStartCol <$> getState
guard (col == startLine)
try
( do
void $ char '-'
void (char ' ') <|> pBlankline
BulletListItem <$> withIndent col (many pMarkup)
)
<|> try
( do
start <- (Nothing <$ char '+') <|> (Just <$> enumListStart)
void (char ' ') <|> pBlankline
EnumListItem start <$> withIndent col (many pMarkup)
)
<|> try
( do
-- desc list
void (char '/')
void (many1 (char ' '))
term <- manyTill pMarkup (char ':')
skipMany spaceChar
optional pBlankline
DescListItem term <$> withIndent col (many pMarkup)
)
enumListStart :: P Int
enumListStart = do
ds <- many1 digit
void $ char '.'
case readMaybe ds of
Nothing -> fail $ "could not read " <> ds <> " as digits"
Just x -> pure x
-- line-comment = '//' (!unicode(Newline))*
-- block-comment = '/*' (. | block-comment)* '*/'
pComment :: P Markup
pComment = Comment <$ (pLineComment <|> pBlockComment)
pLineComment :: P ()
pLineComment = do
void $ string "//"
skipMany (satisfy (\c -> c /= '\n' && c /= '\r'))
void endOfLine <|> eof
pBlockComment :: P ()
pBlockComment = do
void $ string "/*"
void $
manyTill
( pBlockComment
<|> pLineComment
<|> void anyChar
)
(string "*/")
pSpace :: P Markup
pSpace = Space <$ some (satisfy (\c -> isSpace c && c /= '\r' && c /= '\n'))
pEol :: P Markup
pEol = do
pBaseEol
(ParBreak <$ many1 pBaseEol)
<|> (ParBreak <$ pEndOfContent)
<|> pure SoftBreak
pBaseEol :: P ()
pBaseEol = try $ do
void endOfLine
-- fail if we can't indent enough
indents <- stIndent <$> getState
case indents of
(i : _) -> void (try (count i (char ' '))) <|> pBlankline
[] -> pure ()
eatPrefixSpaces
eatPrefixSpaces :: P ()
eatPrefixSpaces = do
skipMany spaceChar
col <- sourceColumn <$> getPosition
updateState $ \st -> st {stLineStartCol = col}
spaceChar :: P Char
spaceChar = satisfy (\c -> c == ' ' || c == '\t')
pHardbreak :: P Markup
pHardbreak =
HardBreak <$ try (char '\\' *> (void spaceChar <|> pBaseEol) *> skipMany spaceChar)
pBlankline :: P ()
pBlankline = try $ do
skipMany spaceChar
void (lookAhead endOfLine) <|> pEndOfContent
pRawInline :: P Markup
pRawInline =
RawInline . T.pack
<$> (char '`' *> manyTill anyChar (void (char '`') <|> eof))
pRawBlock :: P Markup
pRawBlock = do
void $ string "```"
numticks <- (+ 3) . length <$> many (char '`')
lang <- T.pack <$> (many alphaNum <* optional (char ' '))
optional $ try $ skipMany (char ' ') *> pEol
let nl = newline <* optionalGobbleIndent
code <-
T.pack
<$> manyTill
(nl <|> anyChar)
(string (replicate numticks '`'))
skipMany (char '`')
pure $ RawBlock lang code
optionalGobbleIndent :: P ()
optionalGobbleIndent = do
indents <- stIndent <$> getState
case indents of
(i : _) -> gobble i
[] -> pure ()
where
gobble :: Int -> P ()
gobble 0 = pure ()
gobble n = (char ' ' *> gobble (n - 1)) <|> pure ()
pStrong :: P Markup
pStrong = Strong <$> (char '*' *> manyTill pMarkup (char '*'))
pEmph :: P Markup
pEmph = Emph <$> (char '_' *> manyTill pMarkup (char '_'))
pHeading :: P Markup
pHeading = try $ do
col <- sourceColumn <$> getPosition
lineStartCol <- stLineStartCol <$> getState
guard (col == lineStartCol)
lev <- length <$> many1 (char '=')
void (many1 (char ' ')) <|> void (lookAhead endOfLine)
-- Note: == hi _foo
-- bar_ is parsed as a heading with "hi emph(foobar)"
ms <- manyTill pMarkup ( void pEol
<|> pEndOfContent
<|> void (lookAhead (try (spaces *> pLabel)))
<|> void (lookAhead (char ']')))
skipMany spaceChar
pure $ Heading lev ms
pUrl :: P Markup
pUrl = try $ do
prot <- T.pack <$> (string "http://" <|> string "https://")
rest <- T.pack <$> pNonspaceWithBalancedBrackets 0 0 0
pure $ Url $ prot <> rest
pNonspaceWithBalancedBrackets :: Int -> Int -> Int -> P [Char]
pNonspaceWithBalancedBrackets parens brackets braces =
((:) <$> char '(' <*> pNonspaceWithBalancedBrackets (parens + 1) brackets braces)
<|> ((:) <$> (guard (parens > 0) *> char ')') <*> pNonspaceWithBalancedBrackets (parens - 1) brackets braces)
<|> ((:) <$> char '[' <*> pNonspaceWithBalancedBrackets parens (brackets + 1) braces)
<|> ((:) <$> (guard (brackets > 0) *> char ']') <*> pNonspaceWithBalancedBrackets parens (brackets - 1) braces)
<|> ((:) <$> char '{' <*> pNonspaceWithBalancedBrackets parens brackets (braces + 1))
<|> ((:) <$> (guard (braces > 0) *> char '}') *> pNonspaceWithBalancedBrackets parens brackets (braces - 1))
<|> (:) <$> noneOf " \t\r\n()[]{}" <*> pNonspaceWithBalancedBrackets parens brackets braces
<|> pure []
pText :: P Markup
pText = Text . mconcat <$> some
((do xs <- some alphaNum
T.pack . (xs <>) <$>
try (some (char '*' <|> char '_') <* lookAhead (satisfy nonCJKAlphaNum))
<|> pure (T.pack xs))
<|> (T.pack <$> some (satisfy (\c -> not (isSpace c || isSpecial c))))
)
nonCJKAlphaNum :: Char -> Bool
nonCJKAlphaNum c = isAlphaNum c && not (isCJK c)
isCJK :: Char -> Bool
isCJK c | c < '\x2e80' = False
isCJK c =
(c >= '\x2e80' && c <= '\x2eff') -- CJK Radicals Supplement
|| (c >= '\x2f00' && c <= '\x2fdf') -- Kangxi Radicals
|| (c >= '\x2ff0' && c <= '\x2fff') -- Ideographic Description Characters
|| (c >= '\x3000' && c <= '\x303f') -- JK Symbols and Punctuation
|| (c >= '\x3040' && c <= '\x309f') -- Hiragana
|| (c >= '\x30a0' && c <= '\x30ff') -- Katakana
|| (c >= '\x3100' && c <= '\x312f') -- Bopomofo
|| (c >= '\x3130' && c <= '\x318f') -- Kanbun
|| (c >= '\x3190' && c <= '\x319f') -- Kanbun
|| (c >= '\x31c0' && c <= '\x31ef') -- CJK Strokes
|| (c >= '\x31f0' && c <= '\x31ff') -- Katakana Phonetic Extensions
|| (c >= '\x3200' && c <= '\x32ff') -- Enclosed CJK Letters & Months
|| (c >= '\x3300' && c <= '\x33ff') -- CJK Compatibility
|| (c >= '\x3400' && c <= '\x4dbf') -- CJK Unified Ideographs Extension A
|| (c >= '\x4e00' && c <= '\x9fff') -- CJK Unified Ideographs
|| (c >= '\xa000' && c <= '\xa48f') -- Yi Syllables
|| (c >= '\xa490' && c <= '\xa4cf') -- Yi Radicals
|| (c >= '\xf900' && c <= '\xfaff') -- CJK Compatibility Ideographs
|| (c >= '\xfe10' && c <= '\xfe1f') -- Vertical forms
|| (c >= '\xfe30' && c <= '\xfe4f') -- CJK Compatibility Forms
|| (c >= '\xFE50' && c <= '\xFE6F') -- Small Form Variants
|| (c >= '\xFF00' && c <= '\xFFEE') -- Halfwidth and Fullwidth Forms
|| (c >= '\x1B000' && c <= '\x1B0FF') -- Kana Supplement
|| (c >= '\x1B100' && c <= '\x1B12F') -- Kana Extended-A
|| (c >= '\x1B130' && c <= '\x1B16F') -- Small Kana Extension
|| (c >= '\x20000' && c <= '\x2A6DF') -- CJK Unified Ideographs Extension B
|| (c >= '\x2A700' && c <= '\x2B73F') -- CJK Unified Ideographs Extension C
|| (c >= '\x2B740' && c <= '\x2B81F') -- CJK Unified Ideographs Extension D
|| (c >= '\x2B820' && c <= '\x2CEAF') -- CJK Unified Ideographs Extension E
|| (c >= '\x2CEB0' && c <= '\x2EBEF') -- CJK Unified Ideographs Extension F
|| (c >= '\x2F800' && c <= '\x2FA1F') -- CJK Compatibility Ideographs Supp
|| (c >= '\x30000' && c <= '\x3134F') -- CJK Unified Ideographs Exten
pEscaped :: P Markup
pEscaped = Text . T.singleton <$> pEsc
pEsc :: P Char
pEsc =
char '\\' *> (uniEsc <|> satisfy (not . isSpace))
pStrEsc :: P Char
pStrEsc =
try $
char '\\'
*> ( uniEsc
<|> ('\\' <$ char '\\')
<|> ('"' <$ char '"')
<|> ('\n' <$ char 'n')
<|> ('\t' <$ char 't')
<|> ('\r' <$ char 'r')
)
uniEsc :: P Char
uniEsc = chr <$> (char 'u' *> char '{' *> hexnum <* char '}')
where
hexnum :: P Int
hexnum = do
ds <- many1 hexDigit
case readMaybe ("0x" ++ ds) of
Just i
| i <= 1114112 -> pure i
| otherwise -> pure 0xFFFD
Nothing -> fail $ "Could not read hex number " ++ ds
pNbsp :: P Markup
pNbsp = Nbsp <$ char '~'
pDash :: P Markup
pDash = do
void $ char '-'
(Shy <$ char '?')
<|> (char '-' *> ((EmDash <$ char '-') <|> pure EnDash))
<|> pure (Text "-")
pEllipsis :: P Markup
pEllipsis = do
void $ char '.'
(Ellipsis <$ string "..") <|> pure (Text ".")
pQuote :: P Markup
pQuote = Quote <$> (char '\'' <|> char '"')
pLabelInContent :: P Markup
pLabelInContent = Code <$> getPosition <*> pLabel
pLabel :: P Expr
pLabel =
Label . T.pack
<$> lexeme (try
( char '<'
*> many1 (satisfy isIdentContinue <|>
char '_' <|> char '.' <|> char ':')
<* char '>'
))
pRef :: P Markup
pRef =
Ref
<$> (char '@' *> (T.pack <$> many1 (satisfy isIdentContinue <|> char '_')))
<*> option (Literal Auto) (Block <$> pContent)
-- "If a character would continue the expression but should be interpreted as
-- text, the expression can forcibly be ended with a semicolon (;)."
-- "A few kinds of expressions are not compatible with the hashtag syntax
-- (e.g. binary operator expressions). To embed these into markup, you
-- can use parentheses, as in #(1 + 2)." Hence pBasicExpr not pExpr.
pHash :: P Markup
pHash = do
void $ char '#'
res <- Code <$> getPosition <*> pBasicExpr <* optional (sym ";")
-- rewind if we gobbled space:
mbBeforeSpace <- stSpaceBefore <$> getState
case mbBeforeSpace of
Nothing -> pure ()
Just (pos, inp) -> do
setPosition pos
setInput inp
pure res
isSpecial :: Char -> Bool
isSpecial '\\' = True
isSpecial '[' = True
isSpecial ']' = True
isSpecial '#' = True
isSpecial '-' = True
isSpecial '.' = True
isSpecial '"' = True
isSpecial '\'' = True
isSpecial '*' = True
isSpecial '_' = True
isSpecial '`' = True
isSpecial '$' = True
isSpecial '<' = True
isSpecial '>' = True
isSpecial '@' = True
isSpecial '/' = True
isSpecial ':' = True
isSpecial '~' = True
isSpecial '=' = True
isSpecial '(' = True -- so we don't gobble ( before URLs
isSpecial _ = False
pIdentifier :: P Identifier
pIdentifier = lexeme $ try $ do
c <- satisfy isIdentStart
cs <- many $ satisfy isIdentContinue
pure $ Identifier $ T.pack (c : cs)
-- ident_start ::= unicode(XID_Start)
-- ID_Start characters are derived from the Unicode General_Category of
-- uppercase letters, lowercase letters, titlecase letters, modifier letters,
-- other letters, letter numbers, plus Other_ID_Start, minus Pattern_Syntax and
-- Pattern_White_Space code points.
isIdentStart :: Char -> Bool
isIdentStart c = c == '_' ||
case generalCategory c of
UppercaseLetter -> True
LowercaseLetter -> True
TitlecaseLetter -> True
ModifierLetter -> True
OtherLetter -> True
LetterNumber -> True
_ -> False
-- ident_continue ::= unicode(XID_Continue) | '-'
-- ID_Continue characters include ID_Start characters, plus characters having
-- the Unicode General_Category of nonspacing marks, spacing combining marks,
-- decimal number, connector punctuation, plus Other_ID_Continue, minus
-- Pattern_Syntax and Pattern_White_Space code points.
isIdentContinue :: Char -> Bool
isIdentContinue c =
isIdentStart c
|| c == '-'
|| c == '_'
|| case generalCategory c of
NonSpacingMark -> True
SpacingCombiningMark -> True
DecimalNumber -> True
ConnectorPunctuation -> True
_ -> False
pKeyword :: String -> P ()
pKeyword t = lexeme $ try $ string t *> notFollowedBy (satisfy isIdentContinue)
-- NOTE: there can be field access lookups that require identifiers like
-- 'not'.
-- keywords :: [Text]
-- keywords = ["none", "auto", "true", "false", "not", "and", "or", "let",
-- "set", "show", "wrap", "if", "else", "for", "in", "as", "while",
-- "break", "continue", "return", "import", "include", "from"]
pExpr :: P Expr
pExpr = buildExpressionParser operatorTable pBasicExpr
-- A basic expression excludes the unary and binary operators outside of parens,
-- but includes field access and function application. Needed for pHash.
pBasicExpr :: P Expr
pBasicExpr = buildExpressionParser basicOperatorTable pBaseExpr
pQualifiedIdentifier :: P Expr
pQualifiedIdentifier =
buildExpressionParser (replicate 4 [fieldAccess]) pIdent
pBaseExpr :: P Expr
pBaseExpr =
pLiteral
<|> pKeywordExpr
<|> pFuncExpr
<|> pIdent
<|> pArrayExpr
<|> pDictExpr
<|> inParens pExpr
<|> pLabel
<|> (Block . Content . (: [])
<$> lexeme (pRawBlock <|> pRawInline <|> pEquation))
<|> pBlock
pLiteral :: P Expr
pLiteral =
Literal <$> ( pNone <|> pAuto <|> pBoolean <|> pNumeric <|> pStr )
fieldAccess :: Operator Text PState Identity Expr
fieldAccess = Postfix (FieldAccess <$> try (sym "." *> pIdent))
-- don't allow space after .
restrictedFieldAccess :: Operator Text PState Identity Expr
restrictedFieldAccess = Postfix (FieldAccess <$> try (char '.' *> pIdent))
functionCall :: Operator Text PState Identity Expr
functionCall =
Postfix
( do
mbBeforeSpace <- stSpaceBefore <$> getState
-- NOTE: can't have space before () or [] arg in a
-- function call! to prevent bugs with e.g. 'if 2<3 [...]'.
guard $ isNothing mbBeforeSpace
args <- pArgs
pure $ \expr -> FuncCall expr args
)
-- The reason we cycle field access and function call
-- is that a postfix operator will not
-- be repeatable at the same precedence level...see docs for
-- buildExpressionParser.
basicOperatorTable :: [[Operator Text PState Identity Expr]]
basicOperatorTable =
take 16 (cycle [[restrictedFieldAccess], [functionCall]])
operatorTable :: [[Operator Text PState Identity Expr]]
operatorTable =
-- precedence 8 (real field access, perhaps with space after .)
take 12 (cycle [[fieldAccess], [functionCall]])
++
-- precedence 7 (repeated because of parsec's quirks with postfix, prefix)
replicate 6 [Postfix (ToPower <$> try (char 'e' *> notFollowedBy letter *> pExpr))]
++ replicate 6 [Prefix (Negated <$ op "-"), Prefix (id <$ op "+")]
++ [
-- precedence 6
[ Infix (Times <$ op "*") AssocLeft,
Infix (Divided <$ op "/") AssocLeft
],
-- precedence 5
[ Infix (Plus <$ op "+") AssocLeft,
Infix (Minus <$ op "-") AssocLeft
],
-- precedence 4
[ Infix (Equals <$ op "==") AssocLeft,
Infix ((\x y -> Not (Equals x y)) <$ op "!=") AssocLeft,
Infix (LessThan <$ op "<") AssocLeft,
Infix (LessThanOrEqual <$ op "<=") AssocLeft,
Infix (GreaterThan <$ op ">") AssocLeft,
Infix (GreaterThanOrEqual <$ op ">=") AssocLeft,
Infix (InCollection <$ pKeyword "in") AssocLeft,
Infix
( (\x y -> Not (InCollection x y))
<$ try (pKeyword "not" *> pKeyword "in")
)
AssocLeft
],
-- precedence 3
[ Prefix (Not <$ pKeyword "not"),
Infix (And <$ pKeyword "and") AssocLeft
],
-- precedence 2
[ Infix (Or <$ pKeyword "or") AssocLeft
],
-- precedence 1
[ Infix (Assign <$ op "=") AssocRight,
Infix ((\x y -> Assign x (Plus x y)) <$ op "+=") AssocRight,
Infix ((\x y -> Assign x (Minus x y)) <$ op "-=") AssocRight,
Infix ((\x y -> Assign x (Times x y)) <$ op "*=") AssocRight,
Infix ((\x y -> Assign x (Divided x y)) <$ op "/=") AssocRight
]
]
pNone :: P Literal
pNone = None <$ pKeyword "none"
pAuto :: P Literal
pAuto = Auto <$ pKeyword "auto"
pBoolean :: P Literal
pBoolean =
(Boolean True <$ pKeyword "true") <|> (Boolean False <$ pKeyword "false")
pNumber :: P (Either Integer Double)
pNumber = try $ do
pref <- string "0b" <|> string "0x" <|> string "0o" <|> pure ""
case pref of
"0b" -> do
nums <- many1 ((1 <$ char '1') <|> (0 <$ char '0'))
pure $ Left $ sum $ zipWith (*) (reverse nums) (map (2 ^) [(0 :: Integer) ..])
"0x" -> do
num <- many1 hexDigit
case readMaybe ("0x" ++ num) of
Just (i :: Integer) -> pure $ Left i
_ -> fail $ "could not read " <> num <> " as hex digits"
"0o" -> do
num <- many1 octDigit
case readMaybe ("0o" ++ num) of
Just (i :: Integer) -> pure $ Left i
_ -> fail $ "could not read " <> num <> " as octal digits"
_ -> do
as <- many1 digit <|> ("0" <$ lookAhead (try (char '.' *> digit)))
pe <- option [] $ string "."
bs <- many digit
es <-
option
""
( do
void $ try $ char 'e' *> lookAhead (digit <|> char '-')
minus <- option [] $ count 1 (char '-')
ds <- many1 digit
pure ("e" ++ minus ++ ds)
)
let num = pref ++ as ++ pe ++ bs ++ es
case readMaybe num of
Just (i :: Integer) -> pure $ Left i
Nothing ->
case readMaybe num of
Just (d :: Double) -> pure $ Right d
Nothing -> fail $ "could not read " <> num <> " as integer"
pNumeric :: P Literal
pNumeric = lexeme $ do
result <- pNumber
( do
unit <- pUnit
case result of
Left i -> pure $ Numeric (fromIntegral i) unit
Right d -> pure $ Numeric d unit
)
<|> case result of
Left i -> pure $ Int i
Right d -> pure $ Float d
pStr :: P Literal
pStr = lexeme $ do
void $ char '"'
String . T.pack <$> manyTill (pStrEsc <|> satisfy (/= '"')) (char '"')
pUnit :: P Unit
pUnit =
(Percent <$ sym "%")
<|> (Pt <$ pKeyword "pt")
<|> (Mm <$ pKeyword "mm")
<|> (Cm <$ pKeyword "cm")
<|> (In <$ pKeyword "in")
<|> (Deg <$ pKeyword "deg")
<|> (Rad <$ pKeyword "rad")
<|> (Em <$ pKeyword "em")
<|> (Fr <$ pKeyword "fr")
pIdent :: P Expr
pIdent = Ident <$> pIdentifier
pBlock :: P Expr
pBlock = Block <$> (pCodeBlock <|> pContent)
pCodeBlock :: P Block
pCodeBlock = CodeBlock <$> inBraces pCode
pCode :: P [Expr]
pCode = sepEndBy pExpr (void (sym ";") <|> ws)
-- content-block ::= '[' markup ']'
pContent :: P Block
pContent = do
void $ char '['
col <- sourceColumn <$> getPosition
oldLineStartCol <- stLineStartCol <$> getState
oldIndent <- stIndent <$> getState
updateState $ \st ->
st
{ stLineStartCol = col,
stContentBlockNesting =
stContentBlockNesting st + 1,
stIndent = []
}
ms <- manyTill pMarkup (char ']')
ws
updateState $ \st ->
st
{ stLineStartCol = oldLineStartCol,
stContentBlockNesting =
stContentBlockNesting st - 1,
stIndent = oldIndent
}
pure $ Content ms
pEndOfContent :: P ()
pEndOfContent =
eof <|> do
blockNesting <- stContentBlockNesting <$> getState
if blockNesting > 0
then void (lookAhead (char ']'))
else mzero
-- array-expr ::= '(' ((expr ',') | (expr (',' expr)+ ','?))? ')'
pArrayExpr :: P Expr
pArrayExpr =
try $
inParens $
( do
v <- pSpread <|> (Reg <$> pExpr)
vs <- many $ try $ sym "," *> (pSpread <|> (Reg <$> pExpr))
if null vs
then void $ sym ","
else optional $ void $ sym ","
pure $ Array (v : vs)
)
<|> (Array [] <$ optional (void $ sym ","))
-- dict-expr ::= '(' (':' | ':'? (pair (',' pair)* ','?)) ')'
-- pair ::= (ident | str) ':' expr
pDictExpr :: P Expr
pDictExpr = try $ inParens (sym ":" *> (pNonemptyDict <|> pure (Dict mempty)) <|> pNonemptyDict)
where
pNonemptyDict = Dict <$> sepEndBy1 (pSpread <|> pPair) (sym ",")
pPair = Reg <$> ((,) <$> pExpr <*> try (sym ":" *> pExpr))
pSpread :: P (Spreadable a)
pSpread = try $ string ".." *> (Spr <$> pExpr)
-- func-expr ::= (params | ident) '=>' expr
pFuncExpr :: P Expr
pFuncExpr = try $ FuncExpr <$> pParamsOrIdent <*> (sym "=>" *> pExpr)
where
pParamsOrIdent =
pParams
<|> (do i <- pIdentifier
if i == "_"
then pure [SkipParam]
else pure [NormalParam i])
pKeywordExpr :: P Expr
pKeywordExpr =
pLetExpr
<|> pSetExpr
<|> pShowExpr
<|> pIfExpr
<|> pWhileExpr
<|> pForExpr
<|> pImportExpr
<|> pIncludeExpr
<|> pBreakExpr
<|> pContinueExpr
<|> pReturnExpr
<|> pContextExpr
-- args ::= ('(' (arg (',' arg)* ','?)? ')' content-block*) | content-block+
pArgs :: P [Arg]
pArgs = do
void $ lookAhead (char '(' <|> char '[')
args <- option [] $ inParens $ sepEndBy pArg (sym ",")
blocks <- many $ do
-- make sure we haven't had a space
skippedSpaces <- isJust . stSpaceBefore <$> getState
if skippedSpaces
then mzero
else do
Content ms <- pContent
pure ms
pure $ args ++ map BlockArg blocks
-- arg ::= (ident ':')? expr
pArg :: P Arg
pArg = pKeyValArg <|> pSpreadArg <|> pNormalArg
where
pKeyValArg = KeyValArg <$> try (pIdentifier <* sym ":") <*> pExpr
pNormalArg = NormalArg <$> pExpr
pSpreadArg = SpreadArg <$> try (string ".." *> pExpr)
-- params ::= '(' (param (',' param)* ','?)? ')'
pParams :: P [Param]
pParams = inParens $ sepEndBy pParam (sym ",")
-- param ::= ident (':' expr)?
pParam :: P Param
pParam =
pSinkParam <|> pDestructuringParam <|> pNormalOrDefaultParam <|> pSkipParam
where
pSinkParam =
SinkParam
<$> try
( sym ".."
*> option Nothing (Just <$> pIdentifier)
)
pSkipParam = SkipParam <$ sym "_"
pNormalOrDefaultParam = do
i <- pIdentifier
(DefaultParam i <$> (sym ":" *> pExpr)) <|> pure (NormalParam i)
pDestructuringParam = do
DestructuringBind parts <- pDestructuringBind
pure $ DestructuringParam parts
pBind :: P Bind
pBind = pBasicBind <|> pDestructuringBind
pBasicBind :: P Bind
pBasicBind = BasicBind <$> try (pBindIdentifier <|> inParens pBindIdentifier)
pBindIdentifier :: P (Maybe Identifier)
pBindIdentifier = do
ident <- pIdentifier
if ident == "_"
then pure Nothing
else pure $ Just ident
pDestructuringBind :: P Bind
pDestructuringBind =
inParens $
DestructuringBind <$> (pBindPart `sepEndBy` (sym ","))
where
pBindPart = do
sink <- option False $ True <$ string ".."
if sink
then do
ident <- option Nothing pBindIdentifier -- ..
pure $ Sink ident
else do
ident <- pBindIdentifier
case ident of
Nothing -> pure (Simple ident)
Just key ->
(WithKey key <$> (sym ":" *> pBindIdentifier))
<|> pure (Simple ident)
-- let-expr ::= 'let' ident params? '=' expr
pLetExpr :: P Expr
pLetExpr = do
pKeyword "let"
bind <- pBind
case bind of
BasicBind mbname -> do
mbparams <- option Nothing $ Just <$> pParams
mbexpr <- option Nothing $ Just <$> (sym "=" *> pExpr)
case (mbparams, mbexpr, mbname) of
(Nothing, Nothing, _) -> pure $ Let bind (Literal None)
(Nothing, Just expr, _) -> pure $ Let bind expr
(Just params, Just expr, Just name) -> pure $ LetFunc name params expr
(Just _, Just _, Nothing) -> fail "expected name for function"
(Just _, Nothing, _) -> fail "expected expression for let binding"
_ -> Let bind <$> (sym "=" *> pExpr)
-- set-expr ::= 'set' expr args
pSetExpr :: P Expr
pSetExpr = do
oldAllowNewlines <- stAllowNewlines <$> getState
-- see #23 -- 'set' doesn't go with 'if' unless it's on the same line
updateState $ \st -> st {stAllowNewlines = 0}
set <- pKeyword "set" *> (Set <$> pQualifiedIdentifier <*> pArgs)
updateState $ \st -> st {stAllowNewlines = oldAllowNewlines}
addCondition <- option id $ pKeyword "if" *> ((\c x -> If [(c, x)]) <$> pExpr)
pure $ addCondition set
pShowExpr :: P Expr
pShowExpr = do
pKeyword "show"
from <- (Nothing <$ sym ":") <|> Just <$> (pBasicExpr <* sym ":")
to <- pBasicExpr
pure $ Show from to
-- if-expr ::= 'if' expr block ('else' 'if' expr block)* ('else' block)?
pIfExpr :: P Expr
pIfExpr = do
a <- pIf
as <- many $ try (pKeyword "else" *> pIf)
finalElse <-
option [] $
-- we represent the final "else" as a conditional with expr True:
(: []) . (Literal (Boolean True),) <$> (pKeyword "else" *> pBlock)
return $ If (a : as ++ finalElse)
where
pIf = pKeyword "if" *> ((,) <$> pExpr <*> pBlock)
-- while-expr ::= 'while' expr block
pWhileExpr :: P Expr
pWhileExpr = pKeyword "while" *> (While <$> pExpr <*> pBlock)
-- for-expr ::= 'for' bind 'in' expr block
pForExpr :: P Expr
pForExpr =
pKeyword "for" *> (For <$> pBind <*> (pKeyword "in" *> pExpr) <*> pBlock)
pImportExpr :: P Expr
pImportExpr = pKeyword "import" *> (Import <$> pExpr <*> pImportItems)
where
pImportItems =
(sym ":"
*> ( (AllIdentifiers <$ sym "*")
<|> inParens pIdentifierList
<|> pIdentifierList
)
) <|> (NoIdentifiers <$> pAs)
pIdentifierList = SomeIdentifiers <$> sepEndBy pIdentifierAs (sym ",")
pIdentifierAs = do
ident <- pIdentifier
mbAs <- pAs
pure (ident, mbAs)
pAs = option Nothing $ Just <$> (pKeyword "as" *> pIdentifier)
pBreakExpr :: P Expr
pBreakExpr = Break <$ pKeyword "break"
pContinueExpr :: P Expr
pContinueExpr = Continue <$ pKeyword "continue"
pReturnExpr :: P Expr
pReturnExpr = do
pos <- getPosition
pKeyword "return"
pos' <- getPosition
if sourceLine pos' > sourceLine pos
then pure $ Return Nothing
else Return <$> (option Nothing (Just <$> pExpr))
pContextExpr :: P Expr
pContextExpr = Context <$> (pKeyword "context" *> pExpr)
pIncludeExpr :: P Expr
pIncludeExpr = Include <$> (pKeyword "include" *> pExpr)