diff --git a/src/Djot.hs b/src/Djot.hs index 997c85c..eb56ca0 100644 --- a/src/Djot.hs +++ b/src/Djot.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -10,14 +11,17 @@ module Djot where import Control.Applicative (many, optional, some, (<|>)) +import Control.Monad.ST (runST) +import Data.Foldable (for_) import Data.Functor (void, (<$>)) import Data.List (elemIndex) import qualified Data.List.NonEmpty as NE +import Data.STRef (modifySTRef', newSTRef, readSTRef, writeSTRef) 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, parse, sepBy, setErrorOffset, someTill) +import Text.Megaparsec (MonadParsec (lookAhead, notFollowedBy, parseError, try), ParseErrorBundle (ParseErrorBundle, bundleErrors), SourcePos (sourceColumn), anySingle, choice, errorOffset, getInput, getOffset, manyTill, parse, satisfy, sepBy, setErrorOffset, someTill) import Text.Megaparsec.Char (char, lowerChar, newline, numberChar, space, string, tab, upperChar) import Utilities.Parsing @@ -46,10 +50,10 @@ blockElement accumulated_attributes = 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, + 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, + try $ footnoteDefinition accumulated_attributes, + try $ referenceDef accumulated_attributes, lookAhead (char '{') *> blockAttribute accumulated_attributes, paragraph accumulated_attributes ] @@ -86,7 +90,9 @@ blockQuote attrs = do parseError $ remap $ NE.head errs where blockQuote' = do - pure $ BlockQuote (error "todo") attrs + -- using document for convenience + (Doc contents) <- document + pure $ BlockQuote (Q contents) attrs bq_line = do char '>' space @@ -98,7 +104,7 @@ listBlock attrs = do startOffset <- getOffset list_type <- listMarker first_item <- list_item_content - rem_items <- manyTill (listMarker *> list_item_content) $ lookAhead blockSeparator + rem_items <- manyTill (listMarker' list_type *> list_item_content) $ lookAhead blockSeparator let items = first_item : rem_items case parse listBlock' "" $ error "todo: figure out how to take our list of items and put them toegether for easy parsing" of Right ret -> pure ret @@ -127,6 +133,41 @@ lowerAlphabet = ['a' .. 'z'] upperAlphabet :: [Char] upperAlphabet = ['A' .. 'Z'] +-- inner parsing of roman numerals done via Gemini due to lazy +romanValue :: Char -> Int +romanValue 'I' = 1 +romanValue 'V' = 5 +romanValue 'X' = 10 +romanValue 'L' = 50 +romanValue 'C' = 100 +romanValue 'D' = 500 +romanValue 'M' = 1000 +romanValue _ = 0 + +romanToInt :: Text -> Int +romanToInt s = runST $ do + total <- newSTRef 0 + prevVal <- newSTRef 0 + + for_ (T.unpack s) $ \char -> do + let curr = romanValue char + p <- readSTRef prevVal + + -- If current > previous (e.g., IV), we subtract the previous twice + if curr > p + then modifySTRef' total (\t -> t + curr - 2 * p) + else modifySTRef' total (+ curr) + + writeSTRef prevVal curr + + readSTRef total + +upperRoman :: [Char] +upperRoman = "IVXLCDM" + +lowerRoman :: [Char] +lowerRoman = T.unpack $ T.toLower $ T.pack upperRoman + -- consumes whitespace as well for convenience in element parser listMarker :: (Logger m, Characters s) => Parser s m ListType listMarker = choice [bullet, decimal, try lower_letter, try upper_letter, try lower_roman_numeral, try upper_roman_numeral] <* space @@ -145,7 +186,14 @@ listMarker = choice [bullet, decimal, try lower_letter, try upper_letter, try lo letter <- choice $ map ($ upperChar) [try . surroundParen, try . rightParen, point] let start_number = elemIndex letter upperAlphabet pure $ Ordered {start_number, style = Just "A"} - roman_numeral = error "todo" + lower_roman_numeral = do + numeral <- choice $ map ($ some (satisfy (`elem` lowerRoman))) [try . surroundParen, try . rightParen, point] + let start_number = Just $ romanToInt $ T.toUpper $ toText numeral + pure $ Ordered {start_number, style = Just "i"} + upper_roman_numeral = do + numeral <- choice $ map ($ some (satisfy (`elem` upperRoman))) [try . surroundParen, try . rightParen, point] + let start_number = Just $ romanToInt $ T.toUpper $ toText numeral + pure $ Ordered {start_number, style = Just "I"} surroundParen :: (Logger m, Characters s) => Parser s m a -> Parser s m a surroundParen parser = do @@ -180,7 +228,7 @@ codeBlock attrs = do else Just $ toText language' code <- toText <$> manyTill anySingle codeFence - pure $ Code $ C {language, code} + pure $ Code (C {language, code}) attrs blockAttribute :: (Logger m, Characters s) => Attrs -> Parser s m Element blockAttribute attrs = do @@ -310,4 +358,76 @@ inlineContent' opened = someTill (inlineElement opened) $ lookAhead blockSeparat inlineElement :: (Logger m, Characters s) => [OpenInline] -> Parser s m InlineText inlineElement opened = choice - [lookAhead (string "![") *> image, lookAhead] + -- 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, + 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" + +plainText :: (Logger m, Characters s) => Parser s m InlineText +plainText = error "todo" diff --git a/src/HTML.hs b/src/HTML.hs index ec65f45..1fb2f9b 100644 --- a/src/HTML.hs +++ b/src/HTML.hs @@ -49,16 +49,16 @@ spaceSep = T.intercalate " " elementToHTML :: Element -> T.Text elementToHTML (Heading header attrs) = T.concat ["", serializeInlineToHTML header.text, ""] -- -elementToHTML (Code code_block) = T.concat ["
", escapeText code_block.code, "", "
"] +elementToHTML (Code code_block attrs) = T.concat ["
", escapeText code_block.code, "", "
"] where language = fromMaybe "" code_block.language -elementToHTML (BlockQuote (Q elems)) = T.concat ["
", elementsToHTML elems, "
"] +elementToHTML (BlockQuote (Q elems) attrs) = T.concat ["
", elementsToHTML elems, "
"] elementToHTML (List (L {list_type = Ordered {start_number, style}, items}) attrs) = spaceSep ["", generateLiElems items, ""] elementToHTML (List (L {list_type = Unordered {style}, items}) attrs) = spaceSep ["", generateLiElems items, ""] elementToHTML (HTML (HTMLTag {html_content})) = html_content elementToHTML (Paragraph (P snippets) attrs) = spaceSep ["", serializeInlineToHTML snippets, "

"] elementToHTML (Transparent snippets) = serializeInlineToHTML snippets -elementToHTML HorizontalRule = "
" +elementToHTML (HorizontalRule attrs) = "
handleAttrs attrs <> ">" elementToHTML (Table _ _) = error "TODO" elementToHTML (Container _ _) = error "TODO" elementToHTML (Footnote _ _) = error "TODO" diff --git a/src/Markdown.hs b/src/Markdown.hs index bd8a50f..e6fc411 100644 --- a/src/Markdown.hs +++ b/src/Markdown.hs @@ -138,7 +138,7 @@ fencedCodeBlock = between (string "```") (string "```") $ do lineEnding code <- T.pack <$> (many ((notFollowedBy $ string "```") *> anySingle)) let language = if language' == "" then Just language' else Nothing - pure $ Code $ C {language, code} + pure $ Code (C {language, code}) mempty blockquoteBlock :: (Logger m, Characters s) => Parser s m Element blockquoteBlock = do