{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}

import Control.Monad (join)
import Control.Monad.IO.Class (liftIO)
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy.Char8 as Char8
import Data.List (intercalate)
import Language.Haskell.TH (AnnLookup (..), Q, Type (..), runIO)
import Language.Haskell.TH.Syntax (Extension (..), ForeignSrcLang (..), Quasi (..))
import Test.Tasty
import Test.Tasty.Golden
import Test.Tasty.HUnit

import Language.Haskell.TH.TestUtils
import Language.Haskell.TH.TestUtils.QMode (IsMockedMode, TestQResult)
import TH
import TestLib

main :: IO ()
main =
  defaultMain $
    testGroup
      "th-test-utils"
      [ testAllowQ
      , testMockQ
      , testMockQAllowIO
      ]

testAllowQ :: TestTree
testAllowQ =
  testGroup
    "AllowQ"
    [ testRunners
    , testMethods
    ]
  where
    testRunners =
      testGroup
        "tryTestQ, runTestQ, runTestQErr"
        [ $( testCaseTH "tryTestQ - success" $ do
              let x = 1
              result <- tryTestQ unmockedState (return x :: Q Int)
              return $ result @?= Right x
           )
        , $( testCaseTH "tryTestQ - error" $ do
              let msg = "Error message"
              result <- tryTestQ unmockedState (fail msg :: Q Int)
              return $ result @?= Left msg
           )
        , $( testCaseTH "fmap Right . runTestQ === tryTestQ" $ do
              actual <- Right <$> runTestQ unmockedState basicSuccess
              expected <- tryTestQ unmockedState basicSuccess
              return $ actual @?= expected
           )
        , $( testCaseTH "runTestQ errors on failure" $ do
              let msg = "Error message"
              result <- tryQ $ runTestQ unmockedState (fail msg :: Q ())
              return $ result @?= Left msg
           )
        , $( testCaseTH "fmap Left . runTestQErr === tryTestQ" $ do
              actual <- Left <$> runTestQErr unmockedState basicFailure
              expected <- tryTestQ unmockedState basicFailure
              return $ actual @?= expected
           )
        , $( testCaseTH "runTestQErr errors on success" $ do
              result <- tryQ $ runTestQErr unmockedState (return 1 :: Q Int)
              return $ result @?= Left "Unexpected success: 1"
           )
        ]
    testMethods =
      testGroup
        "Quasi methods"
        [ $( testCaseTH "qNewName" $
              isSuccess $
                runTestQ unmockedState $
                  qNewName "foo"
           )
        , $( testCaseTH "qReport" $
              -- not testing 'qReport False' because it fails with '-Werror'
              -- isSuccess $ runTestQ unmockedState $ qReport False "A warning message"
              isSuccess $
                runTestQ unmockedState $
                  qReport True "An error message"
           )
        , $( testCaseTH "qRecover" $ do
              let x = "Success"
              result <- runTestQ unmockedState $ qRecover (return x) basicFailure
              return $ result @?= x
           )
        , $( testCaseTH "qLookupName" $
              checkUnmockedMatches $
                sequence
                  [ qLookupName True "Show"
                  , qLookupName True "Right"
                  , qLookupName False "Right"
                  , qLookupName False "Show"
                  ]
           )
        , $( testCaseTH "qReify" $
              checkUnmockedMatches $
                qReify ''Maybe
           )
        , $( testCaseTH "qReifyFixity" $
              checkUnmockedMatches $
                qReifyFixity '($)
           )
        , $( testCaseTH "qReifyType" $
              checkUnmockedMatches $
                qReifyType ''Maybe
           )
        , $( testCaseTH "qReifyInstances" $
              checkUnmockedMatches $
                qReifyInstances ''Show [ConT ''Int]
           )
        , $( testCaseTH "qReifyRoles" $
              checkUnmockedMatches $
                qReifyRoles ''Maybe
           )
        , $( testCaseTH "qReifyAnnotations" $
              checkUnmockedMatches $
                qReifyAnnotations @_ @[String] (AnnLookupName 'basicSuccess)
           )
        , $( testCaseTH "qReifyModule" $
              checkUnmockedMatches $
                qReifyModule $(thisModule)
           )
        , $( testCaseTH "qReifyConStrictness" $
              checkUnmockedMatches $
                qReifyConStrictness 'Just
           )
        , $( testCaseTH "qLocation" $
              checkUnmockedMatches qLocation
           )
        , $( testCaseTH "qRunIO, qAddDependentFile" $
              checkUnmockedMatches $ do
                readmeContents <- qRunIO $ readFile "README.md"
                qAddDependentFile "README.md"
                return readmeContents
           )
        , $( testCaseTH "qAddTopDecls" $ do
              decs <- [d|{-# ANN module "AllowQ - qAddTopDecls" #-}|]
              isSuccess $ runTestQ unmockedState $ qAddTopDecls decs
           )
        , $( testCaseTH "qAddTempFile, qAddForeignFilePath" $ isSuccess $ do
              fp <- runTestQ unmockedState $ qAddTempFile "c"
              qRunIO $ writeFile fp "#include <stdio.h>"
              runTestQ unmockedState $ qAddForeignFilePath LangC fp
           )
        , $( testCaseTH "qAddModFinalizer" $
              isSuccess $
                runTestQ unmockedState $
                  qAddModFinalizer $
                    return ()
           )
        , -- Not testing qAddCorePlugin because I don't want to actually register plugins here

          $( testCaseTH "qGetQ, qPutQ" $
              checkUnmockedMatches $ do
                qPutQ "Hello"
                qGetQ @_ @String
           )
        , $( testCaseTH "qIsExtEnabled" $
              checkUnmockedMatches $
                sequence
                  [ qIsExtEnabled JavaScriptFFI
                  , qIsExtEnabled TemplateHaskell
                  ]
           )
        , $( testCaseTH "qExtsEnabled" $
              checkUnmockedMatches qExtsEnabled
           )
        ]

testMockQ :: TestTree
testMockQ =
  testMockQ'
    MockQTests
      { qMode = MockQ
      , toIO = pure
      , qRunIOResult = \_ -> Left "IO actions not allowed"
      }

testMockQAllowIO :: TestTree
testMockQAllowIO =
  testMockQ'
    MockQTests
      { qMode = MockQAllowIO
      , toIO = id
      , qRunIOResult = Right
      }

{- Helpers -}

data MockQTests mode = MockQTests
  { qMode :: QMode mode
  , toIO :: forall a. TestQResult mode a -> IO a
  , qRunIOResult :: forall a. a -> Either String a
  }

-- | Tests for both MockQ and MockQAllowIO, since they should behave exactly the same except for qRunIO.
testMockQ' :: forall mode. IsMockedMode mode => MockQTests mode -> TestTree
testMockQ' MockQTests{..} =
  testGroup
    (show qMode)
    [ testRunners
    , testMethods
    ]
  where
    mockedState =
      QState
        { mode = qMode
        , knownNames = []
        , reifyInfo = []
        }

    -- Call runTestQ, converting the result to IO and ensuring that the result is evaluated
    runTestQ' :: QState mode -> Q a -> IO a
    runTestQ' state = forceM . toIO . runTestQ state

    -- Call runTestQ', capturing any 'error' calls that occur in evaluating the result
    runTestQWithErrors :: QState mode -> Q a -> IO (Either String a)
    runTestQWithErrors state = tryIO . runTestQ' state

    testRunners =
      testGroup
        "tryTestQ, runTestQ, runTestQErr"
        [ testCase "tryTestQ - success" $ do
            let x = 1
            result <- toIO $ tryTestQ mockedState (return x :: Q Int)
            (result :: Either String Int) @?= Right x
        , testCase "tryTestQ - error" $ do
            let msg = "Error message"
            result <- toIO $ tryTestQ mockedState (fail msg :: Q Int)
            (result :: Either String Int) @?= Left msg
        , testCase "Right . runTestQ === tryTestQ" $ do
            actual <- fmap Right $ toIO $ runTestQ mockedState basicSuccess
            expected <- toIO $ tryTestQ mockedState basicSuccess
            (actual :: Either String String) @?= (expected :: Either String String)
        , testCase "runTestQ errors on failure" $ do
            let msg = "Error message"
            result <- tryIO $ forceM $ toIO $ runTestQ mockedState (fail msg :: Q ())
            (result :: Either String ()) @?= Left msg
        , testCase "Left . runTestQErr === tryTestQ" $ do
            actual <- fmap Left $ toIO $ runTestQErr mockedState basicFailure
            expected <- toIO $ tryTestQ mockedState basicFailure
            (actual :: Either String String) @?= (expected :: Either String String)
        , testCase "runTestQErr errors on success" $ do
            result <- tryIO $ forceM $ toIO $ runTestQErr mockedState (return 1 :: Q Int)
            (result :: Either String String) @?= Left "Unexpected success: 1"
        ]

    testMethods =
      testGroup
        "Quasi methods"
        [ golden "qNewName" $
            join $
              runTestQ' mockedState $ do
                name1 <- qNewName "foo"
                name2 <- qNewName "foo"
                name3 <- qNewName "bar"
                return $
                  labelled
                    [ ("Name 1", pure name1)
                    , ("Name 2", pure name2)
                    , ("Name 3", pure name3)
                    ]
        , testCase "qReport" $ do
            warningResult <- runTestQ' mockedState $ qReport False "A warning message"
            warningResult @?= ()

            errorResult <- runTestQ' mockedState $ qReport True "An error message"
            errorResult @?= ()
        , testCase "qRecover" $ do
            let x = "Success"
            result <- runTestQ' mockedState $ qRecover (return x) basicFailure
            result @?= x
        , testCase "qLookupName" $ do
            let state = mockedState{knownNames = [("Show", ''Show), ("Right", 'Right)]}

            nameShow <- runTestQ' state $ qLookupName True "Show"
            nameShow @?= Just ''Show

            nameEq <- runTestQ' state $ qLookupName True "Eq"
            nameEq @?= Nothing

            nameRight <- runTestQ' state $ qLookupName False "Right"
            nameRight @?= Just 'Right

            nameLeft <- runTestQ' state $ qLookupName False "Left"
            nameLeft @?= Nothing
        , golden "qReify" $ do
            let state = mockedState{reifyInfo = $(loadNames ['putStrLn])}
            labelled
              [ ("Found", runTestQWithErrors state $ qReify 'putStrLn)
              , ("Missing", runTestQWithErrors state $ qReify ''Show)
              ]
        , golden "qReifyFixity" $ do
            let state = mockedState{reifyInfo = $(loadNames ['($)])}
            labelled
              [ ("Found", runTestQWithErrors state $ qReifyFixity '($))
              , ("Missing", runTestQWithErrors state $ qReifyFixity '(+))
              ]
        , golden "qReifyType" $ do
            let state = mockedState{reifyInfo = $(loadNames [''Maybe])}
            labelled
              [ ("Found", runTestQWithErrors state $ qReifyType ''Maybe)
              , ("Missing", runTestQWithErrors state $ qReifyType ''Show)
              ]
        , golden "qReifyInstances" $
            runUnsupported mockedState $
              qReifyInstances ''Show [ConT ''Int]
        , golden "qReifyRoles" $ do
            let state = mockedState{reifyInfo = $(loadNames [''Maybe, 'map])}
            labelled
              [ ("Found", runTestQWithErrors state $ qReifyRoles ''Maybe)
              , -- reifyRoles errors if name is not of a type constructor
                ("Invalid", runTestQWithErrors state $ qReifyRoles 'map)
              , ("Missing", runTestQWithErrors state $ qReifyRoles ''Show)
              ]
        , golden "qReifyAnnotations" $
            runUnsupported mockedState $
              qReifyAnnotations @_ @[String] (AnnLookupName 'basicSuccess)
        , golden "qReifyModule" $
            runUnsupported mockedState $
              qReifyModule $(thisModule)
        , golden "qReifyConStrictness" $
            runUnsupported mockedState $
              qReifyConStrictness 'Just
        , golden "qLocation" $
            runUnsupported mockedState qLocation
        , testCase "qRunIO" $ do
            let x = 1 :: Int
                io = return x

            qRunIOResult' <- runTestQWithErrors mockedState $ qRunIO io
            qRunIOResult' @?= qRunIOResult x

            runIOResult <- runTestQWithErrors mockedState $ runIO io
            runIOResult @?= qRunIOResult x

            liftIOResult <- runTestQWithErrors mockedState $ liftIO io
            liftIOResult @?= qRunIOResult x
        , golden "qAddDependentFile" $
            runUnsupported mockedState $
              qAddDependentFile "README.md"
        , golden "qAddTopDecls" $
            runUnsupported mockedState $
              qAddTopDecls []
        , golden "qAddTempFile" $
            runUnsupported mockedState $
              qAddTempFile "c"
        , golden "qAddForeignFilePath" $
            runUnsupported mockedState $
              qAddForeignFilePath LangC "foo.c"
        , golden "qAddModFinalizer" $
            runUnsupported mockedState $
              qAddModFinalizer $
                return ()
        , golden "qAddCorePlugin" $
            runUnsupported mockedState $
              qAddCorePlugin "MyPlugin"
        , golden "qGetQ" $
            runUnsupported mockedState $
              qGetQ @_ @String
        , golden "qPutQ" $
            runUnsupported mockedState $
              qPutQ "Hello"
        , golden "qIsExtEnabled" $
            runUnsupported mockedState $
              qIsExtEnabled TemplateHaskell
        , golden "qExtsEnabled" $
            runUnsupported mockedState qExtsEnabled
        ]

    -- force both MockQ and MockQAllowIO to resolve the same goldens
    golden name = goldenVsString name ("test/goldens/MockQ_" ++ name ++ ".golden")

    labelled :: Show a => [(String, IO a)] -> IO ByteString
    labelled vals = do
      let mkLine (label, getVal) = do
            val <- getVal
            return $ label ++ ": " ++ show val
      Char8.pack . intercalate "\n" . map (++ "\n") <$> mapM mkLine vals

    runUnsupported :: Show a => QState mode -> Q a -> IO ByteString
    runUnsupported state q = labelled [("Unsupported", runTestQWithErrors state q)]