Discover.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}

module Test.Tasty.Discover
  ( Tasty(..)
  , TastyInfo
  , SkipTest(..)
  , Flavored(..)
  , flavored
  , name
  , description
  , nameOf
  , descriptionOf
  , skip
  , applySkips
  , platform
  , evaluatePlatformExpression
  ) where

import Data.Maybe
import Data.Monoid
import System.Console.ANSI (Color(..), ColorIntensity(..), ConsoleLayer(..), SGR(..), setSGRCode)
import System.Info (os)
import Test.Tasty.Discover.TastyInfo (TastyInfo)
import Test.Tasty.Discover.Internal.Config (SkipTest(..))

import qualified Test.Tasty as TT
import qualified Test.Tasty.Runners as TR
import qualified Test.Tasty.Providers as TP
import qualified Test.Tasty.Discover.TastyInfo as TI

{- $skipPlatform
Guidelines for using 'skip' and 'platform'
-----------------------------------------

TL;DR:
- For tests exposed via @tasty_@ functions, prefer using the 'Flavored' pattern to apply
  transformations like 'skip' and 'platform' so they take effect at the TestTree level.
- Directly applying 'skip' to an already-constructed 'TT.TestTree' marks the subtree as
  skipped (the test can observe 'SkipTest' via 'TT.askOption'), but the outer 'Tasty'
  instance may not replace it with a top-level "[SKIPPED]" node.

Patterns:
- Skip with 'Flavored':

@
tasty_mySkipped :: Flavored TT.TestTree
tasty_mySkipped = flavored skip $ TT.testCase "will be skipped" $ pure ()
@

-
@
tasty_linuxOnly :: Flavored TT.TestTree
tasty_linuxOnly = flavored (platform "linux") $ TT.testCase "Linux only" $ pure ()
@

Platform expressions:
- Names: @"linux"@, @"darwin"@, @"windows"@ (mapped to @"mingw32"@), @"mingw32"@, and @"unix"@ (matches linux|darwin)
- Operators: NOT @!@, AND @&@, OR @|@
-- Examples:

@
platform "!windows & !darwin"  -- neither Windows nor Darwin
platform "linux | darwin"       -- Linux or Darwin
platform "unix"                 -- Linux or Darwin
@

Combining:
- You can compose transformations: e.g., @flavored (platform "linux") . flavored skip@
  or wrap once with a composed function @flavored (platform "linux" . skip)@.

See 'skip' and 'platform' for function-specific details.
-}

class Tasty a where
  tasty :: TastyInfo -> a -> IO TT.TestTree

instance Tasty TT.TestTree where
  tasty _ a = pure a

instance Tasty [TT.TestTree] where
  tasty info a = pure $ TT.testGroup (descriptionOf info) a

instance Tasty (IO TT.TestTree) where
  tasty _ a = a

instance Tasty (IO [TT.TestTree]) where
  tasty info a = TT.testGroup (descriptionOf info) <$> a

-- | A general-purpose wrapper for transforming TestTrees generated by tasty_ functions.
--
-- The Flavored type allows you to apply transformations to test trees before they
-- are added to the test suite. This enables applying various options and modifications
-- such as skipping tests, setting timeouts, adding metadata, grouping, etc.
--
-- Example usage:
-- @
-- -- Skip a test
-- tasty_skipThis :: Flavored Property
-- tasty_skipThis = flavored skip $ property $ do
--   -- This test will be skipped
--   H.failure
-- @
data Flavored a = Flavored
  { flavoring :: TT.TestTree -> TT.TestTree   -- ^ Transformation function to apply
  , unFlavored :: a                           -- ^ The wrapped test value
  }

-- | Create a Flavored wrapper with a specific transformation function.
--
-- @flavored f a@ applies transformation @f@ to the TestTree generated from @a@.
flavored :: (TT.TestTree -> TT.TestTree) -> a -> Flavored a
flavored f a = Flavored f a

instance Tasty a => Tasty (Flavored a) where
  tasty :: TastyInfo -> Flavored a -> IO TT.TestTree
  tasty info (Flavored f a) = do
    testTree <- tasty info a
    pure $ f testTree

nameOf :: TastyInfo -> String
nameOf info =
  fromMaybe "<unnamed>" (getLast (TI.name info))

descriptionOf :: TastyInfo -> String
descriptionOf info =
  fromMaybe "<undescribed>" (getLast (TI.description info))

name :: String -> TastyInfo
name n = mempty
  { TI.name = Last $ Just n
  }

description :: String -> TastyInfo
description n = mempty
  { TI.description = Last $ Just n
  }

