Compare commits
No commits in common. "c1acbe15f152513014c89a3ab623669256245bb9" and "9e9117db521ad36081c2e02d9faadf48bed5564d" have entirely different histories.
c1acbe15f1
...
9e9117db52
3 changed files with 90 additions and 191 deletions
|
|
@ -15,14 +15,14 @@ class (Monad m) => Logger m where
|
|||
logInfo :: T.Text -> m ()
|
||||
logDebug :: T.Text -> m ()
|
||||
|
||||
logIO :: T.Text -> T.Text -> IO ()
|
||||
logIO kind msg = T.putStrLn $ kind <> ": " <> msg
|
||||
logIO :: T.Text -> IO ()
|
||||
logIO = T.putStrLn
|
||||
|
||||
instance Logger IO where
|
||||
logError = logIO "error"
|
||||
logWarning = logIO "warning"
|
||||
logInfo = logIO "info"
|
||||
logDebug = logIO "debug"
|
||||
logError = logIO
|
||||
logWarning = logIO
|
||||
logInfo = logIO
|
||||
logDebug = logIO
|
||||
|
||||
logState :: (Monad m) => T.Text -> StateT T.Text m ()
|
||||
logState msg = modify (<> msg <> "\n")
|
||||
|
|
|
|||
163
app/Markdown.hs
163
app/Markdown.hs
|
|
@ -1,7 +1,6 @@
|
|||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
-- (document, metadata)
|
||||
module Markdown (document, metadata) where
|
||||
|
|
@ -10,14 +9,12 @@ import Control.Applicative (many, optional, some, (<|>))
|
|||
import Control.Monad (guard, void)
|
||||
import Data.Char (isAlpha)
|
||||
import Data.Functor.Identity (Identity)
|
||||
import Data.String (IsString)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Void (Void)
|
||||
import GHC.Stack (HasCallStack, callStack, prettyCallStack)
|
||||
import IR
|
||||
import Logger (Logger (logDebug))
|
||||
import Text.Megaparsec (ParsecT, Stream, Token, Tokens, anySingle, anySingleBut, between, choice, count, eof, manyTill, notFollowedBy, satisfy, skipSome, try, (<?>))
|
||||
import Text.Megaparsec (ParsecT, anySingle, anySingleBut, between, choice, count, eof, manyTill, notFollowedBy, satisfy, skipSome, try, (<?>))
|
||||
import qualified Text.Megaparsec as MP
|
||||
import Text.Megaparsec.Char (alphaNumChar, char, digitChar, string)
|
||||
import Utilities (tee)
|
||||
|
|
@ -28,41 +25,39 @@ type ParserT m = ParserTG T.Text m
|
|||
|
||||
type Parser = ParserT Identity
|
||||
|
||||
logP :: (Logger m, Show v, Token s ~ Char, Stream s) => ParserTG s m v -> ParserTG s m v
|
||||
logP :: (Logger m, Show s) => ParserTG s m s -> ParserTG s m s
|
||||
logP = tee (logDebug . T.show)
|
||||
|
||||
anyChar :: (Token s ~ Char, Stream s) => ParserTG s m Char
|
||||
anyChar :: ParserTG s m Char
|
||||
anyChar = anySingle
|
||||
|
||||
alphaNum :: (Token s ~ Char, Stream s) => ParserTG s m Char
|
||||
alphaNum :: ParserTG s m Char
|
||||
alphaNum = alphaNumChar
|
||||
|
||||
digit :: (Token s ~ Char, Stream s) => ParserTG s m Char
|
||||
digit :: ParserTG s m Char
|
||||
digit = digitChar
|
||||
|
||||
noneOf :: (Token s ~ Char, Stream s) => [Char] -> ParserTG s m Char
|
||||
noneOf :: [Char] -> ParserTG s m Char
|
||||
noneOf = MP.noneOf
|
||||
|
||||
oneOf :: (Token s ~ Char, Stream s) => [Char] -> ParserTG s m Char
|
||||
oneOf :: [Char] -> ParserTG s m Char
|
||||
oneOf = MP.oneOf
|
||||
|
||||
optionMaybe :: (Token s ~ Char, Stream s) => ParserTG s m a -> ParserTG s m (Maybe a)
|
||||
optionMaybe :: ParserTG s m a -> ParserTG s m (Maybe a)
|
||||
optionMaybe = optional
|
||||
|
||||
skipMany1 :: (Token s ~ Char, Stream s) => ParserTG s m a -> ParserTG s m ()
|
||||
skipMany1 :: ParserTG s m a -> ParserTG s m ()
|
||||
skipMany1 = skipSome
|
||||
|
||||
metadata :: (Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m Text
|
||||
metadata :: ParserTG s m Text
|
||||
metadata = bound *> fmap T.pack (many $ try (char '-' <* notFollowedBy (string "--")) <|> anySingleBut '-') <* bound
|
||||
where
|
||||
bound = string "---"
|
||||
|
||||
document :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m Document
|
||||
document = do
|
||||
logDebug "document"
|
||||
Doc <$> many element <* eof
|
||||
document :: (Logger m) => ParserTG s m Document
|
||||
document = Doc <$> many element <* eof
|
||||
|
||||
element :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m Element
|
||||
element :: (Logger m) => ParserTG s m Element
|
||||
element =
|
||||
choice
|
||||
[ try headingBlock <?> "Element Heading",
|
||||
|
|
@ -78,19 +73,19 @@ element =
|
|||
]
|
||||
|
||||
-- Blank lines (consumed but not stored)
|
||||
blankLines :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m Element
|
||||
blankLines :: (Logger m) => ParserTG s m Element
|
||||
blankLines = do
|
||||
skipMany1 (blankLine *> notFollowedBy eof)
|
||||
element <|> fmap (const $ HTML HTMLTag {html_content = ""}) eof -- Parse the next element (or handle eof)
|
||||
|
||||
blankLine :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m ()
|
||||
blankLine :: (Logger m) => ParserTG s m ()
|
||||
blankLine = do
|
||||
many (char ' ' <|> char '\t')
|
||||
lineEnding
|
||||
pure ()
|
||||
|
||||
-- Heading Block
|
||||
headingBlock :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m Element
|
||||
headingBlock :: (Logger m) => ParserTG s m Element
|
||||
headingBlock = do
|
||||
hashes <- some (char '#') <?> "Heading Hashes"
|
||||
let level = length hashes
|
||||
|
|
@ -100,30 +95,25 @@ headingBlock = do
|
|||
pure $ Heading $ H level content
|
||||
|
||||
-- Fenced Code Block
|
||||
fencedCodeBlock :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m Element
|
||||
fencedCodeBlock :: (Logger m) => ParserTG s m Element
|
||||
fencedCodeBlock = do
|
||||
logDebug "fenced_coding_block"
|
||||
fence <- string "```" <|> string "~~~"
|
||||
logDebug "fence"
|
||||
lang <- optionMaybe languageInfo
|
||||
logDebug "langInfo"
|
||||
lineEnding'
|
||||
logDebug "lineEnding"
|
||||
lineEnding
|
||||
codeLines <- manyTill codeLine (try $ string fence)
|
||||
logDebug "lines"
|
||||
pure $ Code $ C lang (T.pack $ unlines codeLines)
|
||||
|
||||
languageInfo :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m Text
|
||||
languageInfo :: (Logger m) => ParserTG s m Text
|
||||
languageInfo = T.pack <$> some (alphaNum <|> char '-' <|> char '+' <|> char '.')
|
||||
|
||||
codeLine :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m String
|
||||
codeLine :: (Logger m) => ParserTG s m String
|
||||
codeLine = do
|
||||
line <- many $ noneOf "\n\r"
|
||||
lineEnding'
|
||||
lineEnding
|
||||
pure line
|
||||
|
||||
-- Indented Code Block
|
||||
indentedCodeBlock :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m Element
|
||||
indentedCodeBlock :: (Logger m) => ParserTG s m Element
|
||||
indentedCodeBlock = do
|
||||
lines' <- some indentedLine
|
||||
pure $ Code $ C Nothing (T.pack $ unlines lines')
|
||||
|
|
@ -135,7 +125,7 @@ indentedCodeBlock = do
|
|||
pure line
|
||||
|
||||
-- Blockquote Block
|
||||
blockquoteBlock :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m Element
|
||||
blockquoteBlock :: (Logger m) => ParserTG s m Element
|
||||
blockquoteBlock = do
|
||||
lines' <- some blockquoteLine
|
||||
pure $ BlockQuote $ Q (concat lines')
|
||||
|
|
@ -147,7 +137,7 @@ blockquoteBlock = do
|
|||
pure content
|
||||
|
||||
-- Horizontal Rule Block
|
||||
horizontalRuleBlock :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m Element
|
||||
horizontalRuleBlock :: (Logger m) => ParserTG s m Element
|
||||
horizontalRuleBlock = do
|
||||
choice
|
||||
[ try (count 3 (char '*') >> many (char ' ' <|> char '*')),
|
||||
|
|
@ -158,21 +148,21 @@ horizontalRuleBlock = do
|
|||
pure HorizontalRule
|
||||
|
||||
-- Unordered List Block
|
||||
unorderedListBlock :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m Element
|
||||
unorderedListBlock :: (Logger m) => ParserTG s m Element
|
||||
unorderedListBlock = do
|
||||
items <- some unorderedListItem
|
||||
pure $ List $ L Unordered items
|
||||
|
||||
unorderedListItem :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m ListItem
|
||||
unorderedListItem :: (Logger m) => ParserTG s m ListItem
|
||||
unorderedListItem = do
|
||||
oneOf "*-+"
|
||||
char ' ' <|> char '\t'
|
||||
content <- manyTill inlineElement (try lineEnding')
|
||||
content <- manyTill inlineElement (try lineEnding)
|
||||
-- continuations <- many listContinuation
|
||||
children <- many (try indentedList)
|
||||
pure $ LI content children
|
||||
|
||||
listContinuation :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m [InlineText]
|
||||
listContinuation :: (Logger m) => ParserTG s m [InlineText]
|
||||
listContinuation = do
|
||||
count 2 (char ' ' <|> char '\t')
|
||||
many (char ' ' <|> char '\t')
|
||||
|
|
@ -182,35 +172,35 @@ listContinuation = do
|
|||
pure content
|
||||
|
||||
-- TODO: handle list indentation at all levels
|
||||
indentedList :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m List
|
||||
indentedList :: (Logger m) => ParserTG s m List
|
||||
indentedList = do
|
||||
let n = 1
|
||||
void $ count (4 * n) (char ' ') <|> count n (char '\t')
|
||||
choice [try indentedUnorderedList, indentedOrderedList]
|
||||
|
||||
indentedUnorderedList :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m List
|
||||
indentedUnorderedList :: (Logger m) => ParserTG s m List
|
||||
indentedUnorderedList = do
|
||||
items <- some (try $ indentedListItem (oneOf "*-+" >> void (char ' ' <|> char '\t')))
|
||||
pure $ L Unordered items
|
||||
|
||||
indentedOrderedList :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m List
|
||||
indentedOrderedList :: (Logger m) => ParserTG s m List
|
||||
indentedOrderedList = do
|
||||
items <- some (try $ indentedListItem (some digit >> char '.' >> void (char ' ' <|> char '\t')))
|
||||
pure $ L Ordered items
|
||||
|
||||
indentedListItem :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m () -> ParserTG s m ListItem
|
||||
indentedListItem :: (Logger m) => ParserTG s m () -> ParserTG s m ListItem
|
||||
indentedListItem marker = do
|
||||
marker
|
||||
content <- manyTill inlineElement (try $ lineEnding <|> eof)
|
||||
pure $ LI content []
|
||||
|
||||
-- Ordered List Block
|
||||
orderedListBlock :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m Element
|
||||
orderedListBlock :: (Logger m) => ParserTG s m Element
|
||||
orderedListBlock = do
|
||||
items <- some orderedListItem
|
||||
pure $ List $ L Ordered items
|
||||
|
||||
orderedListItem :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m ListItem
|
||||
orderedListItem :: (Logger m) => ParserTG s m ListItem
|
||||
orderedListItem = do
|
||||
some digit
|
||||
char '.'
|
||||
|
|
@ -221,33 +211,33 @@ orderedListItem = do
|
|||
pure $ LI (content ++ concat continuations) children
|
||||
|
||||
-- HTML Block
|
||||
htmlBlock :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m Element
|
||||
htmlBlock :: (Logger m) => ParserTG s m Element
|
||||
htmlBlock = do
|
||||
char '<'
|
||||
-- Capture the entire HTML block as raw text
|
||||
rest <- manyTill anyChar (try $ char '>' >> lineEnding)
|
||||
let content = '<' : (rest <> ">")
|
||||
let content = '<' : rest
|
||||
return $ HTML $ HTMLTag (T.pack content)
|
||||
|
||||
tagName :: (Logger m, Token s ~ Char, Stream s) => ParserTG s m String
|
||||
tagName :: (Logger m) => ParserTG s m String
|
||||
tagName = do
|
||||
first <- satisfy isAlpha
|
||||
rest <- many (alphaNum <|> char '-' <|> char ':')
|
||||
pure (first : rest)
|
||||
|
||||
attribute :: (Logger m, Token s ~ Char, Stream s) => ParserTG s m (Text, Maybe Text)
|
||||
attribute :: (Logger m) => ParserTG s m (Text, Maybe Text)
|
||||
attribute = do
|
||||
name <- attributeName
|
||||
value <- optionMaybe (char '=' >> attributeValue)
|
||||
pure (T.pack name, fmap T.pack value)
|
||||
|
||||
attributeName :: (Logger m, Token s ~ Char, Stream s) => ParserTG s m String
|
||||
attributeName :: (Logger m) => ParserTG s m String
|
||||
attributeName = do
|
||||
first <- satisfy isAlpha
|
||||
rest <- many (alphaNum <|> char '-' <|> char ':')
|
||||
pure (first : rest)
|
||||
|
||||
attributeValue :: (Logger m, Token s ~ Char, Stream s) => ParserTG s m String
|
||||
attributeValue :: (Logger m) => ParserTG s m String
|
||||
attributeValue =
|
||||
choice
|
||||
[ between (char '"') (char '"') (many $ anySingleBut '"'),
|
||||
|
|
@ -256,18 +246,16 @@ attributeValue =
|
|||
]
|
||||
|
||||
-- Paragraph Block
|
||||
paragraphBlock :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m Element
|
||||
paragraphBlock :: (Logger m) => ParserTG s m Element
|
||||
paragraphBlock = do
|
||||
logDebug "paragraph"
|
||||
content <- some (notFollowedBy lineEnding *> inlineElement)
|
||||
content <- some inlineElement
|
||||
lineEnding <|> eof
|
||||
pure $ Paragraph $ P content
|
||||
|
||||
-- Inline Elements
|
||||
inlineElement :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
|
||||
inlineElement :: (Logger m) => ParserTG s m InlineText
|
||||
inlineElement =
|
||||
logDebug "inlineElement"
|
||||
*> choice
|
||||
choice
|
||||
[ try strong <?> "Inline Strong Text",
|
||||
try emphasis <?> "Inline Italic Text",
|
||||
try crossedText <?> "Inline Crossed Text",
|
||||
|
|
@ -280,24 +268,24 @@ inlineElement =
|
|||
]
|
||||
|
||||
-- Strong (Bold)
|
||||
strong :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
|
||||
strong :: (Logger m) => ParserTG s m InlineText
|
||||
strong = strongAsterisk <|> strongUnderscore
|
||||
|
||||
strongAsterisk :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
|
||||
strongAsterisk :: (Logger m) => ParserTG s m InlineText
|
||||
strongAsterisk = do
|
||||
string "**"
|
||||
content <- some (notFollowedBy (string "**") >> inlineElement)
|
||||
string "**"
|
||||
pure $ Bold content
|
||||
|
||||
strongUnderscore :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
|
||||
strongUnderscore :: (Logger m) => ParserTG s m InlineText
|
||||
strongUnderscore = do
|
||||
string "__"
|
||||
content <- some (notFollowedBy (string "__") >> inlineElement)
|
||||
string "__"
|
||||
pure $ Bold content
|
||||
|
||||
crossedText :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
|
||||
crossedText :: (Logger m) => ParserTG s m InlineText
|
||||
crossedText = do
|
||||
string "~~"
|
||||
content <- some (notFollowedBy (string "~~") >> inlineElement)
|
||||
|
|
@ -305,24 +293,24 @@ crossedText = do
|
|||
pure $ Crossed content
|
||||
|
||||
-- Emphasis (Italic)
|
||||
emphasis :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
|
||||
emphasis :: (Logger m) => ParserTG s m InlineText
|
||||
emphasis = emphasisAsterisk <|> emphasisUnderscore
|
||||
|
||||
emphasisAsterisk :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
|
||||
emphasisAsterisk :: (Logger m) => ParserTG s m InlineText
|
||||
emphasisAsterisk = do
|
||||
char '*'
|
||||
content <- some (notFollowedBy (char '*') >> inlineElementNoAsterisk)
|
||||
char '*'
|
||||
pure $ Italic content
|
||||
|
||||
emphasisUnderscore :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
|
||||
emphasisUnderscore :: (Logger m) => ParserTG s m InlineText
|
||||
emphasisUnderscore = do
|
||||
char '_'
|
||||
content <- some inlineElementNoUnderscore
|
||||
char '_'
|
||||
pure $ Italic content
|
||||
|
||||
inlineElementNo :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => Char -> ParserTG s m InlineText
|
||||
inlineElementNo :: (Logger m) => Char -> ParserTG s m InlineText
|
||||
inlineElementNo c =
|
||||
choice
|
||||
[ try strong,
|
||||
|
|
@ -334,13 +322,11 @@ inlineElementNo c =
|
|||
plainTextNo [c]
|
||||
]
|
||||
|
||||
plainTextNo :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => [Char] -> ParserTG s m InlineText
|
||||
plainTextNo list = do
|
||||
plainTextNo' False list
|
||||
plainTextNo :: (Logger m) => [Char] -> ParserTG s m InlineText
|
||||
plainTextNo = plainTextNo' False
|
||||
|
||||
plainTextNo' :: (HasCallStack, Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => Bool -> [Char] -> ParserTG s m InlineText
|
||||
plainTextNo' :: (Logger m) => Bool -> [Char] -> ParserTG s m InlineText
|
||||
plainTextNo' block_whitespace disallow = do
|
||||
logDebug $ "base plain Text: " <> T.show block_whitespace <> " " <> T.show disallow
|
||||
firstChar <- noneOf (disallow <> if block_whitespace then " \t\r\n" else []) <?> "Plain Text Initial Disallow"
|
||||
remChars <- many $ notFollowedBy lineEnding *> plainTextCharNo disallow
|
||||
pure $ Text $ T.map wspHandler $ T.pack $ firstChar : remChars
|
||||
|
|
@ -348,14 +334,14 @@ plainTextNo' block_whitespace disallow = do
|
|||
wspHandler '\n' = ' '
|
||||
wspHandler c = c
|
||||
|
||||
inlineElementNoAsterisk :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
|
||||
inlineElementNoAsterisk :: (Logger m) => ParserTG s m InlineText
|
||||
inlineElementNoAsterisk = inlineElementNo '*'
|
||||
|
||||
inlineElementNoUnderscore :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
|
||||
inlineElementNoUnderscore :: (Logger m) => ParserTG s m InlineText
|
||||
inlineElementNoUnderscore = inlineElementNo '_'
|
||||
|
||||
-- Code Span
|
||||
codeSpan :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
|
||||
codeSpan :: (Logger m) => ParserTG s m InlineText
|
||||
codeSpan =
|
||||
choice
|
||||
[ try tripleBacktick,
|
||||
|
|
@ -378,7 +364,7 @@ codeSpan =
|
|||
pure $ InlineCode (T.pack content)
|
||||
|
||||
-- Image
|
||||
image :: (Logger m, Token s ~ Char, Stream s) => ParserTG s m InlineText
|
||||
image :: (Logger m) => ParserTG s m InlineText
|
||||
image = do
|
||||
char '!'
|
||||
char '['
|
||||
|
|
@ -388,7 +374,7 @@ image = do
|
|||
return $ Image {altText = alt, url = url, title = title}
|
||||
|
||||
-- Link
|
||||
link :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
|
||||
link :: (Logger m) => ParserTG s m InlineText
|
||||
link = do
|
||||
char '['
|
||||
content <- some (notFollowedBy (char ']') >> inlineElementNoBracket)
|
||||
|
|
@ -396,7 +382,7 @@ link = do
|
|||
(url, title) <- linkDestination
|
||||
pure $ Link content url title
|
||||
|
||||
inlineElementNoBracket :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
|
||||
inlineElementNoBracket :: (Logger m) => ParserTG s m InlineText
|
||||
inlineElementNoBracket =
|
||||
choice
|
||||
[ try strong,
|
||||
|
|
@ -407,7 +393,7 @@ inlineElementNoBracket =
|
|||
plainTextNoBracket
|
||||
]
|
||||
|
||||
linkDestination :: (Logger m, Token s ~ Char, Stream s) => ParserTG s m (Text, Maybe Text)
|
||||
linkDestination :: (Logger m) => ParserTG s m (Text, Maybe Text)
|
||||
linkDestination = directLink <|> referenceLink
|
||||
where
|
||||
directLink = do
|
||||
|
|
@ -424,7 +410,7 @@ linkDestination = directLink <|> referenceLink
|
|||
-- In a real implementation, you'd look up the reference
|
||||
pure (T.pack $ "[" ++ ref ++ "]", Nothing)
|
||||
|
||||
titleParser :: (Logger m, Token s ~ Char, Stream s) => ParserTG s m Text
|
||||
titleParser :: (Logger m) => ParserTG s m Text
|
||||
titleParser =
|
||||
T.pack
|
||||
<$> choice
|
||||
|
|
@ -434,44 +420,41 @@ titleParser =
|
|||
]
|
||||
|
||||
-- HTML Inline
|
||||
htmlInline :: (Logger m, Token s ~ Char, Stream s) => ParserTG s m InlineText
|
||||
htmlInline :: (Logger m) => ParserTG s m InlineText
|
||||
htmlInline = do
|
||||
start <- char '<'
|
||||
content <- manyTill anyChar (try $ char '>')
|
||||
return $ HTMLInline (T.pack (start : content ++ ">"))
|
||||
|
||||
-- Escaped Character
|
||||
escapedChar :: (Logger m, Token s ~ Char, Stream s) => ParserTG s m InlineText
|
||||
escapedChar :: (Logger m) => ParserTG s m InlineText
|
||||
escapedChar = do
|
||||
char '\\'
|
||||
c <- satisfy (\x -> x >= '!' && x <= '~')
|
||||
pure $ Text (T.singleton c)
|
||||
|
||||
-- Plain Text
|
||||
plainText :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
|
||||
plainText = plainTextNo' False [] <?> "Baseline Plain Text"
|
||||
plainText :: (Logger m) => ParserTG s m InlineText
|
||||
plainText = plainTextNo' True [] <?> "Baseline Plain Text"
|
||||
|
||||
plainTextBaseDisallow :: [Char]
|
||||
plainTextBaseDisallow = "[~`_*<"
|
||||
|
||||
plainTextCharNo :: (Logger m, Token s ~ Char, Stream s) => [Char] -> ParserTG s m Char
|
||||
plainTextCharNo :: (Logger m) => [Char] -> ParserTG s m Char
|
||||
plainTextCharNo additional = noneOf $ additional <> plainTextBaseDisallow
|
||||
|
||||
plainTextNoAsterisk :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
|
||||
plainTextNoAsterisk :: (Logger m) => ParserTG s m InlineText
|
||||
plainTextNoAsterisk = plainTextNo "*"
|
||||
|
||||
plainTextNoUnderscore :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
|
||||
plainTextNoUnderscore :: (Logger m) => ParserTG s m InlineText
|
||||
plainTextNoUnderscore = plainTextNo "_"
|
||||
|
||||
plainTextNoBracket :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
|
||||
plainTextNoBracket :: (Logger m) => ParserTG s m InlineText
|
||||
plainTextNoBracket = plainTextNo "[]"
|
||||
|
||||
-- Helper Parsers
|
||||
lineEnding :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m ()
|
||||
lineEnding :: (Logger m) => ParserTG s m ()
|
||||
lineEnding = void (try $ count 2 (try (string "\r\n") <|> try (string "\n") <|> string "\r")) <|> eof
|
||||
|
||||
lineEnding' :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m ()
|
||||
lineEnding' = void (try (string "\r\n") <|> try (string "\n") <|> string "\r") <|> eof
|
||||
|
||||
wsParser :: (Logger m, Token s ~ Char, Stream s) => ParserTG s m ()
|
||||
wsParser :: (Logger m) => ParserTG s m ()
|
||||
wsParser = void $ some (char ' ' <|> char '\t')
|
||||
|
|
|
|||
|
|
@ -22,15 +22,7 @@ import Text.Megaparsec
|
|||
main :: IO ()
|
||||
main = do
|
||||
cond <-
|
||||
checkParallel $
|
||||
Group
|
||||
"Parse Tests"
|
||||
[ ("all_compile", all_compiles),
|
||||
("header_and_paragraph", header_and_paragraph),
|
||||
("paragraph_and_header_and_paragraph", paragraph_and_header_and_paragraph),
|
||||
("bold_and_header_and_paragraph", bold_and_header_and_paragraph),
|
||||
("code_block", code_block)
|
||||
]
|
||||
checkParallel $ Group "Parse Tests" [("all_compile", all_compiles)]
|
||||
if cond
|
||||
then exitSuccess
|
||||
else exitFailure
|
||||
|
|
@ -43,79 +35,3 @@ all_compiles = property $ do
|
|||
case parsed of
|
||||
Right _ -> success
|
||||
Left e -> fail $ errorBundlePretty e
|
||||
|
||||
header_and_paragraph :: Property
|
||||
header_and_paragraph = property $ do
|
||||
header_text <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha
|
||||
header_level <- forAll $ Gen.int (Range.linear 1 6)
|
||||
paragraph_text <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha
|
||||
|
||||
let input = (T.pack $ take header_level $ repeat '#') <> header_text <> "\n\n" <> paragraph_text
|
||||
|
||||
let parsed = parse (Markdown.document :: ParsecT Void Text Identity IR.Document) "test_input" input
|
||||
|
||||
case parsed of
|
||||
Right (Doc [Heading (H {level = header_level, text = [Text (header_text)]}), Paragraph (P ([Text paragraph_text]))]) -> success
|
||||
Right tree -> fail $ "Incorrect syntax tree: " <> show tree
|
||||
Left e -> fail $ errorBundlePretty e
|
||||
|
||||
paragraph_and_header_and_paragraph :: Property
|
||||
paragraph_and_header_and_paragraph = property $ do
|
||||
paragraph1_text <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha
|
||||
header_text <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha
|
||||
header_level <- forAll $ Gen.int (Range.linear 1 6)
|
||||
paragraph2_text <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha
|
||||
|
||||
let input = paragraph1_text <> "\n\n" <> (T.pack $ take header_level $ repeat '#') <> header_text <> "\n\n" <> paragraph2_text
|
||||
|
||||
let parsed = parse (Markdown.document :: ParsecT Void Text Identity IR.Document) "test_input" input
|
||||
|
||||
case parsed of
|
||||
Right (Doc [Paragraph (P ([Text paragarph1_text])), Heading (H {level = header_level, text = [Text (header_text)]}), Paragraph (P ([Text paragraph2_text]))]) -> success
|
||||
Right tree -> fail $ "Incorrect syntax tree: " <> show tree
|
||||
Left e -> fail $ errorBundlePretty e
|
||||
|
||||
bold_and_header_and_paragraph :: Property
|
||||
bold_and_header_and_paragraph = property $ do
|
||||
bold_text <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha
|
||||
header_text <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha
|
||||
header_level <- forAll $ Gen.int (Range.linear 1 6)
|
||||
paragraph_text <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha
|
||||
|
||||
let input = "**" <> bold_text <> "**\n\n" <> (T.pack $ take header_level $ repeat '#') <> header_text <> "\n\n" <> paragraph_text
|
||||
|
||||
let parsed = parse (Markdown.document :: ParsecT Void Text Identity IR.Document) "test_input" input
|
||||
|
||||
case parsed of
|
||||
Right (Doc [Paragraph (P ([Bold [Text bold_text]])), Heading (H {level = header_level, text = [Text (header_text)]}), Paragraph (P ([Text paragraph_text]))]) -> success
|
||||
Right tree -> fail $ "Incorrect syntax tree: " <> show tree
|
||||
Left e -> fail $ errorBundlePretty e
|
||||
|
||||
code_block :: Property
|
||||
code_block = property $ do
|
||||
language <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha
|
||||
code <- forAll $ Gen.text (Range.linear 1 10) Gen.alpha
|
||||
let input = "```" <> language <> "\n" <> code <> "```"
|
||||
|
||||
let parsed = parse (Markdown.document :: ParsecT Void Text Identity IR.Document) "test_input" input
|
||||
|
||||
case parsed of
|
||||
Right (Doc [Code (C {language, code})]) -> success
|
||||
Right tree -> fail $ "Incorrect syntax tree: " <> show tree
|
||||
Left e -> fail $ errorBundlePretty e
|
||||
|
||||
-- from new writing learning
|
||||
-- Error case, joins block quotes toegether
|
||||
-- > [*Sic*](https://www.merriam-webster.com/dictionary/sic) usually appears in parentheses or brackets, sometimes with the letters in italics. In this context it means “intentionally so written.” On its own, *sic* means “so” or “thus” and can be found in phrases such as *sic transit gloria mundi* ("so passes away the glory of the world") and *sic semper tyrannis* ("thus ever to tyrants," the motto of the state of Virginia).
|
||||
--
|
||||
-- > What is denoted by *sic* is that the word or phrase that precedes it occurs in the original passage being quoted or name being used and was not introduced by the writer doing the quoting.
|
||||
--
|
||||
|
||||
-- from micro blogs
|
||||
-- Error case 2: made one bullet instead of two, happens for any number of items and probably applicable to numbered list as well
|
||||
-- - item 1
|
||||
-- - item 2
|
||||
|
||||
-- From weekly notes, doing a header after a unordered list causes it to be seens as an inline element
|
||||
--
|
||||
-- From all-projects, not sure if it's block or what causing HTML escapes to go haywire
|
||||
|
|
|
|||
Loading…
Reference in a new issue