├── .gitignore ├── .travis.yml ├── Changes ├── DEBUGGING.pod ├── META6.json ├── README.md ├── examples ├── perl6-dumper └── sample.p6 ├── lib └── Perl6 │ ├── Element.pod │ ├── Parser.pm6 │ └── Parser │ └── Factory.pm6 ├── t ├── 00-class-hierarchy.t ├── 01-nqp-tree.t ├── 02-perl6-tree.t ├── 03-perl6-threaded-tree.t ├── 04-iterator.t ├── 05-editing.t ├── 06-phasers-check.t ├── 10-multi-declarator.t ├── 11-package-declarator.t ├── 12-regex-declarator.t ├── 13-scope-declarator.t ├── 14-type-declarator.t ├── 15-routine-declarator.t ├── 16-quote.t ├── 17-comments.t ├── 18-declaration.t ├── 19-operators.t ├── 20-pair.t ├── 21-pod.t ├── 22-regex.t ├── 23-single-term.t ├── 24-subroutine.t ├── 999-regression.t ├── README.pod ├── corpus │ ├── rosetta-1.t │ ├── rosetta-a.t │ └── rosetta-b.t └── lib │ └── Utils.pm6 └── xt └── meta_info.t /.gitignore: -------------------------------------------------------------------------------- 1 | *.swp 2 | lib/.precomp/ 3 | .precomp/ 4 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: perl6 2 | perl6: 3 | - latest 4 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Revision history for Perl6-Parser 2 | 3 | {{$NEXT}} 4 | 5 | 0.3.0 2019-03-04T15:32:10+09:00 6 | 7 | - Stop compiling CHECK and BEGIN blocks. 8 | 9 | 0.2.1 2019-03-02T14:34:58+09:00 10 | 11 | - Uncomment a few more tests, adding some more pure-perl stuff next. 12 | 13 | 0.2.0 2019-02-24T14:29:06+09:00 14 | - Fixing newly-generated redeclaration errors in test suites. 15 | -------------------------------------------------------------------------------- /DEBUGGING.pod: -------------------------------------------------------------------------------- 1 | =begin DEBUGGING-NOTES 2 | 3 | Abandon all sanity, ye who read this file :) 4 | 5 | =begin Philosophy 6 | 7 | Keep it stupidly simple. Put differently, the old adage is that you have to be 8 | twice as clever to debug code than to write it. So I'm deliberately keeping 9 | this file at least 4x simpler than I would ordinarily make it, so when I come 10 | back to debug a whitespace issue in 2 weeks' time I won't waste 2 weeks getting 11 | back up to speed on what the code does. 12 | 13 | =item Acme dynamite kit 14 | 15 | The code does everything in its power to generate a syntax tree instead of 16 | blowing up, so you can see what it actually is doing. Stack traces are great, 17 | but they can blow up before the actual problem that you're debugging, or they 18 | just get in the way of viewing the rest of the tree. Finding that a brace is 19 | out of place is great, but when all you have is a stacktrace and don't know 20 | which brace it is in a 3-deep block, it does no good. 21 | 22 | =item consistency 23 | 24 | Every match from the Perl 6 internals has a 'method _foo' counterpart, with 25 | only the exceptions of numbers and possibly strings. 26 | 27 | Almost every internal method has the same general pattern of: 28 | 29 | my Perl6::Element @child; # <-- all tokens go in this variable. 30 | given $p { 31 | when assert-hash-keys( $p, [< xxx yyy >] ) { 32 | @child.append( ... ) 33 | } 34 | default { 35 | ... 36 | } 37 | } 38 | 39 | The few exceptions to the pattern are generally where the extra given(} layer 40 | would push the indent too far to the right. I'm old-school and keep things to 41 | an 80xN terminal. 42 | 43 | =item why don't I just subclass the match? 44 | 45 | It'd be so much easier, right? Just add a get-tokens() method for each match 46 | and be done with it. 47 | 48 | This'd be great, and what I wanted to do, but .. NQP objects aren't Perl 6 49 | objects, and aren't constrained to obey the same laws. I B play with the 50 | underlying NQP:: methods, but I'd prefer not to, mostly because of backwards 51 | compatibiity. 52 | 53 | =item Why not just add the match object to the class? 54 | 55 | See above. NQP objects don't play well with others. I'd love to, and it may 56 | very well be possible to do this in a way I'm not sufficiently clever to think 57 | of, but see also KISS. 58 | 59 | =back 60 | 61 | You'll see I use given-when all over the place, even when I probably should be 62 | using a simple if-then-else statement. There are two basic reasons for this 63 | practice. 64 | 65 | =item refactoring 66 | 67 | It's quicker to copy/paste when ... { } blocks than to copy an 'if...' block 68 | and change the 'if' to 'elsif'. I'm well aware that I should be using a more 69 | sophisticated way of handling the validation, but again, keeping it simple. 70 | 71 | =item debugging 72 | 73 | When I first started out with this, I spent 2 hours debugging what turned out 74 | to be my writing: 75 | 76 | if ... { 77 | } 78 | if ... { 79 | } 80 | else { 81 | } 82 | 83 | Twice I rewrote this to if ... { } elsif ... { } ... else { }, then I got wise 84 | and rewrote the entire block as when... when... default { }, so I couldn't 85 | possibly get into the if...if... situation again. 86 | 87 | =back 88 | 89 | =end Philosophy 90 | 91 | =begin Deep-diving 92 | 93 | So you want to fix a bug. Wonderful news, and I wish you the best of luck. 94 | Here's some things to keep in mind when going about it: 95 | 96 | =item .dump-tree() is your friend. 97 | 98 | I've added some helpful debugging hints to this tool, B adding 99 | useful line numbers to the trace data. 100 | 101 | For instance, say you're wondering why 'if { }' repeats itself as 'if { }{}if'. 102 | First off, it's very likely that '{}if' is actually a whitespace block that 103 | I've miscalculated the boundaries of; this happens with depressing frequency. 104 | 105 | Look at the output from .dump-tree($tree) for the telltale 'WS' and 'G' markers. 106 | The 'WS' and line number will tell you "Hey, look at line XXXX! There's a 107 | Perl6::WS object that's been told to capture something that's not whitespace!" 108 | 109 | The 'G' marker will tell you "Hey, the code is returning the same block twice!" 110 | because it'll say token X doesn't overlap token Y. 111 | 112 | =item key-bounds $m.hash. 113 | 114 | This is a simple tool that dumps the 'from', 'to' and contents of a given hash 115 | value or raw string that you give it from a NQPMatch object. 116 | 117 | It will lock up mysteriously if you hand it a .list, so don't be surprised when 118 | your first few tries to debug something infinihangs, as we say in Perl6 119 | parlance. This is because NQPMatch has very few defenses against incorrect 120 | accesses, and if you use the wrong method it will hang. 121 | 122 | If you keep in mind those caveats, and being careful about 'say $m.dump' it's 123 | generally well-behaved. 124 | 125 | =item My god, it's full of \s*. 126 | 127 | Whitespace is the biggest pain in the arse for this process. The Perl 6 128 | grammar only needs whitespace in a few places, so the rest of the grammar 129 | treats WS rather cavalierly. Sometimes a token will have whitespace after 130 | it, sometimes a similar token won't, sometimes it'll have whitespace in the 131 | match 2 layers up. 132 | 133 | What's important to remember is that you B have $match.orig to fall 134 | back on, and can s/// that to your heart's content. I don't rely on it 135 | very much, because I figure the substr() options on the actual match tokens 136 | are faster because they're over small blocks of text, but I'd be happy to 137 | be proved wrong. 138 | 139 | Most of your time fixing a bug will probably be spent lo 140 | 141 | =back 142 | 143 | =end 144 | 145 | =end DEBUGGING-NOTES 146 | -------------------------------------------------------------------------------- /META6.json: -------------------------------------------------------------------------------- 1 | { 2 | "auth" : "github:drforr", 3 | "authors" : [ 4 | "Jeffrey Goff " 5 | ], 6 | "build-depends" : [ ], 7 | "depends" : [ ], 8 | "description" : "Parse Perl 6 from within Perl 6", 9 | "license" : "Artistic-2.0", 10 | "meta6" : "0", 11 | "name" : "Perl6::Parser", 12 | "perl" : "6.c", 13 | "provides" : { 14 | "Perl6::Parser" : "lib/Perl6/Parser.pm6", 15 | "Perl6::Parser::Factory" : "lib/Perl6/Parser/Factory.pm6" 16 | }, 17 | "resources" : [ ], 18 | "source-url" : "https://github.com/drforr/perl6-Perl6-Parser.git", 19 | "support" : { 20 | "source" : "https://github.com/drforr/perl6-Perl6-Parser" 21 | }, 22 | "tags" : [ 23 | "parse", 24 | "parser", 25 | "parsing" 26 | ], 27 | "test-depends" : [ 28 | "Test" 29 | ], 30 | "version" : "0.3.0" 31 | } 32 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Build Status](https://travis-ci.org/drforr/perl6-Perl6-Parser.svg?branch=master)](https://travis-ci.org/drforr/perl6-Perl6-Parser) 2 | 3 | NAME 4 | ==== 5 | 6 | Perl6::Parser - Extract a Perl 6 AST from the NQP Perl 6 Parser 7 | 8 | SYNOPSIS 9 | ======== 10 | 11 | my $pt = Perl6::Parser.new; 12 | my $source = Q:to[_END_]; 13 | code-goes-here(); 14 | that you( $want-to, $parse ); 15 | _END_ 16 | 17 | # Get a fully-parsed data tree 18 | # 19 | my $tree = $pt.to-tree( $source ); 20 | say $pt.dump-tree( $tree ); 21 | 22 | # Return only the displayed tokens (including whitespace) in the document 23 | # 24 | my @token = $pt.to-tokens-only( $source ); 25 | 26 | # Return all tokens and structures in the document 27 | # 28 | my @everything = $pt.to-list( $source ); 29 | 30 | # This used to fire BEGIN and CHECK phasers, it no longer does so. 31 | 32 | # As of 2019-03-05 $*PURE-PERL has gone away, instead all lines that *can* 33 | # call the pure Perl 6 parser *do* call it, and I'm replacing calls to the 34 | # internal Perl6 nqp parser with calls to regular Perl 6 code. This method 35 | # will eventually get rid of some code that I use to bypass BEGIN and CHECK 36 | # phasers, but that's a ways off. 37 | 38 | DESCRIPTION 39 | =========== 40 | 41 | Uses the built-in Perl 6 parser exposed by the internal nqp module, so that you can parse Perl 6 using Perl 6 itself. If it scares you... well, it probably should. Assuming everything works out, you'll get back a Perl 6 object tree that exactly mirrors your source file's layout, with every bit of whitespace, POD, and code given one or more tokens. 42 | 43 | Redisplaying it becomes a matter of calling the `to-string()` method on the tree, which passes an optional formatting hashref down the tree. You can use the format methods as they are, or add a role or subclass the objects created as you see fit to create new objects. 44 | 45 | This process **will** be simplified and encapsulated in the near future, as reformatting Perl 6 code was what this rather extensive module was designed to do. 46 | 47 | I've added fairly extensive debugging documentation to the [README.md](README.md) of this module, along with an internal [DEBUGGING.pod](DEBUGGING.pod) file talking about what you're seeing here, and why on **earth** didn't I do it **this** way? I have my reasons, but can be talked out of it with a good argument. 48 | 49 | Please note that this does compile your code, but it takes the precaution of munging `BEGIN` and `CHECK` phasers into `ENTER` instead so that it won't run at compile time. 50 | 51 | As it stands, the `.parse` method returns a deeply-nested object representation of the Perl 6 code it's given. It handles the regex language, but not the other braided languages such as embedded blocks in strings. It will do so eventually, but for the moment I'm busy getting the grammar rules covered. 52 | 53 | While classes like [EClass](EClass) won't go away, their parent classes like [DecInteger](DecInteger) will remove them from the tree once their validation job has been done. For example, while the internals need to know that [$/ ]($/ ) (the exponent for a scientific-notation number) hasn't been renamed or moved elsewhere in the tree, you as a consumer of the [DecInteger](DecInteger) class don't need to know that. The `DecInteger.perl6` method will delete the child classes so that we don't end up with a **horribly** cluttered tree. 54 | 55 | Classes representing Perl 6 object code are currently in the same file as the main [Perl6::Parser](Perl6::Parser) class, as moving them to separate files caused a severe performance penalty. When the time is right I'll look at moving these to another location, but as shuffling out 20 classes increased my runtime on my little ol' VM from 6 to 20 seconds, it's not worth my time to break them out. And besides, having them all in one file makes editing en masse easier. 56 | 57 | DEBUGGING 58 | ========= 59 | 60 | Some notes on how I go about debugging various issues follow. 61 | 62 | Let's take the case of the following glitch: The terms `$_` and `0` don't show up in the fragment `[$_, 0 .. 100]`, for various reasons, mostly because there's a branch that's either not being traversed, or simply a term has gone missing. 63 | 64 | The first thing is to break the offending bit of code out so it's easier to debug. The test file I make to do this (usually an existing test file I've got lying around) looks partially like this, with boilerplate stripped out: 65 | 66 | my $source = Q:to[_END_]; 67 | my @a; @a[$_, 0 .. 100]; 68 | _END_ 69 | my $p = $pt.parse( $source ); 70 | say $p.dump; 71 | my $tree = $pt.build-tree( $p ); 72 | say $pt.dump-tree($tree); 73 | is $pt.to-string( $tree ), $source, Q{formatted}; 74 | 75 | Already a few things might stand out. First, the code inside the here-doc doesn't actually do anything, it'll never print anything to the screen or do anything interesting. That's not the point at this stage in the game. At this point all I need is a syntactically valid bit of Perl 6 that has the constructs that reproduce the bug. I don't care what the code actually does in the real world. 76 | 77 | Second, I'm not doing anything that you as a user of the class would do. As a user of a the class, all you have to do is run the to-string() method, and it does what you want. I'm breaking things down into their component steps. 78 | 79 | (side note - This will probably have changed in detail since I wrote this text - Consult your nearest test file for examples of current usage.) 80 | 81 | Internally, the library takes sevaral steps to get to the nicely objectified tree that you see on your output. The two important steps in our case are the `.parse( 'text goes here' )` method call, and `.build-tree( $parse-tree )`. 82 | 83 | The `.parse()` call returns a very raw [NQPMatch](NQPMatch) object, which is the Perl 6 internal we're trying to reparse into a more useful form. Most of the time you can call `.dump()` on this object and get back a semi-useful object tree. On occasion this **will** lock up, most often because you're trying to `.dump()` a [list](list) accessor, and that hasn't been implemented for NQPMatch. The actual `list` accessor works, but the `.dump()` call will not. A simple workaround is to call `$p.list.[0].dump` on one of the list elements inside, and hope there is one. 84 | 85 | Again, these are NQP internals, and aren't quite as stable as the Perl 6 main support layer. 86 | 87 | Once you've got a dump of the offending area, it'll look something like this: 88 | 89 | - postcircumfix: [0, $_ ... 100] 90 | - semilist: 0, $_ ... 100 91 | - statement: 1 matches 92 | - EXPR: ... 93 | - 0: , 94 | - 0: 0 95 | - value: 0 96 | # ... 97 | - 1: $_ 98 | - variable: $_ 99 | - sigil: $ 100 | # ... 101 | - infix: , 102 | - sym: , 103 | - O: 104 | - OPER: , 105 | 106 | The full thing will probably go on for a few hundred lines. Hope you've got scrollback, or just use tmux as I do. 107 | 108 | With this you can almost immediately jump to what appears to be the offending expression, albeit with a bit of interpretation. You'll see `- 0: 0` and `- 1: $_`, and these are exactly the two bits of syntax that have gone missing in our example. Down below you'll see `- infix: ,` which is where the comma separator goes. 109 | 110 | We can combine these facts and reason that we have to search for the bit of code where we find an `infix` operator and two list elements. The `- 0` and `- 1` bits tell us that we're dealing with two list elements, and the `- infix` and `- OPER` bits tell us that we've also got two hash keys to find. 111 | 112 | Look down in this file for a `assert-hash-keys()` call attempting to assert the existence of exactly a `infix` and `OPER` tag. There may actually be other hash keys in this data structure, as `.dump()` doesn't report unused hash keys; this caused me a deal of confusion. 113 | 114 | Eventually you'll find in the `_EXPR()` method this bit of code: (due to change, obviously) 115 | 116 | when self.assert-hash-keys( $_, [< infix OPER >] ) { 117 | @child.append( 118 | self._infix( $_.hash. ) 119 | ) 120 | } 121 | 122 | You're most welcome to use the Perl 6 debugger, but what I just do is add a `say 1;` statement just above the `@child.append()` method call (and anywhere else I find a `infix` and `OPER` hash key hiding, because there are multiple places in the code that match an `infix` and `OPER` hash key) and rerun the test. 123 | 124 | Now that we've confirmed where the element `should` be getting generated, but somehow isn't, we need to look at the actual text to verify that this is actually where the `$_` and `0` bits are being matched, and we can use another internal debugging tool to help out with that. Add these lines: 125 | 126 | key-bounds $_.list.[0]; 127 | key-bounds $_.hash.; 128 | key-bounds $_.list.[1]; 129 | key-bounds $_.hash.; 130 | key-bounds $_; 131 | 132 | And rerun your code. Or make the appropriate calls in the debugger, it's your funeral :) What this function does is return something that looks like this: 133 | 134 | 45 60 [[0, $_ ... 100]] 135 | 136 | The two numbers are the glyphs where the matched text starts and stops, respectively. The bit in between [..] (in this case seemingly doubled, but that's because the text is itself bracketed) is the actual text that's been matched. 137 | 138 | So, by now you know what the text you're matching actually looks like, where it is in the string, and maybe eve have a rough idea of why what you're seeing isn't being displayedk 139 | 140 | With any luck you'll see that the code simply isn't adding the variables to the list that is being glommed onto the `@child` array, and can add it. 141 | 142 | By convention, when you're dumping a `- semilist:` match, you can always call `self._semilist( $p.hash. )` in order to get back the list of tokens generated by matching on the `$p.hash.semilist` object. You might be wondering why I don't just subclass NQPMatch and add this as a generic multimethod or dispatch it in some other way. 143 | 144 | Well, the reason it's called `NQP` is because it's Not Quite Perl 6, and like poor Rudolph, Perl 6 won't let NQP objects join in any subclasing or dispatching games, because it's Not Quite Perl. And yes, this leads to quite a bit of frustruation. 145 | 146 | Let's assume that you've found the `$_.list.[0]` and `$_.hash. ` handlers, and now need to add whitespace between the `$_` and `0` elements in your generated code. 147 | 148 | Now we turn to the rather bewildering array of methods on the `Perl6::WS` class. This profusion of methods is because of two things: 149 | 150 | * Whitespace can be inside a token, before or after a token, or even simply not be there because it's actually inside the L object one or more levels up, so you're never B sure where your whitespace will be hiding. 151 | * If each of the ~50 classes handled whitespace on its own, I'd have to track down each of the ~50 whitespace-generating methods in order to see which of the whitespace calls is being made. This way I can just look for L and know that those are the only B places where a whitespace token could be being generated. 152 | 153 | METHODS 154 | ======= 155 | 156 | * _roundtrip( Str $perl-code ) returns Perl6::Parser::Root 157 | 158 | Given a string containing valid Perl 6 code ... well, return that code. This is mostly a shortcut for testing purposes, and wil probably be moved out of the main file. 159 | 160 | * to-tree( Str $source ) 161 | 162 | This is normally what you want, it returns the Perl 6 parsed tree corresponding to your source code. 163 | 164 | * parse( Str $source ) 165 | 166 | Returns the underlying NQPMatch object. This is what gets passed on to `build-tree()` and every other important method in this module. It does some minor wizardry to call the Perl 6 reentrant compiler to compile the string you pass it, and return a match object. Please note that it **has** to compile the string in order to validate things like custom operators, so this step is **not** optional. 167 | 168 | * build-tree( Mu $parsed ) 169 | 170 | Build the Perl6::Element tree from the NQPMatch object. This is the core, and runs the factory which silly-walks the match tree and returns one or more tokens for every single match entry it finds, and **more**. 171 | 172 | * consistency-check( Perl6::Element $root ) 173 | 174 | Check the integrity of the data structure. The Factory at its core puts together the structure very sloppily, to give the tree every possible chance to create actual quasi-valid text. This method makes sure that the factory returned valid tokens, which often doesn't happen. But since you really want to see the data round-tripped, most users don't care what the tree loos like internally. 175 | 176 | * to-string( Perl6::Element $tree ) returns Str 177 | 178 | Call .perl6 on each element of the tree. You can subclass or override this method in any class as you see fit to properly pretty-print the methods. Right now it's awkward to use, and will probably be removed in favor of an upcoming [Perl6::Tidy](Perl6::Tidy) module. That's why I wrote this yak.. er, module in the first place. 179 | 180 | * dump-tree( Perl6::Element $root ) returns Str 181 | 182 | Given a Perl6::Document (or other) object, return a full nested tree of text detailing every single token, for debugging purposes. 183 | 184 | * ruler( Str $source ) 185 | 186 | Purely a debugging aid, it puts an ASCII ruler above your source so that you don't have to go blind counting whitespace to figure out which ' ' a given token belongs to. As a courtesy it also makes newlines visible so you don't have to count those separately. I might use the visible space character later to make it easier to read, if I happen to like it. 187 | 188 | Further-Information 189 | =================== 190 | 191 | For further information, there's a [DEBUGGING.pod](DEBUGGING.pod) file detailing how to go about tracing down a bug in this module, and an extensive test suite in [t/README.pod](t/README.pod) with some ideas of how I'm structuring the test suite. 192 | 193 | -------------------------------------------------------------------------------- /examples/perl6-dumper: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use lib '../lib'; 4 | use Perl6::Parser; 5 | 6 | sub MAIN(Str $filename, Bool :$ruler = False) { 7 | my $source = $filename.IO.slurp; 8 | my $pp = Perl6::Parser.new; 9 | if $ruler { 10 | say $pp.ruler( $source ); 11 | return; 12 | } 13 | my $tree = $pp.to-tree( $source ); 14 | 15 | say $pp.dump-tree( $tree ); 16 | } 17 | -------------------------------------------------------------------------------- /examples/sample.p6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | if !@*ARGS { 4 | say "Usage: $*PROGRAM-NAME go"; 5 | exit; 6 | } 7 | 8 | foo; 9 | 10 | sub foo() { 11 | say "Hi from sub foo!"; 12 | } 13 | -------------------------------------------------------------------------------- /lib/Perl6/Element.pod: -------------------------------------------------------------------------------- 1 | =begin pod 2 | 3 | =begin NAME 4 | 5 | Perl6::Element - Root of the token hierarchy 6 | 7 | =end NAME 8 | 9 | =begin DESCRIPTION 10 | 11 | =end DESCRIPTION 12 | 13 | =begin METHODS 14 | 15 | =item C<_dump> 16 | 17 | Returns the content of the element itself, B all internal pointers pointed at itself, to cut down on debugging noise. 18 | 19 | =cut 20 | 21 | =end 22 | 23 | =end pod 24 | -------------------------------------------------------------------------------- /lib/Perl6/Parser.pm6: -------------------------------------------------------------------------------- 1 | =begin pod 2 | 3 | =begin NAME 4 | 5 | Perl6::Parser - Extract a Perl 6 AST from the NQP Perl 6 Parser 6 | 7 | =end NAME 8 | 9 | =begin SYNOPSIS 10 | 11 | my $pt = Perl6::Parser.new; 12 | my $source = Q:to[_END_]; 13 | code-goes-here(); 14 | that you( $want-to, $parse ); 15 | _END_ 16 | 17 | # Get a fully-parsed data tree 18 | # 19 | my $tree = $pt.to-tree( $source ); 20 | say $pt.dump-tree( $tree ); 21 | 22 | # Return only the displayed tokens (including whitespace) in the document 23 | # 24 | my @token = $pt.to-tokens-only( $source ); 25 | 26 | # Return all tokens and structures in the document 27 | # 28 | my @everything = $pt.to-list( $source ); 29 | 30 | # This used to fire BEGIN and CHECK phasers, it no longer does so. 31 | 32 | # As of 2019-03-05 $*PURE-PERL no longer exists, because it's still 33 | # a bit of a misnomer. And it tends to mess with the test suites a bit. 34 | # I've instead chosen to just make it the default, and add a comment to 35 | # lines that go directly to the pure Perl6 parser. 36 | 37 | =end SYNOPSIS 38 | 39 | =begin DESCRIPTION 40 | 41 | Uses the built-in Perl 6 parser exposed by the internal nqp module, so that you can parse Perl 6 using Perl 6 itself. If it scares you... well, it probably should. Assuming everything works out, you'll get back a Perl 6 object tree that exactly mirrors your source file's layout, with every bit of whitespace, POD, and code given one or more tokens. 42 | 43 | Redisplaying it becomes a matter of calling the C method on the tree, which passes an optional formatting hashref down the tree. You can use the format methods as they are, or add a role or subclass the objects created as you see fit to create new objects. 44 | 45 | This process B be simplified and encapsulated in the near future, as reformatting Perl 6 code was what this rather extensive module was designed to do. 46 | 47 | I've added fairly extensive debugging documentation to the L of this module, along with an internal L file talking about what you're seeing here, and why on B didn't I do it B way? I have my reasons, but can be talked out of it with a good argument. 48 | 49 | Please note that this does compile your code, but it takes the precaution of munging C and C phasers into C instead so that it won't run at compile time. 50 | 51 | As it stands, the C<.parse> method returns a deeply-nested object representation of the Perl 6 code it's given. It handles the regex language, but not the other braided languages such as embedded blocks in strings. It will do so eventually, but for the moment I'm busy getting the grammar rules covered. 52 | 53 | While classes like L won't go away, their parent classes like L will remove them from the tree once their validation job has been done. For example, while the internals need to know that L<< $/ >> (the exponent for a scientific-notation number) hasn't been renamed or moved elsewhere in the tree, you as a consumer of the L class don't need to know that. The C method will delete the child classes so that we don't end up with a B cluttered tree. 54 | 55 | Classes representing Perl 6 object code are currently in the same file as the main L class, as moving them to separate files caused a severe performance penalty. When the time is right I'll look at moving these to another location, but as shuffling out 20 classes increased my runtime on my little ol' VM from 6 to 20 seconds, it's not worth my time to break them out. And besides, having them all in one file makes editing en masse easier. 56 | 57 | =end DESCRIPTION 58 | 59 | =begin DEBUGGING 60 | 61 | Some notes on how I go about debugging various issues follow. 62 | 63 | Let's take the case of the following glitch: The terms C<$_> and C<0> don't show up in the fragment C<[$_, 0 .. 100]>, for various reasons, mostly because there's a branch that's either not being traversed, or simply a term has gone missing. 64 | 65 | The first thing is to break the offending bit of code out so it's easier to debug. The test file I make to do this (usually an existing test file I've got lying around) looks partially like this, with boilerplate stripped out: 66 | 67 | my $source = Q:to[_END_]; 68 | my @a; @a[$_, 0 .. 100]; 69 | _END_ 70 | my $p = $pt.parse( $source ); 71 | say $p.dump; 72 | my $tree = $pt.build-tree( $p ); 73 | say $pt.dump-tree($tree); 74 | is $pt.to-string( $tree ), $source, Q{formatted}; 75 | 76 | Already a few things might stand out. First, the code inside the here-doc doesn't actually do anything, it'll never print anything to the screen or do anything interesting. That's not the point at this stage in the game. At this point all I need is a syntactically valid bit of Perl 6 that has the constructs that reproduce the bug. I don't care what the code actually does in the real world. 77 | 78 | Second, I'm not doing anything that you as a user of the class would do. As a user of a the class, all you have to do is run the to-string() method, and it does what you want. I'm breaking things down into their component steps. 79 | 80 | (side note - This will probably have changed in detail since I wrote this text - Consult your nearest test file for examples of current usage.) 81 | 82 | Internally, the library takes sevaral steps to get to the nicely objectified tree that you see on your output. The two important steps in our case are the C<.parse( 'text goes here' )> method call, and C<.build-tree( $parse-tree )>. 83 | 84 | The C<.parse()> call returns a very raw L object, which is the Perl 6 internal we're trying to reparse into a more useful form. Most of the time you can call C<.dump()> on this object and get back a semi-useful object tree. On occasion this B lock up, most often because you're trying to C<.dump()> a L accessor, and that hasn't been implemented for NQPMatch. The actual C accessor works, but the C<.dump()> call will not. A simple workaround is to call C<$p.list.[0].dump> on one of the list elements inside, and hope there is one. 85 | 86 | Again, these are NQP internals, and aren't quite as stable as the Perl 6 main support layer. 87 | 88 | Once you've got a dump of the offending area, it'll look something like this: 89 | 90 | - postcircumfix: [0, $_ ... 100] 91 | - semilist: 0, $_ ... 100 92 | - statement: 1 matches 93 | - EXPR: ... 94 | - 0: , 95 | - 0: 0 96 | - value: 0 97 | # ... 98 | - 1: $_ 99 | - variable: $_ 100 | - sigil: $ 101 | # ... 102 | - infix: , 103 | - sym: , 104 | - O: 105 | - OPER: , 106 | 107 | The full thing will probably go on for a few hundred lines. Hope you've got scrollback, or just use tmux as I do. 108 | 109 | With this you can almost immediately jump to what appears to be the offending expression, albeit with a bit of interpretation. You'll see C<- 0: 0> and C<- 1: $_>, and these are exactly the two bits of syntax that have gone missing in our example. Down below you'll see C<- infix: ,> which is where the comma separator goes. 110 | 111 | We can combine these facts and reason that we have to search for the bit of code where we find an C operator and two list elements. The C<- 0> and C<- 1> bits tell us that we're dealing with two list elements, and the C<- infix> and C<- OPER> bits tell us that we've also got two hash keys to find. 112 | 113 | Look down in this file for a C call attempting to assert the existence of exactly a C and C tag. There may actually be other hash keys in this data structure, as C<.dump()> doesn't report unused hash keys; this caused me a deal of confusion. 114 | 115 | Eventually you'll find in the C<_EXPR()> method this bit of code: (due to change, obviously) 116 | 117 | when self.assert-hash-keys( $_, [< infix OPER >] ) { 118 | @child.append( 119 | self._infix( $_.hash. ) 120 | ) 121 | } 122 | 123 | You're most welcome to use the Perl 6 debugger, but what I just do is add a C statement just above the C<@child.append()> method call (and anywhere else I find a C and C hash key hiding, because there are multiple places in the code that match an C and C hash key) and rerun the test. 124 | 125 | Now that we've confirmed where the element C be getting generated, but somehow isn't, we need to look at the actual text to verify that this is actually where the C<$_> and C<0> bits are being matched, and we can use another internal debugging tool to help out with that. Add these lines: 126 | 127 | key-bounds $_.list.[0]; 128 | key-bounds $_.hash.; 129 | key-bounds $_.list.[1]; 130 | key-bounds $_.hash.; 131 | key-bounds $_; 132 | 133 | And rerun your code. Or make the appropriate calls in the debugger, it's your funeral :) What this function does is return something that looks like this: 134 | 135 | 45 60 [[0, $_ ... 100]] 136 | 137 | The two numbers are the glyphs where the matched text starts and stops, respectively. The bit in between [..] (in this case seemingly doubled, but that's because the text is itself bracketed) is the actual text that's been matched. 138 | 139 | So, by now you know what the text you're matching actually looks like, where it is in the string, and maybe eve have a rough idea of why what you're seeing isn't being displayedk 140 | 141 | With any luck you'll see that the code simply isn't adding the variables to the list that is being glommed onto the C<@child> array, and can add it. 142 | 143 | By convention, when you're dumping a C<- semilist:> match, you can always call C )> in order to get back the list of tokens generated by matching on the C<$p.hash.semilist> object. You might be wondering why I don't just subclass NQPMatch and add this as a generic multimethod or dispatch it in some other way. 144 | 145 | Well, the reason it's called C is because it's Not Quite Perl 6, and like poor Rudolph, Perl 6 won't let NQP objects join in any subclasing or dispatching games, because it's Not Quite Perl. And yes, this leads to quite a bit of frustruation. 146 | 147 | Let's assume that you've found the C<$_.list.[0]> and C<< $_.hash. >> handlers, and now need to add whitespace between the C<$_> and C<0> elements in your generated code. 148 | 149 | Now we turn to the rather bewildering array of methods on the C class. This profusion of methods is because of two things: 150 | 151 | * Whitespace can be inside a token, before or after a token, or even simply not be there because it's actually inside the L object one or more levels up, so you're never B sure where your whitespace will be hiding. 152 | * If each of the ~50 classes handled whitespace on its own, I'd have to track down each of the ~50 whitespace-generating methods in order to see which of the whitespace calls is being made. This way I can just look for L and know that those are the only B places where a whitespace token could be being generated. 153 | 154 | =end DEBUGGING 155 | 156 | =begin METHODS 157 | 158 | =item _roundtrip( Str $perl-code ) returns Perl6::Parser::Root 159 | 160 | Given a string containing valid Perl 6 code ... well, return that code. This 161 | is mostly a shortcut for testing purposes, and wil probably be moved out of the 162 | main file. 163 | 164 | =item to-tree( Str $source ) 165 | 166 | This is normally what you want, it returns the Perl 6 parsed tree corresponding to your source code. 167 | 168 | =item parse( Str $source ) 169 | 170 | Returns the underlying NQPMatch object. This is what gets passed on to C and every other important method in this module. It does some minor wizardry to call the Perl 6 reentrant compiler to compile the string you pass it, and return a match object. Please note that it B to compile the string in order to validate things like custom operators, so this step is B optional. 171 | 172 | =item build-tree( Mu $parsed ) 173 | 174 | Build the Perl6::Element tree from the NQPMatch object. This is the core, and runs the factory which silly-walks the match tree and returns one or more tokens for every single match entry it finds, and B. 175 | 176 | =item consistency-check( Perl6::Element $root ) 177 | 178 | Check the integrity of the data structure. The Factory at its core puts together the structure very sloppily, to give the tree every possible chance to create actual quasi-valid text. This method makes sure that the factory returned valid tokens, which often doesn't happen. But since you really want to see the data round-tripped, most users don't care what the tree loos like internally. 179 | 180 | =item to-string( Perl6::Element $tree ) returns Str 181 | 182 | Call .perl6 on each element of the tree. You can subclass or override this method in any class as you see fit to properly pretty-print the methods. Right now it's awkward to use, and will probably be removed in favor of an upcoming L module. That's why I wrote this yak.. er, module in the first place. 183 | 184 | =item dump-tree( Perl6::Element $root ) returns Str 185 | 186 | Given a Perl6::Document (or other) object, return a full nested tree of text detailing every single token, for debugging purposes. 187 | 188 | =item ruler( Str $source ) 189 | 190 | Purely a debugging aid, it puts an ASCII ruler above your source so that you don't have to go blind counting whitespace to figure out which ' ' a given token belongs to. As a courtesy it also makes newlines visible so you don't have to count those separately. I might use the visible space character later to make it easier to read, if I happen to like it. 191 | 192 | =end METHODS 193 | 194 | =begin Further-Information 195 | 196 | For further information, there's a L file detailing how to go about tracing down a bug in this module, and an extensive test suite in L with some ideas of how I'm structuring the test suite. 197 | 198 | =end Further-Information 199 | 200 | =end pod 201 | 202 | use Perl6::Parser::Factory; 203 | 204 | my role Debugging { 205 | 206 | method _interrogate-element( Perl6::Element $node ) { 207 | my @problem; 208 | if $node.WHAT.perl eq 'Perl6::Element' { 209 | @problem.push( Q{raw element} ); 210 | return @problem; 211 | } 212 | unless $node.^can('is-leaf') { 213 | @problem.push( Q{no leaf test} ); 214 | return @problem; 215 | } 216 | unless $node.^can('is-twig') { 217 | @problem.push( Q{no twig test} ); 218 | return @problem; 219 | } 220 | unless $node.^can('from') { 221 | @problem.push( Q{no from} ); 222 | return @problem; 223 | } 224 | unless $node.^can('to') { 225 | @problem.push( Q{no to} ); 226 | return @problem; 227 | } 228 | 229 | @problem.push( Q{from} ) if $node.from < 0; 230 | @problem.push( Q{to} ) if $node.to < 0; 231 | @problem.push( Q{cross} ) if $node.from > $node.to; 232 | 233 | if $node.is-twig { 234 | given $node { 235 | when Perl6::Block { 236 | @problem.push( Q{structure start} ) if 237 | $node.child[0] !~~ 238 | Perl6::Balanced::Enter; 239 | @problem.push( Q{structure end} ) if 240 | $node.child[*-1] !~~ 241 | Perl6::Balanced::Exit; 242 | } 243 | } 244 | } 245 | elsif $node.is-leaf { 246 | @problem.push( Q{empty} ) if $node.from == $node.to; 247 | 248 | @problem.push( Q{short} ) if 249 | $node.to - $node.from < $node.content.chars; 250 | @problem.push( Q{long} ) if 251 | $node.to - $node.from > $node.content.chars; 252 | 253 | given $node { 254 | when Perl6::Comment | Perl6::String | Perl6::Sir-Not-Appearing-In-This-Statement { } 255 | when Perl6::WS | Perl6::Newline { 256 | @problem.push( Q{WS} ) if 257 | $node.content ~~ /\S/; 258 | } 259 | default { 260 | @problem.push( Q{WS} ) if 261 | $node.content ~~ /\s/; 262 | @problem.push( Q{EMPTY} ) if 263 | $node.content eq Q{}; 264 | } 265 | } 266 | } 267 | else { 268 | @problem.push( Q{not tree member} ); 269 | } 270 | @problem; 271 | } 272 | 273 | #constant indent = "\t"; 274 | my constant indent = ' '; 275 | method _dump-tree( Perl6::Element $root, 276 | Bool $display-ws = True, 277 | Int $depth = 0 ) { 278 | my $str = ( indent xx $depth ) ~ self.dump-term( $root ) ~ "\n"; 279 | if $root.is-twig { 280 | for ^$root.child { 281 | my @problem; 282 | @problem.append( 283 | self._interrogate-element( 284 | $root.child.[$_] 285 | ) 286 | ); 287 | 288 | # Mark the tokens that don't overlap. 289 | # 290 | if $root.child.[$_+1].defined and 291 | $root.child.[$_].to != 292 | $root.child.[$_+1].from { 293 | @problem.push( 'G' ) 294 | } 295 | $str ~= @problem.join( ' ' ) if @problem; 296 | $str ~= self._dump-tree( 297 | $root.child.[$_], 298 | $display-ws, $depth + 1 299 | ) 300 | } 301 | } 302 | $str 303 | } 304 | 305 | method dump-tree( Perl6::Element $root, 306 | Bool $display-ws = True, 307 | Int $depth = 0 ) { 308 | my $str; 309 | 310 | for $.factory.here-doc.keys.sort -> $k { 311 | $str ~= "Here-Doc ($k-{$.factory.here-doc.{$k}})" ~ 312 | "\n"; 313 | } 314 | $str ~= self._dump-tree( $root, $display-ws, $depth ); 315 | $str 316 | } 317 | 318 | method dump-term( Perl6::Element $term ) { 319 | my $line = $term.WHAT.perl; 320 | $line ~~ s/'Perl6::'//; 321 | 322 | if $term.is-leaf { 323 | if $term ~~ Perl6::Number { 324 | $line ~= " ({$term.content})" 325 | } 326 | # Circumfix operators don't have content. 327 | # Their children do. 328 | elsif $term ~~ Perl6::Operator::PostCircumfix or 329 | $term ~~ Perl6::Operator::Circumfix { 330 | } 331 | else { 332 | $line ~= " ({$term.content.perl})" 333 | } 334 | } 335 | 336 | if $term.^can('from') and not ( 337 | $term ~~ Perl6::Document | Perl6::Statement 338 | ) { 339 | $line ~= " ({$term.from}-{$term.to})"; 340 | } 341 | 342 | if $term.^can('here-doc') { 343 | $line ~= " <{$term.here-doc}>" if 344 | $term.here-doc and $term.here-doc ne ''; 345 | } 346 | 347 | $line ~= " (line {$term.factory-line-number})" if 348 | $term.factory-line-number; 349 | if $term.is-end or !$term.next { 350 | $line ~= " -> END"; 351 | } 352 | else { 353 | my $next = $term.next; 354 | my $name = $next.WHAT.perl; 355 | $name ~~ s/'Perl6::'//; 356 | my $next-bounds = "{$next.from}-{$next.to}"; 357 | $line ~= " -> $name ($next-bounds)"; 358 | } 359 | $line; 360 | } 361 | 362 | method ruler( Str $source ) { 363 | my Str $munged = substr( $source, 0, min( $source.chars, 72 ) ); 364 | $munged ~= '...' if $source.chars > 72; 365 | my Int $blocks = $munged.chars div 10 + 1; 366 | $munged ~~ s:g{ \n } = Q{␤}; 367 | my Str $nums = ''; 368 | for ^$blocks { 369 | $nums ~= " {$_+1}"; 370 | } 371 | 372 | my $ruler = ''; 373 | $ruler ~= '#' ~ ' ' ~ $nums ~ "\n"; 374 | $ruler ~= '#' ~ ('0123456789' x $blocks) ~ "\n"; 375 | $ruler ~= '#' ~ $munged ~ "\n"; 376 | } 377 | } 378 | 379 | my role Testing { 380 | 381 | method _roundtrip( Str $source ) { 382 | my $tree = self.to-tree( $source ); 383 | my $formatted = self.to-string( $tree ); 384 | 385 | $formatted 386 | } 387 | } 388 | 389 | my role Validating { 390 | 391 | method _consistency-check( Perl6::Element $node ) { 392 | my @problems = self._interrogate-element( $node ); 393 | if @problems { 394 | $*ERR.say( @problems ~ ": " ~ $node.perl ); 395 | } 396 | 397 | if $node.is-twig { 398 | if $node.child.elems > 1 { 399 | for $node.child.kv -> $index, $_ { 400 | self._consistency-check( $_ ); 401 | 402 | next if $index == 0; 403 | if $node.child.[$index-1] ~~ Perl6::WS and 404 | $node.child.[$index] ~~ Perl6::WS { 405 | $*ERR.say( "Two WS entries in a row" ); 406 | } 407 | if $node.child.[$index-1].to != 408 | $node.child.[$index].from { 409 | $*ERR.say( "Gap between two items" ); 410 | } 411 | } 412 | } 413 | } 414 | } 415 | 416 | # Just in case we need to pass in parameters later on... 417 | # sigh. 418 | # 419 | method consistency-check( Perl6::Element $root ) { 420 | self._consistency-check( $root ); 421 | } 422 | } 423 | 424 | my class CompleteIterator { 425 | also does Iterator; 426 | 427 | has Perl6::Element $.head; 428 | has Bool $.is-done = False; 429 | 430 | method pull-one { 431 | if $.head.is-end { 432 | if $.is-done { 433 | return IterationEnd; 434 | } 435 | else { 436 | $!is-done = True; 437 | return $.head; 438 | } 439 | } 440 | else { 441 | my $elem = $.head; 442 | $!head = $.head.next; 443 | $elem; 444 | } 445 | } 446 | 447 | method is-lazy { False } 448 | } 449 | 450 | my class TokenIterator { 451 | also does Iterator; 452 | 453 | has Perl6::Element $.head; 454 | has Bool $.is-done = False; 455 | 456 | method pull-one { 457 | if $.head.is-end-leaf { 458 | if $.is-done { 459 | return IterationEnd; 460 | } 461 | else { 462 | $!is-done = True; 463 | return $.head; 464 | } 465 | } 466 | else { 467 | my $elem = $.head; 468 | $!head = $.head.next; 469 | $!head = $!head.next while !$.head.is-leaf; 470 | $elem; 471 | } 472 | } 473 | 474 | method is-lazy { False } 475 | } 476 | 477 | my class Munge-Phasers { 478 | has @.munged-BEGIN; 479 | has @.munged-CHECK; 480 | 481 | method _munge-element( Perl6::Element $node ) { 482 | return unless $node.^can( 'content' ); 483 | 484 | for @.munged-BEGIN -> $from { 485 | next unless $node.from <= $from <= $node.to; 486 | next unless $node.content.substr( 487 | $from - $node.from, 'BEGIN'.chars 488 | ) eq 'ENTER'; 489 | $node.content.substr-rw( 490 | $from - $node.from, 491 | #$from, 492 | 'BEGIN'.chars 493 | ) = 'BEGIN'; 494 | last; 495 | } 496 | for @.munged-CHECK -> $from { 497 | next unless $node.from <= $from <= $node.to; 498 | next unless $node.content.substr( 499 | $from - $node.from, 'CHECK'.chars 500 | ) eq 'ENTER'; 501 | $node.content.substr-rw( 502 | $from - $node.from, 503 | 'CHECK'.chars 504 | ) = 'CHECK'; 505 | last; 506 | } 507 | } 508 | 509 | method _munge-phasers( Perl6::Element $node ) { 510 | self._munge-element( $node ); 511 | 512 | if $node.is-twig { 513 | for $node.child.kv -> $index, $_ { 514 | self._munge-phasers( $_ ); 515 | } 516 | } 517 | } 518 | 519 | # Just in case we need to pass in parameters later on... 520 | # sigh. 521 | # 522 | method munge-phasers( Perl6::Element $root ) { 523 | return unless @.munged-BEGIN or @.munged-CHECK; 524 | self._munge-phasers( $root ); 525 | } 526 | } 527 | 528 | class Perl6::Parser:ver<0.3.0> { 529 | also does Debugging; 530 | also does Testing; 531 | also does Validating; 532 | use nqp; 533 | 534 | has $.factory = Perl6::Parser::Factory.new; 535 | has @.munged-BEGIN; 536 | has @.munged-CHECK; 537 | 538 | # These could easily be a single method, but I'll separate them for 539 | # testing purposes. 540 | # 541 | method parse( Str $source ) { 542 | my $*LINEPOSCACHE; 543 | my $compiler := nqp::getcomp('Raku') // nqp::getcomp('perl6'); 544 | my $g := nqp::findmethod( 545 | $compiler,'parsegrammar' 546 | )($compiler); 547 | #$g.HOW.trace-on($g); 548 | my $a := nqp::findmethod( 549 | $compiler,'parseactions' 550 | )($compiler); 551 | 552 | @.munged-BEGIN = (); 553 | my $munged-source = $source; 554 | $munged-source ~~ s:g{ 'BEGIN' } = 'ENTER'; 555 | for @( $/ ) -> $BEGIN { 556 | @.munged-BEGIN.push: $BEGIN.from; 557 | } 558 | $munged-source ~~ s:g{ 'CHECK' } = 'ENTER'; 559 | for @( $/ ) -> $CHECK { 560 | @.munged-CHECK.push: $CHECK.from; 561 | } 562 | my $parsed = $g.parse( 563 | $munged-source, 564 | :p( 0 ), 565 | :actions( $a ) 566 | ); 567 | 568 | $parsed; 569 | } 570 | 571 | method build-tree( Mu $parsed ) { 572 | my $tree = $.factory.build( $parsed ); 573 | my $munger = Munge-Phasers.new( 574 | :munged-BEGIN( @.munged-BEGIN ), 575 | :munged-CHECK( @.munged-CHECK ), 576 | ); 577 | $munger.munge-phasers( $tree ); 578 | self.consistency-check( $tree ) if 579 | $*CONSISTENCY-CHECK; 580 | $tree 581 | } 582 | 583 | method to-tree( Str $source ) { 584 | my $parsed = self.parse( $source ); 585 | self.build-tree( $parsed ); 586 | } 587 | 588 | method to-string( Perl6::Element $tree ) { 589 | my $str = $tree.to-string; 590 | 591 | $str; 592 | } 593 | 594 | method to-tokens-only( Str $source ) { 595 | my $tree = self.to-tree( $source ); 596 | $.factory.thread( $tree ); 597 | my $head = $.factory.flatten( $tree ); 598 | $head = $head.next while !$head.is-leaf and !$head.is-end-leaf; 599 | 600 | Seq.new( TokenIterator.new( :head( $head ) ) ); 601 | } 602 | 603 | method to-list( Str $source ) { 604 | my $tree = self.to-tree( $source ); 605 | $.factory.thread( $tree ); 606 | my $head = $.factory.flatten( $tree ); 607 | 608 | Seq.new( CompleteIterator.new( :head( $head ) ) ); 609 | } 610 | } 611 | -------------------------------------------------------------------------------- /t/00-class-hierarchy.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | use Perl6::Parser; 5 | 6 | use lib 't/lib'; 7 | use Utils; 8 | 9 | plan 1; 10 | 11 | # I've tried to arrange this so one token comes per line. 12 | # Makes it easier to comment out one term at a time. 13 | # 14 | # Or, another way of thinking about it is that commenting out each line 15 | # (excepting those that span multiples) should break a test. 16 | # 17 | # '3.27e5' blows past parser 18 | my $tree = Perl6::Parser.new.to-tree( Q:to[_END_] ); 19 | =begin pod 20 | 21 | =end pod 22 | 23 | 1; 24 | 0b1; 25 | 0o2; 26 | 0d3; 27 | 0x4; 28 | # Comment - make sure it's not contiguous with a Pod block 29 | :r3<12>; 30 | -0.1; 31 | my $a; 32 | my %a; 33 | my @a; 34 | my &a; 35 | my $*a; 36 | my %*a; 37 | my @*a; 38 | my &*a; 39 | my $=pod; 40 | my %=pod; 41 | my @=pod; 42 | my &=pod; 43 | class Foo { 44 | my $.a; 45 | my %.b; 46 | my @.c; 47 | my &.d; 48 | has $!e; 49 | has %!f; 50 | has @!g; 51 | has &!h; 52 | } 53 | 'foo'; 54 | "foo"; 55 | q{foo}; 56 | qq{foo}; 57 | qw{foo}; 58 | qww{foo}; 59 | qqw{foo}; 60 | qqx{foo}; 61 | qqww{foo}; 62 | ; 63 | qx{foo}; 64 | qqx{foo}; 65 | Q{foo}; 66 | Qw{foo}; 67 | Qx{foo}; 68 | ｢foo｣; 69 | q:to[END]; 70 | END 71 | Q:to[END]; 72 | END 73 | 74 | sub foo { }; 75 | 76 | { 77 | say [+] @a; 78 | say ++$a + $a++; 79 | say @a[1]; 80 | $a ~~ m{ . }; 81 | $a = Inf; 82 | $a = NaN; 83 | }; 84 | open 'foo', :r; 85 | _END_ 86 | 87 | subtest { 88 | ok Perl6::Element ~~ Mu, Q{has correct parent}; 89 | ok has-a( $tree, Perl6::Element ), Q{found}; 90 | 91 | subtest { 92 | ok Perl6::Visible ~~ Perl6::Element, Q{has correct parent}; 93 | ok has-a( $tree, Perl6::Visible ), Q{found}; 94 | 95 | subtest { 96 | ok Perl6::Operator ~~ Perl6::Visible, Q{has correct parent}; 97 | ok has-a( $tree, Perl6::Operator ), Q{found}; 98 | 99 | subtest { 100 | ok Perl6::Operator::Hyper ~~ Perl6::Operator, Q{has correct parent}; 101 | ok has-a( $tree, Perl6::Operator ), Q{found}; 102 | 103 | done-testing; 104 | }, Q{Operator::Hyper}; 105 | 106 | subtest { 107 | ok Perl6::Operator::Prefix ~~ Perl6::Operator, Q{has correct parent}; 108 | ok has-a( $tree, Perl6::Operator ), Q{found}; 109 | 110 | done-testing; 111 | }, Q{Operator::Prefix}; 112 | 113 | subtest { 114 | ok Perl6::Operator::Infix ~~ Perl6::Operator, Q{has correct parent}; 115 | ok has-a( $tree, Perl6::Operator ), Q{found}; 116 | 117 | done-testing; 118 | }, Q{Operator::Infix}; 119 | 120 | subtest { 121 | ok Perl6::Operator::Postfix ~~ Perl6::Operator, Q{has correct parent}; 122 | ok has-a( $tree, Perl6::Operator ), Q{found}; 123 | 124 | done-testing; 125 | }, Q{Operator::Postfix}; 126 | 127 | subtest { 128 | ok Perl6::Operator::Circumfix ~~ Perl6::Operator, 129 | Q{has correct parent}; 130 | ok has-a( $tree, Perl6::Operator ), Q{found}; 131 | 132 | done-testing; 133 | }, Q{Operator::Circumfix}; 134 | 135 | subtest { 136 | ok Perl6::Operator::PostCircumfix ~~ Perl6::Operator, 137 | Q{has correct parent}; 138 | ok has-a( $tree, Perl6::Operator ), Q{found}; 139 | 140 | done-testing; 141 | }, Q{Operator::PostCircumfix}; 142 | 143 | done-testing; 144 | }, Q{Operator}; 145 | 146 | subtest { 147 | ok Perl6::String ~~ Perl6::Visible, Q{has correct parent}; 148 | ok has-a( $tree, Perl6::String ), Q{found}; 149 | 150 | subtest { 151 | ok Perl6::String::Body ~~ Perl6::String, Q{has correct parent}; 152 | ok has-a( $tree, Perl6::String::Body ), Q{found}; 153 | 154 | done-testing; 155 | }, Q{String::Body}; 156 | 157 | subtest { 158 | ok Perl6::String::WordQuoting ~~ Perl6::String, Q{has correct parent}; 159 | ok has-a( $tree, Perl6::String::WordQuoting ), Q{found}; 160 | 161 | subtest { 162 | ok Perl6::String::WordQuoting::QuoteProtection ~~ 163 | Perl6::String::WordQuoting, Q{has correct parent}; 164 | ok has-a( $tree, Perl6::String::WordQuoting::QuoteProtection ), 165 | Q{found}; 166 | 167 | done-testing; 168 | }, Q{String::WordQuoting::QuoteProtection}; 169 | 170 | done-testing; 171 | }, Q{String::WordQuoting}; 172 | 173 | subtest { 174 | ok Perl6::String::Interpolation ~~ Perl6::String, 175 | Q{has correct parent}; 176 | ok has-a( $tree, Perl6::String::Interpolation ), Q{found}; 177 | 178 | subtest { 179 | ok Perl6::String::Interpolation::Shell ~~ 180 | Perl6::String::Interpolation, 181 | Q{has correct parent}; 182 | ok has-a( $tree, Perl6::String::Interpolation::Shell ), Q{found}; 183 | 184 | done-testing; 185 | }, Q{String::Interpolation::Shell}; 186 | 187 | subtest { 188 | ok Perl6::String::Interpolation::WordQuoting ~~ 189 | Perl6::String::Interpolation, Q{has correct parent}; 190 | ok has-a( $tree, Perl6::String::Interpolation::WordQuoting ), 191 | Q{found}; 192 | 193 | subtest { 194 | ok Perl6::String::Interpolation::WordQuoting::QuoteProtection ~~ 195 | Perl6::String::Interpolation::WordQuoting, 196 | Q{has correct parent}; 197 | ok has-a( 198 | $tree, 199 | Perl6::String::Interpolation::WordQuoting::QuoteProtection 200 | ), Q{found}; 201 | 202 | done-testing; 203 | }, Q{String::Interpolation::WordQuoting::QuoteProtection}; 204 | 205 | done-testing; 206 | }, Q{String::Interpolation::WordQuoting}; 207 | 208 | done-testing; 209 | }, Q{String::Interpolation}; 210 | 211 | subtest { 212 | ok Perl6::String::Shell ~~ Perl6::String, Q{has correct parent}; 213 | ok has-a( $tree, Perl6::String::Shell ), Q{found}; 214 | 215 | done-testing; 216 | }, Q{String::Shell}; 217 | 218 | subtest { 219 | ok Perl6::String::Escaping ~~ Perl6::String, Q{has correct parent}; 220 | ok has-a( $tree, Perl6::String::Escaping ), Q{found}; 221 | 222 | done-testing; 223 | }, Q{String::Escaping}; 224 | 225 | subtest { 226 | ok Perl6::String::Literal ~~ Perl6::String, Q{has correct parent}; 227 | ok has-a( $tree, Perl6::String::Literal ), Q{found}; 228 | 229 | subtest { 230 | ok Perl6::String::Literal::WordQuoting ~~ Perl6::String, 231 | Q{has correct parent}; 232 | ok has-a( $tree, Perl6::String::Literal::WordQuoting ), Q{found}; 233 | 234 | done-testing; 235 | }, Q{String::Literal::WordQuoting}; 236 | 237 | subtest { 238 | ok Perl6::String::Literal::Shell ~~ Perl6::String, 239 | Q{has correct parent}; 240 | ok has-a( $tree, Perl6::String::Literal::Shell ), Q{found}; 241 | 242 | done-testing; 243 | }, Q{String::Literal::Shell}; 244 | 245 | done-testing; 246 | }, Q{String::Literal}; 247 | 248 | done-testing; 249 | }, Q{String}; 250 | 251 | subtest { 252 | ok Perl6::Documentation ~~ Perl6::Visible, Q{has correct parent}; 253 | ok has-a( $tree, Perl6::Documentation ), Q{found}; 254 | 255 | subtest { 256 | ok Perl6::Pod ~~ Perl6::Documentation, Q{has correct parent}; 257 | ok has-a( $tree, Perl6::Pod ), Q{found}; 258 | 259 | done-testing; 260 | }, Q{Pod}; 261 | 262 | subtest { 263 | ok Perl6::Comment ~~ Perl6::Documentation, Q{has correct parent}; 264 | ok has-a( $tree, Perl6::Comment ), Q{found}; 265 | 266 | done-testing; 267 | }, Q{Comment}; 268 | 269 | done-testing; 270 | }, Q{Documentation}; 271 | 272 | subtest { 273 | ok Perl6::Balanced ~~ Perl6::Visible, Q{has correct parent}; 274 | ok has-a( $tree, Perl6::Balanced ), Q{found}; 275 | 276 | subtest { 277 | ok Perl6::Balanced::Enter ~~ Perl6::Balanced, Q{has correct parent}; 278 | ok has-a( $tree, Perl6::Balanced::Enter ), Q{found}; 279 | 280 | subtest { 281 | ok Perl6::Block::Enter ~~ Perl6::Balanced::Enter, 282 | Q{has correct parent}; 283 | ok has-a( $tree, Perl6::Block::Enter ), Q{found}; 284 | 285 | done-testing; 286 | }, Q{Block::Enter}; 287 | 288 | subtest { 289 | ok Perl6::String::Enter ~~ Perl6::Balanced::Enter, 290 | Q{has correct parent}; 291 | #`{ 292 | ok has-a( $tree, Perl6::String::Enter ), Q{found}; 293 | } 294 | 295 | done-testing; 296 | }, Q{String::Enter}; 297 | 298 | done-testing; 299 | }, Q{Balanced::Enter}; 300 | 301 | subtest { 302 | ok Perl6::Balanced::Exit ~~ Perl6::Balanced, Q{has correct parent}; 303 | ok has-a( $tree, Perl6::Balanced::Exit ), Q{found}; 304 | 305 | subtest { 306 | ok Perl6::Block::Exit ~~ Perl6::Balanced::Exit, Q{has correct parent}; 307 | ok has-a( $tree, Perl6::Block::Exit ), Q{found}; 308 | 309 | done-testing; 310 | }, Q{Block::Exit}; 311 | 312 | subtest { 313 | ok Perl6::String::Exit ~~ Perl6::Balanced::Exit, 314 | Q{has correct parent}; 315 | #`{ 316 | ok has-a( $tree, Perl6::String::Exit ), Q{found}; 317 | } 318 | 319 | done-testing; 320 | }, Q{String::Exit}; 321 | 322 | done-testing; 323 | }, Q{Balanced::Exit}; 324 | 325 | done-testing; 326 | }, Q{Balanced}; 327 | 328 | # A proper test makes sure that documents *don't* have these. 329 | # They shouldn't be generated when validating in tests, and 330 | # *really* shouldn't be generated by regular code. 331 | # 332 | subtest { 333 | ok Perl6::Catch-All ~~ Perl6::Visible, Q{has correct parent}; 334 | ok !has-a( $tree, Perl6::Catch-All ), Q{found}; 335 | 336 | done-testing; 337 | }, Q{Catch-All}; 338 | 339 | subtest { 340 | ok Perl6::Whatever ~~ Perl6::Visible, Q{has correct parent}; 341 | #`{ 342 | ok has-a( $tree, Perl6::Whatever ), Q{found}; 343 | } 344 | 345 | done-testing; 346 | }, Q{Whatever}; 347 | 348 | subtest { 349 | ok Perl6::Loop-Separator ~~ Perl6::Visible, Q{has correct parent}; 350 | #`{ 351 | ok has-a( $tree, Perl6::Loop-Separator ), Q{found}; 352 | } 353 | 354 | done-testing; 355 | }, Q{Loop-Separator}; 356 | 357 | subtest { 358 | ok Perl6::Dimension-Separator ~~ Perl6::Visible, Q{has correct parent}; 359 | #`{ 360 | ok has-a( $tree, Perl6::Dimension-Separator ), Q{found}; 361 | } 362 | 363 | done-testing; 364 | }, Q{Dimension-Separator}; 365 | 366 | subtest { 367 | ok Perl6::Semicolon ~~ Perl6::Visible, Q{has correct parent}; 368 | ok has-a( $tree, Perl6::Semicolon ), Q{found}; 369 | 370 | done-testing; 371 | }, Q{Semicolon}; 372 | 373 | subtest { 374 | ok Perl6::Backslash ~~ Perl6::Visible, Q{has correct parent}; 375 | #`{ 376 | ok has-a( $tree, Perl6::Backslash ), Q{found}; 377 | } 378 | 379 | done-testing; 380 | }, Q{Backslash}; 381 | 382 | # XXX is this a bug?... Not really, RTFS to see why. 383 | subtest { 384 | ok Perl6::Sir-Not-Appearing-In-This-Statement ~~ Perl6::Visible, 385 | Q{has correct parent}; 386 | ok has-a( $tree, Perl6::Sir-Not-Appearing-In-This-Statement ), Q{found}; 387 | 388 | done-testing; 389 | }, Q{Sir-Not-Appearing-In-This-Statement}; 390 | 391 | subtest { 392 | ok Perl6::Number ~~ Perl6::Visible, Q{has correct parent}; 393 | ok has-a( $tree, Perl6::Number ), Q{found}; 394 | 395 | subtest { 396 | ok Perl6::Number::Binary ~~ Perl6::Number, Q{has correct parent}; 397 | ok has-a( $tree, Perl6::Number::Binary ), Q{found}; 398 | 399 | done-testing; 400 | }, Q{Number::Binary}; 401 | 402 | subtest { 403 | ok Perl6::Number::Octal ~~ Perl6::Number, Q{has correct parent}; 404 | ok has-a( $tree, Perl6::Number::Octal ), Q{found}; 405 | 406 | done-testing; 407 | }, Q{Number::Octal}; 408 | 409 | subtest { 410 | ok Perl6::Number::Decimal ~~ Perl6::Number, Q{has correct parent}; 411 | ok has-a( $tree, Perl6::Number::Decimal ), Q{found}; 412 | 413 | subtest { 414 | ok Perl6::Number::Decimal::Explicit ~~ Perl6::Number::Decimal, 415 | Q{has correct parent}; 416 | #`{ 417 | ok has-a( $tree, Perl6::Number::Decimal::Explicit), Q{found}; 418 | } 419 | 420 | done-testing; 421 | }, Q{Number::Decimal::Explicit}; 422 | 423 | done-testing; 424 | }, Q{Number::Decimal}; 425 | 426 | subtest { 427 | ok Perl6::Number::Hexadecimal ~~ Perl6::Number, Q{has correct parent}; 428 | ok has-a( $tree, Perl6::Number::Hexadecimal ), Q{found}; 429 | 430 | done-testing; 431 | }, Q{Number::Hexadecimal}; 432 | 433 | subtest { 434 | ok Perl6::Number::Radix ~~ Perl6::Number, Q{has correct parent}; 435 | #`{ 436 | ok has-a( $tree, Perl6::Number::Radix ), Q{found}; 437 | } 438 | 439 | done-testing; 440 | }, Q{Number::Radix}; 441 | 442 | subtest { 443 | ok Perl6::Number::FloatingPoint ~~ Perl6::Number, Q{has correct parent}; 444 | ok has-a( $tree, Perl6::Number::FloatingPoint ), Q{found}; 445 | 446 | done-testing; 447 | }, Q{Number::FloatingPoint}; 448 | 449 | done-testing; 450 | }, Q{Number}; 451 | 452 | subtest { 453 | ok Perl6::NotANumber ~~ Perl6::Visible, Q{has correct parent}; 454 | ok has-a( $tree, Perl6::NotANumber ), Q{found}; 455 | 456 | done-testing; 457 | }, Q{NotANumber}; 458 | 459 | subtest { 460 | ok Perl6::Infinity ~~ Perl6::Visible, Q{has correct parent}; 461 | ok has-a( $tree, Perl6::Infinity ), Q{found}; 462 | 463 | done-testing; 464 | }, Q{Infinity}; 465 | 466 | subtest { 467 | ok Perl6::Regex ~~ Perl6::Visible, Q{has correct parent}; 468 | ok has-a( $tree, Perl6::Regex ), Q{found}; 469 | 470 | done-testing; 471 | }, Q{Regex}; 472 | 473 | subtest { 474 | ok Perl6::Bareword ~~ Perl6::Visible, Q{has correct parent}; 475 | ok has-a( $tree, Perl6::Bareword ), Q{found}; 476 | 477 | subtest { 478 | ok Perl6::SubroutineDeclaration ~~ Perl6::Bareword, 479 | Q{has correct parent}; 480 | ok has-a( $tree, Perl6::SubroutineDeclaration ), Q{found}; 481 | 482 | done-testing; 483 | }, Q{SubroutineDeclaration}; 484 | 485 | subtest { 486 | ok Perl6::ColonBareword ~~ Perl6::Bareword, Q{has correct parent}; 487 | ok has-a( $tree, Perl6::ColonBareword ), Q{found}; 488 | 489 | done-testing; 490 | }, Q{ColonBareword}; 491 | 492 | done-testing; 493 | }, Q{Bareword}; 494 | 495 | subtest { 496 | ok Perl6::Adverb ~~ Perl6::Visible, Q{has correct parent}; 497 | #`{ 498 | ok has-a( $tree, Perl6::Adverb ), Q{found}; 499 | } 500 | 501 | done-testing; 502 | }, Q{Adverb}; 503 | 504 | subtest { 505 | ok Perl6::PackageName ~~ Perl6::Visible, Q{has correct parent}; 506 | #`{ 507 | ok has-a( $tree, Perl6::PackageName ), Q{found}; 508 | } 509 | 510 | done-testing; 511 | }, Q{PackageName}; 512 | 513 | subtest { 514 | ok Perl6::Variable ~~ Perl6::Visible, Q{has correct parent}; 515 | ok has-a( $tree, Perl6::Variable ), Q{found}; 516 | 517 | subtest { 518 | ok Perl6::Variable::Scalar ~~ Perl6::Variable, Q{has correct parent}; 519 | ok has-a( $tree, Perl6::Variable::Scalar ), Q{found}; 520 | 521 | subtest { 522 | ok Perl6::Variable::Scalar::Contextualizer ~~ Perl6::Variable::Scalar, 523 | Q{has correct parent}; 524 | #`{ 525 | ok has-a( $tree, Perl6::Variable::Scalar::Contextualizer ), Q{found}; 526 | } 527 | 528 | done-testing; 529 | }, Q{Variable::Scalar::Contextualizer}; 530 | 531 | subtest { 532 | ok Perl6::Variable::Scalar::Dynamic ~~ Perl6::Variable::Scalar, 533 | Q{has correct parent}; 534 | ok has-a( $tree, Perl6::Variable::Scalar::Dynamic ), Q{found}; 535 | 536 | done-testing; 537 | }, Q{Variable::Scalar::Dynamic}; 538 | 539 | subtest { 540 | ok Perl6::Variable::Scalar::Attribute ~~ Perl6::Variable::Scalar, 541 | Q{has correct parent}; 542 | ok has-a( $tree, Perl6::Variable::Scalar::Attribute ), Q{found}; 543 | 544 | done-testing; 545 | }, Q{Variable::Scalar::Attribute}; 546 | 547 | subtest { 548 | ok Perl6::Variable::Scalar::Accessor ~~ Perl6::Variable::Scalar, 549 | Q{has correct parent}; 550 | ok has-a( $tree, Perl6::Variable::Scalar::Accessor ), Q{found}; 551 | 552 | done-testing; 553 | }, Q{Variable::Scalar::Accessor}; 554 | 555 | subtest { 556 | ok Perl6::Variable::Scalar::CompileTime ~~ Perl6::Variable::Scalar, 557 | Q{has correct parent}; 558 | #`{ 559 | ok has-a( $tree, Perl6::Variable::Scalar::CompileTime ), Q{found}; 560 | } 561 | 562 | done-testing; 563 | }, Q{Variable::Scalar::CompileTime}; 564 | 565 | subtest { 566 | ok Perl6::Variable::Scalar::MatchIndex ~~ Perl6::Variable::Scalar, 567 | Q{has correct parent}; 568 | #`{ 569 | ok has-a( $tree, Perl6::Variable::Scalar::MatchIndex ), Q{found}; 570 | } 571 | 572 | done-testing; 573 | }, Q{Variable::Scalar::MatchIndex}; 574 | 575 | subtest { 576 | ok Perl6::Variable::Scalar::Positional ~~ Perl6::Variable::Scalar, 577 | Q{has correct parent}; 578 | #`{ 579 | ok has-a( $tree, Perl6::Variable::Scalar::Positional ), Q{found}; 580 | } 581 | 582 | done-testing; 583 | }, Q{Variable::Scalar::Positional}; 584 | 585 | subtest { 586 | ok Perl6::Variable::Scalar::Named ~~ Perl6::Variable::Scalar, 587 | Q{has correct parent}; 588 | #`{ 589 | ok has-a( $tree, Perl6::Variable::Scalar::Named ), Q{found}; 590 | } 591 | 592 | done-testing; 593 | }, Q{Variable::Scalar::Named}; 594 | 595 | subtest { 596 | ok Perl6::Variable::Scalar::Pod ~~ Perl6::Variable::Scalar, 597 | Q{has correct parent}; 598 | ok has-a( $tree, Perl6::Variable::Scalar::Pod ), Q{found}; 599 | 600 | done-testing; 601 | }, Q{Variable::Scalar::Pod}; 602 | 603 | subtest { 604 | ok Perl6::Variable::Scalar::SubLanguage ~~ Perl6::Variable::Scalar, 605 | Q{has correct parent}; 606 | #`{ 607 | ok has-a( $tree, Perl6::Variable::Scalar::SubLanguage ), Q{found}; 608 | } 609 | 610 | done-testing; 611 | }, Q{Variable::Scalar::SubLanguage}; 612 | 613 | done-testing; 614 | }, Q{Variable::Scalar}; 615 | 616 | subtest { 617 | ok Perl6::Variable::Array ~~ Perl6::Variable, Q{has correct parent}; 618 | ok has-a( $tree, Perl6::Variable::Array ), Q{found}; 619 | 620 | # subtest { 621 | # ok Perl6::Variable::Array::Contextualizer ~~ Perl6::Variable::Array, 622 | # Q{has correct parent}; 623 | # ok has-a( $tree, Perl6::Variable::Array::Contextualizer ), Q{found}; 624 | # 625 | # done-testing; 626 | # }, Q{Variable::Array::Contextualizer}; 627 | 628 | subtest { 629 | ok Perl6::Variable::Array::Dynamic ~~ Perl6::Variable::Array, 630 | Q{has correct parent}; 631 | ok has-a( $tree, Perl6::Variable::Array::Dynamic ), Q{found}; 632 | 633 | done-testing; 634 | }, Q{Variable::Array::Dynamic}; 635 | 636 | subtest { 637 | ok Perl6::Variable::Array::Attribute ~~ Perl6::Variable::Array, 638 | Q{has correct parent}; 639 | ok has-a( $tree, Perl6::Variable::Array::Attribute ), Q{found}; 640 | 641 | done-testing; 642 | }, Q{Variable::Array::Attribute}; 643 | 644 | subtest { 645 | ok Perl6::Variable::Array::Accessor ~~ Perl6::Variable::Array, 646 | Q{has correct parent}; 647 | ok has-a( $tree, Perl6::Variable::Array::Accessor ), Q{found}; 648 | 649 | done-testing; 650 | }, Q{Variable::Array::Accessor}; 651 | 652 | subtest { 653 | ok Perl6::Variable::Array::CompileTime ~~ Perl6::Variable::Array, 654 | Q{has correct parent}; 655 | #`{ 656 | ok has-a( $tree, Perl6::Variable::Array::CompileTime ), Q{found}; 657 | } 658 | 659 | done-testing; 660 | }, Q{Variable::Array::CompileTime}; 661 | 662 | subtest { 663 | ok Perl6::Variable::Array::MatchIndex ~~ Perl6::Variable::Array, 664 | Q{has correct parent}; 665 | #`{ 666 | ok has-a( $tree, Perl6::Variable::Array::MatchIndex ), Q{found}; 667 | } 668 | 669 | done-testing; 670 | }, Q{Variable::Array::MatchIndex}; 671 | 672 | subtest { 673 | ok Perl6::Variable::Array::Positional ~~ Perl6::Variable::Array, 674 | Q{has correct parent}; 675 | #`{ 676 | ok has-a( $tree, Perl6::Variable::Array::Positional ), Q{found}; 677 | } 678 | 679 | done-testing; 680 | }, Q{Variable::Array::Positional}; 681 | 682 | subtest { 683 | ok Perl6::Variable::Array::Named ~~ Perl6::Variable::Array, 684 | Q{has correct parent}; 685 | #`{ 686 | ok has-a( $tree, Perl6::Variable::Array::Named ), Q{found}; 687 | } 688 | 689 | done-testing; 690 | }, Q{Variable::Array::Named}; 691 | 692 | subtest { 693 | ok Perl6::Variable::Array::Pod ~~ Perl6::Variable::Array, 694 | Q{has correct parent}; 695 | ok has-a( $tree, Perl6::Variable::Array::Pod ), Q{found}; 696 | 697 | done-testing; 698 | }, Q{Variable::Array::Pod}; 699 | 700 | subtest { 701 | ok Perl6::Variable::Array::SubLanguage ~~ Perl6::Variable::Array, 702 | Q{has correct parent}; 703 | #`{ 704 | ok has-a( $tree, Perl6::Variable::Array::SubLanguage ), Q{found}; 705 | } 706 | 707 | done-testing; 708 | }, Q{Variable::Array::SubLanguage}; 709 | 710 | 711 | done-testing; 712 | }, Q{Variable::Array}; 713 | 714 | subtest { 715 | ok Perl6::Variable::Hash ~~ Perl6::Variable, Q{has correct parent}; 716 | ok has-a( $tree, Perl6::Variable::Hash ), Q{found}; 717 | 718 | # subtest { 719 | # ok Perl6::Variable::Hash::Contextualizer ~~ Perl6::Variable::Hash, 720 | # Q{has correct parent}; 721 | # ok has-a( $tree, Perl6::Variable::Hash::Contextualizer ), Q{found}; 722 | # 723 | # done-testing; 724 | # }, Q{Variable::Hash::Contextualizer}; 725 | 726 | subtest { 727 | ok Perl6::Variable::Hash::Dynamic ~~ Perl6::Variable::Hash, 728 | Q{has correct parent}; 729 | ok has-a( $tree, Perl6::Variable::Hash::Dynamic ), Q{found}; 730 | 731 | done-testing; 732 | }, Q{Variable::Hash::Dynamic}; 733 | 734 | subtest { 735 | ok Perl6::Variable::Hash::Attribute ~~ Perl6::Variable::Hash, 736 | Q{has correct parent}; 737 | ok has-a( $tree, Perl6::Variable::Hash::Attribute ), Q{found}; 738 | 739 | done-testing; 740 | }, Q{Variable::Hash::Attribute}; 741 | 742 | subtest { 743 | ok Perl6::Variable::Hash::Accessor ~~ Perl6::Variable::Hash, 744 | Q{has correct parent}; 745 | ok has-a( $tree, Perl6::Variable::Hash::Accessor ), Q{found}; 746 | 747 | done-testing; 748 | }, Q{Variable::Hash::Accessor}; 749 | 750 | subtest { 751 | ok Perl6::Variable::Hash::CompileTime ~~ Perl6::Variable::Hash, 752 | Q{has correct parent}; 753 | #`{ 754 | ok has-a( $tree, Perl6::Variable::Hash::CompileTime ), Q{found}; 755 | } 756 | 757 | done-testing; 758 | }, Q{Variable::Hash::CompileTime}; 759 | 760 | subtest { 761 | ok Perl6::Variable::Hash::MatchIndex ~~ Perl6::Variable::Hash, 762 | Q{has correct parent}; 763 | #`{ 764 | ok has-a( $tree, Perl6::Variable::Hash::MatchIndex ), Q{found}; 765 | } 766 | 767 | done-testing; 768 | }, Q{Variable::Hash::MatchIndex}; 769 | 770 | subtest { 771 | ok Perl6::Variable::Hash::Positional ~~ Perl6::Variable::Hash, 772 | Q{has correct parent}; 773 | #`{ 774 | ok has-a( $tree, Perl6::Variable::Hash::Positional ), Q{found}; 775 | } 776 | 777 | done-testing; 778 | }, Q{Variable::Hash::Positional}; 779 | 780 | subtest { 781 | ok Perl6::Variable::Hash::Named ~~ Perl6::Variable::Hash, 782 | Q{has correct parent}; 783 | #`{ 784 | ok has-a( $tree, Perl6::Variable::Hash::Named ), Q{found}; 785 | } 786 | 787 | done-testing; 788 | }, Q{Variable::Hash::Named}; 789 | 790 | subtest { 791 | ok Perl6::Variable::Hash::Pod ~~ Perl6::Variable::Hash, 792 | Q{has correct parent}; 793 | ok has-a( $tree, Perl6::Variable::Hash::Pod ), Q{found}; 794 | 795 | done-testing; 796 | }, Q{Variable::Hash::Pod}; 797 | 798 | subtest { 799 | ok Perl6::Variable::Hash::SubLanguage ~~ Perl6::Variable::Hash, 800 | Q{has correct parent}; 801 | #`{ 802 | ok has-a( $tree, Perl6::Variable::Hash::SubLanguage ), Q{found}; 803 | } 804 | 805 | done-testing; 806 | }, Q{Variable::Hash::SubLanguage}; 807 | 808 | done-testing; 809 | }, Q{Variable::Hash}; 810 | 811 | subtest { 812 | ok Perl6::Variable::Callable ~~ Perl6::Variable, Q{has correct parent}; 813 | ok has-a( $tree, Perl6::Variable::Callable ), Q{found}; 814 | 815 | # subtest { 816 | # ok Perl6::Variable::Callable::Contextualizer ~~ Perl6::Variable::Callable, 817 | # Q{has correct parent}; 818 | # ok has-a( $tree, Perl6::Variable::Callable::Contextualizer ), 819 | # Q{found}; 820 | # 821 | # done-testing; 822 | # }, Q{Variable::Callable::Contextualizer}; 823 | 824 | subtest { 825 | ok Perl6::Variable::Callable::Dynamic ~~ Perl6::Variable::Callable, 826 | Q{has correct parent}; 827 | ok has-a( $tree, Perl6::Variable::Callable::Dynamic ), Q{found}; 828 | 829 | done-testing; 830 | }, Q{Variable::Callable::Dynamic}; 831 | 832 | subtest { 833 | ok Perl6::Variable::Callable::Attribute ~~ Perl6::Variable::Callable, 834 | Q{has correct parent}; 835 | ok has-a( $tree, Perl6::Variable::Callable::Attribute ), Q{found}; 836 | 837 | done-testing; 838 | }, Q{Variable::Callable::Attribute}; 839 | 840 | subtest { 841 | ok Perl6::Variable::Callable::Accessor ~~ Perl6::Variable::Callable, 842 | Q{has correct parent}; 843 | ok has-a( $tree, Perl6::Variable::Callable::Accessor ), Q{found}; 844 | 845 | done-testing; 846 | }, Q{Variable::Callable::Accessor}; 847 | 848 | subtest { 849 | ok Perl6::Variable::Callable::CompileTime ~~ 850 | Perl6::Variable::Callable, 851 | Q{has correct parent}; 852 | #`{ 853 | ok has-a( $tree, Perl6::Variable::Callable::CompileTime ), Q{found}; 854 | } 855 | 856 | done-testing; 857 | }, Q{Variable::Callable::CompileTime}; 858 | 859 | subtest { 860 | ok Perl6::Variable::Callable::MatchIndex ~~ Perl6::Variable::Callable, 861 | Q{has correct parent}; 862 | #`{ 863 | ok has-a( $tree, Perl6::Variable::Callable::MatchIndex ), Q{found}; 864 | } 865 | 866 | done-testing; 867 | }, Q{Variable::Callable::MatchIndex}; 868 | 869 | subtest { 870 | ok Perl6::Variable::Callable::Positional ~~ Perl6::Variable::Callable, 871 | Q{has correct parent}; 872 | #`{ 873 | ok has-a( $tree, Perl6::Variable::Callable::Positional ), Q{found}; 874 | } 875 | 876 | done-testing; 877 | }, Q{Variable::Callable::Positional}; 878 | 879 | subtest { 880 | ok Perl6::Variable::Callable::Named ~~ Perl6::Variable::Callable, 881 | Q{has correct parent}; 882 | #`{ 883 | ok has-a( $tree, Perl6::Variable::Callable::Named ), Q{found}; 884 | } 885 | 886 | done-testing; 887 | }, Q{Variable::Callable::Named}; 888 | 889 | subtest { 890 | ok Perl6::Variable::Callable::Pod ~~ Perl6::Variable::Callable, 891 | Q{has correct parent}; 892 | ok has-a( $tree, Perl6::Variable::Callable::Pod ), Q{found}; 893 | 894 | done-testing; 895 | }, Q{Variable::Callable::Pod}; 896 | 897 | subtest { 898 | ok Perl6::Variable::Callable::SubLanguage ~~ 899 | Perl6::Variable::Callable, 900 | Q{has correct parent}; 901 | #`{ 902 | ok has-a( $tree, Perl6::Variable::Callable::SubLanguage ), Q{found}; 903 | } 904 | 905 | done-testing; 906 | }, Q{Variable::Callable::SubLanguage}; 907 | 908 | done-testing; 909 | }, Q{Variable::Callable}; 910 | 911 | done-testing; 912 | }, Q{Variable}; 913 | 914 | done-testing; 915 | }, Q{Visible}; 916 | 917 | subtest { 918 | ok Perl6::Invisible ~~ Perl6::Element, Q{has correct parent}; 919 | ok has-a( $tree, Perl6::Invisible ), Q{found}; 920 | 921 | subtest { 922 | ok Perl6::WS ~~ Perl6::Invisible, Q{has correct parent}; 923 | ok has-a( $tree, Perl6::Document ), Q{found}; 924 | 925 | done-testing; 926 | }, Q{WS}; 927 | 928 | subtest { 929 | ok Perl6::Newline ~~ Perl6::Invisible, Q{has correct parent}; 930 | ok has-a( $tree, Perl6::Document ), Q{found}; 931 | 932 | done-testing; 933 | }, Q{Newline}; 934 | 935 | done-testing; 936 | }, Q{Invisible}; 937 | 938 | subtest { 939 | ok Perl6::Document ~~ Perl6::Element, Q{has correct parent}; 940 | ok has-a( $tree, Perl6::Document ), Q{found}; 941 | 942 | done-testing; 943 | }, Q{Document}; 944 | 945 | subtest { 946 | ok Perl6::Statement ~~ Perl6::Element, Q{has correct parent}; 947 | ok has-a( $tree, Perl6::Statement ), Q{found}; 948 | 949 | done-testing; 950 | }, Q{Statement}; 951 | 952 | subtest { 953 | ok Perl6::Block ~~ Perl6::Element, Q{has correct parent}; 954 | ok has-a( $tree, Perl6::Block ), Q{found}; 955 | 956 | done-testing; 957 | }, Q{Block}; 958 | 959 | done-testing; 960 | }, Q{Element}; 961 | 962 | done-testing; 963 | 964 | # vim: ft=perl6 965 | -------------------------------------------------------------------------------- /t/01-nqp-tree.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | use Perl6::Parser; 5 | 6 | sub hash-matches( Mu $parsed, $key, $from, $to, $text ) returns Bool { 7 | $parsed.hash:exists{$key} or 8 | diag "Key '$key' missing"; 9 | $parsed.hash.{$key}.from == $from or 10 | diag "Key starts at {$parsed.hash.{$key}.from}, not $from"; 11 | $parsed.hash.{$key}.to == $to or 12 | diag "Key does not end at {$parsed.hash.{$key}.to}, not $to"; 13 | $parsed.hash.{$key}.Str eq $text or 14 | diag "Key is '{$parsed.hash.{$key}.Str}', not '$text'"; 15 | 16 | return ?( ( $parsed.hash:exists{$key} ) and 17 | ( $parsed.hash.{$key}.from == $from ) and 18 | ( $parsed.hash.{$key}.to == $to ) and 19 | ( $parsed.hash.{$key}.Str eq $text ) ); 20 | } 21 | 22 | plan 2; 23 | 24 | # Reuse $pp so that we can make sure state is cleaned up. 25 | # 26 | # Also, just check that we have the keys we're expecting in the hash/list. 27 | # 28 | my $pp = Perl6::Parser.new; 29 | my $*CONSISTENCY-CHECK = True; 30 | my $*FALL-THROUGH = True; 31 | 32 | subtest { 33 | my $parsed = $pp.parse( Q{} ); 34 | 35 | ok $parsed.hash:exists, Q{statement list}; 36 | $parsed = $parsed.hash.; 37 | 38 | ok $parsed.hash:exists, Q{statement}; 39 | }, Q{empty file}; 40 | 41 | subtest { 42 | my $parsed = $pp.parse( Q{'a'} ); 43 | 44 | ok hash-matches( $parsed, 'statementlist', 0, 3, Q{'a'} ), Q{statementlist}; 45 | $parsed = $parsed.hash.; 46 | 47 | ok hash-matches( $parsed, 'statement', 0, 3, Q{'a'} ), Q{statement}; 48 | $parsed = $parsed.hash.; 49 | 50 | ok $parsed.list.elems > 0, q{list has at least one element}; 51 | $parsed = $parsed.list.[0]; 52 | 53 | ok hash-matches( $parsed, 'EXPR', 0, 3, Q{'a'} ), Q{EXPR}; 54 | $parsed = $parsed.hash.; 55 | 56 | ok hash-matches( $parsed, 'value', 0, 3, Q{'a'} ), Q{value}; 57 | $parsed = $parsed.hash.; 58 | 59 | ok hash-matches( $parsed, 'quote', 0, 3, Q{'a'} ), Q{quote}; 60 | $parsed = $parsed.hash.; 61 | 62 | ok hash-matches( $parsed, 'nibble', 1, 2, Q{a} ), Q{nibble}; 63 | $parsed = $parsed.hash.; 64 | 65 | ok !$parsed.hash, Q{tree ends}; 66 | }, Q{'a'}; 67 | 68 | # vim: ft=perl6 69 | -------------------------------------------------------------------------------- /t/02-perl6-tree.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | use Perl6::Parser; 5 | 6 | plan 3; 7 | 8 | my $pp = Perl6::Parser.new; 9 | my $*CONSISTENCY-CHECK = True; 10 | my $*FALL-THROUGH = True; 11 | 12 | subtest { 13 | my $parsed = $pp.to-tree( Q{} ); 14 | 15 | ok $parsed ~~ Perl6::Document, Q{document}; 16 | ok $parsed.is-twig, Q{document is a branch}; 17 | is $parsed.child.elems, 0, Q{document has no children}; 18 | }, Q{empty file}; 19 | 20 | subtest { 21 | my $parsed = $pp.to-tree( Q{ } ); 22 | 23 | subtest { 24 | ok $parsed ~~ Perl6::Document, Q{document}; 25 | ok $parsed.is-twig, Q{document is a branch}; 26 | is $parsed.child.elems, 1, Q{document has one WS child}; 27 | $parsed = $parsed.child.[0]; 28 | }, Q{document root}; 29 | 30 | subtest { 31 | ok $parsed ~~ Perl6::WS, Q{whitespace}; 32 | ok $parsed.is-leaf, Q{whitespace is a leaf}; 33 | }, Q{whitespace}; 34 | }, Q{''}; 35 | 36 | subtest { 37 | my $parsed = $pp.to-tree( Q{my $a = 1;} ); 38 | 39 | subtest { 40 | ok $parsed ~~ Perl6::Document, Q{type is correct}; 41 | ok $parsed.is-twig, Q{is a branch}; 42 | is $parsed.child.elems, 1, Q{has children}; 43 | }, Q{document root}; 44 | 45 | $parsed = $parsed.child.[0]; 46 | 47 | subtest { 48 | ok $parsed ~~ Perl6::Statement, Q{type is correct}; 49 | ok $parsed.is-twig, Q{statement is a leaf}; 50 | is $parsed.child.elems, 8, Q{has children}; 51 | # is $parsed.content, Q{my $a;}, Q{statement has correct content}; 52 | }, Q{Statement 'my $a;'}; 53 | 54 | my $count = 0; 55 | 56 | subtest { 57 | my $_parsed = $parsed.child.[$count++]; 58 | ok $_parsed ~~ Perl6::Bareword, Q{type is correct}; 59 | ok $_parsed.is-leaf, Q{is a leaf}; 60 | is $_parsed.content, Q{my}, Q{has correct content}; 61 | }, Q{Bareword 'my'}; 62 | 63 | subtest { 64 | my $_parsed = $parsed.child.[$count++]; 65 | ok $_parsed ~~ Perl6::WS, Q{type is correct}; 66 | ok $_parsed.is-leaf, Q{whitespace is a leaf}; 67 | is $_parsed.content, Q{ }, Q{has correct content}; 68 | }, Q{WS ' '}; 69 | 70 | subtest { 71 | my $_parsed = $parsed.child.[$count++]; 72 | ok $_parsed ~~ Perl6::Variable::Scalar, Q{type is correct}; 73 | ok $_parsed.is-leaf, Q{is a leaf}; 74 | is $_parsed.content, Q{$a}, Q{has correct content}; 75 | }, Q{Variable::Scalar '$a'}; 76 | 77 | subtest { 78 | my $_parsed = $parsed.child.[$count++]; 79 | ok $_parsed ~~ Perl6::WS, Q{type is correct}; 80 | ok $_parsed.is-leaf, Q{whitespace is a leaf}; 81 | is $_parsed.content, Q{ }, Q{has correct content}; 82 | }, Q{WS ' '}; 83 | 84 | subtest { 85 | my $_parsed = $parsed.child.[$count++]; 86 | ok $_parsed ~~ Perl6::Operator, Q{type is correct}; 87 | ok $_parsed.is-leaf, Q{is a leaf}; 88 | is $_parsed.content, Q{=}, Q{has correct content}; 89 | }, Q{Operator '='}; 90 | 91 | subtest { 92 | my $_parsed = $parsed.child.[$count++]; 93 | ok $_parsed ~~ Perl6::WS, Q{type is correct}; 94 | ok $_parsed.is-leaf, Q{whitespace is a leaf}; 95 | is $_parsed.content, Q{ }, Q{has correct content}; 96 | }, Q{WS ' '}; 97 | 98 | subtest { 99 | my $_parsed = $parsed.child.[$count++]; 100 | ok $_parsed ~~ Perl6::Number::Decimal, Q{type is correct}; 101 | ok $_parsed.is-leaf, Q{is a leaf}; 102 | is $_parsed.content, Q{1}, Q{has correct content}; 103 | }, Q{Operator '1'}; 104 | 105 | subtest { 106 | my $_parsed = $parsed.child.[$count++]; 107 | ok $_parsed ~~ Perl6::Semicolon, Q{type is correct}; 108 | ok $_parsed.is-leaf, Q{is a leaf}; 109 | is $_parsed.content, Q{;}, Q{has correct content}; 110 | }, Q{Semicolon ';'}; 111 | }, Q{my $a = 1;}; 112 | 113 | # vim: ft=perl6 114 | -------------------------------------------------------------------------------- /t/03-perl6-threaded-tree.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | use Perl6::Parser; 5 | use Perl6::Parser::Factory; 6 | 7 | plan 2; 8 | 9 | my $pp = Perl6::Parser.new; 10 | my $ppf = Perl6::Parser::Factory.new; 11 | my $*CONSISTENCY-CHECK = True; 12 | my $*FALL-THROUGH = True; 13 | 14 | subtest { 15 | my $parsed = $pp.to-tree( Q{} ); 16 | $ppf.thread( $parsed ); 17 | 18 | ok $parsed ~~ Perl6::Document, Q{root is a document}; 19 | 20 | subtest { 21 | ok $parsed.is-root, Q{root is root}; 22 | ok $parsed.is-start, Q{root is start}; 23 | #`{ ok !$parsed.is-start-leaf, Q{root is not start-leaf}; } 24 | ok $parsed.is-end, Q{root is end}; 25 | #`{ ok !$parsed.is-end-leaf, Q{root is end-leaf}; } 26 | 27 | #`{ Should twig be "accurate" based on whether the node is actually on its own 28 | or should it be based upon the type? } 29 | ok $parsed.is-twig, Q{root is a twig}; 30 | ok !$parsed.is-leaf, Q{root is not a leaf}; 31 | }, Q{root predicates}; 32 | 33 | subtest { 34 | ok $parsed.next, Q{root has a next node}; 35 | ok $parsed.next ~~ Perl6::Document, Q{next node loops back}; 36 | ok $parsed.next === $parsed, Q{next node is the root node}; 37 | 38 | ok $parsed.previous, Q{root has a previous node}; 39 | ok $parsed.previous ~~ Perl6::Document, Q{previous node loops back}; 40 | ok $parsed.previous === $parsed, Q{previous node is the root node}; 41 | 42 | ok $parsed.parent, Q{root has a parent node}; 43 | ok $parsed.parent ~~ Perl6::Document, Q{parent node loops back}; 44 | ok $parsed.parent === $parsed, Q{parent node is the root node}; 45 | }, Q{root accessors}; 46 | }, Q{empty file}; 47 | 48 | subtest { 49 | my $parsed = $pp.to-tree( Q{my $a = 1;} ); 50 | $ppf.thread( $parsed ); 51 | 52 | ok $parsed.first-child ~~ Perl6::Statement, 53 | Q{first child is a Statement}; 54 | ok $parsed.last-child ~~ Perl6::Statement, 55 | Q{last child is (the same) Statement}; 56 | 57 | $parsed = $parsed.first-child; 58 | 59 | subtest { 60 | my $bareword = $parsed.first-child; 61 | 62 | ok $bareword ~~ Perl6::Bareword, Q{has correct type}; 63 | is $bareword.content, 'my', Q{has correct content}; 64 | }, Q{'my'}; 65 | 66 | subtest { 67 | my $semicolon = $parsed.last-child; 68 | 69 | ok $semicolon ~~ Perl6::Semicolon, Q{has correct type}; 70 | is $semicolon.content, ';', Q{has correct content}; 71 | }, Q{';'}; 72 | }, Q{my $a = 1;}; 73 | 74 | # vim: ft=perl6 75 | -------------------------------------------------------------------------------- /t/04-iterator.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | use Perl6::Parser; 5 | 6 | plan 2; 7 | 8 | my $pp = Perl6::Parser.new; 9 | my $*CONSISTENCY-CHECK = True; 10 | my $*FALL-THROUGH = True; 11 | 12 | subtest { 13 | my $source = Q{();2;1;}; 14 | my @token = $pp.to-list( $source ); 15 | my $iterated = ''; 16 | 17 | for grep { .textual }, @token { 18 | $iterated ~= $_.content; 19 | } 20 | is $iterated, $source, Q{pull-one returns complete list}; 21 | 22 | done-testing; 23 | }, Q{default iterator pull-one}; 24 | 25 | subtest { 26 | my $source = Q{();2;1;}; 27 | my @token = $pp.to-tokens-only( $source ); 28 | my $iterated = ''; 29 | 30 | for @token { 31 | $iterated ~= $_.content; 32 | } 33 | is $iterated, $source, Q{tokens only display cleanly}; 34 | 35 | done-testing; 36 | }, Q{token-only iterator} 37 | 38 | # vim: ft=perl6 39 | -------------------------------------------------------------------------------- /t/05-editing.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | use Perl6::Parser; 5 | 6 | plan 6; 7 | 8 | my $pp = Perl6::Parser.new; 9 | my $ppf = Perl6::Parser::Factory.new; 10 | my $*CONSISTENCY-CHECK = True; 11 | my $*UPDATE-RANGES = True; 12 | my $*FALL-THROUGH = True; 13 | 14 | sub check-node( 15 | Perl6::Element $element, Mu $type, Mu $parent, Int $from, Int $to ) { 16 | my $is-ok = True; 17 | unless $element ~~ $type { 18 | diag "expected type '$type', got type '{$element.WHAT.perl}'"; 19 | $is-ok = False; 20 | } 21 | unless $element.parent ~~ $parent { 22 | diag "expected parent '$type', got type '{$element.WHAT.perl}'"; 23 | $is-ok = False; 24 | } 25 | unless $element.from == $from { 26 | diag "expected from $from, got {$element.from}"; 27 | $is-ok = False; 28 | } 29 | unless $element.to == $to { 30 | diag "expected to $to, got {$element.to}"; 31 | $is-ok = False; 32 | } 33 | return $is-ok; 34 | } 35 | 36 | subtest { 37 | my $source = Q{(3);2;1}; 38 | my $edited = Q{();2;1}; 39 | my $tree = $pp.to-tree( $source ); 40 | $ppf.thread( $tree ); 41 | my $head = $ppf.flatten( $tree ); 42 | 43 | my $walk-me = $head; 44 | my $integer = $head.next(4); 45 | 46 | # Remove the current element, and do so non-recursively. 47 | # That is, if there are elements "under" it in the tree, they'll 48 | # still be attached somehow. 49 | # 50 | $integer.remove-node; 51 | 52 | # Check links going forward and upward. 53 | # 54 | ok check-node( $head, Perl6::Document, Perl6::Document, 0, 7 ); 55 | $head = $head.next; 56 | 57 | ok check-node( $head, Perl6::Statement, Perl6::Document, 0, 4 ); 58 | $head = $head.next; 59 | 60 | ok check-node( $head, 61 | Perl6::Operator::Circumfix, Perl6::Statement, 0, 3 ); 62 | $head = $head.next; 63 | 64 | ok check-node( $head, 65 | Perl6::Balanced::Enter, Perl6::Operator::Circumfix, 0, 1 ); 66 | $head = $head.next; 67 | 68 | # ok $head ~~ Perl6::Number::Decimal; 69 | # is $head.from, 2; 70 | # $head = $head.next; 71 | 72 | ok check-node( $head, 73 | Perl6::Balanced::Exit, Perl6::Operator::Circumfix, 1, 2 ); 74 | $head = $head.next; 75 | 76 | ok check-node( $head, Perl6::Semicolon, Perl6::Statement, 2, 3 ); 77 | $head = $head.next; 78 | 79 | ok check-node( $head, Perl6::Statement, Perl6::Document, 3, 5 ); 80 | $head = $head.next; 81 | 82 | ok check-node( $head, Perl6::Number::Decimal, Perl6::Statement, 3, 4 ); 83 | $head = $head.next; 84 | 85 | ok check-node( $head, Perl6::Semicolon, Perl6::Statement, 4, 5 ); 86 | $head = $head.next; 87 | 88 | ok check-node( $head, Perl6::Statement, Perl6::Document, 5, 6 ); 89 | $head = $head.next; 90 | 91 | ok check-node( $head, Perl6::Number::Decimal, Perl6::Statement, 6, 7 ); 92 | $head = $head.next; 93 | 94 | ok check-node( $head, Perl6::Number::Decimal, Perl6::Statement, 6, 7 ); 95 | ok $head.is-end; 96 | 97 | # Now that we're at the end, throw this baby into reverse. 98 | # 99 | ok $head ~~ Perl6::Number::Decimal; $head = $head.previous; 100 | ok $head ~~ Perl6::Statement; $head = $head.previous; 101 | ok $head ~~ Perl6::Semicolon; $head = $head.previous; 102 | ok $head ~~ Perl6::Number; $head = $head.previous; 103 | ok $head ~~ Perl6::Statement; $head = $head.previous; 104 | ok $head ~~ Perl6::Semicolon; $head = $head.previous; 105 | ok $head ~~ Perl6::Balanced::Exit; $head = $head.previous; 106 | # ok $head ~~ Perl6::String::Body; $head = $head.previous; 107 | ok $head ~~ Perl6::Balanced::Enter; $head = $head.previous; 108 | ok $head ~~ Perl6::Operator::Circumfix; $head = $head.previous; 109 | ok $head ~~ Perl6::Statement; $head = $head.previous; 110 | ok $head ~~ Perl6::Document; $head = $head.previous; 111 | ok $head.is-start; 112 | 113 | my $iterated = ''; 114 | while $walk-me { 115 | $iterated ~= $walk-me.content if $walk-me.is-leaf; 116 | last if $walk-me.is-end; 117 | $walk-me = $walk-me.next; 118 | } 119 | is $iterated, $edited, Q{edited document}; 120 | 121 | done-testing; 122 | }, Q{Remove internal node}; 123 | 124 | subtest { 125 | my $source = Q{(3);2;1}; 126 | my $edited = Q{(42);2;1}; 127 | my $tree = $pp.to-tree( $source ); 128 | $ppf.thread( $tree ); 129 | my $head = $ppf.flatten( $tree ); 130 | 131 | my $walk-me = $head; 132 | my $integer = $head.next(4); 133 | 134 | $integer.replace-node-with( 135 | Perl6::Number::Decimal.new( 136 | :from( 1 ), 137 | :to( 2 ), 138 | :content( '42' ) 139 | ) 140 | ); 141 | 142 | # Check links going forward and upward. 143 | # 144 | ok check-node( $head, Perl6::Document, Perl6::Document, 0, 7 ); 145 | $head = $head.next; 146 | 147 | ok check-node( $head, Perl6::Statement, Perl6::Document, 0, 4 ); 148 | $head = $head.next; 149 | 150 | ok check-node( $head, 151 | Perl6::Operator::Circumfix, Perl6::Statement, 0, 3 ); 152 | $head = $head.next; 153 | 154 | ok check-node( $head, 155 | Perl6::Balanced::Enter, Perl6::Operator::Circumfix, 0, 1 ); 156 | $head = $head.next; 157 | 158 | ok check-node( $head, 159 | Perl6::Number::Decimal, Perl6::Operator::Circumfix, 1, 2 ); 160 | $head = $head.next; 161 | 162 | ok check-node( $head, 163 | Perl6::Balanced::Exit, Perl6::Operator::Circumfix, 2, 3 ); 164 | $head = $head.next; 165 | 166 | ok check-node( $head, 167 | Perl6::Semicolon, Perl6::Statement, 3, 4 ); 168 | $head = $head.next; 169 | 170 | ok check-node( $head, 171 | Perl6::Statement, Perl6::Document, 4, 6 ); 172 | $head = $head.next; 173 | 174 | ok check-node( $head, 175 | Perl6::Number::Decimal, Perl6::Statement, 4, 5 ); 176 | $head = $head.next; 177 | 178 | ok check-node( $head, 179 | Perl6::Semicolon, Perl6::Statement, 5, 6 ); 180 | $head = $head.next; 181 | 182 | ok check-node( $head, 183 | Perl6::Statement, Perl6::Document, 6, 7 ); 184 | $head = $head.next; 185 | 186 | ok check-node( $head, 187 | Perl6::Number::Decimal, Perl6::Statement, 6, 7 ); 188 | $head = $head.next; 189 | 190 | ok check-node( $head, 191 | Perl6::Number::Decimal, Perl6::Statement, 6, 7 ); 192 | ok $head.is-end; 193 | 194 | # Now that we're at the end, throw this baby into reverse. 195 | # 196 | ok $head ~~ Perl6::Number::Decimal; $head = $head.previous; 197 | ok $head ~~ Perl6::Statement; $head = $head.previous; 198 | ok $head ~~ Perl6::Semicolon; $head = $head.previous; 199 | ok $head ~~ Perl6::Number; $head = $head.previous; 200 | ok $head ~~ Perl6::Statement; $head = $head.previous; 201 | ok $head ~~ Perl6::Semicolon; $head = $head.previous; 202 | ok $head ~~ Perl6::Balanced::Exit; $head = $head.previous; 203 | ok $head ~~ Perl6::Number::Decimal; $head = $head.previous; 204 | ok $head ~~ Perl6::Balanced::Enter; $head = $head.previous; 205 | ok $head ~~ Perl6::Operator::Circumfix; $head = $head.previous; 206 | ok $head ~~ Perl6::Statement; $head = $head.previous; 207 | ok $head ~~ Perl6::Document; $head = $head.previous; 208 | ok $head.is-start; 209 | 210 | my $iterated = ''; 211 | while $walk-me { 212 | $iterated ~= $walk-me.content if $walk-me.is-leaf; 213 | last if $walk-me.is-end; 214 | $walk-me = $walk-me.next; 215 | } 216 | is $iterated, $edited, Q{edited document}; 217 | 218 | done-testing; 219 | }, Q{Replace internal node}; 220 | 221 | subtest { 222 | my $source = Q{(3);2;1}; 223 | my $edited = Q{(3);2;}; 224 | my $tree = $pp.to-tree( $source ); 225 | $ppf.thread( $tree ); 226 | my $head = $ppf.flatten( $tree ); 227 | 228 | my $walk-me = $head; 229 | my $one = $head; 230 | $one = $one.next while !$one.is-end; 231 | 232 | # Remove the current element, and do so non-recursively. 233 | # That is, if there are elements "under" it in the tree, they'll 234 | # still be attached somehow. 235 | # 236 | $one.remove-node; 237 | 238 | ok $head ~~ Perl6::Document; $head = $head.next; 239 | ok $head ~~ Perl6::Statement; $head = $head.next; 240 | ok $head ~~ Perl6::Operator::Circumfix; $head = $head.next; 241 | ok $head ~~ Perl6::Balanced::Enter; $head = $head.next; 242 | ok $head ~~ Perl6::Number::Decimal; $head = $head.next; 243 | ok $head ~~ Perl6::Balanced::Exit; $head = $head.next; 244 | ok $head ~~ Perl6::Semicolon; $head = $head.next; 245 | ok $head ~~ Perl6::Statement; $head = $head.next; 246 | ok $head ~~ Perl6::Number::Decimal; $head = $head.next; 247 | ok $head ~~ Perl6::Semicolon; $head = $head.next; 248 | ok $head ~~ Perl6::Statement; $head = $head.next; 249 | # ok $head ~~ Perl6::Number::Decimal; $head = $head.next; 250 | ok $head.is-end; 251 | 252 | # ok $head ~~ Perl6::Number::Decimal; $head = $head.previous; 253 | ok $head ~~ Perl6::Statement; $head = $head.previous; 254 | ok $head ~~ Perl6::Semicolon; $head = $head.previous; 255 | ok $head ~~ Perl6::Number::Decimal; $head = $head.previous; 256 | ok $head ~~ Perl6::Statement; $head = $head.previous; 257 | ok $head ~~ Perl6::Semicolon; $head = $head.previous; 258 | ok $head ~~ Perl6::Balanced::Exit; $head = $head.previous; 259 | ok $head ~~ Perl6::Number::Decimal; $head = $head.previous; 260 | ok $head ~~ Perl6::Balanced::Enter; $head = $head.previous; 261 | ok $head ~~ Perl6::Operator::Circumfix; $head = $head.previous; 262 | ok $head ~~ Perl6::Statement; $head = $head.previous; 263 | ok $head ~~ Perl6::Document; $head = $head.previous; 264 | 265 | my $iterated = ''; 266 | while $walk-me { 267 | $iterated ~= $walk-me.content if $walk-me.is-leaf; 268 | last if $walk-me.is-end; 269 | $walk-me = $walk-me.next; 270 | } 271 | is $iterated, $edited, Q{edited document}; 272 | 273 | done-testing; 274 | }, Q{Remove final node}; 275 | 276 | subtest { 277 | my $source = Q{();2;1}; 278 | my $edited = Q{(3);2;1}; 279 | my $tree = $pp.to-tree( $source ); 280 | $ppf.thread( $tree ); 281 | my $head = $ppf.flatten( $tree ); 282 | 283 | my $walk-me = $head; 284 | my $start-paren = $head.next(3); 285 | 286 | # insert '3' into the parenthesized list. 287 | # 288 | $start-paren.insert-node-after( 289 | Perl6::Number::Decimal.new( 290 | :from( 0 ), 291 | :to( 0 ), 292 | :content( '3' ) 293 | ) 294 | ); 295 | 296 | # Check links going forward and upward. 297 | # 298 | ok $head ~~ Perl6::Document; $head = $head.next; 299 | ok $head.parent ~~ Perl6::Document; 300 | ok $head ~~ Perl6::Statement; $head = $head.next; 301 | ok $head.parent ~~ Perl6::Statement; 302 | ok $head ~~ Perl6::Operator::Circumfix; $head = $head.next; 303 | ok $head.parent ~~ Perl6::Operator::Circumfix; 304 | ok $head ~~ Perl6::Balanced::Enter; $head = $head.next; 305 | ok $head.parent ~~ Perl6::Operator::Circumfix; 306 | ok $head ~~ Perl6::Number::Decimal; $head = $head.next; 307 | ok $head.parent ~~ Perl6::Operator::Circumfix; 308 | ok $head ~~ Perl6::Balanced::Exit; $head = $head.next; 309 | ok $head.parent ~~ Perl6::Statement; 310 | ok $head ~~ Perl6::Semicolon; $head = $head.next; 311 | ok $head.parent ~~ Perl6::Document; 312 | ok $head ~~ Perl6::Statement; $head = $head.next; 313 | ok $head.parent ~~ Perl6::Statement; 314 | ok $head ~~ Perl6::Number::Decimal; $head = $head.next; 315 | ok $head.parent ~~ Perl6::Statement; 316 | ok $head ~~ Perl6::Semicolon; $head = $head.next; 317 | ok $head.parent ~~ Perl6::Document; 318 | ok $head ~~ Perl6::Statement; $head = $head.next; 319 | ok $head.parent ~~ Perl6::Statement; 320 | ok $head ~~ Perl6::Number::Decimal; $head = $head.next; 321 | ok $head.is-end; 322 | 323 | # Now that we're at the end, throw this baby into reverse. 324 | # 325 | ok $head ~~ Perl6::Number::Decimal; $head = $head.previous; 326 | ok $head ~~ Perl6::Statement; $head = $head.previous; 327 | ok $head ~~ Perl6::Semicolon; $head = $head.previous; 328 | ok $head ~~ Perl6::Number; $head = $head.previous; 329 | ok $head ~~ Perl6::Statement; $head = $head.previous; 330 | ok $head ~~ Perl6::Semicolon; $head = $head.previous; 331 | ok $head ~~ Perl6::Balanced::Exit; $head = $head.previous; 332 | ok $head ~~ Perl6::Number::Decimal; $head = $head.previous; 333 | ok $head ~~ Perl6::Balanced::Enter; $head = $head.previous; 334 | ok $head ~~ Perl6::Operator::Circumfix; $head = $head.previous; 335 | ok $head ~~ Perl6::Statement; $head = $head.previous; 336 | ok $head ~~ Perl6::Document; $head = $head.previous; 337 | ok $head.is-start; 338 | 339 | my $iterated = ''; 340 | while $walk-me { 341 | $iterated ~= $walk-me.content if $walk-me.is-leaf; 342 | last if $walk-me.is-end; 343 | $walk-me = $walk-me.next; 344 | } 345 | is $iterated, $edited, Q{edited document}; 346 | 347 | done-testing; 348 | }, Q{Insert internal node after '('}; 349 | 350 | subtest { 351 | my $source = Q{();2;1}; 352 | my $edited = Q{(3);2;1}; 353 | my $tree = $pp.to-tree( $source ); 354 | $ppf.thread( $tree ); 355 | my $head = $ppf.flatten( $tree ); 356 | 357 | my $walk-me = $head; 358 | my $start-paren = $head.next(4); 359 | 360 | # insert '3' into the parenthesized list. 361 | # 362 | $start-paren.insert-node-before( 363 | Perl6::Number::Decimal.new( 364 | :from( 0 ), 365 | :to( 0 ), 366 | :content( '3' ) 367 | ) 368 | ); 369 | 370 | # Check links going forward and upward. 371 | # 372 | ok $head ~~ Perl6::Document; $head = $head.next; 373 | ok $head.parent ~~ Perl6::Document; 374 | ok $head ~~ Perl6::Statement; $head = $head.next; 375 | ok $head.parent ~~ Perl6::Statement; 376 | ok $head ~~ Perl6::Operator::Circumfix; $head = $head.next; 377 | ok $head.parent ~~ Perl6::Operator::Circumfix; 378 | ok $head ~~ Perl6::Balanced::Enter; $head = $head.next; 379 | ok $head.parent ~~ Perl6::Operator::Circumfix; 380 | ok $head ~~ Perl6::Number::Decimal; $head = $head.next; 381 | ok $head.parent ~~ Perl6::Operator::Circumfix; 382 | ok $head ~~ Perl6::Balanced::Exit; $head = $head.next; 383 | ok $head.parent ~~ Perl6::Statement; 384 | ok $head ~~ Perl6::Semicolon; $head = $head.next; 385 | ok $head.parent ~~ Perl6::Document; 386 | ok $head ~~ Perl6::Statement; $head = $head.next; 387 | ok $head.parent ~~ Perl6::Statement; 388 | ok $head ~~ Perl6::Number::Decimal; $head = $head.next; 389 | ok $head.parent ~~ Perl6::Statement; 390 | ok $head ~~ Perl6::Semicolon; $head = $head.next; 391 | ok $head.parent ~~ Perl6::Document; 392 | ok $head ~~ Perl6::Statement; $head = $head.next; 393 | ok $head.parent ~~ Perl6::Statement; 394 | ok $head ~~ Perl6::Number::Decimal; $head = $head.next; 395 | ok $head.is-end; 396 | 397 | # Now that we're at the end, throw this baby into reverse. 398 | # 399 | ok $head ~~ Perl6::Number::Decimal; $head = $head.previous; 400 | ok $head ~~ Perl6::Statement; $head = $head.previous; 401 | ok $head ~~ Perl6::Semicolon; $head = $head.previous; 402 | ok $head ~~ Perl6::Number; $head = $head.previous; 403 | ok $head ~~ Perl6::Statement; $head = $head.previous; 404 | ok $head ~~ Perl6::Semicolon; $head = $head.previous; 405 | ok $head ~~ Perl6::Balanced::Exit; $head = $head.previous; 406 | ok $head ~~ Perl6::Number::Decimal; $head = $head.previous; 407 | ok $head ~~ Perl6::Balanced::Enter; $head = $head.previous; 408 | ok $head ~~ Perl6::Operator::Circumfix; $head = $head.previous; 409 | ok $head ~~ Perl6::Statement; $head = $head.previous; 410 | ok $head ~~ Perl6::Document; $head = $head.previous; 411 | ok $head.is-start; 412 | 413 | my $iterated = ''; 414 | while $walk-me { 415 | $iterated ~= $walk-me.content if $walk-me.is-leaf; 416 | last if $walk-me.is-end; 417 | $walk-me = $walk-me.next; 418 | } 419 | is $iterated, $edited, Q{edited document}; 420 | 421 | done-testing; 422 | }, Q{Insert internal node before ')'}; 423 | 424 | subtest { 425 | my $source = Q{();2;1;}; 426 | my $edited = Q{();42;1;}; 427 | my @token = $pp.to-list( $source ); 428 | my $iterated = ''; 429 | 430 | my $replacement = 431 | Perl6::Number::Decimal.new( :from(0), :to(0), :content('42') ); 432 | 433 | @token.splice( 7, 1, $replacement ); 434 | 435 | for grep { .textual }, @token { 436 | $iterated ~= $_.content; 437 | } 438 | is $iterated, $edited, Q{splice into array works}; 439 | 440 | done-testing; 441 | }, Q{edit list}; 442 | 443 | # vim: ft=perl6 444 | -------------------------------------------------------------------------------- /t/06-phasers-check.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | use Perl6::Parser; 5 | 6 | use lib 't/lib'; 7 | use Utils; 8 | 9 | plan 5; 10 | 11 | my $*CONSISTENCY-CHECK = True; 12 | my $*FALL-THROUGH = True; 13 | 14 | # Make certain that BEGIN {}, CHECK {}, phasers don't halt compilation. 15 | # Also check that 'my $x will begin { }', 'my $x will check { }' phasers 16 | # don't halt compilation. 17 | # 18 | 19 | ok round-trips( Q{BEGIN { die "HALT!" }} ), 20 | Q{BEGIN}; 21 | ok round-trips( Q{BEGIN { die "HALT!" }; BEGIN { die "HALT!" }} ), 22 | Q{BEGIN BEGIN}; 23 | ok round-trips( Q{CHECK { die "HALT!" }} ), 24 | Q{CHECK}; 25 | ok round-trips( Q{CHECK { die "HALT!" }; CHECK { die "HALT!" }} ), 26 | Q{CHECK CHECK}; 27 | ok round-trips( Q{BEGIN { die "HALT!" }; CHECK { die "HALT!" }} ), 28 | Q{BEGIN CHECK}; 29 | 30 | # XXX Yes, there is Q{my $x will begin { die "HALT!" }} as well. 31 | # XXX The simple answer doesn't seem to work, I'll work on it later. 32 | 33 | # vim: ft=perl6 34 | -------------------------------------------------------------------------------- /t/10-multi-declarator.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | use Perl6::Parser; 5 | 6 | use lib 't/lib/'; 7 | use Utils; 8 | 9 | plan 4; 10 | 11 | # The terms that get tested here are: 12 | # 13 | # multi 14 | # proto 15 | # only 16 | # null 17 | 18 | my $*CONSISTENCY-CHECK = True; 19 | my $*FALL-THROUGH = True; 20 | 21 | subtest { 22 | my $pp = Perl6::Parser.new; 23 | my $tree = $pp.to-tree( Q:to[_END_] ); 24 | multi Foo{} 25 | _END_ 26 | 27 | ok has-a( $tree, Perl6::Block::Enter ), Q{enter brace}; 28 | ok has-a( $tree, Perl6::Block::Exit ), Q{exit brace}; 29 | 30 | done-testing; 31 | }, Q{Check the token structure}; 32 | 33 | subtest { 34 | plan 2; 35 | 36 | subtest { 37 | plan 4; 38 | 39 | ok round-trips( Q:to[_END_] ), Q{no ws}; 40 | multi Foo{} 41 | _END_ 42 | 43 | ok round-trips( Q:to[_END_] ), Q{leading ws}; 44 | multi Foo {} 45 | _END_ 46 | 47 | ok round-trips( Q{multi Foo{} } ), Q{trailing ws}; 48 | 49 | ok round-trips( Q{multi Foo {} } ), Q{leading, trailing ws}; 50 | }, Q{no intrabrace spacing}; 51 | 52 | subtest { 53 | plan 4; 54 | 55 | ok round-trips( Q:to[_END_] ), Q{no ws}; 56 | multi Foo{ } 57 | _END_ 58 | 59 | ok round-trips( Q:to[_END_] ), Q{leading ws}; 60 | multi Foo { } 61 | _END_ 62 | 63 | ok round-trips( Q{multi Foo{ } } ), Q{trailing ws}; 64 | 65 | ok round-trips( Q{multi Foo { } } ), Q{leading, trailing ws}; 66 | }, Q{intrabrace spacing}; 67 | }, Q{multi}; 68 | 69 | subtest { 70 | plan 2; 71 | 72 | subtest { 73 | plan 4; 74 | 75 | ok round-trips( Q:to[_END_] ), Q{no ws}; 76 | proto Foo{} 77 | _END_ 78 | 79 | ok round-trips( Q:to[_END_] ), Q{leading ws}; 80 | proto Foo {} 81 | _END_ 82 | 83 | ok round-trips( Q{proto Foo{} } ), Q{trailing ws}; 84 | 85 | ok round-trips( Q{proto Foo {} } ), Q{leading, trailing ws}; 86 | }, Q{no intrabrace spacing}; 87 | 88 | subtest { 89 | plan 4; 90 | 91 | ok round-trips( Q:to[_END_] ), Q{no ws}; 92 | proto Foo{ } 93 | _END_ 94 | 95 | ok round-trips( Q:to[_END_] ), Q{leading ws}; 96 | proto Foo { } 97 | _END_ 98 | 99 | ok round-trips( Q{proto Foo{ } } ), Q{trailing ws}; 100 | 101 | ok round-trips( Q{proto Foo { } } ), Q{leading, trailing ws}; 102 | }, Q{intrabrace spacing}; 103 | }, Q{proto}; 104 | 105 | subtest { 106 | plan 2; 107 | 108 | subtest { 109 | plan 4; 110 | 111 | ok round-trips( Q:to[_END_] ), Q{no ws}; 112 | only Foo{} 113 | _END_ 114 | 115 | ok round-trips( Q:to[_END_] ), Q{leading ws}; 116 | only Foo {} 117 | _END_ 118 | 119 | ok round-trips( Q{only Foo{} } ), Q{trailing ws}; 120 | 121 | ok round-trips( Q{only Foo {} } ), Q{leading, trailing ws}; 122 | }, Q{no intrabrace spacing}; 123 | 124 | subtest { 125 | plan 4; 126 | 127 | ok round-trips( Q:to[_END_] ), Q{no ws}; 128 | only Foo{ } 129 | _END_ 130 | 131 | ok round-trips( Q:to[_END_] ), Q{no leading ws}; 132 | only Foo { } 133 | _END_ 134 | 135 | ok round-trips( Q{only Foo{ } } ), Q{trailing ws}; 136 | 137 | ok round-trips( Q{only Foo { } } ), Q{leading, trailing ws}; 138 | }, Q{intrabrace spacing}; 139 | }, Q{only}; 140 | 141 | # 'null' does not exist 142 | 143 | # vim: ft=perl6 144 | -------------------------------------------------------------------------------- /t/11-package-declarator.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | use Perl6::Parser; 5 | 6 | use lib 't/lib'; 7 | use Utils; 8 | 9 | plan 9; 10 | 11 | my $*CONSISTENCY-CHECK = True; 12 | my $*FALL-THROUGH = True; 13 | 14 | # The terms that get tested here are: 15 | 16 | # package { } 17 | # module { } 18 | # class { } 19 | # grammar { } 20 | # role { } 21 | # knowhow { } 22 | # native { } 23 | # also is 24 | # trusts 25 | # 26 | # class Foo { also is Int } # 'also' is a package_declaration. 27 | # class Foo { trusts Int } # 'trusts' is a package_declaration. 28 | 29 | # These terms either are invalid or need additional support structures. 30 | # I'll add them momentarily... 31 | # 32 | # lang 33 | 34 | subtest { 35 | my $pp = Perl6::Parser.new; 36 | my $source = gensym-package Q{package %s{}}; 37 | my $tree = $pp.to-tree( $source ); 38 | 39 | ok has-a( $tree, Perl6::Block::Enter ), Q{enter brace}; 40 | ok has-a( $tree, Perl6::Block::Exit ), Q{exit brace}; 41 | 42 | done-testing; 43 | }, Q{Check the token structure}; 44 | 45 | subtest { 46 | subtest { 47 | plan 4; 48 | 49 | ok round-trips( gensym-package Q{package %s{}} ), Q{no ws}; 50 | 51 | ok round-trips( gensym-package Q:to[_END_] ), Q{leading ws}; 52 | package %s {} 53 | _END_ 54 | 55 | ok round-trips( gensym-package Q{package %s{} } ), 56 | Q{trailing ws}; 57 | 58 | ok round-trips( gensym-package Q{package %s {} } ), 59 | Q{leading, trailing ws}; 60 | }, Q{no intrabrace spacing}; 61 | 62 | subtest { 63 | plan 4; 64 | 65 | ok round-trips( gensym-package Q{package %s{ }} ), Q{no ws}; 66 | 67 | ok round-trips( gensym-package Q:to[_END_] ), Q{leading ws}; 68 | package %s { } 69 | _END_ 70 | 71 | ok round-trips( gensym-package Q{package %s{ } } ), Q{trailing ws}; 72 | 73 | ok round-trips( gensym-package Q{package %s { } } ), 74 | Q{leading, trailing ws}; 75 | }, Q{intrabrace spacing}; 76 | 77 | subtest { 78 | plan 2; 79 | 80 | ok round-trips( gensym-package Q{unit package %s;} ), Q{no ws}; 81 | 82 | ok round-trips( gensym-package Q:to[_END_] ), Q{ws before semi}; 83 | unit package %s ; 84 | _END_ 85 | }, Q{unit form}; 86 | }, Q{package}; 87 | 88 | subtest { 89 | subtest { 90 | plan 4; 91 | 92 | ok round-trips( gensym-package Q{module %s{}} ), Q{no ws}; 93 | 94 | ok round-trips( gensym-package Q:to[_END_] ), Q{leading ws}; 95 | module %s {} 96 | _END_ 97 | 98 | ok round-trips( gensym-package Q{module %s{} } ), Q{trailing ws}; 99 | 100 | ok round-trips( gensym-package Q{module %s {} } ), 101 | Q{leading, trailing ws}; 102 | }, Q{no intrabrace spacing}; 103 | 104 | subtest { 105 | plan 4; 106 | 107 | ok round-trips( gensym-package Q{module %s{ }} ), Q{no ws}; 108 | 109 | ok round-trips( gensym-package Q:to[_END_] ), Q{leading ws}; 110 | module %s { } 111 | _END_ 112 | 113 | ok round-trips( gensym-package Q{module %s{ } } ), Q{trailing ws}; 114 | 115 | ok round-trips( gensym-package Q{module %s { } } ), 116 | Q{leading, trailing ws}; 117 | }, Q{intrabrace spacing}; 118 | 119 | subtest { 120 | plan 2; 121 | 122 | ok round-trips( gensym-package Q{unit module %s;} ), Q{no ws}; 123 | 124 | ok round-trips( gensym-package Q:to[_END_] ), Q{ws}; 125 | unit module %s; 126 | _END_ 127 | }, Q{unit form}; 128 | }, Q{module}; 129 | 130 | subtest { 131 | subtest { 132 | plan 4; 133 | 134 | ok round-trips( gensym-package Q{class %s{}} ), Q{no ws}; 135 | 136 | ok round-trips( gensym-package Q:to[_END_] ), Q{leading ws}; 137 | class %s {} 138 | _END_ 139 | 140 | ok round-trips( gensym-package Q{class %s{} } ), Q{trailing ws}; 141 | 142 | ok round-trips( gensym-package Q{class %s {} } ), 143 | Q{leading, trailing ws}; 144 | }, Q{no intrabrace spacing}; 145 | 146 | subtest { 147 | plan 4; 148 | 149 | ok round-trips( gensym-package Q{class %s{ }} ), Q{no ws}; 150 | 151 | ok round-trips( gensym-package Q:to[_END_] ), Q{leading ws}; 152 | class %s { } 153 | _END_ 154 | 155 | ok round-trips( gensym-package Q{class %s{ } } ), Q{trailing ws}; 156 | 157 | ok round-trips( gensym-package Q{class %s { } } ), 158 | Q{leading, trailing ws}; 159 | }, Q{intrabrace spacing}; 160 | 161 | subtest { 162 | plan 2; 163 | 164 | ok round-trips( gensym-package Q{unit class %s;} ), Q{no ws}; 165 | 166 | ok round-trips( gensym-package Q:to[_END_] ), Q{ws}; 167 | unit class %s; 168 | _END_ 169 | }, Q{unit form}; 170 | 171 | subtest { 172 | plan 2; 173 | 174 | ok round-trips( gensym-package Q{class %s{also is Int}} ), Q{no ws}; 175 | 176 | ok round-trips( gensym-package Q:to[_END_] ), Q{ws}; 177 | class %s{also is Int} 178 | _END_ 179 | }, Q{also is}; 180 | 181 | subtest { 182 | plan 2; 183 | 184 | # space between 'Int' and {} is required 185 | ok round-trips( gensym-package Q{class %s is Int {}} ), Q{no ws}; 186 | 187 | ok round-trips( gensym-package Q:to[_END_] ), Q{ws}; 188 | class %s is Int {} 189 | _END_ 190 | }, Q{is}; 191 | 192 | subtest { 193 | plan 4; 194 | 195 | ok round-trips( gensym-package Q{class %s is repr('CStruct'){has int8$i}} ), 196 | Q{no ws}; 197 | 198 | ok round-trips( gensym-package Q:to[_END_] ), Q{ws}; 199 | class %s is repr('CStruct'){has int8$i} 200 | _END_ 201 | 202 | ok round-trips( gensym-package Q:to[_END_] ), Q{more ws}; 203 | class %s is repr('CStruct') { has int8 $i } 204 | _END_ 205 | 206 | ok round-trips( gensym-package Q:to[_END_] ), Q{even more ws}; 207 | class %s is repr( 'CStruct' ) { has int8 $i } 208 | _END_ 209 | }, Q{is repr()}; 210 | }, Q{class}; 211 | 212 | subtest { 213 | plan 2; 214 | 215 | # space between 'Int' and {} is required 216 | ok round-trips( gensym-package Q{class %s{trusts Int}} ), Q{no ws}; 217 | 218 | ok round-trips( gensym-package Q:to[_END_] ), Q{ws}; 219 | class %s { trusts Int } 220 | _END_ 221 | }, Q{class Foo trusts}; 222 | 223 | # grammar 224 | subtest { 225 | subtest { 226 | plan 4; 227 | 228 | ok round-trips( gensym-package Q{grammar %s{}} ), Q{no ws}; 229 | 230 | ok round-trips( gensym-package Q:to[_END_] ), Q{leading ws}; 231 | grammar %s {} 232 | _END_ 233 | 234 | ok round-trips( gensym-package Q{grammar %s{} } ), Q{trailing ws}; 235 | 236 | ok round-trips( gensym-package Q{grammar %s {} } ), 237 | Q{leading, trailing ws}; 238 | }, Q{no intrabrace spacing}; 239 | 240 | subtest { 241 | plan 4; 242 | 243 | ok round-trips( gensym-package Q{grammar %s{ }} ), Q{no ws}; 244 | 245 | ok round-trips( gensym-package Q:to[_END_] ), Q{leading ws}; 246 | grammar %s { } 247 | _END_ 248 | 249 | ok round-trips( gensym-package Q{grammar %s{ } } ), Q{trailing ws}; 250 | 251 | ok round-trips( gensym-package Q{grammar %s { } } ), 252 | Q{leading, trailing ws}; 253 | }, Q{intrabrace spacing}; 254 | 255 | subtest { 256 | plan 2; 257 | 258 | ok round-trips( gensym-package Q{unit grammar %s;} ), 259 | Q{no ws}; 260 | 261 | ok round-trips( gensym-package Q:to[_END_] ), Q{ws}; 262 | unit grammar %s; 263 | _END_ 264 | }, Q{unit form}; 265 | }, Q{grammar}; 266 | 267 | subtest { 268 | subtest { 269 | plan 4; 270 | 271 | ok round-trips( gensym-package Q{role %s{}} ), Q{no ws}; 272 | 273 | ok round-trips( gensym-package Q:to[_END_] ), Q{leading ws}; 274 | role %s {} 275 | _END_ 276 | 277 | ok round-trips( gensym-package Q{role %s{} } ), Q{trailing ws}; 278 | 279 | ok round-trips( gensym-package Q{role %s {} } ), 280 | Q{leading, trailing ws}; 281 | }, Q{no intrabrace spacing}; 282 | 283 | subtest { 284 | plan 4; 285 | 286 | ok round-trips( Q{role Foo{ }} ), Q{no ws}; 287 | 288 | ok round-trips( Q:to[_END_] ), Q{leading ws}; 289 | role Foo { } 290 | _END_ 291 | 292 | ok round-trips( Q{role Foo{ } } ), Q{trailing ws}; 293 | 294 | ok round-trips( Q{role Foo { } } ), Q{leading, trailing ws}; 295 | }, Q{intrabrace spacing}; 296 | 297 | subtest { 298 | plan 2; 299 | 300 | ok round-trips( gensym-package Q{unit role %s;} ), Q{no ws}; 301 | 302 | ok round-trips( gensym-package Q:to[_END_] ), Q{ws}; 303 | unit role %s; 304 | _END_ 305 | }, Q{unit form}; 306 | }, Q{role}; 307 | 308 | subtest { 309 | subtest { 310 | plan 4; 311 | 312 | ok round-trips( gensym-package Q{knowhow %s{}} ), Q{no ws}; 313 | 314 | ok round-trips( gensym-package Q:to[_END_] ), Q{leading ws}; 315 | knowhow %s {} 316 | _END_ 317 | 318 | ok round-trips( gensym-package Q{knowhow %s{} } ), Q{trailing ws}; 319 | 320 | ok round-trips( gensym-package Q{knowhow %s {} } ), 321 | Q{leading, trailing ws}; 322 | }, Q{no intrabrace spacing}; 323 | 324 | subtest { 325 | plan 4; 326 | 327 | ok round-trips( gensym-package Q{knowhow %s{ }} ), Q{no ws}; 328 | 329 | ok round-trips( gensym-package Q:to[_END_] ), Q{leading ws}; 330 | knowhow %s { } 331 | _END_ 332 | 333 | ok round-trips( gensym-package Q{knowhow %s{ } } ), Q{trailing ws}; 334 | 335 | ok round-trips( gensym-package Q{knowhow %s { } } ), 336 | Q{leading, trailing ws}; 337 | }, Q{intrabrace spacing}; 338 | 339 | subtest { 340 | plan 2; 341 | 342 | ok round-trips( gensym-package Q{unit knowhow %s;} ), Q{no ws}; 343 | 344 | ok round-trips( gensym-package Q:to[_END_] ), Q{ws}; 345 | unit knowhow %s; 346 | _END_ 347 | }, Q{unit form}; 348 | }, Q{knowhow}; 349 | 350 | subtest { 351 | subtest { 352 | plan 4; 353 | 354 | ok round-trips( gensym-package Q{native %s{}} ), Q{no ws}; 355 | 356 | ok round-trips( gensym-package Q:to[_END_] ), Q{leading ws}; 357 | native %s {} 358 | _END_ 359 | 360 | ok round-trips( gensym-package Q{native %s{} } ), Q{trailing ws}; 361 | 362 | ok round-trips( gensym-package Q{native %s {} } ), 363 | Q{leading, trailing ws}; 364 | }, Q{native - no intrabrace spacing}; 365 | 366 | subtest { 367 | plan 4; 368 | 369 | ok round-trips( gensym-package Q{native %s{ }} ), Q{no ws}; 370 | 371 | ok round-trips( gensym-package Q:to[_END_] ), Q{leading ws}; 372 | native %s { } 373 | _END_ 374 | 375 | ok round-trips( gensym-package Q{native %s{ } } ), Q{trailing ws}; 376 | 377 | ok round-trips( gensym-package Q{native %s { } } ), 378 | Q{leading, trailing ws}; 379 | }, Q{native - intrabrace spacing}; 380 | 381 | subtest { 382 | plan 2; 383 | 384 | ok round-trips( gensym-package Q{unit native %s;} ), Q{no ws}; 385 | 386 | ok round-trips( gensym-package Q:to[_END_] ), Q{ws}; 387 | unit native %s; 388 | _END_ 389 | }, Q{native - unit form}; 390 | }, Q{native}; 391 | 392 | # XXX 'lang Foo{}' illegal 393 | # XXX 'unit lang Foo;' illegal 394 | 395 | # vim: ft=perl6 396 | -------------------------------------------------------------------------------- /t/12-regex-declarator.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | use Perl6::Parser; 5 | 6 | use lib 't/lib'; 7 | use Utils; 8 | 9 | plan 4; 10 | 11 | my $*CONSISTENCY-CHECK = True; 12 | my $*FALL-THROUGH = True; 13 | 14 | # The terms that get tested here are: 15 | # 16 | # my rule Foo { } # 'rule' is a regex_declaration 17 | # my token Foo { } # 'token' is a regex_declaration 18 | # my regex Foo { } # 'regex' is a regex_declaration 19 | 20 | subtest { 21 | my $pp = Perl6::Parser.new; 22 | my $source = Q{my token Foo{a}}; 23 | my $tree = $pp.to-tree( $source ); 24 | 25 | ok has-a( $tree, Perl6::Block::Enter ), Q{enter brace}; 26 | ok has-a( $tree, Perl6::Block::Exit ), Q{exit brace}; 27 | 28 | done-testing; 29 | }, Q{Check the token structure}; 30 | 31 | subtest { 32 | subtest { 33 | plan 4; 34 | 35 | ok round-trips( Q{my token Foo{a}} ), Q{no ws}; 36 | 37 | ok round-trips( Q:to[_END_] ), Q{leading ws}; 38 | my token Foo {a} 39 | _END_ 40 | 41 | ok round-trips( Q{my token Foo{a} } ), Q{trailing ws}; 42 | 43 | ok round-trips( Q{my token Foo {a} } ), 44 | Q{leading, trailing ws}; 45 | }, Q{no intrabrace spacing}; 46 | 47 | subtest { 48 | plan 4; 49 | 50 | ok round-trips( Q:to[_END_] ), Q{no ws}; 51 | my token Foo{ a } 52 | _END_ 53 | 54 | 55 | ok round-trips( Q:to[_END_] ), Q{leading ws}; 56 | my token Foo { a } 57 | _END_ 58 | 59 | ok round-trips( Q{my token Foo{ a } } ), Q{trailing ws}; 60 | 61 | ok round-trips( Q{my token Foo { a } } ), Q{leading, trailing ws}; 62 | }, Q{intrabrace spacing}; 63 | }, Q{token}; 64 | 65 | subtest { 66 | plan 2; 67 | 68 | subtest { 69 | plan 4; 70 | 71 | ok round-trips( Q{my rule Foo{a}} ), Q{no ws}; 72 | 73 | ok round-trips( Q:to[_END_] ), Q{leading ws}; 74 | my rule Foo {a} 75 | _END_ 76 | 77 | ok round-trips( Q{my rule Foo{a} } ), Q{trailing ws}; 78 | 79 | ok round-trips( Q{my rule Foo {a} } ), Q{leading, trailing ws}; 80 | }, Q{no intrabrace spacing}; 81 | 82 | subtest { 83 | plan 4; 84 | 85 | ok round-trips( Q{my rule Foo{ a }} ), Q{no ws}; 86 | 87 | ok round-trips( Q{my rule Foo { a }} ), Q{leading ws}; 88 | 89 | ok round-trips( Q{my rule Foo{ a } } ), Q{trailing ws}; 90 | 91 | ok round-trips( Q{my rule Foo { a } } ), Q{leading, trailing ws}; 92 | }, Q{intrabrace spacing}; 93 | }, Q{rule}; 94 | 95 | subtest { 96 | plan 2; 97 | 98 | subtest { 99 | plan 4; 100 | 101 | ok round-trips( Q{my regex Foo{a}} ), Q{no ws}; 102 | 103 | ok round-trips( Q{my regex Foo {a}} ), Q{leading ws}; 104 | 105 | ok round-trips( Q{my regex Foo{a} } ), Q{trailing ws}; 106 | 107 | ok round-trips( Q{my regex Foo {a} } ), Q{leading, trailing ws}; 108 | }, Q{no intrabrace spacing}; 109 | 110 | subtest { 111 | plan 4; 112 | 113 | ok round-trips( Q{my regex Foo{ a }} ), Q{no ws}; 114 | 115 | ok round-trips( Q{my regex Foo { a }} ), Q{leading ws}; 116 | 117 | ok round-trips( Q{my regex Foo{ a } } ), Q{trailing ws}; 118 | 119 | ok round-trips( Q{my regex Foo { a } } ), 120 | Q{leading, trailing ws}; 121 | }, Q{intrabrace spacing}; 122 | }, Q{regex}; 123 | 124 | # vim: ft=perl6 125 | -------------------------------------------------------------------------------- /t/13-scope-declarator.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | use Perl6::Parser; 5 | 6 | use lib 't/lib/'; 7 | use Utils; 8 | 9 | plan 4; 10 | 11 | my $*CONSISTENCY-CHECK = True; 12 | my $*FALL-THROUGH = True; 13 | 14 | # The terms that get tested here are: 15 | # 16 | # my 17 | # our 18 | # has 19 | # HAS 20 | # augment 21 | # anon 22 | # state 23 | # supersede 24 | # 25 | # class Foo { has } # 'has' is a scope declaration. 26 | # class Foo { HAS } # 'HAS' requires a separate class to work 27 | 28 | # These terms are invalid: 29 | # 30 | # lang 31 | 32 | subtest { 33 | plan 3; 34 | 35 | subtest { 36 | my $pp = Perl6::Parser.new; 37 | my $source = Q:to[_END_]; 38 | my$x 39 | _END_ 40 | 41 | my $tree = $pp.to-tree( $source ); 42 | 43 | ok has-a( $tree, Perl6::Bareword ), Q{'my'}; 44 | ok has-a( $tree, Perl6::Variable::Scalar ), Q{'$x'}; 45 | ok has-a( $tree, Perl6::Newline ), Q{\n}; 46 | ok !has-a( $tree, Perl6::WS ), Q{no ' '}; 47 | 48 | done-testing; 49 | }, Q{Check the token structure}; 50 | 51 | ok round-trips( Q:to[_END_] ), Q{no ws}; 52 | my$x 53 | _END_ 54 | 55 | ok round-trips( Q:to[_END_] ), Q{leading ws}; 56 | my $x 57 | _END_ 58 | 59 | done-testing; 60 | }, Q{my}; 61 | 62 | subtest { 63 | plan 2; 64 | 65 | ok round-trips( Q:to[_END_] ), Q{no ws}; 66 | our$x 67 | _END_ 68 | 69 | ok round-trips( Q:to[_END_] ), Q{leading ws}; 70 | our $x 71 | _END_ 72 | 73 | done-testing; 74 | }, Q{our}; 75 | 76 | subtest { 77 | subtest { 78 | my $pp = Perl6::Parser.new; 79 | my $source = gensym-package Q:to[_END_]; 80 | class %s{has$x} 81 | _END_ 82 | 83 | my $tree = $pp.to-tree( $source ); 84 | ok has-a( $tree, Perl6::Block::Enter ), Q{enter brace}; 85 | ok has-a( $tree, Perl6::Block::Exit ), Q{exit brace}; 86 | 87 | done-testing; 88 | }, Q{Check the token structure}; 89 | 90 | ok round-trips( gensym-package Q:to[_END_] ), Q{no ws}; 91 | class %s{has$x} 92 | _END_ 93 | 94 | ok round-trips( gensym-package Q:to[_END_] ), Q{leading ws}; 95 | class %s{has $x} 96 | _END_ 97 | 98 | done-testing; 99 | }, Q{has}; 100 | 101 | # HAS requires another class definition. 102 | # 103 | #subtest { 104 | # plan 2; 105 | # 106 | # subtest { 107 | # $source = Q{class Foo is repr('CStruct'){HAS int $x}}; 108 | # ok round-trips( $source ), Q{formatted}; 109 | # 110 | # done-testing; 111 | # }, Q{no ws}; 112 | # 113 | # subtest { 114 | # source = Q:to[_END_]; 115 | # lass Foo is repr( 'CStruct' ) { HAS int $x } 116 | # END_ 117 | # 118 | # ok round-trips( $source ), Q{formatted}; 119 | # 120 | # done-testing; 121 | # }, Q{leading ws}; 122 | #}, Q{HAS}; 123 | 124 | # XXX 'augment $x' is NIY 125 | 126 | # XXX 'anon $x' is NIY 127 | 128 | ok round-trips( Q:to[_END_] ), Q{state}; 129 | state $x 130 | _END_ 131 | 132 | # XXX 'supersede $x' NIY 133 | 134 | # vim: ft=perl6 135 | -------------------------------------------------------------------------------- /t/14-type-declarator.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | use Perl6::Parser; 5 | 6 | use lib 't/lib/'; 7 | use Utils; 8 | 9 | plan 3; 10 | 11 | my $*CONSISTENCY-CHECK = True; 12 | my $*FALL-THROUGH = True; 13 | 14 | # The terms that get tested here are: 15 | # 16 | # enum "foo" 17 | # subset of Type 18 | # constant = 1 19 | 20 | subtest { 21 | plan 3; 22 | 23 | subtest { 24 | my $pp = Perl6::Parser.new; 25 | my $source = gensym-package Q:to[_END_]; 26 | enum %s() 27 | _END_ 28 | 29 | my $tree = $pp.to-tree( $source ); 30 | 31 | ok has-a( $tree, Perl6::Bareword ), Q{'my'}; 32 | ok has-a( $tree, Perl6::WS ), Q{' '}; 33 | ok has-a( $tree, Perl6::Bareword ), Q{Foo%s}; 34 | ok has-a( $tree, Perl6::Operator::Circumfix) , q{open}; 35 | ok has-a( $tree, Perl6::Balanced::Enter ), Q{enter brace}; 36 | ok has-a( $tree, Perl6::Balanced::Exit ), Q{exit brace}; 37 | ok has-a( $tree, Perl6::Newline ), Q{\n}; 38 | 39 | done-testing; 40 | }, Q{Check the token structure}; 41 | 42 | subtest { 43 | plan 4; 44 | 45 | ok round-trips( gensym-package Q:to[_END_] ), Q{no ws}; 46 | enum %s() 47 | _END_ 48 | 49 | ok round-trips( gensym-package Q:to[_END_] ), Q{leading ws}; 50 | enum %s () 51 | _END_ 52 | 53 | ok round-trips( gensym-package Q{enum %s() } ), Q{trailing ws}; 54 | 55 | ok round-trips( gensym-package Q{enum %s () } ), 56 | Q{leading, trailing ws}; 57 | }, Q{no intrabrace spacing}; 58 | 59 | subtest { 60 | plan 4; 61 | 62 | ok round-trips( gensym-package Q:to[_END_] ), Q{no ws}; 63 | enum %s( ) 64 | _END_ 65 | 66 | ok round-trips( gensym-package Q:to[_END_] ), Q{leading ws}; 67 | enum %s ( ) 68 | _END_ 69 | 70 | ok round-trips( gensym-package Q{enum %s( ) } ), Q{trailing ws}; 71 | 72 | ok round-trips( gensym-package Q{enum %s ( ) } ), 73 | Q{leading, trailing ws}; 74 | }, Q{intrabrace spacing}; 75 | }, Q{enum}; 76 | 77 | subtest { 78 | plan 2; 79 | 80 | subtest { 81 | plan 2; 82 | 83 | ok round-trips( gensym-package Q:to[_END_] ), Q{no ws}; 84 | subset %s of Int 85 | _END_ 86 | 87 | ok round-trips( gensym-package Q{subset %s of Int } ), Q{trailing ws}; 88 | }, Q{Normal version}; 89 | 90 | ok round-trips( gensym-package Q:to[_END_] ), Q{unit form}; 91 | unit subset %s; 92 | _END_ 93 | }, Q{subset}; 94 | 95 | subtest { 96 | plan 5; 97 | 98 | ok round-trips( Q:to[_END_] ), Q{no ws}; 99 | constant Foo=1 100 | _END_ 101 | 102 | ok round-trips( Q:to[_END_] ), Q{leading ws}; 103 | constant Foo =1 104 | _END_ 105 | 106 | ok round-trips( Q:to[_END_] ), Q{intermediate ws}; 107 | constant Foo= 1 108 | _END_ 109 | 110 | ok round-trips( Q:to[_END_] ), Q{intermediate ws}; 111 | constant Foo = 1 112 | _END_ 113 | 114 | ok round-trips( Q{constant Foo=1 } ), Q{trailing ws}; 115 | }, Q{constant}; 116 | 117 | # vim: ft=perl6 118 | -------------------------------------------------------------------------------- /t/15-routine-declarator.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | use Perl6::Parser; 5 | 6 | use lib 't/lib'; 7 | use Utils; 8 | 9 | plan 4; 10 | 11 | my $pp = Perl6::Parser.new; 12 | my $*CONSISTENCY-CHECK = True; 13 | my $*FALL-THROUGH = True; 14 | 15 | # The terms that get tested here are: 16 | # 17 | # sub ... { } 18 | # method ... { } 19 | # submethod ... { } 20 | # 21 | # class Foo { method Bar { } } # 'method' is a routine_declaration. 22 | # class Foo { submethod Bar { } } # 'submethod' is a routine_declaration. 23 | 24 | # These terms either are invalid or need additional support structures. 25 | # 26 | # macro ... { } # NYI 27 | 28 | # MAIN is the only subroutine that allows the 'unit sub FOO' form, 29 | # and naturally it can't be redeclared, as there's only one MAIN. 30 | # 31 | # So here it remains, outside the testing block. 32 | # 33 | subtest { 34 | plan 2; 35 | 36 | ok round-trips( Q{unit sub MAIN;} ), Q{no ws}; 37 | 38 | ok round-trips( Q:to[_END_] ), Q{ws before semi}; 39 | unit sub MAIN ; 40 | _END_ 41 | }, Q{unit form}; 42 | 43 | subtest { 44 | plan 2; 45 | 46 | subtest { 47 | plan 4; 48 | 49 | subtest { 50 | my $source = gensym-package Q:to[_END_]; 51 | sub %s{} 52 | _END_ 53 | my $tree = $pp.to-tree( $source ); 54 | is $pp.to-string( $tree ), $source, Q{formatted}; 55 | ok $tree.child[0].child[3].child[0] ~~ 56 | Perl6::Block::Enter, Q{enter brace}; 57 | ok $tree.child[0].child[3].child[1] ~~ 58 | Perl6::Block::Exit, Q{exit brace}; 59 | 60 | done-testing; 61 | }, Q{no ws}; 62 | 63 | ok round-trips( gensym-package Q:to[_END_] ), Q{leading ws}; 64 | sub %s {} 65 | _END_ 66 | 67 | ok round-trips( gensym-package Q{sub %s{} } ), Q{trailing ws}; 68 | 69 | ok round-trips( gensym-package Q{sub %s {} } ), 70 | Q{leading, trailing ws}; 71 | }, Q{no intrabrace spacing}; 72 | 73 | subtest { 74 | plan 4; 75 | 76 | ok round-trips( gensym-package Q:to[_END_] ), Q{no ws}; 77 | sub %s{ } 78 | _END_ 79 | 80 | ok round-trips( gensym-package Q:to[_END_] ), Q{leading ws}; 81 | sub %s { } 82 | _END_ 83 | 84 | ok round-trips( gensym-package Q{sub %s{ } } ), Q{trailing ws}; 85 | 86 | ok round-trips( gensym-package Q{sub %s { } } ), 87 | Q{leading, trailing ws}; 88 | }, Q{intrabrace spacing}; 89 | }, Q{sub}; 90 | 91 | subtest { 92 | plan 2; 93 | 94 | subtest { 95 | plan 4; 96 | 97 | subtest { 98 | my $source = gensym-package Q:to[_END_]; 99 | class %s{method Bar{}} 100 | _END_ 101 | my $tree = $pp.to-tree( $source ); 102 | is $pp.to-string( $tree ), $source, Q{formatted}; 103 | 104 | ok has-a( $tree, Perl6::Block::Enter ), Q{enter brace}; 105 | ok has-a( $tree, Perl6::Block::Exit ), Q{exit brace}; 106 | ok has-a( $tree, Perl6::Block::Enter ), Q{enter brace}; 107 | ok has-a( $tree, Perl6::Block::Exit ), Q{exit brace}; 108 | 109 | done-testing; 110 | }, Q{no ws}; 111 | 112 | ok round-trips( gensym-package Q:to[_END_] ), Q{leading ws}; 113 | class %s{method Bar {}} 114 | _END_ 115 | 116 | ok round-trips( gensym-package Q{class %s{method Foo{} }} ), 117 | Q{trailing ws}; 118 | 119 | ok round-trips( gensym-package Q{class %s{method Bar {} }} ), 120 | Q{leading, trailing ws}; 121 | }, Q{no intrabrace spacing}; 122 | 123 | subtest { 124 | plan 4; 125 | 126 | ok round-trips( gensym-package Q:to[_END_] ), Q{no ws}; 127 | class %s{method Bar {}} 128 | _END_ 129 | 130 | ok round-trips( gensym-package Q:to[_END_] ), Q{leading ws}; 131 | class %s{method Bar { }} 132 | _END_ 133 | 134 | ok round-trips( gensym-package Q{class %s{method Foo{ } }} ), 135 | Q{trailing ws}; 136 | 137 | ok round-trips( gensym-package Q{class %s{method Bar { } }} ), 138 | Q{leading, trailing ws}; 139 | }, Q{with intrabrace spacing}; 140 | }, Q{method}; 141 | 142 | subtest { 143 | plan 2; 144 | 145 | subtest { 146 | plan 4; 147 | 148 | ok round-trips( gensym-package Q:to[_END_] ), Q{no ws}; 149 | class %s{submethod Bar{}} 150 | _END_ 151 | 152 | ok round-trips( gensym-package Q:to[_END_] ), Q{leading ws}; 153 | class %s{submethod Bar {}} 154 | _END_ 155 | 156 | ok round-trips( gensym-package Q{class %s{submethod Foo{} }} ), 157 | Q{trailing ws}; 158 | 159 | ok round-trips( gensym-package Q{class %s{submethod Bar {} }} ), 160 | Q{leading, trailing ws}; 161 | }, Q{no intrabrace spacing}; 162 | 163 | subtest { 164 | plan 4; 165 | 166 | ok round-trips( gensym-package Q:to[_END_] ), Q{no ws}; 167 | class %s{submethod Bar {}} 168 | _END_ 169 | 170 | ok round-trips( gensym-package Q:to[_END_] ), Q{leading ws}; 171 | class %s{submethod Bar { }} 172 | _END_ 173 | 174 | ok round-trips( gensym-package Q{class %s{submethod Foo{ } }} ), 175 | Q{trailing ws}; 176 | 177 | ok round-trips( gensym-package Q{class %s{submethod Bar { } }} ), 178 | Q{leading, trailing ws}; 179 | }, Q{with intrabrace spacing}; 180 | }, Q{submethod}; 181 | 182 | # XXX 'macro Foo{}' is still experimental. 183 | 184 | # vim: ft=perl6 185 | -------------------------------------------------------------------------------- /t/17-comments.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | use Perl6::Parser; 5 | 6 | use lib 't/lib/'; 7 | use Utils; 8 | 9 | plan 3; 10 | 11 | my $*CONSISTENCY-CHECK = True; 12 | my $*FALL-THROUGH = True; 13 | 14 | ok round-trips( Q:to[_END_] ), Q{shebang line}; 15 | #!/usr/bin/env perl6 16 | _END_ 17 | 18 | subtest { 19 | plan 2; 20 | 21 | ok round-trips( Q:to[_END_] ), Q{single EOL comment}; 22 | # comment to end of line 23 | _END_ 24 | 25 | ok round-trips( Q:to[_END_] ), Q{Two EOL comments in a row}; 26 | # comment to end of line 27 | # comment to end of line 28 | _END_ 29 | 30 | done-testing; 31 | }, Q{full-line comments}; 32 | 33 | subtest { 34 | plan 2; 35 | 36 | ok round-trips( Q:to[_END_] ), Q{single EOL comment}; 37 | #`( comment on single line ) 38 | _END_ 39 | 40 | ok round-trips( Q:to[_END_] ), Q{Two EOL comments in a row}; 41 | #`( comment 42 | spanning 43 | multiple 44 | lines ) 45 | _END_ 46 | 47 | done-testing; 48 | }, Q{spanning comment}; 49 | 50 | # vim: ft=perl6 51 | -------------------------------------------------------------------------------- /t/18-declaration.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | use Perl6::Parser; 5 | 6 | use lib 't/lib/'; 7 | use Utils; 8 | 9 | plan 2; 10 | 11 | my $*CONSISTENCY-CHECK = True; 12 | my $*FALL-THROUGH = True; 13 | 14 | subtest { 15 | plan 3; 16 | 17 | subtest { 18 | plan 3; 19 | 20 | ok round-trips( Q{my Int $a} ), Q{regular}; 21 | ok round-trips( Q{my Int:U $a} ), Q{undefined}; 22 | ok round-trips( Q{my Int:D $a = 0} ), Q{defined}; 23 | 24 | done-testing; 25 | }, Q{typed}; 26 | 27 | ok round-trips( Q{my $a where 1} ), Q{constrained}; 28 | 29 | ok round-trips( Q{my $a where 1 = 2} ), Q{constrained}; 30 | 31 | done-testing; 32 | }, Q{variable}; 33 | 34 | subtest { 35 | plan 2; 36 | 37 | subtest { 38 | plan 2; 39 | 40 | ok round-trips( Q{sub foo{}} ), Q{no ws}; 41 | 42 | ok round-trips( Q:to[_END_] ), Q{ws}; 43 | sub foo {} 44 | _END_ 45 | 46 | done-testing; 47 | }, Q{sub foo {}}; 48 | 49 | subtest { 50 | plan 2; 51 | 52 | ok round-trips( Q{sub foo returns Int {}} ), Q{ws}; 53 | 54 | ok round-trips( Q:to[_END_] ), Q{ws}; 55 | sub foo returns Int {} 56 | _END_ 57 | 58 | done-testing; 59 | }, Q{sub foo returns Int {}}; 60 | 61 | done-testing; 62 | }, Q{subroutine}; 63 | 64 | # vim: ft=perl6 65 | -------------------------------------------------------------------------------- /t/20-pair.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | use Perl6::Parser; 5 | 6 | use lib 't/lib/'; 7 | use Utils; 8 | 9 | plan 13; 10 | 11 | my $*CONSISTENCY-CHECK = True; 12 | my $*FALL-THROUGH = True; 13 | 14 | subtest { 15 | plan 2; 16 | 17 | ok round-trips( Q{a=>1} ), Q{no ws}; 18 | 19 | ok round-trips( Q:to[_END_] ), Q{ws}; 20 | a => 1 21 | _END_ 22 | }, Q{a => 1}; 23 | 24 | subtest { 25 | plan 2; 26 | 27 | ok round-trips( Q{'a'=>'b'} ), Q{no ws}; 28 | 29 | ok round-trips( Q:to[_END_] ), Q{ws}; 30 | 'a' => 'b' 31 | _END_ 32 | }, Q{a => 1}; 33 | 34 | subtest { 35 | plan 2; 36 | 37 | ok round-trips( Q{:a} ), Q{no ws}; 38 | 39 | ok round-trips( Q:to[_END_] ), Q{ws}; 40 | :a 41 | _END_ 42 | }, Q{:a}; 43 | 44 | subtest { 45 | plan 2; 46 | 47 | ok round-trips( Q{:!a} ), Q{no ws}; 48 | 49 | ok round-trips( Q:to[_END_] ), Q{ws}; 50 | :!a 51 | _END_ 52 | }, Q{:!a}; 53 | 54 | subtest { 55 | plan 2; 56 | 57 | ok round-trips( Q{:a} ), Q{no ws}; 58 | 59 | ok round-trips( Q:to[_END_] ), Q{ws}; 60 | :a< b > 61 | _END_ 62 | }, Q{:a}; 63 | 64 | subtest { 65 | plan 2; 66 | 67 | ok round-trips( Q{:a} ), Q{no ws}; 68 | 69 | ok round-trips( Q:to[_END_] ), Q{ws}; 70 | :a< b c > 71 | _END_ 72 | }, Q{:a< b c >}; 73 | 74 | subtest { 75 | plan 2; 76 | 77 | ok round-trips( Q{my$a;:a{$a}} ), Q{no ws}; 78 | 79 | ok round-trips( Q:to[_END_] ), Q{ws}; 80 | my $a; :a{$a} 81 | _END_ 82 | }, Q{:a{$a}}; 83 | 84 | subtest { 85 | plan 2; 86 | 87 | ok round-trips( Q{my$a;:a{'a','b'}} ), Q{no ws}; 88 | 89 | ok round-trips( Q:to[_END_] ), Q{ws}; 90 | my $a; :a{'a', 'b'} 91 | _END_ 92 | }, Q{:a{'a', 'b'}}; 93 | 94 | subtest { 95 | plan 2; 96 | 97 | ok round-trips( Q{my$a;:a{'a'=>'b'}} ), Q{no ws}; 98 | 99 | ok round-trips( Q:to[_END_] ), Q{ws}; 100 | my $a; :a{'a' => 'b'} 101 | _END_ 102 | }, Q{:a{'a' => 'b'}}; 103 | 104 | subtest { 105 | plan 2; 106 | 107 | ok round-trips( Q{my$a;:$a} ), Q{no ws}; 108 | 109 | ok round-trips( Q:to[_END_] ), Q{ws}; 110 | my $a; :$a 111 | _END_ 112 | }, Q{:$a}; 113 | 114 | subtest { 115 | plan 2; 116 | 117 | ok round-trips( Q{my@a;:@a} ), Q{no ws}; 118 | 119 | ok round-trips( Q:to[_END_] ), Q{ws}; 120 | my @a; :@a 121 | _END_ 122 | }, Q{:@a}; 123 | 124 | subtest { 125 | plan 2; 126 | 127 | ok round-trips( Q{my%a;:%a} ), Q{no ws}; 128 | 129 | ok round-trips( Q:to[_END_] ), Q{ws}; 130 | my %a; :%a 131 | _END_ 132 | }, Q{:%a}; 133 | 134 | subtest { 135 | plan 2; 136 | 137 | ok round-trips( Q{my&a;:&a} ), Q{no ws}; 138 | 139 | ok round-trips( Q:to[_END_] ), Q{ws}; 140 | my &a; :&a 141 | _END_ 142 | }, Q{:&a}; 143 | 144 | # vim: ft=perl6 145 | -------------------------------------------------------------------------------- /t/21-pod.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | use Perl6::Parser; 5 | 6 | use lib 't/lib/'; 7 | use Utils; 8 | 9 | plan 1; 10 | 11 | my $*CONSISTENCY-CHECK = True; 12 | my $*FALL-THROUGH = True; 13 | 14 | subtest { 15 | ok round-trips( Q:to[_END_] ), Q{formatted}; 16 | =begin EMPTY 17 | =end EMPTY 18 | _END_ 19 | 20 | done-testing; 21 | }, Q{empty}; 22 | 23 | # vim: ft=perl6 24 | -------------------------------------------------------------------------------- /t/22-regex.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | use Perl6::Parser; 5 | 6 | use lib 't/lib/'; 7 | use Utils; 8 | 9 | plan 4; 10 | 11 | my $*CONSISTENCY-CHECK = True; 12 | my $*FALL-THROUGH = True; 13 | 14 | subtest { 15 | plan 2; 16 | 17 | ok round-trips( Q{/pi/} ), Q{no ws}; 18 | 19 | ok round-trips( Q:to[_END_] ), Q{ws}; 20 | /pi/ 21 | _END_ 22 | }, Q{/pi/}; 23 | 24 | subtest { 25 | plan 2; 26 | 27 | ok round-trips( Q{/<[ p i ]>/} ), Q{no ws}; 28 | 29 | ok round-trips( Q:to[_END_] ), Q{ws}; 30 | / <[ p i ]> / 31 | _END_ 32 | }, Q{/<[ p i ]>/}; 33 | 34 | subtest { 35 | plan 2; 36 | 37 | ok round-trips( Q{/\d/} ), Q{no ws}; 38 | 39 | ok round-trips( Q:to[_END_] ), Q{ws}; 40 | / \d / 41 | _END_ 42 | }, Q{/ \d /}; 43 | 44 | subtest { 45 | plan 2; 46 | 47 | ok round-trips( Q{/./} ), Q{no ws}; 48 | 49 | ok round-trips( Q:to[_END_] ), Q{ws}; 50 | / . / 51 | _END_ 52 | }, Q{/ . /}; 53 | 54 | # vim: ft=perl6 55 | -------------------------------------------------------------------------------- /t/23-single-term.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | use Perl6::Parser; 5 | 6 | use lib 't/lib/'; 7 | use Utils; 8 | 9 | plan 23; 10 | 11 | my $pp = Perl6::Parser.new; 12 | my $*CONSISTENCY-CHECK = True; 13 | my $*FALL-THROUGH = True; 14 | 15 | # number 16 | # 17 | subtest { 18 | subtest { 19 | subtest { 20 | my $source = Q{0}; 21 | my $tree = $pp.to-tree( $source ); 22 | ok has-a( $tree, Perl6::Number ), Q{found token}; 23 | is $pp.to-string( $tree ), $source, Q{formatted}; 24 | 25 | done-testing; 26 | }, Q{no ws}; 27 | 28 | subtest { 29 | my $source = Q{ 0 }; 30 | my $tree = $pp.to-tree( $source ); 31 | ok has-a( $tree, Perl6::Number ), Q{found token}; 32 | is $pp.to-string( $tree ), $source, Q{formatted}; 33 | 34 | done-testing; 35 | }, Q{ws}; 36 | 37 | done-testing; 38 | }, Q{Zero}; 39 | 40 | subtest { 41 | subtest { 42 | my $source = Q{1}; 43 | my $tree = $pp.to-tree( $source ); 44 | ok has-a( $tree, Perl6::Number ), Q{found token}; 45 | is $pp.to-string( $tree ), $source, Q{formatted}; 46 | 47 | done-testing; 48 | }, Q{no ws}; 49 | 50 | subtest { 51 | my $source = Q{ 1 }; 52 | my $tree = $pp.to-tree( $source ); 53 | ok has-a( $tree, Perl6::Number ), Q{found token}; 54 | is $pp.to-string( $tree ), $source, Q{formatted}; 55 | 56 | done-testing; 57 | }, Q{ws}; 58 | 59 | done-testing; 60 | }, Q{1}; 61 | 62 | subtest { 63 | subtest { 64 | my $source = Q{-1}; 65 | my $tree = $pp.to-tree( $source ); 66 | ok has-a( $tree, Perl6::Number ), Q{found token}; 67 | is $pp.to-string( $tree ), $source, Q{formatted}; 68 | 69 | done-testing; 70 | }, Q{no ws}; 71 | 72 | subtest { 73 | my $source = Q{ -1 }; 74 | my $tree = $pp.to-tree( $source ); 75 | ok has-a( $tree, Perl6::Number ), Q{found token}; 76 | is $pp.to-string( $tree ), $source, Q{formatted}; 77 | 78 | done-testing; 79 | }, Q{ws}; 80 | 81 | done-testing; 82 | }, Q{-1}; 83 | 84 | subtest { 85 | subtest { 86 | my $source = Q{1_1}; 87 | my $tree = $pp.to-tree( $source ); 88 | ok has-a( $tree, Perl6::Number ), Q{found token}; 89 | is $pp.to-string( $tree ), $source, Q{formatted}; 90 | 91 | done-testing; 92 | }, Q{no ws}; 93 | 94 | subtest { 95 | my $source = Q{ 1_1 }; 96 | my $tree = $pp.to-tree( $source ); 97 | ok has-a( $tree, Perl6::Number ), Q{found token}; 98 | is $pp.to-string( $tree ), $source, Q{formatted}; 99 | 100 | done-testing; 101 | }, Q{ws}; 102 | 103 | done-testing; 104 | }, Q{1_1}; 105 | 106 | subtest { 107 | subtest { 108 | my $source = Q{Inf}; 109 | my $tree = $pp.to-tree( $source ); 110 | ok has-a( $tree, Perl6::Infinity ), Q{found token}; 111 | is $pp.to-string( $tree ), $source, Q{formatted}; 112 | 113 | done-testing; 114 | }, Q{no ws}; 115 | 116 | subtest { 117 | my $source = Q{ Inf }; 118 | my $tree = $pp.to-tree( $source ); 119 | ok has-a( $tree, Perl6::Infinity ), Q{found token}; 120 | is $pp.to-string( $tree ), $source, Q{formatted}; 121 | 122 | done-testing; 123 | }, Q{ws}; 124 | 125 | done-testing; 126 | }, Q{Inf}; 127 | 128 | subtest { 129 | subtest { 130 | my $source = Q{NaN}; 131 | my $tree = $pp.to-tree( $source ); 132 | ok has-a( $tree, Perl6::NotANumber ), Q{found token}; 133 | is $pp.to-string( $tree ), $source, Q{formatted}; 134 | 135 | done-testing; 136 | }, Q{no ws}; 137 | 138 | subtest { 139 | my $source = Q{ NaN }; 140 | my $tree = $pp.to-tree( $source ); 141 | ok has-a( $tree, Perl6::NotANumber ), Q{found token}; 142 | is $pp.to-string( $tree ), $source, Q{formatted}; 143 | 144 | done-testing; 145 | }, Q{ws}; 146 | 147 | done-testing; 148 | }, Q{Inf}; 149 | 150 | done-testing; 151 | }, Q{decimal}; 152 | 153 | subtest { 154 | subtest { 155 | subtest { 156 | my $source = Q{0b0}; 157 | my $tree = $pp.to-tree( $source ); 158 | ok has-a( $tree, Perl6::Number ), Q{found token}; 159 | is $pp.to-string( $tree ), $source, Q{formatted}; 160 | 161 | done-testing; 162 | }, Q{no ws}; 163 | 164 | subtest { 165 | my $source = Q{ 0b0 }; 166 | my $tree = $pp.to-tree( $source ); 167 | ok has-a( $tree, Perl6::Number ), Q{found token}; 168 | is $pp.to-string( $tree ), $source, Q{formatted}; 169 | 170 | done-testing; 171 | }, Q{ws}; 172 | }, Q{0b0}; 173 | 174 | subtest { 175 | subtest { 176 | my $source = Q{0b1}; 177 | my $tree = $pp.to-tree( $source ); 178 | ok has-a( $tree, Perl6::Number ), Q{found token}; 179 | is $pp.to-string( $tree ), $source, Q{formatted}; 180 | 181 | done-testing; 182 | }, Q{no ws}; 183 | 184 | subtest { 185 | my $source = Q{ 0b1 }; 186 | my $tree = $pp.to-tree( $source ); 187 | ok has-a( $tree, Perl6::Number ), Q{found token}; 188 | is $pp.to-string( $tree ), $source, Q{formatted}; 189 | 190 | done-testing; 191 | }, Q{ws}; 192 | }, Q{0b1}; 193 | 194 | subtest { 195 | subtest { 196 | my $source = Q{-0b1}; 197 | my $tree = $pp.to-tree( $source ); 198 | ok has-a( $tree, Perl6::Number ), Q{found token}; 199 | is $pp.to-string( $tree ), $source, Q{formatted}; 200 | 201 | done-testing; 202 | }, Q{no ws}; 203 | 204 | subtest { 205 | my $source = Q{ -0b1 }; 206 | my $tree = $pp.to-tree( $source ); 207 | ok has-a( $tree, Perl6::Number ), Q{found token}; 208 | is $pp.to-string( $tree ), $source, Q{formatted}; 209 | 210 | done-testing; 211 | }, Q{ws}; 212 | 213 | done-testing; 214 | }, Q{-0b1}; 215 | 216 | done-testing; 217 | }, Q{binary}; 218 | 219 | subtest { 220 | subtest { 221 | subtest { 222 | my $source = Q{0o0}; 223 | my $tree = $pp.to-tree( $source ); 224 | ok has-a( $tree, Perl6::Number ), Q{found token}; 225 | is $pp.to-string( $tree ), $source, Q{formatted}; 226 | 227 | done-testing; 228 | }, Q{no ws}; 229 | 230 | subtest { 231 | my $source = Q{ 0o0 }; 232 | my $tree = $pp.to-tree( $source ); 233 | ok has-a( $tree, Perl6::Number ), Q{found token}; 234 | is $pp.to-string( $tree ), $source, Q{formatted}; 235 | 236 | done-testing; 237 | }, Q{ws}; 238 | 239 | done-testing; 240 | }, Q{0o0}; 241 | 242 | subtest { 243 | subtest { 244 | my $source = Q{0o1}; 245 | my $tree = $pp.to-tree( $source ); 246 | ok has-a( $tree, Perl6::Number ), Q{found token}; 247 | is $pp.to-string( $tree ), $source, Q{formatted}; 248 | 249 | done-testing; 250 | }, Q{no ws}; 251 | 252 | subtest { 253 | my $source = Q{ 0o1 }; 254 | my $tree = $pp.to-tree( $source ); 255 | ok has-a( $tree, Perl6::Number ), Q{found token}; 256 | is $pp.to-string( $tree ), $source, Q{formatted}; 257 | 258 | done-testing; 259 | }, Q{ws}; 260 | 261 | done-testing; 262 | }, Q{0o1}; 263 | 264 | subtest { 265 | subtest { 266 | my $source = Q{-0o1}; 267 | my $tree = $pp.to-tree( $source ); 268 | ok has-a( $tree, Perl6::Number ), Q{found token}; 269 | is $pp.to-string( $tree ), $source, Q{formatted}; 270 | 271 | done-testing; 272 | }, Q{no ws}; 273 | 274 | subtest { 275 | my $source = Q{ -0o1 }; 276 | my $tree = $pp.to-tree( $source ); 277 | ok has-a( $tree, Perl6::Number ), Q{found token}; 278 | is $pp.to-string( $tree ), $source, Q{formatted}; 279 | 280 | done-testing; 281 | }, Q{ws}; 282 | 283 | done-testing; 284 | }, Q{-0o1}; 285 | 286 | done-testing; 287 | }, Q{octal}; 288 | 289 | subtest { 290 | subtest { 291 | subtest { 292 | my $source = Q{0d0}; 293 | my $tree = $pp.to-tree( $source ); 294 | ok has-a( $tree, Perl6::Number ), Q{found token}; 295 | is $pp.to-string( $tree ), $source, Q{formatted}; 296 | 297 | done-testing; 298 | }, Q{no ws}; 299 | 300 | subtest { 301 | my $source = Q{ 0d0 }; 302 | my $tree = $pp.to-tree( $source ); 303 | ok has-a( $tree, Perl6::Number ), Q{found token}; 304 | is $pp.to-string( $tree ), $source, Q{formatted}; 305 | 306 | done-testing; 307 | }, Q{ws}; 308 | 309 | done-testing; 310 | }, Q{0d0}; 311 | 312 | subtest { 313 | subtest { 314 | my $source = Q{0d1}; 315 | my $tree = $pp.to-tree( $source ); 316 | ok has-a( $tree, Perl6::Number ), Q{found token}; 317 | is $pp.to-string( $tree ), $source, Q{formatted}; 318 | 319 | done-testing; 320 | }, Q{no ws}; 321 | 322 | subtest { 323 | my $source = Q{ 0d1 }; 324 | my $tree = $pp.to-tree( $source ); 325 | ok has-a( $tree, Perl6::Number ), Q{found token}; 326 | is $pp.to-string( $tree ), $source, Q{formatted}; 327 | 328 | done-testing; 329 | }, Q{ws}; 330 | 331 | done-testing; 332 | }, Q{0d1}; 333 | 334 | subtest { 335 | subtest { 336 | my $source = Q{-0d1}; 337 | my $tree = $pp.to-tree( $source ); 338 | ok has-a( $tree, Perl6::Number ), Q{found token}; 339 | is $pp.to-string( $tree ), $source, Q{formatted}; 340 | 341 | done-testing; 342 | }, Q{no ws}; 343 | 344 | subtest { 345 | my $source = Q{ -0d1 }; 346 | my $tree = $pp.to-tree( $source ); 347 | ok has-a( $tree, Perl6::Number ), Q{found token}; 348 | is $pp.to-string( $tree ), $source, Q{formatted}; 349 | 350 | done-testing; 351 | }, Q{ws}; 352 | 353 | done-testing; 354 | }, Q{-0d1}; 355 | 356 | done-testing; 357 | }, Q{explicit decimal}; 358 | 359 | subtest { 360 | subtest { 361 | subtest { 362 | my $source = Q{0}; 363 | my $tree = $pp.to-tree( $source ); 364 | ok has-a( $tree, Perl6::Number ), Q{found token}; 365 | is $pp.to-string( $tree ), $source, Q{formatted}; 366 | 367 | done-testing; 368 | }, Q{no ws}; 369 | 370 | subtest { 371 | my $source = Q{ 0 }; 372 | my $tree = $pp.to-tree( $source ); 373 | ok has-a( $tree, Perl6::Number ), Q{found token}; 374 | is $pp.to-string( $tree ), $source, Q{formatted}; 375 | 376 | done-testing; 377 | }, Q{ws}; 378 | 379 | done-testing; 380 | }, Q{0}; 381 | 382 | subtest { 383 | subtest { 384 | my $source = Q{1}; 385 | my $tree = $pp.to-tree( $source ); 386 | ok has-a( $tree, Perl6::Number ), Q{found token}; 387 | is $pp.to-string( $tree ), $source, Q{formatted}; 388 | 389 | done-testing; 390 | }, Q{no ws}; 391 | 392 | subtest { 393 | my $source = Q{ 1 }; 394 | my $tree = $pp.to-tree( $source ); 395 | ok has-a( $tree, Perl6::Number ), Q{found token}; 396 | is $pp.to-string( $tree ), $source, Q{formatted}; 397 | 398 | done-testing; 399 | }, Q{ws}; 400 | 401 | done-testing; 402 | }, Q{1}; 403 | 404 | subtest { 405 | subtest { 406 | my $source = Q{-1}; 407 | my $tree = $pp.to-tree( $source ); 408 | ok has-a( $tree, Perl6::Number ), Q{found token}; 409 | is $pp.to-string( $tree ), $source, Q{formatted}; 410 | 411 | done-testing; 412 | }, Q{no ws}; 413 | 414 | subtest { 415 | my $source = Q{ -1 }; 416 | my $tree = $pp.to-tree( $source ); 417 | ok has-a( $tree, Perl6::Number ), Q{found token}; 418 | is $pp.to-string( $tree ), $source, Q{formatted}; 419 | 420 | done-testing; 421 | }, Q{ws}; 422 | 423 | done-testing; 424 | }, Q{-1}; 425 | 426 | done-testing; 427 | }, Q{implicit decimal}; 428 | 429 | subtest { 430 | subtest { 431 | subtest { 432 | my $source = Q{0x0}; 433 | my $tree = $pp.to-tree( $source ); 434 | ok has-a( $tree, Perl6::Number ), Q{found token}; 435 | is $pp.to-string( $tree ), $source, Q{formatted}; 436 | 437 | done-testing; 438 | }, Q{no ws}; 439 | 440 | subtest { 441 | my $source = Q{ 0x0 }; 442 | my $tree = $pp.to-tree( $source ); 443 | ok has-a( $tree, Perl6::Number ), Q{found token}; 444 | is $pp.to-string( $tree ), $source, Q{formatted}; 445 | 446 | done-testing; 447 | }, Q{ws}; 448 | 449 | done-testing; 450 | }, Q{0x0}; 451 | 452 | subtest { 453 | subtest { 454 | my $source = Q{0x1}; 455 | my $tree = $pp.to-tree( $source ); 456 | ok has-a( $tree, Perl6::Number ), Q{found token}; 457 | is $pp.to-string( $tree ), $source, Q{formatted}; 458 | 459 | done-testing; 460 | }, Q{no ws}; 461 | 462 | subtest { 463 | my $source = Q{ 0x1 }; 464 | my $tree = $pp.to-tree( $source ); 465 | ok has-a( $tree, Perl6::Number ), Q{found token}; 466 | is $pp.to-string( $tree ), $source, Q{formatted}; 467 | 468 | done-testing; 469 | }, Q{ws}; 470 | 471 | done-testing; 472 | }, Q{0x1}; 473 | 474 | subtest { 475 | subtest { 476 | my $source = Q{-0x1}; 477 | my $tree = $pp.to-tree( $source ); 478 | ok has-a( $tree, Perl6::Number ), Q{found token}; 479 | is $pp.to-string( $tree ), $source, Q{formatted}; 480 | 481 | done-testing; 482 | }, Q{no ws}; 483 | 484 | subtest { 485 | my $source = Q{ -0x1 }; 486 | my $tree = $pp.to-tree( $source ); 487 | ok has-a( $tree, Perl6::Number ), Q{found token}; 488 | is $pp.to-string( $tree ), $source, Q{formatted}; 489 | 490 | done-testing; 491 | }, Q{ws}; 492 | 493 | done-testing; 494 | }, Q{-0x1}; 495 | 496 | done-testing; 497 | }, Q{hexadecimal}; 498 | 499 | subtest { 500 | subtest { 501 | subtest { 502 | my $source = Q{:13(0)}; 503 | my $tree = $pp.to-tree( $source ); 504 | ok has-a( $tree, Perl6::Number ), Q{found token}; 505 | is $pp.to-string( $tree ), $source, Q{formatted}; 506 | 507 | done-testing; 508 | }, Q{no ws}; 509 | 510 | subtest { 511 | my $source = Q{ :13(0) }; 512 | my $tree = $pp.to-tree( $source ); 513 | ok has-a( $tree, Perl6::Number ), Q{found token}; 514 | is $pp.to-string( $tree ), $source, Q{formatted}; 515 | 516 | done-testing; 517 | }, Q{ws}; 518 | 519 | done-testing; 520 | }, Q{:13(0)}; 521 | 522 | subtest { 523 | subtest { 524 | my $source = Q{:13(1)}; 525 | my $tree = $pp.to-tree( $source ); 526 | ok has-a( $tree, Perl6::Number ), Q{found token}; 527 | is $pp.to-string( $tree ), $source, Q{formatted}; 528 | 529 | done-testing; 530 | }, Q{no ws}; 531 | 532 | subtest { 533 | my $source = Q{ :13(1) }; 534 | my $tree = $pp.to-tree( $source ); 535 | ok has-a( $tree, Perl6::Number ), Q{found token}; 536 | is $pp.to-string( $tree ), $source, Q{formatted}; 537 | 538 | done-testing; 539 | }, Q{ws}; 540 | 541 | done-testing; 542 | }, Q{:13(1)}; 543 | 544 | subtest { 545 | subtest { 546 | my $source = Q{:13(-1)}; 547 | my $tree = $pp.to-tree( $source ); 548 | ok has-a( $tree, Perl6::Number ), Q{found token}; 549 | is $pp.to-string( $tree ), $source, Q{formatted}; 550 | 551 | done-testing; 552 | }, Q{no ws}; 553 | 554 | subtest { 555 | my $source = Q{ :13(-1) }; 556 | my $tree = $pp.to-tree( $source ); 557 | ok has-a( $tree, Perl6::Number ), Q{found token}; 558 | is $pp.to-string( $tree ), $source, Q{formatted}; 559 | 560 | done-testing; 561 | }, Q{ws}; 562 | 563 | done-testing; 564 | }, Q{:13(-1)}; 565 | 566 | done-testing; 567 | }, Q{radix}; 568 | 569 | subtest { 570 | subtest { 571 | subtest { 572 | my $source = Q{0e0}; 573 | my $tree = $pp.to-tree( $source ); 574 | ok has-a( $tree, Perl6::Number ), Q{found token}; 575 | is $pp.to-string( $tree ), $source, Q{formatted}; 576 | 577 | done-testing; 578 | }, Q{no ws}; 579 | 580 | subtest { 581 | my $source = Q{ 0e0 }; 582 | my $tree = $pp.to-tree( $source ); 583 | ok has-a( $tree, Perl6::Number ), Q{found token}; 584 | is $pp.to-string( $tree ), $source, Q{formatted}; 585 | 586 | done-testing; 587 | }, Q{ws}; 588 | 589 | done-testing; 590 | }, Q{0e0}; 591 | 592 | subtest { 593 | subtest { 594 | my $source = Q{0e1}; 595 | my $tree = $pp.to-tree( $source ); 596 | ok has-a( $tree, Perl6::Number ), Q{found token}; 597 | is $pp.to-string( $tree ), $source, Q{formatted}; 598 | 599 | done-testing; 600 | }, Q{no ws}; 601 | 602 | subtest { 603 | my $source = Q{ 0e1 }; 604 | my $tree = $pp.to-tree( $source ); 605 | ok has-a( $tree, Perl6::Number ), Q{found token}; 606 | is $pp.to-string( $tree ), $source, Q{formatted}; 607 | 608 | done-testing; 609 | }, Q{ws}; 610 | 611 | done-testing; 612 | }, Q{0e1}; 613 | 614 | subtest { 615 | subtest { 616 | my $source = Q{-0e1}; 617 | my $tree = $pp.to-tree( $source ); 618 | ok has-a( $tree, Perl6::Number ), Q{found token}; 619 | is $pp.to-string( $tree ), $source, Q{formatted}; 620 | 621 | done-testing; 622 | }, Q{no ws}; 623 | 624 | subtest { 625 | my $source = Q{ -0e1 }; 626 | my $tree = $pp.to-tree( $source ); 627 | ok has-a( $tree, Perl6::Number ), Q{found token}; 628 | is $pp.to-string( $tree ), $source, Q{formatted}; 629 | 630 | done-testing; 631 | }, Q{ws}; 632 | 633 | done-testing; 634 | }, Q{-0e1}; 635 | 636 | subtest { 637 | subtest { 638 | my $source = Q{0e-1}; 639 | my $tree = $pp.to-tree( $source ); 640 | ok has-a( $tree, Perl6::Number ), Q{found token}; 641 | is $pp.to-string( $tree ), $source, Q{formatted}; 642 | 643 | done-testing; 644 | }, Q{no ws}; 645 | 646 | subtest { 647 | my $source = Q{ 0e-1 }; 648 | my $tree = $pp.to-tree( $source ); 649 | ok has-a( $tree, Perl6::Number ), Q{found token}; 650 | is $pp.to-string( $tree ), $source, Q{formatted}; 651 | 652 | done-testing; 653 | }, Q{ws}; 654 | 655 | done-testing; 656 | }, Q{-0e1}; 657 | 658 | done-testing; 659 | }, Q{scientific}; 660 | 661 | subtest { 662 | subtest { 663 | subtest { 664 | my $source = Q{0i}; 665 | my $tree = $pp.to-tree( $source ); 666 | ok has-a( $tree, Perl6::Number ), Q{found token}; 667 | is $pp.to-string( $tree ), $source, Q{formatted}; 668 | 669 | done-testing; 670 | }, Q{no ws}; 671 | 672 | subtest { 673 | my $source = Q{ 0i }; 674 | my $tree = $pp.to-tree( $source ); 675 | ok has-a( $tree, Perl6::Number ), Q{found token}; 676 | is $pp.to-string( $tree ), $source, Q{formatted}; 677 | 678 | done-testing; 679 | }, Q{ws}; 680 | 681 | done-testing; 682 | }, Q{0i}; 683 | 684 | subtest { 685 | subtest { 686 | my $source = Q{1i}; 687 | my $tree = $pp.to-tree( $source ); 688 | ok has-a( $tree, Perl6::Number ), Q{found token}; 689 | is $pp.to-string( $tree ), $source, Q{formatted}; 690 | 691 | done-testing; 692 | }, Q{no ws}; 693 | 694 | subtest { 695 | my $source = Q{ 1i }; 696 | my $tree = $pp.to-tree( $source ); 697 | ok has-a( $tree, Perl6::Number ), Q{found token}; 698 | is $pp.to-string( $tree ), $source, Q{formatted}; 699 | 700 | done-testing; 701 | }, Q{ws}; 702 | 703 | done-testing; 704 | }, Q{1i}; 705 | 706 | subtest { 707 | subtest { 708 | my $source = Q{-1i}; 709 | my $tree = $pp.to-tree( $source ); 710 | ok has-a( $tree, Perl6::Number ), Q{found token}; 711 | is $pp.to-string( $tree ), $source, Q{formatted}; 712 | 713 | done-testing; 714 | }, Q{no ws}; 715 | 716 | subtest { 717 | my $source = Q{ -1i }; 718 | my $tree = $pp.to-tree( $source ); 719 | ok has-a( $tree, Perl6::Number ), Q{found token}; 720 | is $pp.to-string( $tree ), $source, Q{formatted}; 721 | 722 | done-testing; 723 | }, Q{ws}; 724 | 725 | done-testing; 726 | }, Q{-1i}; 727 | 728 | done-testing; 729 | }, Q{imaginary}; 730 | 731 | # variable 732 | # 733 | subtest { 734 | subtest { 735 | my $source = Q{@*ARGS}; 736 | my $tree = $pp.to-tree( $source ); 737 | ok has-a( $tree, Perl6::Variable ), Q{found token}; 738 | is $pp.to-string( $tree ), $source, Q{formatted}; 739 | 740 | done-testing; 741 | }, Q{no ws}; 742 | 743 | subtest { 744 | my $source = Q{ @*ARGS }; 745 | my $tree = $pp.to-tree( $source ); 746 | ok has-a( $tree, Perl6::Variable ), Q{found token}; 747 | is $pp.to-string( $tree ), $source, Q{formatted}; 748 | 749 | done-testing; 750 | }, Q{ws}; 751 | 752 | done-testing; 753 | }, Q{@*ARGS (is a global, so available everywhere)}; 754 | 755 | subtest { 756 | subtest { 757 | my $source = Q{$}; 758 | my $tree = $pp.to-tree( $source ); 759 | ok has-a( $tree, Perl6::Variable ), Q{found token}; 760 | is $pp.to-string( $tree ), $source, Q{formatted}; 761 | 762 | done-testing; 763 | }, Q{no ws}; 764 | 765 | subtest { 766 | my $source = Q{ $ }; 767 | my $tree = $pp.to-tree( $source ); 768 | ok has-a( $tree, Perl6::Variable ), Q{found token}; 769 | is $pp.to-string( $tree ), $source, Q{formatted}; 770 | 771 | done-testing; 772 | }, Q{ws}; 773 | 774 | done-testing; 775 | }, Q{$}; 776 | 777 | subtest { 778 | subtest { 779 | my $source = Q{$_}; 780 | my $tree = $pp.to-tree( $source ); 781 | ok has-a( $tree, Perl6::Variable ), Q{found token}; 782 | is $pp.to-string( $tree ), $source, Q{formatted}; 783 | 784 | done-testing; 785 | }, Q{no ws}; 786 | 787 | subtest { 788 | my $source = Q{ $_ }; 789 | my $tree = $pp.to-tree( $source ); 790 | ok has-a( $tree, Perl6::Variable ), Q{found token}; 791 | is $pp.to-string( $tree ), $source, Q{formatted}; 792 | 793 | done-testing; 794 | }, Q{ws}; 795 | 796 | done-testing; 797 | }, Q{$_}; 798 | 799 | subtest { 800 | subtest { 801 | my $source = Q{$/}; 802 | my $tree = $pp.to-tree( $source ); 803 | ok has-a( $tree, Perl6::Variable ), Q{found token}; 804 | is $pp.to-string( $tree ), $source, Q{formatted}; 805 | 806 | done-testing; 807 | }, Q{no ws}; 808 | 809 | subtest { 810 | my $source = Q{ $/ }; 811 | my $tree = $pp.to-tree( $source ); 812 | ok has-a( $tree, Perl6::Variable ), Q{found token}; 813 | is $pp.to-string( $tree ), $source, Q{formatted}; 814 | 815 | done-testing; 816 | }, Q{ws}; 817 | 818 | done-testing; 819 | }, Q{$/}; 820 | 821 | subtest { 822 | subtest { 823 | my $source = Q{$!}; 824 | my $tree = $pp.to-tree( $source ); 825 | ok has-a( $tree, Perl6::Variable ), Q{found token}; 826 | is $pp.to-string( $tree ), $source, Q{formatted}; 827 | 828 | done-testing; 829 | }, Q{no ws}; 830 | 831 | subtest { 832 | my $source = Q{ $! }; 833 | my $tree = $pp.to-tree( $source ); 834 | ok has-a( $tree, Perl6::Variable ), Q{found token}; 835 | is $pp.to-string( $tree ), $source, Q{formatted}; 836 | 837 | done-testing; 838 | }, Q{ws}; 839 | 840 | done-testing; 841 | }, Q{$!}; 842 | 843 | subtest { 844 | subtest { 845 | my $source = Q{$Foo::Bar}; 846 | my $tree = $pp.to-tree( $source ); 847 | ok has-a( $tree, Perl6::Variable ), Q{found token}; 848 | is $pp.to-string( $tree ), $source, Q{formatted}; 849 | 850 | done-testing; 851 | }, Q{no ws}; 852 | 853 | subtest { 854 | my $source = Q{ $Foo::Bar }; 855 | my $tree = $pp.to-tree( $source ); 856 | ok has-a( $tree, Perl6::Variable ), Q{found token}; 857 | is $pp.to-string( $tree ), $source, Q{formatted}; 858 | 859 | done-testing; 860 | }, Q{ws}; 861 | 862 | 863 | done-testing; 864 | }, Q{$Foo::Bar}; 865 | 866 | subtest { 867 | subtest { 868 | my $source = Q{&sum}; 869 | my $tree = $pp.to-tree( $source ); 870 | is $pp.to-string( $tree ), $source, Q{formatted}; 871 | 872 | done-testing; 873 | }, Q{no ws}; 874 | 875 | subtest { 876 | my $source = Q{ &sum }; 877 | my $tree = $pp.to-tree( $source ); 878 | is $pp.to-string( $tree ), $source, Q{formatted}; 879 | 880 | done-testing; 881 | }, Q{ws}; 882 | 883 | done-testing; 884 | }, Q{&sum}; 885 | 886 | subtest { 887 | subtest { 888 | my $source = Q{$Foo::($*GLOBAL)::Bar}; 889 | my $tree = $pp.to-tree( $source ); 890 | ok has-a( $tree, Perl6::Variable ), Q{found token}; 891 | is $pp.to-string( $tree ), $source, Q{formatted}; 892 | 893 | done-testing; 894 | }, Q{no ws}; 895 | 896 | subtest { 897 | my $source = Q{ $Foo::($*GLOBAL)::Bar }; 898 | my $tree = $pp.to-tree( $source ); 899 | ok has-a( $tree, Perl6::Variable ), Q{found token}; 900 | is $pp.to-string( $tree ), $source, Q{formatted}; 901 | 902 | done-testing; 903 | }, Q{ws}; 904 | 905 | done-testing; 906 | }, Q[$Foo::($*GLOBAL)::Bar]; 907 | 908 | # type 909 | # 910 | subtest { 911 | subtest { 912 | my $source = Q{Int}; 913 | my $tree = $pp.to-tree( $source ); 914 | # XXX Probably shouldn't be a bareword... 915 | # ok (grep { $_ ~~ Perl6::Number }, 916 | # $tree.child.[0].child), 917 | # Q{found number}; 918 | is $pp.to-string( $tree ), $source, Q{formatted}; 919 | 920 | done-testing; 921 | }, Q{no ws}; 922 | 923 | subtest { 924 | my $source = Q{ Int }; 925 | my $tree = $pp.to-tree( $source ); 926 | # XXX Probably shouldn't be a bareword... 927 | # ok (grep { $_ ~~ Perl6::Number }, 928 | # $tree.child.[0].child), 929 | # Q{found number}; 930 | is $pp.to-string( $tree ), $source, Q{formatted}; 931 | 932 | done-testing; 933 | }, Q{ws}; 934 | 935 | done-testing; 936 | }, Q{Int}; 937 | 938 | subtest { 939 | subtest { 940 | my $source = Q{IO::Handle}; 941 | my $tree = $pp.to-tree( $source ); 942 | # XXX Probably shouldn't be a bareword... 943 | # ok (grep { $_ ~~ Perl6::Number }, 944 | # $tree.child.[0].child), 945 | # Q{found number}; 946 | is $pp.to-string( $tree ), $source, Q{formatted}; 947 | 948 | done-testing; 949 | }, Q{no ws}; 950 | 951 | subtest { 952 | my $source = Q{ IO::Handle }; 953 | my $tree = $pp.to-tree( $source ); 954 | # XXX Probably shouldn't be a bareword... 955 | # ok (grep { $_ ~~ Perl6::Number }, 956 | # $tree.child.[0].child), 957 | # Q{found number}; 958 | is $pp.to-string( $tree ), $source, Q{formatted}; 959 | 960 | done-testing; 961 | }, Q{ws}; 962 | 963 | done-testing; 964 | }, Q{IO::Handle (Two package names)}; 965 | 966 | # constant 967 | # 968 | subtest { 969 | subtest { 970 | my $source = Q{pi}; 971 | my $tree = $pp.to-tree( $source ); 972 | # XXX Probably shouldn't be a bareword... 973 | # ok (grep { $_ ~~ Perl6::Number }, 974 | # $tree.child.[0].child), 975 | # Q{found number}; 976 | is $pp.to-string( $tree ), $source, Q{formatted}; 977 | 978 | done-testing; 979 | }, Q{no ws}; 980 | 981 | subtest { 982 | my $source = Q{ pi }; 983 | my $tree = $pp.to-tree( $source ); 984 | # XXX Probably shouldn't be a bareword... 985 | # ok (grep { $_ ~~ Perl6::Number }, 986 | # $tree.child.[0].child), 987 | # Q{found number}; 988 | is $pp.to-string( $tree ), $source, Q{formatted}; 989 | 990 | done-testing; 991 | }, Q{ws}; 992 | 993 | done-testing; 994 | }, Q{pi}; 995 | 996 | # function call 997 | # 998 | subtest { 999 | subtest { 1000 | my $source = Q{sum}; 1001 | my $tree = $pp.to-tree( $source ); 1002 | # ok (grep { $_ ~~ Perl6::Number }, 1003 | # $tree.child.[0].child), 1004 | # Q{found number}; 1005 | is $pp.to-string( $tree ), $source, Q{formatted}; 1006 | 1007 | done-testing; 1008 | }, Q{no ws}; 1009 | 1010 | subtest { 1011 | my $source = Q{ sum }; 1012 | my $tree = $pp.to-tree( $source ); 1013 | # ok (grep { $_ ~~ Perl6::Number }, 1014 | # $tree.child.[0].child), 1015 | # Q{found number}; 1016 | is $pp.to-string( $tree ), $source, Q{formatted}; 1017 | 1018 | done-testing; 1019 | }, Q{ws}; 1020 | 1021 | done-testing; 1022 | }, Q{sum}; 1023 | 1024 | # operators 1025 | # 1026 | subtest { 1027 | subtest { 1028 | my $source = Q{()}; 1029 | my $tree = $pp.to-tree( $source ); 1030 | # ok (grep { $_ ~~ Perl6::Number }, 1031 | # $tree.child.[0].child), 1032 | # Q{found number}; 1033 | is $pp.to-string( $tree ), $source, Q{formatted}; 1034 | 1035 | done-testing; 1036 | }, Q{no ws}; 1037 | 1038 | subtest { 1039 | my $source = Q{ () }; 1040 | my $tree = $pp.to-tree( $source ); 1041 | # ok (grep { $_ ~~ Perl6::Number }, 1042 | # $tree.child.[0].child), 1043 | # Q{found number}; 1044 | is $pp.to-string( $tree ), $source, Q{formatted}; 1045 | 1046 | done-testing; 1047 | }, Q{ws}; 1048 | 1049 | done-testing; 1050 | }, Q{circumfix}; 1051 | 1052 | # :foo (adverbial-pair) is already tested in t/pair.t 1053 | 1054 | # signature 1055 | # 1056 | subtest { 1057 | subtest { 1058 | my $source = Q{:()}; 1059 | my $tree = $pp.to-tree( $source ); 1060 | # ok (grep { $_ ~~ Perl6::Number }, 1061 | # $tree.child.[0].child), 1062 | # Q{found number}; 1063 | is $pp.to-string( $tree ), $source, Q{formatted}; 1064 | 1065 | done-testing; 1066 | }, Q{no ws}; 1067 | 1068 | subtest { 1069 | my $source = Q{ :() }; 1070 | my $tree = $pp.to-tree( $source ); 1071 | # ok (grep { $_ ~~ Perl6::Number }, 1072 | # $tree.child.[0].child), 1073 | # Q{found number}; 1074 | is $pp.to-string( $tree ), $source, Q{formatted}; 1075 | 1076 | done-testing; 1077 | }, Q{ws}; 1078 | 1079 | done-testing; 1080 | }, Q{:()}; 1081 | 1082 | done-testing; 1083 | 1084 | # vim: ft=perl6 1085 | -------------------------------------------------------------------------------- /t/24-subroutine.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | use Perl6::Parser; 5 | 6 | use lib 't/lib/'; 7 | use Utils; 8 | 9 | plan 4; 10 | 11 | my $*CONSISTENCY-CHECK = True; 12 | my $*FALL-THROUGH = True; 13 | 14 | # Scalar arguments 15 | # 16 | subtest { 17 | plan 5; 18 | 19 | subtest { 20 | plan 2; 21 | 22 | ok round-trips( Q{sub foo(){}} ), Q{no ws}; 23 | 24 | ok round-trips( Q{sub foo( ) { }} ), 25 | Q{intra-term ws}; 26 | }, Q{empty}; 27 | 28 | subtest { 29 | plan 2; 30 | 31 | ok round-trips( Q{sub foo(0){}} ), Q{no ws}; 32 | 33 | ok round-trips( Q:to[_END_] ), Q{ws}; 34 | sub foo( 0 ) { } 35 | _END_ 36 | }, Q{constant}; 37 | 38 | subtest { 39 | plan 2; 40 | 41 | ok round-trips( Q{sub foo($a){}} ), Q{no ws}; 42 | 43 | ok round-trips( Q:to[_END_] ), Q{ws}; 44 | sub foo( $a ) { } 45 | _END_ 46 | }, Q{untyped}; 47 | 48 | subtest { 49 | plan 5; 50 | 51 | subtest { 52 | plan 2; 53 | 54 | ok round-trips( Q{sub foo(Int$a){}} ), Q{no ws}; 55 | 56 | ok round-trips( Q:to[_END_] ), Q{ws}; 57 | sub foo( Int $a ) { } 58 | _END_ 59 | }, Q{typed}; 60 | 61 | subtest { 62 | plan 2; 63 | 64 | ok round-trips( Q{sub foo(Int$a=32){}} ), 65 | Q{no ws}; 66 | 67 | ok round-trips( Q:to[_END_] ), Q{ws}; 68 | sub foo( Int $a = 32 ) { } 69 | _END_ 70 | }, Q{typed and declared}; 71 | 72 | subtest { 73 | plan 2; 74 | 75 | ok round-trips( Q{sub foo(::T$a){}} ), Q{no ws}; 76 | 77 | ok round-trips( Q:to[_END_] ), Q{ws}; 78 | sub foo( ::T $a ) { } 79 | _END_ 80 | }, Q{type-capture}; 81 | 82 | subtest { 83 | plan 2; 84 | 85 | ok round-trips( Q{sub foo(Int){}} ), Q{no ws}; 86 | 87 | ok round-trips( Q:to[_END_] ), Q{no ws}; 88 | sub foo( Int ) { } 89 | _END_ 90 | }, Q{type-only}; 91 | 92 | subtest { 93 | plan 2; 94 | 95 | ok round-trips( Q{sub foo(Int$a where 1){}} ), 96 | Q{no ws}; 97 | 98 | ok round-trips( Q:to[_END_] ), Q{ws}; 99 | sub foo( Int $a where 1 ) { } 100 | _END_ 101 | }, Q{type-constrained}; 102 | }, Q{typed}; 103 | 104 | subtest { 105 | plan 2; 106 | 107 | ok round-trips( Q{sub foo($a=0){}} ), Q{no ws}; 108 | 109 | ok round-trips( Q:to[_END_] ), Q{ws}; 110 | sub foo( $a = 0 ) { } 111 | _END_ 112 | }, Q{default}; 113 | 114 | # XXX 'sub foo(:a) { }' illegal 115 | }, Q{single}; 116 | 117 | subtest { 118 | plan 2; 119 | 120 | ok round-trips( Q{sub foo($a,$b){}} ), Q{no ws}; 121 | 122 | ok round-trips( Q:to[_END_] ), Q{ws}; 123 | sub foo( $a, $b ) { } 124 | _END_ 125 | }, Q{multiple}; 126 | 127 | subtest { 128 | plan 4; 129 | 130 | ok round-trips( Q{sub foo($a,Str$b,Str$c where"foo",Int$d=32){}} ), 131 | Q{minimal spacing}; 132 | 133 | ok round-trips( Q:to[_END_] ), Q{minimal spacing with newline}; 134 | sub foo($a,Str$b,Str$c where"foo",Int$d=32){} 135 | _END_ 136 | 137 | # Having differing whitespace on each side of an operator 138 | # assures that Perl6::WS objects aren't being reused, and the 139 | # WS isn't actually being copied from the wrong RE. 140 | # 141 | ok round-trips( Q:to[_END_] ), Q{alternating spacing}; 142 | sub foo( 143 | $a , 144 | Str $b 145 | , Str 146 | $c where 147 | "foo" , 148 | Int $d 149 | = 32 150 | ) { 151 | } 152 | _END_ 153 | 154 | ok round-trips( Q:to[_END_] ), Q{maximal spacing}; 155 | sub foo( $a , Str $b , Str $c where "foo" , Int $d = 32 ) { } 156 | _END_ 157 | }, Q{christmas tree}; 158 | 159 | ok round-trips( Q:to[_END_] ), Q{separate function name and body}; 160 | sub foo ( ) { } 161 | _END_ 162 | 163 | # vim: ft=perl6 164 | -------------------------------------------------------------------------------- /t/999-regression.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | use Perl6::Parser; 5 | 6 | use lib 't/lib'; 7 | use Utils; 8 | 9 | my $*CONSISTENCY-CHECK = True; 10 | my $*FALL-THROUGH = True; 11 | 12 | # No plan here. 13 | 14 | # We're just checking odds and ends here, so no need to rigorously check 15 | # the object tree. 16 | 17 | ok round-trips( Q:to[_END_] ), Q{say }; 18 | say ; 19 | _END_ 20 | 21 | ok round-trips( Q:to[_END_] ), Q{flat (99 ... 1)}; 22 | my @quantities = flat (99 ... 1), 'No more', 99; 23 | _END_ 24 | 25 | ok round-trips( Q:to[_END_] ), Q{is copy}; 26 | sub foo( $a is copy ) { } 27 | _END_ 28 | 29 | ok round-trips( gensym-package Q:to[_END_] ), Q{actions in grammars}; 30 | grammar %s { 31 | token TOP { ^ $ { fail } } 32 | } 33 | _END_ 34 | 35 | # Despite how it looks, '%%' here isn't doubled-percent. 36 | # The sprintf() format rewrites %% to %. 37 | # 38 | ok round-trips( gensym-package Q:to[_END_] ), Q{mod in grammar}; 39 | grammar %s { 40 | rule exp { + %% } 41 | } 42 | _END_ 43 | 44 | ok round-trips( Q:to[_END_] ), Q{grep: { }}; 45 | my @blocks; 46 | @blocks.grep: { } 47 | _END_ 48 | 49 | ok round-trips( Q:to[_END_] ), Q{my \y}; 50 | my \y = 1; 51 | _END_ 52 | 53 | ok round-trips( gensym-package Q:to[_END_] ), Q{method fill-pixel($i)}; 54 | class %s { 55 | method fill-pixel($i) { } 56 | } 57 | _END_ 58 | 59 | ok round-trips( Q:to[_END_] ), Q{quoted hash}; 60 | my %dir = ( 61 | "\e[A" => 'up', 62 | "\e[B" => 'down', 63 | "\e[C" => 'left', 64 | ); 65 | _END_ 66 | 67 | ok round-trips( gensym-package Q:to[_END_] ), Q{alternation}; 68 | grammar %s { rule term { | } } 69 | _END_ 70 | 71 | ok round-trips( Q:to[_END_] ), Q{contextualized}; 72 | say $[0]; 73 | _END_ 74 | 75 | ok round-trips( Q:to[_END_] ), Q{list reference}; 76 | my @solved = [1,2,3,4],[5,6,7,8],[9,10,11,12],[13,14,15,' ']; 77 | _END_ 78 | 79 | ok round-trips( Q:to[_END_] ), Q{class attribute traits}; 80 | role a_role { # role to add a variable: foo, 81 | has $.foo is rw = 2; # with an initial value of 2 82 | } 83 | _END_ 84 | 85 | ok round-trips( Q:to[_END_] ), Q{infix period}; 86 | constant expansions = 1; 87 | 88 | expansions[1].[2] 89 | _END_ 90 | 91 | ok round-trips( Q:to[_END_] ), Q{rx with bracketed array}; 92 | my @c; 93 | rx/<@c>/; 94 | _END_ 95 | 96 | ok round-trips( Q:to[_END_] ), Q{range}; 97 | for 99...1 -> $bottles { } 98 | 99 | #| Prints a verse about a certain number of beers, possibly on a wall. 100 | _END_ 101 | 102 | ok round-trips( Q:to[_END_] ), Q{return Sub type}; 103 | sub sma(Int \P) returns Sub { 104 | sub ($x) { 105 | } 106 | } 107 | _END_ 108 | 109 | ok round-trips( Q:to[_END_] ), Q{subroutine with 'where' clause}; 110 | sub sma(Int \P where * > 0) returns Sub { } 111 | _END_ 112 | 113 | ok round-trips( Q:to[_END_] ), Q{regex modifier}; 114 | /<[ d ]>*/ 115 | _END_ 116 | 117 | ok round-trips( Q:to[_END_] ), Q{guillemot}; 118 | my @a; 119 | bag +« flat @a».comb: 1 120 | _END_ 121 | 122 | ok round-trips( Q:to[_END_] ), Q{dereference}; 123 | my @x; @x.grep( +@($_) ) 124 | _END_ 125 | 126 | ok round-trips( Q:to[_END_] ), Q{semicolon in function call}; 127 | roundrobin( 1 ; 2 ); 128 | _END_ 129 | 130 | ok round-trips( Q:to[_END_] ), Q{semicolon in array slice}; 131 | my @board; 132 | @board[*;1] = 1,2; 133 | _END_ 134 | 135 | ok round-trips( Q:to[_END_] ), Q{here-doc with text after marker}; 136 | print qq:to/END/; 137 | Press direction arrows to move. 138 | Press q to quit. Press n for a new puzzle. 139 | END 140 | _END_ 141 | 142 | ok round-trips( Q:to[_END_] ), Q{infix-increment}; 143 | my ($x,@x); 144 | $x.push: @x[$x] += @x.shift; 145 | _END_ 146 | 147 | ok round-trips( Q:to[_END_] ), Q{optional arguments}; 148 | sub sing( Bool :$wall ) { } 149 | _END_ 150 | 151 | ok round-trips( Q:to[_END_] ), Q{optional argument w/ trailing comma}; 152 | sub sing( Int $a , Int $b , Bool :$wall, ) { } 153 | _END_ 154 | 155 | ok round-trips( Q:to[_END_] ), Q{loop}; 156 | my ($n,$k); 157 | loop (my ($p, $f) = 2, 0; $f < $k && $p*$p <= $n; $p++) { } 158 | _END_ 159 | 160 | ok round-trips( Q:to[_END_] ), Q{break up args}; 161 | my @a; 162 | (sub ($w1, $w2, $w3, $w4){ })(|@a); 163 | _END_ 164 | 165 | ok round-trips( Q:to[_END_] ), Q{meta-tilde}; 166 | ("a".comb «~» "a".comb); 167 | _END_ 168 | 169 | ok round-trips( Q:to[_END_] ), Q{postcircumfix method call}; 170 | my $x; $x() 171 | _END_ 172 | 173 | ok round-trips( Q:to[_END_] ), Q{if-elsif}; 174 | if 1 { } elsif 2 { } elsif 3 { } 175 | _END_ 176 | 177 | ok round-trips( Q:to[_END_] ), Q{operation: bareword}; 178 | sub infix: ($a,$b) { } 179 | _END_ 180 | 181 | ok round-trips( Q:to[_END_] ), Q{param argument}; 182 | do -> (:value(@pa)) { }; 183 | _END_ 184 | 185 | #`( Aha, found another potential lockup 186 | ok round-trips( Q:to[_END_] ), Q{trailing slash}; 187 | .put for slurp\ 188 | () 189 | _END_ 190 | ) 191 | 192 | ok round-trips( Q:to[_END_] ), Q{zip-equal}; 193 | my (@a,@b); 194 | my %h = @a Z=> @b; 195 | _END_ 196 | 197 | ok round-trips( Q:to[_END_] ), Q{multiple ...}; 198 | do 0 => [], -> { 2 ... 1 } ... * 199 | _END_ 200 | 201 | ok round-trips( Q:to[_END_] ), Q{posfix 'or'}; 202 | open "example.txt" , :r or 1; 203 | _END_ 204 | 205 | ok round-trips( Q:to[_END_] ), Q{implicit return type}; 206 | sub ev (Str $s --> Num) { } 207 | _END_ 208 | 209 | ok round-trips( Q:to[_END_] ), Q{ordered alternation}; 210 | grammar { token literal { ['.' \d+]? || '.' } } 211 | _END_ 212 | 213 | ok round-trips( Q:to[_END_] ), Q{repeat block}; 214 | repeat { } while 1; 215 | _END_ 216 | 217 | ok round-trips( Q:to[_END_] ), Q{postcircumfix operator}; 218 | $ 219 | _END_ 220 | 221 | ok round-trips( Q:to[_END_] ), Q{regex with adverb}; 222 | m:s/^ \d $/ 223 | _END_ 224 | 225 | ok round-trips( Q:to[_END_] ), Q{shaped hash}; 226 | my %hash{Any}; 227 | _END_ 228 | 229 | ok round-trips( Q:to[_END_] ), Q{hyper triangle}; 230 | my $s; 231 | 1 given [\+] '\\' «leg« $s.comb; 232 | _END_ 233 | 234 | #`( Type check fails on the interior 235 | ok round-trips( Q:to[_END_] ), Q{whateverable prototype}; 236 | proto A { {*} } 237 | _END_ 238 | ) 239 | 240 | ok round-trips( Q:to[_END_] ), Q{whateverable placeholder}; 241 | sub find-loop { %^mapping{*} } 242 | _END_ 243 | 244 | #`( Another potential lockup - Add '+1' on the next line to make it compile, 245 | yet it still locks the parser. 246 | ok round-trips( Q:to[_END_] ), Q{Another backslash}; 247 | 2 for 1\ # foo 248 | _END_ 249 | ) 250 | 251 | ok round-trips( Q:to[_END_] ), Q{guillemot again}; 252 | sort()»; 253 | _END_ 254 | 255 | ok round-trips( Q:to[_END_] ), Q{More comma-separated lists}; 256 | sub binary_search (&p, Int $lo, Int $hi --> Int) { 257 | } 258 | _END_ 259 | 260 | ok round-trips( gensym-package Q:to[_END_] ), Q{Even more comma-separated lists}; 261 | class %s { 262 | method pixel( $i, $j --> Int ) is rw { } 263 | } 264 | _END_ 265 | 266 | ok round-trips( Q:to[_END_] ), Q{substitution with adverb}; 267 | s:g/'[]'// 268 | _END_ 269 | 270 | done-testing; 271 | 272 | # vim: ft=perl6 273 | -------------------------------------------------------------------------------- /t/README.pod: -------------------------------------------------------------------------------- 1 | =begin README 2 | 3 | I'm commenting out not-working-yet tests using the #`(..) style (1) because I 4 | can, and (2) because the ` is rarer in Perl 6, therefore faster to search for. 5 | In fact, I recently deleted a bunch of tests that were using the #`(..) marker 6 | but marked as 'Illegal' because they do illegal things with whitespace, rather 7 | than skip past them using '`'. 8 | 9 | In passing, please note that while it's trivially possible to bum down the 10 | tests, doing so makes it harder to insert 'say $p.dump' to view the 11 | AST, and 'say $tree.perl' to view the generated Perl 6 structure. 12 | 13 | As much as I dislike explicitly handling whitespace, here's the rationale: 14 | 15 | Leading WS, intrabrace WS and trailing WS are all different lengths. This is 16 | by design, so that in case I've matched the wrong whitespace section (they all 17 | look alike) during testing, the different lengths will break the test. 18 | 19 | Leading is 5 characters, intra is 3, trailing is 2. 20 | It's a happy coincidence that these are the 3rd-5th terms in the Fibonacci 21 | sequence. 22 | 23 | It's not a coincidence, however, that leading, trailing and intrabrace spacing all get tested in the same pass, however. This way if I duplicate a trailing space, it can't be confused with other whitespace because nothing else is 4 spaces (2 + 2) long. Same with the intra of 3, nothing else is 6 spaces long. And duplicating code is the most common failure mode. 24 | 25 | =end README 26 | -------------------------------------------------------------------------------- /t/corpus/rosetta-1.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | use Perl6::Parser; 5 | 6 | use lib 't/lib/'; 7 | use Utils; 8 | 9 | my $*CONSISTENCY-CHECK = True; 10 | my $*FALL-THROUGH = True; 11 | 12 | # Note that I'm adding redundant {}; blocks around all tests so that navigating 13 | # is nicer. 14 | # 15 | subtest { 16 | { ok round-trips( Q:to[_END_] ), Q{version 1}; 17 | my @doors = False xx 101; 18 | 19 | (.=not for @doors[0, $_ ... 100]) for 1..100; 20 | 21 | say "Door $_ is ", [ @doors[$_] ] for 1..100; 22 | _END_ 23 | }; 24 | 25 | { ok round-trips( Q:to[_END_] ), Q{version 2}; 26 | say "Door $_ is open" for map {$^n ** 2}, 1..10; 27 | _END_ 28 | }; 29 | 30 | { ok round-trips( Q:to[_END_] ), Q{version 3}; 31 | say "Door $_ is open" for 1..10 X** 2; 32 | _END_ 33 | }; 34 | 35 | { ok round-trips( Q:to[_END_] ), Q{version 4}; 36 | say "Door $_ is ", [.sqrt == .sqrt.floor] for 1..100; 37 | _END_ 38 | }; 39 | 40 | done-testing; 41 | }, Q{100 doors}; 42 | 43 | # The parser also recursively parses use'd classes, so since 44 | # Term::termios might not be present on all systems, stub it 45 | # out. 46 | { ok round-trips( Q:to[_END_] ), Q{15 Puzzle}; 47 | class Term::termios { has $fd; method getattr {}; method unset_lflags { }; method unset_iflags { }; method setattr { } } 48 | #use Term::termios; 49 | 50 | constant $saved = Term::termios.new(fd => 1).getattr; 51 | constant $termios = Term::termios.new(fd => 1).getattr; 52 | # raw mode interferes with carriage returns, so 53 | # set flags needed to emulate it manually 54 | $termios.unset_iflags(); 55 | $termios.unset_lflags(< ECHO ICANON IEXTEN ISIG>); 56 | $termios.setattr(:DRAIN); 57 | 58 | # reset terminal to original setting on exit 59 | END { $saved.setattr(:NOW) } 60 | 61 | constant n = 4; # board size 62 | constant cell = 6; # cell width 63 | 64 | constant $top = join '─' x cell, '┌', '┬' xx n-1, '┐'; 65 | constant $mid = join '─' x cell, '├', '┼' xx n-1, '┤'; 66 | constant $bot = join '─' x cell, '└', '┴' xx n-1, '┘'; 67 | 68 | my %dir = ( 69 | "\e[A" => 'up', 70 | "\e[B" => 'down', 71 | "\e[C" => 'right', 72 | "\e[D" => 'left', 73 | ); 74 | 75 | my @solved = [1,2,3,4],[5,6,7,8],[9,10,11,12],[13,14,15,' ']; 76 | my @board; 77 | new(); 78 | 79 | sub new () { 80 | loop { 81 | @board = shuffle(); 82 | last if parity-ok(@board); 83 | } 84 | } 85 | 86 | sub shuffle () { 87 | my @c = [1,2,3,4],[5,6,7,8],[9,10,11,12],[13,14,15,' ']; 88 | for (^16).pick(*) -> $y, $x { 89 | my ($yd, $ym, $xd, $xm) = ($y div n, $y mod n, $x div n, $x mod n); 90 | my $temp = @c[$ym;$yd]; 91 | @c[$ym;$yd] = @c[$xm;$xd]; 92 | @c[$xm;$xd] = $temp; 93 | } 94 | @c; 95 | } 96 | 97 | sub parity-ok (@b) { 98 | so (sum @b».grep(/' '/,:k).grep(/\d/, :kv)) %% 2; 99 | } 100 | 101 | sub row (@row) { '│' ~ (join '│', @row».¢er) ~ '│' } 102 | 103 | sub center ($s){ 104 | my $c = cell - $s.chars; 105 | my $pad = ' ' x ceiling($c/2); 106 | sprintf "%{cell}s", "$s$pad"; 107 | } 108 | 109 | sub draw-board { 110 | run('clear'); 111 | print qq:to/END/; 112 | 113 | 114 | Press direction arrows to move. 115 | 116 | Press q to quit. Press n for a new puzzle. 117 | 118 | $top 119 | { join "\n\t$mid\n\t", map { .&row }, @board } 120 | $bot 121 | 122 | { (so @board ~~ @solved) ?? 'Solved!!' !! '' } 123 | END 124 | } 125 | 126 | sub slide (@c is copy) { 127 | my $t = (grep { /' '/ }, :k, @c)[0]; 128 | return @c unless $t and $t > 0; 129 | @c[$t,$t-1] = @c[$t-1,$t]; 130 | @c; 131 | } 132 | 133 | multi sub move('up') { 134 | map { @board[*;$_] = reverse slide reverse @board[*;$_] }, ^n; 135 | } 136 | 137 | multi sub move('down') { 138 | map { @board[*;$_] = slide @board[*;$_] }, ^n; 139 | } 140 | 141 | multi sub move('left') { 142 | map { @board[$_] = reverse slide reverse @board[$_] }, ^n; 143 | } 144 | 145 | multi sub move('right') { 146 | map { @board[$_] = slide @board[$_] }, ^n; 147 | } 148 | 149 | loop { 150 | draw-board; 151 | 152 | # Read up to 4 bytes from keyboard buffer. 153 | # Page navigation keys are 3-4 bytes each. 154 | # Specifically, arrow keys are 3. 155 | my $key = $*IN.read(4).decode; 156 | 157 | move %dir{$key} if so %dir{$key}; 158 | last if $key eq 'q'; # (q)uit 159 | new() if $key eq 'n'; 160 | } 161 | _END_ 162 | }; 163 | 164 | { ok round-trips( Q:to[_END_] ), Q{2048}; 165 | class Term::termiosA { has $fd; method getattr {}; method unset_lflags { }; method unset_iflags { }; method setattr { } } 166 | #use Term::termiosA; 167 | 168 | constant $saved = Term::termiosA.new(fd => 1).getattr; 169 | constant $termios = Term::termiosA.new(fd => 1).getattr; 170 | # raw mode interferes with carriage returns, so 171 | # set flags needed to emulate it manually 172 | $termios.unset_iflags(); 173 | $termios.unset_lflags(< ECHO ICANON IEXTEN ISIG>); 174 | $termios.setattr(:DRAIN); 175 | 176 | # reset terminal to original setting on exit 177 | END { $saved.setattr(:NOW) } 178 | 179 | constant n = 4; # board size 180 | constant cell = 6; # cell width 181 | constant ansi = True; # color! 182 | 183 | my @board = ( ['' xx n] xx n ); 184 | my $save = ''; 185 | my $score = 0; 186 | 187 | constant $top = join '─' x cell, '┌', '┬' xx n-1, '┐'; 188 | constant $mid = join '─' x cell, '├', '┼' xx n-1, '┤'; 189 | constant $bot = join '─' x cell, '└', '┴' xx n-1, '┘'; 190 | 191 | my %dir = ( 192 | "\e[A" => 'up', 193 | "\e[B" => 'down', 194 | "\e[C" => 'right', 195 | "\e[D" => 'left', 196 | ); 197 | 198 | my @ANSI = <0 1;97 1;93 1;92 1;96 1;91 1;95 1;94 1;30;47 1;43 199 | 1;42 1;46 1;41 1;45 1;44 1;33;43 1;33;42 1;33;41 1;33;44>; 200 | 201 | sub row (@row) { '│' ~ (join '│', @row».¢er) ~ '│' } 202 | 203 | sub center ($s){ 204 | my $c = cell - $s.chars; 205 | my $pad = ' ' x ceiling($c/2); 206 | my $tile = sprintf "%{cell}s", "$s$pad"; 207 | my $idx = $s ?? $s.log(2) !! 0; 208 | ansi ?? "\e[{@ANSI[$idx]}m$tile\e[0m" !! $tile; 209 | } 210 | 211 | sub draw-board { 212 | run('clear'); 213 | print qq:to/END/; 214 | 215 | 216 | Press direction arrows to move. 217 | 218 | Press q to quit. 219 | 220 | $top 221 | { join "\n\t$mid\n\t", map { .&row }, @board } 222 | $bot 223 | 224 | Score: $score 225 | 226 | END 227 | } 228 | 229 | sub squash (@c) { 230 | my @t = grep { .chars }, @c; 231 | map { combine(@t[$_], @t[$_+1]) if @t[$_] && @t[$_+1] == @t[$_] }, ^@t-1; 232 | @t = grep { .chars }, @t; 233 | @t.push: '' while @t < n; 234 | @t; 235 | } 236 | 237 | sub combine ($v is rw, $w is rw) { $v += $w; $w = ''; $score += $v; } 238 | 239 | multi sub move('up') { 240 | map { @board[*;$_] = squash @board[*;$_] }, ^n; 241 | } 242 | 243 | multi sub move('down') { 244 | map { @board[*;$_] = reverse squash reverse @board[*;$_] }, ^n; 245 | } 246 | 247 | multi sub move('left') { 248 | map { @board[$_] = squash @board[$_] }, ^n; 249 | } 250 | 251 | multi sub move('right') { 252 | map { @board[$_] = reverse squash reverse @board[$_] }, ^n; 253 | } 254 | 255 | sub another { 256 | my @empties; 257 | for @board.kv -> $r, @row { 258 | @empties.push(($r, $_)) for @row.grep(:k, ''); 259 | } 260 | my ( $x, $y ) = @empties.roll; 261 | @board[$x; $y] = (flat 2 xx 9, 4).roll; 262 | } 263 | 264 | sub save () { join '|', flat @board».list } 265 | 266 | loop { 267 | another if $save ne save(); 268 | draw-board; 269 | $save = save(); 270 | 271 | # Read up to 4 bytes from keyboard buffer. 272 | # Page navigation keys are 3-4 bytes each. 273 | # Specifically, arrow keys are 3. 274 | my $key = $*IN.read(4).decode; 275 | 276 | move %dir{$key} if so %dir{$key}; 277 | last if $key eq 'q'; # (q)uit 278 | } 279 | _END_ 280 | }; 281 | 282 | #`{ XXX consistency check gets flagged 283 | { ok round-trips( Q:to[_END_] ), Q{24 game}; 284 | use MONKEY-SEE-NO-EVAL; 285 | 286 | say "Here are your digits: ", 287 | constant @digits = (1..9).roll(4)».Str; 288 | 289 | grammar Exp24 { 290 | token TOP { ^ $ { fail unless EVAL($/) == 24 } } 291 | rule exp { + % } 292 | rule term { '(' ')' | <@digits> } 293 | token op { < + - * / > } 294 | } 295 | 296 | while my $exp = prompt "\n24? " { 297 | if try Exp24.parse: $exp { 298 | say "You win :)"; 299 | last; 300 | } else { 301 | say ( 302 | 'Sorry. Try again.' xx 20, 303 | 'Try harder.' xx 5, 304 | 'Nope. Not even close.' xx 2, 305 | 'Are you five or something?', 306 | 'Come on, you can do better than that.' 307 | ).flat.pick 308 | } 309 | } 310 | _END_ 311 | }; 312 | } 313 | 314 | { ok round-trips( Q:to[_END_] ), Q{24 game/Solve}; 315 | use MONKEY-SEE-NO-EVAL; 316 | 317 | my @digits; 318 | my $amount = 4; 319 | 320 | # Get $amount digits from the user, 321 | # ask for more if they don't supply enough 322 | while @digits.elems < $amount { 323 | @digits.append: (prompt "Enter {$amount - @digits} digits from 1 to 9, " 324 | ~ '(repeats allowed): ').comb(/<[1..9]>/); 325 | } 326 | # Throw away any extras 327 | @digits = @digits[^$amount]; 328 | 329 | # Generate combinations of operators 330 | my @ops = [X,] <+ - * /> xx 3; 331 | 332 | # Enough sprintf formats to cover most precedence orderings 333 | my @formats = ( 334 | '%d %s %d %s %d %s %d', 335 | '(%d %s %d) %s %d %s %d', 336 | '(%d %s %d %s %d) %s %d', 337 | '((%d %s %d) %s %d) %s %d', 338 | '(%d %s %d) %s (%d %s %d)', 339 | '%d %s (%d %s %d %s %d)', 340 | '%d %s (%d %s (%d %s %d))', 341 | ); 342 | 343 | # Brute force test the different permutations 344 | for unique @digits.permutations -> @p { 345 | for @ops -> @o { 346 | for @formats -> $format { 347 | my $string = sprintf $format, flat roundrobin(|@p; |@o); 348 | my $result = EVAL($string); 349 | say "$string = 24" and last if $result and $result == 24; 350 | } 351 | } 352 | } 353 | 354 | # Only return unique sub-arrays 355 | sub unique (@array) { 356 | my %h = map { $_.Str => $_ }, @array; 357 | %h.values; 358 | } 359 | _END_ 360 | }; 361 | 362 | { ok round-trips( Q:to[_END_] ), Q{9 billion names of God}; 363 | my @todo = $[1]; 364 | my @sums = 0; 365 | sub nextrow($n) { 366 | for +@todo .. $n -> $l { 367 | @sums[$l] = 0; 368 | print $l,"\r" if $l < $n; 369 | my $r = []; 370 | for reverse ^$l -> $x { 371 | my @x := @todo[$x]; 372 | if @x { 373 | $r.push: @sums[$x] += @x.shift; 374 | } 375 | else { 376 | $r.push: @sums[$x]; 377 | } 378 | } 379 | @todo.push($r); 380 | } 381 | @todo[$n]; 382 | } 383 | 384 | say "rows:"; 385 | say .fmt('%2d'), ": ", nextrow($_)[] for 1..10; 386 | 387 | 388 | say "\nsums:"; 389 | for 23, 123, 1234, 10000 { 390 | say $_, "\t", [+] nextrow($_)[]; 391 | } 392 | _END_ 393 | }; 394 | 395 | subtest { 396 | { ok round-trips( Q:to[_END_] ), Q{version 1}; 397 | my $b = 99; 398 | 399 | repeat while --$b { 400 | say "{b $b} on the wall"; 401 | say "{b $b}"; 402 | say "Take one down, pass it around"; 403 | say "{b $b-1} on the wall"; 404 | say ""; 405 | } 406 | 407 | sub b($b) { 408 | "$b bottle{'s' if $b != 1} of beer"; 409 | } 410 | _END_ 411 | }; 412 | 413 | { ok round-trips( Q:to[_END_] ), Q{version 2}; 414 | for 99...1 -> $bottles { 415 | sing $bottles, :wall; 416 | sing $bottles; 417 | say "Take one down, pass it around"; 418 | sing $bottles - 1, :wall; 419 | say ""; 420 | } 421 | 422 | #| Prints a verse about a certain number of beers, possibly on a wall. 423 | sub sing( 424 | Int $number, #= Number of bottles of beer. 425 | Bool :$wall, #= Mention that the beers are on a wall? 426 | ) { 427 | my $quantity = $number == 0 ?? "No more" !! $number; 428 | my $plural = $number == 1 ?? "" !! "s"; 429 | my $location = $wall ?? " on the wall" !! ""; 430 | say "$quantity bottle$plural of beer$location" 431 | } 432 | _END_ 433 | }; 434 | 435 | { ok round-trips( Q:to[_END_] ), Q{version 3}; 436 | my @quantities = flat (99 ... 1), 'No more', 99; 437 | my @bottles = flat 'bottles' xx 98, 'bottle', 'bottles' xx 2; 438 | my @actions = flat 'Take one down, pass it around' xx 99, 439 | 'Go to the store, buy some more'; 440 | 441 | for @quantities Z @bottles Z @actions Z 442 | @quantities[1 .. *] Z @bottles[1 .. *] 443 | -> ($a, $b, $c, $d, $e) { 444 | say "$a $b of beer on the wall"; 445 | say "$a $b of beer"; 446 | say $c; 447 | say "$d $e of beer on the wall\n"; 448 | } 449 | _END_ 450 | }; 451 | 452 | done-testing; 453 | }, Q{99 bottles of beer}; 454 | 455 | done-testing; 456 | 457 | # vim: ft=perl6 458 | -------------------------------------------------------------------------------- /t/corpus/rosetta-b.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | use Perl6::Parser; 5 | 6 | use lib 't/lib/'; 7 | use Utils; 8 | 9 | my $*CONSISTENCY-CHECK = True; 10 | my $*FALL-THROUGH = True; 11 | 12 | # As an aide-de-memoire here, put "redundant" blocks around the tests that now 13 | # appear at the left edge. That way it's easier to skip with % around the file. 14 | # 15 | { ok round-trips( Q:to[_END_] ), Q{Babbage problem}; 16 | # For all positives integers from 1 to Infinity 17 | for 1 .. Inf -> $integer { 18 | # calculate the square of the integer 19 | my $square = $integer²; 20 | # print the integer and square and exit if the square modulo 1000000 is equal to 269696 21 | print "{$integer}² equals $square" and exit if $square % 1000000 == 269696; 22 | } 23 | _END_ 24 | }; 25 | 26 | { ok round-trips( Q:to[_END_] ), Q{Bacon cipher}; 27 | my $secret = q:to/END/; 28 | This task is to implement a program for encryption and decryption 29 | of plaintext using the simple alphabet of the Baconian cipher or 30 | some other kind of representation of this alphabet (make anything 31 | signify anything). This example will work with anything in the 32 | ASCII range... even code! $r%_-^&*(){}+~ #=`/\';*1234567890"' 33 | END 34 | 35 | my $text = q:to/END/; 36 | Bah. It isn't really practical to use typeface changes to encode 37 | information, it is too easy to tell that there is something going 38 | on and will attract attention. Font changes with enough regularity 39 | to encode mesages relatively efficiently would need to happen so 40 | often it would be obvious that there was some kind of manipulation 41 | going on. Steganographic encryption where it is obvious that there 42 | has been some tampering with the carrier is not going to be very 43 | effective. Not that any of these implementations would hold up to 44 | serious scrutiny anyway. Anyway, here's a semi-bogus implementation 45 | that hides information in white space. The message is hidden in this 46 | paragraph of text. Yes, really. It requires a fairly modern file 47 | viewer to display (not display?) the hidden message, but that isn't 48 | too unlikely any more. It may be stretching things to call this a 49 | Bacon cipher, but I think it falls within the spirit of the task, 50 | if not the exact definition. 51 | END 52 | #' 53 | my @enc = "", "​"; 54 | my %dec = @enc.pairs.invert; 55 | 56 | sub encode ($c) { @enc[($c.ord).fmt("%07b").comb].join('') } 57 | 58 | sub hide ($msg is copy, $text) { 59 | $msg ~= @enc[0] x (0 - ($msg.chars % 8)).abs; 60 | my $head = $text.substr(0,$msg.chars div 8); 61 | my $tail = $text.substr($msg.chars div 8, *-1); 62 | ($head.comb «~» $msg.comb(/. ** 8/)).join('') ~ $tail; 63 | } 64 | 65 | sub reveal ($steg) { 66 | join '', map { :2(%dec{$_.comb}.join('')).chr }, 67 | $steg.subst( /\w | | " " | "\n" /, '', :g).comb(/. ** 7/); 68 | } 69 | 70 | my $hidden = join '', map { .&encode }, $secret.comb; 71 | 72 | my $steganography = hide $hidden, $text; 73 | 74 | say "Steganograpic message hidden in text:"; 75 | say $steganography; 76 | 77 | say '*' x 70; 78 | 79 | say "Hidden message revealed:"; 80 | say reveal $steganography; 81 | _END_ 82 | }; 83 | 84 | subtest { 85 | { ok round-trips( Q:to[_END_] ), Q{version 1}; 86 | sub balanced($s) { 87 | my $l = 0; 88 | for $s.comb { 89 | when "]" { 90 | --$l; 91 | return False if $l < 0; 92 | } 93 | when "[" { 94 | ++$l; 95 | } 96 | } 97 | return $l == 0; 98 | } 99 | 100 | my $n = prompt "Number of brackets"; 101 | my $s = (<[ ]> xx $n).flat.pick(*).join; 102 | say "$s {balanced($s) ?? "is" !! "is not"} well-balanced" 103 | _END_ 104 | }; 105 | 106 | { ok round-trips( Q:to[_END_] ), Q{version 2}; 107 | sub balanced($s) { 108 | .none < 0 and .[*-1] == 0 109 | given [\+] '\\' «leg« $s.comb; 110 | } 111 | 112 | my $n = prompt "Number of bracket pairs: "; 113 | my $s = <[ ]>.roll($n*2).join; 114 | say "$s { balanced($s) ?? "is" !! "is not" } well-balanced" 115 | _END_ 116 | }; 117 | 118 | { ok round-trips( Q:to[_END_] ), Q{version 3}; 119 | sub balanced($_ is copy) { 120 | Nil while s:g/'[]'//; 121 | $_ eq ''; 122 | } 123 | 124 | my $n = prompt "Number of bracket pairs: "; 125 | my $s = <[ ]>.roll($n*2).join; 126 | say "$s is", ' not' x not balanced($s), " well-balanced"; 127 | _END_ 128 | }; 129 | 130 | { ok round-trips( Q:to[_END_] ), Q{version 4}; 131 | grammar BalBrack { token TOP { '[' * ']' } } 132 | 133 | my $n = prompt "Number of bracket pairs: "; 134 | my $s = ('[' xx $n, ']' xx $n).flat.pick(*).join; 135 | say "$s { BalBrack.parse($s) ?? "is" !! "is not" } well-balanced"; 136 | _END_ 137 | }; 138 | 139 | done-testing; 140 | }, Q{Balanced brackets}; 141 | 142 | { ok round-trips( Q:to[_END_] ), Q{Balanced ternary}; 143 | class BT { 144 | has @.coeff; 145 | 146 | my %co2bt = '-1' => '-', '0' => '0', '1' => '+'; 147 | my %bt2co = %co2bt.invert; 148 | 149 | multi method new (Str $s) { 150 | self.bless(*, coeff => %bt2co{$s.flip.comb}); 151 | } 152 | multi method new (Int $i where $i >= 0) { 153 | self.bless(*, coeff => carry $i.base(3).comb.reverse); 154 | } 155 | multi method new (Int $i where $i < 0) { 156 | self.new(-$i).neg; 157 | } 158 | 159 | method Str () { %co2bt{@!coeff}.join.flip } 160 | method Int () { [+] @!coeff Z* (1,3,9...*) } 161 | 162 | multi method neg () { 163 | self.new: coeff => carry self.coeff X* -1; 164 | } 165 | } 166 | 167 | sub carry (*@digits is copy) { 168 | loop (my $i = 0; $i < @digits; $i++) { 169 | while @digits[$i] < -1 { @digits[$i] += 3; @digits[$i+1]--; } 170 | while @digits[$i] > 1 { @digits[$i] -= 3; @digits[$i+1]++; } 171 | } 172 | pop @digits while @digits and not @digits[*-1]; 173 | @digits; 174 | } 175 | 176 | multi prefix:<-> (BT $x) { $x.neg } 177 | 178 | multi infix:<+> (BT $x, BT $y) { 179 | my ($b,$a) = sort +*.coeff, $x, $y; 180 | BT.new: coeff => carry $a.coeff Z+ $b.coeff, 0 xx *; 181 | } 182 | 183 | multi infix:<-> (BT $x, BT $y) { $x + $y.neg } 184 | 185 | multi infix:<*> (BT $x, BT $y) { 186 | my @x = $x.coeff; 187 | my @y = $y.coeff; 188 | my @z = 0 xx @x+@y-1; 189 | my @safe; 190 | for @x -> $xd { 191 | @z = @z Z+ (@y X* $xd), 0 xx *; 192 | @safe.push: @z.shift; 193 | } 194 | BT.new: coeff => carry @safe, @z; 195 | } 196 | 197 | my $a = BT.new: "+-0++0+"; 198 | my $b = BT.new: -436; 199 | my $c = BT.new: "+-++-"; 200 | my $x = $a * ( $b - $c ); 201 | 202 | say 'a == ', $a.Int; 203 | say 'b == ', $b.Int; 204 | say 'c == ', $c.Int; 205 | say "a × (b − c) == ", ~$x, ' == ', $x.Int; 206 | _END_ 207 | }; 208 | 209 | # XXX Make up a 'Image::PNG::Portable' class 210 | { ok round-trips( Q:to[_END_] ), Q{Barnsley fern}; 211 | class Image::PNG::Portable { has ( $.width, $.height ); method set { }; method write { } } 212 | #use Image::PNG::Portable; 213 | 214 | my ($w, $h) = (640, 640); 215 | 216 | my $png = Image::PNG::Portable.new: :width($w), :height($h); 217 | 218 | my ($x, $y) = (0, 0); 219 | 220 | for ^2e5 { 221 | my $r = 100.rand; 222 | ($x, $y) = do given $r { 223 | when $r <= 1 { ( 0, 0.16 * $y ) } 224 | when $r <= 8 { ( 0.20 * $x - 0.26 * $y, 0.23 * $x + 0.22 * $y + 1.60) } 225 | when $r <= 15 { (-0.15 * $x + 0.28 * $y, 0.26 * $x + 0.24 * $y + 0.44) } 226 | default { ( 0.85 * $x + 0.04 * $y, -0.04 * $x + 0.85 * $y + 1.60) } 227 | }; 228 | $png.set(($w / 2 + $x * 60).Int, $h - ($y * 60).Int, 0, 255, 0); 229 | } 230 | 231 | $png.write: 'Barnsley-fern-perl6.png'; 232 | _END_ 233 | }; 234 | 235 | { ok round-trips( Q:to[_END_] ), Q{Base64 encode data}; 236 | sub MAIN { 237 | my $buf = slurp("/tmp/favicon.ico", :bin); 238 | say buf-to-Base64($buf); 239 | } 240 | 241 | my @base64map = 'A' .. 'Z', 'a' .. 'z', ^10, '+', '/'; 242 | 243 | sub buf-to-Base64($buf) { 244 | join '', gather for $buf.list -> $a, $b = [], $c = [] { 245 | my $triplet = ($a +< 16) +| ($b +< 8) +| $c; 246 | take @base64map[($triplet +> (6 * 3)) +& 0x3F]; 247 | take @base64map[($triplet +> (6 * 2)) +& 0x3F]; 248 | if $c.elems { 249 | take @base64map[($triplet +> (6 * 1)) +& 0x3F]; 250 | take @base64map[($triplet +> (6 * 0)) +& 0x3F]; 251 | } 252 | elsif $b.elems { 253 | take @base64map[($triplet +> (6 * 1)) +& 0x3F]; 254 | take '='; 255 | } 256 | else { take '==' } 257 | } 258 | } 259 | _END_ 260 | }; 261 | 262 | #`{ XXX consistency check gets flagged 263 | { ok round-trips( Q:to[_END_] ), Q{Benford's law}; 264 | sub benford(@a) { bag +« flat @a».comb: /<( <[ 1..9 ]> )> <[ , . \d ]>*/ } 265 | 266 | sub show(%distribution) { 267 | printf "%9s %9s %s\n", ; 268 | for 1 .. 9 -> $digit { 269 | my $actual = %distribution{$digit} * 100 / [+] %distribution.values; 270 | my $expected = (1 + 1 / $digit).log(10) * 100; 271 | printf "%d: %5.2f%% | %5.2f%% | %.2f%%\n", 272 | $digit, $actual, $expected, abs($expected - $actual); 273 | } 274 | } 275 | 276 | multi MAIN($file) { show benford $file.IO.lines } 277 | multi MAIN() { show benford ( 1, 1, 2, *+* ... * )[^1000] } 278 | _END_ 279 | }; 280 | } 281 | 282 | subtest { 283 | { ok round-trips( Q:to[_END_] ), Q{version 1}; 284 | sub bernoulli($n) { 285 | my @a; 286 | for 0..$n -> $m { 287 | @a[$m] = FatRat.new(1, $m + 1); 288 | for reverse 1..$m -> $j { 289 | @a[$j - 1] = $j * (@a[$j - 1] - @a[$j]); 290 | } 291 | } 292 | return @a[0]; 293 | } 294 | 295 | constant @bpairs = grep *.value.so, ($_ => bernoulli($_) for 0..60); 296 | 297 | my $width = [max] @bpairs.map: *.value.numerator.chars; 298 | my $form = "B(%2d) = \%{$width}d/%d\n"; 299 | 300 | printf $form, .key, .value.nude for @bpairs; 301 | _END_ 302 | }; 303 | 304 | { ok round-trips( Q:to[_END_] ), Q{version 2}; 305 | constant bernoulli = gather { 306 | my @a; 307 | for 0..* -> $m { 308 | @a = FatRat.new(1, $m + 1), 309 | -> $prev { 310 | my $j = @a.elems; 311 | $j * (@a.shift - $prev); 312 | } ... { not @a.elems } 313 | take $m => @a[*-1] if @a[*-1]; 314 | } 315 | } 316 | 317 | constant @bpairs = bernoulli[^52]; 318 | 319 | my $width = [max] @bpairs.map: *.value.numerator.chars; 320 | my $form = "B(%d)\t= \%{$width}d/%d\n"; 321 | 322 | printf $form, .key, .value.nude for @bpairs; 323 | _END_ 324 | 325 | ok round-trips( Q:to[_END_] ), Q{version 3}; 326 | my sub infix:(\prev,\this) { this.key => this.key * (this.value - prev.value) } 327 | 328 | constant bernoulli = grep *.value, map { (.key => .value.[*-1]) }, do 329 | 0 => [FatRat.new(1,1)], 330 | -> (:key($pm),:value(@pa)) { 331 | $pm + 1 => [ map *.value, [\bop] ($pm + 2 ... 1) Z=> FatRat.new(1, $pm + 2), @pa ]; 332 | } ... *; 333 | _END_ 334 | }; 335 | 336 | done-testing; 337 | }, Q{Balanced brackets}; 338 | 339 | { ok round-trips( Q:to[_END_] ), Q{Best shuffle}; 340 | sub best-shuffle(Str $orig) { 341 | 342 | my @s = $orig.comb; 343 | my @t = @s.pick(*); 344 | 345 | for ^@s -> $i { 346 | for ^@s -> $j { 347 | if $i != $j and @t[$i] ne @s[$j] and @t[$j] ne @s[$i] { 348 | @t[$i, $j] = @t[$j, $i]; 349 | last; 350 | } 351 | } 352 | } 353 | 354 | my $count = 0; 355 | for @t.kv -> $k,$v { 356 | ++$count if $v eq @s[$k] 357 | } 358 | 359 | return (@t.join, $count); 360 | } 361 | 362 | printf "%s, %s, (%d)\n", $_, best-shuffle $_ 363 | for ; 364 | _END_ 365 | } 366 | 367 | { ok round-trips( Q:to[_END_] ), Q{Binary digits}; 368 | say .fmt("%b") for 5, 50, 9000; 369 | _END_ 370 | }; 371 | 372 | subtest { 373 | { ok round-trips( Q:to[_END_] ), Q{version 1}; 374 | sub search (@a, $x --> Int) { 375 | binary_search { $x cmp @a[$^i] }, 0, @a.end 376 | } 377 | 378 | sub binary_search (&p, Int $lo is copy, Int $hi is copy --> Int) { 379 | until $lo > $hi { 380 | my Int $mid = ($lo + $hi) div 2; 381 | given p $mid { 382 | when -1 { $hi = $mid - 1; } 383 | when 1 { $lo = $mid + 1; } 384 | default { return $mid; } 385 | } 386 | } 387 | fail; 388 | } 389 | _END_ 390 | }; 391 | 392 | { ok round-trips( Q:to[_END_] ), Q{version 2}; 393 | sub binary_search (&p, Int $lo, Int $hi --> Int) { 394 | $lo <= $hi or fail; 395 | my Int $mid = ($lo + $hi) div 2; 396 | given p $mid { 397 | when -1 { binary_search &p, $lo, $mid - 1 } 398 | when 1 { binary_search &p, $mid + 1, $hi } 399 | default { $mid } 400 | } 401 | } 402 | _END_ 403 | }; 404 | 405 | done-testing; 406 | }, Q{Binary search}; 407 | 408 | #`{ 409 | { ok round-trips( Q:to[_END_] ), Q{Binary strings}; 410 | # Perl 6 is perfectly fine with NUL *characters* in strings: 411 | 412 | my Str $s = 'nema' ~ 0.chr ~ 'problema!'; 413 | say $s; 414 | 415 | # However, Perl 6 makes a clear distinction between strings 416 | # (i.e. sequences of characters), like your name, or … 417 | my Str $str = "My God, it's full of chars!"; 418 | # … and sequences of bytes (called Bufs), for example a PNG image, or … 419 | my Buf $buf = Buf.new(255, 0, 1, 2, 3); 420 | say $buf; 421 | 422 | # Strs can be encoded into Bufs … 423 | my Buf $this = 'foo'.encode('ascii'); 424 | # … and Bufs can be decoded into Strs … 425 | my Str $that = $this.decode('ascii'); 426 | 427 | # So it's all there. Nevertheless, let's solve this task explicitly 428 | # in order to see some nice language features: 429 | 430 | # We define a class … 431 | class ByteStr { 432 | # … that keeps an array of bytes, and we delegate some 433 | # straight-forward stuff directly to this attribute: 434 | # (Note: "has byte @.bytes" would be nicer, but that is 435 | # not yet implemented in rakudo or niecza.) 436 | has Int @.bytes handles(< Bool elems gist push >); 437 | 438 | # A handful of methods … 439 | method clone() { 440 | self.new(:@.bytes); 441 | } 442 | 443 | method substr(Int $pos, Int $length) { 444 | self.new(:bytes(@.bytes[$pos .. $pos + $length - 1])); 445 | } 446 | 447 | method replace(*@substitutions) { 448 | my %h = @substitutions; 449 | @.bytes.=map: { %h{$_} // $_ } 450 | } 451 | } 452 | 453 | # A couple of operators for our new type: 454 | multi infix:(ByteStr $x, ByteStr $y) { $x.bytes cmp $y.bytes } 455 | multi infix:<~> (ByteStr $x, ByteStr $y) { ByteStr.new(:bytes($x.bytes, $y.bytes)) } 456 | 457 | # create some byte strings (destruction not needed due to garbage collection) 458 | my ByteStr $b0 = ByteStr.new; 459 | my ByteStr $b1 = ByteStr.new(:bytes( 'foo'.ords, 0, 10, 'bar'.ords )); 460 | 461 | # assignment ($b1 and $b2 contain the same ByteStr object afterwards): 462 | my ByteStr $b2 = $b1; 463 | 464 | # comparing: 465 | say 'b0 cmp b1 = ', $b0 cmp $b1; 466 | say 'b1 cmp b2 = ', $b1 cmp $b2; 467 | 468 | # cloning: 469 | my $clone = $b1.clone; 470 | $b1.replace('o'.ord => 0); 471 | say 'b1 = ', $b1; 472 | say 'b2 = ', $b2; 473 | say 'clone = ', $clone; 474 | 475 | # to check for (non-)emptiness we evaluate the ByteStr in boolean context: 476 | say 'b0 is ', $b0 ?? 'not empty' !! 'empty'; 477 | say 'b1 is ', $b1 ?? 'not empty' !! 'empty'; 478 | 479 | # appending a byte: 480 | $b1.push: 123; 481 | 482 | # extracting a substring: 483 | my $sub = $b1.substr(2, 4); 484 | say 'sub = ', $sub; 485 | 486 | # replacing a byte: 487 | $b2.replace(102 => 103); 488 | say $b2; 489 | 490 | # joining: 491 | my ByteStr $b3 = $b1 ~ $sub; 492 | say 'joined = ', $b3; 493 | _END_ 494 | }; 495 | } 496 | 497 | # XXX class Digest::SHA exports 'sha256' 498 | { ok round-trips( Q:to[_END_] ), Q{Bitcoin validation}; 499 | sub sha256 { } 500 | my $bitcoin-address = rx/ 501 | <+alnum-[0IOl]> ** 26..* # an address is at least 26 characters long 502 | .pairs.invert.hash{$/.comb} 510 | .reduce(* * 58 + *) 511 | .polymod(256 xx 24) 512 | .reverse; 513 | }> 514 | /; 515 | 516 | say "Here is a bitcoin address: 1AGNa15ZQXAZUgFiqJ2i7Z2DPU2J6hW62i" ~~ $bitcoin-address; 517 | _END_ 518 | }; 519 | 520 | # XXX class Digest::SHA exports sub sha256, sub rmd160 521 | { ok round-trips( Q:to[_END_] ), Q{Bitcoin public point to address}; 522 | sub sha256 { }; sub rmd160 { } 523 | #use SSL::Digest; 524 | 525 | constant BASE58 = < 526 | 1 2 3 4 5 6 7 8 9 527 | A B C D E F G H J K L M N P Q R S T U V W X Y Z 528 | a b c d e f g h i j k m n o p q r s t u v w x y z 529 | >; 530 | 531 | sub encode(Int $n) { 532 | $n < BASE58 ?? 533 | BASE58[$n] !! 534 | encode($n div 58) ~ BASE58[$n % 58] 535 | } 536 | 537 | sub public_point_to_address(Int $x is copy, Int $y is copy) { 538 | my @bytes; 539 | for 1 .. 32 { push @bytes, $y % 256; $y div= 256 } 540 | for 1 .. 32 { push @bytes, $x % 256; $x div= 256 } 541 | my $hash = rmd160 sha256 Blob.new: 4, @bytes.reverse; 542 | my $checksum = sha256(sha256 Blob.new: 0, $hash.list).subbuf: 0, 4; 543 | encode reduce * * 256 + * , 0, ($hash, $checksum)».list 544 | } 545 | 546 | say public_point_to_address 547 | 0x50863AD64A87AE8A2FE83C1AF1A8403CB53F53E486D8511DAD8A04887E5B2352, 548 | 0x2CD470243453A299FA9E77237716103ABC11A1DF38855ED6F2EE187E9C582BA6; 549 | _END_ 550 | }; 551 | 552 | #`{ 553 | { ok round-trips( Q:to[_END_] ), Q{Bitmap}; 554 | class Pixel { has UInt ($.R, $.G, $.B) } 555 | class Bitmap { 556 | has UInt ($.width, $.height); 557 | has Pixel @!data; 558 | 559 | method fill(Pixel $p) { 560 | @!data = $p.clone xx ($!width*$!height) 561 | } 562 | method pixel( 563 | $i where ^$!width, 564 | $j where ^$!height 565 | --> Pixel 566 | ) is rw { @!data[$i*$!height + $j] } 567 | 568 | method set-pixel ($i, $j, Pixel $p) { 569 | self.pixel($i, $j) = $p.clone; 570 | } 571 | method get-pixel ($i, $j) returns Pixel { 572 | self.pixel($i, $j); 573 | } 574 | } 575 | 576 | my Bitmap $b = Bitmap.new( width => 10, height => 10); 577 | 578 | $b.fill( Pixel.new( R => 0, G => 0, B => 200) ); 579 | 580 | $b.set-pixel( 7, 5, Pixel.new( R => 100, G => 200, B => 0) ); 581 | 582 | say $b.perl; 583 | _END_ 584 | }; 585 | } 586 | 587 | # XXX Create a shell 'Bitmap' class.. yes, just above but separation... 588 | #`{ 589 | { ok round-trips( Q:to[_END_] ), Q{Bitmap / Bresenham's line algorithm}; 590 | class Pixel { has UInt ($.R, $.G, $.B) } 591 | class Bitmap { has ($.width, $.height, @!data); method fill { }; method pixel { }; method set-pixel { }; method get-pixel { } } 592 | sub line(Bitmap $bitmap, $x0 is copy, $x1 is copy, $y0 is copy, $y1 is copy) { 593 | my $steep = abs($y1 - $y0) > abs($x1 - $x0); 594 | if $steep { 595 | ($x0, $y0) = ($y0, $x0); 596 | ($x1, $y1) = ($y1, $x1); 597 | } 598 | if $x0 > $x1 { 599 | ($x0, $x1) = ($x1, $x0); 600 | ($y0, $y1) = ($y1, $y0); 601 | } 602 | my $Δx = $x1 - $x0; 603 | my $Δy = abs($y1 - $y0); 604 | my $error = 0; 605 | my $Δerror = $Δy / $Δx; 606 | my $y-step = $y0 < $y1 ?? 1 !! -1; 607 | my $y = $y0; 608 | for $x0 .. $x1 -> $x { 609 | my $pix = Pixel.new(R => 100, G => 200, B => 0); 610 | if $steep { 611 | $bitmap.set-pixel($y, $x, $pix); 612 | } else { 613 | $bitmap.set-pixel($x, $y, $pix); 614 | } 615 | $error += $Δerror; 616 | if $error >= 0.5 { 617 | $y += $y-step; 618 | $error -= 1.0; 619 | } 620 | } 621 | } 622 | _END_ 623 | }; 624 | } 625 | 626 | # XXX Create a shell 'Bitmap' class.. yes, just above but separation... 627 | #`{ 628 | { ok round-trips( Q:to[_END_] ), Q{Bitmap / midpoint circle algorithm}; 629 | use MONKEY-TYPING; 630 | class Pixel { has UInt ($.R, $.G, $.B) } 631 | class Bitmap { has ($.width, $.height, @!data); method fill { }; method pixel { }; method set-pixel { }; method get-pixel { } } 632 | augment class Pixel { method Str { "$.R $.G $.B" } } 633 | augment class Bitmap { 634 | method P3 { 635 | join "\n", «P3 "$.width $.height" 255», 636 | do for ^$.height { join ' ', @.data[]»[$_] } 637 | } 638 | method raster-circle ( $x0, $y0, $r, Pixel $value ) { 639 | my $f = 1 - $r; 640 | my $ddF_x = 0; 641 | my $ddF_y = -2 * $r; 642 | my ($x, $y) = 0, $r; 643 | self.set-pixel($x0, $y0 + $r, $value); 644 | self.set-pixel($x0, $y0 - $r, $value); 645 | self.set-pixel($x0 + $r, $y0, $value); 646 | self.set-pixel($x0 - $r, $y0, $value); 647 | while $x < $y { 648 | if $f >= 0 { 649 | $y--; 650 | $ddF_y += 2; 651 | $f += $ddF_y; 652 | } 653 | $x++; 654 | $ddF_x += 2; 655 | $f += $ddF_x + 1; 656 | self.set-pixel($x0 + $x, $y0 + $y, $value); 657 | self.set-pixel($x0 - $x, $y0 + $y, $value); 658 | self.set-pixel($x0 + $x, $y0 - $y, $value); 659 | self.set-pixel($x0 - $x, $y0 - $y, $value); 660 | self.set-pixel($x0 + $y, $y0 + $x, $value); 661 | self.set-pixel($x0 - $y, $y0 + $x, $value); 662 | self.set-pixel($x0 + $y, $y0 - $x, $value); 663 | self.set-pixel($x0 - $y, $y0 - $x, $value); 664 | } 665 | } 666 | } 667 | _END_ 668 | }; 669 | } 670 | 671 | #`{ 672 | { ok round-trips( Q:to[_END_] ), Q{Bitmap / write a PPM file}; 673 | class Pixel { has uint8 ($.R, $.G, $.B) } 674 | class Bitmap { 675 | has UInt ($.width, $.height); 676 | has Pixel @!data; 677 | 678 | method fill(Pixel $p) { 679 | @!data = $p.clone xx ($!width*$!height) 680 | } 681 | method pixel( 682 | $i where ^$!width, 683 | $j where ^$!height 684 | --> Pixel 685 | ) is rw { @!data[$i*$!height + $j] } 686 | 687 | method data { @!data } 688 | } 689 | 690 | role PPM { 691 | method P6 returns Blob { 692 | "P6\n{self.width} {self.height}\n255\n".encode('ascii') 693 | ~ Blob.new: flat map { .R, .G, .B }, self.data 694 | } 695 | } 696 | 697 | my Bitmap $b = Bitmap.new(width => 125, height => 125) but PPM; 698 | for flat ^$b.height X ^$b.width -> $i, $j { 699 | $b.pixel($i, $j) = Pixel.new: :R($i*2), :G($j*2), :B(255-$i*2); 700 | } 701 | 702 | $*OUT.write: $b.P6; 703 | _END_ 704 | }; 705 | } 706 | 707 | { ok round-trips( Q:to[_END_] ), Q{Bitwise I/O}; 708 | sub encode-ascii(Str $s) { 709 | my @b = $s.ords».fmt("%07b")».comb; 710 | @b.push(0) until @b %% 8; # padding 711 | Buf.new: gather while @b { take reduce * *2+*, (@b.pop for ^8) } 712 | } 713 | 714 | sub decode-ascii(Buf $b) { 715 | my @b = $b.list».fmt("%08b")».comb; 716 | @b.shift until @b %% 7; # remove padding 717 | @b = gather while @b { take reduce * *2+*, (@b.pop for ^7) } 718 | return [~] @b».chr; 719 | } 720 | say my $encode = encode-ascii 'STRING'; 721 | say decode-ascii $encode; 722 | _END_ 723 | }; 724 | 725 | #`[ 726 | { ok round-trips( Q:to[_END_] ), Q{Bitwise operations}; 727 | constant MAXINT = uint.Range.max; 728 | constant BITS = MAXINT.base(2).chars; 729 | 730 | # define rotate ops for the fun of it 731 | multi sub infix:<⥁>(Int:D \a, Int:D \b) { :2[(a +& MAXINT).polymod(2 xx BITS-1).list.rotate(b).reverse] } 732 | multi sub infix:<⥀>(Int:D \a, Int:D \b) { :2[(a +& MAXINT).polymod(2 xx BITS-1).reverse.rotate(b)] } 733 | 734 | sub int-bits (Int $a, Int $b) { 735 | say ''; 736 | say_bit "$a", $a; 737 | say ''; 738 | say_bit "2's complement $a", +^$a; 739 | say_bit "$a and $b", $a +& $b; 740 | say_bit "$a or $b", $a +| $b; 741 | say_bit "$a xor $b", $a +^ $b; 742 | say_bit "$a unsigned shift right $b", ($a +& MAXINT) +> $b; 743 | say_bit "$a signed shift right $b", $a +> $b; 744 | say_bit "$a rotate right $b", $a ⥁ $b; 745 | say_bit "$a shift left $b", $a +< $b; 746 | say_bit "$a rotate left $b", $a ⥀ $b; 747 | } 748 | 749 | int-bits(7,2); 750 | int-bits(-65432,31); 751 | 752 | sub say_bit ($message, $value) { 753 | printf("%30s: %{'0' ~ BITS}b\n", $message, $value +& MAXINT); 754 | } 755 | _END_ 756 | } 757 | ] 758 | 759 | { ok round-trips( Q:to[_END_] ), Q{Boolean types}; 760 | my Bool $crashed = False; 761 | my $val = 0 but True; 762 | _END_ 763 | }; 764 | 765 | { ok round-trips( Q:to[_END_] ), Q{Box the compass}; 766 | sub point (Int $index) { 767 | my $ix = $index % 32; 768 | if $ix +& 1 769 | { "&point(($ix + 1) +& 28) by &point(((2 - ($ix +& 2)) * 4) + $ix +& 24)" } 770 | elsif $ix +& 2 771 | { "&point(($ix + 2) +& 24)-&point(($ix +| 4) +& 28)" } 772 | elsif $ix +& 4 773 | { "&point(($ix + 8) +& 16)&point(($ix +| 8) +& 24)" } 774 | else 775 | { [$ix div 8]; } 776 | } 777 | 778 | sub test-angle ($ix) { $ix * 11.25 + (0, 5.62, -5.62)[ $ix % 3 ] } 779 | sub angle-to-point(\𝜽) { floor 𝜽 / 360 * 32 + 0.5 } 780 | 781 | for 0 .. 32 -> $ix { 782 | my \𝜽 = test-angle($ix); 783 | printf " %2d %6.2f° %s\n", 784 | $ix % 32 + 1, 785 | 𝜽, 786 | tc point angle-to-point 𝜽; 787 | } 788 | _END_ 789 | }; 790 | 791 | #`[ 792 | { ok round-trips( Q:to[_END_] ), Q{Brace expansion}; 793 | grammar BraceExpansion { 794 | token TOP { ( | . )* } 795 | token meta { '{' '}' | \\ . } 796 | token alts { + % ',' } 797 | token alt { ( | <-[ , } ]> )* } 798 | } 799 | 800 | sub crosswalk($/) { 801 | [X~] '', $0.map: -> $/ { ([$.&alternatives]) or ~$/ } 802 | } 803 | 804 | sub alternatives($_) { 805 | when :not { () } 806 | when 1 { '{' X~ $_».&crosswalk X~ '}' } 807 | default { $_».&crosswalk } 808 | } 809 | 810 | sub brace-expand($s) { crosswalk BraceExpansion.parse($s) } 811 | 812 | sub bxtest(*@s) { 813 | for @s -> $s { 814 | say "\n$s"; 815 | for brace-expand($s) { 816 | say " ", $_; 817 | } 818 | } 819 | } 820 | 821 | bxtest Q:to/END/.lines; 822 | ~/{Downloads,Pictures}/*.{jpg,gif,png} 823 | It{{em,alic}iz,erat}e{d,}, please. 824 | {,{,gotta have{ ,\, again\, }}more }cowbell! 825 | {}} some {\\{edge,edgy} }{ cases, here\\\} 826 | a{b{1,2}c 827 | a{1,2}b}c 828 | a{1,{2},3}b 829 | a{b{1,2}c{}} 830 | more{ darn{ cowbell,},} 831 | ab{c,d\,e{f,g\h},i\,j{k,l\,m}n,o\,p}qr 832 | {a,{\,b}c 833 | a{b,{{c}} 834 | {a{\}b,c}d 835 | {a,b{{1,2}e}f 836 | END 837 | _END_ 838 | }; 839 | ] 840 | 841 | { ok round-trips( Q:to[_END_] ), Q{Break OO privacy}; 842 | class Foos { 843 | has $!shyguy = 42; 844 | } 845 | my Foos $foo .= new; 846 | 847 | say $foo.^attributes.first('$!shyguy').get_value($foo); 848 | _END_ 849 | }; 850 | 851 | #`{ There's now a check that munges 'CHECK' and 'BEGIN' lines, that may 852 | be causing problems with this particular parse. 853 | { ok round-trips( Q:to[_END_] ), Q{Brownian tree}; 854 | constant size = 100; 855 | constant particlenum = 1_000; 856 | 857 | 858 | constant mid = size div 2; 859 | 860 | my $spawnradius = 5; 861 | my @map; 862 | 863 | sub set($x, $y) { 864 | @map[$x][$y] = True; 865 | } 866 | 867 | sub get($x, $y) { 868 | return @map[$x][$y] || False; 869 | } 870 | 871 | set(mid, mid); 872 | my @blocks = " ","\c[UPPER HALF BLOCK]", "\c[LOWER HALF BLOCK]","\c[FULL BLOCK]"; 873 | 874 | sub infix:<█>($a, $b) { 875 | @blocks[$a + 2 * $b] 876 | } 877 | 878 | sub display { 879 | my $start = 0; 880 | my $end = size; 881 | say (for $start, $start + 2 ... $end -> $y { 882 | (for $start..$end -> $x { 883 | if abs(($x&$y) - mid) < $spawnradius { 884 | get($x, $y) █ get($x, $y+1); 885 | } else { 886 | " " 887 | } 888 | }).join 889 | }).join("\n") 890 | } 891 | 892 | for ^particlenum -> $progress { 893 | my Int $x; 894 | my Int $y; 895 | my &reset = { 896 | repeat { 897 | ($x, $y) = (mid - $spawnradius..mid + $spawnradius).pick, (mid - $spawnradius, mid + $spawnradius).pick; 898 | ($x, $y) = ($y, $x) if (True, False).pick(); 899 | } while get($x,$y); 900 | } 901 | reset; 902 | 903 | while not get($x-1|$x|$x+1, $y-1|$y|$y+1) { 904 | $x = ($x-1, $x, $x+1).pick; 905 | $y = ($y-1, $y, $y+1).pick; 906 | if (False xx 3, True).pick { 907 | $x = $x >= mid ?? $x - 1 !! $x + 1; 908 | $y = $y >= mid ?? $y - 1 !! $y + 1; 909 | } 910 | if abs(($x | $y) - mid) > $spawnradius { 911 | reset; 912 | } 913 | } 914 | set($x,$y); 915 | display if $progress %% 50; 916 | if $spawnradius < mid && abs(($x|$y) - mid) > $spawnradius - 5 { 917 | $spawnradius = $spawnradius + 1; 918 | } 919 | } 920 | 921 | say ""; 922 | display; 923 | say ""; 924 | say "time elapsed: ", (now - BEGIN { now }).Num.fmt("%.2f"), " seconds"; 925 | say ""; 926 | _END_ 927 | }; 928 | } 929 | 930 | { ok round-trips( Q:to[_END_] ), Q{Bulls and cows}; 931 | my $size = 4; 932 | my @secret = pick $size, '1' .. '9'; 933 | 934 | for 1..* -> $guesses { 935 | my @guess; 936 | loop { 937 | @guess = (prompt("Guess $guesses: ") // exit).comb; 938 | last if @guess == $size and 939 | all(@guess) eq one(@guess) & any('1' .. '9'); 940 | say 'Malformed guess; try again.'; 941 | } 942 | my ($bulls, $cows) = 0, 0; 943 | for ^$size { 944 | when @guess[$_] eq @secret[$_] { ++$bulls; } 945 | when @guess[$_] eq any @secret { ++$cows; } 946 | } 947 | last if $bulls == $size; 948 | say "$bulls bulls, $cows cows."; 949 | } 950 | 951 | say 'A winner is you!'; 952 | _END_ 953 | }; 954 | 955 | { ok round-trips( Q:to[_END_] ), Q{Bulls and cows / player}; 956 | # we use the [] reduction meta operator along with the Cartesian Product 957 | # operator X to create the Cartesian Product of four times [1..9] and then get 958 | # all the elements where the number of unique digits is four. 959 | my @candidates = ([X] [1..9] xx 4).tree.grep: *.uniq == 4; 960 | 961 | repeat { 962 | my $guess = @candidates.pick; 963 | my ($bulls, $cows) = read-score; 964 | @candidates .= grep: &score-correct; 965 | 966 | # note how we declare our two subroutines within the repeat block. This 967 | # limits the scope in which the routines are known to the scope in which 968 | # they are needed and saves us a lot of arguments to our two routines. 969 | sub score-correct($a) { 970 | # use the Z (zip) meta operator along with == to construct the 971 | # list ($a[0] == $b[0], $a[1] == $b[1], ...) and then add it up 972 | # using the reduction meta operator [] and +. 973 | my $exact = [+] $a Z== $guess; 974 | 975 | # number of elements of $a that match any element of $b 976 | my $loose = +$a.grep: any @$guess; 977 | 978 | return $bulls == $exact && $cows == $loose - $exact; 979 | } 980 | 981 | sub read-score() { 982 | loop { 983 | my $score = prompt "My guess: {$guess.join}.\n"; 984 | 985 | # use the :s modifier to tell Perl 6 to handle spaces 986 | # automatically and save the first digit in $ and 987 | # the second digit in $ 988 | if $score ~~ m:s/^ $=(\d) $=(\d) $/ 989 | and $ + $ <= 4 { 990 | return +$, +$; 991 | } 992 | 993 | say "Please specify the number of bulls and cows"; 994 | } 995 | } 996 | } while @candidates > 1; 997 | 998 | say @candidates 999 | ?? "Your secret number is {@candidates[0].join}!" 1000 | !! "I think you made a mistake with your scoring."; 1001 | _END_ 1002 | }; 1003 | 1004 | done-testing; 1005 | 1006 | #vim: ft=perl6 1007 | -------------------------------------------------------------------------------- /t/lib/Utils.pm6: -------------------------------------------------------------------------------- 1 | class Utils { 2 | 3 | use Perl6::Parser; 4 | 5 | # Classes, modules, packages &c can no longer be redeclared. 6 | # Which is probably a good thing, but plays havoc with testing here. 7 | # 8 | # This is a little ol' tool that generates a fresh package name every 9 | # time through the testing suite. I can't just make up new names as 10 | # the test suite goes along because I'm running the full test suite 11 | # twice, once with the original Perl6 parser-aided version, and once 12 | # with the new regex-based parser. 13 | # 14 | # Use it to build out package names and such. 15 | # 16 | sub gensym-package( Str $code ) is export { 17 | state $appendix = 'A'; 18 | my $num-package-uses = $code.indices( '%s' ).elems; 19 | my $package = 'Foo' ~ $appendix++; 20 | 21 | return sprintf $code, ( $package ) xx $num-package-uses; 22 | } 23 | 24 | sub round-trips( Str $code ) returns Bool is export { 25 | my $pp = Perl6::Parser.new; 26 | my $tree = $pp.to-tree( $code ); 27 | 28 | return $pp.to-string( $tree ) eq $code; 29 | } 30 | 31 | sub has-a( $root, $type-object ) returns Bool is export { 32 | return True if $root ~~ $type-object; 33 | if $root.is-twig { 34 | for $root.child -> $child { 35 | return True if has-a( $child, $type-object ); 36 | } 37 | } 38 | return False; 39 | } 40 | } 41 | -------------------------------------------------------------------------------- /xt/meta_info.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use lib 'lib'; 3 | use Test; 4 | plan 1; 5 | 6 | constant AUTHOR = ?%*ENV; 7 | 8 | if AUTHOR { 9 | require Test::META <&meta-ok>; 10 | meta-ok; 11 | done-testing; 12 | } 13 | else { 14 | skip-rest "Skipping author test"; 15 | exit; 16 | } 17 | --------------------------------------------------------------------------------