haddock2/test/Spec.hs

{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-orphans #-}

import Data.String (IsString (..))
import Data.Text (Text)
import GHC.Stack
import Identifier (Identifier)
import Lexer
import Parser
import Types

import Test.Hspec
import Text.Parsec.Pos

main :: IO ()
main = hspec $ do
  describe "Lexer" do
    describe "minimal" do
      it "handles unicode" unicode
      it "escapes" escaping
      it "maths" maths
      it "anchors" anchor
      it "space chars" space
      it "bare string" someString
      it "emphasis" emphatic
      it "monospace" monospace
      it "labeled link" labeledLink
      it "markdown link" link
      it "bird tracks" birdTracks
      it "module names" modules
      it "quotes" quotes
      it "expressions" expressions
      it "numeric entity" numericEntity
      it "ignores nesting" ignoreNesting

  describe "Parser" do
    it "Bold" do
      "__bold__" `shouldParseTo` DocBold (DocString "bold")
    it "Emphasis" do
      "/emphasis/" `shouldParseTo` DocEmphasis (DocString "emphasis")

------------
-- Tests
------------

modules :: Expectation
modules = do
  "\"MyModule.Name\""
    `shouldLexTo` [ (1, 2, Module "MyModule.Name")
                  ]

  "\"OtherModule.Name#myAnchor\""
    `shouldLexTo` [ (1, 2, Module "OtherModule.Name")
                  , (1, 18, Anchor "myAnchor")
                  ]

  "\"OtherModule.Name\\#myAnchor\""
    `shouldLexTo` [ (1, 2, Module "OtherModule.Name")
                  , (1, 18, Anchor "myAnchor")
                  ]

link :: Expectation
link =
  "[link to](http://some.website)"
    `shouldLexTo` [ (1, 1, LinkOpen)
                  , (1, 1, BracketOpen)
                  , (1, 2, Token "link to")
                  , (1, 9, BracketClose)
                  , (1, 10, ParenOpen)
                  , (1, 11, Token "http://some.website")
                  , (1, 30, ParenClose)
                  , (1, 30, LinkClose)
                  ]

labeledLink :: Expectation
labeledLink =
  "<[link here](http://to.here) label>"
    `shouldLexTo` [ (1, 1, LabeledLinkOpen)
                  , (1, 2, BracketOpen)
                  , (1, 3, Token "link here")
                  , (1, 12, BracketClose)
                  , (1, 13, ParenOpen)
                  , (1, 14, Token "http://to.here")
                  , (1, 28, ParenClose)
                  , (1, 29, Token " label")
                  , (1, 35, LabeledLinkClose)
                  ]

anchor :: Expectation
anchor =
  "#myAnchor#"
    `shouldLexTo` [ (1, 1, Anchor "myAnchor")
                  ]

maths :: IO ()
maths = do
  "\\[some math\\]"
    `shouldLexTo` [ (1, 1, MathMultilineOpen)
                  , (1, 3, Token "some math")
                  , (1, 12, MathMultilineClose)
                  ]
  "\\(other maths\\)"
    `shouldLexTo` [ (1, 1, MathInlineOpen)
                  , (1, 3, Token "other maths")
                  , (1, 14, MathInlineClose)
                  ]

escaping :: Expectation
escaping = do
  "\\("
    `shouldLexTo` [ (1, 1, Escape)
                  , (1, 2, Token "(")
                  ]
  "\\(\r\n"
    `shouldLexTo` [ (1, 1, Escape)
                  , (1, 2, Token "(")
                  ]

unicode :: Expectation
unicode =
  "ドラゴンクエストの冒険者🐉"
    `shouldLexTo` [ (1, 1, Token "ドラゴンクエストの冒険者🐉")
                  ]

ignoreNesting :: Expectation
ignoreNesting =
  ">/foo/"
    `shouldLexTo` [ (1, 1, Token ">/foo/")
                  ]

birdTracks :: Expectation
birdTracks = do
  "> code line"
    `shouldLexTo` [ (1, 1, BirdTrack)
                  , (1, 3, Token "code line")
                  ]
  " > not code"
    `shouldLexTo` [ (1, 1, Space)
                  , (1, 2, Token ">")
                  , (1, 3, Space)
                  , (1, 4, Token "not")
                  , (1, 7, Space)
                  , (1, 8, Token "code")
                  ]

expressions :: Expectation
expressions = do
  ">>> eval this"
    `shouldLexTo` [ (1, 1, Expression)
                  , (1, 5, Token "eval this")
                  ]
  " >>> not eval this"
    `shouldLexTo` [ (1, 1, Space)
                  , (1, 2, Token ">>>")
                  , (1, 5, Space)
                  , (1, 6, Token "not")
                  , (1, 9, Space)
                  , (1, 10, Token "eval")
                  , (1, 14, Space)
                  , (1, 15, Token "this")
                  ]

quotes :: Expectation
quotes =
  "\"quoted\""
    `shouldLexTo` [ (1, 1, QuoteOpen)
                  , (1, 2, Token "quoted")
                  , (1, 8, QuoteClose)
                  ]

space :: Expectation
space = do
  "\n "
    `shouldLexTo` [ (1, 1, Newline)
                  , (2, 1, Space)
                  ]
  " \n"
    `shouldLexTo` [ (1, 1, Space)
                  , (1, 2, Newline)
                  ]

numericEntity :: Expectation
numericEntity = do
  "&#65; &#955;"
    `shouldLexTo` [ (1, 1, NumericEntity 65)
                  , (1, 6, Space)
                  , (1, 7, NumericEntity 955) -- lambda
                  ]
  -- Hex
  "&#x65;"
    `shouldLexTo` [ (1, 1, NumericEntity 101)
                  ]

monospace :: Expectation
monospace =
  "@mono@"
    `shouldLexTo` [ (1, 1, MonospaceOpen)
                  , (1, 2, Token "mono")
                  , (1, 6, MonospaceClose)
                  ]

emphatic :: Expectation
emphatic =
  "/emphatic/"
    `shouldLexTo` [ (1, 1, EmphasisOpen)
                  , (1, 2, Token "emphatic")
                  , (1, 10, EmphasisClose)
                  ]

someString :: Expectation
someString =
  "some string"
    `shouldLexTo` [ (1, 1, Token "some")
                  , (1, 5, Space)
                  , (1, 6, Token "string")
                  ]

--------------
-- Helpers
--------------

type Doc id = DocMarkup () id

instance IsString (Doc String) where
  fromString = DocString

shouldLexTo :: String -> [(Int, Int, Token)] -> Expectation
shouldLexTo input expected =
  withFrozenCallStack $
    case lexer input of
      Right tokens -> do
        let actual = map (\(pos, tok) -> (sourceLine pos, sourceColumn pos, tok)) tokens
        actual `shouldBe` expected
      Left err -> expectationFailure $ "Parse error: " <> show err

shouldParseTo :: Text -> DocMarkup mod Identifier -> Expectation
shouldParseTo input ast = parseText input `shouldBe` ast