{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Test.Framework (
  TestTree,
  testGroup,
  groupSetCollapse,
  testProperty,
  runTests,
  defaultMain,
  Options(..),

  -- * Resources
  withResource,
  withResource',
  TestCtx,
  outputWarningText,

  -- * Compatibility
  TestName,
) where

import Control.Concurrent (setNumCapabilities, forkIO, forkOn, killThread)
import Control.Concurrent.MVar
import Control.Concurrent.STM
import Control.Exception (SomeException, throw, try, throwIO)
import Control.Monad (forM, when, forM_)
import Control.Monad.IO.Class
import Data.IORef
import Data.List (isInfixOf, intercalate)
import Data.Maybe (mapMaybe, fromJust)
import Data.Monoid (All(..), Any(..), Sum(..))
import Data.PQueue.Prio.Min qualified as PQ
import Data.String (fromString)
import Data.Time.Clock
import GHC.Conc (getNumProcessors)
import GHC.Generics (Generic, Generically(..))
import System.Console.ANSI qualified as ANSI
import System.Console.Concurrent (outputConcurrent)
import System.Console.Regions
import System.Environment (getArgs, getProgName)
import System.Exit
import System.IO (hFlush, hPutStrLn, stdout, stderr, hIsTerminalDevice)
import Text.Read (readMaybe)

import Hedgehog qualified as H
import Hedgehog.Internal.Config qualified as H
import Hedgehog.Internal.Property qualified as H
import Hedgehog.Internal.Report qualified as H
import Hedgehog.Internal.Runner qualified as H
import Hedgehog.Internal.Seed qualified as H.Seed


-- TODO: with GHC 9.12 we have tryWithContext and rethrowIO, which is better for rethrowing exceptions


type TestName = String

data TestTree
  = Group GroupOpts String [TestTree]
  | forall a. Resource String ((?testCtx :: TestCtx) => IO a) ((?testCtx :: TestCtx) => a -> IO ()) (a -> TestTree)
      -- ^ Name is not specified by user, but inherited from the tree below
  | HP String H.Property

data TestCtx = TestCtx
  { tctxOutput :: String -> IO () }

outputWarningText :: (?testCtx :: TestCtx) => String -> IO ()
outputWarningText = tctxOutput ?testCtx

-- Not exported because a Resource is not supposed to have a name in the first place
treeName :: TestTree -> String
treeName (Group _ name _) = name
treeName (Resource name _ _ _) = name
treeName (HP name _) = name

data GroupOpts = GroupOpts
  { goCollapse :: Bool }
  deriving (Show)

defaultGroupOpts :: GroupOpts
defaultGroupOpts = GroupOpts False

testGroup :: String -> [TestTree] -> TestTree
testGroup = Group defaultGroupOpts

groupSetCollapse :: TestTree -> TestTree
groupSetCollapse (Group opts name trees) = Group opts { goCollapse = True } name trees
groupSetCollapse _ = error "groupSetCollapse: not called on a Group"

-- | The @a -> TestTree@ function must use the @a@ only inside properties: the
-- function will be passed 'undefined' when exploring the test tree (without
-- running properties).
withResource :: ((?testCtx :: TestCtx) => IO a) -> ((?testCtx :: TestCtx) => a -> IO ()) -> (a -> TestTree) -> TestTree
withResource make cleanup fun = Resource (treeName (fun undefined)) make cleanup fun

-- | Same caveats as 'withResource'.
withResource' :: ((?testCtx :: TestCtx) => IO a) -> (a -> TestTree) -> TestTree
withResource' make fun = withResource make (\_ -> return ()) fun

testProperty :: String -> H.Property -> TestTree
testProperty = HP

filterTree :: Options -> TestTree -> Maybe TestTree
filterTree (Options { optsPattern = pat }) = go []
  where
    go path (Group opts name trees) =
      case mapMaybe (go (name:path)) trees of
        [] -> Nothing
        trees' -> Just (Group opts name trees')
    go path (Resource inhname make free fun) =
      case go path (fun undefined) of
        Nothing -> Nothing
        Just _ -> Just $ Resource inhname make free (fromJust . go path . fun)
    go path hp@(HP name _)
      | pat `isInfixOf` renderPath (name:path) = Just hp
      | otherwise = Nothing

    renderPath comps = "^" ++ intercalate "/" (reverse comps) ++ "$"

