From d695910c7cd9b34a61efb55a9927cec485a9c92b Mon Sep 17 00:00:00 2001 From: Pagwin Date: Fri, 4 Sep 2026 15:15:33 -0400 Subject: [PATCH] implement the djot parser Fills out src/Djot.hs, which was a skeleton of `error "todo"` stubs. Three layers, so container prefixes and indentation never have to be threaded through the parser state: - line primitives (rawLine/peekLine/lineWhen/dedent): block parsers peek at the next line, decide whether they want it, then consume it - container blocks strip their prefix off the lines they own and re-parse the result with subParse, a rank-2 helper that runs a polymorphic parser at Identity and shifts error offsets back into the outer input - inline content is a second pass over the text a block collected Blocks: headings, paragraphs, block quotes, fenced code, raw blocks, divs, tables (alignments, `^` captions, escaped pipes), footnote and reference definitions, block attributes, thematic breaks, and lists -- bullet, ordered (decimal/alpha/roman, `.`/`)`/`(n)`), task, and definition. Tight lists unwrap their paragraphs to Transparent. Inlines: emphasis and its braced forms, verbatim, raw inline, math, links, reference links, images, autolinks, spans, footnote references, symbols, escapes, hard breaks, attribute sets, and smart punctuation. Two spots where the IR came up short: - there is no reference image, so for `![alt][ref]` the label lands in the url field - unordered lists get style = Nothing rather than the bullet character, which HTML.hs would otherwise emit as an invalid type="-" Also includes the psb.cabal fix dropping OverloadedRecordUpdate, without which Psb.Main does not build. Co-Authored-By: Claude Opus 5 --- psb.cabal | 2 +- src/Djot.hs | 1412 +++++++++++++++++++++++++++++++++++++-------------- 2 files changed, 1018 insertions(+), 396 deletions(-) diff --git a/psb.cabal b/psb.cabal index 719eb8d..ed96c30 100644 --- a/psb.cabal +++ b/psb.cabal @@ -30,7 +30,7 @@ library exposed-modules: Djot Markdown HTML Logger IR Logger.Shake Psb.Main Utilities Utilities.FilePath Utilities.Action Utilities.Javascript Utilities.CSS Templates Types Config Utilities.Bundling other-modules: Utilities.Parsing build-depends: base, mustache >=2.4.2, shake >= 0.19.8, deriving-aeson >= 0.2.9, aeson, text >= 2.1.2, time, unordered-containers, yaml, megaparsec >= 9.7.0, transformers >= 0.6.2, bytestring - default-extensions: ApplicativeDo DataKinds NamedFieldPuns DerivingVia LambdaCase TypeApplications DeriveGeneric OverloadedRecordDot OverloadedRecordUpdate NamedFieldPuns DuplicateRecordFields DisambiguateRecordFields FlexibleInstances + default-extensions: ApplicativeDo DataKinds NamedFieldPuns DerivingVia LambdaCase TypeApplications DeriveGeneric OverloadedRecordDot NamedFieldPuns DuplicateRecordFields DisambiguateRecordFields FlexibleInstances test-suite test-markdown-parse hs-source-dirs: tests diff --git a/src/Djot.hs b/src/Djot.hs index df0a307..a7847be 100644 --- a/src/Djot.hs +++ b/src/Djot.hs @@ -4,6 +4,22 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +-- | A parser for . +-- +-- The general shape of this module is: +-- +-- * block level parsing is line oriented, every block parser peeks at the +-- next line (via 'peekLine'), decides whether it wants it and then +-- consumes it with 'rawLine' +-- * container blocks (block quotes, divs, list items, footnotes, ...) strip +-- their prefix\/indentation off of the lines they own and then re-parse the +-- resulting text with 'subParse' +-- * inline parsing happens in a second pass over the text a block collected, +-- also via 'subParse' +-- +-- Doing it this way means indentation and container prefixes never have to be +-- threaded through the parser state, at the cost of the offsets in error +-- messages coming from nested content being approximate. module Djot ( document, metadata, @@ -11,444 +27,1050 @@ module Djot where import Control.Applicative (many, optional, some, (<|>)) -import Control.Monad (guard) -import Data.Foldable (for_) -import Data.Functor (void, (<$>)) -import Data.List (elemIndex) +import Control.Monad (guard, void) +import Data.Char (isAlphaNum, isDigit, isLower, isSpace, isUpper, toLower, toUpper) +import Data.Maybe (fromMaybe, isJust, mapMaybe) import qualified Data.List.NonEmpty as NE import Data.Text (Text) import qualified Data.Text as T import IR -import Logger (Logger (logCallStack, logDebug, logError)) -import Text.Megaparsec (MonadParsec (lookAhead, notFollowedBy, parseError, try), ParseErrorBundle (ParseErrorBundle, bundleErrors), SourcePos (sourceColumn), anySingle, choice, errorOffset, getInput, getOffset, manyTill, oneOf, parse, satisfy, sepBy, setErrorOffset, someTill) -import Text.Megaparsec.Char (char, digitChar, lowerChar, newline, numberChar, space, spaceChar, string, tab, upperChar) +import Logger (Logger (logError)) +import Text.Megaparsec (MonadParsec (lookAhead, notFollowedBy, parseError, try), ParseErrorBundle (ParseErrorBundle), anySingle, choice, count, eof, errorOffset, getOffset, manyTill, oneOf, parse, satisfy, setErrorOffset) +import Text.Megaparsec.Char (char, newline, string) import Utilities.Parsing -(.>) :: (a -> b) -> (b -> c) -> a -> c -(.>) = flip (.) +-------------------------------------------------------------------------------- +-- entry points +-------------------------------------------------------------------------------- +-- | Djot has no metadata syntax of its own, so (like the markdown parser) an +-- optional yaml frontmatter block delimited by @---@ is accepted. metadata :: (Logger m, Characters s) => Parser s m Text -metadata = T.pack <$> many (notFollowedBy (string "---") *> anySingle) +metadata = fromMaybe "" <$> optional (try frontmatter) + where + frontmatter = do + void $ many (char ' ') + void $ string "---" + void $ many (char ' ') + void newline + ls <- many (try metaLine) + -- without a closing fence this isn't frontmatter at all, most likely it + -- is a thematic break, so the whole thing backtracks + closing + pure $ T.unlines ls + metaLine = do + l <- peekLine + guard $ T.strip l /= "---" + rawLine + closing = do + l <- rawLine + guard $ T.strip l == "---" document :: (Logger m, Characters s) => Parser s m Document -document = Doc <$> blockElement mempty `sepBy` blockSeparator +document = Doc <$> blocks -blockElement :: (Logger m, Characters s) => Attrs -> Parser s m Element --- skip is for blockQuote to allow -blockElement accumulated_attributes = - choice - [ lookAhead (char '#') *> header accumulated_attributes, - lookAhead (char '>') *> blockQuote accumulated_attributes, - try $ taskListBlock accumulated_attributes, - try $ listBlock accumulated_attributes, - lookAhead codeFence - *> (lookAhead (codeFence *> rawLang) *> rawBlock accumulated_attributes) - <|> codeBlock accumulated_attributes, - -- Why lookAhead when checking is fully equivalent to parsing - try $ thematicBreak accumulated_attributes, - lookAhead (string ":::") *> containerBlock accumulated_attributes, - -- try used due to table having a non-trivial structure at the start - try $ tableBlock accumulated_attributes, - -- using try due to ambiguity between these and normal text until we've already done some amount of parsing - try $ footnoteDefinition accumulated_attributes, - try $ referenceDef accumulated_attributes, - lookAhead (char '{') *> blockAttribute accumulated_attributes, - paragraph accumulated_attributes - ] - where - rawLang = space *> char '=' *> some (notFollowedBy newline *> anySingle) +-------------------------------------------------------------------------------- +-- line primitives +-------------------------------------------------------------------------------- -header :: (Logger m, Characters s) => Attrs -> Parser s m Element -header attrs = do - level <- length <$> some (char '#') - space - startOffset <- getOffset - raw <- manyTill anySingle $ lookAhead blockSeparator - -- second pass for inline elements - case parse (header' level) "" (fromText $ toText raw) of - Right ret -> pure ret - Left (ParseErrorBundle errs _) -> - let remap err = setErrorOffset (errorOffset err + startOffset) err in parseError $ remap $ NE.head errs - where - header' level = do - text <- inlineContent - pure $ Heading (H {level, text}) attrs +-- | Consume a single line, returning it without its line ending. Fails at end +-- of input, which is what keeps the various @many rawLine@ loops terminating. +rawLine :: (Logger m, Characters s) => Parser s m Text +rawLine = do + notFollowedBy eof + cs <- many (satisfy (/= '\n')) + void (optional newline) + pure $ T.pack cs -blockQuote :: (Logger m, Characters s) => Attrs -> Parser s m Element -blockQuote attrs = do - startOffset <- getOffset - first_line <- bq_line - lines <- manyTill (newline *> bq_line) $ lookAhead blockSeparator - let lines' = map toText $ first_line : lines - case parse blockQuote' "" (fromText $ T.intercalate "\n" lines') of +-- | 'rawLine' without consuming it. +peekLine :: (Logger m, Characters s) => Parser s m Text +peekLine = lookAhead rawLine + +-- | Consume the next line only if it satisfies the predicate. +lineWhen :: (Logger m, Characters s) => (Text -> Bool) -> Parser s m Text +lineWhen predicate = try do + l <- peekLine + guard $ predicate l + rawLine + +blankLine :: (Logger m, Characters s) => Parser s m Text +blankLine = lineWhen isBlank + +skipBlanks :: (Logger m, Characters s) => Parser s m () +skipBlanks = void $ many blankLine + +isBlank :: Text -> Bool +isBlank = T.all isSpace + +indentOf :: Text -> Int +indentOf = T.length . T.takeWhile isIndentChar + +isIndentChar :: Char -> Bool +isIndentChar c = c == ' ' || c == '\t' + +-- | Remove up to @n@ characters of leading indentation. +dedent :: Int -> Text -> Text +dedent n t = + let (ws, rest) = T.span isIndentChar t + in T.drop n ws <> rest + +-- | Remove the indentation shared by every non blank line. +stripCommonIndent :: [Text] -> [Text] +stripCommonIndent ls = case map indentOf (filter (not . isBlank) ls) of + [] -> ls + indents -> map (dedent (minimum indents)) ls + +-------------------------------------------------------------------------------- +-- running a parser over extracted text +-------------------------------------------------------------------------------- + +-- | Run a parser over a chunk of text that was pulled out of the input (the +-- contents of a container block, the inline content of a paragraph, ...). +-- +-- The offset of a failure inside the nested content is shifted by +-- @startOffset@; that is only correct when the nested text is a verbatim slice +-- of the outer input, so for containers whose prefixes were stripped the +-- reported position is merely in the right neighbourhood. +subParse :: + forall s m a. + (Logger m, Characters s) => + Int -> + (forall m'. (Logger m') => Parser s m' a) -> + Text -> + Parser s m a +subParse startOffset p input = + case parse (p <* eof) "" (fromText input :: s) of Right ret -> pure ret Left (ParseErrorBundle errs _) -> do - logError "Error in blockQuote offset may be off" - let remap err = setErrorOffset (errorOffset err + startOffset) err - parseError $ remap $ NE.head errs + logError "Djot: failure while parsing nested content, reported offset may be off" + let err = NE.head errs + parseError $ setErrorOffset (errorOffset err + startOffset) err + +-------------------------------------------------------------------------------- +-- blocks +-------------------------------------------------------------------------------- + +blocks :: (Logger m, Characters s) => Parser s m [Element] +blocks = skipBlanks *> many (blockElement mempty <* skipBlanks) + +blockElement :: (Logger m, Characters s) => Attrs -> Parser s m Element +blockElement attrs = + choice + [ try $ blockAttribute attrs, + try $ thematicBreak attrs, + try $ heading attrs, + try $ blockQuote attrs, + try $ fencedBlock attrs, + try $ divBlock attrs, + try $ tableBlock attrs, + try $ footnoteDefinition attrs, + try $ referenceDef attrs, + try $ listBlock attrs, + paragraph attrs + ] + +-- | Does this line begin a block other than a paragraph? Used to decide where +-- lazily continued content (paragraphs, block quotes, headings) stops. +startsBlock :: Text -> Bool +startsBlock l = + isThematicBreak l + || isHeadingLine l + || T.isPrefixOf ">" s + || isFenceLine l + || T.isPrefixOf ":::" s + || T.isPrefixOf "|" s + || isJust (markerOf l) + || T.isPrefixOf "{" s + || isDefinitionLine l where - blockQuote' = do - -- using document for convenience - (Doc contents) <- document - pure $ BlockQuote (Q contents) attrs - bq_line = do - char '>' - space - manyTill anySingle $ lookAhead newline + s = T.stripStart l -newtype ListTypeEq = LTE ListType +-- | @[label]:@ and @[^label]:@ style definitions. +isDefinitionLine :: Text -> Bool +isDefinitionLine l = case T.uncons (T.stripStart l) of + Just ('[', rest) -> case T.breakOn "]:" rest of + (label, remainder) -> not (T.null remainder) && not (T.any (== '[') label) + _ -> False -instance Eq ListTypeEq where - (LTE (Ordered {style = s1})) == (LTE (Ordered {style = s2})) = s1 == s2 - (LTE (Unordered {style = s1})) == (LTE (Unordered {style = s2})) = s1 == s2 - _ == _ = False - -listBlock :: (Logger m, Characters s) => Attrs -> Parser s m Element -listBlock attrs = do - (list_type, item) <- listItem - remaining_items <- many $ listItem' list_type - pure $ List (L {list_type, items = item : remaining_items}) attrs - where - listItem = do - list_type <- listMarker - first_line <- listLine $ pure () - content <- some $ listLine $ notFollowedBy $ listMarker' list_type - error "todo" - -- any listMarker - -- can probably just use listMarker' via choice or smth like that - listMarker = do - indent <- length <$> many (notFollowedBy newline *> spaceChar) - (lt, markerLen) <- choice [unorderedMarker, orderedMarker] - void (char ' ') <|> lookAhead (void newline) - pure (lt, indent + markerLen + 1) - -- listItem which must be of list_type - listItem' list_type = do - listMarker' list_type - first_line <- listLine $ pure () - content <- some $ listLine $ notFollowedBy $ listMarker' list_type - - error "todo" - unorderedMarker = do - c <- oneOf ['-', '+', '*'] - pure (Unordered {style = Just (T.singleton c)}, 1) - - orderedMarker = - choice - [ parenEnclosed, - periodOrParen - ] - - parenEnclosed = do - void $ char '(' - (content, lt) <- orderedContent - void $ char ')' - let markerLen = T.length content + 2 -- ( + content + ) - pure (lt, markerLen) - - periodOrParen = do - (content, baseType) <- orderedContent - suffix <- oneOf ['.', ')'] - let markerLen = T.length content + 1 - style = orderedStyle baseType - lt = - Ordered - { start_number = orderedStart baseType content, - style = style - } - pure (lt, markerLen) - orderedStart _ (DecimalContent d) = Just (read d) - orderedStart _ _ = Nothing -- roman/alpha start not tracked numerically - orderedStyle DecimalContent {} = Nothing -- default, omit attribute - orderedStyle UpperRomanContent {} = Just "I" - orderedStyle LowerRomanContent {} = Just "i" - orderedStyle UpperAlphaContent {} = Just "A" - orderedStyle LowerAlphaContent {} = Just "a" - orderedStyle UpperRomanMulti {} = Just "I" - orderedStyle LowerRomanMulti {} = Just "i" - orderedStyle UpperAlphaMulti {} = Just "A" - orderedStyle LowerAlphaMulti {} = Just "a" - ol_digit_handle = do - digits <- some digitChar - pure (T.pack digits, DecimalContent digits) - isRomanUpper c = c `elem` ("IVXLCDM" :: String) - isRomanLower c = c `elem` ("ivxlcdm" :: String) - ol_upper_handle = do - c <- upperChar - let t = T.singleton c - if isRomanUpper c - then pure (t, UpperRomanContent c) - else pure (t, UpperAlphaContent c) - orderedContent = do - choice - [ ol_digit_handle, - ol_upper_handle, - do - c <- lowerChar - let t = T.singleton c - if isRomanLower c - then pure (t, LowerRomanContent c) -- assume roman for ambiguous - else pure (t, LowerAlphaContent c), - do - -- multi-char lower: roman or alpha (xix, viii, etc.) - cs <- some lowerChar - let t = T.pack cs - if all isRomanLower cs - then pure (t, LowerRomanMulti cs) - else pure (t, LowerAlphaMulti cs) - ] - -- listMarker which must be of list_type - listMarker' expected = do - indent <- length <$> many (many (notFollowedBy newline *> spaceChar)) - (lt, markerLen) <- case expected of - Unordered {style} -> do - (lt, ml) <- unorderedMarker - guard $ matchesUnordered style lt - pure (lt, ml) - Ordered {style} -> do - (lt, ml) <- orderedMarker - guard $ matchesOrdered style lt - pure (lt, ml) - void (char ' ') <|> lookAhead (void newline) - pure (lt, indent + markerLen + 1) - -- list line which must parse check before the rest of the line - listLine check = do - check - manyTill anySingle newline - -data OrderedContent - = DecimalContent String - | UpperRomanContent Char - | LowerRomanContent Char - | UpperAlphaContent Char - | LowerAlphaContent Char - | UpperRomanMulti String - | LowerRomanMulti String - | UpperAlphaMulti String - | LowerAlphaMulti String - -taskListBlock :: (Logger m, Characters s) => Attrs -> Parser s m Element -taskListBlock attrs = do - error "todo" - -descriptionListBlock :: (Logger m, Characters s) => Attrs -> Parser s m Element -descriptionListBlock attrs = do - error "todo" - -codeFence :: (Logger m, Characters s) => Parser s m () -codeFence = void $ string "```" - -codeBlock :: (Logger m, Characters s) => Attrs -> Parser s m Element -codeBlock attrs = do - codeFence - space - language' <- manyTill anySingle newline - let language = - if null language' - then - Nothing - else - Just $ toText language' - code <- toText <$> manyTill anySingle codeFence - pure $ Code (C {language, code}) attrs +-------------------------------------------------------------------------------- +-- attributes +-------------------------------------------------------------------------------- +-- | A @{...}@ block on a line of its own attaches its attributes to the +-- following block. blockAttribute :: (Logger m, Characters s) => Attrs -> Parser s m Element blockAttribute attrs = do - current <- blockAttribute' + current <- attributeLine let attrs' = attrs <> current - blockElement attrs' <|> error "eof handle" - -blockAttribute' :: (Logger m, Characters s) => Parser s m Attrs -blockAttribute' = do - startOffset <- getOffset - input <- fromText . toText <$> getInput - char '{' - contents <- manyTill anySingle $ char '}' - case parse blockAttribute'' input $ fromText $ toText contents of - Right ret -> pure ret - Left (ParseErrorBundle errs _) -> - let remap err = setErrorOffset (errorOffset err + startOffset) err in parseError $ remap $ NE.head errs + blockElement attrs' <|> pure (Transparent []) where - blockAttribute'' = error "todo" + attributeLine = try do + void $ many (char ' ') + a <- attributeSet + void $ many (char ' ') + void newline <|> eof + pure a -blockSeparator :: (Logger m, Characters s) => Parser s m () -blockSeparator = void $ newline *> newline +-- | @{#id .class key=value %comment%}@, may span several lines. +attributeSet :: (Logger m, Characters s) => Parser s m Attrs +attributeSet = do + void $ char '{' + as <- many (try (attrSpace *> attrItem)) + attrSpace + void $ char '}' + pure $ mconcat as + where + attrSpace = void $ many (satisfy isSpace) -referenceDef :: (Logger m, Characters s) => Attrs -> Parser s m Element -referenceDef attrs = do - char '[' - label <- toText <$> manyTill anySingle (char ']') - char ':' - link <- toText <$> manyTill anySingle (lookAhead blockSeparator) - pure $ ReferenceDefinition $ RD {label, link} +attrItem :: (Logger m, Characters s) => Parser s m Attrs +attrItem = + choice + [ comment, + identifier, + klass, + keyValue + ] + where + comment = do + void $ char '%' + void $ manyTill anySingle (char '%') + pure mempty + identifier = do + void $ char '#' + name <- bareText + pure $ Attrs {attrId = Just name, attrClasses = [], attrKV = []} + klass = do + void $ char '.' + name <- bareText + pure $ Attrs {attrId = Nothing, attrClasses = [name], attrKV = []} + keyValue = do + key <- T.pack <$> some (satisfy isKeyChar) + void $ char '=' + value <- quoted <|> bareText + pure $ Attrs {attrId = Nothing, attrClasses = [], attrKV = [(key, value)]} + isKeyChar c = isAlphaNum c || c `elem` ("_-:" :: String) + bareText = T.pack <$> some (satisfy (\c -> not (isSpace c) && c `notElem` ("}{\"=" :: String))) + quoted = do + void $ char '"' + cs <- many (escaped <|> satisfy (/= '"')) + void $ char '"' + pure $ T.pack cs + escaped = char '\\' *> anySingle -rawBlock :: (Logger m, Characters s) => Attrs -> Parser s m Element -rawBlock attrs = do - Code (C {language = Just format', code = content}) _ <- codeBlock mempty - let format = T.drop 1 format' - pure $ RawBlock (RB {format, content}) attrs +-------------------------------------------------------------------------------- +-- leaf blocks +-------------------------------------------------------------------------------- + +isThematicBreak :: Text -> Bool +isThematicBreak l = + let cs = T.unpack $ T.filter (not . isSpace) l + in length cs >= 3 && (all (== '*') cs || all (== '-') cs) thematicBreak :: (Logger m, Characters s) => Attrs -> Parser s m Element thematicBreak attrs = do - -- even if there's a more concise way to write this - -- that way would probably be less readable - -- \s*[*\-]\s*[*\-]\s*[*\-]\s*([*\-]\s*)* - -- is more comprehensible than - -- (\s*[*\-]){3}\s*([*\-]\s*)* - -- and only mildlylonger - space - part - space - part - space - part - space - many (part *> space) + void $ lineWhen isThematicBreak pure $ HorizontalRule attrs + +isHeadingLine :: Text -> Bool +isHeadingLine l = + let s = T.stripStart l + (hashes, rest) = T.span (== '#') s + in not (T.null hashes) && (T.null rest || isIndentChar (T.head rest)) + +heading :: (Logger m, Characters s) => Attrs -> Parser s m Element +heading attrs = do + offset <- getOffset + first <- lineWhen isHeadingLine + let (hashes, firstText) = T.span (== '#') (T.stripStart first) + level = min 6 (T.length hashes) + rest <- many continuation + text <- subParse offset inlines $ T.intercalate "\n" $ map T.strip (firstText : rest) + pure $ Heading (H {level, text}) attrs where - part = choice $ map char "*-" - -containerBlock :: (Logger m, Characters s) => Attrs -> Parser s m Element -containerBlock = containerBlock' 0 - -containerBlock' :: (Logger m, Characters s) => Int -> Attrs -> Parser s m Element -containerBlock' n attrs = do - startOffset <- getOffset - input <- fromText . toText <$> getInput - let fence = string ":::" - fence - space - div_class <- someTill anySingle newline - contents <- manyTill anySingle (newline *> fence) - case parse containerBlock'' input $ fromText $ toText contents of - Right ret -> pure ret - Left (ParseErrorBundle errs _) -> - let remap err = setErrorOffset (errorOffset err + startOffset) err in parseError $ remap $ NE.head errs - where - containerBlock'' = error "todo" - -tableBlock :: (Logger m, Characters s) => Attrs -> Parser s m Element -tableBlock attrs = do - prefix <- tablePrefix - rem_rows <- manyTill tableRow $ lookAhead blockSeparator - case prefix of - Just (header, separator) -> pure $ Table (T {tableCaption = Nothing, tableHead = Just header, tableBody = rem_rows, columnAlignments = Just separator}) attrs - Nothing -> pure $ Table (T {tableCaption = Nothing, columnAlignments = Nothing, tableHead = Nothing, tableBody = rem_rows}) attrs - where - tableSeparatorRow = error "todo" :: Parser s m [Alignment] - -tablePrefix :: (Logger m, Characters s) => Parser s m (Maybe (TableRow, [Alignment])) -tablePrefix = error "todo" - -tableRow :: (Logger m, Characters s) => Parser s m TableRow -tableRow = do - char '|' - cells <- tableCell `sepBy` char '|' - char '|' - pure $ TR cells - where - tableCell = error "todo" - -footnoteDefinition :: (Logger m, Characters s) => Attrs -> Parser s m Element -footnoteDefinition attrs = do - string "[^" - label <- toText <$> manyTill anySingle (char ']') - char ':' - first_line <- footnoteElement' - rem_lines <- many footnoteElement - pure $ Footnote (F {label, content = first_line : rem_lines}) attrs - where - footnoteElement' = error "todo" - footnoteElement = tab *> footnoteElement' + -- continuation lines may repeat the `#` prefix or omit it entirely + continuation = lineWhen (\l -> not (isBlank l) && (isHeadingLine l || not (startsBlock l))) >>= pure . stripHashes + stripHashes l = let s = T.stripStart l in if isHeadingLine l then T.dropWhile (== '#') s else s paragraph :: (Logger m, Characters s) => Attrs -> Parser s m Element paragraph attrs = do - content <- inlineContent + offset <- getOffset + first <- lineWhen (not . isBlank) + rest <- many $ lineWhen (\l -> not (isBlank l) && not (startsBlock l)) + content <- subParse offset inlines $ T.intercalate "\n" (first : rest) pure $ Paragraph (P content) attrs -data OpenInline = SquareBracket | CurlyBracket | Paren | Underscore | Asterisk | Backtick Int | Insert | Delete | Highlight | Superscript | Subscript | AngleBracket deriving (Show) +-------------------------------------------------------------------------------- +-- block quotes +-------------------------------------------------------------------------------- -closingInline :: (Logger m, Characters s) => [OpenInline] -> Parser s m OpenInline -closingInline = error "todo" +blockQuote :: (Logger m, Characters s) => Attrs -> Parser s m Element +blockQuote attrs = do + offset <- getOffset + first <- quotedLine + rest <- many (quotedLine <|> lazyLine) + contents <- subParse offset blocks $ T.unlines (first : rest) + pure $ BlockQuote (Q contents) attrs + where + quotedLine = do + l <- lineWhen (T.isPrefixOf ">" . T.stripStart) + pure $ dedent 1 $ T.drop 1 $ T.stripStart l + lazyLine = lineWhen (\l -> not (isBlank l) && not (startsBlock l)) -inlineContent :: (Logger m, Characters s) => Parser s m [InlineText] -inlineContent = inlineContent' [] +-------------------------------------------------------------------------------- +-- fenced blocks: code and raw +-------------------------------------------------------------------------------- -inlineContent' :: (Logger m, Characters s) => [OpenInline] -> Parser s m [InlineText] -inlineContent' opened = someTill (inlineElement opened) $ lookAhead blockSeparator +isFenceLine :: Text -> Bool +isFenceLine = isJust . fenceOf -inlineElement :: (Logger m, Characters s) => [OpenInline] -> Parser s m InlineText -inlineElement opened = +-- | @(fence character, fence length, info string)@ +fenceOf :: Text -> Maybe (Char, Int, Text) +fenceOf l = + let s = T.stripStart l + in case T.uncons s of + Just (c, _) | c == '`' || c == '~' -> + let (fence, rest) = T.span (== c) s + in if T.length fence >= 3 then Just (c, T.length fence, T.strip rest) else Nothing + _ -> Nothing + +isCloseFenceFor :: Char -> Int -> Text -> Bool +isCloseFenceFor c n l = case fenceOf l of + Just (c', n', info) -> c' == c && n' >= n && T.null info + Nothing -> False + +fencedBlock :: (Logger m, Characters s) => Attrs -> Parser s m Element +fencedBlock attrs = do + opening <- peekLine + (fenceChar, fenceLen, info) <- maybe (fail "not a fence") pure $ fenceOf opening + let indent = indentOf opening + void rawLine + contentLines <- many $ lineWhen (not . isCloseFenceFor fenceChar fenceLen) + void $ optional $ lineWhen (isCloseFenceFor fenceChar fenceLen) + let code = T.unlines $ map (dedent indent) contentLines + pure case T.uncons info of + -- ```=html marks a raw block rather than a code block + Just ('=', format) -> RawBlock (RB {format, content = code}) attrs + _ -> + let language = if T.null info then Nothing else Just (T.takeWhile (not . isSpace) info) + in Code (C {language, code}) attrs + +-------------------------------------------------------------------------------- +-- divs +-------------------------------------------------------------------------------- + +isDivFence :: Text -> Bool +isDivFence l = T.isPrefixOf ":::" (T.stripStart l) + +isDivClose :: Int -> Text -> Bool +isDivClose n l = + let s = T.strip l + in T.length s >= n && T.all (== ':') s + +divBlock :: (Logger m, Characters s) => Attrs -> Parser s m Element +divBlock attrs = do + offset <- getOffset + opening <- peekLine + guard $ isDivFence opening + let s = T.stripStart opening + fenceLen = T.length $ T.takeWhile (== ':') s + divClass = T.strip $ T.dropWhile (== ':') s + guard $ fenceLen >= 3 + void rawLine + contentLines <- divLines fenceLen (0 :: Int) + contents <- subParse offset blocks $ T.unlines contentLines + let classAttrs = Attrs {attrId = Nothing, attrClasses = [divClass | not (T.null divClass)], attrKV = []} + pure $ Container contents (attrs <> classAttrs) + where + -- collect lines until the fence that closes *this* div, keeping track of + -- how deeply nested we are so an inner div's closing fence isn't stolen + divLines n depth = + choice + [ try do + l <- rawLine + if isDivClose n l + then + if depth <= 0 + then pure [] + else (l :) <$> divLines n (depth - 1) + else + if isDivFence l && not (isDivClose n l) + then (l :) <$> divLines n (depth + 1) + else (l :) <$> divLines n depth, + pure [] + ] + +-------------------------------------------------------------------------------- +-- tables +-------------------------------------------------------------------------------- + +-- | A parsed table line, before it is known which rows are headers. +data TableLine + = TSeparator [Alignment] + | TCells [Text] + +tableLineOf :: Text -> Maybe TableLine +tableLineOf l = do + cells <- splitCells l + pure case mapM alignmentOf cells of + Just alignments | not (null alignments) -> TSeparator alignments + _ -> TCells cells + +-- | Split a @|a|b|@ line into its cells, honouring @\\|@ escapes. +splitCells :: Text -> Maybe [Text] +splitCells line + | not (T.isPrefixOf "|" stripped) = Nothing + | otherwise = Just $ map T.strip $ dropTrailingEmpty $ go (T.unpack (T.drop 1 stripped)) "" + where + stripped = T.strip line + go [] acc = [T.pack (reverse acc)] + go ('\\' : '|' : rest) acc = go rest ('|' : '\\' : acc) + go ('|' : rest) acc = T.pack (reverse acc) : go rest "" + go (c : rest) acc = go rest (c : acc) + dropTrailingEmpty cells = case reverse cells of + (lastCell : earlier) | T.null (T.strip lastCell) -> reverse earlier + _ -> cells + +alignmentOf :: Text -> Maybe Alignment +alignmentOf cell = case T.unpack (T.strip cell) of + (':' : rest) -> fmap (\trailing -> if trailing then AlignCenter else AlignLeft) (stripDashes rest) + rest -> fmap (\trailing -> if trailing then AlignRight else AlignDefault) (stripDashes rest) + where + -- returns whether the run of dashes was followed by a `:` + stripDashes cs = + let dashes = takeWhile (== '-') cs + rest = dropWhile (== '-') cs + in if null dashes + then Nothing + else case rest of + [] -> Just False + [':'] -> Just True + _ -> Nothing + +tableBlock :: (Logger m, Characters s) => Attrs -> Parser s m Element +tableBlock attrs = do + offset <- getOffset + rawRows <- some $ mapMaybe' tableLineOf + caption <- optional $ try $ tableCaption offset + let (tableHead, columnAlignments, bodyRows) = case rawRows of + (TCells headCells : TSeparator alignments : rest) -> (Just headCells, Just alignments, cellRows rest) + _ -> (Nothing, Nothing, cellRows rawRows) + headRow <- traverse (toRow offset) tableHead + bodyRs <- traverse (toRow offset) bodyRows + pure $ Table (T {tableCaption = caption, tableHead = headRow, tableBody = bodyRs, columnAlignments}) attrs + where + mapMaybe' f = try do + l <- peekLine + parsed <- maybe (fail "not a table row") pure (f l) + void rawLine + pure parsed + cellRows = mapMaybe \case + TCells cells -> Just cells + TSeparator _ -> Nothing + toRow offset cells = TR <$> traverse (fmap TC . subParse offset inlines) cells + -- `^ some text` directly after the rows is the table's caption + tableCaption offset = do + first <- lineWhen (T.isPrefixOf "^" . T.stripStart) + rest <- many $ lineWhen (\l -> not (isBlank l) && not (startsBlock l)) + let firstText = T.stripStart $ T.drop 1 $ T.stripStart first + subParse offset inlines $ T.intercalate "\n" (firstText : map T.strip rest) + +-------------------------------------------------------------------------------- +-- footnote and reference definitions +-------------------------------------------------------------------------------- + +footnoteDefinition :: (Logger m, Characters s) => Attrs -> Parser s m Element +footnoteDefinition attrs = do + offset <- getOffset + first <- peekLine + (label, rest) <- maybe (fail "not a footnote definition") pure $ definitionLabel "^" first + void rawLine + continuation <- continuationLines 1 False + content <- subParse offset blocks $ T.unlines (T.stripStart rest : stripCommonIndent continuation) + pure $ Footnote (F {label, content}) attrs + +referenceDef :: (Logger m, Characters s) => Attrs -> Parser s m Element +referenceDef _ = do + first <- peekLine + (label, rest) <- maybe (fail "not a reference definition") pure $ definitionLabel "" first + void rawLine + continuation <- continuationLines 1 False + let target = T.concat $ map T.strip (rest : continuation) + pure $ ReferenceDefinition $ RD {label, link = target} + +-- | Split @[prefix label]: rest@ into the label and the rest of the line. +definitionLabel :: Text -> Text -> Maybe (Text, Text) +definitionLabel prefix l = do + rest <- T.stripPrefix ("[" <> prefix) (T.stripStart l) + let (label, remainder) = T.breakOn "]:" rest + guard $ not (T.null remainder) + guard $ not (T.any (`elem` ("[]" :: String)) label) + guard $ T.null prefix || not (T.isPrefixOf "^" label) + pure (label, T.drop 2 remainder) + +-------------------------------------------------------------------------------- +-- lists +-------------------------------------------------------------------------------- + +data MarkerType + = MBullet Char + | MOrdered OrderedStyle OrderedDelim Int + | MDefinition + deriving (Eq, Show) + +data OrderedStyle = ODecimal | OLowerAlpha | OUpperAlpha | OLowerRoman | OUpperRoman + deriving (Eq, Show) + +data OrderedDelim = DPeriod | DParen | DParens + deriving (Eq, Show) + +-- | Two markers belong to the same list when they only differ in their number. +sameMarker :: MarkerType -> MarkerType -> Bool +sameMarker (MBullet a) (MBullet b) = a == b +sameMarker (MOrdered s1 d1 _) (MOrdered s2 d2 _) = d1 == d2 && compatible s1 s2 +sameMarker MDefinition MDefinition = True +sameMarker _ _ = False + +-- | Roman numerals and letters overlap, so a list started with @iv.@ is +-- continued by @v.@ even though @v@ on its own reads as a letter. +compatible :: OrderedStyle -> OrderedStyle -> Bool +compatible a b = a == b || ambiguous a b || ambiguous b a + where + ambiguous OLowerRoman OLowerAlpha = True + ambiguous OUpperRoman OUpperAlpha = True + ambiguous _ _ = False + +-- | Recognise a list marker at the start of a line, yielding the marker and +-- the column its content starts at. +markerOf :: Text -> Maybe (MarkerType, Int) +markerOf l = do + let (ws, rest) = T.span isIndentChar l + indent = T.length ws + (marker, markerLen, afterMarker) <- bulletMarker rest <|> definitionMarker rest <|> orderedMarker rest + spaces <- contentGap afterMarker + pure (marker, indent + markerLen + spaces) + where + -- a marker is only a marker when followed by a space or the end of the line + contentGap rest + | T.null rest = Just 1 + | isIndentChar (T.head rest) = Just $ T.length $ T.takeWhile isIndentChar rest + | otherwise = Nothing + bulletMarker rest = do + (c, remainder) <- T.uncons rest + guard $ c `elem` ("-+*" :: String) + pure (MBullet c, 1, remainder) + definitionMarker rest = do + (c, remainder) <- T.uncons rest + guard $ c == ':' + pure (MDefinition, 1, remainder) + orderedMarker rest = parenthesised rest <|> suffixed rest + parenthesised rest = do + body <- T.stripPrefix "(" rest + let (numeral, remainder) = T.span isNumeralChar body + (style, value) <- numeralOf numeral + remainder' <- T.stripPrefix ")" remainder + pure (MOrdered style DParens value, T.length numeral + 2, remainder') + suffixed rest = do + let (numeral, remainder) = T.span isNumeralChar rest + (style, value) <- numeralOf numeral + (suffix, remainder') <- T.uncons remainder + delim <- case suffix of + '.' -> Just DPeriod + ')' -> Just DParen + _ -> Nothing + pure (MOrdered style delim value, T.length numeral + 1, remainder') + +isNumeralChar :: Char -> Bool +isNumeralChar c = isAlphaNum c + +-- | Classify the numeral part of an ordered list marker. +-- +-- A single letter is ambiguous (@i@ is both the ninth letter and roman one); +-- it is read as alphabetic, while multi character all-roman numerals are read +-- as roman. +numeralOf :: Text -> Maybe (OrderedStyle, Int) +numeralOf numeral = case T.unpack numeral of + [] -> Nothing + [c] + | isDigit c -> Just (ODecimal, read [c]) + | isUpper c -> Just (OUpperAlpha, alphaValue c) + | isLower c -> Just (OLowerAlpha, alphaValue c) + | otherwise -> Nothing + cs + | all isDigit cs -> Just (ODecimal, read cs) + | all isUpperRoman cs -> Just (OUpperRoman, romanValue cs) + | all isLowerRoman cs -> Just (OLowerRoman, romanValue cs) + -- multi letter markers only exist for roman numerals + | otherwise -> Nothing + where + isUpperRoman c = c `elem` ("IVXLCDM" :: String) + isLowerRoman c = c `elem` ("ivxlcdm" :: String) + alphaValue c = fromEnum (toLower c) - fromEnum 'a' + 1 + +romanValue :: String -> Int +romanValue = fst . foldr step (0, 0) . map (digit . toUpper) + where + step value (total, previous) + | value < previous = (total - value, previous) + | otherwise = (total + value, value) + digit 'I' = 1 + digit 'V' = 5 + digit 'X' = 10 + digit 'L' = 50 + digit 'C' = 100 + digit 'D' = 500 + digit 'M' = 1000 + digit _ = 0 + +-- | Everything a single list item contributed, before it is known what kind of +-- list it is part of. +data RawItem = RawItem + { itemMarker :: MarkerType, + itemChecked :: Maybe Bool, + itemLines :: [Text], + itemLoose :: Bool + } + +listBlock :: (Logger m, Characters s) => Attrs -> Parser s m Element +listBlock attrs = do + offset <- getOffset + first <- listItem Nothing + rest <- many $ try do + blanks <- many blankLine + item <- listItem (Just (itemMarker first)) + pure + RawItem + { itemMarker = itemMarker item, + itemChecked = itemChecked item, + itemLines = itemLines item, + itemLoose = itemLoose item || not (null blanks) + } + let items = first : rest + loose = any itemLoose items + case itemMarker first of + MDefinition -> descriptionList offset loose items + _ | any (isJust . itemChecked) items -> taskList offset loose items + marker -> plainList offset loose marker items + where + itemBlocks offset loose item = do + content <- subParse offset blocks $ T.unlines (itemLines item) + pure $ if loose then content else map unwrapParagraph content + plainList offset loose marker items = do + contents <- traverse (itemBlocks offset loose) items + pure $ List (L {list_type = listTypeOf marker, items = map LI contents}) attrs + taskList offset loose items = do + tasks <- traverse (task offset loose) items + pure $ TaskList (TL {items = tasks}) attrs + task offset loose item = do + content <- itemBlocks offset loose item + pure $ Ta {checked = fromMaybe False (itemChecked item), content} + descriptionList offset loose items = do + definitions <- traverse (definition offset loose) items + pure $ DescriptionList (DL {items = definitions}) attrs + -- for a definition item the first line is the term and the rest the body + definition offset loose item = do + let (term, body) = case itemLines item of + (t : b) -> (t, b) + [] -> ("", []) + defTitle <- subParse offset inlines term + defContent <- subParse offset blocks (T.unlines body) + pure $ Def {defTitle, defContent = if loose then defContent else map unwrapParagraph defContent} + +-- | In a tight list a paragraph isn't wrapped in @

@. +unwrapParagraph :: Element -> Element +unwrapParagraph (Paragraph (P content) _) = Transparent content +unwrapParagraph element = element + +listTypeOf :: MarkerType -> ListType +listTypeOf (MBullet _) = Unordered {style = Nothing} +listTypeOf (MOrdered numberStyle _ start) = Ordered {start_number = Just start, style = orderedStyle numberStyle} +listTypeOf MDefinition = Unordered {style = Nothing} + +orderedStyle :: OrderedStyle -> Maybe Text +orderedStyle ODecimal = Nothing +orderedStyle OLowerAlpha = Just "a" +orderedStyle OUpperAlpha = Just "A" +orderedStyle OLowerRoman = Just "i" +orderedStyle OUpperRoman = Just "I" + +-- | Parse one list item; when a marker is supplied the item must match it. +listItem :: (Logger m, Characters s) => Maybe MarkerType -> Parser s m RawItem +listItem expected = do + first <- peekLine + (marker, contentIndent) <- maybe (fail "not a list item") pure $ markerOf first + case expected of + Just wanted -> guard $ sameMarker wanted marker + Nothing -> pure () + void rawLine + let afterMarker = T.drop contentIndent first + (itemChecked, firstLine) = checkbox afterMarker + rest <- continuationLines contentIndent True + pure + RawItem + { itemMarker = marker, + itemChecked, + itemLines = firstLine : rest, + itemLoose = any isBlank rest + } + where + checkbox t = case T.uncons (T.stripStart t) of + Just ('[', rest) -> case T.uncons rest of + Just (mark, rest') | mark `elem` (" xX" :: String) -> + case T.stripPrefix "]" rest' of + Just body -> (Just (mark /= ' '), T.stripStart body) + Nothing -> (Nothing, t) + _ -> (Nothing, t) + _ -> (Nothing, t) + +-- | Lines belonging to an indented continuation of a block (list item bodies, +-- footnote definitions). +-- +-- Blank lines are kept only when indented content follows them, so a list item +-- does not swallow the blank line that ends the list. With @lazy@ set, an +-- unindented line that doesn't start another block continues the item. +continuationLines :: (Logger m, Characters s) => Int -> Bool -> Parser s m [Text] +continuationLines n lazy = go + where + go = + choice + [ try do + blanks <- some blankLine + l <- indented + rest <- go + pure $ map (const "") blanks <> (l : rest), + try do + l <- indented <|> lazyLine + rest <- go + pure (l : rest), + pure [] + ] + indented = dedent n <$> lineWhen (\l -> not (isBlank l) && indentOf l >= n) + lazyLine + | lazy = lineWhen (\l -> not (isBlank l) && not (startsBlock l)) + | otherwise = fail "no lazy continuation" + +-------------------------------------------------------------------------------- +-- inline content +-------------------------------------------------------------------------------- + +-- | Parse inline content up to the end of the (already extracted) input. +inlines :: (Logger m, Characters s) => Parser s m [InlineText] +inlines = finish <$> manyTill inlineElement eof + +-- | Parse inline content up to (and consuming) the given closer. +inlinesTill :: (Logger m, Characters s) => Parser s m () -> Parser s m [InlineText] +inlinesTill end = finish <$> manyTill inlineElement (try end) + +finish :: [InlineText] -> [InlineText] +finish = smartQuotes . mergeText + +inlineElement :: (Logger m, Characters s) => Parser s m InlineText +inlineElement = do + base <- inlineBase + extra <- many (try attributeSet) + pure $ foldl' applyAttrs base extra + +inlineBase :: (Logger m, Characters s) => Parser s m InlineText +inlineBase = choice - -- spamming try because backtracking is easier than having state for partial parses - [ try $ image opened, - try $ Djot.link opened, - try $ autolink opened, - try $ verbatim opened, - try $ emphasis opened, - try $ highlight opened, - try $ superscript opened, - try $ subscript opened, - try $ insert opened, - try $ math opened, - try $ footnoteRef opened, - try $ linebreak opened, - try $ symbol opened, - try $ rawInline opened, - try $ Djot.span opened, - try $ inlineAttribute opened, + -- `try` everywhere so an unterminated construct degrades into plain text + [ try escapeSequence, + try math, + try verbatim, + try footnoteReference, + try image, + try Djot.link, + try Djot.span, + try autolink, + try emphasis, + try bracedInline, + try symbol, plainText ] -image :: (Logger m, Characters s) => [OpenInline] -> Parser s m InlineText -image opened = error "todo" - -link :: (Logger m, Characters s) => [OpenInline] -> Parser s m InlineText -link opened = error "todo" - -autolink :: (Logger m, Characters s) => [OpenInline] -> Parser s m InlineText -autolink opened = error "todo" - -verbatim :: (Logger m, Characters s) => [OpenInline] -> Parser s m InlineText -verbatim opened = error "todo" - -emphasis :: (Logger m, Characters s) => [OpenInline] -> Parser s m InlineText -emphasis opened = error "todo" - -highlight :: (Logger m, Characters s) => [OpenInline] -> Parser s m InlineText -highlight opened = error "todo" - -superscript :: (Logger m, Characters s) => [OpenInline] -> Parser s m InlineText -superscript opene = error "todo" - -subscript :: (Logger m, Characters s) => [OpenInline] -> Parser s m InlineText -subscript opened = error "todo" - -insert :: (Logger m, Characters s) => [OpenInline] -> Parser s m InlineText -insert opened = error "todo" - -delete :: (Logger m, Characters s) => [OpenInline] -> Parser s m InlineText -delete = error "todo" - -math :: (Logger m, Characters s) => [OpenInline] -> Parser s m InlineText -math opened = error "todo" - -footnoteRef :: (Logger m, Characters s) => [OpenInline] -> Parser s m InlineText -footnoteRef opened = error "todo" - -linebreak :: (Logger m, Characters s) => [OpenInline] -> Parser s m InlineText -linebreak opened = error "todo" - -symbol :: (Logger m, Characters s) => [OpenInline] -> Parser s m InlineText -symbol opened = error "todo" - -rawInline :: (Logger m, Characters s) => [OpenInline] -> Parser s m InlineText -rawInline opened = error "todo" - -span :: (Logger m, Characters s) => [OpenInline] -> Parser s m InlineText -span opened = error "todo" - -inlineAttribute :: (Logger m, Characters s) => [OpenInline] -> Parser s m InlineText -inlineAttribute opened = error "todo" +-- | Characters that may begin some inline construct; plain text runs stop at +-- them and they are consumed one at a time as a fallback. +isSpecial :: Char -> Bool +isSpecial c = c `elem` ("\\`*_^~[]{}<>$:!-.=+" :: String) plainText :: (Logger m, Characters s) => Parser s m InlineText -plainText = error "todo" +plainText = + choice + [ Text "\8230" <$ try (string "..."), + Text "\8212" <$ try (string "---"), + Text "\8211" <$ try (string "--"), + Text . T.pack <$> some (satisfy (not . isSpecial)), + Text . T.singleton <$> anySingle + ] + +escapeSequence :: (Logger m, Characters s) => Parser s m InlineText +escapeSequence = do + void $ char '\\' + choice + [ LineBreak <$ newline, + -- backslash space is a non breaking space + Text "\160" <$ char ' ', + Text . T.singleton <$> satisfy isPunctuation + ] + where + isPunctuation c = c `elem` ("!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" :: String) + +-- | @`verbatim`@, optionally turned into raw content by a trailing @{=format}@. +verbatim :: (Logger m, Characters s) => Parser s m InlineText +verbatim = do + content <- verbatimText + format <- optional (try rawFormat) + pure case format of + Just f -> RawInline (RI {format = f, content}) mempty + Nothing -> InlineCode content mempty + where + rawFormat = do + void $ string "{=" + f <- T.pack <$> some (satisfy (\c -> c /= '}' && not (isSpace c))) + void $ char '}' + pure f + +-- | The shared body of verbatim spans: @n@ backticks, content, @n@ backticks. +verbatimText :: (Logger m, Characters s) => Parser s m Text +verbatimText = do + ticks <- some (char '`') + let n = length ticks + content <- T.pack <$> manyTill anySingle (try (closing n)) + pure $ trimVerbatim content + where + closing n = count n (char '`') *> notFollowedBy (char '`') + -- a single space next to the delimiters is dropped so `` ` `` can be written + trimVerbatim t + | T.isPrefixOf " " t && T.isSuffixOf " " t && T.length t > 1 = T.drop 1 $ T.dropEnd 1 t + | otherwise = t + +math :: (Logger m, Characters s) => Parser s m InlineText +math = do + void $ char '$' + display <- isJust <$> optional (char '$') + content <- verbatimText + pure $ Math (if display then BlockLaTeX content else InlineLaTeX content) mempty + +footnoteReference :: (Logger m, Characters s) => Parser s m InlineText +footnoteReference = do + void $ string "[^" + label <- T.pack <$> some (satisfy (\c -> c /= ']' && c /= '\n')) + void $ char ']' + pure $ FootnoteReference {label, attrs = mempty} + +-- | The @[...]@ part shared by links, images and spans. +bracketed :: (Logger m, Characters s) => Parser s m [InlineText] +bracketed = do + void $ char '[' + inlinesTill (void (char ']')) + +link :: (Logger m, Characters s) => Parser s m InlineText +link = do + linkText <- bracketed + destination linkText + where + destination linkText = + choice + [ do + url <- inlineDestination + pure $ Link {linkText, url, title = Nothing, misc_attrs = mempty}, + do + label <- referenceLabel + pure $ + ReferenceLink + { linkText, + label = if T.null label then plainOf linkText else label, + attrs = mempty + } + ] + +image :: (Logger m, Characters s) => Parser s m InlineText +image = do + void $ char '!' + altInlines <- bracketed + let altText = plainOf altInlines + choice + [ do + url <- inlineDestination + pure $ Image {altText, url, title = Nothing, misc_attrs = mempty}, + do + -- the IR has no reference image, so the label stands in for the url + label <- referenceLabel + pure $ Image {altText, url = if T.null label then altText else label, title = Nothing, misc_attrs = mempty} + ] + +-- | @(url)@, with line endings inside the url removed as djot specifies. +inlineDestination :: (Logger m, Characters s) => Parser s m Text +inlineDestination = do + void $ char '(' + cs <- many (escaped <|> satisfy (/= ')')) + void $ char ')' + pure $ T.filter (/= '\n') $ T.strip $ T.pack cs + where + escaped = char '\\' *> anySingle + +referenceLabel :: (Logger m, Characters s) => Parser s m Text +referenceLabel = do + void $ char '[' + cs <- many (satisfy (\c -> c /= ']')) + void $ char ']' + pure $ T.unwords $ T.words $ T.pack cs + +-- | @[text]{.class}@; the attributes themselves are attached by +-- 'inlineElement'. +span :: (Logger m, Characters s) => Parser s m InlineText +span = do + content <- bracketed + void $ lookAhead (char '{') + pure $ Span content mempty + +autolink :: (Logger m, Characters s) => Parser s m InlineText +autolink = do + void $ char '<' + target <- T.pack <$> some (satisfy (\c -> c /= '>' && c /= '<' && not (isSpace c))) + void $ char '>' + let url = if isEmail target then "mailto:" <> target else target + guard $ isEmail target || T.any (== ':') target + pure $ Link {linkText = [Text target], url, title = Nothing, misc_attrs = mempty} + where + isEmail t = T.any (== '@') t && not (T.any (== ':') t) + +-- | @*strong*@, @_emphasis_@, @^superscript^@ and @~subscript~@. +emphasis :: (Logger m, Characters s) => Parser s m InlineText +emphasis = + choice + [ try $ delimited '*' Bold, + try $ delimited '_' Italic, + try $ delimited '^' Superscript, + try $ delimited '~' Subscript + ] + where + delimited c construct = do + void $ char c + -- an opener may not be followed, nor a closer preceded, by whitespace + notFollowedBy (satisfy isSpace) + content <- inlinesTill (void (char c)) + guard $ not (null content) + guard $ not (endsWithSpace content) + pure $ construct content mempty + +-- | The @{x ... x}@ family: @{=highlight=}@, @{+insert+}@, @{-delete-}@ and +-- the explicit forms of emphasis. +bracedInline :: (Logger m, Characters s) => Parser s m InlineText +bracedInline = do + void $ char '{' + marker <- oneOf ("=+-*_^~" :: String) + content <- inlinesTill (void (char marker) *> void (char '}')) + guard $ not (null content) + pure $ construct marker content mempty + where + construct '=' = Highlighted + construct '+' = Insert + construct '-' = Crossed + construct '*' = Bold + construct '_' = Italic + construct '^' = Superscript + construct _ = Subscript + +symbol :: (Logger m, Characters s) => Parser s m InlineText +symbol = do + void $ char ':' + name <- T.pack <$> some (satisfy (\c -> isAlphaNum c || c `elem` ("_+-" :: String))) + void $ char ':' + pure $ Symbol name + +-------------------------------------------------------------------------------- +-- inline post processing +-------------------------------------------------------------------------------- + +endsWithSpace :: [InlineText] -> Bool +endsWithSpace content = case reverse content of + (Text t : _) -> maybe False (isSpace . snd) (T.unsnoc t) + _ -> False + +-- | The text of an inline sequence, for alt text and implicit link labels. +plainOf :: [InlineText] -> Text +plainOf = T.concat . map go + where + go (Text t) = t + go (Bold content _) = plainOf content + go (Italic content _) = plainOf content + go (Crossed content _) = plainOf content + go (Underlined content) = plainOf content + go (InlineCode t _) = t + go (Link {linkText}) = plainOf linkText + go (ReferenceLink {linkText}) = plainOf linkText + go (Image {altText}) = altText + go (HTMLInline {inline_html_content}) = inline_html_content + go (Superscript content _) = plainOf content + go (Subscript content _) = plainOf content + go (Highlighted content _) = plainOf content + go (Insert content _) = plainOf content + go (Math (InlineLaTeX t) _) = t + go (Math (BlockLaTeX t) _) = t + go (FootnoteReference {}) = "" + go (Symbol t) = ":" <> t <> ":" + go (RawInline (RI {content}) _) = content + go (Span content _) = plainOf content + go LineBreak = "\n" + +mergeText :: [InlineText] -> [InlineText] +mergeText (Text a : Text b : rest) = mergeText (Text (a <> b) : rest) +mergeText (element : rest) = element : mergeText rest +mergeText [] = [] + +applyAttrs :: InlineText -> Attrs -> InlineText +applyAttrs element extra = case element of + Bold content attrs -> Bold content (attrs <> extra) + Italic content attrs -> Italic content (attrs <> extra) + Crossed content attrs -> Crossed content (attrs <> extra) + InlineCode content attrs -> InlineCode content (attrs <> extra) + Superscript content attrs -> Superscript content (attrs <> extra) + Subscript content attrs -> Subscript content (attrs <> extra) + Highlighted content attrs -> Highlighted content (attrs <> extra) + Insert content attrs -> Insert content (attrs <> extra) + Math content attrs -> Math content (attrs <> extra) + RawInline content attrs -> RawInline content (attrs <> extra) + Span content attrs -> Span content (attrs <> extra) + Link {linkText, url, title, misc_attrs} -> Link {linkText, url, title, misc_attrs = misc_attrs <> extra} + ReferenceLink {linkText, label, attrs} -> ReferenceLink {linkText, label, attrs = attrs <> extra} + Image {altText, url, title, misc_attrs} -> Image {altText, url, title, misc_attrs = misc_attrs <> extra} + FootnoteReference {label, attrs} -> FootnoteReference {label, attrs = attrs <> extra} + -- anything else (plain text in particular) becomes a span carrying the attrs + other -> Span [other] extra + +-- | Turn straight quotes into curly ones, the way djot does. +smartQuotes :: [InlineText] -> [InlineText] +smartQuotes = fst . go ' ' + where + go previous [] = ([], previous) + go previous (element : rest) = + let (element', previous') = one previous element + (rest', final) = go previous' rest + in (element' : rest', final) + one previous (Text t) = + let t' = convert previous t + in (Text t', maybe previous snd (T.unsnoc t)) + one previous (Bold content attrs) = nested previous content (`Bold` attrs) + one previous (Italic content attrs) = nested previous content (`Italic` attrs) + one previous (Crossed content attrs) = nested previous content (`Crossed` attrs) + one previous (Superscript content attrs) = nested previous content (`Superscript` attrs) + one previous (Subscript content attrs) = nested previous content (`Subscript` attrs) + one previous (Highlighted content attrs) = nested previous content (`Highlighted` attrs) + one previous (Insert content attrs) = nested previous content (`Insert` attrs) + one previous (Span content attrs) = nested previous content (`Span` attrs) + one previous (Underlined content) = nested previous content Underlined + one previous (Link {linkText, url, title, misc_attrs}) = + nested previous linkText (\c -> Link {linkText = c, url, title, misc_attrs}) + one previous (ReferenceLink {linkText, label, attrs}) = + nested previous linkText (\c -> ReferenceLink {linkText = c, label, attrs}) + -- verbatim-ish content is left alone + one _ element = (element, 'x') + nested previous content construct = + let (content', previous') = go previous content + in (construct content', previous') + convert previous = T.pack . reverse . snd . foldl' step (previous, "") . T.unpack + step (previous, acc) c = case c of + '"' -> (c, (if opening previous then '\8220' else '\8221') : acc) + '\'' -> (c, (if opening previous then '\8216' else '\8217') : acc) + _ -> (c, c : acc) + opening previous = isSpace previous || previous `elem` ("([{-\8220\8216" :: String)