{-# LANGUAGE NegativeLiterals #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

module Main (main) where

import Control.Monad (void)
import Data.Foldable (asum)
import Data.Functor (($>))
import Data.Sequence (Seq (..))
import qualified Data.Sequence as Seq
import qualified Data.Sequence.NonEmpty as NESeq
import Data.String (IsString)
import Data.Text (Text)
import qualified Data.Text as T
import SimpleParser
import SimpleParser.Examples.Common.Sexp (Atom (..), Sexp (..), SexpF (..))
import SimpleParser.Examples.Direct.Json (Json (..), JsonF (..), jsonParser)
import qualified SimpleParser.Examples.Direct.Sexp as SexpDirect
import qualified SimpleParser.Examples.Lexed.Sexp as SexpLexed
import Test.Tasty (TestName, TestTree, testGroup)
import Test.Tasty.HUnit (testCase, (@?=))
import Test.Tasty.TH (defaultMainGenerator)

newtype Label = Label { unLabel :: String } deriving (Eq, Show, IsString)

newtype Error = Error { unError :: String } deriving (Eq, Show, IsString)

type TestState = OffsetStream Text

type TestBlock a b = PureMatchBlock Label TestState Error a b

type TestParser a = Parser Label TestState Error a

type TestResult a = ParseResult Label TestState Error a

type TestRawError = RawError Text Char

type TestParseError = ParseError Label TestState Error

data ParserCase a = ParserCase !TestName !(TestParser a) !Text !(Maybe (TestResult a))

data ExamineCase a b = ExamineCase !TestName !(TestBlock a b) !Text !(LookAheadTestResult Label)

fwd :: Int -> TestState -> TestState
fwd n (OffsetStream (Offset i) t) =
  let m = min n (T.length t)
  in OffsetStream (Offset (i + m)) (T.drop m t)

sucRes :: TestState -> a -> Maybe (TestResult a)
sucRes st = Just . ParseResultSuccess . ParseSuccess st

errRes :: [TestParseError] -> Maybe (TestResult a)
errRes es = Just (ParseResultError (ParseErrorBundle (NESeq.unsafeFromSeq (Seq.fromList es))))

custErr :: TestState -> Error -> TestParseError
custErr endSt = ParseError emptyStack endSt . CompoundErrorCustom

stmErr :: TestState -> TestRawError -> TestParseError
stmErr endSt = ParseError emptyStack endSt . CompoundErrorStream . StreamError

failErr :: TestState -> Text -> TestParseError
failErr endSt = ParseError emptyStack endSt . CompoundErrorFail

markWith :: TestState -> TestParseError -> TestParseError
markWith s = markParseError (Mark Nothing s)

anyTokErr :: TestState -> TestParseError
anyTokErr s = markWith s (stmErr s RawErrorAnyToken)

anyChunkErr :: TestState -> TestParseError
anyChunkErr s = markWith s (stmErr s RawErrorAnyChunk)

matchTokErr :: TestState -> Char -> Maybe Char -> TestParseError
matchTokErr s x my = markWith s (stmErr (fwd 1 s) (RawErrorMatchToken x my))

matchChunkErr :: TestState -> Text -> Maybe Text -> TestParseError
matchChunkErr s x my = markWith s (stmErr (fwd (T.length x) s) (RawErrorMatchChunk x my))

matchEndErr :: TestState -> Char -> TestParseError
matchEndErr s x = markWith s (stmErr (fwd 1 s) (RawErrorMatchEnd x))

takeTokErr :: TestState -> Int -> Maybe Char -> TestParseError
takeTokErr s n my = markWith s (stmErr (fwd n s) (RawErrorTakeTokensWhile1 my))

dropTokErr :: TestState -> Int -> Maybe Char -> TestParseError
dropTokErr s n my = markWith s (stmErr (fwd n s) (RawErrorDropTokensWhile1 my))

testParserCase :: (Show a, Eq a) => ParserCase a -> TestTree
testParserCase (ParserCase name parser input expected) = testCase name $ do
  let actual = runParser parser (newOffsetStream input)
  actual @?= expected

testExamineCase :: ExamineCase a b -> TestTree
testExamineCase (ExamineCase name block input expected) = testCase name $ do
  let actual = pureLookAheadTest block (newOffsetStream input)
  actual @?= expected

test_empty :: [TestTree]
test_empty =
  let parser = emptyParser :: TestParser Int
      cases =
        [ ParserCase "empty" parser "" Nothing
        , ParserCase "non-empty" parser "hi" Nothing
        ]
  in fmap testParserCase cases

test_pure :: [TestTree]
test_pure =
  let parser = pure (1 :: Int)
      cases =
        [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") 1)
        , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 0 "hi") 1)
        ]
  in fmap testParserCase cases