treeNumTests :: TestTree -> Int
treeNumTests (Group _ _ ts) = sum (map treeNumTests ts)
treeNumTests (Resource _ _ _ fun) = treeNumTests (fun undefined)
treeNumTests HP{} = 1

computeMaxLen :: TestTree -> Int
computeMaxLen = go 0
  where
    go :: Int -> TestTree -> Int
    go indent (Group opts name trees)
      -- If we collapse, the name of the group gets prefixed before the final status message after collapsing.
      | goCollapse opts = maximum (2*indent + length name : map (go (indent+1)) trees)
      -- If we don't collapse, the group name does get printed but without any status message, so it doesn't need to get accounted for in maxlen.
      | otherwise = maximum (0 : map (go (indent+1)) trees)
    go indent (Resource _ _ _ fun) = go indent (fun undefined)
    go indent (HP name _) = 2 * indent + length name

data Stats = Stats
  { statsOK :: Int
  , statsTotal :: Int }
  deriving (Show)

initStats :: Stats
initStats = Stats 0 0

modifyStats :: (?stats :: IORef Stats) => (Stats -> Stats) -> IO ()
modifyStats f = atomicModifyIORef' ?stats (\s -> (f s, ()))

data Options = Options
  { optsPattern :: String
  , optsHelp :: Bool
  , optsHedgehogReplay :: Maybe (H.Skip, H.Seed)
  , optsHedgehogShrinks :: Maybe Int
  , optsParallel :: Bool
  , optsVerbose :: Bool
  }
  deriving (Show)

defaultOptions :: Options
defaultOptions = Options "" False Nothing Nothing False False

parseOptions :: [String] -> Options -> Either String Options
parseOptions [] opts = pure opts
parseOptions ("-h":args) opts = parseOptions args opts { optsHelp = True }
parseOptions ("--help":args) opts = parseOptions args opts { optsHelp = True }
parseOptions ("-p":arg:args) opts
  | optsPattern opts == "" = parseOptions args opts { optsPattern = arg }
  | otherwise = Left "Multiple '-p' arguments given"
parseOptions ("--hedgehog-replay":arg:args) opts
  | Nothing <- optsHedgehogReplay opts =
      let parsed = do
            (skipstr, ' ' : seedstr) <- return $ span (/= ' ') arg
            (,) <$> H.skipDecompress skipstr <*> readMaybe seedstr
      in case parsed of
           Just res -> parseOptions args opts { optsHedgehogReplay = Just res }
           Nothing -> Left "Invalid argument to '--hedgehog-replay'"
  | otherwise = Left "Multiple '--hedgehog-replay' arguments given"
parseOptions ("--hedgehog-shrinks":arg:args) opts =
  case readMaybe arg of
    Just n -> parseOptions args opts { optsHedgehogShrinks = Just n }
    Nothing -> Left "Invalid argument to '--hedgehog-shrinks'"
parseOptions ("--parallel":args) opts = parseOptions args opts { optsParallel = True }
parseOptions ("--verbose":args) opts = parseOptions args opts { optsVerbose = True }
parseOptions (arg:_) _ = Left $ "Unrecognised argument: '" ++ arg ++ "'"

printUsage :: IO ()
printUsage = do
  progname <- getProgName
  putStr $ unlines
    ["Usage: " ++ progname ++ " [options]"
    ,"Options:"
    ,"  -h / --help    Show this help"
    ,"  -p PATTERN     Only tests whose path contains PATTERN are run. The path of a"
    ,"                 test looks like: '^group1/group2/testname$'."
    ,"  --hedgehog-replay '{skip} {seed}'"
    ,"                 Skip to a particular generated Hedgehog test. Should be used"
    ,"                 with -p. Overrides 'propertySkip' in 'PropertyConfig' if set."
    ,"  --hedgehog-shrinks NUM"
    ,"                 Limit the number of shrinking steps."
    ,"  --parallel     Run tests in parallel."
    ,"  --verbose      Currently only has an effect with --parallel. Also shows OK"
    ,"                 and timing for test groups, not only individual tests."]

defaultMain :: TestTree -> IO ()
defaultMain tree = do
  args <- getArgs
  case parseOptions args defaultOptions of
    Left err -> die err
    Right opts
      | optsHelp opts -> printUsage >> exitSuccess
      | otherwise -> runTests opts tree >>= exitWith

