haddock2/test/Spec.hs

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

import Test.Hspec

import Identifier (Identifier)
import Lexer
import Parser
import Types

import Data.String (IsString (..))
import Data.Text (Text)
import GHC.Stack
import Text.Parsec.Pos

main :: IO ()
main = hspec $ do
  describe "Lexer" do
    describe "minimal" do
      it "handles unicode" unicode
      it "escapes" escaping
      it "maths" math
      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 "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")
                  ]

math :: IO ()
math = 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 =
  ">> code"
    `shouldLexTo` [ (1, 1, BirdTrack)
                  , (1, 4, Token "code")
                  ]

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)
                  ]

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