Skip to content

Instantly share code, notes, and snippets.

@lepinekong

lepinekong/.github.lib.red

Last active May 14, 2018 17:21
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save lepinekong/7574892bfefe7e53e7bd4dd4759f30f8 to your computer and use it in GitHub Desktop.
Save lepinekong/7574892bfefe7e53e7bd4dd4759f30f8 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
.github.lib.red
Red []
.use: func [locals [block!] body [block!]][
do bind body make object! collect [
forall locals [keep to set-word! locals/1]
keep none
]
]
use: :.use
.get-github-url: function[.github-url [url!] .id [string! file!]][
{description: get github url for ReAdABLE.Human.Format.red}
either file? .id [
id: rejoin ["file-" .id]
replace/all id "." "-"
replace/all id "--" "-"
id: lowercase id
][
id: .id
]
github: read .github-url
div-id: rejoin [{<div id="} id {" class="file">}]
parse github [
to div-id
thru {href="} copy url to {">Raw</a>}
]
url: to-url rejoin [https://gist.githubusercontent.com url]
]
get-github-url: :.get-github-url
.get-short-filename: function[.filepath [file! url!] /wo-extension /without-extension][
filepath: .filepath
short-filename: (pick (split-path .filepath) 2)
unless (without-extension or wo-extension) [
return short-filename
]
return (pick (.split-filename short-filename) 1)
]
.split-filename: function[.filename][
{
#### Example:
.split-filename short-filename
}
;example -> .filename: %/c/test/test.red
filename: reverse copy .filename
pos: index? find filename "."
suffix: reverse (copy/part filename pos)
short-filename: copy/part (reverse filename) ((length? filename) - (length? suffix))
return reduce [short-filename suffix]
]
split-filename: :.split-filename
.type?: function [
"Returns the datatype of a value"
value [any-type!]
][
type: type?/word get/any value
]
.switch: function [
{Evaluates the first block following the value found in cases}
value [any-type!] "The value to match"
cases [block!]
case [block!] "Default block to evaluate"
][
value: to-word value
switch/default value cases case
]
.cases: :.switch
.if: :either
.do-events: function [
{Launch the event loop, blocks until all windows are closed}
/no-wait "Process an event in the queue and returns at once"
return: [logic! word!] "Returned value from last event"
/local result
win
][
try [
either no-wait [
do-events/no-wait
][
do-events
]
]
]
.refresh-screen: does [.do-events/no-wait]
.do-trace: function [.line-number [integer!] '.block [word! block! unset!] .file [file! url! string!]
/filter that-contains [string! file! url!]
][
{
#### Example:
- [x] [1].
```
f: function [.file .argument][
do-trace 2 [
probe .argument
] .file
]
f %test-this-file.red "test this file"
```
- [x] [2].
```
g: function [.file .argument][
do-trace/filter 2 [
probe .argument
] .file "test"
]
g %this-should-not-be-traced.red "this file should not be traced"
```
}
file: form .file
if filter [
either not find file that-contains [exit][
]
]
switch type?/word get/any '.block [
unset! [
print {TODO:}
]
block! [
.do-events/no-wait
print [file "line" .line-number ": "]
.do-events/no-wait
do :.block
ask "pause..."
]
]
]
do-trace: :.do-trace
Raw
.system.coder.languages.redlang.lib.red
Red [
Title: ".system.coder.apps.redlang.red"
Parent: ".system.coder.apps.red"
]
.Redlang.Get-Meta: function[.src [string! file! url!]][
{Purpose:
Contrary to Interpreter,
Red compiler doesn't play well with all text above Red []
so we must clean all above Red [...] before compiling
}
; accept:
; c:\test\test.red ; windows format without space
; "c:\test with space\test.red" ; windows format
; %/c/test/test.red ; red file format
case [
string! = type? .src [src: .src]
(file! = type? .src) or (url! = type? .src) [
.src: to-red-file form .src
src: read .src
]
]
; Extract Red meta
rule-meta: [
copy meta to "Red ["
]
parse src rule-meta
return meta
]
Redlang.Get-Meta: :.Redlang.Get-Meta
.Redlang.Get-Program: function[.src [string! file! url!] /header][
{Purpose:
Contrary to Interpreter,
Red compiler doesn't play well with all text above Red []
so we must clean all above Red [...] before compiling
}
; accept:
; c:\test\test.red ; windows format without space
; "c:\test with space\test.red" ; windows format
; %/c/test/test.red ; red file format
case [
string! = type? .src [src: .src]
(file! = type? .src) or (url! = type? .src) [
.src: to-red-file form .src
src: read .src
]
]
; Extract Red program
rule-program: [
any [
to "Red [" start: thru "Red ["
] to end
(program: copy start)
]
parse src rule-program
either header [
src-block: split src newline
src-block-extract: copy []
count: 0
previous-count: 0
forall src-block [
line: src-block/1
parse line [
some [
thru "[" (count: count + 1)
|
thru "]" (count: count - 1)
]
]
either (count > 0) [
;?? count
append src-block-extract line
previous-count: count
][
;?? count
;?? previous-count
if (previous-count > 0) [
append src-block-extract line
probe line
ask "pause"
break
]
]
]
src-extract: copy ""
forall src-block-extract [
line: src-block-extract/1
append src-extract line
append src-extract newline
]
return src-extract
][
return program
]
]
Redlang.Get-Program: :.Redlang.Get-Program
.Redlang.SHA256: function['.file [word! string! file! url! unset!] /local ][
switch/default type?/word get/any '.file [
unset! [
print {
to calculate SHA256 for red script syntax possible syntax is:
Redlang.SHA256 c:\path-without-space\test.red
Redlang.SHA256 "c:\path with space\test.red"
}
]
word! string! file! url! [
file: form .file
file: to-red-file file
src: read file
rule-meta: [
copy meta to "Red ["
]
parse src rule-meta
if find meta "SHA256: " [
parse meta [thru "SHA256: " copy SHA256 thru "}"]
print rejoin["Previous: " SHA256]
]
program: Redlang.get-program src
last-SHA256: checksum program 'SHA256
print rejoin["Last: " mold last-SHA256]
]
][
throw error 'script 'expect-arg .file
]
]
Redlang.SHA256: :.Redlang.SHA256
Raw
.system.libraries.reAdABLE-json.red
Red [
Title: "ReAdABLE Human Format - JSON Decoder/Encoder"
Author: "Christopher Ross-Gill"
Adaptation: "Lépine KONG"
Date: 12-Sep-2017
Home: http://www.ross-gill.com/page/JSON_and_Rebol
File: %.system.libraries.reAdABLE-json.red.red
Version: 0.3.6.3
Purpose: "Convert a Red block to a JSON string"
Rights: http://opensource.org/licenses/Apache-2.0
Type: 'module
Name: 'rgchris.altjson
Exports: [load-json to-json]
History: [
12-Sep-2017 0.3.6.1 "Red Compatibilities"
18-Sep-2015 0.3.6 "Non-Word keys loaded as strings"
17-Sep-2015 0.3.5 "Added GET-PATH! lookup"
16-Sep-2015 0.3.4 "Reinstate /FLAT refinement"
21-Apr-2015 0.3.3 {
- Merge from Reb4.me version
- Recognize set-word pairs as objects
- Use map! as the default object type
- Serialize dates in RFC 3339 form
}
14-Mar-2015 0.3.2 "Converts Json input to string before parsing"
07-Jul-2014 0.3.0 "Initial support for JSONP"
15-Jul-2011 0.2.6 "Flattens Flickr '_content' objects"
02-Dec-2010 0.2.5 "Support for time! added"
28-Aug-2010 0.2.4 "Encodes tag! any-type! paired blocks as an object"
06-Aug-2010 0.2.2 "Issue! composed of digits encoded as integers"
22-May-2005 0.1.0 "Original Version"
]
Notes: {
- Converts date! to RFC 3339 Date String
}
]
if not value? 'use [
use: func [locals [block!] body [block!]][
do bind body make object! collect [
forall locals [keep to set-word! locals/1]
keep none
]
]
]
load-json: use [
tree branch here val is-flat emit new-child to-parent neaten-one neaten-two word to-word
space comma number string block object _content value ident
][
branch: make block! 10
emit: func [val][here: insert/only here val]
new-child: quote (insert/only branch insert/only here here: make block! 10)
to-parent: quote (here: take branch)
neaten-one: quote (new-line/all head here true)
neaten-two: quote (new-line/all/skip head here true 2)
to-word: use [word1 word+][
; upper ranges borrowed from AltXML
word1: charset [
"!&*=?ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz|~"
#"^(C0)" - #"^(D6)" #"^(D8)" - #"^(F6)" #"^(F8)" - #"^(02FF)"
#"^(0370)" - #"^(037D)" #"^(037F)" - #"^(1FFF)" #"^(200C)" - #"^(200D)"
#"^(2070)" - #"^(218F)" #"^(2C00)" - #"^(2FEF)" #"^(3001)" - #"^(D7FF)"
#"^(f900)" - #"^(FDCF)" #"^(FDF0)" - #"^(FFFD)"
]
word+: charset [
"!&'*+-.0123456789=?ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz|~"
#"^(B7)" #"^(C0)" - #"^(D6)" #"^(D8)" - #"^(F6)" #"^(F8)" - #"^(037D)"
#"^(037F)" - #"^(1FFF)" #"^(200C)" - #"^(200D)" #"^(203F)" - #"^(2040)"
#"^(2070)" - #"^(218F)" #"^(2C00)" - #"^(2FEF)" #"^(3001)" - #"^(D7FF)"
#"^(f900)" - #"^(FDCF)" #"^(FDF0)" - #"^(FFFD)"
]
func [text [string!]][
all [
parse text [word1 any word+]
to word! text
]
]
]
space: use [space][
space: charset " ^-^/^M"
[any space]
]
comma: [space #"," space]
number: use [dg ex nm as-num][
dg: charset "0123456789"
ex: [[#"e" | #"E"] opt [#"+" | #"-"] some dg]
nm: [opt #"-" some dg opt [#"." some dg] opt ex]
as-num: func [val [string!]][
case [
not parse val [opt "-" some dg][to float! val]
not integer? try [val: to integer! val][to issue! val]
val [val]
]
]
[copy val nm (val: as-num val)]
]
string: use [ch es hx mp decode-surrogate decode][
ch: complement charset {\"}
hx: charset "0123456789ABCDEFabcdef"
mp: #(#"^"" "^"" #"\" "\" #"/" "/" #"b" "^H" #"f" "^L" #"r" "^M" #"n" "^/" #"t" "^-")
es: charset words-of mp
decode-surrogate: func [char [string!]][
char: debase/base char 16
to char! 65536
+ (shift/left 1023 and to integer! take/part char 2 10)
+ (1023 and to integer! char)
]
decode: use [char escape][
escape: [
change [
#"\" [
char: es (char: select mp char/1)
|
#"u" copy char [
#"d" [#"8" | #"9" | #"a" | #"b"] 2 hx
"\u"
#"d" [#"c" | #"d" | #"e" | #"f"] 2 hx
] (
char: decode-surrogate head remove remove skip char 4
)
|
#"u" copy char 4 hx (
char: to char! to integer! to issue! char
)
]
] (char)
]
func [text [string! none!]][
either none? text [make string! 0][
all [parse text [any [to "\" escape] to end] text]
]
]
]
[#"^"" copy val [any [some ch | #"\" [#"u" 4 hx | es]]] #"^"" (val: decode val)]
]
block: use [list][
list: [space opt [value any [comma value]] space]
[#"[" new-child list #"]" neaten-one to-parent]
]
_content: [#"{" space {"_content"} space #":" space value space "}"] ; Flickr
object: use [name list as-map][
name: [
string space #":" space (
emit either is-flat [
;to tag! val
to-set-word val
][
any [
to-word val
val
]
]
)
]
list: [space opt [name value any [comma name value]] space]
as-map: [(unless is-flat [here: change back here make map! pick back here 1])]
[#"{" new-child list #"}" neaten-two to-parent as-map]
]
ident: use [initial ident][
initial: charset ["$_" #"a" - #"z" #"A" - #"Z"]
ident: union initial charset [#"0" - #"9"]
[initial any ident]
]
value: [
"null" (emit none)
| "true" (emit true)
| "false" (emit false)
| number (emit val)
| string (emit val)
| _content
| object | block
]
func [
"Convert a JSON string to Rebol data"
json [string!] "JSON string"
/flat "Objects are imported as tag-value pairs"
/padded "Loads JSON data wrapped in a JSONP envelope"
][
is-flat: :flat
tree: here: make block! 0
either parse json either padded [
[space ident space "(" space opt value space ")" opt ";" space]
][
[space opt value space]
][
pick tree 1
][
do make error! "Not a valid JSON string"
]
]
]
to-json: use [
json emit escape emit-string emit-issue emit-date
here lookup comma block object block-of-pairs value
][
emit: func [data][repend json data]
escape: use [mp ch to-char encode][
mp: #(#"^/" "\n" #"^M" "\r" #"^-" "\t" #"^"" "\^"" #"\" "\\" #"/" "\/")
ch: intersect ch: charset [#" " - #"~"] difference ch charset words-of mp
to-char: func [char [char!]][
rejoin ["\u" skip tail form to-hex to integer! char -4]
]
encode: use [mark][
[
change mark: skip (
case [
find mp mark/1 [select mp mark/1]
mark/1 < 10000h [to-char mark/1]
mark/1 [
rejoin [
to-char mark/1 - 10000h / 400h + D800h
to-char mark/1 - 10000h // 400h + DC00h
]
]
/else ["\uFFFD"]
]
)
]
]
func [text][
also text parse text [any [some ch | encode]]
]
]
emit-string: func [data][emit {"} emit data emit {"}]
emit-issue: use [dg nm mk][
dg: charset "0123456789"
nm: [opt #"-" some dg]
quote (either parse next form here/1 [copy mk nm][emit mk][emit-string here/1])
]
emit-date: use [second][
quote (
emit-string rejoin collect [
keep reduce [
pad/left/with here/1/year 4 #"0"
#"-" pad/left/with here/1/month 2 #"0"
#"-" pad/left/with here/1/day 2 #"0"
]
if here/1/time [
keep reduce [
#"T" pad/left/with here/1/hour 2 #"0"
#":" pad/left/with here/1/minute 2 #"0"
#":"
]
keep pad/left/with to integer! here/1/second 2 #"0"
any [
".0" = second: find form round/to here/1/second 0.000001 #"."
keep second
]
keep either any [
none? here/1/zone
zero? here/1/zone
][#"Z"][
reduce [
either here/1/zone/hour < 0 [#"-"][#"+"]
pad/left/with absolute here/1/zone/hour 2 #"0"
#":" pad/left/with here/1/zone/minute 2 #"0"
]
]
]
]
)
]
lookup: [
change [get-word! | get-path!] (reduce reduce [here/1])
]
comma: quote (unless tail? here [emit ","])
block: [
(emit #"[") any [here: value here: comma] (emit #"]")
]
block-of-pairs: [
some [set-word! skip]
| some [tag! skip]
]
object: [
(emit "{")
any [
here: [set-word! (change here to word! here/1) | any-string! | any-word!]
(emit [{"} escape to string! here/1 {":}])
here: value here: comma
]
(emit "}")
]
value: [
lookup fail ; resolve a GET-WORD! reference
| number! (emit here/1)
| [logic! | 'true | 'false] (emit to string! here/1)
| [none! | 'none | 'none] (emit "null")
| date! emit-date
| issue! emit-issue
| [
any-string! | word! | lit-word! | tuple! | pair! | time!
] (emit-string escape form here/1)
| any-word! (emit-string escape form to word! here/1)
| ahead [object! | map!] (change/only here body-of first here) into object
| ahead into block-of-pairs (change/only here copy first here) into object
| ahead any-block! (change/only here copy first here) into block
| any-type! (emit-string to tag! type? first here)
]
func [data][
json: make string! 1024
if parse compose/only [(data)][here: value][json]
]
]
Raw
.system.user.apps.authoring.library.red
Red [
Title: ".system.user.apps.authoring.library.red"
Url: https://gist.github.com/lepinekong/7574892bfefe7e53e7bd4dd4759f30f8
History: [
v1.0: {initial version}
V1.1: {+ .get-github-url}
V1.1.1: {fixed bug .get-github-url}
V1.2: {+ .to-json}
v1.2.1: [{+ .get-file-extension} https://gist.githubusercontent.com/lepinekong/7574892bfefe7e53e7bd4dd4759f30f8/raw/96a7e9345212a7b24fabc643d380268d10235cdd/.system.user.apps.authoring.library.red]
v2.0.0: {+ .copy-file}
]
]
->: .->: .=>: =>: ""
.use: func [locals [block!] body [block!]][
do bind body make object! collect [
forall locals [keep to set-word! locals/1]
keep none
]
]
use: :.use
.Config: func [spec [block!]][make object! spec]
Config: :.Config
.to-file: function [.file [file! string! word! block!]][
either block? .file [
return to-red-file rejoin .file
][
return to-red-file form .file
]
]
to-file: :.to-file
.to-dir: function[.dir [word! string! file! url! block! unset!] /local ][
{
#### Example:
- [x] [0]. to-dir %/c/test/ -> %/c/test/
- [x] [1]. to-dir %/c/test -> %/c/test/
- [X] [2]. to-dir c:\test -> %/c/test/
}
switch/default type?/word .dir [
unset! [
print {TODO:}
]
file! [
dir: :.dir
if not dir? dir [
append dir to-string "/"
to-red-file dir
]
dir
]
word! string! url! [
dir: to-red-file to-string :.dir
replace/all dir "//" "/"
to-dir (dir)
]
block! [
dir: .dir
joined-dir: copy ""
forall dir [
append joined-dir rejoin [dir/1 "/"]
]
repeat i 2 [replace/all joined-dir "//" "/"]
to-red-file joined-dir
]
] [
throw error 'script 'expect-arg varName
]
]
to-dir: :.to-dir
.switch: function [
{Evaluates the first block following the value found in cases}
value [any-type!] "The value to match"
cases [block!]
case [block!] "Default block to evaluate"
][
value: to-word value
switch/default value cases case
]
.type?: function [
"Returns the datatype of a value"
value [any-type!]
][
type: type?/word get/any value
]
.cases: :.switch
.if: :either
.get-full-path: function[.path [file! string! url!]][
.cases .type? '.path [
string! url! [
path: to-red-file to-string .path
]
][
path: .path
]
clean-path path
]
.to-full-path: :.get-full-path
.request-file: function [/dir .default-dir][
either dir [
return request-file/file .default-dir
][
return request-file/file what-dir
]
]
.get-short-filename: function[.filepath [file! url!] /wo-extension /without-extension][
filepath: .filepath
short-filename: (pick (split-path .filepath) 2)
unless (without-extension or wo-extension) [
return short-filename
]
return (pick (.split-filename short-filename) 1)
]
get-short-filename: :.get-short-filename
.split-filename: function[.filename][
{
#### Example:
.split-filename short-filename
}
;example -> .filename: %/c/test/test.red
filename: reverse copy .filename
pos: index? find filename "."
suffix: reverse (copy/part filename pos)
short-filename: copy/part (reverse filename) ((length? filename) - (length? suffix))
return reduce [short-filename suffix]
]
split-filename: :.split-filename
.get-file-extension: function[.filepath [file! url!]][
short-filename: .get-short-filename .filepath
return pick (.split-filename short-filename) 2
]
get-file-extension: :.get-file-extension
.replace: function [
series [series! none!]
pattern
value
/all
][
if error? try [
either all [
replace/all series pattern value
return series
][
replace series pattern value
return series
]
][
return none
]
]
.Read: function [
"Reads from a file, URL, or other port"
source [file! url! string! unset!]
/part {Partial read a given number of units (source relative)}
length [number!]
/seek "Read from a specific position (source relative)"
index [number!]
/binary "Preserves contents exactly"
/clipboard "Read from clipboard"
/lines "Convert to block of strings"
/info
/as {Read with the specified encoding, default is 'UTF-8}
encoding [word!]
/local
source?
out
][
bin-to-string: function [bin [binary!]][
text: make string! length? bin
foreach byte bin [append text to char! byte]
text
]
source?: true
switch/default type?/word get/any 'source [
unset! [
if clipboard [
source: read-clipboard
source?: false
]
]
url! [
response: write/binary/info source [GET [User-Agent: "Red 0.6.3"]]
out: bin-to-string response/3
]
][
either lines [
if (suffix? source) = %.zip [
return ""
]
switch/default (type?/word source) [
file! url! [
out: sysRead/lines source
]
string! [
out: split source newline
]
][
out: sysRead/lines source
]
][
; prevent error when reading path not terminated with /
if exists? source [
if error? try [
out: sysRead source
][
if (last source) <> #"/" [
source: rejoin [source #"/"]
out: sysRead source
]
]
]
]
]
either source? [
either clipboard [
][
out
]
][
out
]
]
if not value? 'sysRead [
sysRead: :Read
Read: :.Read
]
.Html.Read: function[url [file! url!]][
exclude-urls: []
exclude: 0
foreach exclude-url exclude-urls [
if find url exclude-url [
exclude: 1
]
]
either (exclude = 1) [
return ""
][
convert-invalid: function [page] [
collect/into [foreach c page [keep to-char c]] clear ""
]
if error? try [
return .read url
][
return convert-invalid url
]
]
]
Html.Read: :.Html.Read
.html.get-title: function[source][
html-to-parse: .html.read to-url source
rules: [thru {<title} thru {>} copy title to </title> to end]
either parse html-to-parse rules [
title: trim/head/tail title
print title
print [{from:} source]
return title
][
print [{no title found} {in} source]
return none
]
]
html.get.title: :.html.get-title
html.get6title: :.html.get-title
.select: function [.block-spec [block!] .selector [word! string!]][
selector: to-set-word form .selector
block: .block-spec
select block selector
]
.emit: function [.line [char! string! block! none!]][
if none? .line [exit]
either block? .line [
line: rejoin .line
][
line: .line
]
write/lines/append =>output-file line
]
.get-github-url: function[.github-url [url!] .id [string! file!]][
{description: get github url for ReAdABLE.Human.Format.red}
either file? .id [
id: rejoin ["file-" .id]
replace/all id "." "-"
replace/all id "--" "-"
id: lowercase id
][
id: .id
]
github: read .github-url
div-id: rejoin [{<div id="} id {" class="file">}]
parse github [
to div-id
thru {href="} copy url to {">Raw</a>}
]
url: to-url rejoin [https://gist.githubusercontent.com url]
]
get-github-url: :.get-github-url
if not value? 'syswrite-clipboard [
syswrite-clipboard: :write-clipboard
write-clipboard: function [data [string! file! url!] /local filePath][
if url? data [
data: to-string data
]
syswrite-clipboard data
]
]
.to-reAdABLE: function['.source [string! file! url! unset!]][
if not value? 'load-json [
github-url: https://gist.github.com/lepinekong/7574892bfefe7e53e7bd4dd4759f30f8
remote-lib: .get-github-url github-url %.system.libraries.reAdABLE-json.red
do read remote-lib
]
switch type?/word get/any '.source [
unset! [
ask "copy json to clipboard then enter..."
source: read-clipboard
readable: load-json/flat source
ask "ReAdable will be copied to clipboard..."
write-clipboard mold readable
]
file! [
source: .read .source
]
url![
.source: form .source
source: .read .source
]
]
return load-json/flat source
]
to-reAdABLE: :.to-reAdABLE
.to-json: function[.source [block! file! url!]][
if not value? 'to-json [
github-url: https://gist.github.com/lepinekong/7574892bfefe7e53e7bd4dd4759f30f8
remote-lib: .get-github-url github-url %.system.libraries.reAdABLE-json.red
print remote-lib
do read remote-lib
]
source: .source
switch type?/word get/any '.source [
file! [
source: .read .source
]
url![
.source: form .source
source: .read .source
]
]
return to-json source
]
.build-markup: func [
{Return markup text replacing <%tags%> with their evaluated results.}
content [string! file! url!]
/bind obj [object!] "Object to bind" ;ability to run in a local context
/quiet "Do not show errors in the output."
/local out eval value
][
content: either string? content [copy content] [read content]
out: make string! 126
eval: func [val /local tmp] [
either error? set/any 'tmp try [either bind [do system/words/bind load val obj] [do val]] [
if not quiet [
tmp: disarm :tmp
append out reform ["***ERROR" tmp/id "in:" val]
]
] [
if not unset? get/any 'tmp [append out :tmp]
]
]
parse content [
any [
end break
| "<%" [copy value to "%>" 2 skip | copy value to end] (eval value)
| copy value [to "<%" | to end] (append out value)
]
]
out
]
build-markup: :.build-markup
.string.expand: function[.string-template [string!] .block-vars[block!]][
return build-markup/bind .string-template Context Compose .block-vars
]
string-expand: :.string.expand
.expand: :.string.expand
.Redlang.Get-Meta: function[.src [string! file! url!]][
{Purpose:
Contrary to Interpreter,
Red compiler doesn't play well with all text above Red []
so we must clean all above Red [...] before compiling
}
; accept:
; c:\test\test.red ; windows format without space
; "c:\test with space\test.red" ; windows format
; %/c/test/test.red ; red file format
case [
string! = type? .src [src: .src]
(file! = type? .src) or (url! = type? .src) [
.src: to-red-file form .src
src: read .src
]
]
; Extract Red meta
rule-meta: [
copy meta to "Red ["
]
parse src rule-meta
return meta
]
Redlang.Get-Meta: :.Redlang.Get-Meta
.Redlang.Get-Body: function[.src [string! file! url!]][
{Purpose:
Contrary to Interpreter,
Red compiler doesn't play well with all text above Red []
so we must clean all above Red [...] before compiling
}
; accept:
; c:\test\test.red ; windows format without space
; "c:\test with space\test.red" ; windows format
; %/c/test/test.red ; red file format
case [
string! = type? .src [src: .src]
(file! = type? .src) or (url! = type? .src) [
.src: to-red-file form .src
src: read .src
]
]
; Extract Red body
rule-body: [
any [
to "Red [" start: thru "Red ["
] to end
(body: copy start)
]
parse src rule-body
return body
]
Redlang.Get-Body: :.Redlang.Get-Body
.do-trace: function [.line-number [integer!] '.block [word! block! unset!] .file [file! url! string!]
/filter that-contains [string! file! url!]
][
{
#### Example:
- [x] [1].
```
f: function [.file .argument][
do-trace 2 [
probe .argument
] .file
]
f %test-this-file.red "test this file"
```
- [x] [2].
```
g: function [.file .argument][
do-trace/filter 2 [
probe .argument
] .file "test"
]
g %this-should-not-be-traced.red "this file should not be traced"
```
}
file: form .file
if filter [
either not find file that-contains [exit][
]
]
switch type?/word get/any '.block [
unset! [
print {TODO:}
]
block! [
.do-events/no-wait
print [file "line" .line-number ": "]
.do-events/no-wait
do :.block
ask "pause..."
]
]
]
do-trace: :.do-trace
.guiconsole?: not (system/console = none)
.do-events: function [
{Launch the event loop, blocks until all windows are closed}
/no-wait "Process an event in the queue and returns at once"
return: [logic! word!] "Returned value from last event"
/local result
win
][
try [
either no-wait [
do-events/no-wait
][
do-events
]
]
]
.copy-file: function[ .what-files [file! block!]
/target-folder .target-folder
/github ; same as none target-folder; .target-folder will be first .github folder encountered in parent folders
/target-file .target-file
][
copy-file: function[.what-file][
what-file: .what-file
filename: .get-short-filename what-file
either github or not target-folder [
get-target-folder: function[path][
files: read path
folders: find files %.github/
either folders [
target-folder: .to-file rejoin [path folders/1]
return target-folder
][
unless (clean-path path) = %/ [
path: to-red-file rejoin [path "../"]
get-target-folder path
]
]
]
path: %./
target-folder: get-target-folder path
][
target-folder: .target-folder
]
target-file: clean-path .to-file rejoin [target-folder filename]
print ["Copying" what-file "to" target-file]
write/binary target-file read/binary what-file
]
either block? .what-files [
forall .what-files [
copy-file .what-files/1
]
][
copy-file .what-files
]
]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment