psb/tests/Test/Gen.hs

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