diff options
10 files changed, 50 insertions, 107 deletions
diff --git a/new-luxc/source/luxc/lang/translation/common-lisp/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/common-lisp/procedure/common.jvm.lux index 43ef5c384..b7dd1b58a 100644 --- a/new-luxc/source/luxc/lang/translation/common-lisp/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/common-lisp/procedure/common.jvm.lux @@ -105,10 +105,6 @@ Trinary (caseT.translate-if testO thenO elseO)) -(def: (lux//noop valueO) - Unary - valueO) - (exception: #export (Wrong-Syntax {message Text}) message) @@ -138,7 +134,6 @@ (def: lux-procs Bundle (|> (dict.new text.Hash<Text>) - (install "noop" (unary lux//noop)) (install "is" (binary lux//is)) (install "try" (unary runtimeT.lux//try)) (install "if" (trinary lux//if)) diff --git a/new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux index 7b4a19b91..1d4e0e5c4 100644 --- a/new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux @@ -116,10 +116,6 @@ Unary (format runtimeT.lux//try "(" riskyJS ")")) -(def: (lux//noop valueJS) - Unary - valueJS) - (exception: #export (Wrong-Syntax {message Text}) message) @@ -413,7 +409,6 @@ (def: lux-procs Bundle (|> (dict.new text.Hash<Text>) - (install "noop" (unary lux//noop)) (install "is" (binary lux//is)) (install "try" (unary lux//try)) (install "if" (trinary lux//if)) diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux index 7daf35fb5..db92bc413 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux @@ -164,10 +164,6 @@ ($t.method (list $Function) (#.Some $Object-Array) (list)) false))) -(def: (lux//noop valueI) - Unary - valueI) - (exception: #export (Wrong-Syntax {message Text}) message) @@ -553,7 +549,6 @@ (def: lux-procs Bundle (|> (dict.new text.Hash<Text>) - (install "noop" (unary lux//noop)) (install "is" (binary lux//is)) (install "try" (unary lux//try)) (install "if" (trinary lux//if)) diff --git a/new-luxc/source/luxc/lang/translation/lua/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/lua/procedure/common.jvm.lux index b49d4951c..21baddcfc 100644 --- a/new-luxc/source/luxc/lang/translation/lua/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/lua/procedure/common.jvm.lux @@ -108,10 +108,6 @@ Unary (runtimeT.lux//try riskyO)) -(def: (lux//noop valueO) - Unary - valueO) - (exception: #export (Wrong-Syntax {message Text}) message) @@ -402,7 +398,6 @@ (def: lux-procs Bundle (|> (dict.new text.Hash<Text>) - (install "noop" (unary lux//noop)) (install "is" (binary lux//is)) (install "try" (unary lux//try)) (install "if" (trinary lux//if)) diff --git a/new-luxc/source/luxc/lang/translation/php/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/php/procedure/common.jvm.lux index 0e0931b1e..8ce6fe1ef 100644 --- a/new-luxc/source/luxc/lang/translation/php/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/php/procedure/common.jvm.lux @@ -109,10 +109,6 @@ ## Unary ## (runtimeT.lux//try riskyO)) -## (def: (lux//noop valueO) -## Unary -## valueO) - ## (exception: #export (Wrong-Syntax {message Text}) ## message) @@ -142,7 +138,6 @@ ## (def: lux-procs ## Bundle ## (|> (dict.new text.Hash<Text>) -## (install "noop" (unary lux//noop)) ## (install "is" (binary lux//is)) ## (install "try" (unary lux//try)) ## (install "if" (trinary lux//if)) diff --git a/new-luxc/source/luxc/lang/translation/python/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/python/procedure/common.jvm.lux index a83a897d1..f63371bd1 100644 --- a/new-luxc/source/luxc/lang/translation/python/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/python/procedure/common.jvm.lux @@ -109,10 +109,6 @@ Unary (runtimeT.lux//try riskyO)) -(def: (lux//noop valueO) - Unary - valueO) - (exception: #export (Wrong-Syntax {message Text}) message) @@ -142,7 +138,6 @@ (def: lux-procs Bundle (|> (dict.new text.Hash<Text>) - (install "noop" (unary lux//noop)) (install "is" (binary lux//is)) (install "try" (unary lux//try)) (install "if" (trinary lux//if)) diff --git a/new-luxc/source/luxc/lang/translation/r/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/r/procedure/common.jvm.lux index 885837078..022e1ea16 100644 --- a/new-luxc/source/luxc/lang/translation/r/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/r/procedure/common.jvm.lux @@ -110,10 +110,6 @@ Unary (runtimeT.lux//try riskyO)) -(def: (lux//noop valueO) - Unary - valueO) - (exception: #export (Wrong-Syntax {message Text}) message) @@ -143,7 +139,6 @@ (def: lux-procs Bundle (|> (dict.new text.Hash<Text>) - (install "noop" (unary lux//noop)) (install "is" (binary lux//is)) (install "try" (unary lux//try)) (install "if" (trinary lux//if)) diff --git a/new-luxc/source/luxc/lang/translation/ruby/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/ruby/procedure/common.jvm.lux index f26cefad6..7a9dfcb08 100644 --- a/new-luxc/source/luxc/lang/translation/ruby/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/ruby/procedure/common.jvm.lux @@ -108,10 +108,6 @@ Unary (runtimeT.lux//try riskyO)) -(def: (lux//noop valueO) - Unary - valueO) - (exception: #export (Wrong-Syntax {message Text}) message) @@ -141,7 +137,6 @@ (def: lux-procs Bundle (|> (dict.new text.Hash<Text>) - (install "noop" (unary lux//noop)) (install "is" (binary lux//is)) (install "try" (unary lux//try)) (install "if" (trinary lux//if)) diff --git a/new-luxc/test/test/luxc/lang/translation/jvm.lux b/new-luxc/test/test/luxc/lang/translation/jvm.lux index ae66b68af..6652c8484 100644 --- a/new-luxc/test/test/luxc/lang/translation/jvm.lux +++ b/new-luxc/test/test/luxc/lang/translation/jvm.lux @@ -130,9 +130,9 @@ (with-expansions [<tests> (do-template [<procedure> <reference>] [(test <procedure> (|> (do macro.Monad<Meta> - [sampleI (expressionT.translate (` (<post> ((~ (code.text <procedure>)) - (<pre> (~ (<tag> subject))) - (<pre> (~ (<tag> param)))))))] + [sampleI (expressionT.translate (<post> ((code.text <procedure>) + (<pre> (<tag> subject)) + (<pre> (<tag> param)))))] (evalT.eval sampleI)) (lang.with-current-module "") (macro.run (io.run init-jvm)) @@ -154,9 +154,9 @@ )))))] ["int" gen-int code.int Int i/= (i/* 10) i/+ i/- i/* i// i/% "jvm convert long-to-int" "jvm convert int-to-long"] - ["long" gen-int code.int Int i/= (i/* 10) i/+ i/- i/* i// i/% "lux noop" "lux noop"] + ["long" gen-int code.int Int i/= (i/* 10) i/+ i/- i/* i// i/% id id] ["float" gen-frac code.frac Frac f/= (f/* 10.0) f/+ f/- f/* f// f/% "jvm convert double-to-float" "jvm convert float-to-double"] - ["double" gen-frac code.frac Frac f/= (f/* 10.0) f/+ f/- f/* f// f/% "lux noop" "lux noop"] + ["double" gen-frac code.frac Frac f/= (f/* 10.0) f/+ f/- f/* f// f/% id id] ) (do-template [<domain> <post> <convert>] @@ -169,9 +169,9 @@ (~~ (do-template [<procedure> <reference>] [(test <procedure> (|> (do macro.Monad<Meta> - [sampleI (expressionT.translate (` (<post> ((~ (code.text <procedure>)) - (<convert> (~ (code.nat subject))) - (<convert> (~ (code.nat param)))))))] + [sampleI (expressionT.translate (<post> ((code.text <procedure>) + (<convert> (code.nat subject)) + (<convert> (code.nat param)))))] (evalT.eval sampleI)) (lang.with-current-module "") (macro.run (io.run init-jvm)) @@ -189,7 +189,7 @@ )))))] ["int" "jvm convert int-to-long" "jvm convert long-to-int"] - ["long" "lux noop" "lux noop"] + ["long" id id] ) (do-template [<domain> <post> <convert>] @@ -203,9 +203,9 @@ (~~ (do-template [<procedure> <reference> <type> <test> <pre-subject> <pre>] [(test <procedure> (|> (do macro.Monad<Meta> - [sampleI (expressionT.translate (` (<post> ((~ (code.text <procedure>)) - (<convert> (~ (<pre> subject))) - ("jvm convert long-to-int" (~ (code.nat shift)))))))] + [sampleI (expressionT.translate (<post> ((code.text <procedure>) + (<convert> (<pre> subject)) + ("jvm convert long-to-int" (code.nat shift)))))] (evalT.eval sampleI)) (lang.with-current-module "") (macro.run (io.run init-jvm)) @@ -223,7 +223,7 @@ )))))] ["int" "jvm convert int-to-long" "jvm convert long-to-int"] - ["long" "lux noop" "lux noop"] + ["long" id id] ) (do-template [<domain> <generator> <tag> <=> <<> <pre>] @@ -235,9 +235,9 @@ (with-expansions [<tests> (do-template [<procedure> <reference>] [(test <procedure> (|> (do macro.Monad<Meta> - [sampleI (expressionT.translate (` ((~ (code.text <procedure>)) - (<pre> (~ (<tag> subject))) - (<pre> (~ (<tag> param))))))] + [sampleI (expressionT.translate ((code.text <procedure>) + (<pre> (<tag> subject)) + (<pre> (<tag> param))))] (evalT.eval sampleI)) (lang.with-current-module "") (macro.run (io.run init-jvm)) @@ -256,9 +256,9 @@ )))))] ["int" gen-int code.int i/= i/< "jvm convert long-to-int"] - ["long" gen-int code.int i/= i/< "lux noop"] + ["long" gen-int code.int i/= i/< id] ["float" gen-frac code.frac f/= f/< "jvm convert double-to-float"] - ["double" gen-frac code.frac f/= f/< "lux noop"] + ["double" gen-frac code.frac f/= f/< id] ["char" gen-int code.int i/= i/< "jvm convert long-to-char"] ) @@ -293,9 +293,7 @@ [sampleI (expressionT.translate (|> (jvm//array//new +0 <class> size) (jvm//array//write <class> idx <input>) (jvm//array//read <class> idx) - (~) - <post> - (`)))] + <post>))] (evalT.eval sampleI)) (lang.with-current-module "") (macro.run (io.run init-jvm)) @@ -306,7 +304,7 @@ false)))] ["boolean" Bool valueZ bool/= (code.bool valueZ) - "lux noop"] + id] ["byte" Int valueB i/= (|> (code.int valueB) (~) "jvm convert long-to-byte" (`)) "jvm convert byte-to-long"] ["short" Int valueS i/= (|> (code.int valueS) (~) "jvm convert long-to-short" (`)) @@ -314,11 +312,11 @@ ["int" Int valueI i/= (|> (code.int valueI) (~) "jvm convert long-to-int" (`)) "jvm convert int-to-long"] ["long" Int valueL i/= (code.int valueL) - "lux noop"] + id] ["float" Frac valueF f/= (|> (code.frac valueF) (~) "jvm convert double-to-float" (`)) "jvm convert float-to-double"] ["double" Frac valueD f/= (code.frac valueD) - "lux noop"] + id] )] ($_ seq <array> @@ -343,9 +341,7 @@ [sampleI (expressionT.translate (|> (jvm//array//new +0 <class> size) (jvm//array//write <class> idx <input>) (jvm//array//read <class> idx) - (~) - <post> - (`)))] + <post>))] (evalT.eval sampleI)) (lang.with-current-module "") (macro.run (io.run init-jvm)) @@ -360,7 +356,7 @@ "jvm convert char-to-long"] ["java.lang.Long" Int valueL i/= (code.int valueL) - "lux noop"] + id] )] ($_ seq <array> diff --git a/stdlib/source/lux/type/abstract.lux b/stdlib/source/lux/type/abstract.lux index 0cbe49087..70a71c60b 100644 --- a/stdlib/source/lux/type/abstract.lux +++ b/stdlib/source/lux/type/abstract.lux @@ -3,9 +3,9 @@ (lux (control [monad #+ do Monad] ["p" parser]) (data [text "text/" Eq<Text> Monoid<Text>] - ["E" error] + [error] (coll [list "list/" Functor<List> Monoid<List>])) - [macro] + [macro #+ "meta/" Monad<Meta>] (macro [code] ["s" syntax #+ syntax:] (syntax ["cs" common] @@ -57,43 +57,36 @@ (|>> ($_ text/compose "{" kind "@" module "}") (let [[module kind] (ident-for #..Representation)]))) +(def: (cast name type-vars input-declaration output-declaration) + (-> Text (List Code) Code Code Macro) + (function (_ tokens) + (case tokens + (^ (list value)) + (meta/wrap (list (` ((: (All [(~+ type-vars)] + (-> (~ input-declaration) (~ output-declaration))) + (|>> :assume)) + (~ value))))) + + _ + (macro.fail ($_ text/compose "Wrong syntax for " name))))) + (def: (install-casts' this-module-name name type-vars) (-> Text Text (List Text) (Meta Any)) (do macro.Monad<Meta> [this-module (macro.find-module this-module-name) #let [type-varsC (list/map code.local-symbol type-vars) - abstract-declaration (` ((~ (code.local-symbol name)) (~+ type-varsC))) + abstraction-declaration (` ((~ (code.local-symbol name)) (~+ type-varsC))) representation-declaration (` ((~ (code.local-symbol (representation-name name))) (~+ type-varsC))) this-module (|> this-module (update@ #.definitions (put down-cast (: Definition [Macro macro-anns - (: Macro - (function (_ tokens) - (case tokens - (^ (list value)) - (wrap (list (` ((: (All [(~+ type-varsC)] - (-> (~ representation-declaration) (~ abstract-declaration))) - (|>> :assume)) - (~ value))))) - - _ - (macro.fail ($_ text/compose "Wrong syntax for " down-cast)))))]))) + (cast down-cast type-varsC representation-declaration abstraction-declaration)]))) (update@ #.definitions (put up-cast (: Definition [Macro macro-anns - (: Macro - (function (_ tokens) - (case tokens - (^ (list value)) - (wrap (list (` ((: (All [(~+ type-varsC)] - (-> (~ abstract-declaration) (~ representation-declaration))) - (|>> :assume)) - (~ value))))) - - _ - (macro.fail ($_ text/compose "Wrong syntax for " up-cast)))))]))))]] + (cast up-cast type-varsC abstraction-declaration representation-declaration)]))))]] (function (_ compiler) - (#E.Success [(update@ #.modules (put this-module-name this-module) compiler) - []])))) + (#error.Success [(update@ #.modules (put this-module-name this-module) compiler) + []])))) (def: (un-install-casts' this-module-name) (-> Text (Meta Any)) @@ -103,8 +96,8 @@ (update@ #.definitions (remove down-cast)) (update@ #.definitions (remove up-cast)))]] (function (_ compiler) - (#E.Success [(update@ #.modules (put this-module-name this-module) compiler) - []])))) + (#error.Success [(update@ #.modules (put this-module-name this-module) compiler) + []])))) (syntax: (install-casts {name s.local-symbol} {type-vars (s.tuple (p.some s.local-symbol))}) @@ -119,10 +112,7 @@ (wrap (list))) _ - (macro.fail ($_ text/compose - "Cannot temporarily define casting functions (" - down-cast " & " up-cast - ") because definitions like that already exist."))))) + (macro.fail ($_ text/compose "Cannot temporarily define casting functions (" down-cast " & " up-cast ") because definitions like that already exist."))))) (syntax: (un-install-casts) (do macro.Monad<Meta> @@ -136,10 +126,7 @@ (wrap (list))) _ - (macro.fail ($_ text/compose - "Cannot un-define casting functions (" - down-cast " & " up-cast - ") because they do not exist."))))) + (macro.fail ($_ text/compose "Cannot un-define casting functions (" down-cast " & " up-cast ") because they do not exist."))))) (def: declaration (s.Syntax [Text (List Text)]) @@ -154,9 +141,9 @@ {primitives (p.some s.any)}) (let [hidden-name (representation-name name) type-varsC (list/map code.local-symbol type-vars) - abstract-declaration (` ((~ (code.local-symbol name)) (~+ type-varsC))) + abstraction-declaration (` ((~ (code.local-symbol name)) (~+ type-varsC))) representation-declaration (` ((~ (code.local-symbol hidden-name)) (~+ type-varsC)))] - (wrap (list& (` (type: (~+ (csw.export export)) (~ abstract-declaration) + (wrap (list& (` (type: (~+ (csw.export export)) (~ abstraction-declaration) (~ (csw.annotations annotations)) (primitive (~ (code.text hidden-name)) [(~+ type-varsC)]))) (` (type: (~+ (csw.export export)) (~ representation-declaration) |