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

Compare commits

base: Pagwin:0f356e4d5e048a603443cfcca9e8d5a698a54e35
Branches Tags
Pagwin:main
Pagwin:v2
Pagwin:v1.1
Pagwin:v1
..
compare: Pagwin:85ce3ee34a93f0b072a608d1d909ca0b924c48d8
Branches Tags
Pagwin:main
Pagwin:v2
Pagwin:v1.1
Pagwin:v1

No commits in common. "0f356e4d5e048a603443cfcca9e8d5a698a54e35" and "85ce3ee34a93f0b072a608d1d909ca0b924c48d8" have entirely different histories.
0f356e4d5e ... 85ce3ee34a

11 changed files with 741 additions and 2683 deletions
Show stats Expand all files Collapse all files

2
.gitignore vendored
View file

@ -1,4 +1,2 @@
dist-newstyle
.shake
.claude
.serena

11
psb.cabal
View file

@ -30,15 +30,14 @@ library
exposed-modules: Djot Markdown HTML Logger IR Logger.Shake Psb.Main Utilities Utilities.FilePath Utilities.Action Utilities.Javascript Utilities.CSS Templates Types Config Utilities.Bundling
other-modules: Utilities.Parsing
build-depends: base, 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, bytestring
default-extensions: ApplicativeDo DataKinds NamedFieldPuns DerivingVia LambdaCase TypeApplications DeriveGeneric OverloadedRecordDot NamedFieldPuns DuplicateRecordFields DisambiguateRecordFields FlexibleInstances
default-extensions: ApplicativeDo DataKinds NamedFieldPuns DerivingVia LambdaCase TypeApplications DeriveGeneric OverloadedRecordDot OverloadedRecordUpdate NamedFieldPuns DuplicateRecordFields DisambiguateRecordFields FlexibleInstances
test-suite tests
test-suite test-markdown-parse
hs-source-dirs: tests
type: exitcode-stdio-1.0
main-is: Main.hs
other-modules: Test.Gen, Test.Gen.Document, Test.Harness, Markdown.Parse, Djot.Parse
build-depends: base, text, megaparsec, transformers, QuickCheck, tasty, tasty-quickcheck, time, psb
main-is: Markdown/Parse.hs
build-depends: base, text, megaparsec, transformers, hedgehog, time, psb
default-extensions: ApplicativeDo DataKinds NamedFieldPuns DerivingVia LambdaCase TypeApplications DeriveGeneric OverloadedRecordDot NamedFieldPuns DuplicateRecordFields DisambiguateRecordFields FlexibleInstances
default-language: Haskell2010

1427
src/Djot.hs
View file

File diff suppressed because it is too large Load diff

57
src/IR.hs
View file

@ -4,7 +4,7 @@ import Control.Applicative ((<|>))
import Data.Text
newtype Document = Doc [Element]
deriving (Show, Eq)
deriving (Show)
data Element
= Heading Heading Attrs
@ -25,7 +25,7 @@ data Element
| RawBlock RawBlock Attrs
| TaskList TaskList Attrs
| ReferenceDefinition RefDef
deriving (Show, Eq)
deriving (Show)
-- Removed: BlankLine
@ -33,37 +33,37 @@ data Heading = H
{ level :: Int,
text :: [InlineText]
}
deriving (Show, Eq)
deriving (Show)
data Code = C
{ language :: Maybe Text,
code :: Text
}
deriving (Show, Eq)
deriving (Show)
newtype BlockQuote = Q [Element] deriving (Show, Eq)
newtype BlockQuote = Q [Element] deriving (Show)
newtype ListItem = LI
-- children are just more elements
{ content :: [Element] -- Flatten continuations into here
}
deriving (Show, Eq)
deriving (Show)
data ListType = Ordered {start_number :: Maybe Int, style :: Maybe Text} | Unordered {style :: Maybe Text} deriving (Show, Eq)
data ListType = Ordered {start_number :: Maybe Int, style :: Maybe Text} | Unordered {style :: Maybe Text} deriving (Show)
data List = L
{ list_type :: ListType,
items :: [ListItem]
}
deriving (Show, Eq)
deriving (Show)
newtype HTML
= HTMLTag
{ html_content :: Text
}
deriving (Show, Eq)
deriving (Show)
newtype Paragraph = P [InlineText] deriving (Show, Eq)
newtype Paragraph = P [InlineText] deriving (Show)
data InlineText
= Text Text -- Combined Normal and Escaped
@ -90,13 +90,6 @@ data InlineText
title :: Maybe Text,
misc_attrs :: Attrs
}
| -- the image equivalent of ReferenceLink, url comes from a RefDef with a
-- matching label
ReferenceImage
{ altText :: Text,
label :: Text,
attrs :: Attrs
}
| -- Markdown only DJOT uses RawInline
HTMLInline {inline_html_content :: Text}
| Superscript [InlineText] Attrs
@ -110,14 +103,14 @@ data InlineText
| RawInline RawInline Attrs
| Span [InlineText] Attrs
| LineBreak
deriving (Show, Eq)
deriving (Show)
data Attrs = Attrs
{ attrId :: Maybe Text,
attrClasses :: [Text],
attrKV :: [(Text, Text)]
}
deriving (Show, Eq)
deriving (Show)
instance Semigroup Attrs where
a <> b =
@ -133,17 +126,17 @@ instance Monoid Attrs where
data Math
= InlineLaTeX Text
| BlockLaTeX Text
deriving (Show, Eq)
deriving (Show)
data Alignment = AlignLeft | AlignRight | AlignCenter | AlignDefault
deriving (Show, Eq)
deriving (Show)
newtype TableCell = TC
{ cellContent :: [InlineText]
}
deriving (Show, Eq)
deriving (Show)
newtype TableRow = TR [TableCell] deriving (Show, Eq)
newtype TableRow = TR [TableCell] deriving (Show)
data Table = T
{ tableCaption :: Maybe [InlineText],
@ -151,43 +144,43 @@ data Table = T
tableBody :: [TableRow],
columnAlignments :: Maybe [Alignment]
}
deriving (Show, Eq)
deriving (Show)
newtype DescriptionList = DL {items :: [DefinitionItem]} deriving (Show, Eq)
newtype DescriptionList = DL {items :: [DefinitionItem]} deriving (Show)
data DefinitionItem = Def
{ defTitle :: [InlineText],
defContent :: [Element]
}
deriving (Show, Eq)
deriving (Show)
data Footnote = F {label :: Text, content :: [Element]} deriving (Show, Eq)
data Footnote = F {label :: Text, content :: [Element]} deriving (Show)
newtype TaskList = TL {items :: [Task]} deriving (Show, Eq)
newtype TaskList = TL {items :: [Task]} deriving (Show)
data Task = Ta
{ checked :: Bool,
content :: [Element]
}
deriving (Show, Eq)
deriving (Show)
data RawInline = RI
{ format :: Text,
content :: Text
}
deriving (Show, Eq)
deriving (Show)
data RawBlock = RB
{ format :: Text,
content :: Text
}
deriving (Show, Eq)
deriving (Show)
data RefDef = RD
{ label :: Text,
link :: Text
}
deriving (Show, Eq)
deriving (Show)
-- for processing math
-- https://hackage.haskell.org/package/typst-0.6.1/docs/Typst-Parse.html#v:parseTypst

18
src/Markdown.hs
View file

@ -45,15 +45,7 @@ element =
try htmlBlock <?> "HTML Block",
paragraphBlock <?> "Paragarph"
]
-- a block is normally followed by a blank line or the end of input, but a
-- block that ends without one is the next block's problem rather than a
-- parse error for the whole document. requiring the ending here turned
-- "- a\n:" into a hard failure, because listItem has already eaten the
-- newline that blockEnding wants and the consumed input escapes document's
-- many. the try matters for the same reason optional isn't enough on its
-- own, blockEnding can consume one line ending before finding out there is
-- no second one.
<* optional (try blockEnding)
<* blockEnding
lineEnding :: (Logger m, Characters s, HasCallStack) => Parser s m ()
lineEnding = {-logCallStack *>-} ((try eof) <|> void newline)
@ -145,7 +137,7 @@ fencedCodeBlock = between (string "```") (string "```") $ do
language' <- T.pack <$> (many (notFollowedBy lineEnding *> anySingle))
lineEnding
code <- T.pack <$> (many ((notFollowedBy $ string "```") *> anySingle))
let language = if language' == "" then Nothing else Just language'
let language = if language' == "" then Just language' else Nothing
pure $ Code (C {language, code}) mempty
blockquoteBlock :: (Logger m, Characters s) => Parser s m Element
@ -178,11 +170,7 @@ listBlock list_type prefix child_parser_factory nest_level = do
optional ((notFollowedBy blockEnding) *> lineEnding)
-- the try is load bearing, optional only recovers from a failure that
-- consumed nothing and the child parser eats the next item's indentation
-- before finding out it belongs to this list's level rather than the
-- child's
child <- optional $ try $ child_parser_factory $ nest_level + 1
child <- optional $ child_parser_factory $ nest_level + 1
case child of
Just c -> pure $ LI {content = [Transparent content, List c mempty]}

706
tests/Djot/Parse.hs
View file

