haddock2/test/Spec.hs

{-# LANGUAGE MultilineStrings #-}
{-# 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 "emphasis" emphatic
      it "bold" bolded
      it "monospace" monospace
      it "module names" modules
      it "labeled link" labeledLink
      it "markdown link" link
      it "anchors" anchor
      it "images" images
      it "maths" math
      it "numeric entity" numericEntity
      it "code blocks" codeBlocks
      it "bird tracks" birdTracks
      it "expressions" expressions

      it "escapes" escaping
      it "space chars" space
      it "bare string" someString
      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
------------

images :: Expectation
images = do
  "<<image.png>>"
    `shouldLexTo` [ (1, 3, Picture "image.png" Nothing)
                  ]
  "<<image.png title text>>"
    `shouldLexTo` [ (1, 3, Picture "image.png" (Just "title text"))
                  ]
  "![alt text](image.png)"
    `shouldLexTo` [ (1, 3, Picture "image.png" (Just "alt text"))
                  ]

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

expressions :: Expectation
expressions = do
  """
  >>> expression
  result line 1
  result line 2

  """
    `shouldLexTo` [ (1, 1, Expression)
                  , (1, 5, Token "expression")
                  , (2, 1, ResultLine "result line 1")
                  , (3, 1, ResultLine "result line 2")
                  ]
  """
  >>> expression
  result line 3
  result line 4
  """
    `shouldLexTo` [ (1, 1, Expression)
                  , (1, 5, Token "expression")
                  , (2, 1, ResultLine "result line 3")
                  , (3, 1, ResultLine "result line 4")
                  ]

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

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

codeBlocks :: Expectation
codeBlocks =
  """
  @
  func call here
  @
  """
    `shouldLexTo` [ (1, 1, MonospaceOpen)
                  , (1, 2, Token "\nfunc call here\n")
                  , (3, 1, MonospaceClose)
                  ]

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

bolded :: Expectation
bolded =
  "__bold text__"
    `shouldLexTo` [ (1, 1, BoldOpen)
                  , (1, 3, Token "bold text")
                  , (1, 12, BoldClose)
                  ]

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