diff --git a/src/Djot.hs b/src/Djot.hs index 5c2d5ef..8bd100e 100644 --- a/src/Djot.hs +++ b/src/Djot.hs @@ -9,15 +9,15 @@ module Djot ) where -import Control.Applicative (many, some, (<|>)) +import Control.Applicative (many, optional, some, (<|>)) 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, 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 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 Utilities.Parsing (.>) :: (a -> b) -> (b -> c) -> a -> c @@ -178,7 +178,10 @@ referenceDef attrs = do pure $ ReferenceDefinition $ RD {label, link} rawBlock :: (Logger m, Characters s) => Attrs -> Parser s m Element -rawBlock = error "todo" +rawBlock attrs = do + Code (C {language = Just format', code = content}) _ <- codeBlock mempty + let format = T.drop 1 format' + pure $ RawBlock (RB {format, content}) attrs thematicBreak :: (Logger m, Characters s) => Attrs -> Parser s m Element thematicBreak attrs = do @@ -201,16 +204,55 @@ thematicBreak attrs = do part = choice $ map char "*-" containerBlock :: (Logger m, Characters s) => Attrs -> Parser s m Element -containerBlock = error "todo" +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 = error "todo" +tableBlock attrs = do + prefix <- tablePrefix + rem_rows <- manyTill tableRow 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] -tableRow :: (Logger m, Characters s) => Parser s m Element -tableRow = 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 = error "todo" +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' paragraph :: (Logger m, Characters s) => Attrs -> Parser s m Element paragraph = error "todo" diff --git a/src/IR.hs b/src/IR.hs index 02ae20e..894e6f5 100644 --- a/src/IR.hs +++ b/src/IR.hs @@ -8,7 +8,7 @@ newtype Document = Doc [Element] data Element = Heading Heading Attrs - | Code Code + | Code Code Attrs | BlockQuote BlockQuote Attrs | List List Attrs | -- Markdown only, DJOT will produce a RawBlock with an html type @@ -131,9 +131,8 @@ data Math data Alignment = AlignLeft | AlignRight | AlignCenter | AlignDefault deriving (Show) -data TableCell = TC - { cellContent :: [InlineText], - cellAlign :: Alignment +newtype TableCell = TC + { cellContent :: [InlineText] } deriving (Show) @@ -142,7 +141,8 @@ newtype TableRow = TR [TableCell] deriving (Show) data Table = T { tableCaption :: Maybe [InlineText], tableHead :: Maybe TableRow, - tableBody :: [TableRow] + tableBody :: [TableRow], + columnAlignments :: Maybe [Alignment] } deriving (Show) @@ -164,15 +164,15 @@ data Task = Ta } deriving (Show) --- TODO data RawInline = RI - { + { format :: Text, + content :: Text } deriving (Show) --- TODO data RawBlock = RB - { + { format :: Text, + content :: Text } deriving (Show)