runTests :: Options -> TestTree -> IO ExitCode
runTests options = \tree' ->
  case filterTree options tree' of
    Nothing -> do hPutStrLn stderr "No tests matched the given pattern."
                  return (ExitFailure 1)
    Just tree -> do
      isterm <- hIsTerminalDevice stdout
      starttm <- getCurrentTime
      statsRef <- newIORef initStats
      success <-
        let ?stats = statsRef
            ?options = options
            ?maxlen = computeMaxLen tree
            ?istty = isterm
        in if optsParallel options
             then do nproc <- getNumProcessors
                     setNumCapabilities nproc
                     displayConsoleRegions $
                       withWorkerPool nproc $ \pool -> do
                         let ?pool = pool
                         successVar <- newEmptyMVar
                         runTreePar Nothing [] [] tree successVar
                         readMVar successVar
             else getAll . seqresAllSuccess <$> runTreeSeq 0 [] tree
      stats <- readIORef statsRef
      endtm <- getCurrentTime
      let ?istty = isterm in printStats (treeNumTests tree) stats (diffUTCTime endtm starttm)
      return (if success then ExitSuccess else ExitFailure 1)

-- | Returns when all jobs in this tree have been scheduled. When all jobs are
-- done, the outvar is filled with whether all tests in this tree were
-- successful.
-- The mparregion is the parent region to take over, if any. Having a parent
-- region to take over implies that we are currently executing in a worker and
-- can hence run blocking user code directly in the current thread.
runTreePar :: (?options :: Options, ?stats :: IORef Stats, ?maxlen :: Int, ?istty :: Bool, ?pool :: WorkerPool [Int])
           => Maybe ConsoleRegion -> [Int] -> [String] -> TestTree -> MVar Bool -> IO ()
-- TODO: handle collapse somehow?
runTreePar mparregion revidxlist revpath (Group _ name trees) outvar = do
  let path = intercalate "/" (reverse (name : revpath))
  -- outputConcurrent $ "! " ++ path ++ ": Started\n"

  -- If we have exactly one child and we're currently running in a worker, we can continue doing so
  mparregion2 <- case trees of
    [_] -> return mparregion
    _ -> do  -- If not, we have to close the region (and implicitly relinquish the worker job)
      forM_ mparregion closeConsoleRegion
      return Nothing

  starttm <- getCurrentTime
  suboutvars <- forM (zip trees [0..]) $ \(tree, idx) -> do
    suboutvar <- newEmptyMVar
    runTreePar mparregion2 (idx : revidxlist) (name : revpath) tree suboutvar
    return suboutvar

  -- outputConcurrent $ "! " ++ path ++ ": Scheduled all\n"

  -- If we took over the parent region then this readMVar will resolve
  -- immediately and the forkIO would be unnecessary. Meh.
  _ <- forkIO $ do
    success <- and <$> traverse readMVar suboutvars
    endtm <- getCurrentTime
    -- outputConcurrent $ "! " ++ path ++ ": Done\n"
    if success && optsVerbose ?options
      then let text = path ++ ": " ++ ansiGreen ++ "OK" ++ ansiReset ++ " " ++
                      prettyDuration False (realToFrac (diffUTCTime endtm starttm))
           in outputConcurrent (text ++ "\n")
      else return ()
    putMVar outvar success

  return ()

