aboutsummaryrefslogtreecommitdiff
path: root/source/util.lux
diff options
context:
space:
mode:
Diffstat (limited to 'source/util.lux')
-rw-r--r--source/util.lux169
1 files changed, 169 insertions, 0 deletions
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]))))
+ ))