diff --git a/src/Djot.hs b/src/Djot.hs index bfd4218..5c2d5ef 100644 --- a/src/Djot.hs +++ b/src/Djot.hs @@ -10,13 +10,13 @@ module Djot where import Control.Applicative (many, some, (<|>)) -import Control.Monad.Trans.Accum (accum) -import Data.Functor (void, (<$>), (<&>)) +import Data.Functor (void, (<$>)) +import qualified Data.List.NonEmpty as NE import Data.Text (Text) import qualified Data.Text as T import IR -import Logger (Logger (logCallStack, logDebug)) -import Text.Megaparsec (MonadParsec (lookAhead, notFollowedBy, try), anySingle, choice, manyTill, sepBy) +import Logger (Logger (logCallStack, logDebug, logError)) +import Text.Megaparsec (MonadParsec (lookAhead, notFollowedBy, parseError, try), ParseErrorBundle (ParseErrorBundle, bundleErrors), anySingle, choice, errorOffset, getInput, getOffset, manyTill, parse, sepBy, setErrorOffset) import Text.Megaparsec.Char (char, newline, space, string) import Utilities.Parsing @@ -36,7 +36,7 @@ blockElement accumulated_attributes = [ lookAhead (char '#') *> header accumulated_attributes, lookAhead (char '>') *> blockQuote accumulated_attributes, lookAhead listMarker - *> (lookAhead taskMarker *> taskListBlock accumulated_attributes) + *> (lookAhead (bullet *> taskMarker) *> taskListBlock accumulated_attributes) <|> listBlock accumulated_attributes, lookAhead codeFence *> (lookAhead rawLang *> rawBlock accumulated_attributes) @@ -53,49 +53,152 @@ blockElement accumulated_attributes = ] where rawLang = space *> char '=' *> some (notFollowedBy newline *> anySingle) - taskMarker = void $ char '[' *> choice (map char " xX") *> char ']' header :: (Logger m, Characters s) => Attrs -> Parser s m Element -header = error "todo" +header attrs = do + level <- length <$> some (char '#') + space + startOffset <- getOffset + raw <- manyTill anySingle $ lookAhead blockSeparator + -- second pass for inline elements + case parse header' "" (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 blockQuote :: (Logger m, Characters s) => Attrs -> Parser s m Element -blockQuote = error "todo" +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 + 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 + where + blockQuote' = do + pure $ BlockQuote (error "todo") attrs + bq_line = do + char '>' + space + manyTill anySingle $ lookAhead newline listBlock :: (Logger m, Characters s) => Attrs -> Parser s m Element -listBlock = error "todo" +listBlock attrs = do + 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 + 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 + where + list_item_content = error "todo" + listBlock' = error "todo" +taskListBlock :: (Logger m, Characters s) => Attrs -> Parser s m Element +taskListBlock attrs = do + startOffset <- getOffset + bullet + first_item <- task_item + rem_items <- manyTill (listMarker *> task_item) $ lookAhead blockSeparator + pure $ TaskList (TL {items = first_item : rem_items}) attrs + where + task_item = error "todo" + +-- consumes whitespace as well for convenience in element parser listMarker :: (Logger m, Characters s) => Parser s m ListType -listMarker = error "todo" +listMarker = choice [bullet, decimal, try letter, roman_numeral] <* space + where + decimal = error "todo" + letter = error "todo" + roman_numeral = error "todo" + +bullet :: (Logger m, Characters s) => Parser s m ListType +bullet = error "todo" + +taskMarker :: (Logger m, Characters s) => Parser s m Char +taskMarker = char '[' *> choice (map char " xX") <* char ']' <* space codeFence :: (Logger m, Characters s) => Parser s m () codeFence = void $ string "```" codeBlock :: (Logger m, Characters s) => Attrs -> Parser s m Element -codeBlock = error "todo" - -paragraph :: (Logger m, Characters s) => Attrs -> Parser s m Element -paragraph = error "todo" +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} blockAttribute :: (Logger m, Characters s) => Attrs -> Parser s m Element -blockAttribute attrs = (blockAttribute' <&> (attrs <>) >>= blockElement) <|> error "eof handle" +blockAttribute attrs = do + current <- blockAttribute' + let attrs' = attrs <> current + blockElement attrs' <|> error "eof handle" blockAttribute' :: (Logger m, Characters s) => Parser s m Attrs -blockAttribute' = error "todo" +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 + where + blockAttribute'' = error "todo" blockSeparator :: (Logger m, Characters s) => Parser s m () blockSeparator = void $ newline *> newline -taskListBlock :: (Logger m, Characters s) => Attrs -> Parser s m Element -taskListBlock = error "todo" - referenceDef :: (Logger m, Characters s) => Attrs -> Parser s m Element -referenceDef = error "todo" +referenceDef attrs = do + char '[' + label <- toText <$> manyTill anySingle (char ']') + char ':' + link <- toText <$> manyTill anySingle (lookAhead blockSeparator) + pure $ ReferenceDefinition $ RD {label, link} rawBlock :: (Logger m, Characters s) => Attrs -> Parser s m Element rawBlock = error "todo" thematicBreak :: (Logger m, Characters s) => Attrs -> Parser s m Element -thematicBreak = error "todo" +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) + pure $ HorizontalRule attrs + where + part = choice $ map char "*-" containerBlock :: (Logger m, Characters s) => Attrs -> Parser s m Element containerBlock = error "todo" @@ -108,3 +211,6 @@ tableRow = error "todo" footnoteDefinition :: (Logger m, Characters s) => Attrs -> Parser s m Element footnoteDefinition = error "todo" + +paragraph :: (Logger m, Characters s) => Attrs -> Parser s m Element +paragraph = error "todo" diff --git a/src/IR.hs b/src/IR.hs index 38fd25d..02ae20e 100644 --- a/src/IR.hs +++ b/src/IR.hs @@ -9,14 +9,14 @@ newtype Document = Doc [Element] data Element = Heading Heading Attrs | Code Code - | BlockQuote BlockQuote + | BlockQuote BlockQuote Attrs | List List Attrs | -- Markdown only, DJOT will produce a RawBlock with an html type HTML HTML | Paragraph Paragraph Attrs | -- to avoid breaking generation when swapping InlineText to Element in Markdown parser Transparent [InlineText] - | HorizontalRule + | HorizontalRule Attrs | Table Table Attrs | -- Djot ::: Container [Element] Attrs @@ -176,9 +176,9 @@ data RawBlock = RB } deriving (Show) --- TODO data RefDef = RD - { + { label :: Text, + link :: Text } deriving (Show) diff --git a/src/Markdown.hs b/src/Markdown.hs index b9bca46..bd8a50f 100644 --- a/src/Markdown.hs +++ b/src/Markdown.hs @@ -143,7 +143,7 @@ fencedCodeBlock = between (string "```") (string "```") $ do blockquoteBlock :: (Logger m, Characters s) => Parser s m Element blockquoteBlock = do content <- Q . concat <$> some blockquoteLine - pure $ BlockQuote content + pure $ BlockQuote content mempty where blockquoteLine = do char '>'