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

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

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

main :: IO ()
main = hspec $ do
  describe "Lexer" do
    describe "minimal" do
      it "bare string" someString
      it "emphasis" emphatic
      it "monospace" monospace
      it "ignores nesting" ignoreNesting
  describe "Parser" do
    it "Bold" do
      "__bold__" `shouldParseTo` (DocBold (DocString "bold"))
    it "Emphasis" do
      "/emphasis/" `shouldParseTo` (DocEmphasis (DocString "emphasis"))

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

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

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

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