REBOL [
  Title: "Tester"
  Author: ["Henrik Mikael Kristensen"]
  Copyright: "2006 - HMK Design"
  Filename: %tester.r
  Version: 0.0.5
  Created: 03-Feb-2006
  Date: 22-Mar-2006
  License: {
    BSD (www.opensource.org/licenses/bsd-license.php)
    Use at your own risk.
  }
  Purpose: {
    Standardized test system to load REBOL scripts and run functions from them.
    The input and output can be sequenced and recorded for later analysis.
  }
  History: []
]

do-file: func [file [file!]] [
  do to-file either exists? file [file][join "../" file]
]

do-file %list-view.r

; ---------- Testing Functions

; The result output is a block of blocks:

columns: [ID Stage Code Intended Result Status Variables Files Marks Marklist]

results: copy []

testerstyle: stylize [
  lbl: box 180.180.180 300x20 font [
    align: 'left size: 12 shadow: none color: black
  ]
  ar: area font [name: "Terminal" size: 11] edge [size: 1x1] para [wrap?: true]
  fld: field 200x20 font-size 11 edge [size: 1x1]
  clear-btn: button edge [size: 1x1] 20x20 "X"
]

area-redrag: func [face face2] [
  face/redrag face2/size/y / max 1 second size-text face2
  show face
]

test: func [
  entries
  /local marklist error monitor-obj monitor-files code run-error val stage
] [
  mark: func [
    id /prb value
  ][
    append/only marklist reduce [id either prb [mold :value :value]["-"]]
    mold :value :value
  ]
  ; the test code should return TRUE
  run-error: error? try [do to-file config/test-code]
  func-list/data: first system/words
  func-list/update
  results: copy []
  stage: none
  repeat i length? entries [
    monitor-files: copy monitor-obj: copy []
    error-obj: none
    code: remove head remove back tail mold/all second entries/:i
    stage: entries/:i/1
    intended: entries/:i/3
    marklist: copy []
    error: none
    attempt [error: try [do entries/:i/2]]
    either error? error [
      ; monitoring variables
      foreach v watch-list/data [
        val: do first v
        append/only monitor-obj reduce [
          to-string first v
          type? val
          switch/default type? val [
            series! [length? val]
            port! [length? val]
            tuple! [length? val]
            bitset! [length? val]
            struct! [length? val]
          ]["-"]
          mold do first v
        ]
      ]
      error-obj: disarm error
      append/only results reduce [
        i
        stage
        code
        intended
        error-obj
        "Error"
        monitor-obj
        monitor-files
        length? marklist
        marklist
      ]
    ][
      ; translating error return variable to useful results
yy: get 'error
      error: switch type? get 'error [
        function! [mold get 'error]
      ][error]
      ; monitoring variables
      foreach v watch-list/data [
        val: do first v
        append/only monitor-obj reduce [
          to-string first v
          type? val
          switch/default type? val [
            series! [length? val]
            port! [length? val]
            tuple! [length? val]
            bitset! [length? val]
            struct! [length? val]
          ]["-"]
          mold do first v
        ]
      ]
      append/only results reduce [
        i
        stage
        code
        intended
        error
        "OK"
        monitor-obj
        monitor-files
        length? marklist
        marklist
      ]
    ]
  ]
;  if run-error [
;    alert mold run-error
;  ]
]

; ---------- Writing out Data

variable-list: layout [
  styles testerstyle
  space 2 origin 4
  watch-list: list-view with [
    data-columns: [Name]
    editable?: true
    finish-edit-action: [save-settings]
  ]
  panel [
    across space 2
    btn "Add" [watch-list/append-row watch-list/show-edit]
    btn "Remove" [watch-list/remove-row]
    btn "Close" [unview variable-list]
  ]
]

file-list: layout [
  styles testerstyle
  space 0 origin 4 across
  lbl "Base Path" 75 base-path: fld 225 return
  watch-file-list: list-view 300x300 with [
    data-columns: [File]
    editable?: true
    finish-edit-action: [save-settings]
  ] return
  panel [
    origin 0x2 across space 2
    btn "Add" [watch-file-list/append-row file-list/show-edit]
    btn "Remove" [watch-file-list/remove-row]
    btn "Close" [unview file-list]
  ]
]

variable-viewer: func [var /text txt /local t] [
  t: either text [txt]["No description"]
  view/new/title layout [
    styles testerstyle
    origin 4 space 0 across
    btn "Next" [
      result-list/next-cnt do result-list/list-action
      set-face first back back tail face/parent-face/pane get-face var
      area-redrag variable-data-scroller variable-data
    ] pad 2
    btn "Previous" [
      result-list/prev-cnt do result-list/list-action
      set-face first back back tail face/parent-face/pane get-face var
      area-redrag variable-data-scroller variable-data
    ] h4 t return
    pad 0x2 return
    variable-data: ar 500x500 (get-face var)
    variable-data-scroller: scroller 20x500 [
      scroll-para variable-data variable-data-scroller
    ]
  ] "Variable Viewer"
]

