diff --git a/src/Djot.hs b/src/Djot.hs index 8bd100e..997c85c 100644 --- a/src/Djot.hs +++ b/src/Djot.hs @@ -11,13 +11,14 @@ where import Control.Applicative (many, optional, some, (<|>)) import Data.Functor (void, (<$>)) +import Data.List (elemIndex) 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, parse, sepBy, setErrorOffset, someTill) -import Text.Megaparsec.Char (char, newline, space, string, tab) +import Text.Megaparsec.Char (char, lowerChar, newline, numberChar, space, string, tab, upperChar) import Utilities.Parsing (.>) :: (a -> b) -> (b -> c) -> a -> c @@ -39,15 +40,16 @@ blockElement accumulated_attributes = *> (lookAhead (bullet *> taskMarker) *> taskListBlock accumulated_attributes) <|> listBlock accumulated_attributes, lookAhead codeFence - *> (lookAhead rawLang *> rawBlock accumulated_attributes) + *> (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, - lookAhead tableRow *> tableBlock accumulated_attributes, - lookAhead (char '[') - *> (lookAhead (char '^') *> footnoteDefinition accumulated_attributes) - <|> referenceDef 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 ] @@ -61,13 +63,14 @@ header attrs = do startOffset <- getOffset raw <- manyTill anySingle $ lookAhead blockSeparator -- second pass for inline elements - case parse header' "" (fromText $ toText raw) of + 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' = do - pure $ Heading (error "todo") attrs + header' level = do + text <- inlineContent + pure $ Heading (H {level, text}) attrs blockQuote :: (Logger m, Characters s) => Attrs -> Parser s m Element blockQuote attrs = do @@ -91,12 +94,13 @@ blockQuote attrs = do listBlock :: (Logger m, Characters s) => Attrs -> Parser s m Element listBlock attrs = do + error "this is probably fundamentally wrong and needs to be redone to work" startOffset <- getOffset list_type <- listMarker first_item <- list_item_content rem_items <- manyTill (listMarker *> list_item_content) $ lookAhead blockSeparator let items = first_item : rem_items - case parse listBlock' "" $ error "todo: fiture out how to take our list of items and put them toegether for easy parsing" of + 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 Left (ParseErrorBundle errs _) -> do logError "Error in blockQuote offset may be off" @@ -108,6 +112,7 @@ listBlock attrs = do taskListBlock :: (Logger m, Characters s) => Attrs -> Parser s m Element taskListBlock attrs = do + error "this is also probably fundamentally wrong" startOffset <- getOffset bullet first_item <- task_item @@ -116,14 +121,44 @@ taskListBlock attrs = do where task_item = error "todo" +lowerAlphabet :: [Char] +lowerAlphabet = ['a' .. 'z'] + +upperAlphabet :: [Char] +upperAlphabet = ['A' .. 'Z'] + -- consumes whitespace as well for convenience in element parser listMarker :: (Logger m, Characters s) => Parser s m ListType -listMarker = choice [bullet, decimal, try letter, roman_numeral] <* space +listMarker = choice [bullet, decimal, try lower_letter, try upper_letter, try lower_roman_numeral, try upper_roman_numeral] <* space where - decimal = error "todo" - letter = error "todo" + decimal = do + num <- choice $ map ($ some numberChar) [try . surroundParen, try . rightParen, point] + let start_number = Just $ read num + pure $ Ordered {start_number, style = Just "1"} + lower_letter :: (Logger m, Characters s) => Parser s m ListType + lower_letter = do + letter <- choice $ map ($ lowerChar) [try . surroundParen, try . rightParen, point] + let start_number = elemIndex letter lowerAlphabet + pure $ Ordered {start_number, style = Just "a"} + upper_letter :: (Logger m, Characters s) => Parser s m ListType + upper_letter = do + 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" + surroundParen :: (Logger m, Characters s) => Parser s m a -> Parser s m a + surroundParen parser = do + char '(' + ret <- parser + char ')' + space + pure ret + rightParen :: (Logger m, Characters s) => Parser s m a -> Parser s m a + rightParen parser = parser <* char ')' <* space + point :: (Logger m, Characters s) => Parser s m a -> Parser s m a + point parser = parser <* char '.' <* space + bullet :: (Logger m, Characters s) => Parser s m ListType bullet = error "todo" @@ -225,14 +260,16 @@ containerBlock' n attrs = do tableBlock :: (Logger m, Characters s) => Attrs -> Parser s m Element tableBlock attrs = do prefix <- tablePrefix - rem_rows <- manyTill tableRow blockSeparator + 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 - tablePrefix = error "todo" :: Parser s m (Maybe (TableRow, [Alignment])) 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 '|' @@ -255,4 +292,22 @@ footnoteDefinition attrs = do footnoteElement = tab *> footnoteElement' paragraph :: (Logger m, Characters s) => Attrs -> Parser s m Element -paragraph = error "todo" +paragraph attrs = do + content <- inlineContent + pure $ Paragraph (P content) attrs + +data OpenInline = SquareBracket | CurlyBracket | Paren | Underscore | Asterisk | Backtick Int | Insert | Delete | Highlight | Superscript | Subscript | AngleBracket deriving (Show) + +closingInline :: (Logger m, Characters s) => [OpenInline] -> Parser s m OpenInline +closingInline = error "todo" + +inlineContent :: (Logger m, Characters s) => Parser s m [InlineText] +inlineContent = inlineContent' [] + +inlineContent' :: (Logger m, Characters s) => [OpenInline] -> Parser s m [InlineText] +inlineContent' opened = someTill (inlineElement opened) $ lookAhead blockSeparator + +inlineElement :: (Logger m, Characters s) => [OpenInline] -> Parser s m InlineText +inlineElement opened = + choice + [lookAhead (string "![") *> image, lookAhead]