{-# OPTIONS -fglasgow-exts #-}
 
{-
    *** NOTE ***
    DO NOT EDIT THIS FILE.
    This module is automatically generated by src/gen_prelude.hs.
-}
 
{-|
    Perl 6 Prelude.
 
>   The world was fair, the mountains tall,
>   In Eldar Days before the fall
>   Of mighty kings in Nargothrond
>   And Gondolin, who now beyond
>   The Western Seas have passed away:
>   The world was fair in Durin's day.
 
-}
 
 
module Pugs.Prelude (
    preludeStr
) where
 
preludeStr :: String
preludeStr = unlines
    [ ""
    , "module Prelude-0.0.1;"
    , ""
    , "use v6;"
    , ""
    , "=kwid"
    , ""
    , "There are a couple of things going on here."
    , ""
    , "* These are perl6 implementations of /builtins/"
    , "* They sometimes use Pugs internals to do the job"
    , "* Some of this had not been specced yet (need S29 work)."
    , ""
    , "All functions in this file need to have the `is primitive`"
    , "When writing primitives, please do *not* use &return, because"
    , "that messes up PIR generation.  To return a value, arrange"
    , "it to be the last evaluated expression."
    , ""
    , "Please declare either `is safe` or `is unsafe`, too."
    , ""
    , "For functions exported to the global `*` namespace, please use"
    , "the `is builtin` trait."
    , ""
    , "=cut"
    , ""
    , "class File {"
    , "    my $SEEK_START = 0;"
    , "    my $SEEK_CUR   = 1;"
    , "    my $SEEK_END   = 2;"
    , ""
    , ""
    , ""
    , ""
    , "    multi sub open (Str $filename, Str +$layer, Bool +$r, Bool +$w, Bool +$rw, Bool +$a) returns IO is primitive is unsafe is builtin {"
    , "        die \"fancy open modes not supported yet\" if $a & any($r, $w, $rw);"
    , "        my $mode;"
    , "        $mode = \"a\" if $a;"
    , "        $mode = \"w\" if $w;"
    , "        $mode = \"rw\" if $rw || $r & $w;"
    , "        $mode ||= \"r\";"
    , ""
    , "        my $fh = Pugs::Internals::openFile($filename, $mode);"
    , ""
    , "        Pugs::Internals::hSetBinaryMode($fh, bool::true) if"
    , "            $layer ~~ rx:P5/:raw\\b/;"
    , ""
    , "        $fh;"
    , "    }"
    , ""
    , "    multi method seek ($self: Int $position, Int ?$whence = $File::SEEK_START) returns Bool is primitive is unsafe is builtin {"
    , "        Pugs::Internals::hSeek($seek, $position, $whence);"
    , "    }"
    , "}"
    , ""
    , ""
    , "class Pipe {"
    , ""
    , "    multi sub open (Str $command, Bool +$r is copy, Bool +$w) returns IO is primitive is unsafe {"
    , "        die \"Pipe::open is unidirectional\" if all($r, $w);"
    , "        $r = bool::true if none($r, $w);"
    , "        my ($in, $out, $err, undef) ="
    , "            Pugs::Internals::runInteractiveCommand($command);"
    , "        close $err;"
    , "        close  ($r ?? $in :: $out);"
    , "        ($r ?? $out :: $in);"
    , "    }"
    , ""
    , ""
    , "    multi sub open2 (Str $command) returns List is primitive is unsafe {"
    , "        my ($in, $out, $err, $pid) ="
    , "            Pugs::Internals::runInteractiveCommand($command);"
    , "        close $err;"
    , "        ($in, $out, $pid);"
    , "    }"
    , ""
    , ""
    , "    multi sub open3 (Str $command) returns List is primitive is unsafe {"
    , "        my ($in, $out, $err, $pid) ="
    , "            Pugs::Internals::runInteractiveCommand($command);"
    , "        ($in, $out, $err, $pid);"
    , "    }"
    , "}"
    , ""
    , "class Control::Basic {"
    , ""
    , ""
    , "    multi sub eval (Str ?$code = $CALLER::_, Str +$lang = 'Perl6')"
    , "            is primitive is safe is builtin {"
    , "        given lc $lang {"
    , "            when 'perl6'   { Pugs::Internals::eval($code) };"
    , "            when 'perl5'   { Pugs::Internals::eval_perl5($code) };"
    , "            when 'haskell' { Pugs::Internals::eval_haskell($code) };"
    , "            when 'parrot'  { Pugs::Internals::eval_parrot($code) };"
    , "            when 'pir'     { Pugs::Internals::eval_parrot($code) };"
    , "            when 'yaml'    { Pugs::Internals::eval_yaml($code) };"
    , ""
    , "            die \"Language \\\"$lang\\\" unknown.\";"
    , "        }"
    , "    }"
    , ""
    , ""
    , "    multi sub evalfile (Str $filename : Str +$lang = 'Perl6')"
    , "            is primitive is unsafe {"
    , "        eval(slurp $filename, $lang);"
    , "    }"
    , "}"
    , ""
    , ""
    , "class Control::Caller {"
    , "    has Str $.package;"
    , "    has Str $.file;"
    , "    has Int $.line;"
    , "    has Str $.subname;"
    , "    has Str $.subtype;"
    , "    has Code $.sub;"
    , "    has Str $.params;   # FIXME: needs attention; don't use yet."
    , ""
    , "    multi sub caller (Class ?$kind = Any, Int +$skip = 0, Str +$label) returns Control::Caller is primitive is builtin is safe {"
    , "        my @caller = Pugs::Internals::caller($kind, $skip, $label);"
    , ""
    , ""
    , "        @caller.elems ?? Control::Caller.new("
    , "            'package' => @caller[0],"
    , "            'file'    => @caller[1],"
    , "            'line'    => @caller[2],"
    , "            'subname' => @caller[3],"
    , "            'subtype' => @caller[4],"
    , "            'sub'     => @caller[5],"
    , "        ) :: undef;"
    , "    }"
    , "}"
    , ""
    , ""
    , "class Carp {"
    , "    multi sub longmess (: ?$e = '') returns Str is primitive is safe {"
    , "        my($mess, $i);"
    , "        $mess = \"$e at $?CALLER::POSITION\";"
    , ""
    , "        loop {"
    , "            my $caller = Control::Caller::caller(skip => $i++) err last;"
    , "            $mess ~= \"\\n\\t{$caller.package}::{$caller.subname}() at {$caller.file} line {$caller.line}\";"
    , "        }"
    , "        $mess;"
    , "    }"
    , "}"
    , ""
    , "class IO {"
    , "    method shift () is primitive { ./readline() }"
    , "}"
    , ""
    , "class Str {"
    , "    method shift ($self: ) is primitive { =open($self) }"
    , ""
    , "    method trans(Str $self:*%intable) is primitive is safe {"
    , ""
    , "      my sub expand(Str $string) {"
    , "        if ($string ~~ m:P5/([^-]+)\\-([^-]+)/) {"
    , "          (~ $0)..(~ $1);"
    , "        } else {"
    , "          $string;"
    , "        }"
    , "      }"
    , ""
    , ""
    , "    my %transtable = map{;zip(split('',$_.key),split('',$_.value))}"
    , "                   map{;expand $_.key => expand $_.value} %intable;"
    , ""
    , "    [~] map { %transtable{$_} // $_ } $self.split('');"
    , "  }"
    , ""
    , "}"
    , ""
    , "sub Pugs::Internals::but_block ($obj, Code $code) is primitive is safe {"
    , "    $code($obj);"
    , "    $obj;"
    , "}"
    , ""
    , "class Time::Local {"
    , ""
    , "    has Int  $.year;    # eg., 2005; \"pre-Gregorian dates are inaccurate\" - GHC System.Time"
    , "    has Int  $.month;   # 1 to 12 - NOTE 1-based"
    , "    has Int  $.day;     # 1 to 31"
    , "    has Int  $.hour;    # 0 to 23"
    , "    has Int  $.min;     # 0 to 59"
    , "    has Int  $.sec;     # 0 to 61 (up to two leap seconds)"
    , "    has Int  $.picosec;"
    , "    has Int  $.wday;    # 1 to 7, Sunday == 1"
    , "    has Int  $.yday;    # 0 to 365 (up to one leap day)"
    , "    has Str  $.tzname;  # string, eg, JDT"
    , "    has Int  $.tz;      # variation from UTC in seconds"
    , "    has Bool $.is_dst;"
    , ""
    , "    multi sub localtime(Num ?$when = time) returns Time::Local is primitive is builtin is safe {"
    , "        my $res;"
    , "        my $sec = int $when;"
    , "        my $pico = ($when - int $when) * 10**12;"
    , "            my @tm = Pugs::Internals::localtime(bool::false, $sec, $pico);"
    , ""
    , ""
    , "            $res = Time::Local.new("
    , "                year    => @tm[0],"
    , "                month   => @tm[1],"
    , "                day     => @tm[2],"
    , "                hour    => @tm[3],"
    , "                min     => @tm[4],"
    , "                sec     => @tm[5],"
    , "                picosec => @tm[6],"
    , "                wday    => @tm[7],"
    , "                yday    => @tm[8],"
    , "                tzname  => @tm[9],"
    , "                tz      => @tm[10],"
    , "                is_dst  => @tm[11],"
    , "            );"
    , "        $res;"
    , "    }"
    , "}"
    , ""
    , "class Num {"
    , "    multi sub round_gen(Int $n, Code $corner) returns Int is safe {"
    , "        $n"
    , "    }"
    , "    multi sub round_gen(Num $n, Code $corner) returns Int is safe {"
    , "        (int($n) == $n) ?? int($n) :: $corner($n);"
    , "    }"
    , ""
    , "    sub do_round($n) is primitive is safe {"
    , "        ($n < 0) ?? int( $n - 0.5) :: int($n + 0.5);"
    , "    }"
    , "    sub round($n) is primitive is safe {"
    , "        round_gen($n, &do_round)"
    , "    }"
    , ""
    , "    sub truncate($n) is primitive is safe {"
    , "        int($n)"
    , "    }"
    , "    our &trunc ::= &truncate;"
    , ""
    , "    sub do_ceil($n) is primitive is safe {"
    , "        ($n < 0) ?? (-int(-$n)) :: int($n + 1)"
    , "    }"
    , "    sub ceiling is primitive is safe {"
    , "        round_gen($^n, &do_ceil)"
    , "    }"
    , "    our &ceil ::= &ceiling;"
    , ""
    , "    sub do_floor($n) is primitive is safe {"
    , "        ($n < 0) ?? (-int(1-$n)) :: int($n)"
    , "    }"
    , "    sub floor is primitive is safe {"
    , "        round_gen($^n, &do_floor)"
    , "    }"
    , "}"
    , ""
    , "sub sprintf ($fmt, *@args) is primitive is builtin is safe {"
    , "    my $flen = $fmt.chars;"
    , "    my $fi = 0;"
    , "    my $ai = 0;"
    , "    my $str = \"\";"
    , "    while ($fi < $flen) {"
    , "\tmy $idx = index($fmt,\"%\",$fi);"
    , "\tif $idx < 0 {"
    , "\t    $str ~= substr($fmt,$fi);"
    , "\t    last;"
    , "\t} else {"
    , "\t    my $len = $idx - $fi;"
    , "\t    $str ~= substr($fmt,$fi, $len) if $len > 0;"
    , "\t    $fi = $idx;"
    , "\t}"
    , ""
    , "\tmy $start = $fi;"
    , "\t$fi++;"
    , "\twhile !(substr($fmt,$fi,1)"
    , "\t\t~~ any<% c s d u o x e f g X E G b p n i D U O F>) {"
    , "\t    $fi++;"
    , "\t}"
    , "\tmy $specifier = substr($fmt,$fi,1); $fi++;"
    , "\tmy $conversion = substr($fmt,$start,$fi - $start);"
    , ""
    , "\tmy $arg;"
    , "\tif $specifier ne '%' {"
    , "\t    die \"Insufficient arguments to sprintf\" if $ai >= +@args;"
    , "\t    $arg = @args[$ai];"
    , "\t    $ai++;"
    , "\t}"
    , ""
    , "\tgiven $specifier {"
    , "\t    when '%' {"
    , "\t\t$str ~= '%';"
    , "\t    }"
    , "\t    when any(<c d u o x X b i D U O>) {"
    , "\t\t$str ~= Pugs::Internals::sprintf($conversion,int($arg));"
    , "\t    }"
    , "\t    when 's' {"
    , "\t\t$str ~= Pugs::Internals::sprintf($conversion,\"$arg\");"
    , "\t    }"
    , "\t    when any(<e f g E G F>) {"
    , "\t\t$str ~= Pugs::Internals::sprintf($conversion,1.0*$arg);"
    , "\t    }"
    , "\t    default {"
    , "\t\tdie \"sprintf does not yet implement %{$specifier}\";"
    , "\t    }"
    , "\t}"
    , "    }"
    , "    $str;"
    , "}"
    , ""
    , "sub Scalar::as ($obj, $fmt) is primitive is safe {"
    , "    sprintf($fmt,$obj);"
    , "}"

    ]

