psb/tests/Test/Gen/Document.hs

{-# 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}