aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/module.lux
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/module.lux275
1 files changed, 275 insertions, 0 deletions
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/module.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/module.lux
new file mode 100644
index 000000000..94b289a08
--- /dev/null
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/module.lux
@@ -0,0 +1,275 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ pipe
+ ["." try]
+ ["." exception (#+ exception:)]]
+ [data
+ ["." text ("#\." equivalence)
+ ["%" format (#+ format)]]
+ [collection
+ ["." list ("#\." fold functor)]
+ [dictionary
+ ["." plist]]]]
+ ["." meta]]]
+ ["." /// #_
+ ["#." extension]
+ [//
+ ["/" analysis (#+ Operation)]
+ [///
+ ["#" phase]]]])
+
+(type: #export Tag Text)
+
+(exception: #export (unknown_module {module Text})
+ (exception.report
+ ["Module" module]))
+
+(exception: #export (cannot_declare_tag_twice {module Text} {tag Text})
+ (exception.report
+ ["Module" module]
+ ["Tag" tag]))
+
+(template [<name>]
+ [(exception: #export (<name> {tags (List Text)} {owner Type})
+ (exception.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} {already_existing Global})
+ (exception.report
+ ["Definition" (%.name name)]
+ ["Original" (case already_existing
+ (#.Alias alias)
+ (format "alias " (%.name alias))
+
+ (#.Definition definition)
+ (format "definition " (%.name name)))]))
+
+(exception: #export (can_only_change_state_of_active_module {module Text} {state Module_State})
+ (exception.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})
+ (exception.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))
+ (///extension.lift
+ (do ///.monad
+ [self_name meta.current_module_name
+ self meta.current_module]
+ (case (get@ #.module_annotations self)
+ #.None
+ (function (_ state)
+ (#try.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))
+ (///extension.lift
+ (do ///.monad
+ [self_name meta.current_module_name]
+ (function (_ state)
+ (#try.Success [(update@ #.modules
+ (plist.update self_name (update@ #.imports (function (_ current)
+ (if (list.any? (text\= module)
+ current)
+ current
+ (#.Cons module current)))))
+ state)
+ []])))))
+
+(def: #export (alias alias module)
+ (-> Text Text (Operation Any))
+ (///extension.lift
+ (do ///.monad
+ [self_name meta.current_module_name]
+ (function (_ state)
+ (#try.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] #try.Success))))
+
+(def: #export (define name definition)
+ (-> Text Global (Operation Any))
+ (///extension.lift
+ (do ///.monad
+ [self_name meta.current_module_name
+ self meta.current_module]
+ (function (_ state)
+ (case (plist.get name (get@ #.definitions self))
+ #.None
+ (#try.Success [(update@ #.modules
+ (plist.put self_name
+ (update@ #.definitions
+ (: (-> (List [Text Global]) (List [Text Global]))
+ (|>> (#.Cons [name definition])))
+ self))
+ state)
+ []])
+
+ (#.Some already_existing)
+ ((/.throw' ..cannot_define_more_than_once [[self_name name] already_existing]) state))))))
+
+(def: #export (create hash name)
+ (-> Nat Text (Operation Any))
+ (///extension.lift
+ (function (_ state)
+ (#try.Success [(update@ #.modules
+ (plist.put name (new hash))
+ state)
+ []]))))
+
+(def: #export (with_module hash name action)
+ (All [a] (-> Nat Text (Operation a) (Operation [Module a])))
+ (do ///.monad
+ [_ (create hash name)
+ output (/.with_current_module name
+ action)
+ module (///extension.lift (meta.find_module name))]
+ (wrap [module output])))
+
+(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?
+ (#try.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)
+ (#try.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]
+ )
+
+(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)
+ (#try.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}
+ [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
+ [self_name (///extension.lift meta.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)]
+ (#try.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.enumeration 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-13 13:34:53 +0000