content: {-# LANGUAGE DeriveGeneric, DeriveFoldable, FlexibleInstances, LambdaCase, NamedFieldPuns,
               TypeApplications, ViewPatterns #-}
  
  -- |
  module DependentTestGroup where
  
  import Control.Concurrent
  import Control.Monad (forM_, zipWithM_)
  import Data.Coerce (coerce)
  import Data.List (mapAccumL)
  import Data.Maybe (fromMaybe)
  import Data.Tuple (swap)
  import GHC.Generics (Generic)
  import GHC.IO.Unsafe (unsafePerformIO)
  import System.Random (randomIO)
  import Utils (runSMap)
  
  import Test.Tasty
  import Test.Tasty.HUnit
  import Test.Tasty.Options
  import Test.Tasty.Runners
  import qualified Test.Tasty.QuickCheck as Q
  
  -- | Magic constant determining the number of threads to run with. Should be at
  -- least 2 to trigger chaotic behavior.
  nUM_THREADS :: NumThreads
  nUM_THREADS = NumThreads 3
  
  testDependentTestGroup :: TestTree
  testDependentTestGroup =
    adjustOption (const nUM_THREADS) $
  
    testGroup "DependentTestGroup"
    [ testGroup "tree0"           [toTestTree (GenUniqueLabels True)  (labelTree tree0)]
    , testGroup "tree1"           [toTestTree (GenUniqueLabels True)  (labelTree tree1)]
    , testGroup "tree2"           [toTestTree (GenUniqueLabels True)  (labelTree tree2)]
    , testGroup "tree3"           [toTestTree (GenUniqueLabels True)  (labelTree tree3)]
    , testGroup "tree4"           [toTestTree (GenUniqueLabels True)  (labelTree tree4)]
    , testGroup "tree5"           [toTestTree (GenUniqueLabels True)  (labelTree tree5)]
    , testGroup "tree5_no_unique" [toTestTree (GenUniqueLabels False) (labelTree tree5)]
    , testGroup "tree6"           [toTestTree (GenUniqueLabels True)  (labelTree tree5)]
    , testGroup "treeReg"         [toTestTree (GenUniqueLabels True)  (labelTree emptySeq)]
  
    , Q.testProperty "prop_tree" unsafeRunTest
  
    , testGroup "filtering"
      [ testCase "A" $ filterTestTree "A" @?= ["A.B","A.C","A.D","A.E.F","A.E.G","A.E.H"]
      , testCase "B" $ filterTestTree "B" @?= ["A.B"]
      , testCase "C" $ filterTestTree "C" @?= ["A.C"]
      , testCase "D" $ filterTestTree "D" @?= ["A.D"]
      , testCase "E" $ filterTestTree "E" @?= ["A.E.F", "A.E.G", "A.E.H"]
      , testCase "F" $ filterTestTree "F" @?= ["A.E.F"]
      , testCase "G" $ filterTestTree "G" @?= ["A.E.F", "A.E.G"]
      , testCase "H" $ filterTestTree "H" @?= ["A.E.F", "A.E.G", "A.E.H"]
      , testCase "H" $ filterForOrderedTestGroups "H" @?= ["A.E.H"]
      ]
    ]
  
  emptySeqTree :: SimpleTestTree () ()
  emptySeqTree = Dependently () []
  
  tree0 :: SimpleTestTree () ()
  tree0 = Test ()
  
  tree1 :: SimpleTestTree () ()
  tree1 = InParallel () [Test (), Test (), Test ()]
  
  tree2 :: SimpleTestTree () ()
  tree2 = Dependently () [Test (), Test (), Test ()]
  
  tree3 :: SimpleTestTree () ()
  tree3 = Dependently () [tree1, tree2]
  
  tree4 :: SimpleTestTree () ()
  tree4 = Dependently () [tree2, tree1]
  
  tree5 :: SimpleTestTree () ()
  tree5 = InParallel () [tree0, tree1, tree2, tree3, tree4]
  
  tree6 :: SimpleTestTree () ()
  tree6 = Dependently () [tree3, emptySeqTree, tree3]
  
  mkTestGroup :: (String -> [TestTree] -> TestTree) -> String -> [TestName]
  mkTestGroup groupBuilder pattern =
    testsNames (singleOption (TestPattern (Just expr))) $
      testGroup "A"
        [ emptyTest "B"
        , emptyTest "C"
        , emptyTest "D"
        , groupBuilder "E"
          [ emptyTest "F"
          , emptyTest "G"
          , testGroup "XX" []
          , emptyTest "H"
          ]
      ]
   where
    expr = fromMaybe (error $ "Invalid pattern: " ++ pattern) (parseExpr pattern)
  
    testsNames :: OptionSet -> TestTree -> [TestName]
    testsNames {- opts -} {- tree -} =
      foldTestTree
        trivialFold
          { foldSingle = \_opts name _test -> [name]
          , foldGroup = \_opts groupName names -> map ((groupName ++ ".") ++) (concat names)
          }
  
    emptyTest name = testCase name (pure ())
  
  filterTestTree :: HasCallStack => String -> [TestName]
  filterTestTree = mkTestGroup (\name -> dependentTestGroup name AllFinish)
  
  filterForOrderedTestGroups :: HasCallStack => String -> [TestName]
  filterForOrderedTestGroups = mkTestGroup inOrderTestGroup
  
  -- | Dependencies should account for empty test groups
  emptySeq :: SimpleTestTree () ()
  emptySeq = Dependently () [Test (), Dependently () [], Test ()]
  
  -- | Whether to generate unique labels in 'labelTree'. 'dependentTestGroup' should work
  -- properly, even if there are name collisions in the test tree.
  newtype GenUniqueLabels = GenUniqueLabels Bool
    deriving Show
  
  instance Q.Arbitrary GenUniqueLabels where
    arbitrary = coerce (Q.arbitrary @Bool)
    shrink = coerce (Q.shrink @Bool)
  
  -- | Range composed from a lower bound up to and including an upper bound
  type Range a = (a, a)
  
  -- | Is given element in range?
  inRange :: Ord a => Range a -> a -> Bool
  inRange (lower, upper) a = a >= lower && a <= upper
  
  -- | Extract a range from any constructor of 'SimpleTestTree'
  getRange :: SimpleTestTree (Range Word) Word -> Range Word
  getRange tree = case tree of
    InParallel r _ -> r
    Dependently r _ -> r
    Test n -> (n, n)
  
  -- | Simplified version of Tasty's TestTree. Used to generate test cases for
  -- 'dependentTestGroup'.
  data SimpleTestTree n l
    = InParallel n [SimpleTestTree n l]
    | Dependently n [SimpleTestTree n l]
    | Test l
    deriving (Show, Eq, Ord, Generic, Foldable)
  
  -- | Attach a unique label to each test. Trees are labeled left-to-right in
  -- ascending order. Each node contains a range, which indicates what words
  -- are stored in the leafs corresponding to that node.
  labelTree :: SimpleTestTree () () -> SimpleTestTree (Range Word) Word
  labelTree = snd . go 0
   where
    go n0 = \case
      Test () -> (n0 + 1, Test n0)
  
      InParallel () ts0 ->
        let
          (n1, ts1) = mapAccumL go n0 ts0
        in
          (n1, InParallel (n0, n1-1) ts1)
  
      Dependently () ts0 ->
        let
          (n1, ts1) = mapAccumL go n0 ts0
        in
          (n1, Dependently (n0, n1-1) ts1)
  
  -- | Generates a 'SimpleTestTree' with arbitrary branches with 'InParallel' and
  -- 'Dependently'. The generated test tree is at most 5 levels deep, and each
  -- level generates smaller and smaller 'InParallel' lists. This prevents trees
  -- from growing incredibly large.
  instance Q.Arbitrary (SimpleTestTree () ()) where
    arbitrary = Q.sized (go . min 5)
     where
      go n = do
        if n <= 0 then
          pure (Test ())
        else
          Q.frequency
            [ (1, InParallel () <$> (take n <$> Q.listOf (go (n-1))))
            , (1, Dependently () <$> (take n <$> Q.listOf (go (n-1))))
            , (1, pure (Test ()))
            ]
  
    shrink = Q.genericShrink
  
  -- | Run a simple test tree (see 'toTestTree' for more information) in a separate
  -- Tasty "session" to not pollute the test report. Marked unsafe as it uses
  -- 'unsafePerformIO' - which makes it possible to run with 'Q.testProperty'.
  unsafeRunTest :: GenUniqueLabels -> SimpleTestTree () () -> ()
  unsafeRunTest genUniqueLabels testTree0 = unsafePerformIO $ do
    results <- launchTestTree (singleOption nUM_THREADS) testTree1 $ \smap -> do
      res <- runSMap smap
      pure (const (pure res))
  
    forM_ results $ \Result{resultOutcome}->
      case resultOutcome of
        Success -> pure ()
        Failure reason -> assertFailure (show reason)
   where
    testTree1 :: TestTree
    testTree1 = toTestTree genUniqueLabels (labelTree testTree0)
  {-# NOINLINE unsafeRunTest #-}
  
  -- | Constructs a 'TestTree' from a 'SimpleTestTree'. 'testGroup' is used to
  -- construct parallel test cases in 'InParallel'. Dependent test cases are
  -- constructed using 'dependenttestGroup' in 'Dependently'. A 'Test' prepends its
  -- label to a list shared between all tests. Finally, 'checkResult' is used
  -- to check whether the labels were prepended in a sensible order.
  toTestTree :: GenUniqueLabels -> SimpleTestTree (Range Word) Word -> TestTree
  toTestTree (GenUniqueLabels genUniqueLabels) tree =
    withResource (newMVar []) (const (pure ())) $ \mVar ->
      dependentTestGroup "Seq" AllSucceed [go tree mVar, checkResult tree mVar]
   where
    go :: SimpleTestTree n Word -> IO (MVar [Word]) -> TestTree
    go tree mVarIO = case tree of
      InParallel _ stts ->
        testGroup "Par" (map (`go` mVarIO) stts)
  
      Dependently _ ts ->
        dependentTestGroup "Seq" AllSucceed (map (`go` mVarIO) ts)
  
      Test n -> do
        -- Caller might opt to not generate unique labels for each test: 
        -- sequentialTestGroup should still function properly in face of name collisions.
        let label = if genUniqueLabels then "T" ++ show n else "T"
  
        testCase label $ do
          -- Induce a (very) small delay to make sure tests finish in a chaotic
          -- order when executed in parallel.
          smallDelay <- (`mod` 100) <$> randomIO
          threadDelay smallDelay
  
          mVar <- mVarIO
          modifyMVar_ mVar (\ns -> pure $ n:ns)
  
  -- | Checks whether all test cases wrote their labels in the order imposed by
  -- the given 'SimpleTestTree'. The invariant that should hold is: given any
  -- @Dependently t1 t2@, all labels associated with @t1@ should appear _later_
  -- in the word-list than all labels associated with @t2@.
  checkResult :: SimpleTestTree (Range Word) Word -> IO (MVar [Word]) -> TestTree
  checkResult fullTree resultM =
    testCase "checkResult" (resultM >>= takeMVar >>= go fullTree)
   where
    go :: SimpleTestTree (Range Word) Word -> [Word] -> Assertion
    go tree result0 = case tree of
      InParallel _ ts ->
        mapM_ (`go` result0) ts
  
      Dependently r (reverse -> trees) -> do
        let
          -- Parallel execution might "pollute" the result list with tests that are
          -- not in any of the trees in 'trees'.
          result1 = filter (inRange r) result0
  
          -- Note that 'result' is preprended during test execution, so tests that
          -- ran last appear first. Hence, we reverse the tree list when matching
          -- on 'Dependently'.
          (_, results) = mapAccumL goResult result1 trees
  
        -- Recurse on all branches; if any element is missing or misplaced, the 'Test'
        -- branch will make sure the test fails.
        zipWithM_ go trees results
  
      Test n ->
        assertBool
          (show n ++ " should be present in " ++ show result0)
          (n `elem` result0)
  
    -- Pop off all the test results beloningn to the given tree, pass along the rest
    goResult :: [Word] -> SimpleTestTree (Range Word) Word -> ([Word], [Word])
    goResult results tree = swap (span (inRange (getRange tree)) results)
  
  
  -- Run with:
  --
  --    ghcid -c cabal repl tasty-core-tests -T DependentTestGroup.main
  --
  -- Add -W if you want to run tests in spite of warnings. Remove 'ghcid -c' if you
  -- do not want to run it automatically on changes.
  --
  main :: IO ()
  main = do
    defaultMain testDependentTestGroup
  