aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/lang.lux
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc/lang.lux')
-rw-r--r--new-luxc/source/luxc/lang.lux245
1 files changed, 245 insertions, 0 deletions
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>]
+ 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<Meta>
+ [[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<Meta> (~' 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<Meta>
+ [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)))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-05 16:55:11 +0000