@ -1,706 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
-- | Property tests for the djot parser.
--
-- The expectations here are written from the djot syntax reference
-- (<https://github.com/jgm/djot/blob/master/doc/syntax.html>) and `IR`, not
-- from what the parser currently does. A failure therefore means one of three
-- things: the parser disagrees with the reference, the reference was read
-- wrongly, or the IR has no faithful way to represent what the reference asks
-- for. The comment on each property says which rule it comes from so the first
-- can be told apart from the second.
--
-- Two things the reference leaves open are deliberately not asserted on:
--
-- * headings with more than six @#@ characters, the reference gives no
-- maximum level
-- * whether a space next to a verbatim delimiter is stripped in general or
-- only when the content itself starts or ends with a backtick; only the
-- unambiguous backtick case is tested
module Djot.Parse (tests) where
import qualified Data.Text as T
import IR
import Test.Gen (AlphaNumText (..), AsciiText (..), DjotText (..), EscapedText (..), HeaderLevel (..), UrlText (..), VerbatimText (..))
import Test.Gen.Document (DocSpec, djotSyntax, expected, render)
import Test.Harness (djotDocument, shouldParse, shouldParseTo)
import Test.QuickCheck (Arbitrary (arbitrary, shrink), Gen, Property, chooseInt, counterexample, elements)
import Test.QuickCheck.Monadic (monadicIO)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (testProperty)
tests :: TestTree
tests =
testGroup
"Djot"
[ testGroup
"inline"
[ testProperty "emphasis_delimiters" emphasis_delimiters,
testProperty "braced_emphasis_delimiters" braced_emphasis_delimiters,
testProperty "opener_may_not_be_followed_by_space" opener_may_not_be_followed_by_space,
testProperty "closer_may_not_be_preceded_by_space" closer_may_not_be_preceded_by_space,
testProperty "highlight_insert_delete" highlight_insert_delete,
testProperty "verbatim_is_literal" verbatim_is_literal,
testProperty "verbatim_fences_match_in_length" verbatim_fences_match_in_length,
testProperty "verbatim_may_hold_a_backtick" verbatim_may_hold_a_backtick,
testProperty "unclosed_verbatim_runs_to_the_end" unclosed_verbatim_runs_to_the_end,
testProperty "raw_inline" raw_inline,
testProperty "inline_math" inline_math,
testProperty "display_math" display_math,
testProperty "inline_link" inline_link,
testProperty "reference_link" reference_link,
testProperty "empty_reference_label_is_the_text" empty_reference_label_is_the_text,
testProperty "inline_image" inline_image,
testProperty "reference_image" reference_image,
testProperty "empty_image_label_is_the_alt_text" empty_image_label_is_the_alt_text,
testProperty "autolink_url" autolink_url,
testProperty "autolink_email" autolink_email,
testProperty "span_takes_attributes" span_takes_attributes,
testProperty "attributes_attach_to_the_element" attributes_attach_to_the_element,
testProperty "attributes_stack" attributes_stack,
testProperty "footnote_reference" footnote_reference,
testProperty "symbol" symbol,
testProperty "escaped_punctuation_is_literal" escaped_punctuation_is_literal,
testProperty "backslash_space_is_a_nonbreaking_space" backslash_space_is_a_nonbreaking_space,
testProperty "backslash_newline_is_a_hard_break" backslash_newline_is_a_hard_break,
testProperty "ellipsis" ellipsis,
testProperty "en_dash" en_dash,
testProperty "em_dash" em_dash,
testProperty "smart_quotes" smart_quotes
],
testGroup
"block"
[ testProperty "all_compile" all_compile,
testProperty "heading_levels" heading_levels,
testProperty "paragraphs_split_on_blank_lines" paragraphs_split_on_blank_lines,
testProperty "block_quote_holds_blocks" block_quote_holds_blocks,
testProperty "thematic_break" thematic_break,
testProperty "code_block_with_language" code_block_with_language,
testProperty "code_block_without_language" code_block_without_language,
testProperty "closing_fence_may_be_longer" closing_fence_may_be_longer,
testProperty "raw_block" raw_block,
testProperty "div_block" div_block,
testProperty "bullet_markers" bullet_markers,
testProperty "ordered_markers" ordered_markers,
testProperty "tight_list_items_are_unwrapped" tight_list_items_are_unwrapped,
testProperty "loose_list_items_keep_paragraphs" loose_list_items_keep_paragraphs,
testProperty "nested_list" nested_list,
testProperty "task_list" task_list,
testProperty "definition_list" definition_list,
testProperty "table" table,
testProperty "table_caption" table_caption,
testProperty "footnote_definition" footnote_definition,
testProperty "reference_definition" reference_definition,
testProperty "block_attributes" block_attributes,
testProperty "document_round_trip" document_round_trip
]
]
--------------------------------------------------------------------------------
-- helpers
--------------------------------------------------------------------------------
parses :: T.Text -> Document -> Property
parses source tree =
counterexample (T.unpack source) $ monadicIO $ shouldParseTo djotDocument source tree
paragraph :: [InlineText] -> Document
paragraph content = Doc [Paragraph (P content) mempty]
-- | Inline constructs are checked inside a paragraph that starts with a plain
-- word. Several of the delimiters (@*@, @-@, @:@, @[@, @{@) mean something else
-- entirely in the first column of a line, and that is the block layer's job to
-- test, not the inline layer's.
inlineIs :: T.Text -> [InlineText] -> Property
inlineIs source content = parses ("x " <> source) (paragraph (mergeText (Text "x " : content)))
-- | For the cases where the whole paragraph, prefix included, is one text node.
literalIs :: T.Text -> T.Text -> Property
literalIs source text = inlineIs source [Text text]
-- | Adjacent text is one node, so an expectation that gained a prefix word has
-- to be merged the same way the parser merges.
mergeText :: [InlineText] -> [InlineText]
mergeText (Text a : Text b : rest) = mergeText (Text (a <> b) : rest)
mergeText (element : rest) = element : mergeText rest
mergeText [] = []
item :: T.Text -> ListItem
item content = LI {content = [Transparent [Text content]]}
classOf :: T.Text -> Attrs
classOf name = Attrs {attrId = Nothing, attrClasses = [name], attrKV = []}
--------------------------------------------------------------------------------
-- inline: emphasis
--------------------------------------------------------------------------------
-- | "Emphasis is delimited by @_@ characters, strong by @*@ [...] Superscript
-- is delimited by @^@ characters, subscript by @~@."
newtype Delimiter = Delimiter Char
deriving (Show)
instance Arbitrary Delimiter where
arbitrary = Delimiter <$> elements "*_^~"
shrink _ = []
construct :: Char -> [InlineText] -> Attrs -> InlineText
construct '*' = Bold
construct '_' = Italic
construct '^' = Superscript
construct _ = Subscript
emphasis_delimiters :: Delimiter -> AlphaNumText -> Property
emphasis_delimiters (Delimiter c) (AlphaNumText t) =
inlineIs (d <> t <> d) [construct c [Text t] mempty]
where
d = T.singleton c
-- | "Curly braces may be used, but are not required", and for @{_@ / @_}@ they
-- are what lets the delimiters sit next to whitespace.
braced_emphasis_delimiters :: Delimiter -> AlphaNumText -> Property
braced_emphasis_delimiters (Delimiter c) (AlphaNumText t) =
inlineIs ("{" <> d <> t <> d <> "}") [construct c [Text t] mempty]
where
d = T.singleton c
-- | "Cannot open if directly followed by whitespace."
opener_may_not_be_followed_by_space :: Delimiter -> AlphaNumText -> Property
opener_may_not_be_followed_by_space (Delimiter c) (AlphaNumText t) =
literalIs (d <> " " <> t <> d) (d <> " " <> t <> d)
where
d = T.singleton c
-- | "Cannot close if directly preceded by whitespace."
closer_may_not_be_preceded_by_space :: Delimiter -> AlphaNumText -> Property
closer_may_not_be_preceded_by_space (Delimiter c) (AlphaNumText t) =
literalIs (d <> t <> " " <> d) (d <> t <> " " <> d)
where
d = T.singleton c
-- | "@{=@ and @=}@" for highlight, "@{+@ and @+}@" for insert, "@{-@ and @-}@"
-- for delete; for these the braces are mandatory.
newtype BracedMarker = BracedMarker Char
deriving (Show)
instance Arbitrary BracedMarker where
arbitrary = BracedMarker <$> elements "=+-"
shrink _ = []
highlight_insert_delete :: BracedMarker -> AlphaNumText -> Property
highlight_insert_delete (BracedMarker c) (AlphaNumText t) =
inlineIs ("{" <> d <> t <> d <> "}") [wrap [Text t] mempty]
where
d = T.singleton c
wrap = case c of
'=' -> Highlighted
'+' -> Insert
_ -> Crossed
--------------------------------------------------------------------------------
-- inline: verbatim, raw, math
--------------------------------------------------------------------------------
-- | "Content is treated literally, no escapes are allowed."
verbatim_is_literal :: VerbatimText -> Property
verbatim_is_literal (VerbatimText t) = inlineIs ("`" <> t <> "`") [InlineCode t mempty]
-- | "Opening and closing backticks must match in length."
verbatim_fences_match_in_length :: FenceLength -> VerbatimText -> Property
verbatim_fences_match_in_length (FenceLength n) (VerbatimText t) =
inlineIs (fence <> t <> fence) [InlineCode t mempty]
where
fence = T.replicate n "`"
newtype FenceLength = FenceLength Int
deriving (Show)
instance Arbitrary FenceLength where
arbitrary = FenceLength <$> chooseInt (1, 5)
shrink (FenceLength n) = FenceLength <$> [1 .. n - 1]
-- | "If the content starts or ends with a backtick character, a single space is
-- removed between the opening or closing backticks and the content." A longer
-- fence plus that space is the only way to write a leading backtick.
verbatim_may_hold_a_backtick :: AlphaNumText -> Property
verbatim_may_hold_a_backtick (AlphaNumText t) =
inlineIs ("`` `" <> t <> " ``") [InlineCode ("`" <> t) mempty]
-- | "If no closing backticks are found, the verbatim span extends to the end of
-- the [...] text."
unclosed_verbatim_runs_to_the_end :: VerbatimText -> Property
unclosed_verbatim_runs_to_the_end (VerbatimText t) =
inlineIs ("`" <> t) [InlineCode t mempty]
-- | "A verbatim span followed immediately by @{=FORMAT}@ is raw content."
raw_inline :: AlphaNumText -> VerbatimText -> Property
raw_inline (AlphaNumText format) (VerbatimText t) =
inlineIs ("`" <> t <> "`{=" <> format <> "}") [RawInline (RI {format, content = t}) mempty]
-- | "Put the math in a verbatim span and prefix it with @$@ (for inline math)."
inline_math :: VerbatimText -> Property
inline_math (VerbatimText t) =
inlineIs ("$`" <> t <> "`") [Math (InlineLaTeX t) mempty]
-- | "[...] or @$$@ (for display math)."
display_math :: VerbatimText -> Property
display_math (VerbatimText t) =
inlineIs ("$$`" <> t <> "`") [Math (BlockLaTeX t) mempty]
--------------------------------------------------------------------------------
-- inline: links and images
--------------------------------------------------------------------------------
-- | "@[link text](url)@, with no space between the @]@ and the @(@."
inline_link :: AlphaNumText -> UrlText -> Property
inline_link (AlphaNumText t) (UrlText url) =
inlineIs ("[" <> t <> "](" <> url <> ")") [Link {linkText = [Text t], url, title = Nothing, misc_attrs = mempty}]
-- | "@[link text][label]@, the label in square brackets immediately after."
reference_link :: AlphaNumText -> AlphaNumText -> Property
reference_link (AlphaNumText t) (AlphaNumText label) =
inlineIs ("[" <> t <> "][" <> label <> "]") [ReferenceLink {linkText = [Text t], label, attrs = mempty}]
-- | "@[My link text][]@ [...] the link text is taken as the label."
empty_reference_label_is_the_text :: AlphaNumText -> Property
empty_reference_label_is_the_text (AlphaNumText t) =
inlineIs ("[" <> t <> "][]") [ReferenceLink {linkText = [Text t], label = t, attrs = mempty}]
-- | "Images are like links but prefixed with @!@."
inline_image :: AlphaNumText -> UrlText -> Property
inline_image (AlphaNumText altText) (UrlText url) =
inlineIs ("![" <> altText <> "](" <> url <> ")") [Image {altText, url, title = Nothing, misc_attrs = mempty}]
reference_image :: AlphaNumText -> AlphaNumText -> Property
reference_image (AlphaNumText altText) (AlphaNumText label) =
inlineIs ("![" <> altText <> "][" <> label <> "]") [ReferenceImage {altText, label, attrs = mempty}]
empty_image_label_is_the_alt_text :: AlphaNumText -> Property
empty_image_label_is_the_alt_text (AlphaNumText altText) =
inlineIs ("![" <> altText <> "][]") [ReferenceImage {altText, label = altText, attrs = mempty}]
-- | "A URL [...] enclosed in @<@ and @>@ [...] the contents are treated
-- literally."
autolink_url :: AlphaNumText -> Property
autolink_url (AlphaNumText host) =
inlineIs ("<" <> target <> ">") [Link {linkText = [Text target], url = target, title = Nothing, misc_attrs = mempty}]
where
target = "https://" <> host <> ".example"
-- | An email autolink gets a @mailto:@ destination, while its content stays the
-- bare address.
autolink_email :: AlphaNumText -> AlphaNumText -> Property
autolink_email (AlphaNumText user) (AlphaNumText host) =
inlineIs ("<" <> target <> ">") [Link {linkText = [Text target], url = "mailto:" <> target, title = Nothing, misc_attrs = mempty}]
where
target = user <> "@" <> host <> ".example"
--------------------------------------------------------------------------------
-- inline: spans, attributes, references
--------------------------------------------------------------------------------
-- | "Text in square brackets that is not a link or image, followed immediately
-- by attributes, is a span."
span_takes_attributes :: AlphaNumText -> AlphaNumText -> Property
span_takes_attributes (AlphaNumText t) (AlphaNumText cls) =
inlineIs ("[" <> t <> "]{." <> cls <> "}") [Span [Text t] (classOf cls)]
-- | "Attributes [...] immediately after the element they attach to, with no
-- intervening whitespace." @#@ is the identifier, @.@ a class, @k=v@ a pair.
attributes_attach_to_the_element :: AlphaNumText -> AlphaNumText -> AlphaNumText -> AlphaNumText -> AlphaNumText -> Property
attributes_attach_to_the_element (AlphaNumText t) (AlphaNumText ident) (AlphaNumText cls) (AlphaNumText key) (AlphaNumText value) =
inlineIs
("*" <> t <> "*{#" <> ident <> " ." <> cls <> " " <> key <> "=" <> value <> "}")
[Bold [Text t] (Attrs {attrId = Just ident, attrClasses = [cls], attrKV = [(key, value)]})]
-- | "Attributes are stackable: @element{attr1}{attr2}@."
attributes_stack :: AlphaNumText -> AlphaNumText -> AlphaNumText -> Property
attributes_stack (AlphaNumText t) (AlphaNumText first) (AlphaNumText second) =
inlineIs
("*" <> t <> "*{." <> first <> "}{." <> second <> "}")
[Bold [Text t] (Attrs {attrId = Nothing, attrClasses = [first, second], attrKV = []})]
-- | "A footnote reference is @^@ + the reference label in square brackets", as
-- in @Here is the reference.[^foo]@.
footnote_reference :: AlphaNumText -> Property
footnote_reference (AlphaNumText label) =
inlineIs ("[^" <> label <> "]") [FootnoteReference {label, attrs = mempty}]
-- | "A symbol is a word between @:@ characters."
symbol :: AlphaNumText -> Property
symbol (AlphaNumText name) = inlineIs (":" <> name <> ":") [Symbol name]
--------------------------------------------------------------------------------
-- inline: escapes and smart punctuation
--------------------------------------------------------------------------------
-- | "A backslash escapes any ASCII punctuation character." Every special
-- character therefore has a plain text spelling, and text written that way has
-- to come back out as exactly the intended literal, in one piece.
escaped_punctuation_is_literal :: DjotText -> Property
escaped_punctuation_is_literal (DjotText source) = literalIs source.rendered source.literal
-- | "A backslash before a space is a nonbreaking space."
backslash_space_is_a_nonbreaking_space :: AlphaNumText -> AlphaNumText -> Property
backslash_space_is_a_nonbreaking_space (AlphaNumText before) (AlphaNumText after) =
literalIs (before <> "\\ " <> after) (before <> "\160" <> after)
-- | "A backslash before a newline is a hard line break."
backslash_newline_is_a_hard_break :: AlphaNumText -> AlphaNumText -> Property
backslash_newline_is_a_hard_break (AlphaNumText before) (AlphaNumText after) =
inlineIs (before <> "\\\n" <> after) [Text before, LineBreak, Text after]
-- | "@...@ becomes an ellipsis."
ellipsis :: AlphaNumText -> AlphaNumText -> Property
ellipsis (AlphaNumText before) (AlphaNumText after) =
literalIs (before <> "..." <> after) (before <> "\8230" <> after)
-- | "@--@ becomes an en dash."
en_dash :: AlphaNumText -> AlphaNumText -> Property
en_dash (AlphaNumText before) (AlphaNumText after) =
literalIs (before <> "--" <> after) (before <> "\8211" <> after)
-- | "@---@ becomes an em dash."
em_dash :: AlphaNumText -> AlphaNumText -> Property
em_dash (AlphaNumText before) (AlphaNumText after) =
literalIs (before <> "---" <> after) (before <> "\8212" <> after)
-- | "Straight quotes are treated as curly quotes", opening after a space.
smart_quotes :: AlphaNumText -> Property
smart_quotes (AlphaNumText t) =
literalIs ("\"" <> t <> "\"") ("\8220" <> t <> "\8221")
--------------------------------------------------------------------------------
-- blocks
--------------------------------------------------------------------------------
-- | Djot has no syntax errors to report, every input is a document.
all_compile :: AsciiText -> Property
all_compile (AsciiText input) = monadicIO $ shouldParse djotDocument input
-- | "A heading starts with a sequence of one or more @#@ characters, followed
-- by whitespace [...] the number of @#@ characters defines the level."
heading_levels :: HeaderLevel -> AlphaNumText -> Property
heading_levels (HeaderLevel level) (AlphaNumText t) =
parses (T.replicate level "#" <> " " <> t) (Doc [Heading (H {level, text = [Text t]}) mempty])
-- | "A paragraph [...] ends with a blank line or the end of the document."
paragraphs_split_on_blank_lines :: AlphaNumText -> AlphaNumText -> Property
paragraphs_split_on_blank_lines (AlphaNumText a) (AlphaNumText b) =
parses
(a <> "\n\n" <> b)
(Doc [Paragraph (P [Text a]) mempty, Paragraph (P [Text b]) mempty])
-- | "The contents of the block quote are parsed as block-level content", so a
-- quoted line is a paragraph inside the quote rather than bare inlines.
block_quote_holds_blocks :: AlphaNumText -> Property
block_quote_holds_blocks (AlphaNumText t) =
parses ("> " <> t) (Doc [BlockQuote (Q [Paragraph (P [Text t]) mempty]) mempty])
-- | "A line containing three or more @*@ or @-@ characters, and nothing else
-- except spaces and tabs, is a thematic break."
data Break = Break Char Int
deriving (Show)
instance Arbitrary Break where
arbitrary = Break <$> elements "*-" <*> chooseInt (3, 8)
shrink (Break c n) = [Break c n' | n' <- [3 .. n - 1]]
thematic_break :: Break -> Property
thematic_break (Break c n) =
parses (T.replicate n (T.singleton c)) (Doc [HorizontalRule mempty])
-- | "A code block starts with three or more consecutive backticks [...] the
-- word after the backticks is the language."
code_block_with_language :: AlphaNumText -> AlphaNumText -> Property
code_block_with_language (AlphaNumText language) (AlphaNumText code) =
parses
("```" <> language <> "\n" <> code <> "\n```")
(Doc [Code (C {language = Just language, code = code <> "\n"}) mempty])
code_block_without_language :: AlphaNumText -> Property
code_block_without_language (AlphaNumText code) =
parses
("```\n" <> code <> "\n```")
(Doc [Code (C {language = Nothing, code = code <> "\n"}) mempty])
-- | "[...] until a closing fence of at least the same length."
closing_fence_may_be_longer :: AlphaNumText -> Property
closing_fence_may_be_longer (AlphaNumText code) =
parses
("```\n" <> code <> "\n`````")
(Doc [Code (C {language = Nothing, code = code <> "\n"}) mempty])
-- | "A code block with @=FORMAT@ as the language is a raw block."
raw_block :: AlphaNumText -> AlphaNumText -> Property
raw_block (AlphaNumText format) (AlphaNumText content) =
parses
("```=" <> format <> "\n" <> content <> "\n```")
(Doc [RawBlock (RB {format, content = content <> "\n"}) mempty])
-- | "A div starts with three or more consecutive colons [...] the text after
-- the colons is used as a class name."
div_block :: AlphaNumText -> AlphaNumText -> Property
div_block (AlphaNumText cls) (AlphaNumText t) =
parses
("::: " <> cls <> "\n" <> t <> "\n:::")
(Doc [Container [Paragraph (P [Text t]) mempty] (classOf cls)])
--------------------------------------------------------------------------------
-- blocks: lists
--------------------------------------------------------------------------------
-- | "Bullet list markers are @-@, @+@ and @*@."
newtype Bullet = Bullet Char
deriving (Show)
instance Arbitrary Bullet where
arbitrary = Bullet <$> elements "-+*"
shrink _ = []
bullet_markers :: Bullet -> AlphaNumText -> AlphaNumText -> Property
bullet_markers (Bullet c) (AlphaNumText a) (AlphaNumText b) =
parses
(m <> " " <> a <> "\n" <> m <> " " <> b)
(Doc [List (L {list_type = Unordered {style = Nothing}, items = [item a, item b]}) mempty])
where
m = T.singleton c
-- | The ordered marker styles the reference lists: decimal, lower and upper
-- alpha, lower and upper roman, each with a @.@, @)@ or @(...)@ delimiter.
data NumberStyle = Decimal | LowerAlpha | UpperAlpha | LowerRoman | UpperRoman
deriving (Show, Eq)
data Delim = Period | Paren | Parens
deriving (Show, Eq)
data OrderedMarker = OrderedMarker NumberStyle Delim Int
deriving (Show)
instance Arbitrary OrderedMarker where
arbitrary = do
style <- elements [Decimal, LowerAlpha, UpperAlpha, LowerRoman, UpperRoman]
delim <- elements [Period, Paren, Parens]
start <- startFor style
pure $ OrderedMarker style delim start
-- only decimal starts form a range worth searching, the others are picked
-- from a handful of unambiguous values
shrink (OrderedMarker Decimal delim start) = [OrderedMarker Decimal delim s | s <- [1 .. start - 1]]
shrink _ = []
-- | A single letter is ambiguous between the alphabetic and roman styles, so
-- alphabetic starts avoid the roman letters and roman starts avoid the values
-- whose numeral is a single character.
startFor :: NumberStyle -> Gen Int
startFor Decimal = chooseInt (1, 20)
startFor LowerAlpha = elements alphaStarts
startFor UpperAlpha = elements alphaStarts
startFor LowerRoman = elements romanStarts
startFor UpperRoman = elements romanStarts
alphaStarts :: [Int]
alphaStarts = [n | n <- [1 .. 25], letter n `notElem` ("ivxlcdm" :: String)]
where
letter n = toEnum (fromEnum 'a' + n - 1) :: Char
-- ii, iii, iv, vii, viii, ix
romanStarts :: [Int]
romanStarts = [2, 3, 4, 7, 8, 9]
numeral :: NumberStyle -> Int -> T.Text
numeral Decimal n = T.pack (show n)
numeral LowerAlpha n = T.singleton (toEnum (fromEnum 'a' + n - 1))
numeral UpperAlpha n = T.singleton (toEnum (fromEnum 'A' + n - 1))
numeral LowerRoman n = T.toLower (roman n)
numeral UpperRoman n = roman n
roman :: Int -> T.Text
roman = go [(1000, "M"), (900, "CM"), (500, "D"), (400, "CD"), (100, "C"), (90, "XC"), (50, "L"), (40, "XL"), (10, "X"), (9, "IX"), (5, "V"), (4, "IV"), (1, "I")]
where
go [] _ = ""
go all_digits@((value, sign) : rest) n
| n >= value = sign <> go all_digits (n - value)
| otherwise = go rest n
renderMarker :: OrderedMarker -> Int -> T.Text
renderMarker (OrderedMarker style delim _) n = case delim of
Period -> num <> "."
Paren -> num <> ")"
Parens -> "(" <> num <> ")"
where
num = numeral style n
styleOf :: NumberStyle -> Maybe T.Text
styleOf Decimal = Nothing
styleOf LowerAlpha = Just "a"
styleOf UpperAlpha = Just "A"
styleOf LowerRoman = Just "i"
styleOf UpperRoman = Just "I"
-- | "The start number of an ordered list will be determined by the number of
-- its first item."
ordered_markers :: OrderedMarker -> AlphaNumText -> AlphaNumText -> Property
ordered_markers marker@(OrderedMarker style _ start) (AlphaNumText a) (AlphaNumText b) =
parses
(renderMarker marker start <> " " <> a <> "\n" <> renderMarker marker (start + 1) <> " " <> b)
(Doc [List (L {list_type = Ordered {start_number = Just start, style = styleOf style}, items = [item a, item b]}) mempty])
-- | "A list is tight if there are no blank lines between items"; a tight item's
-- paragraph is not wrapped.
tight_list_items_are_unwrapped :: AlphaNumText -> AlphaNumText -> Property
tight_list_items_are_unwrapped (AlphaNumText a) (AlphaNumText b) =
parses
("- " <> a <> "\n- " <> b)
(Doc [List (L {list_type = Unordered {style = Nothing}, items = [item a, item b]}) mempty])
-- | A blank line between items makes the list loose, and a loose item's content
-- stays a paragraph.
loose_list_items_keep_paragraphs :: AlphaNumText -> AlphaNumText -> Property
loose_list_items_keep_paragraphs (AlphaNumText a) (AlphaNumText b) =
parses
("- " <> a <> "\n\n- " <> b)
(Doc [List (L {list_type = Unordered {style = Nothing}, items = [loose a, loose b]}) mempty])
where
loose t = LI {content = [Paragraph (P [Text t]) mempty]}
-- | "A list item [...] is followed by one or more indented lines", which are
-- parsed as blocks, so an indented marker starts a nested list.
nested_list :: AlphaNumText -> AlphaNumText -> Property
nested_list (AlphaNumText a) (AlphaNumText b) =
parses
("- " <> a <> "\n - " <> b)
( Doc
[ List
( L
{ list_type = Unordered {style = Nothing},
items =
[ LI
{ content =
[ Transparent [Text a],
List (L {list_type = Unordered {style = Nothing}, items = [item b]}) mempty
]
}
]
}
)
mempty
]
)
-- | "A bullet list item that begins with @[ ]@, @[X]@ or @[x]@ followed by a
-- space is a task list item."
task_list :: AlphaNumText -> AlphaNumText -> Property
task_list (AlphaNumText a) (AlphaNumText b) =
parses
("- [ ] " <> a <> "\n- [x] " <> b)
(Doc [TaskList (TL {items = [task False a, task True b]}) mempty])
where
task checked t = Ta {checked, content = [Transparent [Text t]]}
-- | "@:@ [...] the first line is the term, the following blocks the
-- definition."
definition_list :: AlphaNumText -> AlphaNumText -> Property
definition_list (AlphaNumText term) (AlphaNumText def) =
parses
(": " <> term <> "\n\n " <> def)
(Doc [DescriptionList (DL {items = [Def {defTitle = [Text term], defContent = [Paragraph (P [Text def]) mempty]}]}) mempty])
--------------------------------------------------------------------------------
-- blocks: tables
--------------------------------------------------------------------------------
-- | "@:-@ left aligned, @-:@ right aligned, @:-:@ centered, @-@ default."
newtype Align = Align Alignment
deriving (Show)
instance Arbitrary Align where
arbitrary = Align <$> elements [AlignDefault, AlignLeft, AlignRight, AlignCenter]
shrink _ = []
separatorFor :: Alignment -> T.Text
separatorFor AlignDefault = "---"
separatorFor AlignLeft = ":--"
separatorFor AlignRight = "--:"
separatorFor AlignCenter = ":-:"
-- | "The row before the separator line is treated as a header [...] cell
-- contents are parsed as inline content."
table :: Align -> Align -> AlphaNumText -> AlphaNumText -> AlphaNumText -> AlphaNumText -> Property
table (Align left) (Align right) (AlphaNumText h1) (AlphaNumText h2) (AlphaNumText c1) (AlphaNumText c2) =
parses
( T.concat
[ "| " <> h1 <> " | " <> h2 <> " |\n",
"| " <> separatorFor left <> " | " <> separatorFor right <> " |\n",
"| " <> c1 <> " | " <> c2 <> " |"
]
)
( Doc
[ Table
( T
{ tableCaption = Nothing,
tableHead = Just (row h1 h2),
tableBody = [row c1 c2],
columnAlignments = Just [left, right]
}
)
mempty
]
)
where
row a b = TR [TC [Text a], TC [Text b]]
-- | "@^ caption text@ directly after the table is its caption."
table_caption :: AlphaNumText -> AlphaNumText -> Property
table_caption (AlphaNumText cell) (AlphaNumText caption) =
parses
("| " <> cell <> " |\n^ " <> caption)
( Doc
[ Table
( T
{ tableCaption = Just [Text caption],
tableHead = Nothing,
tableBody = [TR [TC [Text cell]]],
columnAlignments = Nothing
}
)
mempty
]
)
--------------------------------------------------------------------------------
-- blocks: definitions and attributes
--------------------------------------------------------------------------------
-- | "A footnote consists of a footnote reference followed by a colon followed
-- by the contents of the note", parsed as block-level content.
footnote_definition :: AlphaNumText -> AlphaNumText -> Property
footnote_definition (AlphaNumText label) (AlphaNumText content) =
parses
("[^" <> label <> "]: " <> content)
(Doc [Footnote (F {label, content = [Paragraph (P [Text content]) mempty]}) mempty])
-- | "@[label]: url@."
reference_definition :: AlphaNumText -> UrlText -> Property
reference_definition (AlphaNumText label) (UrlText link) =
parses ("[" <> label <> "]: " <> link) (Doc [ReferenceDefinition (RD {label, link})])
-- | "Attributes on a line immediately before a block attach to that block."
block_attributes :: AlphaNumText -> AlphaNumText -> AlphaNumText -> Property
block_attributes (AlphaNumText ident) (AlphaNumText cls) (AlphaNumText t) =
parses
("{#" <> ident <> " ." <> cls <> "}\n" <> t)
(Doc [Paragraph (P [Text t]) (Attrs {attrId = Just ident, attrClasses = [cls], attrKV = []})])
--------------------------------------------------------------------------------
-- whole documents
--------------------------------------------------------------------------------
-- | The generalisation of the block tests: a generated document, written out in
-- djot's spelling, has to parse back to the document it was generated from.
document_round_trip :: DocSpec -> Property
document_round_trip spec =
counterexample (T.unpack source) $
monadicIO $
shouldParseTo djotDocument source (expected djotSyntax spec)
where
source = render djotSyntax spec

14
tests/Main.hs
View file

@ -1,14 +0,0 @@
module Main (main) where
import qualified Djot.Parse
import qualified Markdown.Parse
import Test.Tasty (defaultMain, testGroup)
main :: IO ()
main =
defaultMain $
testGroup
"Parse Tests"
[ Markdown.Parse.tests,
Djot.Parse.tests
]

511
tests/Markdown/Parse.hs
View file

@ -1,229 +1,338 @@
{-# LANGUAGE OverloadedStrings #-}
module Markdown.Parse (tests) where
module Main where
import Control.Exception (evaluate)
import Control.Monad.Trans.Class (MonadTrans (lift))
import Data.Either (isRight)
import Data.Functor.Identity (Identity (Identity))
import Data.String (IsString)
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 Test.Gen (AlphaNumText (..), AlphaText (..), AsciiText (..), EscapedText (..), HeaderLevel (..), MarkdownText (..))
import Test.Gen.Document (DocSpec, expected, markdownSyntax, render)
import Test.Harness (markdownDocument, shouldParse, shouldParseTo)
import Test.QuickCheck (Property, counterexample)
import Test.QuickCheck.Monadic (monadicIO)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (testProperty)
import Markdown
import qualified Markdown
import System.Exit (exitFailure, exitSuccess)
import System.Timeout (timeout)
import Text.Megaparsec
tests :: TestTree
tests =
testGroup
"Markdown"
[ testProperty "all_compile" all_compiles,
testProperty "block_html_compile_edgecase" block_html_compile_edgecase,
testProperty "header_and_paragraph" header_and_paragraph,
testProperty "paragraph_and_header_and_paragraph" paragraph_and_header_and_paragraph,
testProperty "bold_and_header_and_paragraph" bold_and_header_and_paragraph,
testProperty "code_block" code_block,
testProperty "code_block_hanging" code_block_hanging,
testProperty "two_blockquotes" two_blockquotes,
testProperty "unordered_list" unordered_list,
testProperty "header_after_unordered_list" header_after_unordered_list,
testProperty "ordered_list" ordered_list,
testProperty "multiple_ordered_lists" multiple_ordered_lists,
testProperty "header_then_ordered_list" header_then_ordered_list,
testProperty "simple_nested_ordered_list" simple_nested_ordered_list,
testProperty "nested_unordered_list" nested_unordered_list,
testProperty "greedy_plain_text" greedy_plain_text,
testProperty "plain_text_is_literal" plain_text_is_literal,
testProperty "document_round_trip" document_round_trip
]
hashes :: Int -> T.Text
hashes level = T.replicate level "#"
all_compiles :: AsciiText -> Property
all_compiles (AsciiText input) = monadicIO $ shouldParse markdownDocument input
block_html_compile_edgecase :: AlphaNumText -> AlphaNumText -> AlphaNumText -> Property
block_html_compile_edgecase (AlphaNumText tag_name) (AlphaNumText misc1) (AlphaNumText misc2) =
monadicIO $ shouldParse markdownDocument input
where
input = T.concat ["<", tag_name, ">", misc1, "</", tag_name, "> ", misc2]
header_and_paragraph :: AlphaText -> HeaderLevel -> AlphaText -> Property
header_and_paragraph (AlphaText header_text) (HeaderLevel level) (AlphaText paragraph_text) =
monadicIO $ shouldParseTo markdownDocument input tree
where
input = hashes level <> header_text <> "\n\n" <> paragraph_text
tree =
Doc
[ Heading (H {level, text = [Text header_text]}) mempty,
Paragraph (P [Text paragraph_text]) mempty
main :: IO ()
main = do
cond <-
checkParallel $
Group
"Parse Tests"
[ ("all_compile", all_compiles),
("block_html_compile_edgecase", block_html_compile_edgecase),
("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),
("code_block_hanging", code_block_hanging),
("two_blockquotes", two_blockquotes),
("unordered_list", unordered_list),
("header_after_unordered_list", header_after_unordered_list),
("ordered_list", ordered_list),
("multiple_ordered_lists", multiple_ordered_lists),
("header_then_ordered_list", header_then_ordered_list),
("simple_nested_ordered_list", simple_nested_ordered_list),
("nested_unordered_list", nested_unordered_list),
("greedy_plain_text", greedy_plain_text)
-- ("",),
]
if cond
then exitSuccess
else exitFailure
paragraph_and_header_and_paragraph :: AlphaText -> AlphaText -> HeaderLevel -> AlphaText -> Property
paragraph_and_header_and_paragraph (AlphaText paragraph1_text) (AlphaText header_text) (HeaderLevel level) (AlphaText paragraph2_text) =
monadicIO $ shouldParseTo markdownDocument input tree
where
input = paragraph1_text <> "\n\n" <> hashes level <> header_text <> "\n\n" <> paragraph2_text
tree =
Doc
[ Paragraph (P [Text paragraph1_text]) mempty,
Heading (H {level, text = [Text header_text]}) mempty,
Paragraph (P [Text paragraph2_text]) mempty
]
-- timeout of 1 second, all of these tests should be completely clear of that, if they run longer they should fail
generic_parse inp = lift $ timeout 1000000 $ evaluate $ parse (Markdown.document :: ParsecT Void Text Identity IR.Document) "test_input" inp
bold_and_header_and_paragraph :: AlphaText -> AlphaText -> HeaderLevel -> AlphaText -> Property
bold_and_header_and_paragraph (AlphaText bold_text) (AlphaText header_text) (HeaderLevel level) (AlphaText paragraph_text) =
monadicIO $ shouldParseTo markdownDocument input tree
where
input = "**" <> bold_text <> "**\n\n" <> hashes level <> header_text <> "\n\n" <> paragraph_text
tree =
Doc
[ Paragraph (P [Bold [Text bold_text] mempty]) mempty,
Heading (H {level, text = [Text header_text]}) mempty,
Paragraph (P [Text paragraph_text]) mempty
]
all_compiles :: Property
all_compiles = property $ do
xs <- forAll $ Gen.text (Range.linear 0 100) Gen.ascii
parsed <- generic_parse xs
case parsed of
Nothing -> fail $ "Hit Timeout"
(Just (Right _)) -> success
(Just (Left e)) -> fail $ errorBundlePretty e
code_block :: AlphaText -> AlphaText -> Property
code_block (AlphaText language) (AlphaText code) =
monadicIO $ shouldParseTo markdownDocument input tree
where
input = "```" <> language <> "\n" <> code <> "\n```"
-- the newline after the info string ends it, the one before the closing
-- fence is part of the code
tree = Doc [Code (C {language = Just language, code = code <> "\n"}) mempty]
block_html_compile_edgecase :: Property
block_html_compile_edgecase = property $ do
let gen = forAll $ Gen.text (Range.linear 0 10) Gen.alphaNum
tagName <- gen
misc1 <- gen
misc2 <- gen
parsed <- generic_parse $ (T.concat ["<", tagName, ">", misc1, "</", tagName, "> ", misc2])
case parsed of
Nothing -> fail $ "Hit Timeout"
(Just (Right _)) -> success
(Just (Left e)) -> fail $ errorBundlePretty e
code_block_hanging :: AlphaText -> AlphaText -> Property
code_block_hanging (AlphaText language) (AlphaText code) =
-- a fence whose closing ``` is not on a line of its own, we're only testing
-- that the parser terminates
monadicIO $ shouldParse markdownDocument ("```" <> language <> "\n" <> code <> "```")
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
two_blockquotes :: AlphaText -> AlphaText -> Property
two_blockquotes (AlphaText text_1) (AlphaText text_2) =
monadicIO $ shouldParseTo markdownDocument input tree
where
input = "> " <> text_1 <> "\n\n> " <> text_2
tree =
Doc
[ BlockQuote (Q [Transparent [Text text_1]]) mempty,
BlockQuote (Q [Transparent [Text text_2]]) mempty
]
let input = (T.pack $ take header_level $ repeat '#') <> header_text <> "\n\n" <> paragraph_text
item :: T.Text -> ListItem
item content = LI {content = [Transparent [Text content]]}
parsed <- generic_parse input
unorderedList :: [ListItem] -> Element
unorderedList items = List (L {list_type = Unordered {style = Nothing}, items}) mempty
case parsed of
Nothing -> fail $ "Hit Timeout"
(Just (Right (Doc [Heading (H {level = header_level, text = [Text (header_text)]}), Paragraph (P ([Text paragraph_text]))]))) -> success
(Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree
(Just (Left e)) -> fail $ errorBundlePretty e
orderedList :: [ListItem] -> Element
orderedList items = List (L {list_type = Ordered {start_number = Nothing, style = Nothing}, items}) mempty
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
unordered_list :: AlphaText -> AlphaText -> Property
unordered_list (AlphaText text_1) (AlphaText text_2) =
monadicIO $ shouldParseTo markdownDocument input tree
where
input = "- " <> text_1 <> "\n- " <> text_2
tree = Doc [unorderedList [item text_1, item text_2]]
let input = paragraph1_text <> "\n\n" <> (T.pack $ take header_level $ repeat '#') <> header_text <> "\n\n" <> paragraph2_text
header_after_unordered_list :: AlphaText -> AlphaText -> HeaderLevel -> Property
header_after_unordered_list (AlphaText bullet_text) (AlphaText header_text) (HeaderLevel level) =
monadicIO $ shouldParseTo markdownDocument input tree
where
input = "- " <> bullet_text <> "\n\n" <> hashes level <> header_text
tree =
Doc
[ unorderedList [item bullet_text],
Heading (H {level, text = [Text header_text]}) mempty
]
parsed <- generic_parse input
ordered_list :: AlphaText -> AlphaText -> AlphaText -> Property
ordered_list (AlphaText item_1) (AlphaText item_2) (AlphaText item_3) =
monadicIO $ shouldParseTo markdownDocument input tree
where
input = "1. " <> item_1 <> "\n2. " <> item_2 <> "\n3. " <> item_3
tree = Doc [orderedList [item item_1, item item_2, item item_3]]
case parsed of
Nothing -> fail $ "Hit Timeout"
(Just (Right (Doc [Paragraph (P ([Text paragarph1_text])), Heading (H {level = header_level, text = [Text (header_text)]}), Paragraph (P ([Text paragraph2_text]))]))) -> success
(Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree
(Just (Left e)) -> fail $ errorBundlePretty e
multiple_ordered_lists :: AlphaText -> AlphaText -> AlphaText -> Property
multiple_ordered_lists (AlphaText item_1) (AlphaText item_2) (AlphaText item_3) =
monadicIO $ shouldParseTo markdownDocument input tree
where
input = "1. " <> item_1 <> "\n\n2. " <> item_2 <> "\n\n3. " <> item_3
tree =
Doc
[ orderedList [item item_1],
orderedList [item item_2],
orderedList [item item_3]
]
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
header_then_ordered_list :: AlphaText -> HeaderLevel -> AlphaText -> AlphaText -> AlphaText -> Property
header_then_ordered_list (AlphaText header_text) (HeaderLevel level) (AlphaText item_1) (AlphaText item_2) (AlphaText item_3) =
monadicIO $ shouldParseTo markdownDocument input tree
where
input = hashes level <> header_text <> "\n\n1) " <> item_1 <> "\n2) " <> item_2 <> "\n3) " <> item_3
tree =
Doc
[ Heading (H {level, text = [Text header_text]}) mempty,
orderedList [item item_1, item item_2, item item_3]
]
let input = "**" <> bold_text <> "**\n\n" <> (T.pack $ take header_level $ repeat '#') <> header_text <> "\n\n" <> paragraph_text
simple_nested_ordered_list :: AlphaText -> AlphaText -> Property
simple_nested_ordered_list (AlphaText item_1) (AlphaText item_2) =
monadicIO $ shouldParseTo markdownDocument input tree
where
input = "1) " <> item_1 <> "\n 1) " <> item_2
tree =
Doc
[ orderedList
[ LI {content = [Transparent [Text item_1], orderedList [item item_2]]}
]
]
parsed <- generic_parse input
case parsed of
Nothing -> fail $ "Hit Timeout"
(Just (Right (Doc [Paragraph (P ([Bold [Text bold_text]])), Heading (H {level = header_level, text = [Text (header_text)]}), Paragraph (P ([Text paragraph_text]))]))) -> success
(Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree
(Just (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 <> "\n```"
parsed <- generic_parse input
case parsed of
Nothing -> fail $ "Hit Timeout"
(Just (Right (Doc [Code (C {language, code})]))) -> success
(Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree
(Just (Left e)) -> fail $ errorBundlePretty e
code_block_hanging :: Property
code_block_hanging = 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 <> "```"
parsed <- generic_parse input
case parsed of
Nothing -> fail $ "Hit Timeout"
-- we're just testing for hanging
(Just (Right _)) -> success
(Just (Left e)) -> fail $ errorBundlePretty e
two_blockquotes :: Property
two_blockquotes = property $ do
let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alpha
text_1 <- text_gen
text_2 <- text_gen
let input = "> " <> text_1 <> "\n\n> " <> text_2
parsed <- generic_parse input
case parsed of
Nothing -> fail $ "Hit Timeout"
(Just (Right (Doc [BlockQuote (Q [Text text_1]), BlockQuote (Q [Text text_2])]))) -> success
(Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree
(Just (Left e)) -> fail $ errorBundlePretty e
unordered_list :: Property
unordered_list = property $ do
let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alpha
text_1 <- text_gen
text_2 <- text_gen
let input = "- " <> text_1 <> "\n- " <> text_2
parsed <- generic_parse input
case parsed of
Nothing -> fail $ "Hit Timeout"
(Just (Right (Doc [List (L {list_type = Unordered, items = [LI {content = [Text text_1], child = Nothing}, LI {content = [Text text_2], child = Nothing}]})]))) -> success
(Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree
(Just (Left e)) -> fail $ errorBundlePretty e
header_after_unordered_list :: Property
header_after_unordered_list = property $ do
let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alpha
bullet_text <- text_gen
header_text <- text_gen
header_level <- forAll $ Gen.int (Range.linear 1 6)
let input = "- " <> bullet_text <> "\n\n" <> (T.pack $ take header_level $ repeat '#') <> header_text
parsed <- generic_parse input
case parsed of
Nothing -> fail $ "Hit Timeout"
(Just (Right (Doc [List (L {list_type = Unordered, items = [LI {content = [Text bullet_text], child = Nothing}]}), Heading (H {level = header_level, text = [Text header_text]})]))) -> success
(Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree
(Just (Left e)) -> fail $ errorBundlePretty e
ordered_list :: Property
ordered_list = property $ do
let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alpha
item_1 <- text_gen
item_2 <- text_gen
item_3 <- text_gen
let input = "1. " <> item_1 <> "\n2. " <> item_2 <> "\n3. " <> item_3
parsed <- generic_parse input
case parsed of
Nothing -> fail $ "Hit Timeout"
(Just (Right (Doc [List (L {list_type = Ordered, items = [LI {content = [Text item_1], child = Nothing}, LI {content = [Text item_2], child = Nothing}, LI {content = [Text item_3], child = Nothing}]})]))) -> success
(Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree
(Just (Left e)) -> fail $ errorBundlePretty e
multiple_ordered_lists :: Property
multiple_ordered_lists = property $ do
let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alpha
item_1 <- text_gen
item_2 <- text_gen
item_3 <- text_gen
let input = "1. " <> item_1 <> "\n\n2. " <> item_2 <> "\n\n3. " <> item_3
parsed <- generic_parse input
case parsed of
Nothing -> fail $ "Hit Timeout"
( Just
( Right
( Doc
[ List (L {list_type = Ordered, items = [LI {content = [Text item_1], child = Nothing}]}),
List (L {list_type = Ordered, items = [LI {content = [Text item_2], child = Nothing}]}),
List (L {list_type = Ordered, items = [LI {content = [Text item_3], child = Nothing}]})
]
)
)
) -> success
(Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree
(Just (Left e)) -> fail $ errorBundlePretty e
simple_nested_ordered_list :: Property
simple_nested_ordered_list = property $ do
let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alpha
item_1 <- text_gen
item_2 <- text_gen
let input = "1) " <> item_1 <> "\n 1) " <> item_2
parsed <- generic_parse input
case parsed of
Nothing -> fail $ "Hit Timeout"
( Just
( Right
( Doc
[ List (L {list_type = Ordered, items = [LI {content = [Text item_1], child = Just (L {list_type = Ordered, items = [LI {content = [Text item_2], child = Nothing}]})}]})
]
)
)
) -> success
(Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree
(Just (Left e)) -> fail $ errorBundlePretty e
-- - a
-- - a
-- - b
nested_unordered_list :: AlphaText -> AlphaText -> AlphaText -> Property
nested_unordered_list (AlphaText item_1) (AlphaText item_2) (AlphaText item_3) =
monadicIO $ shouldParseTo markdownDocument input tree
where
input = "- " <> item_1 <> "\n - " <> item_2 <> "\n- " <> item_3
tree =
Doc
[ unorderedList
[ LI {content = [Transparent [Text item_1], unorderedList [item item_2]]},
item item_3
]
]
nested_unordered_list :: Property
nested_unordered_list = property $ do
let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alpha
item_1 <- text_gen
item_2 <- text_gen
item_3 <- text_gen
let input = "- " <> item_1 <> "\n - " <> item_2 <> "\n- " <> item_3
greedy_plain_text :: AlphaNumText -> AlphaNumText -> AlphaNumText -> Property
greedy_plain_text (AlphaNumText pretext) (AlphaNumText shown) (AlphaNumText url) =
monadicIO $ shouldParseTo markdownDocument input tree
where
input = T.concat [pretext, "[", shown, "]", "(", url, ")"]
tree =
Doc
[ Paragraph
( P
[ Text pretext,
Link {linkText = [Text shown], url, title = Nothing, misc_attrs = mempty}
]
)
mempty
]
parsed <- generic_parse input
case parsed of
Nothing -> fail $ "Hit Timeout"
( Just
( Right
( Doc
[ List (L {list_type = Unordered, items = [LI {content = [Text item_1], child = Just (L {list_type = Unordered, items = [LI {content = [Text item_2], child = Nothing}]})}, LI {content = [Text item_3], child = Nothing}]})
]
)
)
) -> success
(Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree
(Just (Left e)) -> fail $ errorBundlePretty e
-- | Text written in a form the syntax says means that text has to come back
-- out as exactly that text, in one piece.
plain_text_is_literal :: MarkdownText -> Property
plain_text_is_literal (MarkdownText source) =
monadicIO $ shouldParseTo markdownDocument source.rendered tree
where
tree = Doc [Paragraph (P [Text source.literal]) mempty]
-- ##
-- 1)
-- 2)
-- 3)
header_then_ordered_list :: Property
header_then_ordered_list = property $ do
let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alpha
header <- text_gen
header_level <- forAll $ Gen.int (Range.linear 1 6)
item_1 <- text_gen
item_2 <- text_gen
item_3 <- text_gen
let input = (T.pack $ take header_level $ repeat '#') <> header <> "\n\n1) " <> item_1 <> "\n2) " <> item_2 <> "\n3) " <> item_3
-- | The generalisation of every test above it: a generated document, rendered
-- as markdown, has to parse back to the document it was generated from.
document_round_trip :: DocSpec -> Property
document_round_trip spec =
counterexample (T.unpack source) $
monadicIO $
shouldParseTo markdownDocument source (expected markdownSyntax spec)
where
source = render markdownSyntax spec
parsed <- generic_parse input
case parsed of
Nothing -> fail $ "Hit Timeout"
( Just
( Right
( Doc
[ Heading (H {level = header_level, text = header}),
List
( L
{ list_type = Ordered,
items =
[ LI {content = [Text item_1], child = Nothing},
LI {content = [Text item_2], child = Nothing},
LI {content = [Text item_3], child = Nothing}
]
}
)
]
)
)
) -> success
(Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree
(Just (Left e)) -> fail $ errorBundlePretty e
greedy_plain_text :: Property
greedy_plain_text = property $ do
let text_gen = forAll $ Gen.text (Range.linear 1 10) Gen.alphaNum
pretext <- text_gen
shown <- text_gen
link <- text_gen
parsed <- generic_parse $ T.concat [pretext, "[", shown, "]", "(", link, ")"]
case parsed of
Nothing -> fail $ "Hit Timeout"
(Just (Right (Doc [Paragraph (P [Text (pretext), Link {linkText = [Text shown], url = link, title = Nothing}])]))) -> success
(Just (Right tree)) -> fail $ "Incorrect syntax tree: " <> show tree
(Just (Left e)) -> fail $ errorBundlePretty e

229
tests/Test/Gen.hs
View file

@ -1,229 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
-- | Generators shared by the parser test suites.
--
-- Everything a property generates lives behind a newtype with an `Arbitrary`
-- instance rather than being pulled in with `pick`. `pick` embeds its value
-- with `forAll (return a)`, which cannot shrink, so a failing property would
-- report whatever random 10 character string happened to trip it. Going
-- through `Arbitrary` gets shrinking back, at the cost of having to write the
-- shrinkers by hand.
--
-- Those shrinkers have to preserve the invariants their generator established
-- (non-empty, alphabet, ranges). A shrunk counterexample that no longer
-- satisfies what the property assumes is worse than no shrinking at all, it
-- reports a failure for an input the test was never making a claim about.
module Test.Gen
( -- * sized primitives
linear,
textOf,
asciiChar,
alphaChar,
alphaNumChar,
wordsOf,
-- * shrinking
shrinkTextWith,
-- * wrappers
AsciiText (..),
AlphaText (..),
AlphaNumText (..),
VerbatimText (..),
UrlText (..),
HeaderLevel (..),
-- * escaping
Escaper (..),
backslashEscaper,
unescapable,
markdownEscaper,
djotEscaper,
escapeWith,
EscapedText (..),
escapedText,
MarkdownText (..),
DjotText (..),
)
where
import Data.Text (Text)
import qualified Data.Text as T
import Test.QuickCheck (Arbitrary (arbitrary, shrink), Gen, chooseInt, elements, frequency, sized, suchThat, vectorOf)
-- | Hedgehog's `Range.linear` grows its upper bound with the size of the test
-- case, this is the same thing in terms of QuickCheck's size parameter.
linear :: Int -> Int -> Gen Int
linear lo hi = sized $ \size -> chooseInt (lo, lo + ((hi - lo) * min size 99) `div` 99)
textOf :: Gen Char -> Int -> Int -> Gen Text
textOf char_gen lo hi = do
len <- linear lo hi
T.pack <$> vectorOf len char_gen
asciiChar :: Gen Char
asciiChar = elements ['\0' .. '\127']
alphaChar :: Gen Char
alphaChar = elements (['a' .. 'z'] <> ['A' .. 'Z'])
alphaNumChar :: Gen Char
alphaNumChar = elements (['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9'])
-- | One to three alphanumeric words separated by single spaces. Never starts or
-- ends with a space, so it can sit directly after a block marker without the
-- marker's own trailing space being ambiguous.
wordsOf :: Gen Text
wordsOf = do
count <- chooseInt (1, 3)
T.unwords <$> vectorOf count (textOf alphaNumChar 1 8)
-- | Shrink by taking shorter prefixes, dropping any that no longer satisfy the
-- predicate the generator guaranteed. Prefixes keep the first character, which
-- is what stops a shrunk value from acquiring a leading space or a digit where
-- the original had a letter.
shrinkTextWith :: (Text -> Bool) -> Text -> [Text]
shrinkTextWith valid t = filter valid [T.take n t | n <- [1 .. T.length t - 1]]
newtype AsciiText = AsciiText Text
deriving (Show)
instance Arbitrary AsciiText where
arbitrary = AsciiText <$> textOf asciiChar 0 100
shrink (AsciiText t) = AsciiText <$> shrinkTextWith (const True) t
newtype AlphaText = AlphaText Text
deriving (Show)
instance Arbitrary AlphaText where
arbitrary = AlphaText <$> textOf alphaChar 1 10
shrink (AlphaText t) = AlphaText <$> shrinkTextWith (not . T.null) t
newtype AlphaNumText = AlphaNumText Text
deriving (Show)
instance Arbitrary AlphaNumText where
arbitrary = AlphaNumText <$> textOf alphaNumChar 1 10
shrink (AlphaNumText t) = AlphaNumText <$> shrinkTextWith (not . T.null) t
-- | Content for a verbatim span. Djot says verbatim content is literal, so this
-- ranges over printable ascii rather than words; backticks are excluded because
-- they would close the span, and the ends are kept non blank because a space
-- next to a delimiter is subject to a stripping rule of its own.
newtype VerbatimText = VerbatimText Text
deriving (Show)
instance Arbitrary VerbatimText where
arbitrary = VerbatimText <$> (textOf verbatimChar 1 20 `suchThat` wellFormed)
where
verbatimChar = elements $ filter (/= '`') [' ' .. '~']
wellFormed t = not (T.null t) && T.head t /= ' ' && T.last t /= ' '
shrink (VerbatimText t) =
VerbatimText <$> shrinkTextWith (\s -> not (T.null s) && T.last s /= ' ') t
-- | Something that can sit inside @(...)@ as a link destination: no spaces, no
-- closing paren, no newline.
newtype UrlText = UrlText Text
deriving (Show)
instance Arbitrary UrlText where
arbitrary = UrlText <$> textOf urlChar 1 20
where
urlChar = elements $ ['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9'] <> "./:-_~"
shrink (UrlText t) = UrlText <$> shrinkTextWith (not . T.null) t
newtype HeaderLevel = HeaderLevel Int
deriving (Show)
instance Arbitrary HeaderLevel where
arbitrary = HeaderLevel <$> chooseInt (1, 6)
shrink (HeaderLevel level) = HeaderLevel <$> [1 .. level - 1]
-- | How a syntax lets you write a character that would otherwise be markup.
--
-- `escapeChar` is Nothing for a syntax with no escape mechanism at all, in
-- which case the only way to get a special character into plain text is not to
-- generate one. Markdown is currently in that boat.
data Escaper = Escaper
{ specialChars :: [Char],
escapeChar :: Maybe (Char -> Text)
}
backslashEscaper :: [Char] -> Escaper
backslashEscaper cs = Escaper {specialChars = cs, escapeChar = Just $ \c -> T.pack ['\\', c]}
unescapable :: [Char] -> Escaper
unescapable cs = Escaper {specialChars = cs, escapeChar = Nothing}
-- | The characters that start markup in the Markdown parser's inline layer.
-- \`*[~ are the ones `plain_text` breaks a text node on, _ starts an underline
-- and ! an image, both of which are only recognised at the start of an inline
-- run. Markdown.hs has no backslash escape handling, so this is `unescapable`.
markdownEscaper :: Escaper
markdownEscaper = unescapable "`*[~_!<"
-- | Djot's inline specials. The syntax reference says a backslash escapes any
-- ASCII punctuation, and every character here is ASCII punctuation, so all of
-- them are representable in plain text rather than having to be avoided.
--
-- The quote characters are deliberately absent. They are not markup, they are
-- input to the smart punctuation pass, and what an escaped quote should turn
-- into is a separate question from whether escaping works at all.
djotEscaper :: Escaper
djotEscaper = backslashEscaper "\\`*_^~[]{}<>$:!-.=+"
-- | A piece of source text paired with the literal it is supposed to parse to.
-- For an escaping syntax these differ, for `unescapable` they are equal because
-- the only representable literals are the ones needing no escape.
data EscapedText = EscapedText
{ rendered :: Text,
literal :: Text
}
deriving (Show)
-- | Write a literal out in a form the syntax will read back as that literal.
escapeWith :: Escaper -> Text -> Text
escapeWith escaper = T.concatMap render
where
render c = case escaper.escapeChar of
Just escape | c `elem` escaper.specialChars -> escape c
_ -> T.singleton c
-- | Generate a literal the syntax can represent, paired with its source form.
--
-- Which literals are representable depends on the escaper: one with an escape
-- mechanism can carry any special character, one without can only carry the
-- characters that aren't special in the first place.
escapedText :: Escaper -> Gen Char -> Int -> Int -> Gen EscapedText
escapedText escaper base lo hi = escaped escaper <$> textOf char lo hi
where
ordinary = base `suchThat` (`notElem` escaper.specialChars)
char = case escaper.escapeChar of
-- nothing needing an escape can be represented, so don't generate it
Nothing -> ordinary
Just _ -> frequency [(3, ordinary), (1, elements escaper.specialChars)]
escaped :: Escaper -> Text -> EscapedText
escaped escaper t = EscapedText {literal = t, rendered = escapeWith escaper t}
-- | Text destined for the Markdown parser's inline layer, in source form and in
-- the form it should come back out as. The two are equal for as long as
-- `markdownEscaper` is `unescapable`; pointing it at `backslashEscaper` once
-- Markdown.hs handles escapes turns every property using this into a test of
-- that handling, without the properties themselves changing.
newtype MarkdownText = MarkdownText EscapedText
deriving (Show)
instance Arbitrary MarkdownText where
arbitrary = MarkdownText <$> escapedText markdownEscaper alphaNumChar 1 20
shrink (MarkdownText t) = MarkdownText . escaped markdownEscaper <$> shrinkTextWith (not . T.null) t.literal
-- | The same for Djot, where the escaper does have an escape mechanism, so the
-- generated literals contain the special characters and the source form is the
-- backslash escaped version of them.
newtype DjotText = DjotText EscapedText
deriving (Show)
instance Arbitrary DjotText where
arbitrary = DjotText <$> escapedText djotEscaper alphaNumChar 1 20
shrink (DjotText t) = DjotText . escaped djotEscaper <$> shrinkTextWith (not . T.null) t.literal

351
tests/Test/Gen/Document.hs
View file

@ -1,351 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
-- | Generating whole documents.
--
-- A `DocSpec` is a description of a document that can be turned into both the
-- source text to feed the parser and the `IR.Document` that source is supposed
-- to parse to. Generating the spec rather than a source string is what lets the
-- two stay in step under shrinking, a shrunk spec re-renders and re-derives its
-- own expectation.
--
-- Rendering goes through a `Syntax` so the Djot suite can reuse the spec type
-- and the expectations, and only supply its own surface syntax.
--
-- The grammar here is deliberately a subset of what Markdown.hs accepts. It
-- leaves out the constructs that do not currently round trip:
--
-- * fenced code blocks, `fencedCodeBlock` inverts its language test and
-- reports Nothing for a fence that names a language
-- * multi line block quotes, the first line's plain text runs past the
-- newline and swallows the following lines
-- * underlines and images, both are only recognised at the very start of an
-- inline run because _ and ! are missing from the set of characters plain
-- text stops at
--
-- Adding any of those to the generator once the parser handles them is a
-- one-constructor change, which is the point of generating documents rather
-- than writing the cases out by hand.
module Test.Gen.Document
( DocSpec (..),
BlockSpec (..),
ItemSpec (..),
InlineSpec (..),
Marker (..),
Run,
mkRun,
Syntax (..),
markdownSyntax,
djotSyntax,
render,
expected,
)
where
import Data.Text (Text)
import qualified Data.Text as T
import IR
import Test.Gen (shrinkTextWith, wordsOf)
import Test.QuickCheck (Arbitrary (arbitrary, shrink), Gen, chooseInt, elements, frequency, shrinkList, sized, vectorOf)
newtype DocSpec = DocSpec [BlockSpec]
deriving (Show)
data BlockSpec
= ParagraphS Run
| HeadingS Int Run
| -- a single line, see the note above about multi line quotes
QuoteS Run
| ListS Marker [ItemSpec]
deriving (Show)
-- | A list item, optionally followed by a nested list of its own. The nested
-- list's items are flat, one level of nesting is enough to exercise the
-- indentation handling.
data ItemSpec = ItemS Run (Maybe (Marker, [Run]))
deriving (Show)
-- | The character a list marker is written with. Carried in the spec so that a
-- failure reports which one was in play, and so shrinking can normalise it.
data Marker
= Bullet Char
| Numbered Char
deriving (Show)
data InlineSpec
= PlainS Text
| BoldS Text
| ItalicS Text
| CrossedS Text
| CodeS Text
| LinkS Text Text
deriving (Show)
-- | An inline run. Adjacent plain pieces are merged, the parser would produce a
-- single text node for them and the expectation has to match.
type Run = [InlineSpec]
mkRun :: [InlineSpec] -> Run
mkRun = separate . merge
where
merge (PlainS a : PlainS b : rest) = merge (PlainS (a <> b) : rest)
merge (x : rest) = x : merge rest
merge [] = []
-- two markup elements written back to back are ambiguous whenever they
-- share a delimiter character: `a``b` is a verbatim span that failed to
-- close, not two spans, and the reference says as much ("opening and
-- closing backticks must match in length"). a space between them costs the
-- test nothing and makes every generated run mean one thing.
separate (a : b : rest)
| not (isPlain a) && not (isPlain b) = a : PlainS " " : separate (b : rest)
separate (x : rest) = x : separate rest
separate [] = []
isPlain (PlainS _) = True
isPlain _ = False
-- * generation
instance Arbitrary DocSpec where
arbitrary = sized $ \size -> do
count <- chooseInt (1, 1 + min 3 (size `div` 8))
DocSpec . mkBlocks <$> vectorOf count blockSpec
-- an empty document is legitimate, `document` is a `many`
shrink (DocSpec blocks) = DocSpec . mkBlocks <$> shrinkList shrinkBlock blocks
-- | In djot a blank line between two items only makes the list loose, so two
-- lists written one after the other are a single list rather than two blocks.
-- A document therefore never places two lists next to each other; dropping the
-- second is the normalisation that survives shrinking, inserting a separator
-- between them would grow the value the shrinker just made smaller.
mkBlocks :: [BlockSpec] -> [BlockSpec]
mkBlocks (first@(ListS _ _) : ListS _ _ : rest) = mkBlocks (first : rest)
mkBlocks (block : rest) = block : mkBlocks rest
mkBlocks [] = []
blockSpec :: Gen BlockSpec
blockSpec =
frequency
[ (4, ParagraphS <$> runSpec),
(2, HeadingS <$> chooseInt (1, 6) <*> runSpec),
(2, QuoteS <$> runSpec),
(2, ListS <$> markerSpec <*> itemsSpec)
]
markerSpec :: Gen Marker
markerSpec =
frequency
[ (1, Bullet <$> elements "-*+"),
(1, Numbered <$> elements ".)")
]
itemsSpec :: Gen [ItemSpec]
itemsSpec = do
count <- chooseInt (1, 3)
vectorOf count itemSpec
itemSpec :: Gen ItemSpec
itemSpec = ItemS <$> runSpec <*> frequency [(3, pure Nothing), (1, Just <$> nested)]
where
nested = do
marker <- markerSpec
count <- chooseInt (1, 2)
runs <- vectorOf count runSpec
pure (marker, runs)
runSpec :: Gen Run
runSpec = do
count <- chooseInt (1, 4)
mkRun <$> vectorOf count inlineSpec
inlineSpec :: Gen InlineSpec
inlineSpec =
frequency
[ (5, PlainS <$> wordsOf),
(1, BoldS <$> wordsOf),
(1, ItalicS <$> wordsOf),
(1, CrossedS <$> wordsOf),
(1, CodeS <$> wordsOf),
-- a url with a space in it would be parsed as a url plus a title
(1, LinkS <$> wordsOf <*> word)
]
where
word = T.filter (/= ' ') <$> wordsOf
-- * shrinking
shrinkBlock :: BlockSpec -> [BlockSpec]
shrinkBlock (ParagraphS run) = ParagraphS <$> shrinkRun run
shrinkBlock (HeadingS level run) =
[ParagraphS run]
<> [HeadingS level' run | level' <- [1 .. level - 1]]
<> (HeadingS level <$> shrinkRun run)
shrinkBlock (QuoteS run) = [ParagraphS run] <> (QuoteS <$> shrinkRun run)
shrinkBlock (ListS marker items) =
[ParagraphS run | ItemS run _ <- take 1 items]
<> (ListS <$> shrinkMarker marker <*> pure items)
-- `some listItem`, a list with no items is not a list
<> [ListS marker items' | items' <- shrinkList shrinkItem items, not (null items')]
shrinkMarker :: Marker -> [Marker]
shrinkMarker (Bullet c) = [Bullet '-' | c /= '-']
shrinkMarker (Numbered c) = [Numbered '.' | c /= '.']
shrinkItem :: ItemSpec -> [ItemSpec]
shrinkItem (ItemS run nested) =
[ItemS run Nothing | Just _ <- [nested]]
<> (ItemS <$> shrinkRun run <*> pure nested)
<> [ItemS run (Just (marker, runs')) | Just (marker, runs) <- [nested], runs' <- shrinkList shrinkRun runs, not (null runs')]
-- | A run is never empty, an empty one renders to nothing at all and the block
-- around it stops being the block the spec describes.
shrinkRun :: Run -> [Run]
shrinkRun run = [mkRun shrunk | shrunk <- shrinkList shrinkInline run, not (null shrunk)]
shrinkInline :: InlineSpec -> [InlineSpec]
shrinkInline (PlainS t) = PlainS <$> shrinkContent t
shrinkInline (BoldS t) = [PlainS t] <> (BoldS <$> shrinkContent t)
shrinkInline (ItalicS t) = [PlainS t] <> (ItalicS <$> shrinkContent t)
shrinkInline (CrossedS t) = [PlainS t] <> (CrossedS <$> shrinkContent t)
shrinkInline (CodeS t) = [PlainS t] <> (CodeS <$> shrinkContent t)
shrinkInline (LinkS t url) =
[PlainS t]
<> [LinkS t' url | t' <- shrinkContent t]
<> [LinkS t url' | url' <- shrinkContent url, not (T.any (== ' ') url')]
shrinkContent :: Text -> [Text]
shrinkContent = shrinkTextWith (\t -> not (T.null t) && T.last t /= ' ')
-- * rendering
-- | The surface syntax a spec is written out in, and the two places where the
-- two syntaxes disagree about what the result should be. The rest of the
-- expectations are shared.
data Syntax = Syntax
{ renderInline :: InlineSpec -> Text,
renderHeading :: Int -> Text -> Text,
renderQuote :: Text -> Text,
-- | marker, depth, one based index within the list, content
renderItem :: Marker -> Int -> Int -> Text -> Text,
blockSeparator :: Text,
-- | how the single line of a quote appears inside the BlockQuote. Djot
-- parses a quote's contents as blocks, so it is a Paragraph; the Markdown
-- parser collects inlines and wraps them in a Transparent.
quoteContent :: [InlineText] -> Element,
-- | djot reads the start number and style off the first marker, the
-- Markdown parser does not record either
listTypeFor :: Marker -> ListType
}
markdownSyntax :: Syntax
markdownSyntax =
Syntax
{ renderInline = \case
PlainS t -> t
BoldS t -> "**" <> t <> "**"
ItalicS t -> "*" <> t <> "*"
CrossedS t -> "~~" <> t <> "~~"
CodeS t -> "`" <> t <> "`"
LinkS t url -> "[" <> t <> "](" <> url <> ")",
renderHeading = \level content -> T.replicate level "#" <> " " <> content,
renderQuote = \content -> "> " <> content,
renderItem = \marker depth index content ->
T.replicate depth " " <> marked marker index <> " " <> content,
blockSeparator = "\n\n",
quoteContent = Transparent,
listTypeFor = \case
Bullet _ -> Unordered {style = Nothing}
Numbered _ -> Ordered {start_number = Nothing, style = Nothing}
}
-- | Djot. Strong is @*@ and emphasis @_@, delete has to be written in its
-- braced form, and the rest lines up with the markdown spelling.
djotSyntax :: Syntax
djotSyntax =
Syntax
{ renderInline = \case
PlainS t -> t
BoldS t -> "*" <> t <> "*"
ItalicS t -> "_" <> t <> "_"
CrossedS t -> "{-" <> t <> "-}"
CodeS t -> "`" <> t <> "`"
LinkS t url -> "[" <> t <> "](" <> url <> ")",
renderHeading = \level content -> T.replicate level "#" <> " " <> content,
renderQuote = \content -> "> " <> content,
renderItem = \marker depth index content ->
T.replicate depth " " <> marked marker index <> " " <> content,
blockSeparator = "\n\n",
quoteContent = \content -> Paragraph (P content) mempty,
listTypeFor = \case
Bullet _ -> Unordered {style = Nothing}
-- the generator numbers items from one, and a decimal marker carries no
-- style
Numbered _ -> Ordered {start_number = Just 1, style = Nothing}
}
marked :: Marker -> Int -> Text
marked (Bullet c) _ = T.singleton c
marked (Numbered c) index = T.pack (show index) <> T.singleton c
render :: Syntax -> DocSpec -> Text
render syntax (DocSpec blocks) = T.intercalate syntax.blockSeparator $ map (renderBlock syntax) blocks
renderBlock :: Syntax -> BlockSpec -> Text
renderBlock syntax = \case
ParagraphS run -> renderRun syntax run
HeadingS level run -> syntax.renderHeading level (renderRun syntax run)
QuoteS run -> syntax.renderQuote (renderRun syntax run)
ListS marker items -> T.intercalate "\n" $ renderItems syntax marker 0 items
renderItems :: Syntax -> Marker -> Int -> [ItemSpec] -> [Text]
renderItems syntax marker depth items = concat $ zipWith one [1 ..] items
where
one index (ItemS run nested) =
syntax.renderItem marker depth index (renderRun syntax run)
: case nested of
Nothing -> []
Just (child_marker, runs) ->
renderItems syntax child_marker (depth + 1) [ItemS run' Nothing | run' <- runs]
-- | Inline elements are written with nothing between them. Plain pieces carry
-- their own spacing and adjacent plain pieces have already been merged, so a
-- separator here would be text the expectation does not account for.
renderRun :: Syntax -> Run -> Text
renderRun syntax = T.concat . map syntax.renderInline
-- * expectations
expected :: Syntax -> DocSpec -> Document
expected syntax (DocSpec blocks) = Doc $ map (expectedBlock syntax) blocks
expectedBlock :: Syntax -> BlockSpec -> Element
expectedBlock syntax = \case
ParagraphS run -> Paragraph (P (expectedRun run)) mempty
HeadingS level run -> Heading (H {level, text = expectedRun run}) mempty
QuoteS run -> BlockQuote (Q [syntax.quoteContent (expectedRun run)]) mempty
ListS marker items -> List (expectedList syntax marker items) mempty
expectedList :: Syntax -> Marker -> [ItemSpec] -> List
expectedList syntax marker items =
L {list_type = syntax.listTypeFor marker, items = map (expectedItem syntax) items}
-- | A tight item's paragraph is unwrapped by both parsers, so its content is a
-- Transparent regardless of syntax.
expectedItem :: Syntax -> ItemSpec -> ListItem
expectedItem syntax (ItemS run nested) = LI {content = Transparent (expectedRun run) : child}
where
child = case nested of
Nothing -> []
Just (marker, runs) ->
[List (expectedList syntax marker [ItemS run' Nothing | run' <- runs]) mempty]
expectedRun :: Run -> [InlineText]
expectedRun = map expectedInline
expectedInline :: InlineSpec -> InlineText
expectedInline = \case
PlainS t -> Text t
BoldS t -> Bold [Text t] mempty
ItalicS t -> Italic [Text t] mempty
CrossedS t -> Crossed [Text t] mempty
CodeS t -> InlineCode t mempty
LinkS t url -> Link {linkText = [Text t], url, title = Nothing, misc_attrs = mempty}

98
tests/Test/Harness.hs
View file

@ -1,98 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
-- | Running a document parser inside a property and turning the result into a
-- QuickCheck verdict. Everything here is parser agnostic so the Djot suite can
-- share it with the Markdown one.
module Test.Harness
( DocumentParser,
markdownDocument,
djotDocument,
shouldParseTo,
shouldParse,
succeed,
failWith,
)
where
import Control.Exception (evaluate)
import Data.Functor.Identity (Identity)
import Data.Text (Text)
import Data.Void (Void)
import qualified Djot
import IR (Document)
import qualified Markdown
import System.Timeout (timeout)
import Test.QuickCheck (counterexample)
import Test.QuickCheck.Monadic (PropertyM, run, stop)
import Text.Megaparsec (ParsecT, errorBundlePretty, parse)
-- | A document parser pinned to the concrete stream and monad the tests use.
type DocumentParser = ParsecT Void Text Identity Document
markdownDocument :: DocumentParser
markdownDocument = Markdown.document
djotDocument :: DocumentParser
djotDocument = Djot.document
-- | What running a parser over an input told us. Timeouts are a failure mode in
-- their own right because a parser bug is much more likely to loop than to
-- throw.
data Outcome
= TimedOut
| Failed String
| Passed
-- | 1 second, every test here should finish orders of magnitude below that
parseTimeout :: Int
parseTimeout = 1000000
-- | Both the parse and the check on its result happen inside the timeout, a
-- comparison against a lazily built infinite tree would otherwise hang outside
-- of it.
attempt :: DocumentParser -> Text -> (Document -> Maybe String) -> PropertyM IO Outcome
attempt parser input check = do
result <- run $
timeout parseTimeout $ do
parsed <- evaluate $ parse parser "test_input" input
case parsed of
Left e -> pure . Failed $ errorBundlePretty e
Right actual -> case check actual of
Nothing -> pure Passed
Just message -> do
-- force the message, building it is what forces the tree
_ <- evaluate $ length message
pure $ Failed message
pure $ maybe TimedOut id result
verdict :: Outcome -> PropertyM IO ()
verdict TimedOut = failWith "Hit Timeout"
verdict (Failed message) = failWith message
verdict Passed = succeed
-- | The input must parse to exactly this tree.
shouldParseTo :: DocumentParser -> Text -> Document -> PropertyM IO ()
shouldParseTo parser input expected = verdict =<< attempt parser input check
where
check actual
| actual == expected = Nothing
| otherwise =
Just $
unlines
[ "input: " <> show input,
"expected: " <> show expected,
"actual: " <> show actual
]
-- | The input must parse, with no claim about what it parses to. For the cases
-- where the parser only has to not fall over.
shouldParse :: DocumentParser -> Text -> PropertyM IO ()
shouldParse parser input = verdict =<< attempt parser input (const Nothing)
-- | the equivalent of Hedgehog's `success`
succeed :: PropertyM IO ()
succeed = pure ()
-- | the equivalent of Hedgehog's `fail`
failWith :: String -> PropertyM IO a
failWith message = stop $ counterexample message False