Dialected EMIT function

〈Overview〉 ≡

emit: func [
 "Append values to a series according to a dialect"
 output [series! port!]
 values [block!] "EMIT dialect block (see docs)"

 /local 〈emit's locals〉
] [
 〈Append values to output according to the contents of values〉
]

〈Overview〉 +≡

macro: func [
 "Define a macro for the EMIT dialect"
 spec [block!] {Spec for the macro arguments, options and local words}
 body [block!] "Body of the macro (EMIT dialect)"
 /custom "The body is a PARSE rule"

 /local 〈macro's locals〉
] [
 〈Define a macro for the EMIT dialect〉
]

〈Overview〉 +≡

〈Support functions〉

〈Dialect keywords〉 ≡

emit: keyword [
 {Emit the argument, evaluating the dialect if it's a block}
 value "If block, contents is interpreted as EMIT dialect"
 /only "When output is block, emit as a sub-block"
] [
 either block? :value [
  either all [only any-block? output] [
   append/only output make block! 8
   emit last output value
  ] [
   emit output value
  ]
 ] [
  do either only ['append/only] ['append] output :value
 ]
]
if: keyword [
 {If condition is not false or none, emit the given values}
 condition
 values "Value to emit or emit dialect block"
] [
 if :condition [
  either block? :values [
   emit output values
  ] [
   append/only output :values
  ]
 ]
]
either: keyword [
 "Depending on condition, emit on-true or on-false"
 condition
 on-true "Value to emit or emit dialect block"
 on-false "Value to emit or emit dialect block"
 /local values
] [
 values: either :condition [:on-true] [:on-false]
 either block? :values [
  emit output values
 ] [
  append/only output :values
 ]
]
apply: keyword [
 {Call a macro with the arguments in the supplied block}
 name
 arguments
] [
 name: get name
 if macro? :name [
  call-macro output arguments name
 ]
]
encode-text: keyword [
 "Encode and emit text"
 text
 encoding
] [
 either any-string? output [
  encode-text/to text encoding output
 ] [
  append output encode-text text encoding
 ]
]
decode-text: keyword [
 "Decode and emit text"
 text
 encoding
] [
 either any-string? output [
  decode-text/to text encoding output
 ] [
  append output decode-text text encoding
 ]
]
; needs optimization
foreach: keyword [
 "Emits values for each value in a series"
 word "Word or block of words to set each time (local)"
 data "The series to traverse"
 body "The values to emit at each iteration"
] [
 foreach :word data compose/only [emit output (body)]
]
; warning: /default handling, other differences with SWITCH
switch: keyword [
 {Selects a choice and emits the block that follows it}
 value "Value to search for"
 cases [block!] "Block of cases to search"
 /local case
] [
 parse cases [
  to value to block! set case block! (emit output case)
  |
  to /default skip set case block! (emit output case)
 ]
]

〈Append values to output according to the contents of values〉 ≡

parse values [
 some [
  ; lit-words and lit-paths are automatically converted by REBOL
  set value lit-word! (append output value)
  |
  set value lit-path! (append/only output value)
  |
  here: path! :here into [set value word! 'options] here: (
   value: get value
   either macro? :value [
    here: call-macro/options output here value
   ] [
    append output value/options
   ]
  ) :here
  |
  set value path! here: (
   either tmp: in emit-keywords value/1 [
    value/1: tmp
    here: do value output here
   ] [
    append output do value
   ]
  ) :here
  |
  set value word! here: (
   either tmp: in emit-keywords value [
    here: do tmp output here
   ] [
    value: get value
    either macro? :value [
     here: call-macro output here value
    ] [
     append output :value
    ]
   ]
  ) :here
  |
  set value paren! (append output do value)
  |
  set value skip (append/only output :value)
 ]
]
output

〈emit's locals〉 ≡

value here tmp

〈Define a macro for the EMIT dialect〉 ≡

spec*: make block! 3 + length? spec
types: make block! 3 + length? spec
parse spec [
 some [
  set name set-word! do-next [set type block! | (type: none)] (
   insert/only insert tail spec* name pop-result
   append/only types type
  )
  |
  set name word! [set type block! | (type: none)] (
   insert insert tail spec* to set-word! name none
   append/only types type
  )
  |
  [/local | /options] (unless mandatory [mandatory: length? types])
  |
  refinement! (make error! "Refinements not supported.")
  |
  skip
 ]
]
unless mandatory [mandatory: length? types]
spec*: construct spec*
bind body spec*
reduce [
 'macro spec* get spec* mandatory types
 either custom [
  func [output args] compose/deep/only [
   parse args [
    (body)
    args:
   ]
   args
  ]
 ] [
  body
 ]
 spec
]

〈macro's locals〉 ≡

spec* name val type types mandatory

〈Support functions〉 ≡

macro?: func [value] [
 all [
  block? :value
  parse value ['macro object! block! integer! block! [block! | function!] block!]
 ]
]
expect-arg: func [func-name arg-name types near] [
 make error! reduce ['script 'expect-arg func-name arg-name types near]
]
no-arg: func [func-name arg-name near] [
 make error! reduce ['script 'no-arg func-name arg-name none near]
]
call-macro: func [
 output [series! port!]
 args [block!]
 macro [block!]
 /options
 /local saved values value types name near
] [
 ; 1 2 3 4 5 6 7
 ; macro ctx defaults numargs types body/func spec
 saved: get macro/2
 either function? pick macro 6 [
  ; reset to defaults
  set macro/2 macro/3
  args: macro/6 output args
 ] [
  near: copy/part back args 5
  values: copy macro/3
  types: macro/5
  loop macro/4 [
   if empty? args [
    no-arg near/1 pick first macro/2 1 + index? types near
   ]
   set [value args] do/next args
   ; !!! problem !!!
   if all [types/1 not find types/1 type?/word :value] [
    expect-arg near/1 pick first macro/2 1 + index? types types/1 near
   ]
   values/1: :value
   values: next values
   types: next types
  ]
  set macro/2 head values
  if options [
   if empty? args [
    no-arg near/1 'options near
   ]
   set [value args] do/next args
   unless block? :value [
    expect-arg near/1 'options [block!] near
   ]
   options: copy skip first macro/2 macro/4 + 1
   types: copy types
   parse value [
    some [
     set name set-word! do-next (
      if name: find options to word! name [
       ; !!! problem !!!
       types: at head types index? name
       value: pop-result
       if all [types/1 not find types/1 type?/word :value] [
        expect-arg near/1 name/1 types/1 near
       ]
       set in macro/2 name/1 :value
      ]
     )
     |
     skip
    ]
   ]
  ]
  emit output macro/6
 ]
 set macro/2 saved
 args
]
make-keywords: func [
 keywords [block!]
 /local result name spec body actual-spec actual-body value
] [
 result: clear [ ]
 parse keywords [
  some [
   set name set-word! 'keyword block! block!
   (append result name)
  ]
 ]
 append result none
 result: context result
 parse keywords [
  some [
   set name set-word! 'keyword set spec block! set body block! (
    actual-spec: copy [
     output [series! port!]
     args [block!]
     /local
    ]
    actual-body: make block! 16
    parse spec [
     some [
      set value word! (
       append actual-spec value
       append actual-body compose/deep [
        set [(value) args] do/next args
       ]
      )
      |
      /local some [set value word! (append actual-spec value) | skip]
      |
      set value refinement! (
       insert find actual-spec /local value
      )
      |
      skip
     ]
    ]
    append actual-body body
    append actual-body 'args
    result/(to word! name): func actual-spec actual-body
   )
  ]
 ]
 result
]
emit-keywords: make-keywords [
 〈Dialect keywords〉
]