property tests for the djot parser
Expectations come from the djot syntax reference and IR.hs rather than from what the parser currently produces, so a failure is evidence of a bug instead of a record of one. 55 properties: 32 inline (emphasis, verbatim, math, raw, links, images, references, autolinks, spans, attributes, footnotes, symbols, escapes, smart punctuation) and 23 block (headings, quotes, breaks, code fences, divs, raw blocks, every ordered marker style and delimiter, tight vs loose items, nesting, task lists, definition lists, tables, definitions, block attributes, round trip). Two rules are deliberately unasserted and noted in the module header: headings of seven or more hashes, and the general verbatim space stripping rule, of which only the unambiguous backtick case is tested. Three deviations the suite found, fixed in Djot.hs: - an unclosed verbatim span failed the construct back into plain text. The reference says it "extends to the end of the text"; manyTill cannot say that on its own, it needs the eof alternative. - a task list checkbox was recognised without the space the reference requires after it, so "1. [x](5)" ate a link and turned it into a checked item containing a list starting at 5. - checkboxes were recognised on ordered items, but the reference gives them to bullet items only. Test.Gen.Document is now shared by both suites. Syntax grew quoteContent and listTypeFor for the two places markdown and djot disagree about the resulting IR, and two djot facts became generator invariants rather than assertions: adjacent markup sharing a delimiter is ambiguous, so runs separate it, and a blank line between two lists makes one loose list rather than two blocks, so documents never place lists back to back. The test suite is no longer markdown only, so it is just "tests" now. Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
This commit is contained in:
Pagwin
parent
96db1f999c
commit
0f356e4d5e
8 changed files with 869 additions and 36 deletions
|
|
@ -32,11 +32,11 @@ library
|
|||
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
|
||||
|
||||
test-suite test-markdown-parse
|
||||
test-suite tests
|
||||
hs-source-dirs: tests
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Main.hs
|
||||
other-modules: Test.Gen, Test.Gen.Document, Test.Harness, Markdown.Parse
|
||||
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
|
||||
|
||||
default-extensions: ApplicativeDo DataKinds NamedFieldPuns DerivingVia LambdaCase TypeApplications DeriveGeneric OverloadedRecordDot NamedFieldPuns DuplicateRecordFields DisambiguateRecordFields FlexibleInstances
|
||||
|
|
|
|||
18
src/Djot.hs
18
src/Djot.hs
|
|
@ -702,7 +702,7 @@ listItem expected = do
|
|||
Nothing -> pure ()
|
||||
void rawLine
|
||||
let afterMarker = T.drop contentIndent first
|
||||
(itemChecked, firstLine) = checkbox afterMarker
|
||||
(itemChecked, firstLine) = checkbox marker afterMarker
|
||||
rest <- continuationLines contentIndent True
|
||||
pure
|
||||
RawItem
|
||||
|
|
@ -712,14 +712,19 @@ listItem expected = do
|
|||
itemLoose = any isBlank rest
|
||||
}
|
||||
where
|
||||
checkbox t = case T.uncons (T.stripStart t) of
|
||||
-- "a bullet list item that begins with `[ ]`, `[X]`, or `[x]` followed by a
|
||||
-- space is a task list item". Both halves of that matter: an ordered item
|
||||
-- never carries a checkbox, and without the space `[x](url)` at the start of
|
||||
-- an item would be read as one instead of as a link.
|
||||
checkbox (MBullet _) t = case T.uncons (T.stripStart t) of
|
||||
Just ('[', rest) -> case T.uncons rest of
|
||||
Just (mark, rest') | mark `elem` (" xX" :: String) ->
|
||||
case T.stripPrefix "]" rest' of
|
||||
Just body -> (Just (mark /= ' '), T.stripStart body)
|
||||
Nothing -> (Nothing, t)
|
||||
Just body | T.null body || isIndentChar (T.head body) -> (Just (mark /= ' '), T.stripStart body)
|
||||
_ -> (Nothing, t)
|
||||
_ -> (Nothing, t)
|
||||
_ -> (Nothing, t)
|
||||
checkbox _ t = (Nothing, t)
|
||||
|
||||
-- | Lines belonging to an indented continuation of a block (list item bodies,
|
||||
-- footnote definitions).
|
||||
|
|
@ -834,7 +839,10 @@ verbatimText :: (Logger m, Characters s) => Parser s m Text
|
|||
verbatimText = do
|
||||
ticks <- some (char '`')
|
||||
let n = length ticks
|
||||
content <- T.pack <$> manyTill anySingle (try (closing n))
|
||||
-- "if no closing backticks are found, the verbatim span extends to the end of
|
||||
-- the text", so running out of input closes the span rather than failing the
|
||||
-- whole construct back into plain text
|
||||
content <- T.pack <$> manyTill anySingle (try (closing n) <|> eof)
|
||||
pure $ trimVerbatim content
|
||||
where
|
||||
closing n = count n (char '`') *> notFollowedBy (char '`')
|
||||
|
|
|
|||
706
tests/Djot/Parse.hs
Normal file
706
tests/Djot/Parse.hs
Normal file
|
|
@ -0,0 +1,706 @@
|
|||
{-# 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
|
||||
|
|
@ -1,5 +1,6 @@
|
|||
module Main (main) where
|
||||
|
||||
import qualified Djot.Parse
|
||||
import qualified Markdown.Parse
|
||||
import Test.Tasty (defaultMain, testGroup)
|
||||
|
||||
|
|
@ -8,5 +9,6 @@ main =
|
|||
defaultMain $
|
||||
testGroup
|
||||
"Parse Tests"
|
||||
[ Markdown.Parse.tests
|
||||
[ Markdown.Parse.tests,
|
||||
Djot.Parse.tests
|
||||
]
|
||||
|
|
|
|||
|
|
@ -224,6 +224,6 @@ document_round_trip :: DocSpec -> Property
|
|||
document_round_trip spec =
|
||||
counterexample (T.unpack source) $
|
||||
monadicIO $
|
||||
shouldParseTo markdownDocument source (expected spec)
|
||||
shouldParseTo markdownDocument source (expected markdownSyntax spec)
|
||||
where
|
||||
source = render markdownSyntax spec
|
||||
|
|
|
|||
|
|
@ -29,6 +29,8 @@ module Test.Gen
|
|||
AsciiText (..),
|
||||
AlphaText (..),
|
||||
AlphaNumText (..),
|
||||
VerbatimText (..),
|
||||
UrlText (..),
|
||||
HeaderLevel (..),
|
||||
|
||||
-- * escaping
|
||||
|
|
@ -36,10 +38,12 @@ module Test.Gen
|
|||
backslashEscaper,
|
||||
unescapable,
|
||||
markdownEscaper,
|
||||
djotEscaper,
|
||||
escapeWith,
|
||||
EscapedText (..),
|
||||
escapedText,
|
||||
MarkdownText (..),
|
||||
DjotText (..),
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -102,6 +106,32 @@ 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)
|
||||
|
||||
|
|
@ -132,6 +162,16 @@ unescapable cs = Escaper {specialChars = cs, escapeChar = Nothing}
|
|||
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.
|
||||
|
|
@ -177,3 +217,13 @@ newtype MarkdownText = MarkdownText EscapedText
|
|||
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
|
||||
|
|
|
|||
|
|
@ -35,6 +35,7 @@ module Test.Gen.Document
|
|||
mkRun,
|
||||
Syntax (..),
|
||||
markdownSyntax,
|
||||
djotSyntax,
|
||||
render,
|
||||
expected,
|
||||
)
|
||||
|
|
@ -84,19 +85,42 @@ data InlineSpec
|
|||
type Run = [InlineSpec]
|
||||
|
||||
mkRun :: [InlineSpec] -> Run
|
||||
mkRun (PlainS a : PlainS b : rest) = mkRun (PlainS (a <> b) : rest)
|
||||
mkRun (x : rest) = x : mkRun rest
|
||||
mkRun [] = []
|
||||
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 <$> vectorOf count blockSpec
|
||||
DocSpec . mkBlocks <$> vectorOf count blockSpec
|
||||
|
||||
-- an empty document is legitimate, `document` is a `many`
|
||||
shrink (DocSpec blocks) = DocSpec <$> shrinkList shrinkBlock blocks
|
||||
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 =
|
||||
|
|
@ -193,15 +217,23 @@ shrinkContent = shrinkTextWith (\t -> not (T.null t) && T.last t /= ' ')
|
|||
|
||||
-- * rendering
|
||||
|
||||
-- | The surface syntax a spec is written out in. The expectations are shared,
|
||||
-- only this differs between Markdown and Djot.
|
||||
-- | 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
|
||||
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
|
||||
|
|
@ -218,11 +250,41 @@ markdownSyntax =
|
|||
renderQuote = \content -> "> " <> content,
|
||||
renderItem = \marker depth index content ->
|
||||
T.replicate depth " " <> marked marker index <> " " <> content,
|
||||
blockSeparator = "\n\n"
|
||||
blockSeparator = "\n\n",
|
||||
quoteContent = Transparent,
|
||||
listTypeFor = \case
|
||||
Bullet _ -> Unordered {style = Nothing}
|
||||
Numbered _ -> Ordered {start_number = Nothing, style = Nothing}
|
||||
}
|
||||
where
|
||||
marked (Bullet c) _ = T.singleton c
|
||||
marked (Numbered c) index = T.pack (show index) <> T.singleton c
|
||||
|
||||
-- | 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
|
||||
|
|
@ -252,29 +314,29 @@ renderRun syntax = T.concat . map syntax.renderInline
|
|||
|
||||
-- * expectations
|
||||
|
||||
expected :: DocSpec -> Document
|
||||
expected (DocSpec blocks) = Doc $ map expectedBlock blocks
|
||||
expected :: Syntax -> DocSpec -> Document
|
||||
expected syntax (DocSpec blocks) = Doc $ map (expectedBlock syntax) blocks
|
||||
|
||||
expectedBlock :: BlockSpec -> Element
|
||||
expectedBlock = \case
|
||||
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 [Transparent (expectedRun run)]) mempty
|
||||
ListS marker items -> List (expectedList marker items) mempty
|
||||
QuoteS run -> BlockQuote (Q [syntax.quoteContent (expectedRun run)]) mempty
|
||||
ListS marker items -> List (expectedList syntax marker items) mempty
|
||||
|
||||
expectedList :: Marker -> [ItemSpec] -> List
|
||||
expectedList marker items = L {list_type = expectedType marker, items = map expectedItem items}
|
||||
expectedList :: Syntax -> Marker -> [ItemSpec] -> List
|
||||
expectedList syntax marker items =
|
||||
L {list_type = syntax.listTypeFor marker, items = map (expectedItem syntax) items}
|
||||
|
||||
expectedType :: Marker -> ListType
|
||||
expectedType (Bullet _) = Unordered {style = Nothing}
|
||||
expectedType (Numbered _) = Ordered {start_number = Nothing, style = Nothing}
|
||||
|
||||
expectedItem :: ItemSpec -> ListItem
|
||||
expectedItem (ItemS run nested) = LI {content = Transparent (expectedRun run) : child}
|
||||
-- | 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 marker [ItemS run' Nothing | run' <- runs]) mempty]
|
||||
Just (marker, runs) ->
|
||||
[List (expectedList syntax marker [ItemS run' Nothing | run' <- runs]) mempty]
|
||||
|
||||
expectedRun :: Run -> [InlineText]
|
||||
expectedRun = map expectedInline
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@
|
|||
module Test.Harness
|
||||
( DocumentParser,
|
||||
markdownDocument,
|
||||
djotDocument,
|
||||
shouldParseTo,
|
||||
shouldParse,
|
||||
succeed,
|
||||
|
|
@ -17,6 +18,7 @@ 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)
|
||||
|
|
@ -30,6 +32,9 @@ 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.
|
||||
|
|
|
|||
Loading…
Reference in a new issue