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

on the start of trying to make parser more generic for no good reason

Browse source
This commit is contained in:
Pagwin 2025-11-22 20:59:57 -05:00
parent 219dce5abf
commit 9e9117db52
No known key found for this signature in database
GPG key ID: 81137023740CA260
6 changed files with 129 additions and 77 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
app/Logger.hs
View file

@ -8,8 +8,6 @@ import Control.Monad.Trans.Writer (WriterT, tell)
import Data.Functor.Identity (Identity) import Data.Functor.Identity (Identity)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.IO as T import qualified Data.Text.IO as T
import Development.Shake (Action)
import qualified Development.Shake as Shake
class (Monad m) => Logger m where class (Monad m) => Logger m where
logError :: T.Text -> m () logError :: T.Text -> m ()
@ -56,12 +54,6 @@ instance {-# OVERLAPPING #-} (Monad m) => Logger (WriterT String m) where
logInfo = tell . T.unpack . (<> "\n") logInfo = tell . T.unpack . (<> "\n")
logDebug = tell . T.unpack . (<> "\n") logDebug = tell . T.unpack . (<> "\n")
instance Logger Action where
logError = Shake.putError . T.unpack
logWarning = Shake.putWarn . T.unpack
logInfo = Shake.putInfo . T.unpack
logDebug = Shake.putLoud . T.unpack
instance Logger Identity where instance Logger Identity where
logError = const $ pure () logError = const $ pure ()
logWarning = const $ pure () logWarning = const $ pure ()

12
app/Logger/Shake.hs Normal file
View file

@ -0,0 +1,12 @@
module Logger.Shake where
import qualified Data.Text as T
import Development.Shake (Action)
import qualified Development.Shake as Shake
import Logger
instance Logger Action where
logError = Shake.putError . T.unpack
logWarning = Shake.putWarn . T.unpack
logInfo = Shake.putInfo . T.unpack
logDebug = Shake.putLoud . T.unpack

132
app/Markdown.hs
View file

@ -3,7 +3,7 @@
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
-- (document, metadata) -- (document, metadata)
module Markdown where module Markdown (document, metadata) where
import Control.Applicative (many, optional, some, (<|>)) import Control.Applicative (many, optional, some, (<|>))
import Control.Monad (guard, void) import Control.Monad (guard, void)
@ -19,43 +19,45 @@ 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)
type ParserT m = ParsecT Void String m type ParserTG = ParsecT Void
type ParserT m = ParserTG T.Text m
type Parser = ParserT Identity type Parser = ParserT Identity
logP :: (Logger m, Show s) => ParserT m s -> ParserT m s logP :: (Logger m, Show s) => ParserTG s m s -> ParserTG s m s
logP = tee (logDebug . T.show) logP = tee (logDebug . T.show)
anyChar :: ParserT m Char anyChar :: ParserTG s m Char
anyChar = anySingle anyChar = anySingle
alphaNum :: ParserT m Char alphaNum :: ParserTG s m Char
alphaNum = alphaNumChar alphaNum = alphaNumChar
digit :: ParserT m Char digit :: ParserTG s m Char
digit = digitChar digit = digitChar
noneOf :: [Char] -> ParserT m Char noneOf :: [Char] -> ParserTG s m Char
noneOf = MP.noneOf noneOf = MP.noneOf
oneOf :: [Char] -> ParserT m Char oneOf :: [Char] -> ParserTG s m Char
oneOf = MP.oneOf oneOf = MP.oneOf
optionMaybe :: ParserT m a -> ParserT m (Maybe a) optionMaybe :: ParserTG s m a -> ParserTG s m (Maybe a)
optionMaybe = optional optionMaybe = optional
skipMany1 :: ParserT m a -> ParserT m () skipMany1 :: ParserTG s m a -> ParserTG s m ()
skipMany1 = skipSome skipMany1 = skipSome
metadata :: ParserT m Text metadata :: 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) => ParserT m Document document :: (Logger m) => ParserTG s m Document
document = Doc <$> many element <* eof document = Doc <$> many element <* eof
element :: (Logger m) => ParserT m Element element :: (Logger m) => ParserTG s m Element
element = element =
choice choice
[ try headingBlock <?> "Element Heading", [ try headingBlock <?> "Element Heading",
@ -71,19 +73,19 @@ element =
] ]
-- Blank lines (consumed but not stored) -- Blank lines (consumed but not stored)
blankLines :: (Logger m) => ParserT m Element blankLines :: (Logger m) => 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) => ParserT m () blankLine :: (Logger m) => 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) => ParserT m Element headingBlock :: (Logger m) => 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
@ -93,7 +95,7 @@ headingBlock = do
pure $ Heading $ H level content pure $ Heading $ H level content
-- Fenced Code Block -- Fenced Code Block
fencedCodeBlock :: (Logger m) => ParserT m Element fencedCodeBlock :: (Logger m) => ParserTG s m Element
fencedCodeBlock = do fencedCodeBlock = do
fence <- string "```" <|> string "~~~" fence <- string "```" <|> string "~~~"
lang <- optionMaybe languageInfo lang <- optionMaybe languageInfo
@ -101,17 +103,17 @@ fencedCodeBlock = do
codeLines <- manyTill codeLine (try $ string fence) codeLines <- manyTill codeLine (try $ string fence)
pure $ Code $ C lang (T.pack $ unlines codeLines) pure $ Code $ C lang (T.pack $ unlines codeLines)
languageInfo :: (Logger m) => ParserT m Text languageInfo :: (Logger m) => ParserTG s m Text
languageInfo = T.pack <$> some (alphaNum <|> char '-' <|> char '+' <|> char '.') languageInfo = T.pack <$> some (alphaNum <|> char '-' <|> char '+' <|> char '.')
codeLine :: (Logger m) => ParserT m String codeLine :: (Logger m) => 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) => ParserT m Element indentedCodeBlock :: (Logger m) => 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')
@ -123,7 +125,7 @@ indentedCodeBlock = do
pure line pure line
-- Blockquote Block -- Blockquote Block
blockquoteBlock :: (Logger m) => ParserT m Element blockquoteBlock :: (Logger m) => ParserTG s m Element
blockquoteBlock = do blockquoteBlock = do
lines' <- some blockquoteLine lines' <- some blockquoteLine
pure $ BlockQuote $ Q (concat lines') pure $ BlockQuote $ Q (concat lines')
@ -135,7 +137,7 @@ blockquoteBlock = do
pure content pure content
-- Horizontal Rule Block -- Horizontal Rule Block
horizontalRuleBlock :: (Logger m) => ParserT m Element horizontalRuleBlock :: (Logger m) => ParserTG s m Element
horizontalRuleBlock = do horizontalRuleBlock = do
choice choice
[ try (count 3 (char '*') >> many (char ' ' <|> char '*')), [ try (count 3 (char '*') >> many (char ' ' <|> char '*')),
@ -146,12 +148,12 @@ horizontalRuleBlock = do
pure HorizontalRule pure HorizontalRule
-- Unordered List Block -- Unordered List Block
unorderedListBlock :: (Logger m) => ParserT m Element unorderedListBlock :: (Logger m) => 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) => ParserT m ListItem unorderedListItem :: (Logger m) => ParserTG s m ListItem
unorderedListItem = do unorderedListItem = do
oneOf "*-+" oneOf "*-+"
char ' ' <|> char '\t' char ' ' <|> char '\t'
@ -160,7 +162,7 @@ unorderedListItem = do
children <- many (try indentedList) children <- many (try indentedList)
pure $ LI content children pure $ LI content children
listContinuation :: (Logger m) => ParserT m [InlineText] listContinuation :: (Logger m) => 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')
@ -170,35 +172,35 @@ listContinuation = do
pure content pure content
-- TODO: handle list indentation at all levels -- TODO: handle list indentation at all levels
indentedList :: (Logger m) => ParserT m List indentedList :: (Logger m) => 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) => ParserT m List indentedUnorderedList :: (Logger m) => 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) => ParserT m List indentedOrderedList :: (Logger m) => 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) => ParserT m () -> ParserT m ListItem indentedListItem :: (Logger m) => 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) => ParserT m Element orderedListBlock :: (Logger m) => 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) => ParserT m ListItem orderedListItem :: (Logger m) => ParserTG s m ListItem
orderedListItem = do orderedListItem = do
some digit some digit
char '.' char '.'
@ -209,7 +211,7 @@ orderedListItem = do
pure $ LI (content ++ concat continuations) children pure $ LI (content ++ concat continuations) children
-- HTML Block -- HTML Block
htmlBlock :: (Logger m) => ParserT m Element htmlBlock :: (Logger m) => 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
@ -217,25 +219,25 @@ htmlBlock = do
let content = '<' : rest let content = '<' : rest
return $ HTML $ HTMLTag (T.pack content) return $ HTML $ HTMLTag (T.pack content)
tagName :: (Logger m) => ParserT m String tagName :: (Logger m) => 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) => ParserT m (Text, Maybe Text) attribute :: (Logger m) => 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) => ParserT m String attributeName :: (Logger m) => 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) => ParserT m String attributeValue :: (Logger m) => ParserTG s m String
attributeValue = attributeValue =
choice choice
[ between (char '"') (char '"') (many $ anySingleBut '"'), [ between (char '"') (char '"') (many $ anySingleBut '"'),
@ -244,14 +246,14 @@ attributeValue =
] ]
-- Paragraph Block -- Paragraph Block
paragraphBlock :: (Logger m) => ParserT m Element paragraphBlock :: (Logger m) => ParserTG s m Element
paragraphBlock = do paragraphBlock = do
content <- some inlineElement content <- some inlineElement
lineEnding <|> eof lineEnding <|> eof
pure $ Paragraph $ P content pure $ Paragraph $ P content
-- Inline Elements -- Inline Elements
inlineElement :: (Logger m) => ParserT m InlineText inlineElement :: (Logger m) => ParserTG s m InlineText
inlineElement = inlineElement =
choice choice
[ try strong <?> "Inline Strong Text", [ try strong <?> "Inline Strong Text",
@ -266,24 +268,24 @@ inlineElement =
] ]
-- Strong (Bold) -- Strong (Bold)
strong :: (Logger m) => ParserT m InlineText strong :: (Logger m) => ParserTG s m InlineText
strong = strongAsterisk <|> strongUnderscore strong = strongAsterisk <|> strongUnderscore
strongAsterisk :: (Logger m) => ParserT m InlineText strongAsterisk :: (Logger m) => 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) => ParserT m InlineText strongUnderscore :: (Logger m) => 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) => ParserT m InlineText crossedText :: (Logger m) => ParserTG s m InlineText
crossedText = do crossedText = do
string "~~" string "~~"
content <- some (notFollowedBy (string "~~") >> inlineElement) content <- some (notFollowedBy (string "~~") >> inlineElement)
@ -291,24 +293,24 @@ crossedText = do
pure $ Crossed content pure $ Crossed content
-- Emphasis (Italic) -- Emphasis (Italic)
emphasis :: (Logger m) => ParserT m InlineText emphasis :: (Logger m) => ParserTG s m InlineText
emphasis = emphasisAsterisk <|> emphasisUnderscore emphasis = emphasisAsterisk <|> emphasisUnderscore
emphasisAsterisk :: (Logger m) => ParserT m InlineText emphasisAsterisk :: (Logger m) => 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) => ParserT m InlineText emphasisUnderscore :: (Logger m) => 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 -> ParserT m InlineText inlineElementNo :: (Logger m) => Char -> ParserTG s m InlineText
inlineElementNo c = inlineElementNo c =
choice choice
[ try strong, [ try strong,
@ -320,10 +322,10 @@ inlineElementNo c =
plainTextNo [c] plainTextNo [c]
] ]
plainTextNo :: (Logger m) => [Char] -> ParserT m InlineText plainTextNo :: (Logger m) => [Char] -> ParserTG s m InlineText
plainTextNo = plainTextNo' False plainTextNo = plainTextNo' False
plainTextNo' :: (Logger m) => Bool -> [Char] -> ParserT m InlineText plainTextNo' :: (Logger m) => Bool -> [Char] -> ParserTG s m InlineText
plainTextNo' block_whitespace disallow = do plainTextNo' block_whitespace disallow = do
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
@ -332,14 +334,14 @@ plainTextNo' block_whitespace disallow = do
wspHandler '\n' = ' ' wspHandler '\n' = ' '
wspHandler c = c wspHandler c = c
inlineElementNoAsterisk :: (Logger m) => ParserT m InlineText inlineElementNoAsterisk :: (Logger m) => ParserTG s m InlineText
inlineElementNoAsterisk = inlineElementNo '*' inlineElementNoAsterisk = inlineElementNo '*'
inlineElementNoUnderscore :: (Logger m) => ParserT m InlineText inlineElementNoUnderscore :: (Logger m) => ParserTG s m InlineText
inlineElementNoUnderscore = inlineElementNo '_' inlineElementNoUnderscore = inlineElementNo '_'
-- Code Span -- Code Span
codeSpan :: (Logger m) => ParserT m InlineText codeSpan :: (Logger m) => ParserTG s m InlineText
codeSpan = codeSpan =
choice choice
[ try tripleBacktick, [ try tripleBacktick,
@ -362,7 +364,7 @@ codeSpan =
pure $ InlineCode (T.pack content) pure $ InlineCode (T.pack content)
-- Image -- Image
image :: (Logger m) => ParserT m InlineText image :: (Logger m) => ParserTG s m InlineText
image = do image = do
char '!' char '!'
char '[' char '['
@ -372,7 +374,7 @@ image = do
return $ Image {altText = alt, url = url, title = title} return $ Image {altText = alt, url = url, title = title}
-- Link -- Link
link :: (Logger m) => ParserT m InlineText link :: (Logger m) => ParserTG s m InlineText
link = do link = do
char '[' char '['
content <- some (notFollowedBy (char ']') >> inlineElementNoBracket) content <- some (notFollowedBy (char ']') >> inlineElementNoBracket)
@ -380,7 +382,7 @@ link = do
(url, title) <- linkDestination (url, title) <- linkDestination
pure $ Link content url title pure $ Link content url title
inlineElementNoBracket :: (Logger m) => ParserT m InlineText inlineElementNoBracket :: (Logger m) => ParserTG s m InlineText
inlineElementNoBracket = inlineElementNoBracket =
choice choice
[ try strong, [ try strong,
@ -391,7 +393,7 @@ inlineElementNoBracket =
plainTextNoBracket plainTextNoBracket
] ]
linkDestination :: (Logger m) => ParserT m (Text, Maybe Text) linkDestination :: (Logger m) => ParserTG s m (Text, Maybe Text)
linkDestination = directLink <|> referenceLink linkDestination = directLink <|> referenceLink
where where
directLink = do directLink = do
@ -408,7 +410,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) => ParserT m Text titleParser :: (Logger m) => ParserTG s m Text
titleParser = titleParser =
T.pack T.pack
<$> choice <$> choice
@ -418,41 +420,41 @@ titleParser =
] ]
-- HTML Inline -- HTML Inline
htmlInline :: (Logger m) => ParserT m InlineText htmlInline :: (Logger m) => 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) => ParserT m InlineText escapedChar :: (Logger m) => 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) => ParserT m InlineText plainText :: (Logger m) => ParserTG s m InlineText
plainText = plainTextNo' True [] <?> "Baseline Plain Text" plainText = plainTextNo' True [] <?> "Baseline Plain Text"
plainTextBaseDisallow :: [Char] plainTextBaseDisallow :: [Char]
plainTextBaseDisallow = "[~`_*<" plainTextBaseDisallow = "[~`_*<"
plainTextCharNo :: (Logger m) => [Char] -> ParserT m Char plainTextCharNo :: (Logger m) => [Char] -> ParserTG s m Char
plainTextCharNo additional = noneOf $ additional <> plainTextBaseDisallow plainTextCharNo additional = noneOf $ additional <> plainTextBaseDisallow
plainTextNoAsterisk :: (Logger m) => ParserT m InlineText plainTextNoAsterisk :: (Logger m) => ParserTG s m InlineText
plainTextNoAsterisk = plainTextNo "*" plainTextNoAsterisk = plainTextNo "*"
plainTextNoUnderscore :: (Logger m) => ParserT m InlineText plainTextNoUnderscore :: (Logger m) => ParserTG s m InlineText
plainTextNoUnderscore = plainTextNo "_" plainTextNoUnderscore = plainTextNo "_"
plainTextNoBracket :: (Logger m) => ParserT m InlineText plainTextNoBracket :: (Logger m) => ParserTG s m InlineText
plainTextNoBracket = plainTextNo "[]" plainTextNoBracket = plainTextNo "[]"
-- Helper Parsers -- Helper Parsers
lineEnding :: (Logger m) => ParserT m () lineEnding :: (Logger m) => 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) => ParserT m () wsParser :: (Logger m) => ParserTG s m ()
wsParser = void $ some (char ' ' <|> char '\t') wsParser = void $ some (char ' ' <|> char '\t')

