From 38fe9e91f451d9682ff7edf65fc395b85ddde961 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Tue, 10 Feb 2015 02:04:46 -0400
Subject: Super refactoring that breaks the system: Part 1

---
 source/luxc/util.lux | 169 +++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 169 insertions(+)
 create mode 100644 source/luxc/util.lux

(limited to 'source/luxc/util.lux')

diff --git a/source/luxc/util.lux b/source/luxc/util.lux
new file mode 100644
index 000000000..88b035571
--- /dev/null
+++ b/source/luxc/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