From 2103b30f37db2aaed472981d2642f4c32c25869c Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 19 Jan 2015 19:38:38 -0400 Subject: [Bugs] - Removed the issue that was causing the compiler to never display the true source of errors. [Enhancements] - Separated the prelude (lux.lux) and utils (util.lux) from the code at test2.lux - The compiler now handles module-separation a bit better [Cleanup] - Removed the unnecessary another.lux [Temporary] - The base classes/interfaces are now assumed to be in the "lux" module, but they must be moved to "lux/host" --- source/another.lux | 4 - source/lux.lux | 259 +++++++++++++++++++++++++++++ source/test2.lux | 480 +---------------------------------------------------- source/util.lux | 169 +++++++++++++++++++ 4 files changed, 435 insertions(+), 477 deletions(-) delete mode 100644 source/another.lux create mode 100644 source/lux.lux create mode 100644 source/util.lux (limited to 'source') diff --git a/source/another.lux b/source/another.lux deleted file mode 100644 index ff5bb6f0a..000000000 --- a/source/another.lux +++ /dev/null @@ -1,4 +0,0 @@ - -## (ann id #type (All [x] (-> [x] x))) -(def (id x) - x) diff --git a/source/lux.lux b/source/lux.lux new file mode 100644 index 000000000..8f02c681d --- /dev/null +++ b/source/lux.lux @@ -0,0 +1,259 @@ +## Base interfaces & classes +(jvm/definterface Function + (: apply (-> [java.lang.Object] java.lang.Object))) + +(jvm/defclass Tuple0 java.lang.Object + []) +(jvm/defclass Tuple1 java.lang.Object + [[java.lang.Object _1]]) +(jvm/defclass Tuple2 java.lang.Object + [[java.lang.Object _1] [java.lang.Object _2]]) +(jvm/defclass Tuple3 java.lang.Object + [[java.lang.Object _1] [java.lang.Object _2] + [java.lang.Object _3]]) +(jvm/defclass Tuple4 java.lang.Object + [[java.lang.Object _1] [java.lang.Object _2] + [java.lang.Object _3] [java.lang.Object _4]]) +(jvm/defclass Tuple5 java.lang.Object + [[java.lang.Object _1] [java.lang.Object _2] + [java.lang.Object _3] [java.lang.Object _4] + [java.lang.Object _5]]) +(jvm/defclass Tuple6 java.lang.Object + [[java.lang.Object _1] [java.lang.Object _2] + [java.lang.Object _3] [java.lang.Object _4] + [java.lang.Object _5] [java.lang.Object _6]]) +(jvm/defclass Tuple7 java.lang.Object + [[java.lang.Object _1] [java.lang.Object _2] + [java.lang.Object _3] [java.lang.Object _4] + [java.lang.Object _5] [java.lang.Object _6] + [java.lang.Object _7]]) +(jvm/defclass Tuple8 java.lang.Object + [[java.lang.Object _1] [java.lang.Object _2] + [java.lang.Object _3] [java.lang.Object _4] + [java.lang.Object _5] [java.lang.Object _6] + [java.lang.Object _7] [java.lang.Object _8]]) + +(jvm/defclass Variant java.lang.Object + [[java.lang.String tag]]) +(jvm/defclass Variant0 lux.Variant + []) +(jvm/defclass Variant1 lux.Variant + [[java.lang.Object _1]]) +(jvm/defclass Variant2 lux.Variant + [[java.lang.Object _1] [java.lang.Object _2]]) +(jvm/defclass Variant3 lux.Variant + [[java.lang.Object _1] [java.lang.Object _2] + [java.lang.Object _3]]) +(jvm/defclass Variant4 lux.Variant + [[java.lang.Object _1] [java.lang.Object _2] + [java.lang.Object _3] [java.lang.Object _4]]) +(jvm/defclass Variant5 lux.Variant + [[java.lang.Object _1] [java.lang.Object _2] + [java.lang.Object _3] [java.lang.Object _4] + [java.lang.Object _5]]) +(jvm/defclass Variant6 lux.Variant + [[java.lang.Object _1] [java.lang.Object _2] + [java.lang.Object _3] [java.lang.Object _4] + [java.lang.Object _5] [java.lang.Object _6]]) +(jvm/defclass Variant7 lux.Variant + [[java.lang.Object _1] [java.lang.Object _2] + [java.lang.Object _3] [java.lang.Object _4] + [java.lang.Object _5] [java.lang.Object _6] + [java.lang.Object _7]]) +(jvm/defclass Variant8 lux.Variant + [[java.lang.Object _1] [java.lang.Object _2] + [java.lang.Object _3] [java.lang.Object _4] + [java.lang.Object _5] [java.lang.Object _6] + [java.lang.Object _7] [java.lang.Object _8]]) + +## Base functions & macros +(defmacro (list xs) + (case xs + #Nil + (#Tag "Nil") + + (#Cons x xs*) + (#Form (#Cons (#Tag "Cons") (#Cons x (#Cons (list xs*) #Nil)))))) + +(def (++ xs ys) + (case xs + #Nil + ys + + (#Cons x xs*) + (#Cons x (++ xs* ys)))) + +(def (map f xs) + (case xs + #Nil + #Nil + + (#Cons x xs*) + (#Cons (f x) (map f xs*)))) + +(def (untemplate-list untemplate tokens) + (case tokens + #Nil + (#Tag "Nil") + + (#Cons token tokens') + (#Form (list (#Tag "Cons") (untemplate token) (untemplate-list untemplate tokens'))))) + +(def (untemplate token) + (case token + (#Bool elem) + (#Form (list (#Tag "Bool") (#Bool elem))) + + (#Int elem) + (#Form (list (#Tag "Int") (#Int elem))) + + (#Real elem) + (#Form (list (#Tag "Real") (#Real elem))) + + (#Char elem) + (#Form (list (#Tag "Char") (#Char elem))) + + (#Text elem) + (#Form (list (#Tag "Text") (#Text elem))) + + (#Tag elem) + (#Form (list (#Tag "Tag") (#Text elem))) + + (#Ident elem) + (#Form (list (#Tag "Ident") (#Text elem))) + + (#Form (#Cons (#Ident "~") (#Cons unquoted #Nil))) + unquoted + + (#Tuple elems) + (#Form (list (#Tag "Tuple") (untemplate-list untemplate elems))) + + (#Form elems) + (#Form (list (#Tag "Form") (untemplate-list untemplate elems))) + )) + + +## I/O +(def (print x) + (jvm/invokevirtual java.io.PrintStream "print" [Object] + (jvm/getstatic System out) [x])) + +(def (println x) + (jvm/invokevirtual java.io.PrintStream "println" [Object] + (jvm/getstatic System out) [x])) + +(defmacro (' form) + (case form + (#Cons token #Nil) + (untemplate token))) + +(def (+ x y) + (jvm/i+ x y)) + +(def inc (+ 1)) + +(def (id x) + x) + +(def (fold f init values) + (case values + #Nil + init + (#Cons x xs) + (fold f (f init x) xs))) + +(def length (fold (lambda [l x] (inc l)) 0)) + +(def (rem dividend divisor) + (jvm/irem dividend divisor)) + +(def (= x y) + (jvm/invokevirtual Object "equals" [Object] + x [y])) + +(def (pairs list) + (case list + (#Cons x (#Cons y list*)) + (#Cons [x y] (pairs list*)) + + _ + #Nil)) + +(def (show x) + (jvm/invokevirtual Object "toString" [] + x [])) + +(def (concat t1 t2) + (jvm/invokevirtual String "concat" [String] + t1 [t2])) + +(def (range from to) + (if (= from to) + #Nil + (#Cons from (range (inc from) to)))) + +(def (text->list text) + (let length (jvm/invokevirtual String "length" [] + text []) + (map (lambda [idx] + (jvm/invokevirtual String "charAt" [int] + text [idx])) + (range 0 length)))) + +(def (cons tail head) + (#Cons head tail)) + +(def (reverse list) + (fold cons #Nil list)) + +(def (enumerate list) + (case (fold (lambda [state x] + (case state + [idx list'] + [(inc idx) (#Cons [idx x] list')])) + [0 #Nil] + list) + [_ list'] + (reverse list'))) + +(def list-map #Nil) + +(def (put key val map) + (case map + #Nil + (#Cons [key val] map) + + (#Cons [?key ?val] map') + (if (= key ?key) + (#Cons [?key val] map') + (#Cons [?key ?val] (put key val map'))))) + +(def (get key map) + (case map + #Nil + #None + + (#Cons [?key ?val] map') + (if (= key ?key) + (#Some ?val) + (get key map')))) + +(def (show-kv kv) + (case kv + [?key ?val] + (fold concat "" (list "#" ?key " " (show ?val))))) + +(def (interpose elem list) + (case list + (#Cons x (#Cons y list')) + (#Cons x (#Cons elem (#Cons y list'))) + + _ + list)) + +(def (show-list xs) + (case xs + #Nil + "#Nil" + (#Cons x xs') + (fold concat "" (list "(#Cons " (show x) " " (show-list xs') ")")))) diff --git a/source/test2.lux b/source/test2.lux index d036bbde4..c72602edb 100644 --- a/source/test2.lux +++ b/source/test2.lux @@ -1,379 +1,4 @@ -## (use "./another" as another) - -(jvm/definterface Function - (: apply (-> [java.lang.Object] java.lang.Object))) - -(jvm/defclass Tuple0 java.lang.Object - []) -(jvm/defclass Tuple1 java.lang.Object - [[java.lang.Object _1]]) -(jvm/defclass Tuple2 java.lang.Object - [[java.lang.Object _1] [java.lang.Object _2]]) -(jvm/defclass Tuple3 java.lang.Object - [[java.lang.Object _1] [java.lang.Object _2] - [java.lang.Object _3]]) -(jvm/defclass Tuple4 java.lang.Object - [[java.lang.Object _1] [java.lang.Object _2] - [java.lang.Object _3] [java.lang.Object _4]]) -(jvm/defclass Tuple5 java.lang.Object - [[java.lang.Object _1] [java.lang.Object _2] - [java.lang.Object _3] [java.lang.Object _4] - [java.lang.Object _5]]) -(jvm/defclass Tuple6 java.lang.Object - [[java.lang.Object _1] [java.lang.Object _2] - [java.lang.Object _3] [java.lang.Object _4] - [java.lang.Object _5] [java.lang.Object _6]]) -(jvm/defclass Tuple7 java.lang.Object - [[java.lang.Object _1] [java.lang.Object _2] - [java.lang.Object _3] [java.lang.Object _4] - [java.lang.Object _5] [java.lang.Object _6] - [java.lang.Object _7]]) -(jvm/defclass Tuple8 java.lang.Object - [[java.lang.Object _1] [java.lang.Object _2] - [java.lang.Object _3] [java.lang.Object _4] - [java.lang.Object _5] [java.lang.Object _6] - [java.lang.Object _7] [java.lang.Object _8]]) - -(jvm/defclass Variant java.lang.Object - [[java.lang.String tag]]) -(jvm/defclass Variant0 test2.Variant - []) -(jvm/defclass Variant1 test2.Variant - [[java.lang.Object _1]]) -(jvm/defclass Variant2 test2.Variant - [[java.lang.Object _1] [java.lang.Object _2]]) -(jvm/defclass Variant3 test2.Variant - [[java.lang.Object _1] [java.lang.Object _2] - [java.lang.Object _3]]) -(jvm/defclass Variant4 test2.Variant - [[java.lang.Object _1] [java.lang.Object _2] - [java.lang.Object _3] [java.lang.Object _4]]) -(jvm/defclass Variant5 test2.Variant - [[java.lang.Object _1] [java.lang.Object _2] - [java.lang.Object _3] [java.lang.Object _4] - [java.lang.Object _5]]) -(jvm/defclass Variant6 test2.Variant - [[java.lang.Object _1] [java.lang.Object _2] - [java.lang.Object _3] [java.lang.Object _4] - [java.lang.Object _5] [java.lang.Object _6]]) -(jvm/defclass Variant7 test2.Variant - [[java.lang.Object _1] [java.lang.Object _2] - [java.lang.Object _3] [java.lang.Object _4] - [java.lang.Object _5] [java.lang.Object _6] - [java.lang.Object _7]]) -(jvm/defclass Variant8 test2.Variant - [[java.lang.Object _1] [java.lang.Object _2] - [java.lang.Object _3] [java.lang.Object _4] - [java.lang.Object _5] [java.lang.Object _6] - [java.lang.Object _7] [java.lang.Object _8]]) - -(def (print x) - (jvm/invokevirtual java.io.PrintStream "print" [Object] - (jvm/getstatic System out) [x])) - -(def (println x) - (jvm/invokevirtual java.io.PrintStream "println" [Object] - (jvm/getstatic System out) [x])) - -(defmacro (list xs) - (case xs - #Nil - (#Tag "Nil") - - (#Cons x xs*) - (#Form (#Cons (#Tag "Cons") (#Cons x (#Cons (list xs*) #Nil)))))) - -(def (++ xs ys) - (case xs - #Nil - ys - - (#Cons x xs*) - (#Cons x (++ xs* ys)))) - -(def (map f xs) - (case xs - #Nil - #Nil - - (#Cons x xs*) - (#Cons (f x) (map f xs*)))) - -(def (untemplate-list untemplate tokens) - (case tokens - #Nil - (#Tag "Nil") - - (#Cons token tokens') - (#Form (list (#Tag "Cons") (untemplate token) (untemplate-list untemplate tokens'))))) - -(def (untemplate token) - (case token - (#Bool elem) - (#Form (list (#Tag "Bool") (#Bool elem))) - - (#Int elem) - (#Form (list (#Tag "Int") (#Int elem))) - - (#Real elem) - (#Form (list (#Tag "Real") (#Real elem))) - - (#Char elem) - (#Form (list (#Tag "Char") (#Char elem))) - - (#Text elem) - (#Form (list (#Tag "Text") (#Text elem))) - - (#Tag elem) - (#Form (list (#Tag "Tag") (#Text elem))) - - (#Ident elem) - (#Form (list (#Tag "Ident") (#Text elem))) - - (#Form (#Cons (#Ident "~") (#Cons unquoted #Nil))) - unquoted - - (#Tuple elems) - (#Form (list (#Tag "Tuple") (untemplate-list untemplate elems))) - - (#Form elems) - (#Form (list (#Tag "Form") (untemplate-list untemplate elems))) - )) - -(defmacro (' form) - (case form - (#Cons token #Nil) - (untemplate token))) - -## Utils -(def (fail* message) - (#Failure message)) - -(def (return* state value) - (#Ok [state value])) - -(def (fail message) - (lambda [state] - (#Failure message))) - -(def (return value) - (lambda [state] - (#Ok [state value]))) - -(def (bind m-value step) - (lambda [state] - (let inputs (m-value state) - (case inputs - (#Ok [?state ?datum]) - (step ?datum ?state) - - _ - inputs)))) - -(def (+ x y) - (jvm/i+ x y)) - -(def inc (+ 1)) - -(def (id x) - x) - -(def (fold f init values) - (case values - #Nil - init - (#Cons x xs) - (fold f (f init x) xs))) - -(def length (fold (lambda [l x] (inc l)) 0)) - -(def (rem dividend divisor) - (jvm/irem dividend divisor)) - -(def (= x y) - (jvm/invokevirtual Object "equals" [Object] - x [y])) - -(def (as-pairs list) - (case list - (#Cons x (#Cons y list*)) - (#Cons [x y] (as-pairs list*)) - - _ - #Nil)) - -## Ideally, this is what I want... -## (exec [yolo lol -## #let [foo (bar 1 2 3)]] -## (meme yolo foo)) - -(defmacro (exec tokens) - (case tokens - (#Cons (#Tuple steps) (#Cons return #Nil)) - (if (= 0 (rem (length steps) 2)) - (fold (lambda [inner pair] - (case pair - [label computation] - (' (bind (~ computation) - (lambda [(~ label)] (~ inner)))))) - return - (as-pairs steps)) - (#Text "Oh no!")))) - -(def (try-m monad) - (lambda [state] - (case (monad state) - (#Ok [?state ?datum]) - (return* ?state (#Just ?datum)) - - (#Failure _) - (return* state #Nothing)))) - -(def (repeat-m monad) - (lambda [state] - (case (monad state) - (#Ok [?state ?head]) - (case ((repeat-m monad) ?state) - (#Ok [?state* ?tail]) - (return* ?state* (#Cons ?head ?tail))) - - (#Failure ?message) - (return* state #Nil)))) - -(def (try-all-m monads) - (lambda [state] - (case monads - #Nil - (fail* "No alternative worked!") - (#Cons monad monads') - (let output (monad state) - (case output - (#Ok _) - output - - (#Failure _) - (case monads' - #Nil - output - (#Cons _ _) - ((try-all-m monads') state)) - )) - ))) - -(def (map-m f inputs) - (case inputs - #Nil - (return #Nil) - (#Cons input inputs') - (exec [output (f input) - outputs (map-m f inputs')] - (return (#Cons output outputs))))) - -(def (fold-m f init inputs) - (case inputs - #Nil (return init) - (#Cons x inputs') (exec [init* (f init x)] - (fold-m f init* inputs')))) - -(def (apply-m monad call-state) - (lambda [state] - (let output (monad call-state) - (case output - (#Ok [?state ?datum]) - (#Ok [state ?datum]) - - _ - output)))) - -(def (assert test message) - (if test - (return []) - (fail message))) - -(def (pass %value) - (lambda [state] - %value)) - -(def get-state - (lambda [state] - (return* state state))) - -(def (show x) - (jvm/invokevirtual Object "toString" [] - x [])) - -(def (concat t1 t2) - (jvm/invokevirtual String "concat" [String] - t1 [t2])) - -(def (normalize-char char) - (case char - #"*" "_ASTER_" - #"+" "_PLUS_" - #"-" "_DASH_" - #"/" "_SLASH_" - #"_" "_UNDERS_" - #"%" "_PERCENT_" - #"$" "_DOLLAR_" - #"'" "_QUOTE_" - #"`" "_BQUOTE_" - #"@" "_AT_" - #"^" "_CARET_" - #"&" "_AMPERS_" - #"=" "_EQ_" - #"!" "_BANG_" - #"?" "_QM_" - #":" "_COLON_" - #";" "_SCOLON_" - #"." "_PERIOD_" - #"," "_COMMA_" - #"<" "_LT_" - #">" "_GT_" - #"~" "_TILDE_" - ##;;#"\" "_BSLASH_" - _ (show char) - )) - -(def (range from to) - (if (= from to) - #Nil - (#Cons from (range (inc from) to)))) - -(def (text->list text) - (let length (jvm/invokevirtual String "length" [] - text []) - (map (lambda [idx] - (jvm/invokevirtual String "charAt" [int] - text [idx])) - (range 0 length)))) - -(def (normalize-ident ident) - (fold concat "" (map normalize-char (text->list ident)))) - -(def (fresh-class-loader path) - (let file (jvm/new java.io.File [String] [path]) - (let url (jvm/invokevirtual java.io.File "toURL" [] - file []) - (let urls (jvm/new-array java.net.URL 1) - (do (jvm/aastore urls 0 url) - (jvm/new java.net.URLClassLoader [(Array java.net.URL)] [urls])))) - )) - -(def (cons tail head) - (#Cons head tail)) - -(def (reverse list) - (fold cons #Nil list)) - -(def (enumerate list) - (case (fold (lambda [state x] - (case state - [idx list'] - [(inc idx) (#Cons [idx x] list')])) - [0 #Nil] - list) - [_ list'] - (reverse list'))) +(use "./util" as util) (def (print-enum enum) (case enum @@ -384,108 +9,17 @@ (do (print "[") (print idx) (print ":") (print x) (print "]") (print " ") (print-enum enum')))) -(def get-state - (lambda [state] - (#Ok [state state]))) - -(def list-map #Nil) - -(def (put key val map) - (case map - #Nil - (#Cons [key val] map) - - (#Cons [?key ?val] map') - (if (= key ?key) - (#Cons [?key val] map') - (#Cons [?key ?val] (put key val map'))))) - -(def (get key map) - (case map - #Nil - #None - - (#Cons [?key ?val] map') - (if (= key ?key) - (#Some ?val) - (get key map')))) - -(def (show-kv kv) - (case kv - [?key ?val] - (fold concat "" (list "#" ?key " " (show ?val))))) - -(def (within slot monad) - (lambda [state] - (let =return (monad (get slot state)) - (case =return - (#Ok ?state ?value) - (#Ok (put slot ?state state) ?value) - - _ - =return)))) - -(def monadic-dup - (exec [foo get-state - bar get-state - baz (return 1000)] - (return (+ (+ foo bar) baz)))) - -(def (run-state monad state) - (monad state)) - -(def (interpose elem list) - (case list - (#Cons x (#Cons y list')) - (#Cons x (#Cons elem (#Cons y list'))) - - _ - list)) +#((def monadic-dup + (util/exec [foo get-state + bar get-state + baz (util/return 1000)] + (util/return (+ (+ foo bar) baz)))))# (def (print-map list-map) (do (print "{") (print (fold concat "" (interpose " " (map show-kv list-map)))) (println "}"))) -(def (show-list xs) - (case xs - #Nil - "#Nil" - (#Cons x xs') - (fold concat "" (list "(#Cons " (show x) " " (show-list xs') ")")))) - ## Program (def (main args) - (case (' ((~ "Oh yeah..."))) - (#Form (#Cons text #Nil)) - (do (println text) - (println (+ 10 20)) - (println (inc 10)) - (println (jvm/i- 10 20)) - (println (jvm/i* 10 20)) - (println (jvm/i/ 10 2)) - (let xs (list 1 2 3 4 5 6 7 8 9) - (do (println (fold + 0 xs)) - (println (length xs)))) - (println (rem 21 6)) - (println (rem 21 7)) - (println (= false false)) - (println (= false true)) - (println (= true false)) - (println (= true true)) - (case (run-state monadic-dup 123) - (#Ok [_ ?value]) - (println ?value) - - (#Failure ?message) - (println ?message)) - (print-enum (enumerate (list #"a" #"b" #"c" #"d" #"e"))) - (print-map (put "Nyan" "cat" (put "Yolo" "lol" list-map))) - (let char #"*" - (do (print (show char)) (print " -> ") - (println (normalize-char char)))) - (println (show-list (range 0 10))) - (println (normalize-ident "text->list")) - (println (fresh-class-loader "./")) - ) - )) + (println "Hello, world!")) diff --git a/source/util.lux b/source/util.lux new file mode 100644 index 000000000..88b035571 --- /dev/null +++ b/source/util.lux @@ -0,0 +1,169 @@ +(def (fail* message) + (#Failure message)) + +(def (return* state value) + (#Ok [state value])) + +(def (fail message) + (lambda [state] + (#Failure message))) + +(def (return value) + (lambda [state] + (#Ok [state value]))) + +(def (bind m-value step) + (lambda [state] + (let inputs (m-value state) + (case inputs + (#Ok [?state ?datum]) + (step ?datum ?state) + + _ + inputs)))) + +## Ideally, this is what I want... +## (exec [yolo lol +## #let [foo (bar 1 2 3)]] +## (meme yolo foo)) + +(defmacro (exec tokens) + (case tokens + (#Cons (#Tuple steps) (#Cons value #Nil)) + (fold (lambda [inner pair] + (case pair + [label computation] + (' (bind (~ computation) (lambda [(~ label)] (~ inner)))))) + value + (pairs steps)))) + +(def (try-m monad) + (lambda [state] + (case (monad state) + (#Ok [?state ?datum]) + (return* ?state (#Just ?datum)) + + (#Failure _) + (return* state #Nothing)))) + +(def (repeat-m monad) + (lambda [state] + (case (monad state) + (#Ok [?state ?head]) + (case ((repeat-m monad) ?state) + (#Ok [?state* ?tail]) + (return* ?state* (#Cons ?head ?tail))) + + (#Failure ?message) + (return* state #Nil)))) + +(def (try-all-m monads) + (lambda [state] + (case monads + #Nil + (fail* "No alternative worked!") + (#Cons monad monads') + (let output (monad state) + (case output + (#Ok _) + output + + (#Failure _) + (case monads' + #Nil + output + (#Cons _ _) + ((try-all-m monads') state)) + )) + ))) + +(def (map-m f inputs) + (case inputs + #Nil + (return #Nil) + (#Cons input inputs') + (exec [output (f input) + outputs (map-m f inputs')] + (return (#Cons output outputs))))) + +(def (fold-m f init inputs) + (case inputs + #Nil (return init) + (#Cons x inputs') (exec [init* (f init x)] + (fold-m f init* inputs')))) + +(def (apply-m monad call-state) + (lambda [state] + (let output (monad call-state) + (case output + (#Ok [?state ?datum]) + (#Ok [state ?datum]) + + _ + output)))) + +(def (assert test message) + (if test + (return []) + (fail message))) + +(def (pass %value) + (lambda [state] + %value)) + +(def get-state + (lambda [state] + (return* state state))) + +(def (normalize-char char) + (case char + #"*" "_ASTER_" + #"+" "_PLUS_" + #"-" "_DASH_" + #"/" "_SLASH_" + #"_" "_UNDERS_" + #"%" "_PERCENT_" + #"$" "_DOLLAR_" + #"'" "_QUOTE_" + #"`" "_BQUOTE_" + #"@" "_AT_" + #"^" "_CARET_" + #"&" "_AMPERS_" + #"=" "_EQ_" + #"!" "_BANG_" + #"?" "_QM_" + #":" "_COLON_" + #";" "_SCOLON_" + #"." "_PERIOD_" + #"," "_COMMA_" + #"<" "_LT_" + #">" "_GT_" + #"~" "_TILDE_" + ##;;#"\" "_BSLASH_" + _ (show char) + )) + +(def (normalize-ident ident) + (fold concat "" (map normalize-char (text->list ident)))) + +(def (within slot monad) + (lambda [state] + (let =return (monad (get slot state)) + (case =return + (#Ok ?state ?value) + (#Ok (put slot ?state state) ?value) + + _ + =return)))) + +(def (run-state monad state) + (monad state)) + +(def (fresh-class-loader path) + (let file (jvm/new java.io.File [String] [path]) + (let url (jvm/invokevirtual java.io.File "toURL" [] + file []) + (let urls (jvm/new-array java.net.URL 1) + (do (jvm/aastore urls 0 url) + (jvm/new java.net.URLClassLoader [(Array java.net.URL)] [urls])))) + )) -- cgit v1.2.3