diff options
author | Eduardo Julian | 2018-05-16 00:11:49 -0400 |
---|---|---|
committer | Eduardo Julian | 2018-05-16 00:11:49 -0400 |
commit | 8ba6ac8952e3457b1a09e30ac5312168d48006d1 (patch) | |
tree | f4ed8a04f95bd95165add394541ef81eadbfd839 /new-luxc/source/luxc/lang/module.lux | |
parent | 4242e4d3b18eb532ae18e8b38e85ad1ee1988e02 (diff) |
- Migrated structure analysis to stdlib.
- Added an easy way to report information in exceptions.
Diffstat (limited to '')
-rw-r--r-- | new-luxc/source/luxc/lang/module.lux | 234 |
1 files changed, 0 insertions, 234 deletions
diff --git a/new-luxc/source/luxc/lang/module.lux b/new-luxc/source/luxc/lang/module.lux deleted file mode 100644 index 8e24d0cf4..000000000 --- a/new-luxc/source/luxc/lang/module.lux +++ /dev/null @@ -1,234 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:] - pipe) - (data [text "text/" Eq<Text>] - text/format - ["e" error] - (coll [list "list/" Fold<List> Functor<List>])) - [macro] - (macro [code])) - (luxc ["&" lang] - (lang ["&." scope]))) - -(do-template [<name>] - [(exception: #export (<name> {message Text}) - message)] - - [Unknown-Module] - [Cannot-Declare-Tag-Twice] - [Cannot-Declare-Tags-For-Unnamed-Type] - [Cannot-Declare-Tags-For-Foreign-Type] - [Cannot-Define-More-Than-Once] - [Cannot-Define-In-Unknown-Module] - [Can-Only-Change-State-Of-Active-Module] - [Cannot-Set-Module-Annotations-More-Than-Once] - ) - -(def: (new-module hash) - (-> Nat Module) - {#.module-hash hash - #.module-aliases (list) - #.definitions (list) - #.imports (list) - #.tags (list) - #.types (list) - #.module-annotations #.None - #.module-state #.Active}) - -(def: #export (set-annotations annotations) - (-> Code (Meta Top)) - (do macro.Monad<Meta> - [self-name macro.current-module-name - self macro.current-module] - (case (get@ #.module-annotations self) - #.None - (function (_ compiler) - (#e.Success [(update@ #.modules - (&.pl-put self-name (set@ #.module-annotations (#.Some annotations) self)) - compiler) - []])) - - (#.Some old) - (&.throw Cannot-Set-Module-Annotations-More-Than-Once - (format " Module: " self-name "\n" - "Old annotations: " (%code old) "\n" - "New annotations: " (%code annotations) "\n"))))) - -(def: #export (import module) - (-> Text (Meta Top)) - (do macro.Monad<Meta> - [self macro.current-module-name] - (function (_ compiler) - (#e.Success [(update@ #.modules - (&.pl-update self (update@ #.imports (|>> (#.Cons module)))) - compiler) - []])))) - -(def: #export (alias alias module) - (-> Text Text (Meta Top)) - (do macro.Monad<Meta> - [self macro.current-module-name] - (function (_ compiler) - (#e.Success [(update@ #.modules - (&.pl-update self (update@ #.module-aliases (: (-> (List [Text Text]) (List [Text Text])) - (|>> (#.Cons [alias module]))))) - compiler) - []])))) - -(def: #export (exists? module) - (-> Text (Meta Bool)) - (function (_ compiler) - (|> (get@ #.modules compiler) - (&.pl-get module) - (case> (#.Some _) true #.None false) - [compiler] #e.Success))) - -(def: #export (define (^@ full-name [module-name def-name]) - definition) - (-> Ident Definition (Meta Top)) - (function (_ compiler) - (case (&.pl-get module-name (get@ #.modules compiler)) - (#.Some module) - (case (&.pl-get def-name (get@ #.definitions module)) - #.None - (#e.Success [(update@ #.modules - (&.pl-put module-name - (update@ #.definitions - (: (-> (List [Text Definition]) (List [Text Definition])) - (|>> (#.Cons [def-name definition]))) - module)) - compiler) - []]) - - (#.Some already-existing) - ((&.throw Cannot-Define-More-Than-Once (%ident full-name)) compiler)) - - #.None - ((&.throw Cannot-Define-In-Unknown-Module (%ident full-name)) compiler)))) - -(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 macro.Monad<Meta> - [_ (create hash name) - output (&.with-current-module name - action) - module (macro.find-module name)] - (wrap [module output]))) - -(do-template [<flagger> <asker> <tag> <description>] - [(def: #export (<flagger> module-name) - (-> Text (Meta Top)) - (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) - []]) - ((&.throw Can-Only-Change-State-Of-Active-Module - (format " Module: " module-name "\n" - "Desired state: " <description>)) - compiler))) - - #.None - ((&.throw Unknown-Module module-name) compiler)))) - (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 - ((&.throw Unknown-Module module-name) compiler)) - ))] - - [flag-active! active? #.Active "Active"] - [flag-compiled! compiled? #.Compiled "Compiled"] - [flag-cached! 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 - ((&.throw Unknown-Module module-name) compiler)) - ))] - - [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 Top)) - (do macro.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 Top)) - (do macro.Monad<Meta> - [current-module macro.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 - ((&.throw Unknown-Module current-module) compiler))))) |