aboutsummaryrefslogtreecommitdiff
path: root/source
diff options
context:
space:
mode:
Diffstat (limited to 'source')
-rw-r--r--source/another.lux4
-rw-r--r--source/lux.lux259
-rw-r--r--source/test2.lux480
-rw-r--r--source/util.lux169
4 files changed, 435 insertions, 477 deletions
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]))))
+ ))