Discover.hs

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

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

import Data.Maybe
import Data.Monoid
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.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))

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