niecza

use MONKEY_TYPING;
use CClass;
use CgOp;
use GetOptLong;
use NieczaActions;
use NieczaBackendDotnet;
use NieczaCompiler;
use NieczaFrontendSTD;
use NieczaPassSimplifier;
use NieczaPathSearch;
use Op;
use Operator;
use OpHelpers;
use OptBeta;
use OptRxSimple;
use RxOp;
use Sig;
use STD;

# augment class RxOp {
# method oplift() {
#     say "oplift: {self.typename}";
#     my $i = 0;
#     map { say $i++; .oplift }, @$!zyg
# }
# }

augment class Op {
method const_value() { }
}

augment class Op::StatementList {
    method const_value() { $!children[0].const_value if $!children == 1 }
}

augment class Op::Paren {
    method const_value() { $!inside.const_value }
}

augment class Op::StringLiteral {
    method const_value() { $*unit.string_constant(~$!text) }
}

augment class Op::Num {
    method const_value() { $*unit.numeric_constant(@($!value)) }
}

class Op::GeneralConst is Op {
    has $.value;
    method const_value() { $!value }
    method code($) { CgOp.const($!value) }
}

my constant %item_assignment = (:dba('item assignment') , :prec<i=>, :assoc<right>, :!pure);
augment grammar STD::P6 {
    rule post_constraint {
        :my $*IN_DECL = '';
        :dba('constraint')
        [
        | '[' ~ ']' <signature> $<bracket>={1}
        | '(' ~ ')' <signature>
        | where <EXPR(item %item_assignment)>
        ]
    }
}

