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

main :: IO ()
main = hspec $ do
  describe "Lexer" do
    describe "minimal" do
      it "handles unicode" unicode
      it "escapes" escaping
      it "maths" maths
      it "space chars" space
      it "bare string" someString
      it "emphasis" emphatic
      it "monospace" monospace
      it "bird tracks" birdTracks
      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
------------

maths :: IO ()
maths = do
  "\\[some math\\]"
    `shouldLexTo` [ (1, 1, MathsBracketOpen)
                  , (1, 2, Token "some math")
                  , (1, 13, MathsBracketClose)
                  ]
  "\\(other maths\\)"
    `shouldLexTo` [ (1, 1, MathsParenOpen)
                  , (1, 2, Token "other maths")
                  , (1, 15, MathsParenClose)
                  ]

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

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

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

birdTracks :: Expectation
birdTracks =
  ">> code"
    `shouldLexTo` [ (1, 1, BirdTrack)
                  , (1, 2, 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 =
  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