test_fail :: [TestTree]
test_fail =
  let parser = fail "i give up" :: TestParser Int
      cases =
        [ ParserCase "empty" parser "" (errRes [failErr (OffsetStream 0 "") "i give up"])
        , ParserCase "non-empty" parser "hi" (errRes [failErr (OffsetStream 0 "hi") "i give up"])
        ]
  in fmap testParserCase cases

test_peek_token :: [TestTree]
test_peek_token =
  let parser = peekToken
      cases =
        [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") Nothing)
        , ParserCase "match" parser "hi" (sucRes (OffsetStream 0 "hi") (Just 'h'))
        ]
  in fmap testParserCase cases

test_pop_token :: [TestTree]
test_pop_token =
  let parser = popToken
      cases =
        [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") Nothing)
        , ParserCase "match" parser "hi" (sucRes (OffsetStream 1 "i") (Just 'h'))
        ]
  in fmap testParserCase cases

test_peek_chunk :: [TestTree]
test_peek_chunk =
  let parser = peekChunk 2
      cases =
        [ ParserCase "len 0" parser "" (sucRes (OffsetStream 0 "") Nothing)
        , ParserCase "len 1" parser "h" (sucRes (OffsetStream 0 "h") (Just "h"))
        , ParserCase "len 2" parser "hi" (sucRes (OffsetStream 0 "hi") (Just "hi"))
        , ParserCase "len 3" parser "hii" (sucRes (OffsetStream 0 "hii") (Just "hi"))
        ]
  in fmap testParserCase cases

test_pop_chunk :: [TestTree]
test_pop_chunk =
  let parser = popChunk 2
      cases =
        [ ParserCase "len 0" parser "" (sucRes (OffsetStream 0 "") Nothing)
        , ParserCase "len 1" parser "h" (sucRes (OffsetStream 1 "") (Just "h"))
        , ParserCase "len 2" parser "hi" (sucRes (OffsetStream 2 "") (Just "hi"))
        , ParserCase "len 3" parser "hii" (sucRes (OffsetStream 2 "i") (Just "hi"))
        ]
  in fmap testParserCase cases

test_drop_chunk :: [TestTree]
test_drop_chunk =
  let parser = dropChunk 2
      cases =
        [ ParserCase "len 0" parser "" (sucRes (OffsetStream 0 "") Nothing)
        , ParserCase "len 1" parser "h" (sucRes (OffsetStream 1 "") (Just 1))
        , ParserCase "len 2" parser "hi" (sucRes (OffsetStream 2 "") (Just 2))
        , ParserCase "len 3" parser "hii" (sucRes (OffsetStream 2 "i") (Just 2))
        ]
  in fmap testParserCase cases

test_is_end :: [TestTree]
test_is_end =
  let parser = isEnd
      cases =
        [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") True)
        , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 0 "hi") False)
        ]
  in fmap testParserCase cases

test_match_end :: [TestTree]
test_match_end =
  let parser = matchEnd
      cases =
        [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") ())
        , ParserCase "non-empty" parser "hi" (errRes [matchEndErr (OffsetStream 0 "hi") 'h'])
        ]
  in fmap testParserCase cases

