aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/lux/platform/compiler/default/phase/analysis/module.lux
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source/lux/platform/compiler/default/phase/analysis/module.lux')
-rw-r--r--stdlib/source/lux/platform/compiler/default/phase/analysis/module.lux255
1 files changed, 255 insertions, 0 deletions
diff --git a/stdlib/source/lux/platform/compiler/default/phase/analysis/module.lux b/stdlib/source/lux/platform/compiler/default/phase/analysis/module.lux
new file mode 100644
index 000000000..a8f6bda03
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/phase/analysis/module.lux
@@ -0,0 +1,255 @@
+(.module:
+ [lux #*
+ [control
+ ["." monad (#+ do)]
+ ["ex" exception (#+ exception:)]
+ pipe]
+ [data
+ ["." text ("text/." Equivalence<Text>)
+ format]
+ ["." error]
+ [collection
+ ["." list ("list/." Fold<List> Functor<List>)]
+ [dictionary
+ ["." plist]]]]
+ ["." macro]]
+ ["." // (#+ Operation)
+ ["/." //
+ ["." extension]]])
+
+(type: #export Tag Text)
+
+(exception: #export (unknown-module {module Text})
+ (ex.report ["Module" module]))
+
+(exception: #export (cannot-declare-tag-twice {module Text} {tag Text})
+ (ex.report ["Module" module]
+ ["Tag" tag]))
+
+(do-template [<name>]
+ [(exception: #export (<name> {tags (List Text)} {owner Type})
+ (ex.report ["Tags" (text.join-with " " tags)]
+ ["Type" (%type owner)]))]
+
+ [cannot-declare-tags-for-unnamed-type]
+ [cannot-declare-tags-for-foreign-type]
+ )
+
+(exception: #export (cannot-define-more-than-once {name Name})
+ (ex.report ["Definition" (%name name)]))
+
+(exception: #export (can-only-change-state-of-active-module {module Text} {state Module-State})
+ (ex.report ["Module" module]
+ ["Desired state" (case state
+ #.Active "Active"
+ #.Compiled "Compiled"
+ #.Cached "Cached")]))
+
+(exception: #export (cannot-set-module-annotations-more-than-once {module Text} {old Code} {new Code})
+ (ex.report ["Module" module]
+ ["Old annotations" (%code old)]
+ ["New annotations" (%code new)]))
+
+(def: #export (new 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 (Operation Any))
+ (do ///.Monad<Operation>
+ [self-name (extension.lift macro.current-module-name)
+ self (extension.lift macro.current-module)]
+ (case (get@ #.module-annotations self)
+ #.None
+ (extension.lift
+ (function (_ state)
+ (#error.Success [(update@ #.modules
+ (plist.put self-name (set@ #.module-annotations (#.Some annotations) self))
+ state)
+ []])))
+
+ (#.Some old)
+ (///.throw cannot-set-module-annotations-more-than-once [self-name old annotations]))))
+
+(def: #export (import module)
+ (-> Text (Operation Any))
+ (do ///.Monad<Operation>
+ [self-name (extension.lift macro.current-module-name)]
+ (extension.lift
+ (function (_ state)
+ (#error.Success [(update@ #.modules
+ (plist.update self-name (update@ #.imports (|>> (#.Cons module))))
+ state)
+ []])))))
+
+(def: #export (alias alias module)
+ (-> Text Text (Operation Any))
+ (do ///.Monad<Operation>
+ [self-name (extension.lift macro.current-module-name)]
+ (extension.lift
+ (function (_ state)
+ (#error.Success [(update@ #.modules
+ (plist.update self-name (update@ #.module-aliases (: (-> (List [Text Text]) (List [Text Text]))
+ (|>> (#.Cons [alias module])))))
+ state)
+ []])))))
+
+(def: #export (exists? module)
+ (-> Text (Operation Bit))
+ (extension.lift
+ (function (_ state)
+ (|> state
+ (get@ #.modules)
+ (plist.get module)
+ (case> (#.Some _) #1 #.None #0)
+ [state] #error.Success))))
+
+(def: #export (define name definition)
+ (-> Text Definition (Operation Any))
+ (do ///.Monad<Operation>
+ [self-name (extension.lift macro.current-module-name)
+ self (extension.lift macro.current-module)]
+ (extension.lift
+ (function (_ state)
+ (case (plist.get name (get@ #.definitions self))
+ #.None
+ (#error.Success [(update@ #.modules
+ (plist.put self-name
+ (update@ #.definitions
+ (: (-> (List [Text Definition]) (List [Text Definition]))
+ (|>> (#.Cons [name definition])))
+ self))
+ state)
+ []])
+
+ (#.Some already-existing)
+ ((///.throw cannot-define-more-than-once [self-name name]) state))))))
+
+(def: #export (create hash name)
+ (-> Nat Text (Operation Any))
+ (extension.lift
+ (function (_ state)
+ (let [module (new hash)]
+ (#error.Success [(update@ #.modules
+ (plist.put name module)
+ state)
+ []])))))
+
+(def: #export (with-module hash name action)
+ (All [a] (-> Nat Text (Operation a) (Operation [Module a])))
+ (do ///.Monad<Operation>
+ [_ (create hash name)
+ output (//.with-current-module name
+ action)
+ module (extension.lift (macro.find-module name))]
+ (wrap [module output])))
+
+(do-template [<setter> <asker> <tag>]
+ [(def: #export (<setter> module-name)
+ (-> Text (Operation Any))
+ (extension.lift
+ (function (_ state)
+ (case (|> state (get@ #.modules) (plist.get module-name))
+ (#.Some module)
+ (let [active? (case (get@ #.module-state module)
+ #.Active #1
+ _ #0)]
+ (if active?
+ (#error.Success [(update@ #.modules
+ (plist.put module-name (set@ #.module-state <tag> module))
+ state)
+ []])
+ ((///.throw can-only-change-state-of-active-module [module-name <tag>])
+ state)))
+
+ #.None
+ ((///.throw unknown-module module-name) state)))))
+
+ (def: #export (<asker> module-name)
+ (-> Text (Operation Bit))
+ (extension.lift
+ (function (_ state)
+ (case (|> state (get@ #.modules) (plist.get module-name))
+ (#.Some module)
+ (#error.Success [state
+ (case (get@ #.module-state module)
+ <tag> #1
+ _ #0)])
+
+ #.None
+ ((///.throw unknown-module module-name) state)))))]
+
+ [set-active active? #.Active]
+ [set-compiled compiled? #.Compiled]
+ [set-cached cached? #.Cached]
+ )
+
+(do-template [<name> <tag> <type>]
+ [(def: (<name> module-name)
+ (-> Text (Operation <type>))
+ (extension.lift
+ (function (_ state)
+ (case (|> state (get@ #.modules) (plist.get module-name))
+ (#.Some module)
+ (#error.Success [state (get@ <tag> module)])
+
+ #.None
+ ((///.throw unknown-module module-name) state)))))]
+
+ [tags #.tags (List [Text [Nat (List Name) Bit Type]])]
+ [types #.types (List [Text [(List Name) Bit Type]])]
+ [hash #.module-hash Nat]
+ )
+
+(def: (ensure-undeclared-tags module-name tags)
+ (-> Text (List Tag) (Operation Any))
+ (do ///.Monad<Operation>
+ [bindings (..tags module-name)
+ _ (monad.map @
+ (function (_ tag)
+ (case (plist.get tag bindings)
+ #.None
+ (wrap [])
+
+ (#.Some _)
+ (///.throw cannot-declare-tag-twice [module-name tag])))
+ tags)]
+ (wrap [])))
+
+(def: #export (declare-tags tags exported? type)
+ (-> (List Tag) Bit Type (Operation Any))
+ (do ///.Monad<Operation>
+ [self-name (extension.lift macro.current-module-name)
+ [type-module type-name] (case type
+ (#.Named type-name _)
+ (wrap type-name)
+
+ _
+ (///.throw cannot-declare-tags-for-unnamed-type [tags type]))
+ _ (ensure-undeclared-tags self-name tags)
+ _ (///.assert cannot-declare-tags-for-foreign-type [tags type]
+ (text/= self-name type-module))]
+ (extension.lift
+ (function (_ state)
+ (case (|> state (get@ #.modules) (plist.get self-name))
+ (#.Some module)
+ (let [namespaced-tags (list/map (|>> [self-name]) tags)]
+ (#error.Success [(update@ #.modules
+ (plist.update self-name
+ (|>> (update@ #.tags (function (_ tag-bindings)
+ (list/fold (function (_ [idx tag] table)
+ (plist.put tag [idx namespaced-tags exported? type] table))
+ tag-bindings
+ (list.enumerate tags))))
+ (update@ #.types (plist.put type-name [namespaced-tags exported? type]))))
+ state)
+ []]))
+ #.None
+ ((///.throw unknown-module self-name) state))))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-09-12 15:14:07 +0000