-- | Mark a test tree to be skipped by setting the SkipTest option to True.
--
-- Usage guidelines: see the @Guidelines for using 'skip' and 'platform'@ section ('skipPlatform').
-- In short, for @tasty_@ tests prefer 'flavored' 'skip' to let the outer 'Tasty' instance
-- short-circuit at the TestTree level. Direct 'skip' on a pre-built tree applies the option
-- to the subtree; the test can still observe 'SkipTest' via 'TT.askOption'.
--
-- Examples:
-- @
-- -- Direct usage on a TestTree (the test can read SkipTest via askOption)
-- test_directSkip :: TestTree
-- test_directSkip = skip $ testCase "will be skipped" $ pure ()
--
-- -- Preferred for tasty_ tests: apply at the right stage using Flavored
-- tasty_skipProperty :: Flavored Property
-- tasty_skipProperty = flavored skip $ property $ do
--   -- This property will be skipped
--   H.failure
-- @
skip :: TT.TestTree -> TT.TestTree
skip = TT.adjustOption (const (SkipTest True))

-- | Transform a TestTree to apply skipping behavior throughout the entire tree.
--
-- This function wraps a TestTree so that when the 'SkipTest' option is set to 'True',
-- all individual tests within the tree are replaced with skipped placeholder tests.
-- This is useful when you want to conditionally skip an entire group of tests while
-- still showing each test as skipped in the output.
--
-- The function works by:
--
-- * Checking the 'SkipTest' option via 'TT.askOption'
-- * If skipping is enabled, using 'TT.foldTestTree' to traverse the tree and rebuild it with:
--
--     * All single tests replaced with test cases showing "[SKIPPED]"
--     * Test groups preserved with their structure intact
--     * Resources skipped (not acquired)
--
-- * If skipping is disabled, returning the tree unchanged
--
-- This is particularly useful in combination with 'platform' for platform-specific test suites:
--
-- @
-- tasty_testTree_no_darwin :: Flavored (IO TestTree)
-- tasty_testTree_no_darwin =
--   flavored (platform "!darwin") $ pure $ applySkips $ testGroup "Non-Darwin group"
--     [ testProperty "Test 1" $ \\(x :: Int) -> x == x
--     , testCase "Test 2" $ pure ()
--     ]
-- @
--
-- On Darwin, this will show:
--
-- @
-- Non-Darwin group
--   Test 1 [SKIPPED]: OK
--   Test 2 [SKIPPED]: OK
-- @
--
-- @since 5.1.0
-- | A simple test type for skipped tests
data SkippedTest = SkippedTest
  deriving stock (Show, Eq)

instance TP.IsTest SkippedTest where
  run _ _ _ = return $ TP.testPassed ""
  testOptions = return []

applySkips :: TT.TestTree -> TT.TestTree
applySkips tree = TT.askOption $ \(SkipTest shouldSkip) ->
  if shouldSkip
    then transformTree tree
    else tree
  where
    yellowText :: String -> String
    yellowText text = setSGRCode [SetColor Foreground Vivid Yellow] ++ text ++ setSGRCode [Reset]

    transformTree :: TT.TestTree -> TT.TestTree
    transformTree t = case TR.foldTestTree
      TR.TreeFold
        { TR.foldSingle = \_ testName _ -> [TP.singleTest (testName ++ " " ++ yellowText "[SKIPPED]") SkippedTest]
        , TR.foldGroup = \_ groupName trees -> [TT.testGroup groupName (concat trees)]
        , TR.foldResource = \_ _ _ -> []
        , TR.foldAfter = \_ _ _ trees -> trees
        }
      mempty
      t of
        [result] -> result
        results -> TT.testGroup "" results

-- | Conditionally run a test based on a platform expression.
--
-- Usage guidelines, syntax, and examples: see the @Guidelines for using 'skip' and 'platform'@
-- section ('skipPlatform').
--
-- The expression supports logical operations with platform names:
-- - Platform names: "linux", "darwin", "mingw32", "windows", "unix"
-- - Negation: "!platform" (not on platform)  
-- - Conjunction: "platform1 & platform2" (on both platforms)
-- - Disjunction: "platform1 | platform2" (on either platform)
-- - Parentheses: "(platform1 | platform2) & !platform3"
--
-- Examples:
-- @
-- -- Only on Linux
-- test_linuxOnly :: TestTree
-- test_linuxOnly = platform "linux" $ testCase "Linux only" $ pure ()
--
-- -- Not on Windows or macOS
-- test_notWinMac :: TestTree  
-- test_notWinMac = platform "!windows & !darwin" $ testCase "Unix-like only" $ pure ()
--
-- -- On Linux or macOS but not Windows
-- test_unixLike :: TestTree
-- test_unixLike = platform "(linux | darwin) & !windows" $ testCase "Unix-like" $ pure ()
-- @
platform :: String -> TT.TestTree -> TT.TestTree
platform expr testTree = 
  if evaluatePlatformExpression expr os
    then testTree
    else skip testTree