test_any_token :: [TestTree]
test_any_token =
  let parser = anyToken
      cases =
        [ ParserCase "empty" parser "" (errRes [anyTokErr (OffsetStream 0 "")])
        , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 1 "i") 'h')
        ]
  in fmap testParserCase cases

test_any_chunk :: [TestTree]
test_any_chunk =
  let parser = anyChunk 2 :: TestParser Text
      cases =
        [ ParserCase "len 0" parser "" (errRes [anyChunkErr (OffsetStream 0 "")])
        , ParserCase "len 1" parser "h" (sucRes (OffsetStream 1 "") "h")
        , ParserCase "len 2" parser "hi" (sucRes (OffsetStream 2 "") "hi")
        , ParserCase "len 3" parser "hii" (sucRes (OffsetStream 2 "i") "hi")
        ]
  in fmap testParserCase cases

test_match_token :: [TestTree]
test_match_token =
  let parser = matchToken 'h'
      cases =
        [ ParserCase "empty" parser "" (errRes [matchTokErr (OffsetStream 0 "") 'h' Nothing])
        , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 1 "i") 'h')
        , ParserCase "non-match" parser "bye" (errRes [matchTokErr (OffsetStream 0 "bye") 'h' (Just 'b')])
        ]
  in fmap testParserCase cases

test_match_chunk :: [TestTree]
test_match_chunk =
  let parser = matchChunk "hi"
      cases =
        [ ParserCase "empty" parser "" (errRes [matchChunkErr (OffsetStream 0 "") "hi" Nothing])
        , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 2 "") "hi")
        , ParserCase "prefix" parser "hiya" (sucRes (OffsetStream 2 "ya") "hi")
        , ParserCase "partial" parser "hey" (errRes [matchChunkErr (OffsetStream 0 "hey") "hi" (Just "he")])
        , ParserCase "non-match" parser "bye" (errRes [matchChunkErr (OffsetStream 0 "bye") "hi" (Just "by")])
        , ParserCase "short" parser "h" (errRes [matchChunkErr (OffsetStream 0 "h") "hi" (Just "h")])
        ]
  in fmap testParserCase cases

test_greedy_star :: [TestTree]
test_greedy_star =
  let parser = greedyStarParser (matchToken 'h') :: TestParser String
      cases =
        [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") "")
        , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 1 "i") "h")
        , ParserCase "repeat" parser "hhi" (sucRes (OffsetStream 2 "i") "hh")
        , ParserCase "full" parser "hhh" (sucRes (OffsetStream 3 "") "hhh")
        , ParserCase "non-match" parser "bye" (sucRes (OffsetStream 0 "bye") "")
        ]
  in fmap testParserCase cases

test_greedy_star_unit :: [TestTree]
test_greedy_star_unit =
  let parser = greedyStarParser_ (matchToken 'h')
      cases =
        [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") ())
        , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 1 "i") ())
        , ParserCase "repeat" parser "hhi" (sucRes (OffsetStream 2 "i") ())
        , ParserCase "full" parser "hhh" (sucRes (OffsetStream 3 "") ())
        , ParserCase "non-match" parser "bye" (sucRes (OffsetStream 0 "bye") ())
        ]
  in fmap testParserCase cases

test_greedy_plus :: [TestTree]
test_greedy_plus =
  let parser = greedyPlusParser (matchToken 'h') :: TestParser String
      cases =
        [ ParserCase "empty" parser "" (errRes [matchTokErr (OffsetStream 0 "") 'h' Nothing])
        , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 1 "i") "h")
        , ParserCase "repeat" parser "hhi" (sucRes (OffsetStream 2 "i") "hh")
        , ParserCase "full" parser "hhh" (sucRes (OffsetStream 3 "") "hhh")
        , ParserCase "non-match" parser "bye" (errRes [matchTokErr (OffsetStream 0 "bye") 'h' (Just 'b')])
        ]
  in fmap testParserCase cases

