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 Text.Parsec.Pos
import GHC.Stack

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