runTreePar topmparregion revidxlist revpath toptree@Resource{} topoutvar = runResource topmparregion 1 toptree topoutvar
  where
    runResource
      :: (?options :: Options, ?stats :: IORef Stats, ?maxlen :: Int, ?istty :: Bool, ?pool :: WorkerPool [Int])
      => Maybe ConsoleRegion -> Int -> TestTree -> MVar Bool -> IO ()
    runResource mparregion depth (Resource inhname make cleanup fun) outvar = do
      let pathitem = '[' : show depth ++ "](" ++ inhname ++ ")"
          path = intercalate "/" (reverse (pathitem : revpath))
          idxlist = reverse revidxlist
      let ?testCtx = TestCtx (\str ->
                       outputConcurrent (ansiYellow ++ "## Warning for " ++ path ++ ":" ++ ansiReset ++
                                         "\n" ++ str ++ "\n"))
      submitOrRunIn mparregion idxlist Nothing $ \makeRegion -> do
        setConsoleRegion makeRegion ('|' : path ++ " [R] making...")

        try make >>= \case
          Left (err :: SomeException) -> do
            finishConsoleRegion makeRegion $
              ansiRed ++ "Exception building resource at " ++ path ++ ":" ++ ansiReset ++ "\n" ++ show err
            putMVar outvar False
          Right value -> do
            suboutvar <- newEmptyMVar
            runResource (Just makeRegion) (depth + 1) (fun value) suboutvar  -- will consume makeRegion

            _ <- forkIO $ do
              success <- readMVar suboutvar
              poolSubmit ?pool idxlist Nothing $ do
                cleanupRegion <- openConsoleRegion Linear
                setConsoleRegion cleanupRegion ('|' : path ++ " [R] cleanup...")
                try (cleanup value) >>= \case
                  Left (err :: SomeException) -> do
                    finishConsoleRegion cleanupRegion $
                      ansiRed ++ "Exception cleaning up resource at " ++ path ++ ":" ++ ansiReset ++ "\n" ++ show err
                    putMVar outvar False
                  Right () -> do
                    closeConsoleRegion cleanupRegion
                    putMVar outvar success
            return ()
    runResource mparregion _ tree outvar = runTreePar mparregion revidxlist revpath tree outvar

runTreePar mparregion revidxlist revpath (HP name prop) outvar = do
  let path = intercalate "/" (reverse (name : revpath))
      idxlist = reverse revidxlist

  submitOrRunIn mparregion idxlist (Just outvar) $ \region -> do
    -- outputConcurrent $ "! " ++ path ++ ": Running"
    let prefix = path ++ " [T]"
    setConsoleRegion region ('|' : prefix)
    let progressHandler report = do
          str <- H.renderProgress H.EnableColor (Just (fromString "")) report
          setConsoleRegion region ('|' : prefix ++ ": " ++ replace '\n' "  " str)
    (ok, rendered) <- runHP progressHandler revpath name prop
    finishConsoleRegion region (path ++ ": " ++ rendered)
    return ok

submitOrRunIn :: (?pool :: WorkerPool [Int])
              => Maybe ConsoleRegion -> [Int] -> Maybe (MVar a) -> (ConsoleRegion -> IO a) -> IO ()
submitOrRunIn Nothing idxlist outvar fun =
  poolSubmit ?pool idxlist outvar (openConsoleRegion Linear >>= fun)
submitOrRunIn (Just reg) _idxlist outvar fun = do
  result <- fun reg
  forM_ outvar $ \mvar -> putMVar mvar result

data SeqRes = SeqRes
  { seqresHaveWarnings :: Any
  , seqresAllSuccess :: All
  , seqresNumLines :: Sum Int }
  deriving (Generic)
  deriving (Semigroup, Monoid) via Generically SeqRes

-- | If all tests are successful, returns the number of output lines produced
runTreeSeq :: (?options :: Options, ?stats :: IORef Stats, ?maxlen :: Int, ?istty :: Bool)
           => Int -> [String] -> TestTree -> IO SeqRes
runTreeSeq indent revpath (Group opts name trees) = do
  putStrLn (replicate (2 * indent) ' ' ++ name) >> hFlush stdout
  starttm <- getCurrentTime
  res <- fmap mconcat . forM trees $
           runTreeSeq (indent + 1) (name : revpath)
  endtm <- getCurrentTime
  if not (getAny (seqresHaveWarnings res)) && getAll (seqresAllSuccess res) && goCollapse opts && ?istty
    then do
      let thislen = 2*indent + length name
      let Sum lns = seqresNumLines res
      putStrLn $ concat (replicate (lns+1) (ANSI.cursorUpCode 1 ++ ANSI.clearLineCode)) ++
                 ANSI.setCursorColumnCode 0 ++
                 replicate (2 * indent) ' ' ++ name ++ ": " ++ replicate (?maxlen - thislen) ' ' ++
                 ansiGreen ++ "OK" ++ ansiReset ++
                 prettyDuration False (realToFrac (diffUTCTime endtm starttm))
      return (mempty { seqresNumLines = 1 })
    else return (res <> mempty { seqresNumLines = 1 })
