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/lexer.lux | 119 ++++++++++++++++++++++++++++++++++ source/luxc/parser.lux | 72 +++++++++++++++++++++ source/luxc/util.lux | 169 +++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 360 insertions(+) create mode 100644 source/luxc/lexer.lux create mode 100644 source/luxc/parser.lux create mode 100644 source/luxc/util.lux (limited to 'source/luxc') diff --git a/source/luxc/lexer.lux b/source/luxc/lexer.lux new file mode 100644 index 000000000..ed86be68f --- /dev/null +++ b/source/luxc/lexer.lux @@ -0,0 +1,119 @@ +(use ./util #as &util #refer [do return fail try-all]) + +## [Utils] +(def (lex-regex regex) + ...) + +(def (lex-regex2 regex) + ...) + +(def (lex-prefix prefix) + ...) + +(def (escape-char escaped) + (case escaped + "\\t" (return "\t") + "\\b" (return "\b") + "\\n" (return "\n") + "\\r" (return "\r") + "\\f" (return "\f") + "\\\"" (return "\"") + "\\\\" (return "\\") + _ (fail (fold concat "" (list "[Lexer Error] Unknown escape character: " escaped))))) + +(defrec lex-text-body + (try-all (list (do [[prefix escaped] (lex-regex2 "(?s)^([^\\\"\\\\]*)(\\\\.)") + unescaped (escape-char escaped) + postfix lex-text-body] + (return (str prefix unescaped postfix))) + (lex-regex "(?s)^([^\\\"\\\\]*)^")))) + +(def +ident-re+ ...) + +## [Lexers] +(def lex-white-space + (do [white-space (lex-regex #"^(\s+)")] + (return (#White-Space white-space)))) + +(def lex-single-line-comment + (do [_ (lex-prefix "##") + comment (lex-regex #"^([^\n]*)") + _ (lex-regex #"^(\n?)")] + (return (#Comment comment)))) + +(def lex-multi-line-comment + (do [_ (lex-prefix "#(") + comment (try-all (list (lex-regex #"(?is)^((?!#\().)*?(?=\)#)") + (do [pre (lex-regex #"(?is)^(.+?(?=#\())") + [_ inner] lex-multi-line-comment + post (lex-regex #"(?is)^(.+?(?=\)#))")] + (return (fold concat "" (list pre "#(" inner ")#" post)))))) + _ (lex-prefix ")#")] + (return (#Comment comment)))) + +(def lex-comment + (try-all (list lex-single-line-comment + lex-multi-line-comment))) + +(do-template [ ] + (def + (do [token (lex-regex )] + (return ( token)))) + + lex-bool #Bool #"^(true|false)" + lex-real #Real #"^(0|[1-9][0-9]*)\.[0-9]+" + lex-int #Int #"^(0|[1-9][0-9]*)" + lex-ident #Ident +ident-re+) + +(def lex-char + (do [_ (lex-prefix "#\"") + token (try-all (list (do [escaped (lex-regex #"^(\\.)")] + (escape-char escaped)) + (lex-regex #"^(.)"))) + _ (lex-prefix "\"")] + (return (#Char token)))) + +(def lex-text + (do [_ (lex-prefix "\"") + token lex-text-body + _ (lex-prefix "\"")] + (return (#Text token)))) + +(def lex-tag + (do [_ (lex-prefix "#") + token (lex-regex +ident-re+)] + (return (#Tag token)))) + +(do-template [ ] + (def + (do [_ (lex-prefix )] + (return ))) + + lex-open-paren "(" #Open-Paren + lex-close-paren ")" #Close-Paren + lex-open-bracket "[" #Open-Bracket + lex-close-bracket "]" #Close-Bracket + lex-open-brace "{" #Open-Brace + lex-close-brace "}" #Close-Brace + ) + +(def lex-delimiter + (try-all (list lex-open-paren + lex-close-paren + lex-open-bracket + lex-close-bracket + lex-open-brace + lex-close-brace))) + +;; [Interface] +(def #export lex + (try-all (list lex-white-space + lex-comment + lex-bool + lex-real + lex-int + lex-char + lex-text + lex-ident + lex-tag + lex-delimiter))) diff --git a/source/luxc/parser.lux b/source/luxc/parser.lux new file mode 100644 index 000000000..35ec12b17 --- /dev/null +++ b/source/luxc/parser.lux @@ -0,0 +1,72 @@ +(use ./util #as &util #refer [do return fail try-all repeat]) +(use ./lexer #as &lexer) + +;; [Utils] +(do-template [ ] + (def ( parse) + (do [elems (repeat parse) + token &lexer:lex] + (case token + + (return (list ( (fold ++ (list) elems)))) + + _ + (fail (concat (list "[Parser Error] Unbalanced " ".")))))) + + parse-form #&lexer:Close-Paren "parantheses" #Form + parse-tuple #&lexer:Close-Bracket "brackets" #Tuple + ) + +(def (parse-record parse) + (do [elems* (repeat parse) + token &lexer:lex + #let [elems (fold ++ (list) elems*)]] + (case token + #&lexer:Close-Bracket + (if (odd? (size elems)) + (fail "[Parser Error] Records must have an even number of elements.") + (return (list (#Record elems)))) + + _ + (fail "[Parser Error] Unbalanced braces.")))) + +;; [Interface] +(def parse + (do [token &lexer/lex] + (match token + (#&lexer:White-Space _) + (return (list)) + + (#&lexer:Comment _) + (return (list)) + + (#&lexer:Bool ?value) + (return (list [#Bool (jvm:invokestatic Boolean "parseBoolean" [String] [?value])])) + + (#&lexer:Int ?value) + (return (list [#Int (jvm:invokestatic Integer "parseInt" [String] [?value])])) + + (#&lexer:Real ?value) + (return (list [#Real (jvm:invokestatic Float "parseFloat" [String] [?value])])) + + (#&lexer:Char ?value) + (return (list [#Char (jvm:invokevirtual String "charAt" [int] ?value [0])])) + + (#&lexer:Text ?value) + (return (list [#Text ?value])) + + (#&lexer:Ident ?value) + (return (list [#Ident ?value])) + + (#&lexer:Tag ?value) + (return (list [#Tag ?value])) + + #&lexer:Open-Paren + (parse-form parse) + + #&lexer:Open-Bracket + (parse-tuple parse) + + #&lexer:Open-Brace + (parse-record parse) + ))) 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