Pagwin/psb
1
0
Fork 0
Code Issues 4 Pull requests Projects Releases Packages Wiki Activity

minor dev experience improvements

Browse source
This commit is contained in:
Pagwin 2025-11-25 13:37:05 -05:00
parent 9e9117db52
commit 66499505d6
No known key found for this signature in database
GPG key ID: 81137023740CA260
2 changed files with 106 additions and 89 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
app/Logger.hs
View file

@ -15,14 +15,14 @@ class (Monad m) => Logger m where
logInfo :: T.Text -> m () logInfo :: T.Text -> m ()
logDebug :: T.Text -> m () logDebug :: T.Text -> m ()
logIO :: T.Text -> IO () logIO :: T.Text -> T.Text -> IO ()
logIO = T.putStrLn logIO kind msg = T.putStrLn $ kind <> ": " <> msg
instance Logger IO where instance Logger IO where
logError = logIO logError = logIO "error"
logWarning = logIO logWarning = logIO "warning"
logInfo = logIO logInfo = logIO "info"
logDebug = logIO logDebug = logIO "debug"
logState :: (Monad m) => T.Text -> StateT T.Text m () logState :: (Monad m) => T.Text -> StateT T.Text m ()
logState msg = modify (<> msg <> "\n") logState msg = modify (<> msg <> "\n")

183
app/Markdown.hs
View file

