Internal.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

{- |
Module      : TuiSpec.Internal
Description : Shared internal utilities used across tuispec modules.

This module is not part of the public API. It collects helper functions
that are needed by more than one of 'TuiSpec.Runner', 'TuiSpec.Server',
and 'TuiSpec.Render'.
-}
module TuiSpec.Internal (
    -- * List helpers
    safeIndex,

    -- * Path helpers
    safeFileStem,
    snapshotMetadataPath,

    -- * Pattern matching
    regexLikeMatch,
    regexLikeMatchOrigin,
    cleanPattern,
    wildcardContains,
    wildcardContainsOrigin,

    -- * Theme helpers
    resolveAutoSnapshotTheme,
    detectTerminalBackground,

    -- * Exception helpers
    ignoreIOError,
) where

import Control.Exception (SomeException, catch)
import Data.Char (isAlphaNum, toLower)
import Data.List (isSuffixOf)
import Data.Maybe (isJust)
import Data.Text (Text)
import Data.Text qualified as T
import Text.Read (readMaybe)

-- | Safe list indexing that returns 'Nothing' for out-of-bounds access.
safeIndex :: Int -> [a] -> Maybe a
safeIndex indexValue values
    | indexValue < 0 = Nothing
    | otherwise = go indexValue values
  where
    go _ [] = Nothing
    go 0 (x : _) = Just x
    go n (_ : xs) = go (n - 1) xs

-- | Slugify a string into a safe file stem (lowercase, alphanumeric + dashes).
safeFileStem :: String -> String
safeFileStem input =
    let lowered = map toLower input
        normalized = map normalize lowered
        compact = collapseDashes normalized
        trimmed = trimDashes compact
     in if null trimmed then "snapshot" else trimmed
  where
    normalize c
        | isAlphaNum c = c
        | otherwise = '-'

    collapseDashes [] = []
    collapseDashes ('-' : '-' : rest) = collapseDashes ('-' : rest)
    collapseDashes (c : rest) = c : collapseDashes rest

    trimDashes = reverse . dropWhile (== '-') . reverse . dropWhile (== '-')

-- | Derive the @.meta.json@ sidecar path from an @.ansi.txt@ snapshot path.
snapshotMetadataPath :: FilePath -> FilePath
snapshotMetadataPath ansiPath =
    if ".ansi.txt" `isSuffixOf` ansiPath
        then take (length ansiPath - length (".ansi.txt" :: String)) ansiPath <> ".meta.json"
        else ansiPath <> ".meta.json"

{- | Check whether a simple regex-like pattern matches a haystack.

Supports @|@ alternation and @.*@ wildcards.
-}
regexLikeMatch :: Text -> Text -> Bool
regexLikeMatch patternText haystack =
    isJust (regexLikeMatchOrigin patternText haystack)

{- | Like 'regexLikeMatch', but returns the 0-based column where the match
begins — the start of the first literal segment of the earliest-matching
alternative. This is the position a user sees and would click, so selector
clicks must target it rather than, say, the line's first non-blank column.
-}
regexLikeMatchOrigin :: Text -> Text -> Maybe Int
regexLikeMatchOrigin patternText haystack =
    case [col | alt <- alternatives, Just col <- [wildcardContainsOrigin alt haystack]] of
        [] -> Nothing
        cols -> Just (minimum cols)
  where
    alternatives =
        filter (not . T.null) $
            map cleanPattern (T.splitOn "|" patternText)

-- | Strip parentheses from a pattern fragment.
cleanPattern :: Text -> Text
cleanPattern = T.filter (`notElem` ("()" :: String))

-- | Check whether a @.*@-delimited pattern matches within a haystack.
wildcardContains :: Text -> Text -> Bool
wildcardContains patternText haystack =
    isJust (wildcardContainsOrigin patternText haystack)

{- | Like 'wildcardContains', but returns the 0-based start column of the match
— the position of the first literal (non-@.*@) segment — or 'Nothing'. A
pattern that is empty or all wildcards matches at column 0.
-}
wildcardContainsOrigin :: Text -> Text -> Maybe Int
wildcardContainsOrigin patternText haystack =
    case segments of
        [] -> Just 0
        (firstSeg : rest) ->
            let (prefix, suffix) = T.breakOn firstSeg haystack
                firstCol = T.length prefix
             in if not (T.null suffix)
                    && checkSegments (firstCol + T.length firstSeg) rest
                    then Just firstCol
                    else Nothing
  where
    segments = filter (not . T.null) (T.splitOn ".*" patternText)

    checkSegments :: Int -> [Text] -> Bool
    checkSegments _ [] = True
    checkSegments fromIdx (segment : rest) =
        let remaining = T.drop fromIdx haystack
            (prefix, suffix) = T.breakOn segment remaining
         in if T.null suffix
                then False
                else
                    let nextStart = fromIdx + T.length prefix + T.length segment
                     in checkSegments nextStart rest

-- | Resolve @\"auto\"@ snapshot theme to a concrete theme name using @COLORFGBG@.
resolveAutoSnapshotTheme :: String -> Maybe String -> String
resolveAutoSnapshotTheme requestedTheme colorFgBgValue =
    case map toLower requestedTheme of
        "auto" ->
            case detectTerminalBackground colorFgBgValue of
                Just "light" -> "pty-default-light"
                _ -> "pty-default-dark"
        _ -> requestedTheme

-- | Detect terminal background lightness from the @COLORFGBG@ value.
detectTerminalBackground :: Maybe String -> Maybe String
detectTerminalBackground colorFgBgValue =
    case colorFgBgValue >>= parseBgIndex of
        Just bgIndex | bgIndex >= 7 -> Just "light"
        Just _ -> Just "dark"
        Nothing -> Nothing
  where
    parseBgIndex raw =
        case reverse (splitOn ';' raw) of
            [] -> Nothing
            lastPart : _ -> (readMaybe lastPart :: Maybe Int)

    splitOn _ [] = [""]
    splitOn delimiter input =
        case break (== delimiter) input of
            (headPart, []) -> [headPart]
            (headPart, _ : rest) -> headPart : splitOn delimiter rest

-- | Run an IO action, silently discarding any exceptions.
ignoreIOError :: IO () -> IO ()
ignoreIOError action =
    action `catch` \(_ :: SomeException) -> pure ()