From 296d087530cb142efec1dea159770346bb43c3c0 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 15 Nov 2017 19:51:33 -0400 Subject: - Heavy refactoring. --- new-luxc/source/luxc/lang.lux | 245 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 245 insertions(+) create mode 100644 new-luxc/source/luxc/lang.lux (limited to 'new-luxc/source/luxc/lang.lux') diff --git a/new-luxc/source/luxc/lang.lux b/new-luxc/source/luxc/lang.lux new file mode 100644 index 000000000..373c6b12b --- /dev/null +++ b/new-luxc/source/luxc/lang.lux @@ -0,0 +1,245 @@ +(;module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [maybe] + [product] + ["e" error] + [text "text/" Eq] + text/format + (coll [list])) + [meta] + (meta (type ["tc" check]) + ["s" syntax #+ syntax:])) + (luxc (lang ["la" analysis]))) + +(type: #export Eval + (-> Type Code (Meta Top))) + +(type: #export Analyser + (-> Code (Meta la;Analysis))) + +(def: #export version Text "0.6.0") + +(def: #export (fail message) + (All [a] (-> Text (Meta a))) + (do meta;Monad + [[file line col] meta;cursor + #let [location (format file + "," (|> line nat-to-int %i) + "," (|> col nat-to-int %i))]] + (meta;fail (format message "\n\n" + "@ " location)))) + +(def: #export (throw exception message) + (All [a] (-> ex;Exception Text (Meta a))) + (fail (exception message))) + +(syntax: #export (assert exception message test) + (wrap (list (` (if (~ test) + (:: meta;Monad (~' wrap) []) + (;;throw (~ exception) (~ message))))))) + +(def: #export (with-expected-type expected action) + (All [a] (-> Type (Meta a) (Meta a))) + (function [compiler] + (case (action (set@ #;expected (#;Some expected) compiler)) + (#e;Success [compiler' output]) + (let [old-expected (get@ #;expected compiler)] + (#e;Success [(set@ #;expected old-expected compiler') + output])) + + (#e;Error error) + (#e;Error error)))) + +(def: #export (with-type-env action) + (All [a] (-> (tc;Check a) (Meta a))) + (function [compiler] + (case (action (get@ #;type-context compiler)) + (#e;Error error) + ((fail error) compiler) + + (#e;Success [context' output]) + (#e;Success [(set@ #;type-context context' compiler) + output])))) + +(def: #export (with-fresh-type-env action) + (All [a] (-> (Meta a) (Meta a))) + (function [compiler] + (let [old (get@ #;type-context compiler)] + (case (action (set@ #;type-context tc;fresh-context compiler)) + (#e;Success [compiler' output]) + (#e;Success [(set@ #;type-context old compiler') + output]) + + output + output)))) + +(def: #export (infer actualT) + (-> Type (Meta Unit)) + (do meta;Monad + [expectedT meta;expected-type] + (with-type-env + (tc;check expectedT actualT)))) + +(def: #export (pl-get key table) + (All [a] (-> Text (List [Text a]) (Maybe a))) + (case table + #;Nil + #;None + + (#;Cons [k' v'] table') + (if (text/= key k') + (#;Some v') + (pl-get key table')))) + +(def: #export (pl-contains? key table) + (All [a] (-> Text (List [Text a]) Bool)) + (case (pl-get key table) + (#;Some _) + true + + #;None + false)) + +(def: #export (pl-put key val table) + (All [a] (-> Text a (List [Text a]) (List [Text a]))) + (case table + #;Nil + (list [key val]) + + (#;Cons [k' v'] table') + (if (text/= key k') + (#;Cons [key val] + table') + (#;Cons [k' v'] + (pl-put key val table'))))) + +(def: #export (pl-update key f table) + (All [a] (-> Text (-> a a) (List [Text a]) (List [Text a]))) + (case table + #;Nil + #;Nil + + (#;Cons [k' v'] table') + (if (text/= key k') + (#;Cons [k' (f v')] table') + (#;Cons [k' v'] (pl-update key f table'))))) + +(def: #export (with-source-code source action) + (All [a] (-> Source (Meta a) (Meta a))) + (function [compiler] + (let [old-source (get@ #;source compiler)] + (case (action (set@ #;source source compiler)) + (#e;Error error) + (#e;Error error) + + (#e;Success [compiler' output]) + (#e;Success [(set@ #;source old-source compiler') + output]))))) + +(def: #export (with-stacked-errors handler action) + (All [a] (-> (-> [] Text) (Meta a) (Meta a))) + (function [compiler] + (case (action compiler) + (#e;Success [compiler' output]) + (#e;Success [compiler' output]) + + (#e;Error error) + (#e;Error (if (text/= "" error) + (handler []) + (format (handler []) "\n\n-----------------------------------------\n\n" error)))))) + +(def: fresh-bindings + (All [k v] (Bindings k v)) + {#;counter +0 + #;mappings (list)}) + +(def: fresh-scope + Scope + {#;name (list) + #;inner +0 + #;locals fresh-bindings + #;captured fresh-bindings}) + +(def: #export (with-scope action) + (All [a] (-> (Meta a) (Meta [Scope a]))) + (function [compiler] + (case (action (update@ #;scopes (|>. (#;Cons fresh-scope)) compiler)) + (#e;Success [compiler' output]) + (case (get@ #;scopes compiler') + #;Nil + (#e;Error "Impossible error: Drained scopes!") + + (#;Cons head tail) + (#e;Success [(set@ #;scopes tail compiler') + [head output]])) + + (#e;Error error) + (#e;Error error)))) + +(def: #export (with-current-module name action) + (All [a] (-> Text (Meta a) (Meta a))) + (function [compiler] + (case (action (set@ #;current-module (#;Some name) compiler)) + (#e;Success [compiler' output]) + (#e;Success [(set@ #;current-module + (get@ #;current-module compiler) + compiler') + output]) + + (#e;Error error) + (#e;Error error)))) + +(def: #export (with-cursor cursor action) + (All [a] (-> Cursor (Meta a) (Meta a))) + (if (text/= "" (product;left cursor)) + action + (function [compiler] + (let [old-cursor (get@ #;cursor compiler)] + (case (action (set@ #;cursor cursor compiler)) + (#e;Success [compiler' output]) + (#e;Success [(set@ #;cursor old-cursor compiler') + output]) + + (#e;Error error) + (#e;Error error)))))) + +(def: (normalize-char char) + (-> Nat Text) + (case char + (^ (char "*")) "_ASTER_" + (^ (char "+")) "_PLUS_" + (^ (char "-")) "_DASH_" + (^ (char "/")) "_SLASH_" + (^ (char "\\")) "_BSLASH_" + (^ (char "_")) "_UNDERS_" + (^ (char "%")) "_PERCENT_" + (^ (char "$")) "_DOLLAR_" + (^ (char "'")) "_QUOTE_" + (^ (char "`")) "_BQUOTE_" + (^ (char "@")) "_AT_" + (^ (char "^")) "_CARET_" + (^ (char "&")) "_AMPERS_" + (^ (char "=")) "_EQ_" + (^ (char "!")) "_BANG_" + (^ (char "?")) "_QM_" + (^ (char ":")) "_COLON_" + (^ (char ".")) "_PERIOD_" + (^ (char ",")) "_COMMA_" + (^ (char "<")) "_LT_" + (^ (char ">")) "_GT_" + (^ (char "~")) "_TILDE_" + (^ (char "|")) "_PIPE_" + _ + (text;from-code char))) + +(def: underflow Nat (n.dec +0)) + +(def: #export (normalize-name name) + (-> Text Text) + (loop [idx (n.dec (text;size name)) + output ""] + (if (n.= underflow idx) + output + (recur (n.dec idx) (format (|> (text;nth idx name) maybe;assume normalize-char) output))))) -- cgit v1.2.3