REBOL [
Title: "MakeDoc"
Date: 26-Oct-2011
Author: [
"Gabriele Santilli" "FSM Concept"
"Christopher Ross-Gill" "Reorganisation for reuse"
]
License: [
"Finite State Machine"
http://www.colellachiara.com/soft/MD3/fsm.html
]
Type: 'module
; Root: %~/Projects/MakeDocPro/
Root: http://reb4.me/mdp/
Exports: [
load-doc make-doc ; load-para make-para
]
]
amend: context [
ascii: charset ["^/^-" #"^(20)" - #"^(7E)"]
digit: charset [#"0" - #"9"]
upper: charset [#"A" - #"Z"]
lower: charset [#"a" - #"z"]
alpha: union upper lower
alphanum: union alpha digit
hex: union digit charset [#"A" - #"F" #"a" - #"f"]
file*: union alphanum charset "_-"
url-: union alphanum charset "!'*,-._~" ; "!*-._"
url*: union url- charset ":+%&=?"
space: charset " ^-"
ws: charset " ^-^/"
word1: union alpha charset "!&*+-.?_|"
word*: union word1 digit
html*: exclude ascii charset {&<>"}
para*: path*: union alphanum charset "!%'+-._"
extended: charset [#"^(80)" - #"^(FF)"]
chars: complement nochar: charset " ^-^/^@^M"
ascii+: charset [#"^(20)" - #"^(7E)"]
wiki*: complement charset [#"^(00)" - #"^(1F)" {:*.<>} #"{" #"}"]
name: union union lower digit charset "*!',()_-"
wordify-punct: charset "-_()!"
utf-8: use [utf-2 utf-3 utf-4 utf-5 utf-b][
utf-2: #[bitset! 64#{AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA/////wAAAAA=}]
utf-3: #[bitset! 64#{AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAP//AAA=}]
utf-4: #[bitset! 64#{AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA/wA=}]
utf-5: #[bitset! 64#{AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA8=}]
utf-b: #[bitset! 64#{AAAAAAAAAAAAAAAAAAAAAP//////////AAAAAAAAAAA=}]
[utf-2 1 utf-b | utf-3 2 utf-b | utf-4 3 utf-b | utf-5 4 utf-b]
]
get-ucs-code: decode-utf: use [utf-os utf-fc int][
utf-os: [0 192 224 240 248 252]
utf-fc: [1 64 4096 262144 16777216]
func [char][
int: 0
char: change char char/1 xor pick utf-os length? char
forskip char 1 [change char char/1 xor 128]
char: head reverse head char
forskip char 1 [int: (to-integer char/1) * (pick utf-fc index? char) + int]
all [int > 127 int <= 65535 int]
]
]
inline: [ascii+ | utf-8]
text-row: [chars any [chars | space]]
text: [ascii | utf-8]
ident: [alpha 0 14 file*]
wordify: [alphanum 0 99 [wordify-punct | alphanum]]
word: [word1 0 25 word*]
number: [some digit]
integer: [opt #"-" number]
wiki: [some [wiki* | utf-8]]
ws*: white-space: [some ws]
amend: func [rule [block!]][
bind rule 'self
]
]
amend: get in amend 'amend
match: context [
interpolate: func [body [string!] escapes [any-block!] /local out][
body: out: copy body
parse/all body [
any [
to #"%" body: (
body: change/part body reduce any [
select/case escapes body/2 body/2
] 2
) :body
]
]
out
]
filter: [
result: errors: #[none]
messages: [
not-included "is not included in the list"
excluded "is reserved"
invalid "is missing or invalid"
not-confirmed "doesn't match confirmation"
not-accepted "must be accepted"
empty "can't be empty"
blank "can't be blank"
too-long "is too long (maximum is %d characters)"
too-short "is too short (minimum is %d characters)"
wrong-length "is the wrong length (should be %d characters)"
not-a-number "is not a number"
too-many "has too many arguments"
]
datatype: [
'any-string! | 'binary! | 'block! | 'char! | 'date! | 'decimal! | 'email! | 'file! |
'get-word! | 'integer! | 'issue! | 'lit-path! | 'lit-word! | 'logic! | 'money! |
'none! | 'number! | 'pair! | 'paren! | 'path! | 'range! | 'refinement! |
'set-path! | 'set-word! | 'string! | 'tag! | 'time! | 'tuple! | 'url! | 'word!
]
else: #[none]
otherwise: [
['else | 'or][
set else string! | copy else any [word! string!]
] | (else: #[none])
]
source: spec: rule: key: value: required: present: target: type: format: constraints: else: none
constraint: use [is is-not? is-or-length-is op val val-type range group][
op: val: val-type: none
is: ['is | 'are]
is-or-length-is: [
[
['length | 'size] (val: string-length? value val-type: integer!)
| (val: :value val-type: :type)
] is
]
is-not?: ['not (op: false) | (op: true)]
[
is [
'accepted otherwise (
unless true = value [report not-accepted]
) |
'confirmed opt 'by set val get-word! otherwise (
val: to-word val
unless value = as/where :type get-from source :val format [
report not-confirmed
]
) |
is-not? 'within set group any-block! otherwise (
either case [
block? value [value = intersect value group]
true [found? find group value]
][
unless op [report excluded]
][
if op [report not-included]
]
)
] |
is-or-length-is [
is-not? 'between [set range [range! | into [2 val-type]]] otherwise (
either op [
case [
val < target: range/1 [report too-short]
val > target: range/2 [report too-long]
]
][
unless any [
val < range/1
val > range/2
][report excluded]
]
) |
'more-than set target val-type otherwise (
unless val > target [report too-short]
) |
'less-than set target val-type otherwise (
unless val < target [report too-long]
) |
set target val-type otherwise (
unless val = target [report wrong-length]
)
]
]
]
do-constraints: does [constraints: [any constraint]]
skip-constraints: does [constraints: [to set-word! | to end]]
humanize: func [word][uppercase/part replace/all form word "-" " " 1]
report: func ['message [word!]][
message: any [
all [string? else else]
all [block? else select else message]
reform [humanize key any [select messages message ""]]
]
unless select errors :key [repend errors [:key copy []]]
append select errors :key interpolate message [
#"w" [form key]
#"W" [humanize key]
#"d" [form target]
#"t" [form type]
]
]
engage: does [parse spec rule]
]
make-filter: func [source spec rule][
spec: context compose/deep [
(filter)
errors: copy []
result: copy []
rule: [(copy/deep rule)]
spec: [(spec)]
]
spec/source: copy source
spec
]
get-one: func [data type /local res][
parse data [some [res: type to end break | skip]]
unless tail? res [take res]
]
get-some: func [data type /local pos res][
res: make block! length? data
parse data [some [pos: type (append/only res take pos) :pos | skip]]
unless empty? res [res]
]
match: func [
[catch] source [block!] spec [block!]
/report-to errs [block!]
][
spec: make-filter source spec [
(result: context append remove-each item copy spec [not set-word? item] none)
some [
set key set-word! (key: to-word key)
set required ['opt | 'any | 'some | none]
copy type [lit-word! any ['| lit-word!] | datatype any ['| datatype]]
otherwise
(
switch/default required [
any [
value: get-some source type
either value [do-constraints][skip-constraints]
]
opt [
value: get-one source type
either value [do-constraints][skip-constraints]
]
some [
value: get-some source type
either value [do-constraints][skip-constraints report invalid]
]
][
value: get-one source type
either value [do-constraints][skip-constraints report invalid]
]
result/(key): value
)
constraints
]
end (if all [not empty? source empty? errors][key: 'match report too-many])
]
unless spec/engage [raise "Could not parse Match specification"]
all [block? errs insert clear errs spec/errors]
if empty? spec/errors [spec/result]
]
]
match: get in match 'match
make-doc: context [
root: system/script/header/root
load-scanpara: use [para!][
para!: context amend [
para: copy []
emit: use [prev][
func [data][
prev: pick back tail para 1
case [
not string? data [append/only para data]
not string? prev [append para data]
true [append prev data para]
]
]
]
text: char: values: none
in-word?: false
in-word: [(in-word?: true)]
not-in-word: [(in-word?: false)]
string: use [mk ex][
[
mk: {"} (
either error? try [
mk: load/next ex: mk
][
values: "="
][
ex: mk/2
values: reduce ['wiki mk/1]
]
) :ex
]
]
block: use [mk ex][
[
mk: #"[" (
either error? try [
mk: load/next ex: mk
][
ex
values: "="
][
ex: mk/2
values: mk/1
]
) :ex ; ]
]
]
rule: none
scanpara: func [paragraph [string!]][
clear para
parse/all paragraph rule
new-line/all para false
; probe para
copy para
]
]
func [scanpara [file!]][
if all [
exists? scanpara: root/(scanpara)
scanpara: load/header scanpara
'paragraph = get in take scanpara 'type
][
make para! compose/only [rule: (amend scanpara)]
]
]
]
load-scanner: use [para! scanner!][
scanner!: context amend [
doc: []
emit: func ['style data /verbatim][
if string? data [
trim/tail data
unless verbatim [data: inline/scanpara data]
; unless verbatim [data: envelop data]
]
repend doc [style data]
]
inline: text: para: values: none
term: [any space [newline | end]]
trim-each: [(foreach val values [trim/head/tail val])]
options: []
line: [any space copy text text-row term (trim/head/tail text)]
paragraph: [copy para [text-row any [newline text-row]] term]
lines: [any space paragraph]
indented: [some space opt text-row]
example: [
copy para some [indented | some newline indented]
(para: trim/auto para)
]
define: [copy text to " -" 2 skip [newline | any space] paragraph]
commas: [line (values: parse/all text ",") trim-each]
pipes: [line (values: parse/all text "|") trim-each]
block: [term (values: copy []) | line (values: any [attempt [load/all text][]])]
rules: none
scandoc: func [document [string!]][
clear doc
emit options options
parse/all document rules
new-line/skip/all doc true 2
doc
]
]
func [scandoc [file!] scanpara [file!]][
if all [
exists? scandoc: root/(scandoc)
scandoc: load/header scandoc
'document = get in take scandoc 'type
][
scandoc: make scanner! compose/only [rules: (amend scandoc)]
if scandoc/inline: load-scanpara scanpara [
scandoc
]
]
]
]
fsm!: context [
initial: state: none
state-stack: [ ]
goto-state: func [new-state [block!] retact [paren! none!]] [
insert/only insert/only state-stack: tail state-stack :state :retact
state: new-state
]
return-state: has [retact [paren! none!]] [
set [state retact] state-stack
state: any [state initial]
do retact
state-stack: skip clear state-stack -2
]
rewind-state: func [up-to [block!] /local retact stack] [
if empty? state-stack [return false]
stack: tail state-stack
retact: make block! 128
until [
stack: skip stack -2
append retact stack/2
if same? up-to stack/1 [
state: up-to
do retact
state-stack: skip clear stack -2
return true
]
head? stack
]
false
]
event: func [
evt [any-type!]
/local val ovr retact done?
][
if not block? state [exit]
until [
done?: yes
local: any [
find state evt
find state to-get-word type?/word evt
find state [default:]
]
if local [
parse local [
any [any-string! | set-word! | get-word!]
set val opt paren! (do val) [
'continue (done?: no)
|
'override set ovr word! (evt: to set-word! ovr done?: no)
|
none
] [
'return (return-state)
|
'rewind? copy val some word! (
if not foreach word val [
if block? get/any word [
if rewind-state get word [break/return true]
]
false
] [
done?: yes
]
)
|
set val word! set retact opt paren! (
either block? get/any val [goto-state get val :retact][
done?: yes
]
)
|
none (done?: yes)
]
]
]
done?
]
]
init: func [initial-state [word! block!]] [
; _t_ "fsm_init"
if word? initial-state [
unless block? initial-state: get/any :initial-state [
make error! "Not a valid state"
]
]
clear state-stack: head state-stack
initial: state: initial-state
]
end: does [
; _t_ "fsm_end"
foreach [retact state] head reverse head state-stack [do retact]
]
]
load-emitter: use [emitter! para!][
emitter!: context [
document: position: word: data: none
sections: context [
this: 0.0.0.0
reset: does [this: 0.0.0.0]
step: func [level /local bump mask] [
set [bump mask] pick [
[1.0.0.0 1.0.0.0]
[0.1.0.0 1.1.0.0]
[0.0.1.0 1.1.1.0]
[0.0.0.1 1.1.1.1]
] level
level: form this: this + bump * mask
clear find level ".0"
level
]
]
outline: func [doc [block!]][
remove-each style copy doc [
not find [sect1 sect2 sect3 sect4] style
]
]
init-emitter: func [doc] [
sections/reset
foreach [word str] doc [
if w: find [sect1 sect2 sect3 sect4] word [
w: index? w
if w <= toc-levels [
sn: sections/step w
insert insert tail toc capture [make-heading/toc w sn copy/deep str] "
^/"
]
]
]
sections/reset
if no-title [emit toc state: normal]
]
toc: none
initialize: func [para [block!]][
if string? pick para 1 [
insert para reduce [