diff options
Diffstat (limited to 'stdlib/source/program')
| -rw-r--r-- | stdlib/source/program/scriptum.lux | 522 |
1 files changed, 0 insertions, 522 deletions
diff --git a/stdlib/source/program/scriptum.lux b/stdlib/source/program/scriptum.lux deleted file mode 100644 index 40d1176dd..000000000 --- a/stdlib/source/program/scriptum.lux +++ /dev/null @@ -1,522 +0,0 @@ -(.module: - [library - [lux "*" - [program {"+" [program:]}] - ["[0]" type ("[1]\[0]" equivalence)] - ["[0]" debug] - [abstract - ["[0]" monad {"+" [do]}] - ["[0]" enum]] - [control - [pipe {"+" [when> new>]}] - ["[0]" maybe] - ["[0]" try {"+" [Try]}] - ["[0]" exception {"+" [exception:]}] - ["[0]" io {"+" [IO io]}] - ["[0]" function]] - [data - ["[0]" product] - [format - ["md" markdown {"+" [Markdown Span Block]}]] - ["[0]" text ("[1]\[0]" equivalence) - ["%" format {"+" [format]}] - [encoding - ["[0]" utf8]]] - [collection - ["[0]" sequence {"+" [Sequence]} ("[1]\[0]" functor)] - ["[0]" list ("[1]\[0]" functor mix)]]] - [math - [number - ["n" nat]]] - ["[0]" meta - ["[0]" annotation]] - [world - ["[0]" file]]]] - ... This was added to make sure that all tested modules are picked up - ... and their documentation is generated. - [test/lux {"+" []}]) - -... (def: parameter_name_options "abcdefghijklmnopqrstuvwxyz") -... (def: parameter_name_options_count (text.size parameter_name_options)) - -... (def: (parameter_type_name id) -... (-> Nat Text) -... (case (text.char id ..parameter_name_options) -... (#.Some char) -... (text.of_char char) - -... #.None -... (format (parameter_type_name (n./ parameter_name_options_count id)) -... (parameter_type_name (n.% parameter_name_options_count id))))) - -... (def: type_variable_names -... (Sequence Text) -... (|> 0 (sequence.iterations ++) (sequence\each parameter_type_name))) - -... (template [<name> <partition>] -... [(def: (<name> id) -... (-> Nat Bit) -... (<partition> id))] - -... [type_function? n.even?] -... [type_parameter? n.odd?] -... ) - -... (def: (parameter_id level id) -... (-> Nat Nat Nat) -... (n.- (n./ 2 id) level)) - -... (def: (parameter_name [type_function_name type_function_arguments] level id) -... (-> [Text (List Text)] Nat Nat Text) -... (if (type_parameter? id) -... (let [parameter_id (..parameter_id level id)] -... (case (list.item parameter_id type_function_arguments) -... (#.Some found) -... found - -... _ -... (|> type_variable_names -... (sequence.only (function (_ var_name) -... (not (list.member? text.equivalence type_function_arguments var_name)))) -... (sequence.item parameter_id)))) -... type_function_name)) - -... (def: (level_parameters offset level) -... (-> Nat Nat (List Text)) -... (if (n.= 0 level) -... (list) -... (|> level -... -- -... (enum.range n.enum 0) -... (list\each (|>> (n.+ (++ offset)) parameter_type_name))))) - -... (def: (prefix_lines prefix lines) -... (-> Text Text Text) -... (|> lines -... (text.all_split_by text.new_line) -... (list\each (|>> (format prefix))) -... (text.interposed text.new_line))) - -... (def: (pprint_type_definition level type_function_info tags module interface? recursive_type? type) -... (-> Nat [Text (List Text)] (List Name) Text Bit Bit Type Text) -... (case tags -... (^ (list [_ single_tag])) -... (if interface? -... (format "(: " (pprint_type_definition level type_function_info #.None module interface? recursive_type? type) text.new_line " " single_tag ")") -... (format "(Record [#" single_tag " " (pprint_type_definition level type_function_info #.None module interface? recursive_type? type) "])")) - -... _ -... (case [recursive_type? type] -... [_ (#.Primitive name params)] -... (case params -... #.End -... (format "(primitive " (%.text name) ")") - -... _ -... (format "(primitive " (%.text name) " " (|> params (list\each (pprint_type_definition level type_function_info #.None module interface? recursive_type?)) (text.interposed " ")) ")")) - -... [_ (#.Sum _)] -... (let [members (type.flat_variant type)] -... (case tags -... #.End -... (format "(Or " -... (|> members -... (list\each (pprint_type_definition level type_function_info #.None module interface? recursive_type?)) -... (text.interposed " ")) -... ")") - -... _ -... (|> members -... (list.zipped/2 tags) -... (list\each (function (_ [[_ t_name] type]) -... (case type -... (#.Product _) -... (let [types (type.flat_tuple type)] -... (format "(#" t_name " " -... (|> types -... (list\each (pprint_type_definition level type_function_info #.None module interface? recursive_type?)) -... (text.interposed " ")) -... ")")) - -... _ -... (format "(#" t_name " " (pprint_type_definition level type_function_info #.None module interface? recursive_type? type) ")")))) -... (text.interposed text.new_line)))) - -... [_ (#.Product _)] -... (let [members (type.flat_tuple type)] -... (case tags -... #.End -... (format "[" (|> members (list\each (pprint_type_definition level type_function_info #.None module interface? recursive_type?)) (text.interposed " ")) "]") - -... _ -... (let [member_docs (|> members -... (list.zipped/2 tags) -... (list\each (function (_ [[_ t_name] type]) -... (if interface? -... (format "(: " (pprint_type_definition level type_function_info #.None module interface? recursive_type? type) text.new_line " " t_name ")") -... (format "#" t_name " " (pprint_type_definition level type_function_info #.None module interface? recursive_type? type))))) -... (text.interposed (format text.new_line " ")))] -... (if interface? -... member_docs -... (format "(Record [" member_docs "])"))))) - -... [_ (#.Function input output)] -... (let [[ins out] (type.flat_function type)] -... (format "(-> " (|> ins (list\each (pprint_type_definition level type_function_info #.None module interface? recursive_type?)) (text.interposed " ")) -... " " -... (pprint_type_definition level type_function_info #.None module interface? recursive_type? out) -... ")")) - -... [_ (#.Parameter idx)] -... (parameter_name type_function_info level idx) - -... (^template [<tag> <pre> <post>] -... [[_ (<tag> id)] -... (format <pre> (%.nat id) <post>)]) -... ([#.Var "⌈v:" "⌋"] -... [#.Ex "⟨e:" "⟩"]) - -... (^template [<tag> <name> <flat>] -... [[_ (<tag> _)] -... (let [[level' body] (<flat> type) -... args (level_parameters level level') -... body_doc (pprint_type_definition (n.+ level level') type_function_info tags module interface? recursive_type? body)] -... (format "(" <name> " " "[" (text.interposed " " args) "]" -... (case tags -... #.End -... (format " " body_doc) - -... _ -... (format text.new_line (prefix_lines " " body_doc))) -... ")"))]) -... ([#.UnivQ "All" type.flat_univ_q] -... [#.ExQ "Ex" type.flat_ex_q]) - -... [true (#.Apply (#.Parameter 1) (#.Parameter 0))] -... (product.left type_function_info) - -... [_ (#.Apply param fun)] -... (let [[type_func type_arguments] (type.flat_application type)] -... (format "(" (pprint_type_definition level type_function_info tags module interface? recursive_type? type_func) " " (|> type_arguments (list\each (pprint_type_definition level type_function_info #.None module interface? recursive_type?)) (text.interposed " ")) ")")) - -... [_ (#.Named [_module _name] type)] -... (if (text\= module _module) -... _name -... (%.name [_module _name])) -... ))) - -... (def: (pprint_type level type_function_name module type) -... (-> Nat Text Text Type Text) -... (case type -... (#.Primitive name params) -... (case params -... #.End -... (format "(primitive " (%.text name) ")") - -... _ -... (format "(primitive " (%.text name) " " (|> params (list\each (pprint_type level type_function_name module)) (text.interposed " ")) ")")) - -... (#.Sum _) -... (let [members (type.flat_variant type)] -... (format "(Or " (|> members (list\each (pprint_type level type_function_name module)) (text.interposed " ")) ")")) - -... (#.Product _) -... (let [members (type.flat_tuple type)] -... (format "[" (|> members (list\each (pprint_type level type_function_name module)) (text.interposed " ")) "]")) - -... (#.Function input output) -... (let [[ins out] (type.flat_function type)] -... (format "(-> " -... (|> ins (list\each (pprint_type level type_function_name module)) (text.interposed " ")) -... " " -... (pprint_type level type_function_name module out) -... ")")) - -... (#.Parameter idx) -... (parameter_name [type_function_name (list)] level idx) - -... (^template [<tag> <pre> <post>] -... [(<tag> id) -... (format <pre> (%.nat id) <post>)]) -... ([#.Var "⌈" "⌋"] -... [#.Ex "⟨" "⟩"]) - -... (^template [<tag> <name> <flat>] -... [(<tag> _) -... (let [[level' body] (<flat> type) -... args (level_parameters level level') -... body_doc (pprint_type (n.+ level level') type_function_name module body)] -... (format "(" <name> " " "[" (|> args (text.interposed " ")) "]" -... (format " " body_doc) -... ")"))]) -... ([#.UnivQ "All" type.flat_univ_q] -... [#.ExQ "Ex" type.flat_ex_q]) - -... (#.Apply param fun) -... (let [[type_func type_arguments] (type.flat_application type)] -... (format "(" (pprint_type level type_function_name module type_func) " " (|> type_arguments (list\each (pprint_type level type_function_name module)) (text.interposed " ")) ")")) - -... (#.Named [_module _name] type) -... (if (text\= module _module) -... _name -... (%.name [_module _name])) -... )) - -... (type: (Mutation a) -... (-> a a)) - -... (type: Value -... [Text Code Type]) - -... (type: Organization -... (Record -... [#types (List Value) -... #macros (List [Text Code]) -... #implementations (List Value) -... #values (List Value)])) - -... (def: (lux_module? module_name) -... (-> Text Bit) -... (let [prefix (format .prelude_module "/")] -... (or (text\= .prelude_module module_name) -... (text.starts_with? prefix module_name)))) - -... (def: (add_definition [name [exported? def_type def_annotations def_value]] organization) -... (-> [Text Definition] Organization Organization) -... (cond (type\= .Type def_type) -... (revised@ #types -... (: (Mutation (List Value)) -... (|>> (#.Item [name def_annotations (:as Type def_value)]))) -... organization) - -... (type\= .Macro def_type) -... (revised@ #macros -... (: (Mutation (List [Text Code])) -... (|>> (#.Item [name def_annotations]))) -... organization) - -... (annotation.implementation? def_annotations) -... (revised@ #implementations -... (: (Mutation (List Value)) -... (|>> (#.Item [name def_annotations def_type]))) -... organization) - -... ... else -... (revised@ #values -... (: (Mutation (List Value)) -... (|>> (#.Item [name def_annotations def_type]))) -... organization))) - -... (def: name_sort -... (All (_ r) (-> [Text r] [Text r] Bit)) -... (let [text\< (\ text.order <)] -... (function (_ [n1 _] [n2 _]) -... (text\< n1 n2)))) - -... (def: (organize_definitions defs) -... (-> (List [Text Definition]) Organization) -... (let [init [#types (list) -... #macros (list) -... #implementations (list) -... #values (list)]] -... (|> (list\mix add_definition init defs) -... (revised@ #types (list.sorted name_sort)) -... (revised@ #macros (list.sorted name_sort)) -... (revised@ #implementations (list.sorted name_sort)) -... (revised@ #values (list.sorted name_sort))))) - -(def: (unravel_type_func level type) - (-> Nat Type Type) - (if (n.> 0 level) - (case type - (#.UnivQ _env _type) - (unravel_type_func (-- level) _type) - - _ - type) - type)) - -(def: (unrecurse_type type) - (-> Type Type) - (case type - (#.Apply _ (#.UnivQ _env _type)) - _type - - _ - type)) - -(exception: .public (anonymous_type_definition {type Type}) - (exception.report - ["Type" (%.type type)])) - -(def: (document_type module type def_annotations) - (-> Text Type Code (Meta (Markdown Block))) - (case type - (#.Named type_name type) - (do meta.monad - [tags (meta.tags_of type_name) - .let [[_ _name] type_name - recursive_type? (annotation.recursive_type? def_annotations) - type_arguments (annotation.type_arguments def_annotations) - interface? (annotation.interface? def_annotations) - usage (case type_arguments - #.End - _name - - _ - (format "(" (text.interposed " " (list& _name type_arguments)) ")")) - nesting (list.size type_arguments)]] - (in (md.code (format (if interface? "(interface: " "(type: ") - (if recursive_type? "#rec " "") - usage text.new_line - (|> type - (unravel_type_func nesting) - (when> [(new> recursive_type? [])] [unrecurse_type]) - (pprint_type_definition (-- nesting) [_name type_arguments] (maybe.else (list) tags) module interface? recursive_type?) - (text.all_split_by text.new_line) - (list\each (|>> (format " "))) - (text.interposed text.new_line)) - ")")))) - - _ - (meta.failure (exception.error anonymous_type_definition type)))) - -(def: (document_types module types) - (-> Text (List Value) (Meta (Markdown Block))) - (do [! meta.monad] - [type_docs (monad.each ! - (: (-> Value (Meta (Markdown Block))) - (function (_ [name def_annotations type]) - (do meta.monad - [.let [?doc (annotation.documentation def_annotations)] - type_code (document_type module type def_annotations)] - (in ($_ md.then - (md.heading/3 name) - (case ?doc - (#.Some doc) - (md.paragraph (md.text doc)) - - _ - md.empty) - type_code))))) - types)] - (in (list\mix (function.flipped md.then) - (md.heading/2 "Types") - type_docs)))) - -... (def: (document_macros module_name names) -... (-> Text (List [Text Code]) (Markdown Block)) -... (|> names -... (list\each (: (-> [Text Code] (Markdown Block)) -... (function (_ [name def_annotations]) -... ($_ md.then -... (md.heading/3 name) -... (<| (: (Markdown Block)) -... (maybe.else md.empty) -... (do maybe.monad -... [documentation (annotation.documentation def_annotations)] -... (in (md.code documentation)))))))) -... (list\mix (function.flipped md.then) -... (md.heading/2 "Macros")))) - -... (template [<singular> <plural> <header>] -... [(def: (<singular> module type) -... (-> Text Type (Markdown Block)) -... (md.code (pprint_type (-- 0) "?" module type))) - -... (def: (<plural> module values) -... (-> Text (List Value) (Markdown Block)) -... (|> values -... (list\each (function (_ [name def_annotations value_type]) -... (let [?doc (annotation.documentation def_annotations) -... usage (case (annotation.function_arguments def_annotations) -... #.End -... name - -... args -... (format "(" (text.interposed " " (list& name args)) ")"))] -... ($_ md.then -... (md.heading/3 usage) -... (case ?doc -... (#.Some doc) -... (md.code doc) - -... _ -... md.empty) -... (<singular> module value_type))))) -... (list\mix (function.flipped md.then) -... (md.heading/2 <header>))))] - -... [document_implementation document_implementations "Implementations"] -... [document_value document_values "Values"] -... ) - -... (def: (enclose_lines pre+post block) -... (-> [Text Text] Text Text) -... (|> block -... (text.all_split_by text.new_line) -... (list\each (text.enclosed pre+post)) -... (text.interposed text.new_line))) - -... (def: (document_module [[module_name module] organization]) -... (-> [[Text Module] Organization] (Meta [Text (Markdown Block)])) -... (do meta.monad -... [.let [(^slots [#types #macros #implementations #values]) organization -... annotations (|> module -... (value@ #.module_annotations) -... (maybe.else (' {})) -... annotation.documentation) -... description (case annotations -... (#.Some doc_text) -... (md.quote (md.paragraph (md.text doc_text))) - -... #.None -... md.empty) -... empty_block (: (Markdown Block) md.empty)] -... types_documentation (if (list.empty? types) -... (in empty_block) -... (document_types module_name types)) -... .let [documentation ($_ md.then -... types_documentation -... (if (list.empty? macros) empty_block (document_macros module_name macros)) -... (if (list.empty? implementations) empty_block (document_implementations module_name implementations)) -... (if (list.empty? values) empty_block (document_values module_name values)))]] -... (in [module_name -... ($_ md.then -... (md.heading/1 module_name) -... description -... documentation)]))) - -... (exception: .public (io_error {error Text}) -... error) - -... (def: (save_documentation! [module_name documentation]) -... (-> [Text (Markdown Block)] (IO Any)) -... (let [path (format (text.replaced "/" "_" module_name) ".md")] -... (do io.monad -... [outcome (\ file.default write (\ utf8.codec encoded (md.markdown documentation)) path)] -... (in (case outcome -... (#try.Failure error) -... (debug.log! (exception.error io_error error)) - -... (#try.Success _) -... []))))) - -... (macro: (gen_documentation! _) -... (do [! meta.monad] -... [all_modules meta.modules -... .let [lux_modules (|> all_modules -... (list.only (function.composite lux_module? product.left)) -... (list.sorted name_sort))] -... lux_exports (monad.each ! (function.composite meta.exports product.left) -... lux_modules) -... module_documentation (|> (list\each organize_definitions lux_exports) -... (list.zipped/2 lux_modules) -... (monad.each ! document_module)) -... .let [_ (io.run! (monad.each io.monad save_documentation! module_documentation))]] -... (in (list)))) - -... (gen_documentation!) - -... (program: args -... (io (debug.log! "Done!"))) |