37
app/Tests/Markdown/Parse.hs Normal file
View file

@ -0,0 +1,37 @@
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Control.Monad.Trans.Class (MonadTrans (lift))
import Data.Either (isRight)
import Data.Functor.Identity (Identity (Identity))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Data.Void (Void)
import Debug.Trace (traceShow)
import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import IR
import Markdown
import qualified Markdown
import System.Exit (exitFailure, exitSuccess)
import Text.Megaparsec
main :: IO ()
main = do
cond <-
checkParallel $ Group "Parse Tests" [("all_compile", all_compiles)]
if cond
then exitSuccess
else exitFailure
all_compiles :: Property
all_compiles = property $ do
xs <- forAll $ Gen.text (Range.linear 0 10) Gen.ascii
annotate $ T.unpack xs
let parsed = parse (Markdown.document :: ParsecT Void Text Identity IR.Document) "test_input" xs
case parsed of
Right _ -> success
Left e -> fail $ errorBundlePretty e

4
app/Utilities/Action.hs
View file

@ -20,7 +20,7 @@ import Types
markdownToHtml :: (FromJSON a) => FilePath -> Action (a, Text) markdownToHtml :: (FromJSON a) => FilePath -> Action (a, Text)
markdownToHtml filePath = do markdownToHtml filePath = do
content <- Shake.readFile' filePath content <- Shake.readFile' filePath
let parse = runIdentity $ runParserT (liftA2 (,) Markdown.metadata Markdown.document) filePath content let parse = runIdentity $ runParserT (liftA2 (,) Markdown.metadata Markdown.document) filePath $ T.pack content
let (metadataText, document) = case parse of let (metadataText, document) = case parse of
Right (a, b) -> (a, b) Right (a, b) -> (a, b)
Left e -> error $ errorBundlePretty e Left e -> error $ errorBundlePretty e
@ -33,7 +33,7 @@ markdownToHtml filePath = do
markdownToPost :: FilePath -> Action Post markdownToPost :: FilePath -> Action Post
markdownToPost path = do markdownToPost path = do
content <- Shake.readFile' path content <- Shake.readFile' path
let parse = runIdentity $ runParserT Markdown.metadata path content let parse = runIdentity $ runParserT Markdown.metadata path $ T.pack content
let postData = case parse of let postData = case parse of
Right p -> p Right p -> p
Left e -> error $ errorBundlePretty e Left e -> error $ errorBundlePretty e