-- | Evaluate a platform expression against a given platform string.
--
-- Inputs:
-- - The first argument is the platform expression (e.g. @"linux | darwin"@, @"!windows"@).
-- - The second argument is the current platform, typically @System.Info.os@ (e.g. @"linux"@, @"darwin"@, @"mingw32"@).
--
-- Semantics (result is 'True' when the test should run):
-- - Supported platform names: @"linux"@, @"darwin"@, @"mingw32"@, @"windows"@ (alias for @"mingw32"@), and @"unix"@ (alias for @"linux | darwin"@).
-- - Supported operators: NOT @!@, AND @&@, OR @|@.
-- - Unknown simple names evaluate to 'False' (do not run).
-- - Malformed or empty expressions evaluate to 'True' (default to running).
--   Malformed includes the presence of operator characters without a valid parse.
-- - Parentheses characters @(@ and @)@ are tokenized but grouping is not currently implemented;
--   using parentheses in the expression will cause it to be treated as malformed and therefore
--   default to 'True' (run). Prefer composing with @&@ and @|@ without parentheses.
--
-- Examples:
--
-- @
-- evaluatePlatformExpression "linux"        "linux"   == True
-- evaluatePlatformExpression "linux"        "darwin"  == False
-- evaluatePlatformExpression "!windows"     "mingw32" == False
-- evaluatePlatformExpression "linux|darwin" "darwin"  == True
-- evaluatePlatformExpression "unix"         "darwin"  == True   -- alias for linux|darwin
-- evaluatePlatformExpression "unknown"      "linux"   == False  -- unknown simple name
-- evaluatePlatformExpression ""             "linux"   == True   -- empty -> run
-- @
evaluatePlatformExpression :: String -> String -> Bool
evaluatePlatformExpression expr currentPlatform = 
  case parsePlatformExpression expr of
    Just result -> evalExpression result currentPlatform
    Nothing -> 
      -- If it's just a simple unknown platform name, return False
      -- If it's an empty/malformed expression, return True
      let malformedOrEmpty = null (words expr) || any (`elem` ['&', '|', '!', '(', ')']) expr
      in malformedOrEmpty

-- Parse a platform expression with logical operators
parsePlatformExpression :: String -> Maybe PlatformExpr
parsePlatformExpression expr = parseOr (tokenize expr)

-- Tokenize the expression preserving logical operators
tokenize :: String -> [String]
tokenize = words . concatMap tokenizeChar
  where
    tokenizeChar '&' = " & "
    tokenizeChar '|' = " | "  
    tokenizeChar '(' = " ( "
    tokenizeChar ')' = " ) "
    tokenizeChar c = [c]

-- Parse OR expressions (lowest precedence)
parseOr :: [String] -> Maybe PlatformExpr
parseOr tokens = case break (== "|") tokens of
  (left, []) -> parseAnd left
  (left, _:right) -> do
    leftExpr <- parseAnd left
    rightExpr <- parseOr right
    return $ Or leftExpr rightExpr

-- Parse AND expressions (higher precedence)
parseAnd :: [String] -> Maybe PlatformExpr
parseAnd tokens = case break (== "&") tokens of
  (left, []) -> parseAtom left
  (left, _:right) -> do
    leftExpr <- parseAtom left
    rightExpr <- parseAnd right
    return $ And leftExpr rightExpr

-- Parse atomic expressions (platform names and negation)
parseAtom :: [String] -> Maybe PlatformExpr
parseAtom [] = Nothing
parseAtom tokens = case tokens of
  ["linux"] -> Just $ PlatformName "linux"
  ["darwin"] -> Just $ PlatformName "darwin"
  ["windows"] -> Just $ PlatformName "mingw32"
  ["mingw32"] -> Just $ PlatformName "mingw32"
  ["unix"] -> Just $ Or (PlatformName "linux") (PlatformName "darwin")
  ["!linux"] -> Just $ Not (PlatformName "linux")
  ["!darwin"] -> Just $ Not (PlatformName "darwin")
  ["!windows"] -> Just $ Not (PlatformName "mingw32")
  ["!mingw32"] -> Just $ Not (PlatformName "mingw32")
  ["!unix"] -> Just $ Not (Or (PlatformName "linux") (PlatformName "darwin"))
  _ -> Nothing

-- Simple expression data type
data PlatformExpr 
  = PlatformName String
  | Not PlatformExpr
  | And PlatformExpr PlatformExpr  
  | Or PlatformExpr PlatformExpr
  deriving stock (Show, Eq)

-- Evaluate the expression against the current platform
evalExpression :: PlatformExpr -> String -> Bool
evalExpression expr currentPlatform = case expr of
  PlatformName platformName -> currentPlatform == platformName
  Not e -> not (evalExpression e currentPlatform)
  And e1 e2 -> evalExpression e1 currentPlatform && evalExpression e2 currentPlatform
  Or e1 e2 -> evalExpression e1 currentPlatform || evalExpression e2 currentPlatform