test_greedy_plus_unit :: [TestTree]
test_greedy_plus_unit =
  let parser = greedyPlusParser_ (matchToken 'h')
      cases =
        [ ParserCase "empty" parser "" (errRes [matchTokErr (OffsetStream 0 "") 'h' Nothing])
        , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 1 "i") ())
        , ParserCase "repeat" parser "hhi" (sucRes (OffsetStream 2 "i") ())
        , ParserCase "full" parser "hhh" (sucRes (OffsetStream 3 "") ())
        , ParserCase "non-match" parser "bye" (errRes [matchTokErr (OffsetStream 0 "bye") 'h' (Just 'b')])
        ]
  in fmap testParserCase cases

test_or :: [TestTree]
test_or =
  let parser = orParser (matchToken 'h') (matchToken 'x')
      cases =
        [ ParserCase "empty" parser "" $ errRes
            [ matchTokErr (OffsetStream 0 "") 'h' Nothing
            , matchTokErr (OffsetStream 0 "") 'x' Nothing
            ]
        , ParserCase "first" parser "hi" (sucRes (OffsetStream 1 "i") 'h')
        , ParserCase "second" parser "xi" (sucRes (OffsetStream 1 "i") 'x')
        , ParserCase "non-match" parser "bye" $ errRes
            [ matchTokErr (OffsetStream 0 "bye") 'h' (Just 'b')
            , matchTokErr (OffsetStream 0 "bye") 'x' (Just 'b')
            ]
        ]
  in fmap testParserCase cases

test_asum :: [TestTree]
test_asum =
  let state = OffsetStream 1 "i"
      parser = asum [matchToken 'h', 'y' <$ anyToken, matchToken 'x']
      cases =
        [ ParserCase "empty" parser "" $ errRes
            [ matchTokErr (OffsetStream 0 "") 'h' Nothing
            , anyTokErr (OffsetStream 0 "")
            , matchTokErr (OffsetStream 0 "") 'x' Nothing
            ]
        , ParserCase "first" parser "hi" (sucRes state 'h')
        , ParserCase "middle" parser "zi" (sucRes state 'y')
        , ParserCase "last" parser "xi" (sucRes state 'y')
        ]
  in fmap testParserCase cases

test_default_empty :: [TestTree]
test_default_empty =
  let parser = defaultParser 'z' emptyParser
      cases =
        [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") 'z')
        , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 0 "hi") 'z')
        ]
  in fmap testParserCase cases

test_default :: [TestTree]
test_default =
  let parser = defaultParser 'z' (matchToken 'h')
      cases =
        [ ParserCase "non-match empty" parser "" (sucRes (OffsetStream 0 "") 'z')
        , ParserCase "match" parser "hi" (sucRes (OffsetStream 1 "i") 'h')
        , ParserCase "non-match" parser "bye" (sucRes (OffsetStream 0 "bye") 'z')
        ]
  in fmap testParserCase cases

test_bind_1 :: [TestTree]
test_bind_1 =
  let state = OffsetStream 1 "i"
      parser = matchToken 'x' >>= \c -> pure [c, c]
      cases =
        [ ParserCase "empty" parser "" (errRes [matchTokErr (OffsetStream 0 "") 'x' Nothing])
        , ParserCase "first" parser "hi" (errRes [matchTokErr (OffsetStream 0 "hi") 'x' (Just 'h')])
        , ParserCase "second" parser "xi" (sucRes state "xx")
        ]
  in fmap testParserCase cases

test_bind_2 :: [TestTree]
test_bind_2 =
  let state = OffsetStream 1 "i"
      parser = anyToken >>= \x -> if x == 'x' then pure 'y' else emptyParser
      cases =
        [ ParserCase "empty" parser "" (errRes [anyTokErr (OffsetStream 0 "")])
        , ParserCase "first" parser "hi" Nothing
        , ParserCase "second" parser "xi" (sucRes state 'y')
        ]
  in fmap testParserCase cases

