- Fixed remaining tests in compiler.

- Now showing stack-traces for errors on JVM.

4 files changed, 182 insertions, 180 deletions

diff --git a/new-luxc/source/luxc/generator/runtime.jvm.lux b/new-luxc/source/luxc/generator/runtime.jvm.lux
index ce138ca48..d2ad42a2c 100644
--- a/new-luxc/source/luxc/generator/runtime.jvm.lux
+++ b/new-luxc/source/luxc/generator/runtime.jvm.lux
@@ -1,12 +1,11 @@
 (;module:
   lux
   (lux (control monad)
-       (data ["R" error]
-             text/format
-             (coll [list "L/" Functor<List>]))
+       (data text/format
+             (coll [list "list/" Functor<List>]))
        [math]
-       [meta #+ Monad<Meta> "Meta/" Monad<Meta>]
-       [host #+ do-to])
+       [meta]
+       [host])
   (luxc ["&" base]
         (lang ["la" analysis]
               ["ls" synthesis])
@@ -55,6 +54,7 @@
 (def: #export $Flag $;Type $Object)
 (def: #export $Datum $;Type $Object)
 (def: #export $Function $;Type ($t;class function-class (list)))
+(def: $Throwable $;Type ($t;class "java.lang.Throwable" (list)))
 
 (def: #export logI
   $;Inst
@@ -468,27 +468,42 @@
 
 (def: io-methods
   $;Def
-  (|>. ($d;method #$;Public $;staticM "try" ($t;method (list $Function) (#;Some $Variant) (list))
-                  (<| $i;with-label (function [@from])
-                      $i;with-label (function [@to])
-                      $i;with-label (function [@handler])
-                      (|>. ($i;try @from @to @handler "java.lang.Throwable")
-                           ($i;label @from)
-                           ($i;ALOAD +0)
-                           $i;NULL
-                           ($i;INVOKEVIRTUAL function-class apply-method (apply-signature +1) false)
-                           rightI
-                           $i;ARETURN
-                           ($i;label @to)
-                           ($i;label @handler)
-                           ($i;INVOKEVIRTUAL "java.lang.Throwable" "getMessage" ($t;method (list) (#;Some $String) (list)) false)
-                           leftI
-                           $i;ARETURN)))
-       ))
+  (let [string-writerI (|>. ($i;NEW "java.io.StringWriter")
+                            $i;DUP
+                            ($i;INVOKESPECIAL "java.io.StringWriter" "<init>" ($t;method (list) #;None (list)) false))
+        print-writerI (|>. ($i;NEW "java.io.PrintWriter")
+                           $i;SWAP
+                           $i;DUP2
+                           $i;POP
+                           $i;SWAP
+                           ($i;boolean true)
+                           ($i;INVOKESPECIAL "java.io.PrintWriter" "<init>" ($t;method (list ($t;class "java.io.Writer" (list)) $t;boolean) #;None (list)) false)
+                           )]
+    (|>. ($d;method #$;Public $;staticM "try" ($t;method (list $Function) (#;Some $Variant) (list))
+                    (<| $i;with-label (function [@from])
+                        $i;with-label (function [@to])
+                        $i;with-label (function [@handler])
+                        (|>. ($i;try @from @to @handler "java.lang.Throwable")
+                             ($i;label @from)
+                             ($i;ALOAD +0)
+                             $i;NULL
+                             ($i;INVOKEVIRTUAL function-class apply-method (apply-signature +1) false)
+                             rightI
+                             $i;ARETURN
+                             ($i;label @to)
+                             ($i;label @handler)
+                             string-writerI ## TW
+                             $i;DUP2 ## TWTW
+                             print-writerI ## TWTP
+                             ($i;INVOKEVIRTUAL "java.lang.Throwable" "printStackTrace" ($t;method (list ($t;class "java.io.PrintWriter" (list))) #;None (list)) false) ## TW
+                             ($i;INVOKEVIRTUAL "java.io.StringWriter" "toString" ($t;method (list) (#;Some $String) (list)) false) ## TS
+                             $i;SWAP $i;POP leftI
+                             $i;ARETURN)))
+         )))
 
 (def: generate-runtime
   (Meta &common;Bytecode)
-  (do Monad<Meta>
+  (do meta;Monad<Meta>
     [_ (wrap [])
      #let [bytecode ($d;class #$;V1.6 #$;Public $;finalC runtime-class (list) ["java.lang.Object" (list)] (list)
                               (|>. adt-methods
@@ -502,25 +517,21 @@
 
 (def: generate-function
   (Meta &common;Bytecode)
-  (do Monad<Meta>
+  (do meta;Monad<Meta>
     [_ (wrap [])
      #let [applyI (|> (list;n.range +2 num-apply-variants)
-                      (L/map (function [arity]
-                               ($d;method #$;Public $;noneM apply-method (apply-signature arity)
-                                          (let [preI (|> (list;n.range +0 (n.dec arity))
-                                                         (L/map $i;ALOAD)
-                                                         $i;fuse)]
-                                            (|>. preI
-                                                 ($i;INVOKEVIRTUAL function-class apply-method (apply-signature (n.dec arity)) false)
-                                                 ($i;CHECKCAST function-class)
-                                                 ($i;ALOAD arity)
-                                                 ($i;INVOKEVIRTUAL function-class apply-method (apply-signature +1) false)
-                                                 $i;ARETURN)))))
-                      (list& ($d;abstract-method #$;Public $;noneM apply-method (apply-signature +1))
-                             ## ($d;method #$;Public $;noneM apply-method (apply-signature +1)
-                             ##            (|>. $i;NULL
-                             ##                 $i;ARETURN))
-                             )
+                      (list/map (function [arity]
+                                  ($d;method #$;Public $;noneM apply-method (apply-signature arity)
+                                             (let [preI (|> (list;n.range +0 (n.dec arity))
+                                                            (list/map $i;ALOAD)
+                                                            $i;fuse)]
+                                               (|>. preI
+                                                    ($i;INVOKEVIRTUAL function-class apply-method (apply-signature (n.dec arity)) false)
+                                                    ($i;CHECKCAST function-class)
+                                                    ($i;ALOAD arity)
+                                                    ($i;INVOKEVIRTUAL function-class apply-method (apply-signature +1) false)
+                                                    $i;ARETURN)))))
+                      (list& ($d;abstract-method #$;Public $;noneM apply-method (apply-signature +1)))
                       $d;fuse)
            bytecode ($d;abstract #$;V1.6 #$;Public $;noneC function-class (list) ["java.lang.Object" (list)] (list)
                                  (|>. ($d;field #$;Public $;finalF partials-field $t;int)
@@ -537,7 +548,7 @@
 
 (def: #export generate
   (Meta [&common;Bytecode &common;Bytecode])
-  (do Monad<Meta>
+  (do meta;Monad<Meta>
     [runtime-bc generate-runtime
      function-bc generate-function]
     (wrap [runtime-bc function-bc])))
diff --git a/new-luxc/test/test/luxc/generator/case.lux b/new-luxc/test/test/luxc/generator/case.lux
index 86319259c..34846a988 100644
--- a/new-luxc/test/test/luxc/generator/case.lux
+++ b/new-luxc/test/test/luxc/generator/case.lux
@@ -3,18 +3,10 @@
   (lux [io]
        (control [monad #+ do]
                 pipe)
-       (data text/format
-             [product]
-             ["e" error]
-             [bool "B/" Eq<Bool>]
-             [text "T/" Eq<Text>]
-             (coll ["a" array]
-                   [list "L/" Functor<List>]
-                   ["S" set]))
+       (data ["e" error]
+             (coll [list]))
        ["r" math/random "r/" Monad<Random>]
-       [meta #+ Monad<Meta>]
-       (meta [code])
-       [host]
+       [meta]
        test)
   (luxc (lang ["ls" synthesis])
         [analyser]
@@ -34,54 +26,51 @@
 (def: gen-case
   (r;Random [ls;Synthesis ls;Path])
   (<| r;rec (function [gen-case])
-      (with-expansions [<simple> (do-template [<gen> <synth> <path>]
-                                   [(do r;Monad<Random>
-                                      [value <gen>]
-                                      (wrap [(<synth> value) (<path> value)]))]
+      (`` ($_ r;either
+              (r/wrap [#ls;Unit #ls;UnitP])
+              (~~ (do-template [<gen> <synth> <path>]
+                    [(do r;Monad<Random>
+                       [value <gen>]
+                       (wrap [(<synth> value) (<path> value)]))]
 
-                                   [r;bool #ls;Bool #ls;BoolP]
-                                   [r;nat #ls;Nat #ls;NatP]
-                                   [r;int #ls;Int #ls;IntP]
-                                   [r;deg #ls;Deg #ls;DegP]
-                                   [r;frac #ls;Frac #ls;FracP]
-                                   [(r;text +5) #ls;Text #ls;TextP])]
-        ($_ r;either
-            (r/wrap [#ls;Unit #ls;UnitP])
-            <simple>
-            (do r;Monad<Random>
-              [size (|> r;nat (:: @ map (|>. (n.% struct-limit) (n.max +2))))
-               idx (|> r;nat (:: @ map (n.% size)))
-               [subS subP] gen-case
-               #let [dummyS (list;repeat (n.dec size) #ls;Unit)
-                     caseS (#ls;Tuple (list;concat (list (list;take idx dummyS)
-                                                         (list subS)
-                                                         (list;drop idx dummyS))))
-                     caseP (#ls;TupleP (if (tail? idx idx)
-                                         (#;Right idx)
-                                         (#;Left idx))
-                                       subP)]]
-              (wrap [caseS caseP]))
-            (do r;Monad<Random>
-              [size (|> r;nat (:: @ map (|>. (n.% struct-limit) (n.max +2))))
-               idx (|> r;nat (:: @ map (n.% size)))
-               [subS subP] gen-case
-               #let [caseS (#ls;Variant idx (tail? idx idx) subS)
-                     caseP (#ls;VariantP (if (tail? idx idx)
+                    [r;bool #ls;Bool #ls;BoolP]
+                    [r;nat #ls;Nat #ls;NatP]
+                    [r;int #ls;Int #ls;IntP]
+                    [r;deg #ls;Deg #ls;DegP]
+                    [r;frac #ls;Frac #ls;FracP]
+                    [(r;text +5) #ls;Text #ls;TextP]))
+              (do r;Monad<Random>
+                [size (|> r;nat (:: @ map (|>. (n.% struct-limit) (n.max +2))))
+                 idx (|> r;nat (:: @ map (n.% size)))
+                 [subS subP] gen-case
+                 #let [caseS (#ls;Tuple (list;concat (list (list;repeat idx #ls;Unit)
+                                                           (list subS)
+                                                           (list;repeat (|> size n.dec (n.- idx)) #ls;Unit))))
+                       caseP (#ls;TupleP (if (tail? size idx)
                                            (#;Right idx)
                                            (#;Left idx))
                                          subP)]]
-              (wrap [caseS caseP]))
-            ))))
+                (wrap [caseS caseP]))
+              (do r;Monad<Random>
+                [size (|> r;nat (:: @ map (|>. (n.% struct-limit) (n.max +2))))
+                 idx (|> r;nat (:: @ map (n.% size)))
+                 [subS subP] gen-case
+                 #let [caseS (#ls;Variant idx (tail? idx idx) subS)
+                       caseP (#ls;VariantP (if (tail? idx idx)
+                                             (#;Right idx)
+                                             (#;Left idx))
+                                           subP)]]
+                (wrap [caseS caseP]))
+              ))))
 
 (context: "Pattern-matching."
-  (<| (seed +17952275935008918762)
-      ## (times +100)
+  (<| (times +100)
       (do @
         [[valueS path] gen-case
          to-bind r;nat]
         ($_ seq
             (test "Can generate pattern-matching."
-                  (|> (do Monad<Meta>
+                  (|> (do meta;Monad<Meta>
                         [runtime-bytecode @runtime;generate
                          sampleI (@;generate valueS
                                              (#ls;AltP (#ls;SeqP path (#ls;ExecP (#ls;Bool true)))
@@ -94,7 +83,7 @@
                              _
                              false)))
             (test "Can bind values."
-                  (|> (do Monad<Meta>
+                  (|> (do meta;Monad<Meta>
                         [runtime-bytecode @runtime;generate
                          sampleI (@;generate (#ls;Nat to-bind)
                                              (#ls;SeqP (#ls;BindP +1) (#ls;ExecP (#ls;Variable 1))))]
diff --git a/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux b/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux
index 00cfd601b..dde15b19b 100644
--- a/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux
+++ b/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux
@@ -8,10 +8,10 @@
              ["e" error]
              [bool "bool/" Eq<Bool>]
              [text "text/" Eq<Text>]
-             [number "n/" Interval<Nat> "i/" Interval<Int> "r/" Interval<Frac> "d/" Interval<Deg>]
+             [number "nat/" Interval<Nat> "int/" Interval<Int> "real/" Interval<Frac> "deg/" Interval<Deg>]
              (coll ["a" array]
                    [list]))
-       ["r" math/random "r/" Monad<Random>]
+       ["r" math/random]
        [meta #+ Monad<Meta>]
        [host]
        test)
@@ -94,8 +94,8 @@
                                                         _
                                                         false)))]
 
-                                      ["nat min" n/bottom]
-                                      ["nat max" n/top]
+                                      ["nat min" nat/bottom]
+                                      ["nat max" nat/top]
                                       )
                           <unary> (do-template [<name> <type> <prepare> <comp>]
                                     [(test <name>
@@ -158,8 +158,8 @@
                                                         _
                                                         false)))]
 
-                                      ["int min" i/bottom]
-                                      ["int max" i/top]
+                                      ["int min" int/bottom]
+                                      ["int max" int/top]
                                       )
                           <unary> (do-template [<name> <type> <prepare> <comp>]
                                     [(test <name>
@@ -254,8 +254,8 @@
                                                         _
                                                         false)))]
 
-                                      ["frac min" (f.= r/bottom)]
-                                      ["frac max" (f.= r/top)]
+                                      ["frac min" (f.= real/bottom)]
+                                      ["frac max" (f.= real/top)]
                                       ["frac not-a-number" number;not-a-number?]
                                       ["frac positive-infinity" (f.= number;positive-infinity)]
                                       ["frac negative-infinity" (f.= number;negative-infinity)]
@@ -296,87 +296,89 @@
                                false)))
               )))))
 
+(def: (above-threshold value)
+  (-> Deg Deg)
+  (let [threshold .000000001 #( 1/(2^30) )#]
+    (if (d.< threshold value)
+      (d.+ threshold value)
+      value)))
+
 (context: "Deg procedures"
-  (<| (seed +1021167468900)
-      ## (times +100)
+  (<| (times +100)
       (do @
-        [param (|> r;deg (r;filter (|>. (d.= .0) not)))
+        [param (|> r;deg (:: @ map above-threshold))
          special r;nat
-         subject r;deg]
-        (with-expansions [<nullary> (do-template [<name> <reference>]
-                                      [(test <name>
-                                             (|> (do meta;Monad<Meta>
-                                                   [sampleI (@;generate (#ls;Procedure <name> (list)))]
-                                                   (@eval;eval sampleI))
-                                                 (meta;run (init-compiler []))
-                                                 (case> (#e;Success valueG)
-                                                        (d.= <reference> (:! Deg valueG))
-
-                                                        _
-                                                        false)))]
-
-                                      ["deg min" d/bottom]
-                                      ["deg max" d/top]
-                                      )
-                          <unary> (do-template [<name> <type> <prepare> <comp>]
-                                    [(test <name>
-                                           (|> (do Monad<Meta>
-                                                 [runtime-bytecode @runtime;generate
-                                                  sampleI (@;generate (#ls;Procedure <name> (list (#ls;Deg subject))))]
-                                                 (@eval;eval sampleI))
-                                               (meta;run (init-compiler []))
-                                               (case> (#e;Success valueG)
-                                                      (<comp> (<prepare> subject) (:! <type> valueG))
-
-                                                      _
-                                                      false)))]
-
-                                    ["deg to-frac" Frac deg-to-frac f.=]
-                                    )
-                          <binary> (do-template [<name> <reference> <outputT> <comp>]
-                                     [(test <name>
-                                            (|> (do Monad<Meta>
-                                                  [runtime-bytecode @runtime;generate
-                                                   sampleI (@;generate (#ls;Procedure <name>
-                                                                                      (list (#ls;Deg subject)
-                                                                                            (#ls;Deg param))))]
-                                                  (@eval;eval sampleI))
-                                                (meta;run (init-compiler []))
-                                                (case> (#e;Success valueG)
-                                                       (<comp> (<reference> param subject) (:! <outputT> valueG))
-
-                                                       _
-                                                       false)))]
-
-                                     ["deg +" d.+ Deg  d.=]
-                                     ["deg -" d.- Deg  d.=]
-                                     ["deg *" d.* Deg  d.=]
-                                     ["deg /" d./ Deg  d.=]
-                                     ["deg %" d.% Deg  d.=]
-                                     ["deg =" d.= Bool bool/=]
-                                     ["deg <" d.< Bool bool/=]
-                                     )
-                          <special> (do-template [<name> <reference> <outputT> <comp>]
-                                      [(test <name>
-                                             (|> (do Monad<Meta>
-                                                   [runtime-bytecode @runtime;generate
-                                                    sampleI (@;generate (#ls;Procedure <name>
-                                                                                       (list (#ls;Deg subject)
-                                                                                             (#ls;Nat special))))]
-                                                   (@eval;eval sampleI))
-                                                 (meta;run (init-compiler []))
-                                                 (case> (#e;Success valueG)
-                                                        (<comp> (<reference> special subject) (:! <outputT> valueG))
-
-                                                        _
-                                                        false)))]
-
-                                      ["deg scale"      d.scale      Deg d.=]
-                                      ["deg reciprocal" d.reciprocal Deg d.=]
-                                      )]
-          ($_ seq
-              <nullary>
-              <unary>
-              <binary>
-              <special>
-              )))))
+         subject (|> r;deg (:: @ map above-threshold))]
+        (`` ($_ seq
+                (~~ (do-template [<name> <reference>]
+                      [(test <name>
+                             (|> (do meta;Monad<Meta>
+                                   [sampleI (@;generate (#ls;Procedure <name> (list)))]
+                                   (@eval;eval sampleI))
+                                 (meta;run (init-compiler []))
+                                 (case> (#e;Success valueG)
+                                        (d.= <reference> (:! Deg valueG))
+
+                                        _
+                                        false)))]
+
+                      ["deg min" deg/bottom]
+                      ["deg max" deg/top]
+                      ))
+                (~~ (do-template [<name> <type> <prepare> <comp>]
+                      [(test <name>
+                             (|> (do Monad<Meta>
+                                   [runtime-bytecode @runtime;generate
+                                    sampleI (@;generate (#ls;Procedure <name> (list (#ls;Deg subject))))]
+                                   (@eval;eval sampleI))
+                                 (meta;run (init-compiler []))
+                                 (case> (#e;Success valueG)
+                                        (<comp> (<prepare> subject) (:! <type> valueG))
+
+                                        _
+                                        false)))]
+
+                      ["deg to-frac" Frac deg-to-frac f.=]
+                      ))
+                (~~ (do-template [<name> <reference> <outputT> <comp>]
+                      [(test <name>
+                             (|> (do Monad<Meta>
+                                   [runtime-bytecode @runtime;generate
+                                    sampleI (@;generate (#ls;Procedure <name>
+                                                                       (list (#ls;Deg subject)
+                                                                             (#ls;Deg param))))]
+                                   (@eval;eval sampleI))
+                                 (meta;run (init-compiler []))
+                                 (case> (#e;Success valueG)
+                                        (<comp> (<reference> param subject) (:! <outputT> valueG))
+
+                                        _
+                                        false)))]
+
+                      ["deg +" d.+ Deg  d.=]
+                      ["deg -" d.- Deg  d.=]
+                      ["deg *" d.* Deg  d.=]
+                      ["deg /" d./ Deg  d.=]
+                      ["deg %" d.% Deg  d.=]
+                      ["deg =" d.= Bool bool/=]
+                      ["deg <" d.< Bool bool/=]
+                      ))
+                (~~ (do-template [<name> <reference> <outputT> <comp>]
+                      [(test <name>
+                             (|> (do Monad<Meta>
+                                   [runtime-bytecode @runtime;generate
+                                    sampleI (@;generate (#ls;Procedure <name>
+                                                                       (list (#ls;Deg subject)
+                                                                             (#ls;Nat special))))]
+                                   (@eval;eval sampleI))
+                                 (meta;run (init-compiler []))
+                                 (case> (#e;Success valueG)
+                                        (<comp> (<reference> special subject) (:! <outputT> valueG))
+
+                                        _
+                                        false)))]
+
+                      ["deg scale"      d.scale      Deg d.=]
+                      ["deg reciprocal" d.reciprocal Deg d.=]
+                      ))
+                )))))
diff --git a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux
index c5aad2cae..097c2b802 100644
--- a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux
+++ b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux
@@ -445,7 +445,7 @@
                       (case> (#e;Success outputG)
                              (case (:! (e;Error Top) outputG)
                                (#e;Error error)
-                               (text/= exception-message error)
+                               (text;contains? exception-message error)
 
                                (#e;Success outputG)
                                false)