[ base,tests ] Reduce dependency on contrib (#1595)

libs/test/Test/Golden.idr

@@ -82,9 +82,10 @@ import Data.String
 import System
 import System.Clock
 import System.Directory
-import System.Future
+import System.File
 import System.Info
 import System.Path
+import System.Concurrency
 
 -- [ Options ]
 
@@ -199,8 +200,8 @@ Result = Either String String
 ||| See the module documentation for more information.
 ||| @testPath the directory that contains the test.
 export
-runTest : Options -> (testPath : String) -> IO (Future Result)
-runTest opts testPath = forkIO $ do
+runTest : Options -> (testPath : String) -> IO Result
+runTest opts testPath = do
   start <- clockTime UTC
   let cg = maybe "" (" --cg " ++) (codegen opts)
   let exe = "\"" ++ exeUnderTest opts ++ cg ++ "\""
@@ -423,14 +424,24 @@ record Summary where
   success : List String
   failure : List String
 
+||| A new, blank summary
 export
 initSummary : Summary
 initSummary = MkSummary [] []
 
+||| Update the summary to contain the given result
 export
-updateSummary : List Result -> Summary -> Summary
-updateSummary res =
-  let (ls, ws) = partitionEithers res in
+updateSummary : (newRes : Result) -> Summary -> Summary
+updateSummary newRes =
+  case newRes of
+       Left l  => { failure $= (l ::) }
+       Right w => { success $= (w ::) }
+
+||| Update the summary to contain the given results
+export
+bulkUpdateSummary : (newRess : List Result) -> Summary -> Summary
+bulkUpdateSummary newRess =
+  let (ls, ws) = partitionEithers newRess in
   { success $= (ws ++)
   , failure $= (ls ++)
   }
@@ -444,7 +455,79 @@ export
 Monoid Summary where
   neutral = initSummary
 
-||| A runner for a test pool
+||| An instruction to a thread which runs tests
+public export
+data ThreadInstruction : Type where
+  ||| A test to run
+  Run : (test : String) -> ThreadInstruction
+  ||| An indication for the thread to stop
+  Stop : ThreadInstruction
+
+||| Sends the given tests on the given @Channel@, then sends `nThreads` many
+||| 'Stop' @ThreadInstruction@s to stop the threads running the tests.
+|||
+||| @testChan The channel to send the tests over.
+||| @nThreads The number of threads being used to run the tests.
+||| @tests The list of tests to send to the runners/threads.
+export
+testSender : (testChan : Channel ThreadInstruction) -> (nThreads : Nat)
+           -> (tests : List String) -> IO ()
+testSender testChan 0 [] = pure ()
+testSender testChan (S k) [] =
+  -- out of tests, so the next thing for all the threads is to stop
+  do channelPut testChan Stop
+     testSender testChan k []
+testSender testChan nThreads (test :: tests) =
+  do channelPut testChan (Run test)
+     testSender testChan nThreads tests
+
+||| A result from a test-runner/thread
+public export
+data ThreadResult : Type where
+  ||| The result of running a test
+  Res : (res : Result) -> ThreadResult
+  ||| An indication that the thread was told to stop
+  Done : ThreadResult
+
+||| Receives results on the given @Channel@, accumulating them as a @Summary@.
+||| When all results have been received (i.e. @nThreads@ many 'Done'
+||| @ThreadInstruction@s have been encountered), send the resulting Summary over
+||| the @accChan@ Channel (necessary to be able to @fork@ this function and
+||| still obtain the Summary at the end).
+|||
+||| @resChan The channel to receives the results on.
+||| @acc The Summary acting as an accumulator.
+||| @accChan The Channel to send the final Summary over.
+||| @nThreads The number of threads being used to run the tests.
+export
+testReceiver : (resChan : Channel ThreadResult) -> (acc : Summary)
+             -> (accChan : Channel Summary) -> (nThreads : Nat) -> IO ()
+testReceiver resChan acc accChan 0 = channelPut accChan acc
+testReceiver resChan acc accChan nThreads@(S k) =
+  do (Res res) <- channelGet resChan
+        | Done => testReceiver resChan acc accChan k
+     testReceiver resChan (updateSummary res acc) accChan nThreads
+
+||| Function responsible for receiving and running tests.
+|||
+||| @opts The options to run the threads under.
+||| @testChan The Channel to receive tests on.
+||| @resChan The Channel to send results over.
+testThread : (opts : Options) -> (testChan : Channel ThreadInstruction)
+              -> (resChan : Channel ThreadResult) -> IO ()
+testThread opts testChan resChan =
+  do (Run test) <- channelGet testChan
+        | Stop => channelPut resChan Done
+     res <- runTest opts test
+     channelPut resChan (Res res)
+     testThread opts testChan resChan
+
+||| A runner for a test pool. If there are tests in the @TestPool@ that we want
+||| to run, spawns `opts.threads` many runners and sends them the tests,
+||| collecting all the results in the @Summary@ returned at the end.
+|||
+||| @opts The options for the TestPool.
+||| @pool The TestPool to run.
 export
 poolRunner : Options -> TestPool -> IO Summary
 poolRunner opts pool
@@ -471,8 +554,23 @@ poolRunner opts pool
                     Nothing => { codegen := Nothing } opts
                     Just cg => { codegen := Just (show @{CG} cg) } opts
                     Default => opts
-       -- if so run them all!
-       loop opts initSummary tests
+
+       -- set up the channels
+       accChan <- makeChannel
+       resChan <- makeChannel
+       testChan <- makeChannel
+
+       -- and then run all the tests
+
+       for_ (replicate opts.threads 0) $ \_ =>
+         fork (testThread opts testChan resChan)
+       -- start sending tests
+       senderTID <- fork $ testSender testChan opts.threads tests
+       -- start receiving results
+       receiverTID <- fork $ testReceiver resChan initSummary accChan opts.threads
+       -- wait until things are done, i.e. until we receive the final acc
+       acc <- channelGet accChan
+       pure acc
 
   where
 
@@ -485,14 +583,6 @@ poolRunner opts pool
        ++ msgs
        ++ [ separator ]
 
-    loop : Options -> Summary -> List String -> IO Summary
-    loop opts acc [] = pure acc
-    loop opts acc tests
-      = do let (now, later) = splitAt opts.threads tests
-           bs <- map await <$> traverse (runTest opts) now
-           loop opts (updateSummary bs acc) later
-
-
 ||| A runner for a whole test suite
 export
 runner : List TestPool -> IO ()

libs/test/test.ipkg

@@ -1,9 +1,6 @@
 package test
 version = 0.5.1
 
-depends = contrib
-
 opts = "--ignore-missing-ipkg"
 
 modules = Test.Golden
-