test_throw :: [TestTree]
test_throw =
  let err = Error "boo"
      parser = throwParser err :: TestParser Int
      cases =
        [ ParserCase "empty" parser "" (errRes [custErr (OffsetStream 0 "") err])
        , ParserCase "non-empty" parser "hi" (errRes [custErr (OffsetStream 0 "hi") err])
        ]
  in fmap testParserCase cases

test_consume_throw :: [TestTree]
test_consume_throw =
  let err = Error "boo"
      parser = anyToken *> throwParser err :: TestParser Int
      cases =
        [ ParserCase "empty" parser "" (errRes [anyTokErr (OffsetStream 0 "")])
        , ParserCase "non-empty" parser "hi" (errRes [custErr (OffsetStream 1 "i") err])
        ]
  in fmap testParserCase cases

test_default_throw :: [TestTree]
test_default_throw =
  let err = Error "boo"
      parser = defaultParser 'z' (throwParser err)
      cases =
        [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") 'z')
        , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 0 "hi") 'z')
        ]
  in fmap testParserCase cases

test_default_consume_throw :: [TestTree]
test_default_consume_throw =
  let err = Error "boo"
      parser = defaultParser 'z' (anyToken *> throwParser err)
      cases =
        [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") 'z')
        , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 0 "hi") 'z')
        ]
  in fmap testParserCase cases

test_throw_mixed :: [TestTree]
test_throw_mixed =
  let state = OffsetStream 0 "hi"
      err = Error "boo"
      parser = orParser (throwParser err) (pure 1) :: TestParser Int
      cases =
        [ ParserCase "non-empty" parser "hi" (sucRes state 1)
        ]
  in fmap testParserCase cases

test_throw_mixed_flip :: [TestTree]
test_throw_mixed_flip =
  let state = OffsetStream 0 "hi"
      err = Error "boo"
      parser = orParser (pure 1) (throwParser err) :: TestParser Int
      cases =
        [ ParserCase "non-empty" parser "hi" (sucRes state 1)
        ]
  in fmap testParserCase cases

test_catch :: [TestTree]
test_catch =
  let state = OffsetStream 0 "hi"
      err = Error "boo"
      parser = catchParser (throwParser err) (\(Error m) -> pure (if m == "boo" then 2 else 3)) :: TestParser Int
      cases =
        [ ParserCase "non-empty" parser "hi" (sucRes state 2)
        ]
  in fmap testParserCase cases

test_catch_recur :: [TestTree]
test_catch_recur =
  let state = OffsetStream 0 "hi"
      err1 = Error "boo"
      err2 = Error "two"
      parser = catchParser (throwParser err1) (const (throwParser err2)) :: TestParser Int
      cases =
        [ ParserCase "non-empty" parser "hi" (errRes [custErr state err2])
        ]
  in fmap testParserCase cases

test_silence_success :: [TestTree]
test_silence_success =
  let state = OffsetStream 0 "hi"
      parser = silenceParser (pure 1) :: TestParser Int
      cases =
        [ ParserCase "non-empty" parser "hi" (sucRes state 1)
        ]
  in fmap testParserCase cases

test_silence_fail :: [TestTree]
test_silence_fail =
  let err = Error "boo"
      parser = silenceParser (throwParser err) :: TestParser Int
      cases =
        [ ParserCase "non-empty" parser "hi" Nothing
        ]
  in fmap testParserCase cases

test_silence_empty :: [TestTree]
test_silence_empty =
  let parser = silenceParser emptyParser :: TestParser Int
      cases =
        [ ParserCase "non-empty" parser "hi" Nothing
        ]
  in fmap testParserCase cases

