diff options
Diffstat (limited to 'new-luxc/source/luxc/lang/module.lux')
| -rw-r--r-- | new-luxc/source/luxc/lang/module.lux | 173 |
1 files changed, 173 insertions, 0 deletions
diff --git a/new-luxc/source/luxc/lang/module.lux b/new-luxc/source/luxc/lang/module.lux new file mode 100644 index 000000000..fba337cc3 --- /dev/null +++ b/new-luxc/source/luxc/lang/module.lux @@ -0,0 +1,173 @@ +(;module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [text "text/" Eq<Text>] + text/format + ["e" error] + (coll [list "list/" Fold<List> Functor<List>])) + [meta] + (meta [code])) + (luxc ["&" lang] + (lang ["&;" scope]))) + +(exception: #export Unknown-Module) +(exception: #export Cannot-Declare-Tag-Twice) +(exception: #export Cannot-Declare-Tags-For-Unnamed-Type) +(exception: #export Cannot-Declare-Tags-For-Foreign-Type) + +(def: (new-module hash) + (-> Nat Module) + {#;module-hash hash + #;module-aliases (list) + #;defs (list) + #;imports (list) + #;tags (list) + #;types (list) + #;module-annotations (' {}) + #;module-state #;Active}) + +(def: #export (define (^@ full-name [module-name def-name]) + definition) + (-> Ident Def (Meta Unit)) + (function [compiler] + (case (&;pl-get module-name (get@ #;modules compiler)) + (#;Some module) + (case (&;pl-get def-name (get@ #;defs module)) + #;None + (#e;Success [(update@ #;modules + (&;pl-put module-name + (update@ #;defs + (: (-> (List [Text Def]) (List [Text Def])) + (|>. (#;Cons [def-name definition]))) + module)) + compiler) + []]) + + (#;Some already-existing) + (#e;Error (format "Cannot re-define definiton: " (%ident full-name)))) + + #;None + (#e;Error (format "Cannot define in unknown module: " module-name))))) + +(def: #export (create hash name) + (-> Nat Text (Meta Module)) + (function [compiler] + (let [module (new-module hash)] + (#e;Success [(update@ #;modules + (&;pl-put name module) + compiler) + module])))) + +(def: #export (with-module hash name action) + (All [a] (-> Nat Text (Meta a) (Meta [Module a]))) + (do meta;Monad<Meta> + [_ (create hash name) + output (&;with-current-module name + (&scope;with-scope name action)) + module (meta;find-module name)] + (wrap [module output]))) + +(do-template [<flagger> <asker> <tag>] + [(def: #export (<flagger> module-name) + (-> Text (Meta Unit)) + (function [compiler] + (case (|> compiler (get@ #;modules) (&;pl-get module-name)) + (#;Some module) + (let [active? (case (get@ #;module-state module) + #;Active true + _ false)] + (if active? + (#e;Success [(update@ #;modules + (&;pl-put module-name (set@ #;module-state <tag> module)) + compiler) + []]) + (#e;Error "Can only change the state of a currently-active module."))) + + #;None + (#e;Error (format "Module does not exist: " module-name))))) + (def: #export (<asker> module-name) + (-> Text (Meta Bool)) + (function [compiler] + (case (|> compiler (get@ #;modules) (&;pl-get module-name)) + (#;Some module) + (#e;Success [compiler + (case (get@ #;module-state module) + <tag> true + _ false)]) + + #;None + (#e;Error (format "Module does not exist: " module-name))) + ))] + + [flag-active! active? #;Active] + [flag-compiled! compiled? #;Compiled] + [flag-cached! cached? #;Cached] + ) + +(do-template [<name> <tag> <type>] + [(def: (<name> module-name) + (-> Text (Meta <type>)) + (function [compiler] + (case (|> compiler (get@ #;modules) (&;pl-get module-name)) + (#;Some module) + (#e;Success [compiler (get@ <tag> module)]) + + #;None + (meta;run compiler (&;throw Unknown-Module module-name))) + ))] + + [tags-by-module #;tags (List [Text [Nat (List Ident) Bool Type]])] + [types-by-module #;types (List [Text [(List Ident) Bool Type]])] + [module-hash #;module-hash Nat] + ) + +(def: (ensure-undeclared-tags module-name tags) + (-> Text (List Text) (Meta Unit)) + (do meta;Monad<Meta> + [bindings (tags-by-module module-name) + _ (monad;map @ + (function [tag] + (case (&;pl-get tag bindings) + #;None + (wrap []) + + (#;Some _) + (&;throw Cannot-Declare-Tag-Twice (format "Module: " module-name "\n" + " Tag: " tag)))) + tags)] + (wrap []))) + +(def: #export (declare-tags tags exported? type) + (-> (List Text) Bool Type (Meta Unit)) + (do meta;Monad<Meta> + [current-module meta;current-module-name + [type-module type-name] (case type + (#;Named type-ident _) + (wrap type-ident) + + _ + (&;throw Cannot-Declare-Tags-For-Unnamed-Type + (format "Tags: " (|> tags (list/map code;text) code;tuple %code) "\n" + "Type: " (%type type)))) + _ (ensure-undeclared-tags current-module tags) + _ (&;assert Cannot-Declare-Tags-For-Foreign-Type + (format "Tags: " (|> tags (list/map code;text) code;tuple %code) "\n" + "Type: " (%type type)) + (text/= current-module type-module))] + (function [compiler] + (case (|> compiler (get@ #;modules) (&;pl-get current-module)) + (#;Some module) + (let [namespaced-tags (list/map (|>. [current-module]) tags)] + (#e;Success [(update@ #;modules + (&;pl-update current-module + (|>. (update@ #;tags (function [tag-bindings] + (list/fold (function [[idx tag] table] + (&;pl-put tag [idx namespaced-tags exported? type] table)) + tag-bindings + (list;enumerate tags)))) + (update@ #;types (&;pl-put type-name [namespaced-tags exported? type])))) + compiler) + []])) + #;None + (meta;run compiler (&;throw Unknown-Module current-module)))))) |