runTreeSeq indent revpath (Resource _ make cleanup fun) = do
  let path = intercalate "/" (reverse revpath)
  outputted <- newIORef False
  let ?testCtx = TestCtx (\str -> do
                   atomicModifyIORef' outputted (\_ -> (True, ()))
                   putStrLn (ansiYellow ++ "## Warning for " ++ path ++
                             ":" ++ ansiReset ++ "\n" ++ str))
  res <- try make >>= \case
    Left (err :: SomeException) -> do
      putStrLn $ ansiRed ++ "Exception building resource at " ++ path ++ ":" ++ ansiReset
      print err
      return (mempty { seqresAllSuccess = All False })
    Right value -> do
      res <- runTreeSeq indent revpath (fun value)
      try (cleanup value) >>= \case
        Left (err :: SomeException) -> do
          putStrLn $ ansiRed ++ "Exception cleaning up resource at " ++ path ++ ":" ++ ansiReset
          print err
          return (res { seqresAllSuccess = All False })
        Right () -> return res

  warnings <- readIORef outputted
  return (res <> mempty { seqresHaveWarnings = Any warnings })
runTreeSeq indent path (HP name prop) = do
  let thislen = 2*indent + length name
  let prefix = replicate (2*indent) ' ' ++ name ++ ": " ++ replicate (?maxlen - thislen) ' '
  when ?istty $ putStr prefix >> hFlush stdout
  (ok, rendered) <- runHP (outputProgress (?maxlen + 2)) path name prop
  putStrLn ((if ?istty then ANSI.clearFromCursorToLineEndCode else prefix) ++ rendered) >> hFlush stdout
  return (mempty { seqresAllSuccess = All ok, seqresNumLines = 1 })

runHP :: (?options :: Options, ?stats :: IORef Stats, ?maxlen :: Int)
      => (H.Report H.Progress -> IO ())
      -> [String]
      -> String -> H.Property -> IO (Bool, String)
