shrub/pkg/arvo/ted/test.hoon

/-  spider
/+  strandio
=,  strand=strand:spider
=>
|%
::  $test: a test with a fully resolved path
::  $test-arm: test with name (derived from its arm name in a test core)
::  $test-func: single test, as gate; sample is entropy, produces failures
::
+$  test       [=beam func=test-func]
+$  test-arm   [name=term func=test-func]
+$  test-func  (trap tang)
+$  args       quiet=?
--
=>
|_  =args
++  build-file
  |=  =beam
  =/  m  (strand ,[(unit vase) tang])
  ^-  form:m
  ;<  res=(unit vase)  bind:m
    (build-file:strandio beam)
  %+  pure:m  res
  ?.  =(res ~)
    ~
  ~[leaf+"FAILED"]
  ::  +run-test: execute an individual test
::
++  run-test
  |=  [bem=beam test=test-func]
  ^-  [ok=? =tang]
  =+  run=(mule test)
  ?-  -.run
    %|  |+p.run
    %&  ?:  =(~ p.run)
          &+~
        |+(flop `tang`[leaf+"FAILED" p.run])
  ==
::  +resolve-test-paths: add test names to file paths to form full identifiers
::
++  resolve-test-paths
  |=  paths-to-tests=(map beam (list test-arm))
  ^-  (list test)
  %-  sort  :_  |=([a=test b=test] !(aor s.beam.a s.beam.b))
  ^-  (list test)
  %-  zing
  %+  turn  ~(tap by paths-to-tests)
  |=  [=beam test-arms=(list test-arm)]
  ^-  (list test)
  ::  for each test, add the test's name to :path
  ::
  %+  turn  test-arms
  |=  =test-arm
  ^-  test
  [beam(s (weld s.beam /[name.test-arm])) func.test-arm]
::  +get-test-arms: convert test arms to functions and produce them
::
++  get-test-arms
  |=  [typ=type cor=*]
  ^-  (list test-arm)
  =/  arms=(list @tas)  (sloe typ)
  %+  turn  (skim arms has-test-prefix)
  |=  name=term
  ^-  test-arm
  =/  fire-arm=nock
    ~|  [%failed-to-compile-test-arm name]
    q:(~(mint ut typ) p:!>(*tang) [%limb name])
  [name |.(;;(tang ?:(quiet.args .*(cor fire-arm) ~>(%bout.[1 name] .*(cor fire-arm)))))]
::  +has-test-prefix: does the arm define a test we should run?
::
++  has-test-prefix
  |=  a=term  ^-  ?
  =((end [3 5] a) 'test-')
::
++  find-test-files
  =|  fiz=(set [=beam test=(unit term)])
  =/  m  (strand ,_fiz)
  |=  bez=(list beam)
  ^-  form:m
  =*  loop  $
  ?~  bez
    (pure:m fiz)
  ;<  hav=?  bind:m  (check-for-file:strandio -.i.bez (snoc s.i.bez %hoon))
  ?:  hav
    loop(bez t.bez, fiz (~(put in fiz) [i.bez(s (snoc s.i.bez %hoon)) ~]))
  ;<  fez=(list path)  bind:m  (list-tree:strandio i.bez)
  ?.  =(~ fez)
    =/  foz
      %+  murn  fez
      |=  p=path
      ?.  =(%hoon (rear p))  ~
      (some [[-.i.bez p] ~])
    loop(bez t.bez, fiz (~(gas in fiz) foz))
  ::
  ::  XX this logic appears to be vestigial
  ::
  =/  tex=term
    ~|  bad-test-beam+i.bez
    =-(?>(((sane %tas) -) -) (rear s.i.bez))
  =/  xup=path  (snip s.i.bez)
  ;<  hov=?  bind:m  (check-for-file:strandio i.bez(s (snoc xup %hoon)))
  ?.  hov
    ~|(no-tests-at-path+i.bez !!)
  loop(bez t.bez, fiz (~(put in fiz) [[-.i.bez (snoc xup %hoon)] `tex]))
++  print-failures
  |=  ls=(list [=beam =tang])
  ^+  same
  ?~  ls
    same
  =/  =tank
    [%rose ["\0a" "/={(trip q.beam.i.ls)}={(spud s.beam.i.ls)}:\0a" ""] tang.i.ls]
  ~>  %slog.[3 tank]
  $(ls t.ls)
--
^-  thread:spider
|=  arg=vase
=/  m  (strand ,vase)
^-  form:m
;<  =bowl:strand  bind:m  get-bowl:strandio
=/  [quiet=? paz=(list path)]
  ::  if no args, test everything under /=base=/tests
  ::
  =*  default-tests
    ~[/(scot %p our.bowl)/[q.byk.bowl]/(scot %da now.bowl)/tests]
  ?+  q.arg  !!
    ~                                                   [& default-tests]
    [~ ?]      =+  !<([~ quiet=?] arg)                  [quiet default-tests]
    [~ ? ^ *]  =+  !<([~ quiet=? paz=(list path)] arg)  [quiet paz]
    [~ ? ^]    =+  !<([~ quiet=? pax=path] arg)         [quiet pax ~]
    [~ ^ *]    =+  !<([~ paz=(list path)] arg)          [& paz]
    [~ *]      =+  !<([~ pax=path] arg)                 [& pax ~]
  ==
=.  quiet.args  quiet
=/  bez=(list beam)
  (turn paz |=(p=path ~|([%test-not-beam p] (need (de-beam p)))))
;<  fiz=(set [=beam test=(unit term)])  bind:m  (find-test-files bez)
=>  .(fiz (sort ~(tap in fiz) aor))
=|  test-arms=(map beam (list test-arm))
=|  build-failed=(list [beam tang])
|-  ^-  form:m
=*  gather-tests  $
?^  fiz
  ;<  [cor=(unit vase) =tang]  bind:m  (build-file beam.i.fiz)
  ?~  cor
    gather-tests(fiz t.fiz, build-failed [[beam.i.fiz tang] build-failed])
  =/  arms=(list test-arm)  (get-test-arms u.cor)
  ::  if test path specified an arm prefix, filter arms to match
  =?  arms  ?=(^ test.i.fiz)
    %+  skim  arms
    |=  test-arm
    =((end [3 (met 3 u.test.i.fiz)] name) u.test.i.fiz)
  =.  test-arms  (~(put by test-arms) beam.i.fiz(s (snip s.beam.i.fiz)) arms)
  gather-tests(fiz t.fiz)
=;  res=_build-failed
  %-  (print-failures res)
  %-  pure:m  !>  ^=  failed
  %+  turn  res
  |=  [=beam *]
  beam
%+  roll  (resolve-test-paths test-arms)
|=  [[=beam =test-func] failed=_build-failed]
^+  failed
=/  res  (run-test beam test-func)
?:  -.res
  failed
:_  failed
[beam +.res]