| View discussion [54 posts] | View script | License |
| Download script | History | Other scripts by: luce80 |
30-Apr 22:04 UTC
[0.102] 22.952k
[0.102] 22.952k
 | Archive version of: mini-edit-do.r ... version: 7 ... luce80 3-Jun-2012Amendment note: Fixed bug when deleting all || Publicly available? Yes REBOL [
title: "Mini-edit-do"
file: %mini-edit-do.r
author: "Marco Antoniazzi"
Copyright: "(C) 2012 Marco Antoniazzi. All Rights reserved"
email: [luce80 AT libero DOT it]
date: 03-06-2012
version: 0.5.6
Purpose: "Helps test short programs (substitutes console)"
History: [
0.0.1 [30-04-2012 "First version"]
0.5.1 [01-05-2012 "Fixed using view and quit"]
0.5.2 [05-05-2012 "Added undo and redo"]
0.5.3 [10-05-2012 "Fixed last probe"]
0.5.4 [12-05-2012 "Added halt and other minor fixes"]
0.5.5 [20-05-2012 "Fixed error inside prin and script header"]
0.5.6 [03-06-2012 "Fixed bug when deleting all"]
]
comment: {30-Apr-2012 GUI automatically generated by VID_build. Author: Marco Antoniazzi.
Derived directly from ParseAid.r
}
library: [
level: 'intermediate
platform: 'all
type: 'tool
domain: [debug testing]
tested-under: [View 2.7.8.3.1]
support: none
license: 'BSD
see-also: %parse-aid.r
]
todo: {
- ask to save before exit if something modified
- options:
- set max area-results length
- set max dumped obj length
- choose between head or tail of dumped obj
}
]
err?: func [blk /local arg1 arg2 arg3 message err][;11-Feb-2007 Guest2
if not error? set/any 'err try blk [return get/any 'err]
err: disarm err
set [arg1 arg2 arg3] reduce [err/arg1 err/arg2 err/arg3]
message: get err/id
if block? message [bind message 'arg1]
prin* ["**ERROR:" form reduce message newline]
prin* ["**Near:" either block? err/near [mold/only err/near][err/near] newline]
throw
]
; patches
old-length: 0
old-prin: :prin old-print: :print ; use these to output to console
old-probe: func [value] [old-print mold :value :value]
old-quit: :quit
quit: does [
; closing all windows (except ours) is similar to quitting ...
foreach face next System/view/screen-face/pane [unview/only face]
]
halt: does [] ; avoid opening console
prin*: func [value][
set-face/no-show area-results append get-face area-results form reduce value
system/view/vid/vid-feel/move-drag area-results/vscroll/pane/3 1 ; autoscroll down
]
prin: func [value] [
either (100000 + old-length) > length? get-face area-results [ ; avoid fill mem
set-face/no-show area-results append get-face area-results form err? [reduce value]
system/view/vid/vid-feel/move-drag area-results/vscroll/pane/3 1 ; autoscroll down
wait 0.0001 ; avoid blocking the gui
][
alert "ERROR. Probable infinite loop."
reset-face area-results
throw
]
exit ; force unsetting result
]
print: func [value] [prin value prin newline]
probbed: none
probe: func [value] [probbed: get 'value print mold :value :value]
*isolator: context [
func: make function! [
"Defines a user function with given spec and body."
[catch]
spec [block!] {Help string (opt) followed by arg words (and opt type and string)}
body [block!] "The body block of the function"
][
throw-on-error [make function! spec compose/deep [err? [(body)]]]
]
view: func ; taken from "REBOL Word Browser (Dictionary)" Author: "Carl Sassenrath"
first get in system/words 'view
head insert copy/deep second get in system/words 'view [new: true]
]
ctx-text/next-word: func [str /local s ns] [
s: charset " ^-^/^M" ns: complement s
any [all [s: find str s find s ns] tail str]
]
ctx-text/back-word: func [str /local s ns] [
s: charset " ^-^/^M" ns: complement s
any [all [ns: find/tail/reverse str ns ns: find/reverse ns s next ns] head str]
]
;
context [ ; protect our functions from being redefined
; file
change_title: func [/modified] [
clear find/tail main-window/text "- "
either modified [append main-window/text "*" saved?: no][saved?: yes]
append main-window/text to-string last split-path any [job-name %Untitled]
main-window/changes: [text] show main-window
]
open_file: func [/local file-name job] [
until [
file-name: request-file/title/keep/only/filter "Load a rules file" "Load" "*.r"
if none? file-name [exit]
exists? file-name
]
job-name: file-name
job: read file-name
set-face area-test job
clear area-test/ar/undo-list
clear area-test/ar/redo-list
code: copy job
named: yes
change_title
saved?: yes
]
save_file: func [/as /local file-name filt ext response job] [
;if empty? job [return false]
if not named [as: true]
if as [
filt: "*.r"
ext: %.r
file-name: request-file/title/keep/only/filter "Save as Rebol file" "Save" filt
if none? file-name [return false]
if not-equal? suffix? file-name ext [append file-name ext]
response: true
if exists? file-name [response: request rejoin [{File "} last split-path file-name {" already exists, overwrite it?}]]
if response <> true [return false]
job-name: file-name
named: yes
]
flash/with join "Saving to: " job-name main-window
job: get-face area-test
write job-name job
code: copy job
wait 1.3
unview
change_title
saved?: yes
]
; do
test: func [/local text script result temp] [
if get-face check-clear-res [reset-face area-results old-length: 0]
err? [
probbed: none
text: copy get-face area-test
script: attempt [load/header text]
if none? script [script: load text insert script make system/script/header [] ]
system/script/header: script/1 ; replace our header with the script's one
doing: true
set/any 'result do bind script *isolator
doing: false
text: none recycle
old-length: old-length + length? get-face area-results
if not unset? get/any 'result [
if any-function? :result [if not equal? :probbed :result [probe mold :result] exit]
if object? result [
if 10000 < length? temp: mold/only result [result: copy/part temp 10000 append result "..."]
]
if not equal? probbed result [probe result]
]
]
]
; gui
;do %area-scroll-style.r ;Copyright: {GNU Less General Public License (LGPL) - Copyright (C) Didier Cadieu 2004}
do decompress ; %area-scroll-style.r Copyright: {GNU Less General Public License (LGPL) - Copyright (C) Didier Cadieu 2004}
64#{
eJztWUuP4zYSvutXcJ3DJAMoak+CRSBMtg97ySW3RRBAcAdsibK4I0uORLfdu9j8
9v2qiqQk2/3KziKXJEgskvUusuojO9GD0enoHluTK/qx/zKqSGS2HPq2zRUN1NG6
BguHrupzVfVmVIUeMhpuVDKYxSwNMVvbUzq2tjJDuteDzlV96ErIWO36B6O0kjWl
y7IfKtttlTMnp2pr2kqJbkx+vVKJq9VK1nRpMB4xFuZM6CDFL5HuQW/VSrdjr/zA
NUad0RNp25e6VW63J1ucsmOygXW2Vl3fmVvl6ozMVoU5WQd37JjT3EgRSpWptial
byKEibt9rna2U+vTGpJA4NmznR62mJ8m+sHKxOgQckhI2TeSghiNdaZPEAAns0o7
zOz0Sd2I7ChD3MhyrTJlkBkEABbQ+OPfQFzIAO6syfA6BKKAUP8p8uwoMkjHGgYx
UzI2/RGGIBzYCLl6CBuhCR9jW+ccJdDyVHq0lWtytf6rSo7IJkKl93vTVUp3j6rg
KVX2e3xvKMhepCo6c8yifDccsC+G7QjFzZyiuUYRUim6VQE3befM1gy3TJJ9EOal
hbKyUR3F3EvC/q7SvmthXd3qbUp7CQRHNS14yv7goJByf046W2FaDl5ZmnGkDH4y
SgbwfTSO2d6HA8EyHnR7MBQaGuW8nTM9qEQ+mDeLnGpi8RS1MW2mq38eRufP3MhE
ZMb2msKN/EBHRtsPZGVr9HCV8DmbZlxi1cv2DOZqCF5QNON6gyI6XpfBpumgjg+0
HETsKf6O0zikX35Q72UTa9qNvMRZjl+ZSLs53Wy+4sPGK3GHJ/Nh1tc13MhOonD6
hSbROtusyWYS1yzFNUtxj15M/H1KXEj53OcLixcGSwwhUX6umbSwyNOfvF8znU9l
CmuJHBepGLazjo4J1ZjRtCiLe93BWl8+2AAugsdB729VEYsDFSRZ5lTdo75/ugVb
20PTB/W9ak23dU2YwgbwGj3J+rubr/1/ZHY83mwEDcdoI1mkqDbS0U4l1HtTyqZ5
xw0THjxg142PozO77MGiRnD3TFtLhT96Q83yfE5X1S+u/2VGLptXl8779ZeN71Xr
G/yjPkbfIo8qBsON9l6Xn5TTtp3WKErdaAaXcXFrUOZmjGwGqZKSoKKFlCQBAI0e
2RpvhNnt3eNCt++ZIEHRpvI3rV2qjgpEK+KWlYghtUfAjrIBJhj8ItQFx6gTYtIJ
bMAiCj79/1sKKtoBa7my/g1vtmu7kUoOJ5S1pw92tPct8h/sCZ2xrZMIeq5HYvLo
MhLT2nNJeF0knnGSg/BSpD5PJC4pw4blSR8aYQQ+YU/ZlCIp3YnhDyqpdQKEoLvs
d/t+RI8dG1s79WUNNGe+wnTncNTj+JNB2PodlfLNIli85b2h/7MGwLWGfNhIldrp
TgP6yTkQL4nKo0n0ZFW2e0ApCjlKhXeeK1LZaGATov5idff3FcUCA8ZDGvUrWtrY
lnTeqsRjO+Ym0eD7eYVK5tlQ++HBpOpcQjrobguEelFQaBMeUNqKdwPqbWVOt95i
OvuyXaJYJU3mduYTA2VvW9c79hrW8BbNKlPrQ+vYzyKBxT+sGJxhnKu9RWY4PdNe
WuMAvWzfGRNJX29QBUnDb+ca3ir8Cbk/rp7jtpfc4MlWxM/sP72VHTsnZ9CJL7u/
7/VQ5Vk29a12v5HYv0mquJQI5x+1ZZRcrOh+h/VCtoWkTgLN8dr4XfMa/1h08I3F
S8i/f6uMV0Q9if9S3W+1M9W8XZfO9l24AKMoZjIjyMHDa/rhmxPjbZXI5Y7G9KUS
XHaNb/Y0GYcEfwZPyffRhEBnHq59EabcEsX8GlIIHmJ7aIJKPcqbSKIv1EYGPjLj
QdAShTHq8RwMgIIVOUMw3z38DWdRadU953m6W6W1bWFbjh5HoeHgRQ5kbExdn/p+
RoWSNuq/7364S+9+u/vx7ue7n+7+8R9uuoM+LsA8NUPU8nmhxd2Wl955pzwUZJwW
wV8yDWM0tUDsKaYsZroGfqM+TjByJo6PFlee2aSUomKt0IxZDur9DA4iB+gYqb+s
XGF/iUe2I4zRW3MREfNgkGHflQACqEZvYpH2CKLqj52E7dzlyo4afbyK+GWq9qn5
9aBbT0dGvZ9ZRdHry0O8gwkoIluyqj9AYoozRlG51pdZwEudmZ4ApDG3pnbS+l8r
S3iviIo9Ho7C32RyWGwX/iLUMPG6AZPUTKkjxdXp3FN7KJScE+Gw5b5e0gmQks3W
i2pZ4lBGNw+d8NJAdsFMxyuk+UvZgDoW33EIz4WLMzDjEL0N+Z6peIWG/1+sPqer
fO086sdQDYTsW6C8/kHe8xay+CnudLOcTGfvBQLk5u8H/L18CJym4lPgW18ZJhHh
8ku2kmlkIsGxdPa0yEE5ZwEFlYXfG2McInTys1hfOHvh6ixUMQ2ENa6+3xz2vjiF
1PjIzJIZhXAqnd1RBeLkXcsRLMGk3NfD9oiZpmiEBNP3n3l9Rfg+c8YFufnKISF7
shfLbUrsJD4GludwY1qnAjq7u80Yk7OuIa1zC+8ijvB47rrZoRMvF8+fNuHUHIZ4
FMn9EkajJdMfIpZLZ39ACU/3bBKog2JYGTqDekeQE3NhI/vdihzvtR0iBA7dLb75
zR8KYe3N1ACbJ0mSiCg9iApwUspswPszgGrOEKogWf9ud6BGzU8J8Y86aAqMWRgp
x20fHycCXQg1SJStTiqjUDLEGxcvdPQiSc90iFLUAJZigvQkOqD5K4/zPgQMwxep
ihVo/j44gWn+m5hQ0l92/HVleiKOfwFZuq9Hydo88sq/3maP6oOXM70NN8/LCayn
pcS1l+PfrmbGFtN3TNP0HB/f1iWxNA6H4b+ybaoPVxwAAA==
}
rezize-faces: func [siz [pair!] /move] [
text-results/offset: text-results/offset + (siz * 0x1)
area-results/offset: area-results/offset + (siz * 0x1)
resize-face/no-show area-test area-test/size + (siz * 1x1)
resize-face/no-show area-results area-results/size + (siz * 1x0)
if move [
resize-face/no-show area-results area-results/size + (siz * 0x-1)
]
]
feel-move: [
engage-super: :engage
engage: func [face action event /local prev-offset] [
engage-super face action event
if find [over away] action [
prev-offset: face/offset
face/offset: 0x1 * (face/old-offset + event/offset) ; We cannot modify face/old-offset but why not use it?
face/offset: 0x1 * second confine face/offset face/size area-test/offset + 0x100 area-results/offset + area-results/size - 0x100
face/offset: face/offset + 4x0 ; ?? must add spacing
if prev-offset <> face/offset [
rezize-faces/move (face/offset - prev-offset * 0x1)
show main-window
]
]
]
]
main-window: center-face layout [
styles area-style
do [sp: 4x4] origin sp space sp
Across
btn "(O)pen..." #"^O" [open_file]
btn "(S)ave" #"^S" [save_file]
pad (sp * -1x0)
btn "as..." [save_file/as]
btn "Undo" #"^z" [area-test/undo if strict-equal? code get-face area-test [change_title]]
btn "(R)edo" #"^r" [area-test/redo if strict-not-equal? code get-face area-test [change_title/modified]]
btn "(D)o script" #"^D" yellow [test area-test]
btn "H(a)lt" #"^A" red [if doing [doing: false make error! "Halt"]]
btn "Clear (T)est" #"^T" [if confirm "Are you sure?" [reset-face area-test change_title/modified]]
btn "Clear R(e)sults" #"^e" [reset-face area-results old-length: 0]
pad 0x1
check-clear-res: check-line "before every do"
return
Below
style area-scroll area-scroll 650x200 hscroll vscroll font-name font-fixed para [origin: 2x0]; Tabs: 16]
text-test: text bold "Test"
area-test: area-scroll {print "Hello world!"} with [append init [deflag-face self/ar 'tabbed ]]
button-balance: button "-----" 650x6 gray feel feel-move edge [size: 1x1] font [size: 6]
text-results: text bold "Results"
area-results: area-scroll silver read-only
key escape (sp * 0x-1) [ask_close]
do [
code: copy area-test/text
old-add_to_undo-list: get in area-test/ar 'add_to_undo-list
area-test/ar/add_to_undo-list: func [key] [change_title/modified old-add_to_undo-list key]
]
]
main-window/user-data: reduce ['size main-window/size]
insert-event-func func [face event /local siz] [
if event/face = main-window [
switch event/type [
close [
ask_close
return none
]
resize [
face: main-window
siz: face/size - face/user-data/size ; compute size difference
face/user-data/size: face/size ; store new size
rezize-faces siz
button-balance/offset: button-balance/offset + (siz * 0x1)
button-balance/size: button-balance/size + (siz * 1x0)
show main-window
]
scroll-line [either event/offset/y < 0 [scroll-drag/back/page area-test/vscroll] [scroll-drag/page area-test/vscroll]]
]
]
event
]
ask_close: does [
either not saved? [
switch request ["Exit without saving?" "Yes" "Save" "No"] reduce [
yes [old-quit]
no [if save_file [old-quit]]
]
][
if confirm "Exit now?" [old-quit]
;old-quit
]
]
; main
doing: false
job-name: none
named: no
saved?: yes
main-title: join copy System/script/header/title " - Untitled"
view/title/options main-window main-title reduce ['resize 'min-size main-window/size + system/view/title-size + 8x10 + system/view/resize-border]
] ; contextNotes
|