@ -1,6 +1,7 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
-- (document, metadata) -- (document, metadata)
module Markdown (document, metadata) where module Markdown (document, metadata) where
@ -9,12 +10,14 @@ import Control.Applicative (many, optional, some, (<|>))
import Control.Monad (guard, void) import Control.Monad (guard, void)
import Data.Char (isAlpha) import Data.Char (isAlpha)
import Data.Functor.Identity (Identity) import Data.Functor.Identity (Identity)
import Data.String (IsString)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Void (Void) import Data.Void (Void)
import GHC.Stack (HasCallStack, callStack, prettyCallStack)
import IR import IR
import Logger (Logger (logDebug)) import Logger (Logger (logDebug))
import Text.Megaparsec (ParsecT, anySingle, anySingleBut, between, choice, count, eof, manyTill, notFollowedBy, satisfy, skipSome, try, (<?>)) import Text.Megaparsec (ParsecT, Stream, Token, Tokens, anySingle, anySingleBut, between, choice, count, eof, manyTill, notFollowedBy, satisfy, skipSome, try, (<?>))
import qualified Text.Megaparsec as MP import qualified Text.Megaparsec as MP
import Text.Megaparsec.Char (alphaNumChar, char, digitChar, string) import Text.Megaparsec.Char (alphaNumChar, char, digitChar, string)
import Utilities (tee) import Utilities (tee)
@ -25,39 +28,41 @@ type ParserT m = ParserTG T.Text m
type Parser = ParserT Identity type Parser = ParserT Identity
logP :: (Logger m, Show s) => ParserTG s m s -> ParserTG s m s logP :: (Logger m, Show v, Token s ~ Char, Stream s) => ParserTG s m v -> ParserTG s m v
logP = tee (logDebug . T.show) logP = tee (logDebug . T.show)
anyChar :: ParserTG s m Char anyChar :: (Token s ~ Char, Stream s) => ParserTG s m Char
anyChar = anySingle anyChar = anySingle
alphaNum :: ParserTG s m Char alphaNum :: (Token s ~ Char, Stream s) => ParserTG s m Char
alphaNum = alphaNumChar alphaNum = alphaNumChar
digit :: ParserTG s m Char digit :: (Token s ~ Char, Stream s) => ParserTG s m Char
digit = digitChar digit = digitChar
noneOf :: [Char] -> ParserTG s m Char noneOf :: (Token s ~ Char, Stream s) => [Char] -> ParserTG s m Char
noneOf = MP.noneOf noneOf = MP.noneOf
oneOf :: [Char] -> ParserTG s m Char oneOf :: (Token s ~ Char, Stream s) => [Char] -> ParserTG s m Char
oneOf = MP.oneOf oneOf = MP.oneOf
optionMaybe :: ParserTG s m a -> ParserTG s m (Maybe a) optionMaybe :: (Token s ~ Char, Stream s) => ParserTG s m a -> ParserTG s m (Maybe a)
optionMaybe = optional optionMaybe = optional
skipMany1 :: ParserTG s m a -> ParserTG s m () skipMany1 :: (Token s ~ Char, Stream s) => ParserTG s m a -> ParserTG s m ()
skipMany1 = skipSome skipMany1 = skipSome
metadata :: ParserTG s m Text metadata :: (Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m Text
metadata = bound *> fmap T.pack (many $ try (char '-' <* notFollowedBy (string "--")) <|> anySingleBut '-') <* bound metadata = bound *> fmap T.pack (many $ try (char '-' <* notFollowedBy (string "--")) <|> anySingleBut '-') <* bound
where where
bound = string "---" bound = string "---"
document :: (Logger m) => ParserTG s m Document document :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m Document
document = Doc <$> many element <* eof document = do
logDebug "document"
Doc <$> many element <* eof
element :: (Logger m) => ParserTG s m Element element :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m Element
element = element =
choice choice
[ try headingBlock <?> "Element Heading", [ try headingBlock <?> "Element Heading",
@ -73,19 +78,19 @@ element =
] ]
-- Blank lines (consumed but not stored) -- Blank lines (consumed but not stored)
blankLines :: (Logger m) => ParserTG s m Element blankLines :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m Element
blankLines = do blankLines = do
skipMany1 (blankLine *> notFollowedBy eof) skipMany1 (blankLine *> notFollowedBy eof)
element <|> fmap (const $ HTML HTMLTag {html_content = ""}) eof -- Parse the next element (or handle eof) element <|> fmap (const $ HTML HTMLTag {html_content = ""}) eof -- Parse the next element (or handle eof)
blankLine :: (Logger m) => ParserTG s m () blankLine :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m ()
blankLine = do blankLine = do
many (char ' ' <|> char '\t') many (char ' ' <|> char '\t')
lineEnding lineEnding
pure () pure ()
-- Heading Block -- Heading Block
headingBlock :: (Logger m) => ParserTG s m Element headingBlock :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m Element
headingBlock = do headingBlock = do
hashes <- some (char '#') <?> "Heading Hashes" hashes <- some (char '#') <?> "Heading Hashes"
let level = length hashes let level = length hashes
@ -95,25 +100,30 @@ headingBlock = do
pure $ Heading $ H level content pure $ Heading $ H level content
-- Fenced Code Block -- Fenced Code Block
fencedCodeBlock :: (Logger m) => ParserTG s m Element fencedCodeBlock :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m Element
fencedCodeBlock = do fencedCodeBlock = do
logDebug "fenced_coding_block"
fence <- string "```" <|> string "~~~" fence <- string "```" <|> string "~~~"
logDebug "fence"
lang <- optionMaybe languageInfo lang <- optionMaybe languageInfo
lineEnding logDebug "langInfo"
lineEnding'
logDebug "lineEnding"
codeLines <- manyTill codeLine (try $ string fence) codeLines <- manyTill codeLine (try $ string fence)
logDebug "lines"
pure $ Code $ C lang (T.pack $ unlines codeLines) pure $ Code $ C lang (T.pack $ unlines codeLines)
languageInfo :: (Logger m) => ParserTG s m Text languageInfo :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m Text
languageInfo = T.pack <$> some (alphaNum <|> char '-' <|> char '+' <|> char '.') languageInfo = T.pack <$> some (alphaNum <|> char '-' <|> char '+' <|> char '.')
codeLine :: (Logger m) => ParserTG s m String codeLine :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m String
codeLine = do codeLine = do
line <- many $ noneOf "\n\r" line <- many $ noneOf "\n\r"
lineEnding lineEnding'
pure line pure line
-- Indented Code Block -- Indented Code Block
indentedCodeBlock :: (Logger m) => ParserTG s m Element indentedCodeBlock :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m Element
indentedCodeBlock = do indentedCodeBlock = do
lines' <- some indentedLine lines' <- some indentedLine
pure $ Code $ C Nothing (T.pack $ unlines lines') pure $ Code $ C Nothing (T.pack $ unlines lines')
@ -125,7 +135,7 @@ indentedCodeBlock = do
pure line pure line
-- Blockquote Block -- Blockquote Block
blockquoteBlock :: (Logger m) => ParserTG s m Element blockquoteBlock :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m Element
blockquoteBlock = do blockquoteBlock = do
lines' <- some blockquoteLine lines' <- some blockquoteLine
pure $ BlockQuote $ Q (concat lines') pure $ BlockQuote $ Q (concat lines')
@ -137,7 +147,7 @@ blockquoteBlock = do
pure content pure content
-- Horizontal Rule Block -- Horizontal Rule Block
horizontalRuleBlock :: (Logger m) => ParserTG s m Element horizontalRuleBlock :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m Element
horizontalRuleBlock = do horizontalRuleBlock = do
choice choice
[ try (count 3 (char '*') >> many (char ' ' <|> char '*')), [ try (count 3 (char '*') >> many (char ' ' <|> char '*')),
@ -148,21 +158,21 @@ horizontalRuleBlock = do
pure HorizontalRule pure HorizontalRule
-- Unordered List Block -- Unordered List Block
unorderedListBlock :: (Logger m) => ParserTG s m Element unorderedListBlock :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m Element
unorderedListBlock = do unorderedListBlock = do
items <- some unorderedListItem items <- some unorderedListItem
pure $ List $ L Unordered items pure $ List $ L Unordered items
unorderedListItem :: (Logger m) => ParserTG s m ListItem unorderedListItem :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m ListItem
unorderedListItem = do unorderedListItem = do
oneOf "*-+" oneOf "*-+"
char ' ' <|> char '\t' char ' ' <|> char '\t'
content <- manyTill inlineElement (try lineEnding) content <- manyTill inlineElement (try lineEnding')
-- continuations <- many listContinuation -- continuations <- many listContinuation
children <- many (try indentedList) children <- many (try indentedList)
pure $ LI content children pure $ LI content children
listContinuation :: (Logger m) => ParserTG s m [InlineText] listContinuation :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m [InlineText]
listContinuation = do listContinuation = do
count 2 (char ' ' <|> char '\t') count 2 (char ' ' <|> char '\t')
many (char ' ' <|> char '\t') many (char ' ' <|> char '\t')
@ -172,35 +182,35 @@ listContinuation = do
pure content pure content
-- TODO: handle list indentation at all levels -- TODO: handle list indentation at all levels
indentedList :: (Logger m) => ParserTG s m List indentedList :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m List
indentedList = do indentedList = do
let n = 1 let n = 1
void $ count (4 * n) (char ' ') <|> count n (char '\t') void $ count (4 * n) (char ' ') <|> count n (char '\t')
choice [try indentedUnorderedList, indentedOrderedList] choice [try indentedUnorderedList, indentedOrderedList]
indentedUnorderedList :: (Logger m) => ParserTG s m List indentedUnorderedList :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m List
indentedUnorderedList = do indentedUnorderedList = do
items <- some (try $ indentedListItem (oneOf "*-+" >> void (char ' ' <|> char '\t'))) items <- some (try $ indentedListItem (oneOf "*-+" >> void (char ' ' <|> char '\t')))
pure $ L Unordered items pure $ L Unordered items
indentedOrderedList :: (Logger m) => ParserTG s m List indentedOrderedList :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m List
indentedOrderedList = do indentedOrderedList = do
items <- some (try $ indentedListItem (some digit >> char '.' >> void (char ' ' <|> char '\t'))) items <- some (try $ indentedListItem (some digit >> char '.' >> void (char ' ' <|> char '\t')))
pure $ L Ordered items pure $ L Ordered items
indentedListItem :: (Logger m) => ParserTG s m () -> ParserTG s m ListItem indentedListItem :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m () -> ParserTG s m ListItem
indentedListItem marker = do indentedListItem marker = do
marker marker
content <- manyTill inlineElement (try $ lineEnding <|> eof) content <- manyTill inlineElement (try $ lineEnding <|> eof)
pure $ LI content [] pure $ LI content []
-- Ordered List Block -- Ordered List Block
orderedListBlock :: (Logger m) => ParserTG s m Element orderedListBlock :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m Element
orderedListBlock = do orderedListBlock = do
items <- some orderedListItem items <- some orderedListItem
pure $ List $ L Ordered items pure $ List $ L Ordered items
orderedListItem :: (Logger m) => ParserTG s m ListItem orderedListItem :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m ListItem
orderedListItem = do orderedListItem = do
some digit some digit
char '.' char '.'
@ -211,33 +221,33 @@ orderedListItem = do
pure $ LI (content ++ concat continuations) children pure $ LI (content ++ concat continuations) children
-- HTML Block -- HTML Block
htmlBlock :: (Logger m) => ParserTG s m Element htmlBlock :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m Element
htmlBlock = do htmlBlock = do
char '<' char '<'
-- Capture the entire HTML block as raw text -- Capture the entire HTML block as raw text
rest <- manyTill anyChar (try $ char '>' >> lineEnding) rest <- manyTill anyChar (try $ char '>' >> lineEnding)
let content = '<' : rest let content = '<' : (rest <> ">")
return $ HTML $ HTMLTag (T.pack content) return $ HTML $ HTMLTag (T.pack content)
tagName :: (Logger m) => ParserTG s m String tagName :: (Logger m, Token s ~ Char, Stream s) => ParserTG s m String
tagName = do tagName = do
first <- satisfy isAlpha first <- satisfy isAlpha
rest <- many (alphaNum <|> char '-' <|> char ':') rest <- many (alphaNum <|> char '-' <|> char ':')
pure (first : rest) pure (first : rest)
attribute :: (Logger m) => ParserTG s m (Text, Maybe Text) attribute :: (Logger m, Token s ~ Char, Stream s) => ParserTG s m (Text, Maybe Text)
attribute = do attribute = do
name <- attributeName name <- attributeName
value <- optionMaybe (char '=' >> attributeValue) value <- optionMaybe (char '=' >> attributeValue)
pure (T.pack name, fmap T.pack value) pure (T.pack name, fmap T.pack value)
attributeName :: (Logger m) => ParserTG s m String attributeName :: (Logger m, Token s ~ Char, Stream s) => ParserTG s m String
attributeName = do attributeName = do
first <- satisfy isAlpha first <- satisfy isAlpha
rest <- many (alphaNum <|> char '-' <|> char ':') rest <- many (alphaNum <|> char '-' <|> char ':')
pure (first : rest) pure (first : rest)
attributeValue :: (Logger m) => ParserTG s m String attributeValue :: (Logger m, Token s ~ Char, Stream s) => ParserTG s m String
attributeValue = attributeValue =
choice choice
[ between (char '"') (char '"') (many $ anySingleBut '"'), [ between (char '"') (char '"') (many $ anySingleBut '"'),
@ -246,46 +256,48 @@ attributeValue =
] ]
-- Paragraph Block -- Paragraph Block
paragraphBlock :: (Logger m) => ParserTG s m Element paragraphBlock :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m Element
paragraphBlock = do paragraphBlock = do
content <- some inlineElement logDebug "paragraph"
content <- some (notFollowedBy lineEnding *> inlineElement)
lineEnding <|> eof lineEnding <|> eof
pure $ Paragraph $ P content pure $ Paragraph $ P content
-- Inline Elements -- Inline Elements
inlineElement :: (Logger m) => ParserTG s m InlineText inlineElement :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
inlineElement = inlineElement =
choice logDebug "inlineElement"
[ try strong <?> "Inline Strong Text", *> choice
try emphasis <?> "Inline Italic Text", [ try strong <?> "Inline Strong Text",
try crossedText <?> "Inline Crossed Text", try emphasis <?> "Inline Italic Text",
try codeSpan <?> "Inline Code", try crossedText <?> "Inline Crossed Text",
try image <?> "Inline Image", try codeSpan <?> "Inline Code",
try link <?> "Inline Link", try image <?> "Inline Image",
try htmlInline <?> "Inline HTML", try link <?> "Inline Link",
try escapedChar <?> "Escaped Character", try htmlInline <?> "Inline HTML",
plainText <?> "Inline Plain Text" try escapedChar <?> "Escaped Character",
] plainText <?> "Inline Plain Text"
]
-- Strong (Bold) -- Strong (Bold)
strong :: (Logger m) => ParserTG s m InlineText strong :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
strong = strongAsterisk <|> strongUnderscore strong = strongAsterisk <|> strongUnderscore
strongAsterisk :: (Logger m) => ParserTG s m InlineText strongAsterisk :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
strongAsterisk = do strongAsterisk = do
string "**" string "**"
content <- some (notFollowedBy (string "**") >> inlineElement) content <- some (notFollowedBy (string "**") >> inlineElement)
string "**" string "**"
pure $ Bold content pure $ Bold content
strongUnderscore :: (Logger m) => ParserTG s m InlineText strongUnderscore :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
strongUnderscore = do strongUnderscore = do
string "__" string "__"
content <- some (notFollowedBy (string "__") >> inlineElement) content <- some (notFollowedBy (string "__") >> inlineElement)
string "__" string "__"
pure $ Bold content pure $ Bold content
crossedText :: (Logger m) => ParserTG s m InlineText crossedText :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
crossedText = do crossedText = do
string "~~" string "~~"
content <- some (notFollowedBy (string "~~") >> inlineElement) content <- some (notFollowedBy (string "~~") >> inlineElement)
@ -293,24 +305,24 @@ crossedText = do
pure $ Crossed content pure $ Crossed content
-- Emphasis (Italic) -- Emphasis (Italic)
emphasis :: (Logger m) => ParserTG s m InlineText emphasis :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
emphasis = emphasisAsterisk <|> emphasisUnderscore emphasis = emphasisAsterisk <|> emphasisUnderscore
emphasisAsterisk :: (Logger m) => ParserTG s m InlineText emphasisAsterisk :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
emphasisAsterisk = do emphasisAsterisk = do
char '*' char '*'
content <- some (notFollowedBy (char '*') >> inlineElementNoAsterisk) content <- some (notFollowedBy (char '*') >> inlineElementNoAsterisk)
char '*' char '*'
pure $ Italic content pure $ Italic content
emphasisUnderscore :: (Logger m) => ParserTG s m InlineText emphasisUnderscore :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
emphasisUnderscore = do emphasisUnderscore = do
char '_' char '_'
content <- some inlineElementNoUnderscore content <- some inlineElementNoUnderscore
char '_' char '_'
pure $ Italic content pure $ Italic content
inlineElementNo :: (Logger m) => Char -> ParserTG s m InlineText inlineElementNo :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => Char -> ParserTG s m InlineText
inlineElementNo c = inlineElementNo c =
choice choice
[ try strong, [ try strong,
@ -322,11 +334,13 @@ inlineElementNo c =
plainTextNo [c] plainTextNo [c]
] ]
plainTextNo :: (Logger m) => [Char] -> ParserTG s m InlineText plainTextNo :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => [Char] -> ParserTG s m InlineText
plainTextNo = plainTextNo' False plainTextNo list = do
plainTextNo' False list
plainTextNo' :: (Logger m) => Bool -> [Char] -> ParserTG s m InlineText plainTextNo' :: (HasCallStack, Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => Bool -> [Char] -> ParserTG s m InlineText
plainTextNo' block_whitespace disallow = do 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" firstChar <- noneOf (disallow <> if block_whitespace then " \t\r\n" else []) <?> "Plain Text Initial Disallow"
remChars <- many $ notFollowedBy lineEnding *> plainTextCharNo disallow remChars <- many $ notFollowedBy lineEnding *> plainTextCharNo disallow
pure $ Text $ T.map wspHandler $ T.pack $ firstChar : remChars pure $ Text $ T.map wspHandler $ T.pack $ firstChar : remChars
@ -334,14 +348,14 @@ plainTextNo' block_whitespace disallow = do
wspHandler '\n' = ' ' wspHandler '\n' = ' '
wspHandler c = c wspHandler c = c
inlineElementNoAsterisk :: (Logger m) => ParserTG s m InlineText inlineElementNoAsterisk :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
inlineElementNoAsterisk = inlineElementNo '*' inlineElementNoAsterisk = inlineElementNo '*'
inlineElementNoUnderscore :: (Logger m) => ParserTG s m InlineText inlineElementNoUnderscore :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
inlineElementNoUnderscore = inlineElementNo '_' inlineElementNoUnderscore = inlineElementNo '_'
-- Code Span -- Code Span
codeSpan :: (Logger m) => ParserTG s m InlineText codeSpan :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
codeSpan = codeSpan =
choice choice
[ try tripleBacktick, [ try tripleBacktick,
@ -364,7 +378,7 @@ codeSpan =
pure $ InlineCode (T.pack content) pure $ InlineCode (T.pack content)
-- Image -- Image
image :: (Logger m) => ParserTG s m InlineText image :: (Logger m, Token s ~ Char, Stream s) => ParserTG s m InlineText
image = do image = do
char '!' char '!'
char '[' char '['
@ -374,7 +388,7 @@ image = do
return $ Image {altText = alt, url = url, title = title} return $ Image {altText = alt, url = url, title = title}
-- Link -- Link
link :: (Logger m) => ParserTG s m InlineText link :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
link = do link = do
char '[' char '['
content <- some (notFollowedBy (char ']') >> inlineElementNoBracket) content <- some (notFollowedBy (char ']') >> inlineElementNoBracket)
@ -382,7 +396,7 @@ link = do
(url, title) <- linkDestination (url, title) <- linkDestination
pure $ Link content url title pure $ Link content url title
inlineElementNoBracket :: (Logger m) => ParserTG s m InlineText inlineElementNoBracket :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
inlineElementNoBracket = inlineElementNoBracket =
choice choice
[ try strong, [ try strong,
@ -393,7 +407,7 @@ inlineElementNoBracket =
plainTextNoBracket plainTextNoBracket
] ]
linkDestination :: (Logger m) => ParserTG s m (Text, Maybe Text) linkDestination :: (Logger m, Token s ~ Char, Stream s) => ParserTG s m (Text, Maybe Text)
linkDestination = directLink <|> referenceLink linkDestination = directLink <|> referenceLink
where where
directLink = do directLink = do
@ -410,7 +424,7 @@ linkDestination = directLink <|> referenceLink
-- In a real implementation, you'd look up the reference -- In a real implementation, you'd look up the reference
pure (T.pack $ "[" ++ ref ++ "]", Nothing) pure (T.pack $ "[" ++ ref ++ "]", Nothing)
titleParser :: (Logger m) => ParserTG s m Text titleParser :: (Logger m, Token s ~ Char, Stream s) => ParserTG s m Text
titleParser = titleParser =
T.pack T.pack
<$> choice <$> choice
@ -420,41 +434,44 @@ titleParser =
] ]
-- HTML Inline -- HTML Inline
htmlInline :: (Logger m) => ParserTG s m InlineText htmlInline :: (Logger m, Token s ~ Char, Stream s) => ParserTG s m InlineText
htmlInline = do htmlInline = do
start <- char '<' start <- char '<'
content <- manyTill anyChar (try $ char '>') content <- manyTill anyChar (try $ char '>')
return $ HTMLInline (T.pack (start : content ++ ">")) return $ HTMLInline (T.pack (start : content ++ ">"))
-- Escaped Character -- Escaped Character
escapedChar :: (Logger m) => ParserTG s m InlineText escapedChar :: (Logger m, Token s ~ Char, Stream s) => ParserTG s m InlineText
escapedChar = do escapedChar = do
char '\\' char '\\'
c <- satisfy (\x -> x >= '!' && x <= '~') c <- satisfy (\x -> x >= '!' && x <= '~')
pure $ Text (T.singleton c) pure $ Text (T.singleton c)
-- Plain Text -- Plain Text
plainText :: (Logger m) => ParserTG s m InlineText plainText :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
plainText = plainTextNo' True [] <?> "Baseline Plain Text" plainText = plainTextNo' False [] <?> "Baseline Plain Text"
plainTextBaseDisallow :: [Char] plainTextBaseDisallow :: [Char]
plainTextBaseDisallow = "[~`_*<" plainTextBaseDisallow = "[~`_*<"
plainTextCharNo :: (Logger m) => [Char] -> ParserTG s m Char plainTextCharNo :: (Logger m, Token s ~ Char, Stream s) => [Char] -> ParserTG s m Char
plainTextCharNo additional = noneOf $ additional <> plainTextBaseDisallow plainTextCharNo additional = noneOf $ additional <> plainTextBaseDisallow
plainTextNoAsterisk :: (Logger m) => ParserTG s m InlineText plainTextNoAsterisk :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
plainTextNoAsterisk = plainTextNo "*" plainTextNoAsterisk = plainTextNo "*"
plainTextNoUnderscore :: (Logger m) => ParserTG s m InlineText plainTextNoUnderscore :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
plainTextNoUnderscore = plainTextNo "_" plainTextNoUnderscore = plainTextNo "_"
plainTextNoBracket :: (Logger m) => ParserTG s m InlineText plainTextNoBracket :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m InlineText
plainTextNoBracket = plainTextNo "[]" plainTextNoBracket = plainTextNo "[]"
-- Helper Parsers -- Helper Parsers
lineEnding :: (Logger m) => ParserTG s m () lineEnding :: (Logger m, Token s ~ Char, Stream s, IsString (Tokens s)) => ParserTG s m ()
lineEnding = void (try $ count 2 (try (string "\r\n") <|> try (string "\n") <|> string "\r")) <|> eof lineEnding = void (try $ count 2 (try (string "\r\n") <|> try (string "\n") <|> string "\r")) <|> eof
wsParser :: (Logger m) => ParserTG s m () 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 = void $ some (char ' ' <|> char '\t') wsParser = void $ some (char ' ' <|> char '\t')