diff --git a/lib/linguist/heuristics.rb b/lib/linguist/heuristics.rb index c203b1bae5..a4657cd8e2 100644 --- a/lib/linguist/heuristics.rb +++ b/lib/linguist/heuristics.rb @@ -70,8 +70,10 @@ def call(data) end end - disambiguate "Perl", "Prolog" do |data| - if data.include?("use strict") + disambiguate "Perl", "Perl6", "Prolog" do |data| + if data.include?("use v6") + Language["Perl6"] + elsif data.include?("use strict") Language["Perl"] elsif data.include?(":-") Language["Prolog"] diff --git a/lib/linguist/languages.yml b/lib/linguist/languages.yml index da18b25a00..41996ffabe 100644 --- a/lib/linguist/languages.yml +++ b/lib/linguist/languages.yml @@ -1970,14 +1970,17 @@ Perl6: type: programming color: "#0298c3" extensions: - - .p6 - .6pl - .6pm - .nqp + - .p6 - .p6l - .p6m + - .pl - .pl6 + - .pm - .pm6 + - .t interpreters: - perl6 tm_scope: none diff --git a/samples/Perl6/01-dash-uppercase-i.t b/samples/Perl6/01-dash-uppercase-i.t new file mode 100644 index 0000000000..57a5afd0bd --- /dev/null +++ b/samples/Perl6/01-dash-uppercase-i.t @@ -0,0 +1,97 @@ +use v6; + +use Test; + +=begin pod + +Test handling of -I. + +Multiple C<-I> switches are supposed to +prepend left-to-right: + + -Ifoo -Ibar + +should make C<@*INC> look like: + + foo + bar + ... + +Duplication of directories on the command line is mirrored +in the C<@*INC> variable, so C will have B +entries C in C<@*INC>. + +=end pod + +# L + +my $fragment = '-e "@*INC.perl.say"'; + +my @tests = ( + 'foo', + 'foo$bar', + 'foo bar$baz', + 'foo$foo', +); + +plan @tests*2; + +diag "Running under $*OS"; + +my ($pugs,$redir) = ($*EXECUTABLE_NAME, ">"); + +if $*OS eq any { + $pugs = 'pugs.exe'; + $redir = '>'; +}; + +sub nonce () { return (".{$*PID}." ~ (1..1000).pick) } + +sub run_pugs ($c) { + my $tempfile = "temp-ex-output" ~ nonce; + my $command = "$pugs $c $redir $tempfile"; + diag $command; + run $command; + my $res = slurp $tempfile; + unlink $tempfile; + return $res; +} + +for @tests -> $t { + my @dirs = split('$',$t); + my $command; + # This should be smarter about quoting + # (currently, this should work for WinNT and Unix shells) + $command = join " ", map { qq["-I$_"] }, @dirs; + my $got = run_pugs( $command ~ " $fragment" ); + $got .= chomp; + + if (substr($got,0,1) ~~ "[") { + # Convert from arrayref to array + $got = substr($got, 1, -1); + }; + + my @got = EVAL $got; + @got = @got[ 0..@dirs-1 ]; + my @expected = @dirs; + + is @got, @expected, "'" ~ @dirs ~ "' works"; + + $command = join " ", map { qq[-I "$_"] }, @dirs; + $got = run_pugs( $command ~ " $fragment" ); + + $got .= chomp; + if (substr($got,0,1) ~~ "[") { + # Convert from arrayref to array + $got = substr($got, 1, -1); + }; + + @got = EVAL $got; + @got = @got[ 0..@dirs-1 ]; + @expected = @dirs; + + is @got, @expected, "'" ~ @dirs ~ "' works (with a space delimiting -I)"; +} + + +# vim: ft=perl6 diff --git a/samples/Perl6/01-parse.t b/samples/Perl6/01-parse.t new file mode 100644 index 0000000000..6c81fb040d --- /dev/null +++ b/samples/Perl6/01-parse.t @@ -0,0 +1,223 @@ +use v6; +BEGIN { @*INC.push('lib') }; + +use JSON::Tiny::Grammar; +use Test; + +my @t = + '{}', + '{ }', + ' { } ', + '{ "a" : "b" }', + '{ "a" : null }', + '{ "a" : true }', + '{ "a" : false }', + '{ "a" : { } }', + '[]', + '[ ]', + ' [ ] ', + # stolen from JSON::XS, 18_json_checker.t, and adapted a bit + Q<<[ + "JSON Test Pattern pass1", + {"object with 1 member":["array with 1 element"]}, + {}, + [] + ]>>, + Q<<[1]>>, + Q<<[true]>>, + Q<<[-42]>>, + Q<<[-42,true,false,null]>>, + Q<<{ "integer": 1234567890 }>>, + Q<<{ "real": -9876.543210 }>>, + Q<<{ "e": 0.123456789e-12 }>>, + Q<<{ "E": 1.234567890E+34 }>>, + Q<<{ "": 23456789012E66 }>>, + Q<<{ "zero": 0 }>>, + Q<<{ "one": 1 }>>, + Q<<{ "space": " " }>>, + Q<<{ "quote": "\""}>>, + Q<<{ "backslash": "\\"}>>, + Q<<{ "controls": "\b\f\n\r\t"}>>, + Q<<{ "slash": "/ & \/"}>>, + Q<<{ "alpha": "abcdefghijklmnopqrstuvwyz"}>>, + Q<<{ "ALPHA": "ABCDEFGHIJKLMNOPQRSTUVWYZ"}>>, + Q<<{ "digit": "0123456789"}>>, + Q<<{ "0123456789": "digit"}>>, + Q<<{"special": "`1~!@#$%^&*()_+-={':[,]}|;.?"}>>, + Q<<{"hex": "\u0123\u4567\u89AB\uCDEF\uabcd\uef4A"}>>, + Q<<{"true": true}>>, + Q<<{"false": false}>>, + Q<<{"null": null}>>, + Q<<{"array":[ ]}>>, + Q<<{"object":{ }}>>, + Q<<{"address": "50 St. James Street"}>>, + Q<<{"url": "http://www.JSON.org/"}>>, + Q<<{"comment": "// /* */": " "}>>, + Q<<{ " s p a c e d " :[1,2 , 3 + +, + +4 , 5 , 6 ,7 ],"compact":[1,2,3,4,5,6,7]}>>, + + Q<<{"jsontext": "{\"object with 1 member\":[\"array with 1 element\"]}"}>>, + Q<<{"quotes": "" \u0022 %22 0x22 034 ""}>>, + Q<<{ "\/\\\"\uCAFE\uBABE\uAB98\uFCDE\ubcda\uef4A\b\f\n\r\t`1~!@#$%^&*()_+-=[]{}|;:',./<>?" +: "A key can be any string" + }>>, + Q<<[ 0.5 ,98.6 +, +99.44 +, + +1066, +1e1, +0.1e1 + ]>>, + Q<<[1e-1]>>, + Q<<[1e00,2e+00,2e-00,"rosebud"]>>, + Q<<[[[[[[[[[[[[[[[[[[["Not too deep"]]]]]]]]]]]]]]]]]]]>>, + Q<<{ + "JSON Test Pattern pass3": { + "The outermost value": "must be an object or array.", + "In this test": "It is an object." + } +} +>>, +# from http://www.json.org/example.html + Q<<{ + "glossary": { + "title": "example glossary", + "GlossDiv": { + "title": "S", + "GlossList": { + "GlossEntry": { + "ID": "SGML", + "SortAs": "SGML", + "GlossTerm": "Standard Generalized Markup Language", + "Acronym": "SGML", + "Abbrev": "ISO 8879:1986", + "GlossDef": { + "para": "A meta-markup language, used to create markup languages such as DocBook.", + "GlossSeeAlso": ["GML", "XML"] + }, + "GlossSee": "markup" + } + } + } + } +} + >>, + Q<<{"menu": { + "id": "file", + "value": "File", + "popup": { + "menuitem": [ + {"value": "New", "onclick": "CreateNewDoc()"}, + {"value": "Open", "onclick": "OpenDoc()"}, + {"value": "Close", "onclick": "CloseDoc()"} + ] + } +}}>>, + Q<<{"widget": { + "debug": "on", + "window": { + "title": "Sample Konfabulator Widget", + "name": "main_window", + "width": 500, + "height": 500 + }, + "image": { + "src": "Images/Sun.png", + "name": "sun1", + "hOffset": 250, + "vOffset": 250, + "alignment": "center" + }, + "text": { + "data": "Click Here", + "size": 36, + "style": "bold", + "name": "text1", + "hOffset": 250, + "vOffset": 100, + "alignment": "center", + "onMouseUp": "sun1.opacity = (sun1.opacity / 100) * 90;" + } +}}>>, + ; + +my @n = + '{ ', + '{ 3 : 4 }', + '{ 3 : tru }', # not quite true + '{ "a : false }', # missing quote + # stolen from JSON::XS, 18_json_checker.t + Q<<"A JSON payload should be an object or array, not a string.">>, + Q<<{"Extra value after close": true} "misplaced quoted value">>, + Q<<{"Illegal expression": 1 + 2}>>, + Q<<{"Illegal invocation": alert()}>>, + Q<<{"Numbers cannot have leading zeroes": 013}>>, + Q<<{"Numbers cannot be hex": 0x14}>>, + Q<<["Illegal backslash escape: \x15"]>>, + Q<<[\naked]>>, + Q<<["Illegal backslash escape: \017"]>>, +# skipped: wo don't implement no stinkin' aritifical limits. +# Q<<[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[["Too deep"]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]>>, + Q<<{"Missing colon" null}>>, + Q<<["Unclosed array">>, + Q<<{"Double colon":: null}>>, + Q<<{"Comma instead of colon", null}>>, + Q<<["Colon instead of comma": false]>>, + Q<<["Bad value", truth]>>, + Q<<['single quote']>>, + qq<["\ttab\tcharacter in string "]>, + Q<<["line +break"]>>, + Q<<["line\ +break"]>>, + Q<<[0e]>>, + Q<<{unquoted_key: "keys must be quoted"}>>, + Q<<[0e+]>>, + Q<<[0e+-1]>>, + Q<<{"Comma instead if closing brace": true,>>, + Q<<["mismatch"}>>, + Q<<["extra comma",]>>, + Q<<["double extra comma",,]>>, + Q<<[ , "<-- missing value"]>>, + Q<<["Comma after the close"],>>, + Q<<["Extra close"]]>>, + Q<<{"Extra comma": true,}>>, +; + +plan (+@t) + (+@n); + +my $i = 0; +for @t -> $t { + my $desc = $t; + if $desc ~~ m/\n/ { + $desc .= subst(/\n.*$/, "\\n...[$i]"); + } + my $parsed = 0; + try { + JSON::Tiny::Grammar.parse($t) + and $parsed = 1; + } + ok $parsed, "JSON string «$desc» parsed"; + $i++; +} + +for @n -> $t { + my $desc = $t; + if $desc ~~ m/\n/ { + $desc .= subst(/\n.*$/, "\\n...[$i]"); + } + my $parsed = 0; + try { JSON::Tiny::Grammar.parse($t) and $parsed = 1 }; + nok $parsed, "NOT parsed «$desc»"; + $i++; +} + + +# vim: ft=perl6 + diff --git a/samples/Perl6/A.pm b/samples/Perl6/A.pm new file mode 100644 index 0000000000..345e889b63 --- /dev/null +++ b/samples/Perl6/A.pm @@ -0,0 +1,9 @@ +# used in t/spec/S11-modules/nested.t + +BEGIN { @*INC.push('t/spec/packages') }; + +module A::A { + use A::B; +} + +# vim: ft=perl6 diff --git a/samples/Perl6/ANSIColor.pm b/samples/Perl6/ANSIColor.pm new file mode 100644 index 0000000000..87e557cb46 --- /dev/null +++ b/samples/Perl6/ANSIColor.pm @@ -0,0 +1,148 @@ +use v6; + +module Term::ANSIColor; + +# these will be macros one day, yet macros can't be exported so far +sub RESET is export { "\e[0m" } +sub BOLD is export { "\e[1m" } +sub UNDERLINE is export { "\e[4m" } +sub INVERSE is export { "\e[7m" } +sub BOLD_OFF is export { "\e[22m" } +sub UNDERLINE_OFF is export { "\e[24m" } +sub INVERSE_OFF is export { "\e[27m" } + +my %attrs = + reset => "0", + bold => "1", + underline => "4", + inverse => "7", + black => "30", + red => "31", + green => "32", + yellow => "33", + blue => "34", + magenta => "35", + cyan => "36", + white => "37", + default => "39", + on_black => "40", + on_red => "41", + on_green => "42", + on_yellow => "43", + on_blue => "44", + on_magenta => "45", + on_cyan => "46", + on_white => "47", + on_default => "49"; + +sub color (Str $what) is export { + my @res; + my @a = $what.split(' '); + for @a -> $attr { + if %attrs.exists($attr) { + @res.push: %attrs{$attr} + } else { + die("Invalid attribute name '$attr'") + } + } + return "\e[" ~ @res.join(';') ~ "m"; +} + +sub colored (Str $what, Str $how) is export { + color($how) ~ $what ~ color('reset'); +} + +sub colorvalid (*@a) is export { + for @a -> $el { + return False unless %attrs.exists($el) + } + return True; +} + +sub colorstrip (*@a) is export { + my @res; + for @a -> $str { + @res.push: $str.subst(/\e\[ <[0..9;]>+ m/, '', :g); + } + return @res.join; +} + +sub uncolor (Str $what) is export { + my @res; + my @list = $what.comb(/\d+/); + for @list -> $elem { + if %attrs.reverse.exists($elem) { + @res.push: %attrs.reverse{$elem} + } else { + die("Bad escape sequence: {'\e[' ~ $elem ~ 'm'}") + } + } + return @res.join(' '); +} + +=begin pod + +=head1 NAME + +Term::ANSIColor - Color screen output using ANSI escape sequences + +=head1 SYNOPSIS + + use Term::ANSIColor; + say color('bold'), "this is in bold", color('reset'); + say colored('underline red on_green', 'what a lovely colours!'); + say BOLD, 'good to be fat!', BOLD_OFF; + say 'ok' if colorvalid('magenta', 'on_black', 'inverse'); + say '\e[36m is ', uncolor('\e36m'); + say colorstrip("\e[1mThis is bold\e[0m"); + +=head1 DESCRIPTION + +Term::ANSIColor provides an interface for using colored output +in terminals. The following functions are available: + +=head2 C + +Given a string with color names, the output produced by C +sets the terminal output so the text printed after it will be colored +as specified. The following color names are recognised: + + reset bold underline inverse black red green yellow blue + magenta cyan white default on_black on_red on_green on_yellow + on_blue on_magenta on_cyan on_white on_default + +The on_* family of colors correspond to the background colors. + +=head2 C + +C is similar to C. It takes two Str arguments, +where the first is the colors to be used, and the second is the string +to be colored. The C sequence is automagically placed after +the string. + +=head2 C + +C gets an array of color specifications (like those +passed to C) and returns true if all of them are valid, +false otherwise. + +=head2 C + +C, given a string, removes all the escape sequences +in it, leaving the plain text without effects. + +=head2 C + +Given escape sequences, C returns a string with readable +color names. E.g. passing "\e[36;44m" will result in "cyan on_blue". + +=head1 Constants + +C provides constants which are just strings of +appropriate escape sequences. The following constants are available: + + RESET BOLD UNDERLINE INVERSE BOLD_OFF UNDERLINE_OFF INVERSE_OFF + +=end pod + +# vim: ft=perl6 diff --git a/samples/Perl6/Bailador.pm b/samples/Perl6/Bailador.pm new file mode 100644 index 0000000000..96e4d8d11c --- /dev/null +++ b/samples/Perl6/Bailador.pm @@ -0,0 +1,102 @@ +use Bailador::App; +use Bailador::Request; +use Bailador::Response; +use Bailador::Context; +use HTTP::Easy::PSGI; + +module Bailador; + +my $app = Bailador::App.current; + +our sub import { + my $file = callframe(1).file; + my $slash = $file.rindex('/'); + if $slash { + $app.location = $file.substr(0, $file.rindex('/')); + } else { + $app.location = '.'; + } +} + +sub route_to_regex($route) { + $route.split('/').map({ + my $r = $_; + if $_.substr(0, 1) eq ':' { + $r = q{(<-[\/\.]>+)}; + } + $r + }).join("'/'"); +} + +multi parse_route(Str $route) { + my $r = route_to_regex($route); + return "/ ^ $r \$ /".eval; +} + +multi parse_route($route) { + # do nothing + $route +} + +sub get(Pair $x) is export { + my $p = parse_route($x.key) => $x.value; + $app.add_route: 'GET', $p; + return $x; +} + +sub post(Pair $x) is export { + my $p = parse_route($x.key) => $x.value; + $app.add_route: 'POST', $p; + return $x; +} + +sub request is export { $app.context.request } + +sub content_type(Str $type) is export { + $app.response.headers = $type; +} + +sub header(Str $name, Cool $value) is export { + $app.response.headers{$name} = ~$value; +} + +sub status(Int $code) is export { + $app.response.code = $code; +} + +sub template(Str $tmpl, *@params) is export { + $app.template($tmpl, @params); +} + +our sub dispatch_request(Bailador::Request $r) { + return dispatch($r.env); +} + +sub dispatch($env) { + $app.context.env = $env; + + my ($r, $match) = $app.find_route($env); + + if $r { + status 200; + if $match { + $app.response.content = $r.value.(|$match.list); + } else { + $app.response.content = $r.value.(); + } + } + + return $app.response; +} + +sub dispatch-psgi($env) { + return dispatch($env).psgi; +} + +sub baile is export { + given HTTP::Easy::PSGI.new(port => 3000) { + .app(&dispatch-psgi); + say "Entering the development dance floor: http://0.0.0.0:3000"; + .run; + } +} diff --git a/samples/Perl6/ContainsUnicode.pm b/samples/Perl6/ContainsUnicode.pm new file mode 100644 index 0000000000..1f3c25c76b --- /dev/null +++ b/samples/Perl6/ContainsUnicode.pm @@ -0,0 +1,7 @@ +module ContainsUnicode { + sub uc-and-join(*@things, :$separator = ', ') is export { + @things».uc.join($separator) + } +} + +# vim: ft=perl6 diff --git a/samples/Perl6/Exception.pm b/samples/Perl6/Exception.pm new file mode 100644 index 0000000000..480a8af9ff --- /dev/null +++ b/samples/Perl6/Exception.pm @@ -0,0 +1,1431 @@ +my class Failure { ... } +my role X::Comp { ... } +my class X::ControlFlow { ... } + +my class Exception { + has $!ex; + + method backtrace() { Backtrace.new(self) } + + multi method Str(Exception:D:) { + self.?message.Str // 'Something went wrong' + } + + multi method gist(Exception:D:) { + my $str = try self.?message; + return "Error while creating error string: $!" if $!; + $str ~= "\n"; + try $str ~= self.backtrace; + return "$str\nError while creating backtrace: $!.message()\n$!.backtrace.full();" if $!; + return $str; + } + + method throw() is hidden_from_backtrace { + nqp::bindattr(self, Exception, '$!ex', nqp::newexception()) + unless nqp::isconcrete($!ex); + nqp::setpayload($!ex, nqp::decont(self)); + my $msg := self.?message; + nqp::setmessage($!ex, nqp::unbox_s($msg.Str)) + if $msg.defined; + nqp::throw($!ex) + } + method rethrow() is hidden_from_backtrace { + nqp::setpayload($!ex, nqp::decont(self)); + nqp::rethrow($!ex) + } + + method resumable() { + nqp::p6bool(nqp::istrue(nqp::atkey($!ex, 'resume'))); + } + + method resume() { + my Mu $resume := nqp::atkey($!ex, 'resume'); + if $resume { + $resume(); + } + else { + die "Exception is not resumable"; + } + } + + method fail(Exception:D:) { + try self.throw; + my $fail := Failure.new($!); + my Mu $return := nqp::getlexcaller('RETURN'); + $return($fail) unless nqp::isnull($return); + $fail + } + + method is-compile-time { False } +} + +my class X::AdHoc is Exception { + has $.payload; + method message() { $.payload.Str } + method Numeric() { $.payload.Numeric } +} + +my class X::Method::NotFound is Exception { + has $.method; + has $.typename; + has Bool $.private = False; + method message() { + $.private + ?? "No such private method '$.method' for invocant of type '$.typename'" + !! "No such method '$.method' for invocant of type '$.typename'"; + } +} + +my class X::Method::InvalidQualifier is Exception { + has $.method; + has $.invocant; + has $.qualifier-type; + method message() { + "Cannot dispatch to method $.method on {$.qualifier-type.^name} " + ~ "because it is not inherited or done by {$.invocant.^name}"; + } +} + + +sub EXCEPTION(|) { + my Mu $vm_ex := nqp::shift(nqp::p6argvmarray()); + my Mu $payload := nqp::getpayload($vm_ex); + if nqp::p6bool(nqp::istype($payload, Exception)) { + nqp::bindattr($payload, Exception, '$!ex', $vm_ex); + $payload; + } else { + my int $type = nqp::getextype($vm_ex); + my $ex; +#?if parrot + if $type == pir::const::EXCEPTION_METHOD_NOT_FOUND && +#?endif +#?if !parrot + if +#?endif + nqp::p6box_s(nqp::getmessage($vm_ex)) ~~ /"Method '" (.*?) "' not found for invocant of class '" (.+)\'$/ { + + $ex := X::Method::NotFound.new( + method => ~$0, + typename => ~$1, + ); + } + else { + + $ex := nqp::create(X::AdHoc); + nqp::bindattr($ex, X::AdHoc, '$!payload', nqp::p6box_s(nqp::getmessage($vm_ex))); + } + nqp::bindattr($ex, Exception, '$!ex', $vm_ex); + $ex; + } +} + +my class X::Comp::AdHoc { ... } +sub COMP_EXCEPTION(|) { + my Mu $vm_ex := nqp::shift(nqp::p6argvmarray()); + my Mu $payload := nqp::getpayload($vm_ex); + if nqp::p6bool(nqp::istype($payload, Exception)) { + nqp::bindattr($payload, Exception, '$!ex', $vm_ex); + $payload; + } else { + my $ex := nqp::create(X::Comp::AdHoc); + nqp::bindattr($ex, Exception, '$!ex', $vm_ex); + nqp::bindattr($ex, X::AdHoc, '$!payload', nqp::p6box_s(nqp::getmessage($vm_ex))); + $ex; + } +} + + +do { + sub is_runtime($bt) { + for $bt.keys { + try { + my Mu $sub := nqp::getattr(nqp::decont($bt[$_]), ForeignCode, '$!do'); + my Mu $codeobj := nqp::ifnull(nqp::getcodeobj($sub), Mu); + my $is_nqp = $codeobj && $codeobj.HOW.name($codeobj) eq 'NQPRoutine'; + return True if nqp::iseq_s(nqp::getcodename($sub), 'eval') && $is_nqp; + return False if nqp::iseq_s(nqp::getcodename($sub), 'compile') && $is_nqp; + } + } + return False; + } + + + sub print_exception(|) is hidden_from_backtrace { + my Mu $ex := nqp::atpos(nqp::p6argvmarray(), 0); + try { + my $e := EXCEPTION($ex); + my Mu $err := nqp::getstderr(); + +#?if parrot + if $e.is-compile-time || is_runtime($ex.backtrace) { +#?endif +#?if !parrot + if $e.is-compile-time || is_runtime(nqp::backtrace($ex)) { +#?endif + nqp::printfh($err, $e.gist); + nqp::printfh($err, "\n"); + } + else { + nqp::printfh($err, "===SORRY!===\n"); + nqp::printfh($err, $e.Str); + nqp::printfh($err, "\n"); + } + $_() for nqp::hllize(nqp::getcurhllsym('@END_PHASERS')); + } + if $! { +#?if parrot + pir::perl6_based_rethrow__0PP(nqp::getattr(nqp::decont($!), Exception, '$!ex'), $ex); +#?endif +#?if !parrot + nqp::rethrow(nqp::getattr(nqp::decont($!), Exception, '$!ex')); + $ex +#?endif + } + } + + sub print_control(|) is hidden_from_backtrace { + my Mu $ex := nqp::atpos(nqp::p6argvmarray(), 0); + my int $type = nqp::getextype($ex); + if ($type == nqp::const::CONTROL_WARN) { + my Mu $err := nqp::getstderr(); + my $msg = nqp::p6box_s(nqp::getmessage($ex)); + nqp::printfh($err, $msg ?? "$msg" !! "Warning"); +#?if parrot + nqp::printfh($err, Backtrace.new($ex.backtrace, 0).nice(:oneline)); +#?endif +#?if jvm +# XXX Backtraces busted +# nqp::printfh($err, Backtrace.new(nqp::backtrace($ex), 0).nice(:oneline)); +#?endif + nqp::printfh($err, "\n"); +#?if parrot + my $resume := nqp::atkey($ex, 'resume'); + if ($resume) { + $resume(); + } +#?endif +#?if !parrot + nqp::resume($ex) +#?endif + } + if ($type == nqp::const::CONTROL_LAST) { + X::ControlFlow.new(illegal => 'last', enclosing => 'loop construct').throw; + } + if ($type == nqp::const::CONTROL_NEXT) { + X::ControlFlow.new(illegal => 'next', enclosing => 'loop construct').throw; + } + if ($type == nqp::const::CONTROL_REDO) { + X::ControlFlow.new(illegal => 'redo', enclosing => 'loop construct').throw; + } + if ($type == nqp::const::CONTROL_PROCEED) { + X::ControlFlow.new(illegal => 'proceed', enclosing => 'when clause').throw; + } + if ($type == nqp::const::CONTROL_SUCCEED) { + # XXX: should work like leave() ? + X::ControlFlow.new(illegal => 'succeed', enclosing => 'when clause').throw; + } + if ($type == nqp::const::CONTROL_TAKE) { + X::ControlFlow.new(illegal => 'take', enclosing => 'gather').throw; + } + } + + my Mu $comp := nqp::getcomp('perl6'); + $comp.HOW.add_method($comp, 'handle-exception', + method (|) { + my Mu $ex := nqp::atpos(nqp::p6argvmarray(), 1); +#?if parrot + pir::perl6_invoke_catchhandler__vPP(&print_exception, $ex); +#?endif +#?if !parrot + print_exception($ex); +#?endif + nqp::exit(1); + 0; + } + ); + $comp.HOW.add_method($comp, 'handle-control', + method (|) { + my Mu $ex := nqp::atpos(nqp::p6argvmarray(), 1); +#?if parrot + pir::perl6_invoke_catchhandler__vPP(&print_control, $ex); +#?endif +#?if !parrot + print_control($ex); +#?endif + nqp::rethrow($ex); + } + ); + +} + +my role X::OS { + has $.os-error; +} + +my role X::IO does X::OS { }; + +my class X::IO::Rename does X::IO is Exception { + has $.from; + has $.to; + method message() { + "Failed to rename '$.from' to '$.to': $.os-error" + } +} + +my class X::IO::Copy does X::IO is Exception { + has $.from; + has $.to; + method message() { + "Failed to copy '$.from' to '$.to': $.os-error" + } +} + +my class X::IO::Symlink does X::IO is Exception { + has $.target; + has $.name; + method message() { + "Failed to create symlink called '$.name' on target '$.target': $.os-error" + } +} + +my class X::IO::Link does X::IO is Exception { + has $.target; + has $.name; + method message() { + "Failed to create link called '$.name' on target '$.target': $.os-error" + } +} + +my class X::IO::Mkdir does X::IO is Exception { + has $.path; + has $.mode; + method message() { + "Failed to create directory '$.path' with mode '0o{$.mode.fmt("%03o")}': $.os-error" + } +} + +my class X::IO::Chdir does X::IO is Exception { + has $.path; + method message() { + "Failed to change the working directory to '$.path': $.os-error" + } +} + +my class X::IO::Dir does X::IO is Exception { + has $.path; + method message() { + "Failed to get the directory contents of '$.path': $.os-error" + } +} + +my class X::IO::Cwd does X::IO is Exception { + method message() { + "Failed to get the working directory: $.os-error" + } +} + +my class X::IO::Rmdir does X::IO is Exception { + has $.path; + method message() { + "Failed to remove the directory '$.path': $.os-error" + } +} + +my class X::IO::Unlink does X::IO is Exception { + has $.path; + method message() { + "Failed to remove the file '$.path': $.os-error" + } +} + +my class X::IO::Chmod does X::IO is Exception { + has $.path; + has $.mode; + method message() { + "Failed to set the mode of '$.path' to '0o{$.mode.fmt("%03o")}': $.os-error" + } +} + +my role X::Comp is Exception { + has $.filename; + has $.line; + has $.column; + has @.modules; + has $.is-compile-time = False; + has $.pre; + has $.post; + has @.highexpect; + multi method gist(::?CLASS:D: :$sorry = True, :$expect = True) { + if $.is-compile-time { + my $color = %*ENV // $*OS ne 'MSWin32'; + my ($red, $green, $yellow, $clear) = $color + ?? ("\e[31m", "\e[32m", "\e[33m", "\e[0m") + !! ("", "", "", ""); + my $eject = $*OS eq 'MSWin32' ?? "" !! "\x[23CF]"; + my $r = $sorry ?? self.sorry_heading() !! ""; + $r ~= "$.message\nat $.filename():$.line\n------> "; + $r ~= "$green$.pre$yellow$eject$red$.post$clear" if defined $.pre; + if $expect && @.highexpect { + $r ~= "\n expecting any of:"; + for @.highexpect { + $r ~= "\n $_"; + } + } + for @.modules.reverse[1..*] { + $r ~= $_.defined + ?? "\n from module $_ ($_:$_)" + !! "\n from $_:$_"; + } + $r; + } + else { + self.Exception::gist; + } + } + method sorry_heading() { + my $color = %*ENV // $*OS ne 'MSWin32'; + my ($red, $clear) = $color ?? ("\e[31m", "\e[0m") !! ("", ""); + "$red==={$clear}SORRY!$red===$clear Error while compiling $.filename\n" + } + method SET_FILE_LINE($file, $line) { + $!filename = $file; + $!line = $line; + $!is-compile-time = True; + } +} + +my class X::Comp::Group is Exception { + has $.panic; + has @.sorrows; + has @.worries; + + method is-compile-time() { True } + + multi method gist(::?CLASS:D:) { + my $r = ""; + if $.panic || @.sorrows { + my $color = %*ENV // $*OS ne 'MSWin32'; + my ($red, $clear) = $color ?? ("\e[31m", "\e[0m") !! ("", ""); + $r ~= "$red==={$clear}SORRY!$red===$clear\n"; + for @.sorrows { + $r ~= .gist(:!sorry, :!expect) ~ "\n"; + } + if $.panic { + $r ~= $.panic.gist(:!sorry) ~ "\n"; + } + } + if @.worries { + $r ~= $.panic || @.sorrows + ?? "Other potential difficulties:\n" + !! "Potential difficulties:\n"; + for @.worries { + $r ~= .gist(:!sorry, :!expect).indent(4) ~ "\n"; + } + } + $r + } + + method message() { + my @m; + for @.sorrows { + @m.push(.message); + } + if $.panic { + @m.push($.panic.message); + } + for @.worries { + @m.push(.message); + } + @m.join("\n") + } +} + +# XXX a hack for getting line numbers from exceptions from the metamodel +my class X::Comp::AdHoc is X::AdHoc does X::Comp { + method is-compile-time() { True } +} + +my role X::Syntax does X::Comp { } +my role X::Pod { } + +my class X::NYI is Exception { + has $.feature; + method message() { "$.feature not yet implemented. Sorry. " } +} +my class X::Comp::NYI is X::NYI does X::Comp { }; + +my class X::Trait::Unknown is Exception { + has $.type; # is, will, of etc. + has $.subtype; # wrong subtype being tried + has $.declaring; # variable, sub, parameter, etc. + method message () { + "Can't use unknown trait '$.type $.subtype' in a$.declaring declaration." + } +} +my class X::Comp::Trait::Unknown is X::Trait::Unknown does X::Comp { }; + +my class X::Trait::NotOnNative is Exception { + has $.type; # is, will, of etc. + has $.subtype; # wrong subtype being tried + has $.native; # type of native (optional) + method message () { + "Can't use trait '$.type $.subtype' on a native" + ~ ( $.native ?? " $.native." !! "." ); + } +} +my class X::Comp::Trait::NotOnNative is X::Trait::NotOnNative does X::Comp { }; + +my class X::OutOfRange is Exception { + has $.what = 'Argument'; + has $.got = ''; + has $.range = ''; + has $.comment; + method message() { + $.comment.defined + ?? "$.what out of range. Is: $.got, should be in $.range.gist(); $.comment" + !! "$.what out of range. Is: $.got, should be in $.range.gist()" + } +} + +my class X::Buf::AsStr is Exception { + has $.method; + method message() { + "Cannot use a Buf as a string, but you called the $.method method on it"; + } +} +my class X::Buf::Pack is Exception { + has $.directive; + method message() { + "Unrecognized directive '$.directive'"; + } +} + +my class X::Buf::Pack::NonASCII is Exception { + has $.char; + method message() { + "non-ASCII character '$.char' while processing an 'A' template in pack"; + } +} + +my class X::Signature::Placeholder does X::Comp { + has $.placeholder; + method message() { + "Placeholder variable '$.placeholder' cannot override existing signature"; + } +} + +my class X::Placeholder::Block does X::Comp { + has $.placeholder; + method message() { + "Placeholder variable $.placeholder may not be used here because the surrounding block takes no signature"; + } +} + +my class X::Placeholder::Mainline is X::Placeholder::Block { + method message() { + "Cannot use placeholder parameter $.placeholder in the mainline" + } +} + +my class X::Undeclared does X::Comp { + has $.what = 'Variable'; + has $.symbol; + has @.suggestions; + method message() { + my $message := "$.what '$.symbol' is not declared"; + if +@.suggestions == 1 { + $message := "$message. Did you mean '@.suggestions[0]'?"; + } elsif +@.suggestions > 1 { + $message := "$message. Did you mean any of these?\n { @.suggestions.join("\n ") }\n"; + } + $message; + } +} + +my class X::Attribute::Undeclared is X::Undeclared { + has $.package-kind; + has $.package-name; + + method message() { + "Attribute $.symbol not declared in $.package-kind $.package-name"; + } +} + +my class X::Undeclared::Symbols does X::Comp { + has %.post_types; + has %.unk_types; + has %.unk_routines; + has %.routine_suggestion; + has %.type_suggestion; + multi method gist(:$sorry = True) { + ($sorry ?? self.sorry_heading() !! "") ~ self.message + } + method message() { + sub l(@l) { + my @lu = @l.map({ nqp::hllize($_) }).uniq.sort; + 'used at line' ~ (@lu == 1 ?? ' ' !! 's ') ~ @lu.join(', ') + } + sub s(@s) { + "Did you mean '{ @s.join("', '") }'?"; + } + my $r = ""; + if %.post_types { + $r ~= "Illegally post-declared type" ~ (%.post_types.elems == 1 ?? "" !! "s") ~ ":\n"; + for %.post_types.sort(*.key) { + $r ~= " $_.key() &l($_.value)\n"; + } + } + if %.unk_types { + $r ~= "Undeclared name" ~ (%.unk_types.elems == 1 ?? "" !! "s") ~ ":\n"; + for %.unk_types.sort(*.key) { + $r ~= " $_.key() &l($_.value)"; + if +%.type_suggestion{$_.key()} { + $r ~= ". " ~ s(%.type_suggestion{$_.key()}); + } + $r ~= "\n"; + } + } + if %.unk_routines { + $r ~= "Undeclared routine" ~ (%.unk_routines.elems == 1 ?? "" !! "s") ~ ":\n"; + for %.unk_routines.sort(*.key) { + $r ~= " $_.key() &l($_.value)"; + if +%.routine_suggestion{$_.key()} { + $r ~= ". " ~ s(%.routine_suggestion{$_.key()}); + } + $r ~= "\n"; + } + } + $r + } +} + +my class X::Redeclaration does X::Comp { + has $.symbol; + has $.postfix = ''; + has $.what = 'symbol'; + method message() { + "Redeclaration of $.what $.symbol$.postfix"; + } +} + +my class X::Redeclaration::Outer does X::Comp { + has $.symbol; + method message() { + "Lexical symbol '$.symbol' is already bound to an outer symbol;\n" ~ + "the implicit outer binding must be rewritten as OUTER::<$.symbol>\n" ~ + "before you can unambiguously declare a new '$.symbol' in this scope"; + } +} + +my class X::Import::Redeclaration does X::Comp { + has @.symbols; + has $.source-package-name; + method message() { + @.symbols == 1 + ?? "Cannot import symbol @.symbols[0] from $.source-package-name, because it already exists in this lexical scope" + !! ("Cannot import the following symbols from $.source-package-name, because they already exist in this lexical scope: ", @.symbols.join(', ')); + } +} + +my class X::Import::OnlystarProto does X::Comp { + has @.symbols; + has $.source-package-name; + method message() { + @.symbols == 1 + ?? "Cannot import symbol @.symbols[0] from $.source-package-name, only onlystar-protos can be merged" + !! ("Cannot import the following symbols from $.source-package-name, only onlystar-protos can be merged: ", @.symbols.join(', ')); + } +} + +my class X::Phaser::Multiple does X::Comp { + has $.block; + method message() { "Only one $.block block is allowed" } +} + +my class X::Obsolete does X::Comp { + has $.old; + has $.replacement; # can't call it $.new, collides with constructor + has $.when = 'in Perl 6'; + method message() { "Unsupported use of $.old; $.when please use $.replacement" } +} + +my class X::Parameter::Default does X::Comp { + has $.how; + has $.parameter; + method message() { + $.parameter + ?? "Cannot put default on $.how parameter $.parameter" + !! "Cannot put default on anonymous $.how parameter"; + } +} + +my class X::Parameter::Placeholder does X::Comp { + has $.parameter; + has $.right; + method message() { + "In signature parameter, placeholder variables like $.parameter are illegal\n" + ~ "you probably meant a named parameter: '$.right'"; + } +} + +my class X::Parameter::Twigil does X::Comp { + has $.parameter; + has $.twigil; + method message() { + "In signature parameter $.parameter, it is illegal to use the $.twigil twigil"; + } +} + +my class X::Parameter::MultipleTypeConstraints does X::Comp { + has $.parameter; + method message() { + ($.parameter ?? "Parameter $.parameter" !! 'A parameter') + ~ " may only have one prefix type constraint"; + } +} + +my class X::Parameter::WrongOrder does X::Comp { + has $.misplaced; + has $.parameter; + has $.after; + method message() { + "Cannot put $.misplaced parameter $.parameter after $.after parameters"; + } +} + +my class X::Parameter::InvalidType does X::Comp { + has $.typename; + has @.suggestions; + method message() { + my $msg := "Invalid typename '$.typename' in parameter declaration."; + if +@.suggestions > 0 { + $msg := $msg ~ " Did you mean '" ~ @.suggestions.join("', '") ~ "'?"; + } + return $msg; + } +} + +my class X::Signature::NameClash does X::Comp { + has $.name; + method message() { + "Name $.name used for more than one named parameter"; + } +} + +my class X::Method::Private::Permission does X::Comp { + has $.method; + has $.source-package; + has $.calling-package; + method message() { + "Cannot call private method '$.method' on package $.source-package because it does not trust $.calling-package"; + } +} + +my class X::Method::Private::Unqualified does X::Comp { + has $.method; + method message() { + "Private method call to $.method must be fully qualified with the package containing the method"; + } +} + +my class X::Bind is Exception { + has $.target; + method message() { + $.target.defined + ?? "Cannot bind to $.target" + !! 'Cannot use bind operator with this left-hand side' + } +} +my class X::Bind::NativeType does X::Comp { + has $.name; + method message() { + "Cannot bind to natively typed variable '$.name'; use assignment instead" + } +} +my class X::Bind::Slice is Exception { + has $.type; + method message() { + "Cannot bind to {$.type.^name} slice"; + } +} +my class X::Bind::ZenSlice is X::Bind::Slice { + method message() { + "Cannot bind to {$.type.^name} zen slice"; + } +} + +my class X::Value::Dynamic does X::Comp { + has $.what; + method message() { "$.what value must be known at compile time" } +} + +my class X::Syntax::Name::Null does X::Syntax { + method message() { 'Name component may not be null'; } +} + +my class X::Syntax::UnlessElse does X::Syntax { + method message() { '"unless" does not take "else", please rewrite using "if"' } +} + +my class X::Syntax::KeywordAsFunction does X::Syntax { + has $.word; + has $.needparens; + method message { + "Word '$.word' interpreted as '{$.word}()' function call; please use whitespace " + ~ ($.needparens ?? 'around the parens' !! 'instead of parens') + } +} + +my class X::Syntax::Malformed::Elsif does X::Syntax { + has $.what = 'else if'; + method message() { qq{In Perl 6, please use "elsif' instead of "$.what"} } +} + +my class X::Syntax::Reserved does X::Syntax { + has $.reserved; + has $.instead = ''; + method message() { "The $.reserved is reserved$.instead" } +} + +my class X::Syntax::P5 does X::Syntax { + method message() { 'This appears to be Perl 5 code' } +} + +my class X::Syntax::NegatedPair does X::Syntax { + has $.key; + method message() { "Argument not allowed on negated pair with key '$.key'" } +} + +my class X::Syntax::Variable::Numeric does X::Syntax { + has $.what = 'variable'; + method message() { "Cannot declare a numeric $.what" } +} + +my class X::Syntax::Variable::Match does X::Syntax { + method message() { 'Cannot declare a match variable' } +} + +my class X::Syntax::Variable::Twigil does X::Syntax { + has $.twigil; + has $.scope; + method message() { "Cannot use $.twigil twigil on $.scope variable" } +} + +my class X::Syntax::Variable::IndirectDeclaration does X::Syntax { + method message() { 'Cannot declare a variable by indirect name (use a hash instead?)' } +} + +my class X::Syntax::Augment::WithoutMonkeyTyping does X::Syntax { + method message() { "augment not allowed without 'use MONKEY_TYPING'" }; +} + +my class X::Syntax::Augment::Illegal does X::Syntax { + has $.package; + method message() { "Cannot augment $.package because it is closed" }; +} + +my class X::Syntax::Argument::MOPMacro does X::Syntax { + has $.macro; + method message() { "Cannot give arguments to $.macro" }; +} + +my class X::Does::TypeObject is Exception { + method message() { "Cannot use 'does' operator with a type object." } +} + +my class X::Role::Initialization is Exception { + has $.role; + method message() { "Can only supply an initialization value for a role if it has a single public attribute, but this is not the case for '{$.role.^name}'" } +} + +my class X::Syntax::Comment::Embedded does X::Syntax { + method message() { "Opening bracket required for #` comment" } +} + +my class X::Syntax::Pod::BeginWithoutIdentifier does X::Syntax does X::Pod { + method message() { + '=begin must be followed by an identifier; (did you mean "=begin pod"?)' + } +} + +my class X::Syntax::Pod::BeginWithoutEnd does X::Syntax does X::Pod { + method message() { '=begin without matching =end' } +} + +my class X::Syntax::Confused does X::Syntax { + has $.reason = 'unknown'; + method message() { $.reason eq 'unknown' ?? 'Confused' !! $.reason } +} + +my class X::Syntax::Malformed does X::Syntax { + has $.what; + method message() { "Malformed $.what" } +} +my class X::Syntax::Missing does X::Syntax { + has $.what; + method message() { "Missing $.what" } +} + +my class X::Syntax::Perl5Var does X::Syntax { + has $.name; + my %m = + '$*' => '^^ and $$', + '$"' => '.join() method', + '$$' => '$*PID', + '$(' => '$*GID', + '$)' => '$*EGID', + '$<' => '$*UID', + '$>' => '$*EUID', + '$;' => 'real multidimensional hashes', + '$&' => '$<>', + '$`' => 'explicit pattern before <(', + '$\'' => 'explicit pattern after )>', + '$,' => '$*OUT.output_field_separator()', + '$.' => "the filehandle's .line method", + '$\\' => "the filehandle's .ors attribute", + '$|' => ':autoflush on open', + '$?' => '$! for handling child errors also', + '$@' => '$!', + '$#' => '.fmt', + '$[' => 'user-defined array indices', + '$]' => '$*PERL_VERSION', + + '$^C' => 'COMPILING namespace', + '$^D' => '$*DEBUGGING', + '$^E' => '$!.extended_os_error', + '$^F' => '$*SYSTEM_FD_MAX', + '$^H' => '$?FOO variables', + '$^I' => '$*INPLACE', + '$^M' => 'a global form such as $*M', + '$^N' => '$/[*-1]', + '$^O' => '$?OS or $*OS', + '$^R' => 'an explicit result variable', + '$^S' => 'context function', + '$^T' => '$*BASETIME', + '$^V' => '$*PERL_VERSION', + '$^W' => '$*WARNING', + '$^X' => '$*EXECUTABLE_NAME', + + '$:' => 'Form module', + '$-' => 'Form module', + '$+' => 'Form module', + '$=' => 'Form module', + '$%' => 'Form module', + '$^' => 'Form module', + '$~' => 'Form module', + '$^A' => 'Form module', + '$^L' => 'Form module', + + '@-' => '.from method', + '@+' => '.to method', + + '%-' => '.from method', + '%+' => '.to method', + '%^H' => '$?FOO variables', + ; + method message() { + my $v = $.name ~~ m/ <[ $ @ % & ]> [ \^ <[ A..Z ]> | \W ] /; + $v + ?? %m{~$v} + ?? "Unsupported use of $v variable; in Perl 6 please use {%m{~$v}}" + !! "Unsupported use of $v variable" + !! 'Non-declarative sigil is missing its name'; + } +} + +my class X::Syntax::Self::WithoutObject does X::Syntax { + method message() { "'self' used where no object is available" } +} +my class X::Syntax::VirtualCall does X::Syntax { + has $.call; + method message() { "Virtual call $.call may not be used on partially constructed objects" } +} +my class X::Syntax::NoSelf does X::Syntax { + has $.variable; + method message() { "Variable $.variable used where no 'self' is available" } +} + +my class X::Syntax::Number::RadixOutOfRange does X::Syntax { + has $.radix; + method message() { "Radix $.radix out of range (allowed: 2..36)" } +} + +my class X::Syntax::NonAssociative does X::Syntax { + has $.left; + has $.right; + method message() { + "Operators '$.left' and '$.right' are non-associative and require parenthesis"; + } +} + +my class X::Syntax::Regex::Adverb does X::Syntax { + has $.adverb; + has $.construct; + method message() { "Adverb $.adverb not allowed on $.construct" } +} + +my class X::Syntax::Regex::UnrecognizedMetachar does X::Syntax { + has $.metachar; + method message() { "Unrecognized regex metacharacter $.metachar (must be quoted to match literally)" } +} + +my class X::Syntax::Regex::NullRegex does X::Syntax { + method message() { 'Null regex not allowed' } +} + +my class X::Syntax::Signature::InvocantMarker does X::Syntax { + method message() { + "Can only use : as invocant marker in a signature after the first parameter" + } +} + +my class X::Syntax::Extension::Category does X::Syntax { + has $.category; + method message() { + "Cannot add tokens of category '$.category'"; + } +} + +my class X::Syntax::Extension::Null does X::Syntax { + method message() { + "Null operator is not allowed"; + } +} + +my class X::Syntax::InfixInTermPosition does X::Syntax { + has $.infix; + method message() { + "Preceding context expects a term, but found infix $.infix instead"; + } +} + +my class X::Attribute::Package does X::Comp { + has $.package-kind; + has $.name; + method message() { "A $.package-kind cannot have attributes, but you tried to declare '$.name'" } +} +my class X::Attribute::NoPackage does X::Comp { + has $.name; + method message() { "You cannot declare attribute '$.name' here; maybe you'd like a class or a role?" } +} +my class X::Declaration::Scope does X::Comp { + has $.scope; + has $.declaration; + method message() { "Cannot use '$.scope' with $.declaration declaration" } +} + +my class X::Declaration::Scope::Multi is X::Declaration::Scope { + method message() { + "Cannot use '$.scope' with individual multi candidates. Please declare an {$.scope}-scoped proto instead"; + } +} + +my class X::Anon::Multi does X::Comp { + has $.multiness; + has $.routine-type = 'routine'; + method message() { "Cannot put $.multiness on anonymous $.routine-type" } +} +my class X::Anon::Augment does X::Comp { + has $.package-kind; + method message() { "Cannot augment anonymous $.package-kind" } +} +my class X::Augment::NoSuchType does X::Comp { + has $.package-kind; + has $.package; + method message() { "You tried to augment $.package-kind $.package, but it does not exist" } +} + +my class X::Routine::Unwrap is Exception { + method message() { "Cannot unwrap routine: invalid wrap handle" } +} + +my class X::Constructor::Positional is Exception { + has $.type; + method message() { "Default constructor for '" ~ $.type.^name ~ "' only takes named arguments" } +} + +my class X::Hash::Store::OddNumber is Exception { + method message() { "Odd number of elements found where hash expected" } +} + +my class X::Package::Stubbed does X::Comp { + has @.packages; + # TODO: suppress display of line number + method message() { + "The following packages were stubbed but not defined:\n " + ~ @.packages.join("\n "); + } +} + +my class X::Phaser::PrePost is Exception { + has $.phaser = 'PRE'; + has $.condition; + method message { + my $what = $.phaser eq 'PRE' ?? 'Precondition' !! 'Postcondition'; + $.condition.defined + ?? "$what '$.condition.trim()' failed" + !! "$what failed"; + } +} + +my class X::Str::Numeric is Exception { + has $.source; + has $.pos; + has $.reason; + method source-indicator { + constant marker = chr(0x23CF); + join '', "in '", + $.source.substr(0, $.pos), + marker, + $.source.substr($.pos), + "' (indicated by ", + marker, + ")", + ; + } + method message() { + "Cannot convert string to number: $.reason $.source-indicator"; + } +} + +my class X::Str::Match::x is Exception { + has $.got; + method message() { + "in Str.match, got invalid value of type {$.got.^name} for :x, must be Int or Range" + } +} + +my class X::Str::Trans::IllegalKey is Exception { + has $.key; + method message { + "in Str.trans, got illegal substitution key of type {$.key.^name} (should be a Regex or Str)" + } +} +my class X::Str::Trans::InvalidArg is Exception { + has $.got; + method message() { + "Only Pair objects are allowed as arguments to Str.trans, got {$.got.^name}"; + } +} + +my class X::Range::InvalidArg is Exception { + has $.got; + method message() { + "{$.got.^name} objects are not valid endpoints for Ranges"; + } +} + +my class X::Sequence::Deduction is Exception { + method message() { 'Unable to deduce sequence' } +} + +my class X::Backslash::UnrecognizedSequence does X::Syntax { + has $.sequence; + method message() { "Unrecognized backslash sequence: '\\$.sequence'" } +} + +my class X::Backslash::NonVariableDollar does X::Syntax { + method message() { "Non-variable \$ must be backslashed" } +} + +my class X::ControlFlow is Exception { + has $.illegal; # something like 'next' + has $.enclosing; # .... outside a loop + + method message() { "$.illegal without $.enclosing" } +} +my class X::ControlFlow::Return is X::ControlFlow { + method illegal() { 'return' } + method enclosing() { 'Routine' } + method message() { 'Attempt to return outside of any Routine' } +} + +my class X::Composition::NotComposable does X::Comp { + has $.target-name; + has $.composer; + method message() { + $.composer.^name ~ " is not composable, so $.target-name cannot compose it"; + } +} + +my class X::TypeCheck is Exception { + has $.operation; + has $.got; + has $.expected; + method message() { + "Type check failed in $.operation; expected '{$.expected.^name}' but got '{$.got.^name}'"; + + } +} + +my class X::TypeCheck::Binding is X::TypeCheck { + method operation { 'binding' } +} +my class X::TypeCheck::Return is X::TypeCheck { + method operation { 'returning' } + method message() { + "Type check failed for return value; expected '{$.expected.^name}' but got '{$.got.^name}'"; + } +} +my class X::TypeCheck::Assignment is X::TypeCheck { + has $.symbol; + method operation { 'assignment' } + method message { + $.symbol.defined + ?? "Type check failed in assignment to '$.symbol'; expected '{$.expected.^name}' but got '{$.got.^name}'" + !! "Type check failed in assignment; expected '{$.expected.^name}' but got '{$.got.^name}'"; + } +} +my class X::TypeCheck::Argument is X::TypeCheck { + has $.protoguilt; + has @.arguments; + has $.objname; + has $.signature; + method message { + ($.protoguilt ?? "Calling proto of '" !! "Calling '") ~ + $.objname ~ "' " ~ + (+@.arguments == 0 + ?? "requires arguments\n" + !! "will never work with argument types (" ~ join(', ', @.arguments) ~ ")\n") + ~ $.signature + } +} + +my class X::TypeCheck::Splice is X::TypeCheck does X::Comp { + has $.action; + method message { + "Type check failed in {$.action}; expected {$.expected.^name} but got {$.got.^name}"; + } + +} + +my class X::Assignment::RO is Exception { + method message { + "Cannot modify an immutable value"; + } +} + +my class X::Immutable is Exception { + has $.typename; + has $.method; + method message { + "Cannot call '$.method' on an immutable '$.typename'"; + } +} + +my class X::NoDispatcher is Exception { + has $.redispatcher; + method message() { + "$.redispatcher is not in the dynamic scope of a dispatcher"; + } +} + +my class X::Localizer::NoContainer is Exception { + has $.localizer; + method message() { + "Can only use '$.localizer' on a container"; + } +} + +my class X::Mixin::NotComposable is Exception { + has $.target; + has $.rolish; + method message() { + "Cannot mix in non-composable type {$.rolish.^name} into object of type {$.target.^name}"; + } +} + +my class X::Inheritance::Unsupported does X::Comp { + # note that this exception is thrown before the child type object + # has been composed, so it's useless to carry it around. Use the + # name instead. + has $.child-typename; + has $.parent; + method message { + $.parent.^name ~ ' does not support inheritance, so ' + ~ $.child-typename ~ ' cannot inherit from it'; + } +} + +my class X::Inheritance::UnknownParent is Exception { + has $.child; + has $.parent; + has @.suggestions is rw; + + method message { + my $message := "'" ~ $.child ~ "' cannot inherit from '" ~ $.parent ~ "' because it is unknown."; + if +@.suggestions > 1 { + $message := $message ~ "\nDid you mean one of these?\n '" ~ @.suggestions.join("'\n '") ~ "'\n"; + } elsif +@.suggestions == 1 { + $message := $message ~ "\nDid you mean '" ~ @.suggestions[0] ~ "'?\n"; + } + return $message; + } +} + +my class X::Inheritance::SelfInherit is Exception { + has $.name; + + method message { + "'$.name' cannot inherit from itself." + } +} + +my class X::Export::NameClash does X::Comp { + has $.symbol; + method message() { + "A symbol '$.symbol' has already been exported"; + } +} + +my class X::HyperOp::NonDWIM is Exception { + has &.operator; + has $.left-elems; + has $.right-elems; + method message() { + "Lists on both side of non-dwimmy hyperop of &.operator.name() are not of the same length\n" + ~ "left: $.left-elems elements, right: $.right-elems elements"; + } +} + +my class X::Set::Coerce is Exception { + has $.thing; + method message { + "Cannot coerce object of type {$.thing.^name} to Set. To create a one-element set, pass it to the 'set' function"; + } +} + + +my role X::Temporal is Exception { } +my class X::Temporal::InvalidFormat does X::Temporal { + has $.invalid-str; + has $.target = 'Date'; + has $.format; + method message() { + "Invalid $.target string '$.invalid-str'; use $.format instead"; + } +} +my class X::DateTime::TimezoneClash does X::Temporal { + method message() { + 'DateTime.new(Str): :timezone argument not allowed with a timestamp offset'; + } +} +my class X::DateTime::InvalidDeltaUnit does X::Temporal { + has $.unit; + method message() { + "Cannnot use unit $.unit with Date.delta"; + } +} + +my class X::Eval::NoSuchLang is Exception { + has $.lang; + method message() { + "No compiler available for language '$.lang'"; + } +} + +my class X::Import::MissingSymbols is Exception { + has $.from; + has @.missing; + method message() { + "Trying to import from '$.from', but the following symbols are missing: " + ~ @.missing.join(', '); + } +} + +my class X::Numeric::Real is Exception { + has $.target; + has $.reason; + has $.source; + + method message() { + "Can not convert $.source to {$.target.^name}: $.reason"; + } +} + +my class X::Numeric::DivideByZero is Exception { + has $.using; + method message() { + "Divide by zero" ~ ( $.using ?? " using $.using" !! '' ); + } +} + +my class X::PseudoPackage::InDeclaration does X::Comp { + has $.pseudo-package; + has $.action; + method message() { + "Cannot use pseudo package $.pseudo-package in $.action"; + } +} + +my class X::NoSuchSymbol is Exception { + has $.symbol; + method message { "No such symbol '$.symbol'" } +} + +my class X::Item is Exception { + has $.aggregate; + has $.index; + method message { "Cannot index {$.aggregate.^name} with $.index" } +} + +my class X::Multi::Ambiguous is Exception { + has $.dispatcher; + has @.ambiguous; + method message { + join "\n", + "Ambiguous call to '$.dispatcher.name()'; these signatures all match:", + @.ambiguous.map(*.signature.perl) + } +} + +my class X::Multi::NoMatch is Exception { + has $.dispatcher; + method message { + join "\n", + "Cannot call '$.dispatcher.name()'; none of these signatures match:", + $.dispatcher.dispatchees.map(*.signature.perl) + } +} + +my class X::Caller::NotDynamic is Exception { + has $.symbol; + method message() { + "Cannot access '$.symbol' through CALLER, because it is not declared as dynamic"; + } +} + +{ + my %c_ex; + %c_ex{'X::TypeCheck::Binding'} := sub ($got, $expected) is hidden_from_backtrace { + X::TypeCheck::Binding.new(:$got, :$expected).throw; + }; + %c_ex := sub ($symbol, $got, $expected) is hidden_from_backtrace { + X::TypeCheck::Assignment.new(:$symbol, :$got, :$expected).throw; + }; + %c_ex{'X::TypeCheck::Return'} := sub ($got, $expected) is hidden_from_backtrace { + X::TypeCheck::Return.new(:$got, :$expected).throw; + }; + %c_ex := sub () is hidden_from_backtrace { + X::Assignment::RO.new.throw; + }; + %c_ex{'X::ControlFlow::Return'} := sub () is hidden_from_backtrace { + X::ControlFlow::Return.new().throw; + }; + %c_ex{'X::NoDispatcher'} := sub ($redispatcher) is hidden_from_backtrace { + X::NoDispatcher.new(:$redispatcher).throw; + }; + %c_ex{'X::Multi::Ambiguous'} := sub ($dispatcher, @ambiguous) is hidden_from_backtrace { + X::Multi::Ambiguous.new(:$dispatcher, :@ambiguous).throw + }; + %c_ex{'X::Multi::NoMatch'} := sub ($dispatcher) is hidden_from_backtrace { + X::Multi::NoMatch.new(:$dispatcher).throw + }; + my Mu $parrot_c_ex := nqp::getattr(%c_ex, EnumMap, '$!storage'); + nqp::bindcurhllsym('P6EX', $parrot_c_ex); + + 0; +} + + +# vim: ft=perl6 diff --git a/samples/Perl6/Model.pm b/samples/Perl6/Model.pm new file mode 100644 index 0000000000..1c2bea9d51 --- /dev/null +++ b/samples/Perl6/Model.pm @@ -0,0 +1,146 @@ +use v6; + +class Math::Model; + +use Math::RungeKutta; +# TODO: only load when needed +use SVG; +use SVG::Plot; + +has %.derivatives; +has %.variables; +has %.initials; +has @.captures is rw; + +has %!inv = %!derivatives.invert; +# in Math::Model all variables are accessible by name +# in contrast Math::RungeKutta uses vectors, so we need +# to define an (arbitrary) ordering +# @!deriv-names holds the names of the derivatives in a fixed +# order, sod @!deriv-names[$number] turns the number into a name +# %!deriv-keying{$name} translates a name into the corresponding index +has @!deriv-names = %!inv.keys; +has %!deriv-keying = @!deriv-names Z=> 0..Inf; + +# snapshot of all variables in the current model +has %!current-values; + +has %.results; +has @.time; + +has $.numeric-error is rw = 0.0001; + +my sub param-names(&c) { + &c.signature.params».name».substr(1).grep({ $_ ne '_'}); +} + +method !params-for(&c) { + param-names(&c).map( {; $_ => %!current-values{$_} } ).hash; +} + +method topo-sort(*@vars) { + my %seen; + my @order; + sub topo(*@a) { + for @a { + next if %!inv.exists($_) || %seen{$_} || $_ eq 'time'; + die "Undeclared variable '$_' used in model" + unless %.variables.exists($_); + topo(param-names(%.variables{$_})); + @order.push: $_; + %seen{$_}++; + } + } + topo(@vars); +# say @order.perl; + @order; +} + + +method integrate(:$from = 0, :$to = 10, :$min-resolution = ($to - $from) / 20, :$verbose) { + for %.derivatives -> $d { + die "There must be a variable defined for each derivative, missing for '$d.key()'" + unless %.variables.exists($d.key) || %!inv.exists($d.key); + die "There must be an initial value defined for each derivative target, missing for '$d.value()'" + unless %.initials.exists($d.value); + } + + %!current-values = %.initials; + %!current-values