runHP progressPrinter revpath name (H.Property config test) = do
  let (config', seedfun) = applyHedgehogOptions ?options config
  seed <- seedfun

  starttm <- getCurrentTime
  report <- H.checkReport config' 0 seed test progressPrinter
  endtm <- getCurrentTime

  rendered <- renderResult report (intercalate "/" (reverse (name : revpath))) (diffUTCTime endtm starttm)

  let ok = H.reportStatus report == H.OK
  modifyStats $ \stats -> stats { statsOK = fromEnum ok + statsOK stats
                                , statsTotal = 1 + statsTotal stats }
  return (ok, rendered)

applyHedgehogOptions :: MonadIO m => Options -> H.PropertyConfig -> (H.PropertyConfig, m H.Seed)
applyHedgehogOptions opts config0 =
  let (f1, seedfun) = case optsHedgehogReplay opts of
                        Just (skip, seed) -> (\c -> c { H.propertySkip = Just skip }, return seed)
                        Nothing -> (id, H.Seed.random)
      f2 = case optsHedgehogShrinks opts of
             Just n -> \c -> c { H.propertyShrinkLimit = H.ShrinkLimit n }
             Nothing -> id
  in (f2 . f1 $ config0, seedfun)

outputProgress :: (?istty :: Bool) => Int -> H.Report H.Progress -> IO ()
outputProgress indent report
  | ?istty = do
      str <- H.renderProgress H.EnableColor (Just (fromString "")) report
      putStr (replace '\n' "  " str ++ ANSI.setCursorColumnCode indent)
      hFlush stdout
  | otherwise = return ()

renderResult :: H.Report H.Result -> String -> NominalDiffTime -> IO String
renderResult report path timeTaken = do
  str <- H.renderResult H.EnableColor (Just (fromString "")) report
  case H.reportStatus report of
    H.OK -> return (str ++ prettyDuration False (realToFrac timeTaken))
    H.Failed failure -> do
      let H.Report { H.reportTests = count, H.reportDiscards = discards } = report
          replayInfo = H.skipCompress (H.SkipToShrink count discards (H.failureShrinkPath failure)) ++
                       " " ++ show (H.reportSeed report)
          suffix = "\n    Flags to reproduce: `-p '" ++ path ++ "' --hedgehog-replay '" ++ replayInfo ++ "'`"
      return (str ++ suffix)
    _ -> return str

printStats :: (?istty :: Bool) => Int -> Stats -> NominalDiffTime -> IO ()
printStats numTests stats timeTaken
  | statsOK stats == numTests = do
      putStrLn $ ansiGreen ++ "All " ++ show (statsTotal stats) ++
                 " tests passed." ++ prettyDuration True (realToFrac timeTaken) ++ ansiReset
  | statsOK stats == statsTotal stats =
      putStrLn $ ansiRed ++ "Failed (" ++ show (numTests - statsTotal stats) ++ " tests could not run)." ++
                 prettyDuration True (realToFrac timeTaken) ++ ansiReset
  | otherwise =
      let nfailed = statsTotal stats - statsOK stats
      in putStrLn $ ansiRed ++ "Failed " ++ show nfailed ++ " out of " ++ show (statsTotal stats) ++ " tests" ++
                    (if statsTotal stats /= numTests then " (" ++ show (numTests - statsTotal stats) ++ " could not run)" else "") ++
                    "." ++ prettyDuration True (realToFrac timeTaken) ++ ansiReset


newtype WorkerPool k = WorkerPool (TVar (PQ.MinPQueue k (Terminate PoolJob)))
data PoolJob = forall a. PoolJob (IO a) (Maybe (MVar a))
data Terminate a = Terminate | Value a
  deriving (Eq, Ord)  -- Terminate sorts before Value

withWorkerPool :: Ord k => Int -> (WorkerPool k -> IO a) -> IO a
withWorkerPool numWorkers k = do
  chan <- newTVarIO PQ.empty
  threads <- forM [0..numWorkers-1] (\i -> forkOn i (worker i chan))
  eres <- try (k (WorkerPool chan))
  case eres of
    Left (err :: SomeException) -> do
      atomically $ writeTVar chan PQ.empty
      forM_ threads killThread
      throw err
    Right res -> do
      readTVarIO chan >>= \case
        PQ.Empty -> return ()
        _ -> throwIO (userError "withWorkerPool: computation exited before all jobs were handled")
      return res
  where
    worker :: Ord k => Int -> TVar (PQ.MinPQueue k (Terminate PoolJob)) -> IO ()
    worker idx chan = do
      job <- atomically $
        readTVar chan >>= \case
          PQ.Empty -> retry
          (_, j) PQ.:< q -> writeTVar chan q >> return j
      case job of
        Value (PoolJob action mmvar) -> do
          -- outputConcurrent $ "[" ++ show idx ++ "] got job\n"
          result <- action
          forM_ mmvar $ \mvar -> putMVar mvar result
          worker idx chan
        Terminate -> return ()

poolSubmit :: Ord k => WorkerPool k -> k -> Maybe (MVar a) -> IO a -> IO ()
poolSubmit (WorkerPool chan) key mmvar action =
  atomically $ modifyTVar chan $ PQ.insert key (Value (PoolJob action mmvar))


prettyDuration :: Bool -> Double -> String
prettyDuration False x | x < 0.5 = ""
prettyDuration _ x =
  let str = show (round (x * 100) :: Int)
      str' = replicate (3 - length str) '0' ++ str
      (pre, post) = splitAt (length str' - 2) str'
  in " (" ++ pre ++ "." ++ post ++ "s)"

replace :: Eq a => a -> [a] -> [a] -> [a]
replace x ys = concatMap (\y -> if y == x then ys else [y])

ansi :: (?istty :: Bool) => String -> String
ansi | ?istty = id
     | otherwise = const ""

ansiRed, ansiYellow, ansiGreen, ansiReset :: (?istty :: Bool) => String
ansiRed    = ansi (ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Red])
ansiYellow = ansi (ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Yellow])
ansiGreen  = ansi (ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Green])
ansiReset  = ansi (ANSI.setSGRCode [ANSI.Reset])

-- getTermIsDark :: IO Bool
-- getTermIsDark = do
--   mclr <- ANSI.getLayerColor ANSI.Background
--   case mclr of
--     Nothing -> return True
--     Just (RGB r g b) ->
--       let cvt n = fromIntegral n / fromIntegral (maxBound `asTypeOf` n)
--       in return $ (cvt r + cvt g + cvt b) / 3 < (0.5 :: Double)

-- ansiRegionBg :: (?istty :: Bool, ?termisdark :: Bool) => String
-- ansiRegionBg
--   | not ?istty = ""
--   | ?termisdark = ANSI.setSGRCode [ANSI.SetRGBColor ANSI.Background (rgb 0.0 0.05 0.1)]
--   | otherwise = ANSI.setSGRCode [ANSI.SetRGBColor ANSI.Background (rgb 0.95 0.95 1.0)]