# Copyright (C) 2005-2009, Parrot Foundation.

=head1 TITLE

PGE/Util.pir - useful rules for working with PGE grammars

=head1 DESCRIPTION

This module defines a number of useful rules for various
parsing tasks using PGE.

=head2 Functions

=cut

.namespace [ 'PGE';'Util' ]

.include 'cclass.pasm'

.sub "__onload" :load
    .local pmc p6meta
    p6meta = new 'P6metaclass'
    p6meta.'new_class'('PGE::Util', 'parent'=>'PGE::Grammar')
    .return ()
.end

=over 4

=item die(match, [, message [, ...]] )

Throws an exception at the current point in the match.  If message
doesn't end with a newline, also produces the line number and offset
of the match.

=cut

.sub 'die'
    .param pmc mob                                 # match object
    .param pmc list            :slurpy             # message arguments
    .param pmc dba             :slurpy :named

    .local pmc it
    .local string message
    message = ''
    it = iter list
  iter_loop:
    unless it goto iter_end
    $S0 = shift it
    message .= $S0
    goto iter_loop
  iter_end:

    # get a copy of the match object
    .local string target
    .local int pos
    $P0 = get_hll_global ['PGE'], 'Match'
    (mob, pos, target) = $P0.'new'(mob)
    $I0 = length message
    dec $I0
    $I0 = is_cclass .CCLASS_NEWLINE, message, $I0
    if $I0 goto throw_message

    .local int lines
    .local pmc line_number
    #  FIXME: use 'line_number' method instead?
    line_number = get_hll_global ['PGE';'Util'], 'line_number'
    (lines) = mob.line_number(pos)
    inc lines
    message .= ' at line '
    $S0 = lines
    message .= $S0
    message .= ', near "'
    $I0 = length target
    $I0 -= pos
    if $I0 < 10 goto add_position_1
    $I0 = 10
  add_position_1:
    $S0 = substr target, pos, $I0
    $S0 = escape $S0
    message .= $S0
    message .= "\"\n"

  throw_message:
    $P0 = new 'Exception'
    $P0 = message
    throw $P0

    mob.'to'(-3)
    .return (mob)
.end


=item warn(match, [, message [, ...]] )

Emits the list of messages to stderr.

=cut

.sub 'warn'
    .param pmc mob                                 # match object
    .param pmc list            :slurpy             # message arguments

    .local pmc it
    .local string message
    message = ''
    it = iter list
  iter_loop:
    unless it goto iter_end
    $S0 = shift it
    message .= $S0
    goto iter_loop
  iter_end:

    # get a copy of the match object
    .local string target
    .local int pos
    $P0 = get_hll_global ['PGE'], 'Match'
    (mob, pos, target) = $P0.'new'(mob)
    $I0 = length message
    dec $I0
    $I0 = is_cclass .CCLASS_NEWLINE, message, $I0
    if $I0 goto emit_message

    .local int lines
    .local pmc line_number
    #  FIXME: use 'line_number' method instead?
    line_number = get_hll_global ['PGE';'Util'], 'line_number'
    (lines) = mob.line_number(pos)
    inc lines
    message .= ' at line '
    $S0 = lines
    message .= $S0
    message .= "\n"
  emit_message:
    $P0 = getinterp
    $P1 = $P0.'stderr_handle'()
    $P1.'print'(message)

    mob.'to'(pos)
    .return (mob)
.end



=item line_number(match [, pos])

Return the line number and offset of the of the line corresponding to
offset C<pos> in the string targeted by C<match>.  If C<pos> isn't
supplied, then use the C<from> value of C<match> as the offset.
For this function the line number for the first line in the
string is treated as '0'.

=cut

.sub 'line_number'
    .param pmc match
    .param int pos             :optional
    .param int has_pos         :opt_flag

    if has_pos goto have_pos
    pos = match.'from'()
  have_pos:

    # count newlines to the current position of the parse
    .local int npos, lines
    .local string target
    $P99 = getattribute match, '$.target'
    target = $P99
    npos = 0
    lines = 0
  newline_loop:
    $I0 = find_cclass .CCLASS_NEWLINE, target, npos, pos
    if $I0 >= pos goto newline_done
    $S0 = substr target, $I0, 2
    npos = $I0 + 1
    inc lines
    if $S0 != "\r\n" goto newline_loop
    inc npos
    goto newline_loop
  newline_done:
    .return (lines, npos)
.end


=item split(regex, string [, count])

Split the string where the regex matches, returning an array. Optionally limit
the number of splits.

=cut

.sub 'split'
    .param pmc    regex
    .param string str
    .param int    count     :optional
    .param int    has_count :opt_flag

    .local pmc result, match
    .local int pos, n

    result = new 'ResizablePMCArray'
    pos    = 0
    n      = 1

split_loop:
    match = regex(str, 'continue'=>pos)
    ##  if regex not found in target, we're done
    unless match goto split_end

    ##  save substring up to current match
    $I0 = match.'from'()
    $I0 -= pos
    $S0 = substr str, pos, $I0
    push result, $S0
    pos = match.'to'()

    .local pmc captures
    captures = match.'list'()
    if null captures goto capture_end
    $I0 = elements captures
    $I1 = 0
capture_loop:
    if $I1 == $I0 goto capture_end
    $P0 = captures[$I1]
    $S0 = $P0
    push result, $S0
    inc $I1
    goto capture_loop
capture_end:

    ##  are we counting matches?
    unless has_count goto split_loop
    ##  check if we've already split enough
    inc n
    if n < count goto split_loop
    # goto split_end

split_end:
    ##   save string from end of last match to end of string
    $S0 = substr str, pos
    if $S0 == "" goto end
    push result, $S0

end:
   .return (result)
.end

=item unique()

Returns a unique integer on every call.

=cut

.sub '_unique' :anon :immediate
    $P0 = new ['Integer'], 0
    .return ($P0)
.end

.sub 'unique'
    .param string fmt :optional
    .const 'Sub' $P0 = '_unique'
    $I0 = $P0
    inc $P0
    $S0 = $I0
    $S0 = concat fmt, $S0
    .return ($S0)
.end

=item pir_str_escape(string)

Returns a PIR string for a given string contents.

NOTE: this does B<NOT> securely escape strings.

=cut

.sub 'pir_str_escape'
    .param string str

    $S0 = escape str
    $S0 = concat '"', $S0
    $S0 = concat $S0, '"'

    $I0 = index $S0, "\\x"
    $I0 = $I0 == -1
    $I1 = index $S0, "\\u"
    $I1 = $I1 == -1
    $I2 = and $I0, $I1
    if $I2 goto done_unicode
        $S0 = concat "unicode:", $S0
    done_unicode:

    .return ($S0)
.end


=item pir_key_escape(args)

Constructs a PIR key using the strings passed as arguments.
For example, C<pir_key_escape('Foo', 'Bar')> returns C<["Foo";"Bar"]>.

=cut

.sub 'pir_key_escape'
    .param pmc args :slurpy
    .local pmc retv, it
    .local string sep
    retv = new 'StringBuilder'
    it   = iter args
    push retv, '['
    sep = ''
  loop:
    unless it goto end_loop
    push retv, sep
    $S0 = shift it
    $S0 = 'pir_str_escape'($S0)
    push retv, $S0
    sep = ';'
    goto loop
  end_loop:
    push retv, ']'
    .return (retv)
.end

=back

=cut


# Local Variables:
#   mode: pir
#   fill-column: 100
# End:
# vim: expandtab shiftwidth=4 ft=pir: