{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

module ConfigTest where

import Data.List                              (isInfixOf, isSuffixOf, sort)
import System.Console.ANSI                    (Color(..), ColorIntensity(..), ConsoleLayer(..), SGR(..), setSGRCode)
import Test.Tasty.Discover.Internal.Config
import Test.Tasty.Discover.Internal.Driver    (ModuleTree (..), findTests, generateTestDriver, mkModuleTree, showTests, extractTests)
import Test.Tasty.Discover.Internal.Generator (Test (..), mkTest)

import Test.Tasty.HUnit hiding (Assertion)
import Test.Tasty.QuickCheck
import Test.Hspec.Core.Spec (Spec, describe, it)

import Test.Hspec (shouldBe, shouldSatisfy)
import Test.Tasty.ExpectedFailure (expectFail)
import qualified Test.Tasty as T
import qualified Test.Tasty.HUnit as HU
import qualified Test.Tasty.Discover as TD

import qualified Data.Map.Strict as M

-- For symlinks test
import System.Directory (createDirectoryIfMissing, createFileLink,
                        doesDirectoryExist, listDirectory)
import System.FilePath ((</>))
import System.Process (readProcessWithExitCode)
import System.IO.Temp (withSystemTempDirectory)
import System.Exit (ExitCode(..))

spec_modules :: Spec
spec_modules = describe "Test discovery" $ do
  it "Discovers tests" $ do
    let expectedTests = [ mkTest "PropTest.hs" "prop_additionAssociative"
                        , mkTest "SubSubMod/PropTest.hs" "prop_additionCommutative"
                        ]
        config        = (defaultConfig "test/SubMod") { modules = Just "*Test.hs" }
    discoveredTests <- findTests config
    sort discoveredTests `shouldBe` sort expectedTests

spec_ignores :: Spec
spec_ignores = describe "Module ignore configuration" $ do
  it "Ignores tests in modules with the specified suffix" $ do
    let ignoreModuleConfig = (defaultConfig "test/SubMod") { ignores = Just "*.hs" }
    discoveredTests <- findTests ignoreModuleConfig
    discoveredTests `shouldBe` []

spec_badModuleGlob :: Spec
spec_badModuleGlob = describe "Module suffix configuration" $ do
  it "Filters discovered tests by specified suffix" $ do
    let badGlobConfig = (defaultConfig "test/SubMod") { modules = Just "DoesntExist*.hs" }
    discoveredTests <- findTests badGlobConfig
    discoveredTests `shouldBe` []

spec_backupFilesIgnored :: Spec
spec_backupFilesIgnored = describe "Backup file filtering" $ do
  it "Only matches .hs files, not backup files containing .hs" $ do
    let config = defaultConfig "test/BackupFiles"
    discoveredTests <- findTests config
    -- Should only find ValidTest.hs, not ValidTest.hs.orig or ValidTest.hs.bak
    let moduleNames = map testModule discoveredTests
    length discoveredTests `shouldBe` 1
    moduleNames `shouldBe` ["ValidTest"]
    -- Verify no backup file patterns were found
    let hasBackupPattern name = ".hs." `isInfixOf` name || ".hs" `isInfixOf` name && not (".hs" `isSuffixOf` name)
    moduleNames `shouldSatisfy` (not . any hasBackupPattern)

spec_modulesGlobIgnoresDirectories :: Spec
spec_modulesGlobIgnoresDirectories = describe "Modules glob directory handling" $ do
  it "Ignores directories that match the glob pattern" $ do
    let config = (defaultConfig "test/ModulesGlob") { modules = Just "*" }
    discoveredTests <- findTests config
    -- Should find both test files, not fail on the Sub directory
    let moduleNames = sort $ map testModule discoveredTests
    length discoveredTests `shouldBe` 2
    moduleNames `shouldBe` ["Sub.OneTest", "TwoTest"]

spec_customModuleName :: Spec
spec_customModuleName = describe "Module name configuration" $ do
  it "Creates a generated main function with the specified name" $ do
    let generatedModule = generateTestDriver (defaultConfig "test/") "FunkyModuleName" [] "test/" []
    "FunkyModuleName" `shouldSatisfy` (`isInfixOf` generatedModule)

unit_noTreeDisplayDefault :: IO ()
unit_noTreeDisplayDefault = do
  let config = defaultConfig "test/SubMod"
  tests <- findTests config
  let testNumVars = map (('t' :) . show) [(0::Int)..]
      trees = showTests config tests testNumVars
  length trees @?= 4

unit_treeDisplay :: IO ()
unit_treeDisplay = do
  let config = (defaultConfig "test/SubMod") { treeDisplay = True }
  tests <- findTests config
  let testNumVars = map (('t' :) . show) [(0::Int)..]
      trees = showTests config tests testNumVars
  length trees @?= 3

prop_mkModuleTree :: ModuleTree -> Property
prop_mkModuleTree mtree =
  let (tests, testVars) = unzip $ flattenTree mtree
  in mkModuleTree tests testVars === mtree
  where flattenTree (ModuleTree mp) = M.assocs mp >>= flattenModule
        flattenModule (mdl, (subTree, testVars)) = concat
          [ map (\(Test subMdl _, tVar) -> (Test (mdl ++ '.':subMdl) "-", tVar)) (flattenTree subTree)
          , map (Test mdl "-", ) testVars ]

instance Arbitrary ModuleTree where
  arbitrary = sized $ \size ->
    resize (min size 12) (ModuleTree . M.fromList <$> listOf1 mdlGen)
    where mdlGen = sized $ \size -> do
            mdl <- listOf1 (elements ['a'..'z'])
            subTree <- if size == 0
              then pure $ ModuleTree M.empty
              else resize (size `div` 2) arbitrary
            tVars <- listOf1 (listOf1 arbitrary)
            pure (mdl, (subTree, tVars))

spec_commentHandling :: Spec
spec_commentHandling = describe "Comment handling" $ do
  it "ignores tests in block comments" $ do
    let content = unlines
          [ "module Test where"
          , "{- block comment"
          , "test_ignored :: TestTree"
          , "test_ignored = testCase \"ignored\" $ pure ()"
          , "-}"
          , "test_valid :: TestTree"
          , "test_valid = testCase \"valid\" $ pure ()"
          ]
    let tests = extractTests "Test.hs" content
        testNames = map testFunction tests
    testNames `shouldBe` ["test_valid"]

  it "ignores tests in nested block comments" $ do
    let content = unlines
          [ "module Test where"
          , "{- outer comment"
          , "test_outerIgnored :: TestTree"
          , "  {- inner comment"
          , "test_innerIgnored :: TestTree"
          , "  -}"
          , "test_stillOuterIgnored :: TestTree"
          , "-}"
          , "test_valid :: TestTree"
          ]
    let tests = extractTests "Test.hs" content
        testNames = map testFunction tests
    testNames `shouldBe` ["test_valid"]

  it "correctly handles line comments (existing behavior)" $ do
    let content = unlines
          [ "module Test where"
          , "-- test_lineIgnored :: TestTree"
          , "-- test_lineIgnored = testCase \"ignored\" $ pure ()"
          , "test_valid :: TestTree"
          , "test_valid = testCase \"valid\" $ pure ()"
          ]
    let tests = extractTests "Test.hs" content
        testNames = map testFunction tests
    testNames `shouldBe` ["test_valid"]

  it "finds multiple valid tests correctly" $ do
    let content = unlines
          [ "module Test where"
          , "test_first :: TestTree"
          , "{-"
          , "test_ignored :: TestTree"
          , "-}"
          , "test_second :: TestTree"
          , "test_third :: TestTree"
          ]
    let tests = extractTests "Test.hs" content
        testNames = sort $ map testFunction tests
    testNames `shouldBe` sort ["test_first", "test_second", "test_third"]

{- |
= Custom Test Type Wrapping Pattern

This module demonstrates how to create custom test type wrappers using the @newtype@ pattern
to integrate external testing libraries with tasty-discover's @Tasty@ typeclass and provide
ergonomic flavor functionality (such as skipping tests).

== The Pattern

1. **Wrap external test types**: Use @newtype@ to wrap test types from other libraries
   (e.g., HUnit's @Assertion@, QuickCheck's @Property@, etc.)

2. **Implement Tasty instance**: Provide a @Tasty@ instance that handles the @SkipTest@ option
   and other flavor transformations

3. **Ergonomic skipping**: Tests can be easily skipped using the @Flavored@ pattern with
   visual feedback (yellow @[SKIPPED]@ text)

== Benefits

- **Library Integration**: Seamlessly integrate any testing library with tasty-discover
- **Consistent Interface**: All test types get the same flavor functionality (skip, platform, etc.)
- **Visual Feedback**: Skipped tests are clearly marked with colored @[SKIPPED]@ indicators
- **Type Safety**: @newtype@ provides zero-cost abstractions with compile-time guarantees

== Example Implementation

The @Assertion@ newtype below demonstrates this pattern:

@
newtype Assertion = Assertion HU.Assertion

instance TD.Tasty Assertion where
  tasty info (Assertion assertion) = do
    let yellowText text = setSGRCode [SetColor Foreground Vivid Yellow] ++ text ++ setSGRCode [Reset]
    return $ T.askOption $ \\(TD.SkipTest shouldSkip) ->
      if shouldSkip
        then HU.testCase (TD.nameOf info ++ " " ++ yellowText "[SKIPPED]") (pure ())
        else HU.testCase (TD.nameOf info) assertion
@

== Usage Patterns

**Basic test:**
@
tasty_myTest :: Assertion
tasty_myTest = Assertion $ do
  result <- someComputation
  result \@?\= expectedValue
@

**Skipped test:**
@
tasty_skippedTest :: TD.Flavored Assertion
tasty_skippedTest = TD.flavored TD.skip $ Assertion $ do
  -- This will show as [SKIPPED] in yellow and won't execute
  error "This never runs"
@

**Platform-conditional test:**
@
tasty_linuxOnly :: TD.Flavored Assertion
tasty_linuxOnly = TD.flavored (TD.platform "linux") $ Assertion $ do
  -- Only runs on Linux systems
  linuxSpecificAssertion
@

== Integration with Other Libraries

This pattern can be applied to any testing library:

- **Hedgehog**: @newtype Property = Property H.Property@
- **QuickCheck**: @newtype QCProperty = QCProperty QC.Property@
- **Hspec**: @newtype SpecTest = SpecTest Spec@
- **Custom frameworks**: @newtype MyTest = MyTest MyLibrary.Test@

Each wrapper can implement the @Tasty@ instance to provide consistent flavor functionality
across all test types in your project.
-}

-- | Custom Assertion newtype that wraps HU.Assertion
--
-- This demonstrates the newtype wrapping pattern for integrating external test types
-- with tasty-discover's Tasty typeclass and flavor functionality.
newtype Assertion = Assertion HU.Assertion

-- | Tasty instance for Assertion that provides SkipTest support
--
-- Key features:
-- * Checks SkipTest option at runtime using askOption
-- * Renders skipped tests with yellow [SKIPPED] indicator
-- * Falls back to normal HUnit test execution when not skipped
-- * Maintains test name consistency through TD.nameOf
instance TD.Tasty Assertion where
  tasty info (Assertion assertion) = do
    let yellowText text = setSGRCode [SetColor Foreground Vivid Yellow] ++ text ++ setSGRCode [Reset]
    return $ T.askOption $ \(TD.SkipTest shouldSkip) ->
      if shouldSkip
        then HU.testCase (TD.nameOf info ++ " " ++ yellowText "[SKIPPED]") (pure ())
        else HU.testCase (TD.nameOf info) assertion

-- | Example: Basic usage of the Assertion newtype
--
-- Shows how to create a simple test using the wrapped type.
-- The test will execute normally unless skipped via flavoring.
tasty_assertionExample :: Assertion
tasty_assertionExample = Assertion $ do
  let result = 2 + 2 :: Int
  result @?= 4

-- | Example: Skipped test using Flavored pattern
--
-- Demonstrates how the newtype integrates with the Flavored mechanism
-- to provide ergonomic test skipping with visual feedback.
tasty_skippedAssertion :: TD.Flavored Assertion
tasty_skippedAssertion = TD.flavored TD.skip $ Assertion $ do
  -- This test will be skipped and show "[SKIPPED]" in yellow
  error "This should never run because the test is skipped"

-- | Example: Platform-conditional test
--
-- Shows how the same newtype can work with platform filtering,
-- demonstrating the composability of flavor transformations.
tasty_platformAssertion :: TD.Flavored Assertion
tasty_platformAssertion = TD.flavored (TD.platform "!windows") $ Assertion $ do
  -- This test only runs on non-Windows platforms
  let unixSpecificResult = "Unix-style path" :: String
  length unixSpecificResult @?= 15

spec_symlinksNotFollowed :: Spec
spec_symlinksNotFollowed = describe "Symlinks handling" $ do
  it "this test is disabled - see tasty_symlinksNotFollowed instead" $ do
    pure () :: IO ()

-- Tasty test that expects failure for symlink handling
tasty_symlinksNotFollowed :: IO T.TestTree
tasty_symlinksNotFollowed = do
  pure $ expectFail $ HU.testCase "should handle symlinked directories gracefully without crashing" $ do
    withSystemTempDirectory "tasty-discover-symlink-test" $ \tmpDir -> do
      -- Create a real test directory with a test file
      let realTestDir = tmpDir </> "real-tests"
      createDirectoryIfMissing True realTestDir
      writeFile (realTestDir </> "RealTest.hs") $ unlines
        [ "module RealTest where"
        , "import Test.Tasty.HUnit"
        , "test_real :: TestTree"
        , "test_real = testCase \"real test\" $ 1 @?= 1"
        ]

      -- Create a symlinked directory pointing to the real test directory
      let symlinkTestDir = tmpDir </> "symlinked-tests"
      createFileLink realTestDir symlinkTestDir

      -- Verify symlink was created
      symlinkExists <- doesDirectoryExist symlinkTestDir
      symlinkExists `shouldBe` True

      -- Helper function to print directory structure for debugging
      let printDirStructure dir prefix = do
            contents <- listDirectory dir
            mapM_ (\item -> do
              let fullPath = dir </> item
              isDir <- doesDirectoryExist fullPath
              if isDir
                then do
                  putStrLn $ prefix ++ item ++ "/ (directory)"
                  printDirStructure fullPath (prefix ++ "  ")
                else putStrLn $ prefix ++ item
              ) contents

      -- Run tasty-discover on the temp directory
      let outputFile = tmpDir </> "TestOutput.hs"
      (exitCode, _stdout, stderr) <- readProcessWithExitCode "tasty-discover" [tmpDir, "--output", outputFile] ""

      -- tasty-discover should NOT crash on symlinked directories
      -- This test will FAIL until issue #38 is fixed, which is the correct behavior
      case exitCode of
        ExitFailure code -> do
          putStrLn $ "tasty-discover crashed with exit code " ++ show code
          putStrLn $ "Test directory structure in " ++ tmpDir ++ ":"
          printDirStructure tmpDir ""
          putStrLn $ "stderr: " ++ stderr
          if "withFile: inappropriate type (is a directory)" `isInfixOf` stderr
            then error "BUG: tasty-discover crashes on symlinked directories (GitHub issue #38). This test will pass when the issue is fixed."
            else error $ "tasty-discover failed for unexpected reason: " ++ stderr
        ExitSuccess -> do
          -- Success! tasty-discover handled symlinks gracefully
          putStrLn "tasty-discover handled symlinks gracefully!"
          testOutput <- readFile outputFile
          -- Verify that at least the real test was found
          testOutput `shouldSatisfy` ("RealTest" `isInfixOf`)
          -- The behavior when symlinks are handled correctly could be:
          -- 1. Symlinks are followed (tests appear twice)
          -- 2. Symlinks are ignored (tests appear once)
          -- Either is acceptable as long as no crash occurs