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 [ take pick para 1 ] ] para ] no-indent: true no-nums: true make-heading: func [level num str /toc /local lnk][ lnk: replace/all join "section-" num "." "-" num: either no-nums [""] [join num pick [". " " "] level = 1] either toc [ emit [{}] emit-inline str emit [ newline] ][ emit [{}] emit-inline str emit [{}] ] ] emit-sect: func [level str /local sn] [ sn: sections/step level make-heading level sn str ] hold-values: [] hold: func [value [any-type!]][insert hold-values value value] release: does [take hold-values] out: {} emit: func [value][ insert tail out reduce value ] states: value: options: none inline: make fsm! [] emit-inline: func [ para [block!] /with state [word! block!] ][ unless block? state [ state: get in states any [:state 'inline] ] inline/init state foreach part para [ set 'value part inline/event :value ] inline/end ] raise: func [msg] [emit ["Emitter error: " msg]] sanitize: escape-html: func [text [any-string!] /local char] amend [ ; SANITIZE from QM parse/all copy text [ copy text any [ text: some html* | #"&" (text: change/part text "&" 1) :text | #"<" (text: change/part text "<" 1) :text | #">" (text: change/part text ">" 1) :text | #"^"" (text: change/part text """ 1) :text | #"^M" (remove text) :text | copy char utf-8 (text: change/part text rejoin ["&#" get-ucs-code char ";"] length? char) | skip (text: change/part text rejoin ["#(" to-integer text/1 ")"] 1) :text ; | skip (text: change text "#") :text ] ] any [text ""] ] inherit: func [parent-state new-directives][ append new-directives parent-state ] raise: func [msg][ emit compose [{}] ] outline: make fsm! [] outline-do: func [doc [block!] state [block!]][ outline/init state forskip doc 2 [ position: :doc set [word data] doc outline/event to set-word! word ] outline/end ] generate: func [doc [block!]] [ clear hold-values clear out sections/reset outline-do doc get in states 'initial copy out ] ] func [makedoc [file!]][ if all [ exists? makedoc: root/(makedoc) makedoc: load/header makedoc 'emitter = get in take makedoc 'type ][ makedoc: make emitter! compose/only [states: context (makedoc)] ] ] ] grammar!: context [ document: %document.r paragraph: %paragraph.r markup: %html.r ] load-doc: use [document!][ document!: context [ options: none text: none document: none outline: func [/level depth [integer!]][ level: copy/part [sect1 sect2 sect3 sect4] probe min 4 max 1 any [depth 2] remove-each [style para] copy document [ not find level style ] ] render: does [ make-doc/custom document options ] ] func [ [catch] document [string!] /with model [none! block! object!] /custom options [none! block! object!] /local doc [none!] ][ options: make grammar! any [options []] model: make document! any [model []] model/options: options model/text: :document if doc: load-scanner options/document options/paragraph [ model/document: doc/scandoc document model ] ] ] make-doc: func [ document [string! block! object!] /custom options [block! object!] /local scanner emitter ][ options: make grammar! any [options []] case/all [ string? document [ ; _t_ "md_sc" document: load-doc/custom document options ] block? document [ ; _t_ "md_em" if emitter: load-emitter options/markup [ emitter/generate document ] ] object? document [ if emitter: load-emitter options/markup [ emitter/document: document emitter/generate document/document ] ] ] ] ] load-doc: get in make-doc 'load-doc make-doc: get in make-doc 'make-doc