test_look_ahead_pure :: [TestTree]
test_look_ahead_pure =
  let parser = lookAheadParser (pure 1) :: TestParser Int
      cases =
        [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") 1)
        , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 0 "hi") 1)
        ]
  in fmap testParserCase cases

test_look_ahead_success :: [TestTree]
test_look_ahead_success =
  let parser = lookAheadParser anyToken
      cases =
        [ ParserCase "non-match empty" parser "" (errRes [anyTokErr (OffsetStream 0 "")])
        , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 0 "hi") 'h')
        ]
  in fmap testParserCase cases

test_look_ahead_failure :: [TestTree]
test_look_ahead_failure =
  let err = Error "boo"
      parser = lookAheadParser (anyToken *> throwParser err) :: TestParser Char
      cases =
        [ ParserCase "non-match empty" parser "" (errRes [anyTokErr (OffsetStream 0 "")])
        , ParserCase "non-empty" parser "hi" (errRes [custErr (OffsetStream 1 "i") err])
        ]
  in fmap testParserCase cases

test_commit :: [TestTree]
test_commit =
  let parser = commitParser (void (matchToken 'h')) (matchChunk "hi") :: TestParser Text
      cases =
        [ ParserCase "non-match empty" parser "" Nothing
        , ParserCase "non-match non-empty" parser "ho" (errRes [matchChunkErr (OffsetStream 0 "ho") "hi" (Just "ho")])
        , ParserCase "match" parser "hi" (sucRes (OffsetStream 2 "") "hi")
        ]
  in fmap testParserCase cases

test_take_while :: [TestTree]
test_take_while =
  let parser = takeTokensWhile (=='h') :: TestParser Text
      cases =
        [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") "")
        , ParserCase "non-match" parser "i" (sucRes (OffsetStream 0 "i") "")
        , ParserCase "match" parser "hi" (sucRes (OffsetStream 1 "i") "h")
        , ParserCase "match 2" parser "hhi" (sucRes (OffsetStream 2 "i") "hh")
        , ParserCase "match end" parser "hh" (sucRes (OffsetStream 2 "") "hh")
        ]
  in fmap testParserCase cases

test_take_while_1 :: [TestTree]
test_take_while_1 =
  let parser = takeTokensWhile1 Nothing (=='h') :: TestParser Text
      cases =
        [ ParserCase "empty" parser "" (errRes [takeTokErr(OffsetStream 0 "") 0 Nothing])
        , ParserCase "non-match" parser "i" (errRes [takeTokErr (OffsetStream 0 "i") 0 (Just 'i')])
        , ParserCase "match" parser "hi" (sucRes (OffsetStream 1 "i") "h")
        , ParserCase "match 2" parser "hhi" (sucRes (OffsetStream 2 "i") "hh")
        , ParserCase "match end" parser "hh" (sucRes (OffsetStream 2 "") "hh")
        ]
  in fmap testParserCase cases

test_drop_while :: [TestTree]
test_drop_while =
  let parser = dropTokensWhile (=='h') :: TestParser Int
      cases =
        [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") 0)
        , ParserCase "non-match" parser "i" (sucRes (OffsetStream 0 "i") 0)
        , ParserCase "match" parser "hi" (sucRes (OffsetStream 1 "i") 1)
        , ParserCase "match 2" parser "hhi" (sucRes (OffsetStream 2 "i") 2)
        , ParserCase "match end" parser "hh" (sucRes (OffsetStream 2 "") 2)
        ]
  in fmap testParserCase cases

test_drop_while_1 :: [TestTree]
test_drop_while_1 =
  let parser = dropTokensWhile1 Nothing (=='h') :: TestParser Int
      cases =
        [ ParserCase "empty" parser "" (errRes [dropTokErr (OffsetStream 0 "") 0 Nothing])
        , ParserCase "non-match" parser "i" (errRes [dropTokErr (OffsetStream 0 "i") 0 (Just 'i')])
        , ParserCase "match" parser "hi" (sucRes (OffsetStream 1 "i") 1)
        , ParserCase "match 2" parser "hhi" (sucRes (OffsetStream 2 "i") 2)
        , ParserCase "match end" parser "hh" (sucRes (OffsetStream 2 "") 2)
        ]
  in fmap testParserCase cases

