Indent handling in Perl 6

indent.p6

constant TABSTOP = 4;

class Suite {
    has @.items handles <push at_pos Numeric Bool>;
}

class X::Double::Indent::NotAllowed is Exception { }
class X::Partial::Indent is Exception { }
class X::Initial::Indent is Exception { }

grammar Indent::Savvy {
    regex TOP {
        :my @*SUITES = Suite.new;

        ^ <line>* $

        { make root_suite }
    }

    sub indent { @*SUITES.end }
    sub current_suite { @*SUITES[indent] }
    sub root_suite { @*SUITES[0] }
    sub add_to_current_suite($item) { current_suite.push($item) }

    sub increase_indent($new_suite) { @*SUITES.push($new_suite) }
    sub decrease_indent { pop @*SUITES }

    regex line {
        ^^ (<{ "\\x20" x TABSTOP }>*) (\h*) (\N*) $$ \n?

        {
            my $new_indent = $0.chars div TABSTOP;
            my $partial_indent = ~$1;
            my $line = ~$2;

            die X::Double::Indent::NotAllowed.new
                if $new_indent > indent() + 1;
            die X::Partial::Indent.new
                if $partial_indent;
            die X::Initial::Indent.new
                if !root_suite() && $new_indent > 0;

            if $new_indent > indent() {
                my $new_suite = Suite.new;
                add_to_current_suite($new_suite);
                increase_indent($new_suite);
            }
            elsif $new_indent < indent() {
                decrease_indent until indent() == $new_indent;
            }

            add_to_current_suite($line);
        }
    }
}

use Test;

sub parse($input) {
    Indent::Savvy.parse($input)
        or die "Couldn't parse input";
    return $/.ast;
}

sub parses_correctly($input, $message) {
    try {
        parse($input);
        ok 1, $message;

        CATCH {
            ok 0, $message;
        }
    }
}

sub fails_with($input, $ex_type, $message = $ex_type.^name) {
    try {
        parse($input);
        ok 0, $message;

        CATCH {
            ok $_ ~~ $ex_type, $message;
            default {
                die $_ unless $_ ~~ $ex_type;
            }
        }
    }
}

{
    my $input = q:to/EOF/;
    Level 1
    EOF

    parses_correctly($input, 'just a single line');
}

{
    my $input = q:to/EOF/;
    Level 1
        Level 2
    EOF

    parses_correctly($input, 'single indent');
}

{
    my $input = q:to/EOF/;
    Level 1
            Level 3!
    EOF

    fails_with($input, X::Double::Indent::NotAllowed);
}

{
    my $input = q:to/EOF/;
    Level 1
        Level 2
    EOF

    my $root = parse($input);

    isa_ok $root, Suite;
    is +$root, 2, 'two things were parsed:';
    isa_ok $root[0], Str, 'a string';
    isa_ok $root[1], Suite, 'and a suite';
}

{
    my $input = q:to/EOF/;
    Level 1
        Level 2
    Level 1 again
    EOF

    my $root = parse($input);

    is +$root, 3, 'three things were parsed:';
    isa_ok $root[0], Str, 'a string';
    isa_ok $root[1], Suite, 'a suite';
    isa_ok $root[2], Str, 'and a string';
}

{
    my $input = q:to/EOF/;
    Level 1
        Level 2
            Level 3
            Level 3
    Level 1 again
    EOF

    my $root = parse($input);

    is +$root, 3, 'three things on the top level';
    is +$root[1][1], 2, 'two lines on indent level 3';
}

{
    my $input = q:to/EOF/;
    Level 1
        Level 2
    Level 1 again
        Level 2 again
    EOF

    my $root = parse($input);

    is +$root, 4, 'four things on the top level';
    is +$root[3], 1, 'one line on the second indent';
}

{
    my $input = q:to/EOF/;
    Level 1
          Level 2 and a half!
    EOF

    fails_with($input, X::Partial::Indent);
}

{
    my $input = q:to/EOF/;
        Level 2 already on the first line!
    EOF

    fails_with($input, X::Initial::Indent);
}

done;

# $ perl6 indent.p6 
# ok 1 - just a single line
# ok 2 - single indent
# ok 3 - X::Double::Indent::NotAllowed
# ok 4 - The object is-a 'Suite'
# ok 5 - two things were parsed:
# ok 6 - a string
# ok 7 - and a suite
# ok 8 - three things were parsed:
# ok 9 - a string
# ok 10 - a suite
# ok 11 - and a string
# ok 12 - three things on the top level
# ok 13 - two lines on indent level 3
# ok 14 - four things on the top level
# ok 15 - one line on the second indent
# ok 16 - X::Partial::Indent
# ok 17 - X::Initial::Indent
# 1..17