# A bit hackish; handles the macro aspects of $foo does Role(23)
class Operator::Mixin is Operator::Function {
    method with_args($/, *@args) {
        if @args[1] ~~ ::Op::CallSub {
            nextsame if @args[1].invocant ~~ ::Op::Lexical && @args[1].invocant.name eq '&_param_role_inst';
            $/.CURSOR.sorry("Can only provide exactly one initial value to a mixin") unless @args[1].getargs.elems == 1;
            ::Op::CallSub.new(|node($/), invocant => $.function,
                args => [@args[0], @args[1].invocant, ::Op::SimplePair.new(
                    key => 'value', value => @args[1].getargs[0] // mklex($/,'Nil'))]);
        } else {
            nextsame;
        }
    }
}

augment class NieczaActions {
method check_hash($/) {
    my $do = $<pblock><blockoid>.ast;

    return False unless $do.^isa(::Op::StatementList);
    return True if $do.children == 0;
    return False if $do.children > 1;

    $do = $do.children[0];
    my @bits = $do.^isa(::Op::SimpleParcel) ?? @( $do.items ) !! $do;

    return True if @bits[0].^isa(::Op::SimplePair);

    if @bits[0].^isa(::Op::Builtin) && @bits[0].name eq 'pair' {
        return True;
    }

    if @bits[0].^isa(::Op::GeneralConst) && @bits[0].value.starts_with_pair {
        return True;
    }

    if @bits[0].^isa(::Op::Lexical) && substr(@bits[0].name,0,1) eq '%' {
        return True;
    }

    return False;
}

method process_block_traits($/, @tr) {
    my $sub = $*CURLEX<!sub>;
    my $pack = $sub.body_of;
    for @tr -> $T {
        my $tr = $T.ast;
        if $pack && $tr<name> {
            my $super = $tr<name>;

            $T.CURSOR.sorry("superclass $super.name() declared outside of any class"),
                next unless $sub.body_of;
            $T.CURSOR.sorry("superclass $super.name() declared in an augment"),
                next if defined $*AUGMENT_BUFFER;
            $T.CURSOR.sorry("cannot declare a superclass in this kind of package"),
                next if !$pack.CAN('add_super');

            $T.CURSOR.trymop({
                $pack.add_super($super);
            });
        } elsif $pack && $tr<does> {
            my $role = $tr<does>;

            $T.CURSOR.sorry("role $role.name() used outside of any class"), next
                unless $sub.body_of;
            $T.CURSOR.sorry("role $role.name() used in an augment"),
                next if defined $*AUGMENT_BUFFER;
            $T.CURSOR.sorry("cannot use a role in this kind of package"),
                next if !$pack.CAN('add_role');

            $T.CURSOR.trymop({
                $pack.add_role($role);
            });
        } elsif $pack && $tr<export> {
            my @exports = @( $tr<export> );
            $sub.outer.add_exports($pack.name, $pack, @exports);
        } elsif !$pack && $tr<export> {
            my @exports = @( $tr<export> );
            $sub.outer.add_exports('&'~$sub.name, $sub, @exports);
            $sub.outer.create_static_pad;
            $/.CURSOR.mark_used($sub.outervar)
                if defined $sub.outervar;
        } elsif !$pack && $tr<nobinder> {
            $sub.set_signature(Any);
        } elsif !$pack && $tr<pure> {
            $sub.outer.create_static_pad;
            $sub.set_extend('pure', True);
        } elsif !$pack && grep { defined $tr{$_} }, <looser tighter equiv> {
            my $rel = $tr.keys.[0];
            my $to  = $tr.values.[0];
            $to = $to.inside if $to ~~ ::Op::Paren;
            $to = $to.children[0] if $to ~~ ::Op::StatementList && $to.children == 1;

            my $oprec;
            if $to ~~ ::Op::Lexical {
                $oprec = $T.CURSOR.function_O($to.name);
            } elsif $to ~~ ::Op::StringLiteral && $sub.name ~~ /^(\w+)\:\<.*\>$/ {
                $oprec = $T.CURSOR.cat_O(~$0, $to.text);
            } else {
                $T.CURSOR.sorry("Cannot interpret operator reference");
                next;
            }
            unless $sub.get_extend('prec') {
                $T.CURSOR.sorry("Target does not seem to be an operator");
                next;
            }
            unless $oprec {
                $T.CURSOR.sorry("No precedence available for reference target");
                next;
            }
            if $rel eq 'equiv' {
                $sub.set_extend('prec', $oprec.kv);
            } else {
                my %prec = $sub.get_extend('prec');
                %prec<prec> = $oprec.<prec>;
                %prec<prec> ~~ s/\=/<=/ if $rel eq 'looser';
                %prec<prec> ~~ s/\=/>=/ if $rel eq 'tighter';
                $sub.set_extend('prec', %prec.kv);
            }
        } elsif !$pack && $tr<assoc> {
            my $arg = ~self.trivial_eval($T, $tr<assoc>);
            my %prec = $sub.get_extend('prec');
            unless %prec {
                $T.CURSOR.sorry("Target does not seem to be an operator");
                next;
            }
            unless $arg eq any < left right non list unary chain > {
                $T.CURSOR.sorry("Invalid associativity $arg");
                next;
            }
            %prec<assoc> = $arg;
            $sub.set_extend('prec', %prec.kv);
        } elsif !$pack && $tr<Niecza::absprec> {
            my $arg = ~self.trivial_eval($T, $tr<Niecza::absprec>);
            my %prec = $sub.get_extend('prec');
            unless %prec {
                $T.CURSOR.sorry("Target does not seem to be an operator");
                next;
            }
            %prec<prec> = $arg;
            %prec<dba> = "like $sub.name()";
            $sub.set_extend('prec', %prec.kv);
        } elsif !$pack && $tr<Niecza::builtin> {
            $sub.set_extend('builtin',
                self.trivial_eval($T, $tr<Niecza::builtin>));
        } elsif !$pack && $tr<return_pass> {
            $sub.set_return_pass;
        } elsif !$pack && $tr<of> {
        } elsif !$pack && $tr<rw> {
        } elsif !$pack && $tr<unsafe> {
            $sub.set_unsafe;
        } else {
            $T.CURSOR.sorry("Unhandled trait $tr.keys[0] for this context");
        }
    }
}


method post_constraint($/) { }

method infix:does ($/) {
    make ::Operator::Mixin.new(function => mklex($/, '&infix:<does>'));
}

method infix:but ($/) {
    make ::Operator::Mixin.new(function => mklex($/, '&infix:<but>'));
}

method parameter($/) {
    my $sorry;
    my $p = $<param_var> // $<named_param>;
    my $p_ast = $p ?? $p.ast !! { names => [], flags => $Sig::POSITIONAL };
    my $flags = $p_ast<flags>;

    $flags +|= $Sig::READWRITE if $*SIGNUM && $*CURLEX<!rw_lambda>;

    for @( $<trait> ) -> $trait {
        if $trait.ast<rw> { $flags +|= $Sig::READWRITE }
        elsif $trait.ast<copy> { $flags +|= $Sig::IS_COPY }
        elsif $trait.ast<parcel> { $flags +|= $Sig::RWTRANS }
        elsif $trait.ast<readonly> { $flags +&= +^$Sig::READWRITE }
        else {
            $trait.CURSOR.sorry('Unhandled trait ' ~ $trait.ast.keys.[0]);
        }
    }

    my $default = $<default_value> ?? $<default_value>.ast !! Any;
    $default.set_name("$/ init") if $default;

    my $tag = $<quant> ~ ':' ~ $<kind>;
    if    $tag eq '**:*' { $sorry = "Slice parameters NYI" }
    elsif $tag eq '*:*'  { $flags +|= ($flags +& $Sig::IS_HASH) ?? $Sig::SLURPY_NAM !! $Sig::SLURPY_POS }
    elsif $tag eq '|:*'  { $flags +|= $Sig::SLURPY_CAP }
    elsif $tag eq '\\:!' { $flags +|= $Sig::RWTRANS }
    elsif $tag eq '\\:?' { $flags +|= ($Sig::RWTRANS + $Sig::OPTIONAL) }
    elsif $tag eq ':!'   { }
    elsif $tag eq ':*'   { $flags +|= $Sig::OPTIONAL }
    elsif $tag eq ':?'   { $flags +|= $Sig::OPTIONAL }
    elsif $tag eq '?:?'  { $flags +|= $Sig::OPTIONAL }
    elsif $tag eq '!:!'  { }
    elsif $tag eq '!:?'  { $flags +|= $Sig::OPTIONAL }
    elsif $tag eq '!:*'  { }
    else                 { $sorry = "Confusing parameters ($tag)" }
    if $sorry { $/.CURSOR.sorry($sorry); }

    if defined $p_ast<slot> {
        # TODO: type constraint here
    }

    make ::Sig::Parameter.new(name => ~$/, mdefault => $default,
        |$p_ast, :$flags);

    for @<type_constraint> -> $tc {
        if $tc.ast<where> {
            push ($/.ast.where //= []), self.thunk_sub($tc.ast<where>.ast);
        } elsif $tc.ast<value> {
            $/.ast.tclass = $tc.ast<value>.get_type;
            push ($/.ast.where //= []), self.thunk_sub(
                ::Op::GeneralConst.new(value => $tc.ast<value>));
        } else {
            $/.CURSOR.sorry("Parameter coercion NYI") if $tc.ast<as>;
            my $type = $tc.ast<type>;
            if $type.kind eq 'subset' {
                push ($/.ast.where //= []), self.thunk_sub(
                    ::Op::GeneralConst.new(value => $type.get_type_var));
                $type = $type.get_basetype while $type.kind eq 'subset';
            }
            $/.ast.tclass = $type;
            $/.ast.flags +|= $tc.ast<tmode>;
        }
    }

    for @<post_constraint> -> $pc {
        # XXX this doesn't seem to be specced anywhere, but it's
        # Rakudo-compatible and shouldn't hurt
        if $pc<bracket> {
            $/.ast.flags +&= +^$Sig::IS_HASH;
            $/.ast.flags +|= $Sig::IS_LIST;
        }

        if $pc<signature> -> $ssig {
            $ssig.CURSOR.sorry('Cannot have more than one sub-signature for a pparameter') if $/.ast.subsig;
            $/.ast.subsig = $pc<signature>.ast;
        } else {
            push ($/.ast.where //= []), self.thunk_sub($pc<EXPR>.ast);
        }
    }
}

# :: { flags : Int, slot : Maybe[Str] }
method param_var($/) {
    if $<signature> {
        make { slot => Any, names => [], subsig => $<signature>.ast,
            flags => $Sig::POSITIONAL +
                (substr($/,0,1) eq '[' ?? $Sig::IS_LIST !! 0) };
        return;
    }
    my $twigil = $<twigil> ?? ~$<twigil> !! '';
    my $sigil = ~$<sigil>;
    my $list = $sigil eq '@';
    my $hash = $sigil eq '%';
    my $name = $<name> ?? ~$<name> !! Any;

    my $slot;
    if $twigil eq '' {
        $slot = defined($name) ?? ($sigil ~ $name) !! Any;
    } elsif $twigil eq '*' {
        $slot = "$sigil*" ~ "$name";
    } else {
        $/.CURSOR.sorry("Unhandled parameter twigil $twigil");
        make { };
        return Nil;
    }

    if ($sigil ne '$' && $sigil ne '@' && $sigil ne '%' && $sigil ne '&') {
        $/.CURSOR.sorry('Non bare scalar targets NYI');
        make { }
        return Nil;
    }

    $/.CURSOR.trymop({
        $/.CURSOR.check_categorical($slot);
        $*CURLEX<!sub>.add_my_name($slot, :$list, :$hash, |mnode($/),
            noinit => ?($*SIGNUM)) if defined($slot);
    });

    make { :$slot, names => defined($name) ?? [ $name ] !! [],
        flags => ($list ?? $Sig::IS_LIST !! 0) + ($hash?? $Sig::IS_HASH !! 0) +
            $Sig::POSITIONAL };
}

method variable_declarator($/) {
    if $*MULTINESS {
        $/.CURSOR.sorry("Multi variables NYI");
    }

    my $scope = $*SCOPE // 'my';

    my $start;
    for @$<trait> -> $t {
        if $t.ast<rw> {
        } elsif $t.ast<dynamic> {
        } elsif $t.ast<start> && $*SCOPE eq 'state' {
            $start = $t.ast<start>;
        } else {
            $/.CURSOR.sorry("Trait $t.ast.keys.[0] not available on variables");
        }
    }
    if $<post_constraint> || $<postcircumfix> || $<semilist> {
        $/.CURSOR.sorry("Postconstraints, and shapes on variable declarators NYI");
    }

    if $scope eq 'augment' || $scope eq 'supersede' {
        $/.CURSOR.sorry("Illogical scope $scope for simple variable");
    }

    my $typeconstraint;
    if $*OFTYPE {
        my $of = $*OFTYPE.ast;
        $*OFTYPE.CURSOR.sorry("Only simple types may be attached to variables")
            if !$of<type> || $of<tmode> || $of<as>;
        $typeconstraint = $of<type> // self.get_Any;
        $/.CURSOR.sorry("Common variables are not unique definitions and may not have types") if $scope eq 'our';
    }

    my $v = $<variable>.ast;
    my $t = $v<twigil>;
    my $list = $v<sigil> && $v<sigil> eq '@';
    my $hash = $v<sigil> && $v<sigil> eq '%';
    if ($t && defined "?=~^:".index($t)) {
        $/.CURSOR.sorry("Variables with the $t twigil cannot be declared " ~
            "using $scope; they are created " ~
            ($t eq '?' ?? "using 'constant'." !!
             $t eq '=' ?? "by parsing POD blocks." !!
             $t eq '~' ?? "by 'slang' definitions." !!
             "automatically as parameters to the current block."));
    }

    if $scope ne 'has' && ($t eq '.' || $t eq '!') {
        $/.CURSOR.sorry("Twigil $t is only valid on attribute definitions ('has').");
    }

    if !defined($v<name>) && $scope ne any < my anon state > {
        $/.CURSOR.sorry("Scope $scope requires a name");
    }

    if defined($v<pkg>) || defined($v<iname>) {
        $/.CURSOR.sorry(":: syntax is only valid when referencing variables, not when defining them.");
    }

    my $name = defined($v<name>) ?? $v<sigil> ~ $v<twigil> ~ $v<name> !! "";
    # otherwise identical to my
    my $slot = ($scope eq 'anon' || !defined($v<name>))
        ?? self.gensym !! $name;

    if $scope eq 'has' {
        make self.add_attribute($/, $v<name>, $v<sigil>, $t eq '.',
            $typeconstraint);
    } elsif $scope eq 'state' {
        $/.CURSOR.trymop({
            $/.CURSOR.check_categorical($slot);
            $*CURLEX<!sub>.add_state_name($slot, self.gensym, :$list,
                :$hash, :$typeconstraint, |mnode($/));
        });
        make Op::StateDecl.new(|node($/), inside =>
            Op::Lexical.new(|node($/), name => $slot, :$list, :$hash));
    } elsif $scope eq 'our' {
        make self.package_var($/, $slot, $slot, ['OUR']);
    } else {
        $/.CURSOR.trymop({
            $/.CURSOR.check_categorical($slot);
            $*CURLEX<!sub>.add_my_name($slot, :$list, :$hash,
                :$typeconstraint, |mnode($/));
        });
        make ::Op::Lexical.new(|node($/), name => $slot, :$list, :$hash);
    }

    if $start {
        my $cv = self.gensym;
        $*CURLEX<!sub>.add_state_name(Str, $cv);
        make mklet($/.ast, -> $ll {
            Op::StatementList.new(|node($/), children => [
                Op::Start.new(condvar => $cv, body =>
                    self.inliney_call($/, $start, $ll)), $ll ]) });
    }
}


method trait_mod:does ($/) {
    my $does = $<typename>.ast;
    $*OFTYPE.CURSOR.sorry("Only simple types may be used here")
        if !$does<type> || $does<tmode> || $does<as>;
    make { does => $does<type> // self.get_Any };
}

method trait_mod:of ($/) {
    my $of = $<typename>.ast;
    $*OFTYPE.CURSOR.sorry("Only simple types may be used here")
        if !$of<type> || $of<tmode> || $of<as>;
    make { of => $of<type> // self.get_Any };
}

method get_Any() { $*CURLEX<!sub>.compile_get_pkg('CORE', 'Any') }

method type_constraint($/) {
    if $<value> {
        my $val = $<value>.ast.const_value;
        $val // $/.CURSOR.sorry("Value constraint is not constant");
        make { value => $val // ::Op::Num.new(value => 0).const_value };
    } elsif $<typename> {
        make $<typename>.ast;
    } else {
        make { where => $<EXPR>.ast };
    }
}

method typename($/) {
    constant %masks = ':_' => $Sig::ANY_DEF, ':T' => $Sig::UNDEF_ONLY,
        ':U' => $Sig::UNDEF_ONLY, ':D' => $Sig::DEF_ONLY;

    $/.CURSOR.sorry('WHENCE blocks not allowed on declarative type names')
        if $<whence>;

    if $<ident> {
        $/.CURSOR.sorry('::?CLASS syntax NYI');
        make { tmode => 0, type => self.get_Any };
        return;
    }

    my $tmode = 0;
    my $long = $<longname>;
    my ($type) = self.process_name($long);

    if !$type {
        $/.CURSOR.sorry('A type must be provided');
        $type = self.get_Any;
    }

    if $<typename> {
        $/.CURSOR.sorry('Coercive declarations NYI');
    }

    for @( $long<colonpair> ) -> $cp {
        if %masks{$cp} -> $mask {
            $/.CURSOR.sorry("You may only specify one of :_ :D :U :T") if $tmode;
            $tmode +|= $mask;
        }
    }

    make { :$type, :$tmode };
}
}

# remove run_dispatch
CgOp._register_ops: < who sc_root sc_indir temporize _addmethod _invalidate
    rxlprim
>;

my $usage = q:to/EOM/;
niecza -- a command line wrapper for Niecza

usage: niecza -e 'code'      # run a one-liner
   OR: niecza file.pl [args] # run a program
   OR: niecza -C MyModule    # precompile a module
   OR: niecza                # interactive shell

general options:
   -n                        # short for -L CORN
   -p                        # short for -L CORP
   -B --backend=NAME         # select backend (dotnet)
   -L --language=NAME        # select your setting
   -I --include=DIR          # add a directory to search for modules
   -v --verbose              # detailed timing info
   -c --compile              # don't run (implied with -C)
      --safe                 # disable system interaction
      --help                 # display this message

backend options:
      --obj-dir=DIR          # select output location (all)
EOM

my $runobj = Q:CgOp { (box Str (rawcall get_BaseDirectory (rawscall System.AppDomain.get_CurrentDomain))) };
my $basedir = $runobj.IO.append("..").realpath;

my @lib  = $basedir.append("lib"), ".".IO.realpath;
my $lang = "CORE";
my $safe = False;
my $bcnd = "dotnet";
my $odir = $basedir.append("obj");
my $verb = 0;
my @eval;
my $cmod = False;
my $comp = False;
my $version = False;

GetOptions(:!permute,
    "evaluate|e=s" => sub { push @eval, $_ },
    "compile-module|C" => sub { $cmod = True },
    "backend|B=s" => sub { $bcnd = $_ },
    "language|L=s" => sub { $lang = $_ },
    "p" => sub { $lang = "CORP" },
    "n" => sub { $lang = "CORN" },
    "verbose" => sub { $verb++ },
    "version|v" => sub { $version = True },
    "compile|c" => sub { $comp = True },
    "safe" => sub { $safe = True },
    "include|I=s" => sub { unshift @lib, $_.IO.realpath },
    "obj-dir=s" => sub { $odir = $_ },
    "help|h" => sub { say $usage; exit 0 },
);

my @*INC;
my $backend;
if $bcnd eq 'dotnet' || $bcnd eq 'mono' {
    $backend = NieczaBackendDotnet.new(obj_dir => $odir, safemode => $safe);
}
else {
    note "Backend '$bcnd' not supported";
    exit 1;
}

my $c = NieczaCompiler.new(
    module_finder => NieczaPathSearch.new(
        path => @lib,
    ),
    frontend => NieczaFrontendSTD.new(
        lang => $lang,
        safemode => $safe,
    ),
    backend => $backend,
    verbose => $verb,
);

if $version {
    $c.compile_string('say "This is Niecza Perl 6 {$?PERL<version>}"', True);
    exit 0;
}

if $cmod {
    if @eval {
        note "Module compilation cannot be used with strings to evaluate";
        exit 1;
    }
    if !@*ARGS {
        say "No modules named to compile!";
        exit 0;
    }
    for @*ARGS {
        $c.compile_module($_);
    }
}
elsif @eval {
    $c.backend.run_args = @*ARGS;
    for @eval {
        $c.compile_string($_, !$comp);
    }
}
elsif @*ARGS {
    my $file = shift @*ARGS;
    $c.backend.run_args = @*ARGS;
    $c.compile_file($file, !$comp);
}
else {
    my $*repl_outer;
    my $*repl_outer_frame;
    $c.compile_string('$PROCESS::OUTPUT_USED ::= True', !$comp, :repl,
        :evalmode);
    while True {
        print "niecza> ";
        my $l = $*IN.get // last;
        my $ok;
        try {
            $c.compile_string($l, !$comp, :repl, :evalmode,
                :outer($*repl_outer), :outer_frame($*repl_outer_frame));
            $ok = True;
        }
        say $! unless $ok;
    }
    say "";
}