simpleBlock :: TestBlock Char Text
simpleBlock = MatchBlock anyToken (pure "default")
  [ MatchCase (Just (Label "match x")) (== 'x') (anyToken $> "found x - consuming")
  , MatchCase (Just (Label "match x dupe")) (== 'x') (pure "dupe x - leaving")
  , MatchCase (Just (Label "match y")) (== 'y') (pure "found y - leaving")
  ]

test_look_ahead_match :: [TestTree]
test_look_ahead_match =
  let parser = lookAheadMatch simpleBlock
      cases =
        [ ParserCase "empty" parser "" (errRes [anyTokErr (OffsetStream 0 "")])
        , ParserCase "non-match" parser "wz" (sucRes (OffsetStream 0 "wz") "default")
        , ParserCase "match x" parser "xz" (sucRes (OffsetStream 1 "z") "found x - consuming")
        , ParserCase "match y" parser "yz" (sucRes (OffsetStream 0 "yz") "found y - leaving")
        ]
  in fmap testParserCase cases

test_look_ahead_examine :: [TestTree]
test_look_ahead_examine =
  let xpositions = [MatchPos 0 (Just (Label "match x")), MatchPos 1 (Just (Label "match x dupe"))]
      ypositions = [MatchPos 2 (Just (Label "match y"))]
      cases =
        [ ExamineCase "empty" simpleBlock "" LookAheadTestEmpty
        , ExamineCase "non-match" simpleBlock "wz" LookAheadTestDefault
        , ExamineCase "match x" simpleBlock "xz" (LookAheadTestMatches (NESeq.unsafeFromSeq (Seq.fromList xpositions)))
        , ExamineCase "match y" simpleBlock "yz" (LookAheadTestMatches (NESeq.unsafeFromSeq (Seq.fromList ypositions)))
        ]
  in fmap testExamineCase cases

type JsonResult = Maybe Json

testJsonCase :: TestName -> Text -> JsonResult -> TestTree
testJsonCase name str expected = testCase ("json " <> name) $ do
  let actual = parseJson str
  actual @?= expected

testJsonTrees :: [(TestName, Text, JsonResult)] -> [TestTree]
testJsonTrees = fmap (\(n, s, e) -> testJsonCase n s e)

parseJson :: Text -> JsonResult
parseJson str =
  let p = jsonParser <* matchEnd
  in case runParser p str of
    Just (ParseResultSuccess (ParseSuccess _ a)) -> Just a
    _ -> Nothing

test_json :: [TestTree]
test_json =
  let nullVal = Json JsonNull
      trueVal = Json (JsonBool True)
      falseVal = Json (JsonBool False)
      arrVal = Json . JsonArray . Seq.fromList
      strVal = Json . JsonString
      objVal = Json . JsonObject . Seq.fromList
      numVal = Json . JsonNum
      cases =
        [ ("empty", "", Nothing)
        , ("bad", "bad", Nothing)
        , ("null", "null", Just nullVal)
        , ("true", "true", Just trueVal)
        , ("false", "false", Just falseVal)
        , ("arr0", "[]", Just (arrVal []))
        , ("arr1", "[null]", Just (arrVal [nullVal]))
        , ("arr2", "[null, false]", Just (arrVal [nullVal, falseVal]))
        , ("arr3", "[null, false, true]", Just (arrVal [nullVal, falseVal, trueVal]))
        , ("arrx", "[null,]", Nothing)
        , ("str0", "\"\"", Just (strVal ""))
        , ("str1", "\"x\"", Just (strVal "x"))
        , ("str2", "\"xy\"", Just (strVal "xy"))
        , ("str3", "\"xyz\"", Just (strVal "xyz"))
        , ("str4", "\"xy\\\"z\"", Just (strVal "xy\"z"))
        , ("obj0", "{}", Just (objVal []))
        , ("obj1", "{\"x\": true}", Just (objVal [("x", trueVal)]))
        , ("obj2", "{\"x\": true, \"y\": false}", Just (objVal [("x", trueVal), ("y", falseVal)]))
        , ("num0", "0", Just (numVal 0))
        , ("num1", "123", Just (numVal 123))
        , ("num2", "123.45", Just (numVal 123.45))
        , ("num3", "1e100", Just (numVal (read "1e100")))
        , ("num4", "{\"x\": 1e100, \"y\": 123.45}", Just (objVal [("x", numVal (read "1e100")), ("y", numVal 123.45)]))
        ]
  in testJsonTrees cases