13
psb.cabal
View file

@ -22,6 +22,15 @@ build-type: Simple
common warnings common warnings
ghc-options: -Wall ghc-options: -Wall
test-suite test-markdown-parse
hs-source-dirs: app
type: exitcode-stdio-1.0
main-is: Tests/Markdown/Parse.hs
build-depends: base >=4.17.2.1, text >= 2.1.2, megaparsec >= 9.7.0, transformers >= 0.6.2, hedgehog >= 1.7, time
default-extensions: ApplicativeDo DataKinds NamedFieldPuns DerivingVia LambdaCase TypeApplications DeriveGeneric OverloadedRecordDot NamedFieldPuns DuplicateRecordFields DisambiguateRecordFields FlexibleInstances
other-modules: IR Logger Markdown Utilities
executable psb executable psb
-- Import common warning flags. -- Import common warning flags.
import: warnings import: warnings
@ -29,13 +38,13 @@ executable psb
-- .hs or .lhs file containing the Main module. -- .hs or .lhs file containing the Main module.
main-is: Main.hs main-is: Main.hs
other-modules: Config Utilities Utilities.FilePath Utilities.Action Templates Types IR Markdown Restruct HTML Logger other-modules: Config Utilities Utilities.FilePath Utilities.Action Templates Types IR Markdown Restruct HTML Logger Logger.Shake
default-extensions: ApplicativeDo DataKinds NamedFieldPuns DerivingVia LambdaCase TypeApplications DeriveGeneric OverloadedRecordDot NamedFieldPuns DuplicateRecordFields DisambiguateRecordFields FlexibleInstances default-extensions: ApplicativeDo DataKinds NamedFieldPuns DerivingVia LambdaCase TypeApplications DeriveGeneric OverloadedRecordDot NamedFieldPuns DuplicateRecordFields DisambiguateRecordFields FlexibleInstances
-- Other library packages from which modules are imported. -- Other library packages from which modules are imported.
-- https://hackage.haskell.org/package/texmath -- https://hackage.haskell.org/package/texmath
build-depends: base >=4.17.2.1, mustache >=2.4.2, shake >= 0.19.8, deriving-aeson >= 0.2.9, aeson, text >= 2.1.2, time, unordered-containers, yaml, megaparsec >= 9.7.0, transformers >= 0.6.2 build-depends: base >=4.17.2.1, mustache >=2.4.2, shake >= 0.19.8, deriving-aeson >= 0.2.9, aeson, text >= 2.1.2, time, unordered-containers, yaml, megaparsec >= 9.7.0, transformers >= 0.6.2
--parsec >= 3.1.18.0 --parsec >= 3.1.18.0
-- Directories containing source files. -- Directories containing source files.