diff options
Diffstat (limited to 'stdlib/source/program/scriptum.lux')
| -rw-r--r-- | stdlib/source/program/scriptum.lux | 606 |
1 files changed, 303 insertions, 303 deletions
diff --git a/stdlib/source/program/scriptum.lux b/stdlib/source/program/scriptum.lux index 6841682df..438b071ec 100644 --- a/stdlib/source/program/scriptum.lux +++ b/stdlib/source/program/scriptum.lux @@ -36,59 +36,59 @@ ... and their documentation is generated. [test/lux (#+)]) -(def: name_options "abcdefghijklmnopqrstuvwxyz") -(def: name_options_count (text.size name_options)) - -(def: (parameter_type_name id) - (-> Nat Text) - (case (text.char id ..name_options) - (#.Some char) - (text.of_char char) - - #.None - (format (parameter_type_name (n./ name_options_count id)) - (parameter_type_name (n.% name_options_count id))))) - -(def: type_var_names - (Sequence Text) - (|> 0 (sequence.iterations ++) (sequence\each parameter_type_name))) - -(template [<name> <partition>] - [(def: (<name> id) - (-> Nat Bit) - (<partition> id))] - - [type_func? n.even?] - [type_arg? n.odd?] - ) - -(def: (arg_id level id) - (-> Nat Nat Nat) - (n.- (n./ 2 id) level)) - -(def: (parameter_name [type_func_name type_function_arguments] level id) - (-> [Text (List Text)] Nat Nat Text) - (if (type_arg? id) - (let [arg_id (..arg_id level id)] - (case (list.item arg_id type_function_arguments) - (#.Some found) - found - - _ - (|> type_var_names - (sequence.only (function (_ var_name) - (not (list.member? text.equivalence type_function_arguments var_name)))) - (sequence.item arg_id)))) - type_func_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: 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) @@ -97,13 +97,13 @@ (list\each (|>> (format prefix))) (text.interposed text.new_line))) -(def: (pprint_type_definition level type_func_info tags module interface? recursive_type? type) +(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_func_info #.None module interface? recursive_type? type) text.new_line " " single_tag ")") - (format "{#" single_tag " " (pprint_type_definition level type_func_info #.None module interface? recursive_type? type) "}")) + (format "(: " (pprint_type_definition level type_function_info #.None module interface? recursive_type? type) text.new_line " " single_tag ")") + (format "{#" single_tag " " (pprint_type_definition level type_function_info #.None module interface? recursive_type? type) "}")) _ (case [recursive_type? type] @@ -113,7 +113,7 @@ (format "(primitive " (%.text name) ")") _ - (format "(primitive " (%.text name) " " (|> params (list\each (pprint_type_definition level type_func_info #.None module interface? recursive_type?)) (text.interposed " ")) ")")) + (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)] @@ -121,7 +121,7 @@ #.End (format "(Or " (|> members - (list\each (pprint_type_definition level type_func_info #.None module interface? recursive_type?)) + (list\each (pprint_type_definition level type_function_info #.None module interface? recursive_type?)) (text.interposed " ")) ")") @@ -134,27 +134,27 @@ (let [types (type.flat_tuple type)] (format "(#" t_name " " (|> types - (list\each (pprint_type_definition level type_func_info #.None module interface? recursive_type?)) + (list\each (pprint_type_definition level type_function_info #.None module interface? recursive_type?)) (text.interposed " ")) ")")) _ - (format "(#" t_name " " (pprint_type_definition level type_func_info #.None module interface? recursive_type? type) ")")))) + (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_func_info #.None module interface? recursive_type?)) (text.interposed " ")) "]") + (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_func_info #.None module interface? recursive_type? type) text.new_line " " t_name ")") - (format "#" t_name " " (pprint_type_definition level type_func_info #.None module interface? recursive_type? type))))) + (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 @@ -162,13 +162,13 @@ [_ (#.Function input output)] (let [[ins out] (type.flat_function type)] - (format "(-> " (|> ins (list\each (pprint_type_definition level type_func_info #.None module interface? recursive_type?)) (text.interposed " ")) + (format "(-> " (|> ins (list\each (pprint_type_definition level type_function_info #.None module interface? recursive_type?)) (text.interposed " ")) " " - (pprint_type_definition level type_func_info #.None module interface? recursive_type? out) + (pprint_type_definition level type_function_info #.None module interface? recursive_type? out) ")")) [_ (#.Parameter idx)] - (parameter_name type_func_info level idx) + (parameter_name type_function_info level idx) (^template [<tag> <pre> <post>] [[_ (<tag> id)] @@ -180,7 +180,7 @@ [[_ (<tag> _)] (let [[level' body] (<flat> type) args (level_parameters level level') - body_doc (pprint_type_definition (n.+ level level') type_func_info tags module interface? recursive_type? body)] + 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 @@ -193,11 +193,11 @@ [#.ExQ "Ex" type.flat_ex_q]) [true (#.Apply (#.Parameter 1) (#.Parameter 0))] - (product.left type_func_info) + (product.left type_function_info) [_ (#.Apply param fun)] (let [[type_func type_arguments] (type.flat_application type)] - (format "(" (pprint_type_definition level type_func_info tags module interface? recursive_type? type_func) " " (|> type_arguments (list\each (pprint_type_definition level type_func_info #.None module interface? recursive_type?)) (text.interposed " ")) ")")) + (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) @@ -205,124 +205,124 @@ (%.name [_module _name])) ))) -(def: (pprint_type level type_func_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_func_name module)) (text.interposed " ")) ")")) - - (#.Sum _) - (let [members (type.flat_variant type)] - (format "(Or " (|> members (list\each (pprint_type level type_func_name module)) (text.interposed " ")) ")")) - - (#.Product _) - (let [members (type.flat_tuple type)] - (format "[" (|> members (list\each (pprint_type level type_func_name module)) (text.interposed " ")) "]")) - - (#.Function input output) - (let [[ins out] (type.flat_function type)] - (format "(-> " - (|> ins (list\each (pprint_type level type_func_name module)) (text.interposed " ")) - " " - (pprint_type level type_func_name module out) - ")")) - - (#.Parameter idx) - (parameter_name [type_func_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_func_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_func_name module type_func) " " (|> type_arguments (list\each (pprint_type level type_func_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 - {#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: (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 +... {#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) @@ -403,119 +403,119 @@ (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!"))) +... (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!"))) |