type SexpResult = Maybe Sexp

testSexpCase :: TestName -> Text -> SexpResult -> TestTree
testSexpCase name str expected = testCase ("sexp " <> name) $ do
  let actualDirect = SexpDirect.runSexpParser str
  actualDirect @?= expected
  let actualLexed = SexpLexed.runSexpParser (newOffsetStream str)
  actualLexed @?= expected

testSexpTrees :: [(TestName, Text, SexpResult)] -> [TestTree]
testSexpTrees = fmap (\(n, s, e) -> testSexpCase n s e)

test_sexp :: [TestTree]
test_sexp =
  let numSexp = Sexp (SexpAtom (AtomInt 1))
      sciExpSexp = Sexp (SexpAtom (AtomSci 1))
      identSexp = Sexp (SexpAtom (AtomIdent "abc"))
      stringSexp = Sexp (SexpAtom (AtomString "xyz"))
      sciSexp = Sexp (SexpAtom (AtomSci 3.14))
      emptyList = Sexp (SexpList Empty)
      singletonList = Sexp (SexpList (Seq.singleton numSexp))
      pairList = Sexp (SexpList (Seq.fromList [numSexp, numSexp]))
      cases =
        [ ("empty", "", Nothing)
        , ("empty list", "()", Just emptyList)
        , ("singleton list", "(1)", Just singletonList)
        , ("singleton empty list", "(())", Just (Sexp (SexpList (Seq.fromList [emptyList]))))
        , ("singleton nested list", "((1))", Just (Sexp (SexpList (Seq.fromList [singletonList]))))
        , ("num", "1", Just numSexp)
        , ("num pos", "+1", Just numSexp)
        , ("num neg", "-1", Just (Sexp (SexpAtom (AtomInt -1))))
        , ("ident", "abc", Just identSexp)
        , ("string", "\"xyz\"", Just stringSexp)
        , ("sci", "3.14", Just sciSexp)
        , ("sci pos", "+3.14", Just sciSexp)
        , ("sci neg", "-3.14", Just (Sexp (SexpAtom (AtomSci -3.14))))
        , ("sci exp", "1e0", Just sciExpSexp)
        , ("sci pos exp", "+1e0", Just sciExpSexp)
        , ("sci dec exp", "1.0", Just sciExpSexp)
        , ("sci dec exp 2", "1.0e0", Just sciExpSexp)
        , ("plus", "+", Just (Sexp (SexpAtom (AtomIdent "+"))))
        , ("minus", "-", Just (Sexp (SexpAtom (AtomIdent "-"))))
        , ("multi list", "(1 abc \"xyz\" 3.14)", Just (Sexp (SexpList (Seq.fromList [numSexp, identSexp, stringSexp, sciSexp]))))
        , ("pair nested list", "((1 1) (1 1))", Just (Sexp (SexpList (Seq.fromList [pairList, pairList]))))
        ]
  in testSexpTrees cases

main :: IO ()
main = $(defaultMainGenerator)