diff options
Diffstat (limited to 'new-luxc/source/luxc/module.lux')
| -rw-r--r-- | new-luxc/source/luxc/module.lux | 173 |
1 files changed, 0 insertions, 173 deletions
diff --git a/new-luxc/source/luxc/module.lux b/new-luxc/source/luxc/module.lux deleted file mode 100644 index 7b60af8f2..000000000 --- a/new-luxc/source/luxc/module.lux +++ /dev/null @@ -1,173 +0,0 @@ -(;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 ["&" base] - ["&;" 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)))))) |