0 | module Test.Golden.RunnerHelper
  1 |
  2 | import Data.Maybe
  3 | import Data.String
  4 |
  5 | import public Language.Reflection
  6 |
  7 | import public Test.Golden
  8 |
  9 | import System
 10 | import System.Directory
 11 |
 12 | --- Configuration facilities ---
 13 |
 14 | public export
 15 | record BuildDir where
 16 |   constructor MkBuildDir
 17 |   buildDir : String
 18 |
 19 | ||| Determines which string will be passed as the first argument
 20 | ||| to the `run` script of each test.
 21 | public export
 22 | interface RunScriptArg where
 23 |   constructor MkRunScriptArg
 24 |   runScriptArg : BuildDir => String
 25 |
 26 | ||| When no default argument is given, is passes a filename for "pack lock",
 27 | ||| a file to be locked over when running `pack -q install-deps test.ipkg` using `flock`.
 28 | ||| This is most useful when testing libraries, when only `pack` or `idris2` commands are used in tests.
 29 | public export
 30 | %defaulthint
 31 | DefaultRunScriptArg : RunScriptArg
 32 | DefaultRunScriptArg = R where
 33 |   [R] RunScriptArg where
 34 |     runScriptArg = buildDir %search ++ "/.pack_lock"
 35 |
 36 | --- Options management ---
 37 |
 38 | nproc : IO $ Maybe Nat
 39 | nproc = do
 40 |   rawThreads <- getEnv "NUM_THREADS"
 41 |   let Nothing = rawThreads >>= parsePositive
 42 |     | Just n => pure $ Just n
 43 |   (str, 0) <- run "nproc"
 44 |     | _ => pure Nothing
 45 |   pure $ parsePositive str
 46 |
 47 | nproc' : IO Nat
 48 | nproc' = fromMaybe 1 . filter (> 0) <$> nproc
 49 |
 50 | fitsPattern : (pattern, test : String) -> Bool
 51 | fitsPattern = isInfixOf
 52 |
 53 | testOptions : RunScriptArg => BuildDir => IO Options
 54 | testOptions = do
 55 |   onlies <- filter (not . null) . tail' <$> getArgs
 56 |   pure $
 57 |     { color := isNothing !(getEnv "NO_COLOR")
 58 |     , timing := True
 59 |     , interactive := !((Just "true" /=) <$> getEnv "CI")
 60 |     , failureFile := Just "failures"
 61 |     , onlyNames := onlies <&> \patterns, test => any (`fitsPattern` test) patterns
 62 |     , threads := !nproc'
 63 |     } (initOptions runScriptArg True)
 64 |
 65 | --- A universal way to set test pools from different origins ---
 66 |
 67 | export
 68 | interface TestPoolLike a where
 69 |   toTestPool : a -> IO $ List TestPool
 70 |
 71 | export
 72 | TestPoolLike (IO TestPool) where
 73 |   toTestPool = map pure
 74 |
 75 | export
 76 | TestPoolLike TestPool where
 77 |   toTestPool = pure @{Compose}
 78 |
 79 | export
 80 | TestPoolLike (List TestPool) where
 81 |   toTestPool = pure
 82 |
 83 | export
 84 | TestPoolLike (IO $ List TestPool) where
 85 |   toTestPool = id
 86 |
 87 | export
 88 | TestPoolLike (List $ IO TestPool) where
 89 |   toTestPool = sequence
 90 |
 91 | export
 92 | data TestPools = MkTestPools (IO $ List TestPool)
 93 |
 94 | namespace TestPools
 95 |
 96 |   export
 97 |   Nil : TestPools
 98 |   Nil = MkTestPools $ pure []
 99 |
100 |   export
101 |   (::) : TestPoolLike a => a -> TestPools -> TestPools
102 |   x :: MkTestPools xs = MkTestPools [| toTestPool x ++ xs |]
103 |
104 |   export
105 |   (++) : TestPools -> TestPools -> TestPools
106 |   MkTestPools xs ++ MkTestPools ys = MkTestPools [| xs ++ ys |]
107 |
108 | toList : TestPools -> IO $ List TestPool
109 | toList $ MkTestPools xs = xs
110 |
111 | --- Facilities for user's convenience ---
112 |
113 | export
114 | atDir : (poolName : String) -> (dir : String) -> IO TestPool
115 | atDir poolName dir = do
116 |   True <- exists dir
117 |     | False => emptyPool
118 |   Right (_::_) <- listDir dir
119 |     | _ => emptyPool
120 |   testsInDir dir poolName {pred=not . isPrefixOf "_"}
121 |
122 |   where
123 |     emptyPool : IO TestPool
124 |     emptyPool = pure $ MkTestPool poolName [] Nothing []
125 |
126 | --- Toplevel running ---
127 |
128 | export
129 | goldenRunner' : RunScriptArg => (projectDir, buildDir : String) -> TestPools -> IO ()
130 | goldenRunner' projectDir buildDir tps = do
131 |   let _ = MkBuildDir buildDir
132 |   ignore $ changeDir projectDir
133 |   runnerWith !testOptions !(toList tps)
134 |
135 | export %macro
136 | goldenRunner : RunScriptArg => TestPools -> Elab $ IO ()
137 | goldenRunner tps = pure $ goldenRunner' !(idrisDir ProjectDir) !(idrisDir BuildDir) tps
138 |