intended-results: copy [
  "Ignore" "TRUE" "FALSE" "NONE" "Not Error!" "Error!"
]

test-list: layout [
  styles testerstyle
  space 0 origin 4 across
  code-list: list-view 500x400 with [
    data-columns: [Stage Entry Intended]
    widths: [40 100 75]
    resize-column: 'entry
    list-action: [
      either any [empty? data not get-row] [
        clear-face code-area
        limit-sel-cnt
      ][
        limit-sel-cnt
        set-face code-area get-cell 'entry
        set-face intended-result-pnl foreach i intended-results [
          append [] either i = get-cell 'intended [true][none]
        ]
      ]
      focus code-area
      row-action: [
        cells/stage/color: either stage [stage][white]
        cells/stage/text: none
      ]
    ]
  ]
  panel [
    space 0 across
    lbl "Stage Colors" return
    btn 20x20 black [code-list/change-cell 'stage second face/effect]
    btn 20x20 red [code-list/change-cell 'stage second face/effect]
    btn 20x20 blue [code-list/change-cell 'stage second face/effect]
    btn 20x20 green [code-list/change-cell 'stage second face/effect]
    btn 20x20 yellow [code-list/change-cell 'stage second face/effect]
    btn 20x20 pink [code-list/change-cell 'stage second face/effect]
    btn 20x20 gray [code-list/change-cell 'stage second face/effect] return
    lbl "Code" return
    code-area: ar 280x260 [
      code-list/change-cell 'entry reduce [get-face face]
      code-list/update
      save-settings
    ]
    scroll-code-area: scroller 20x300 [scroll-para code-area scroll-code-area]
    return
    lbl "Intended Result" return
    intended-result-pnl: panel [
      style tgl tog [
        code-list/change-cell 'intended face/text save-settings
      ] of 'intended
      origin 2 space 1 across
      tgl intended-results/1 true
      tgl intended-results/2
      tgl intended-results/3
      tgl intended-results/4
      tgl intended-results/5
      tgl intended-results/6
    ]
  ] return
  panel [
    origin 0x2 across space 2
    btn "Add" [
      code-list/append-row do code-list/list-action
      do code-list/list-action
      focus code-area
      save-settings
    ]
    btn "Insert" [
      code-list/insert-row do code-list/list-action
      do code-list/list-action
      focus code-area
      save-settings
    ]
    btn "Remove" [
      code-list/remove-row do code-list/list-action
      do code-list/list-action
      save-settings
    ]
    btn "Copy" [
      code-list/append-row/values code-list/get-row
      do code-list/list-action
      save-settings
    ]
    pad 5
    btn "Up" [
      code-list/move-row-up
      save-settings
    ]
    btn "Down" [
      code-list/move-row-down
      save-settings
    ]
    pad 5
    btn "Close" [unview test-list]
  ]
]

function-list: layout [
  styles testerstyle
  space 0 origin 4 across
  lbl 130 right "Search" func-search-fld: fld 150 [
    func-list/set-filter value
    func-list/first-cnt
    do func-list/list-action
    focus face
  ] clear-btn [clear-face func-search-fld do-face func-search-fld none]
  lbl "Source Code" 500 return
  func-list: list-view 300x400 with [
    data-columns: [Functions]
    data: first system/words
    list-action: [
      either any [empty? data not get-row] [
        clear-face func-area
        limit-sel-cnt
      ][
        limit-sel-cnt
        word: to-word get-row
        set-face func-area
        either not value? word ["undefined"][
          either any [native? get word op? get word action? get word] [
            reform ["native" mold third get word]
          ] [mold get word]
        ]
      ]
    ]
  ]
  func-area: ar 500x400 font-size 11 para [wrap?: true] return
]

result-pos: 0

main: layout [
  styles testerstyle
  space 2 origin 4 across
  panel [
    across space 2
    btn green "Run Test" [
      result-pos: result-list/sel-cnt
      if not empty? code-list/data [
        test code-list/data
        result-list/data: copy results
        result-list/update
;        result-list/first-cnt
        result-list/sel-cnt: result-pos
        result-list/limit-sel-cnt
        result-list/follow
        do result-list/list-action
      ]
    ]
  ]
  panel [
    across space 2
    btn "Watch..." [
      view/new/title center-face variable-list "Watch Variables"
      watch-list/update
    ]
    btn "File Watch..." [
      view/new/title center-face file-list "Watch Files"
      watch-file-list/update
    ]
    btn "Tests..." [
      view/new/title center-face test-list "Test List"
      code-list/update
    ]
    btn "Functions..." [
      view/new/title center-face function-list "Functions List"
      func-list/update
    ]
    pad 5
    btn "Test Code..." [
      f: request-file
      if f [
        set-face test-code-fld first f
        do-face test-code-fld none
      ]
    ]
    test-code-fld: fld 250x22 [
      either not exists? to-file config/test-code: get-face face [
        face/color: red
      ][face/color: white save-settings]
    ]
    pad 5
    btn "Copy Entry" [write clipboard:// mold result-list/get-row]
  ]
  btn "Console" [halt]
  btn "Quit" [unview/all]
  return
  panel [
    space 0
    result-list: list-view 600x600 with [
      data-columns: columns
      spacing: 1x0
      viewed-columns: [Stage ID Code Intended Marks Status]
      resize-column: 'Code
      widths: [40 40 100 75 50 50]
      data: copy results
      list-action: [
        if not empty? data [
          set-face detail-code get-cell 'code
          area-redrag detail-code-scroller detail-code
          set-face detail-result get-cell 'result
          area-redrag detail-result-scroller detail-result
          set-face detail-status get-cell 'status
          detail-watch/data: get-cell 'variables
          detail-watch/update
          detail-marks/data: get-cell 'marklist
          detail-marks/update
        ]
      ]
      doubleclick-list-action: [
        view/new/title center-face test-list "Test List"
        code-list/update
        code-list/sel-cnt: result-list/sel-cnt
        code-list/follow
        do code-list/list-action
      ]
      row-action: [
        cell/font/color: switch/default status [
          "OK" [0.80.0]
          "Error" [red]
        ][black]
        cell/font/style: either status = "Error" ['bold][none]
        cells/stage/color: either stage [stage][white]
        cells/stage/text: none
      ]
    ] return
    details: panel [
      style copy-btn button
        edge [size: 1x1] 40x20 "Copy"
        font [size: 11 color: 0.0.0]
      style full-btn copy-btn "Full" 30
      space 0 across
      lbl "Testcode" 230 full-btn [
        variable-viewer detail-code
        area-redrag variable-data-scroller variable-data
      ] copy-btn [
        write clipboard:// get-face detail-code
      ] return
      detail-code: ar 280x55
      detail-code-scroller: scroller 20x55 [
        scroll-para detail-code detail-code-scroller
      ]
      return
      lbl "Result" 230 full-btn [
        variable-viewer detail-result
        area-redrag variable-data-scroller variable-data
      ] copy-btn [
        write clipboard:// get-face detail-result
      ] return
      detail-result: ar 280x125 para [wrap?: true]
      detail-result-scroller: scroller 20x125 [
        scroll-para detail-result detail-result-scroller
      ]
      return
      lbl "Status" 50 detail-status: fld 250x20 return
      lbl "Watched Variables" 230 full-btn copy-btn [
        write clipboard:// get-face detail-watch
      ] return
      detail-watch: list-view 300x180 with [
        data-columns: [Name Type Length Contents]
        widths: [100 50 50 100]
        resize-column: 'contents
        spacing: 1x0
        doubleclick-list-action: [
          view/new/title layout [
            styles testerstyle
            space 2 origin 4 across
            h3 (join "Name:" get-cell 'name) pad 20
            h3 (join "Type:" get-cell 'type) pad 20
            h3 (join "Length:" get-cell 'length) return
            ar (get-cell 'contents) 500x700 font-size 11
          ] "Watched Variable"
        ]
      ] return
      lbl "Function Marks" 230 full-btn copy-btn [
        write clipboard:// get-face detail-marks
      ] return
      detail-marks: list-view 300x140 with [
        data-columns: [Mark Probed]
        widths: [40 100]
        resize-column: 'probed
        spacing: 1x0
        doubleclick-list-action: [
          view/new/title layout [
            space 2 origin 4
            styles testerstyle
            h3 (join "Mark:" get-cell 'mark)
            ar (mold get-cell 'probed) 500x700 font-size 11
          ] "Marked Variable"
        ]
      ]
    ]
  ] return
  panel [
    space 2 across
    btn "Go up" 60 [
      result-list/prev-cnt
      do result-list/list-action
    ]
    btn "Go down" 60 [
      result-list/next-cnt
      do result-list/list-action
    ]
    btn "Next Error" 90 [
      do result-list/list-action
    ]
    btn "Previous Error" 90 [
      do result-list/list-action
    ]
  ]
]

; ---------- Settings

config: make object! [
  test-code: none
  entries: copy []
  watch: copy []
  config-file: %tester-cfg.r
]

code-list/data: config/entries
watch-list/data: config/watch

save-settings: does [write/binary config/config-file mold/all config]

load-settings: does [
  either exists? config/config-file [config: load to-file config/config-file
  ][save-settings config/config-file]
  code-list/data: config/entries
  watch-list/data: config/watch
  set-face test-code-fld config/test-code
]

delete-settings: does [delete config/config-file]

load-settings

;yk: copy config/entries
;ik: copy []

;forall yk [
;  append/only ik probe copy reduce ['none first first yk "Ignore"]
;]
;probe ik

;config/entries: copy ik
;save-settings
view/new/title center-face main "Tester"
area-redrag detail-result-scroller detail-result
area-redrag detail-code-scroller detail-code
do-events
;write/binary %testresults mold results