From be5710d104e6ee085dcb9d871be0b80305e48f8b Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 5 Feb 2019 02:14:27 -0400 Subject: Migrated documentation tool's code into stdlib. --- stdlib/source/lux.lux | 7 - stdlib/source/lux/control/comonad.lux | 18 +- stdlib/source/lux/control/continuation.lux | 78 ++-- stdlib/source/lux/data/collection/sequence.lux | 25 +- stdlib/source/lux/data/format/markdown.lux | 14 +- stdlib/source/lux/data/text.lux | 3 - stdlib/source/lux/macro.lux | 20 +- stdlib/source/program/scriptum.lux | 518 +++++++++++++++++++++++++ 8 files changed, 600 insertions(+), 83 deletions(-) create mode 100644 stdlib/source/program/scriptum.lux (limited to 'stdlib/source') diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 1a35b4ebd..e0717c88c 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -5999,13 +5999,6 @@ _ (#Left (..wrong-syntax-error (name-of ..char))))) -(def: #export (when test f) - (All [a] (-> Bit (-> a a) (-> a a))) - (function (_ value) - (if test - (f value) - value))) - (def: target (Meta Text) (function (_ compiler) diff --git a/stdlib/source/lux/control/comonad.lux b/stdlib/source/lux/control/comonad.lux index 853c43615..980935216 100644 --- a/stdlib/source/lux/control/comonad.lux +++ b/stdlib/source/lux/control/comonad.lux @@ -2,17 +2,15 @@ [lux #* [data [collection - ["." list ("list/." Fold)] - ["." sequence]]]] + ["." list ("list/." fold)]]]] [// - ["F" functor]]) + ["." functor (#+ Functor)]]) -## [Signatures] (signature: #export (CoMonad w) {#.doc (doc "CoMonads are the opposite/complement to monads." "CoMonadic structures are often infinite in size and built upon lazily-evaluated functions.")} - (: (F.Functor w) - functor) + (: (Functor w) + &functor) (: (All [a] (-> (w a) a)) unwrap) @@ -20,18 +18,16 @@ (-> (w a) (w (w a)))) split)) -## [Types] (type: #export (CoFree F a) {#.doc "The CoFree CoMonad."} [a (F (CoFree F a))]) -## [Syntax] (def: _cursor Cursor ["" 0 0]) (macro: #export (be tokens state) {#.doc (doc "A co-monadic parallel to the 'do' macro." (let [square (function (_ n) (i/* n n))] - (be sequence.comonad + (be comonad [inputs (iterate inc +2)] (square (head inputs)))))} (case tokens @@ -53,7 +49,9 @@ body (list.reverse (list.as-pairs bindings)))] (#.Right [state (#.Cons (` ({(~' @) - ({{#functor {#F.map (~ g!map)} #unwrap (~' unwrap) #split (~ g!split)} + ({{#&functor {#functor.map (~ g!map)} + #unwrap (~' unwrap) + #split (~ g!split)} (~ body')} (~' @))} (~ comonad))) diff --git a/stdlib/source/lux/control/continuation.lux b/stdlib/source/lux/control/continuation.lux index 66233773a..7a1fd7be8 100644 --- a/stdlib/source/lux/control/continuation.lux +++ b/stdlib/source/lux/control/continuation.lux @@ -3,29 +3,59 @@ [control [functor (#+ Functor)] [apply (#+ Apply)] - monad] - function + [monad (#+ Monad do)]] + ["." function] [macro (#+ with-gensyms) - [code] - [syntax (#+ syntax:)]]]) + ["." code] + ["s" syntax (#+ syntax:)]]]) (type: #export (Cont i o) {#.doc "Continuations."} (-> (-> i o) o)) -(def: #export (continue k cont) - {#.doc "Forces a continuation thunk to be evaluated."} +(def: #export (continue next cont) + {#.doc "Continues a thunk."} (All [i o] (-> (-> i o) (Cont i o) o)) - (cont k)) + (cont next)) (def: #export (run cont) {#.doc "Forces a continuation thunk to be evaluated."} (All [a] (-> (Cont a a) a)) - (cont id)) + (cont function.identity)) + +(def: #export (call/cc f) + {#.doc "Call with current continuation."} + (All [a b z] + (-> (-> (-> a (Cont b z)) + (Cont a z)) + (Cont a z))) + (function (_ k) + (f (function (_ a) (function (_ _) (k a))) + k))) + +(syntax: #export (pending expr) + {#.doc (doc "Turns any expression into a function that is pending a continuation." + (pending (some-function some-input)))} + (with-gensyms [g!_ g!k] + (wrap (list (` (.function ((~ g!_) (~ g!k)) ((~ g!k) (~ expr)))))))) + +(def: #export (reset scope) + (All [i o] (-> (Cont i i) (Cont i o))) + (function (_ k) + (k (run scope)))) + +(def: #export (shift f) + (All [a] + (-> (-> (-> a (Cont a a)) + (Cont a a)) + (Cont a a))) + (function (_ oc) + (f (function (_ a) (function (_ ic) (ic (oc a)))) + function.identity))) (structure: #export functor (All [o] (Functor (All [i] (Cont i o)))) (def: (map f fv) - (function (_ k) (fv (compose k f))))) + (function (_ k) (fv (function.compose k f))))) (structure: #export apply (All [o] (Apply (All [i] (Cont i o)))) (def: &functor ..functor) @@ -46,22 +76,6 @@ (function (_ k) (ffa (continue k))))) -(def: #export (call/cc f) - {#.doc "Call with current continuation."} - (All [a b z] - (-> (-> (-> a (Cont b z)) - (Cont a z)) - (Cont a z))) - (function (_ k) - (f (function (_ a) (function (_ _) (k a))) - k))) - -(syntax: #export (pending expr) - {#.doc (doc "Turns any expression into a function that is pending a continuation." - (pending (some-function some-input)))} - (with-gensyms [g!_ g!k] - (wrap (list (` (.function ((~ g!_) (~ g!k)) ((~ g!k) (~ expr)))))))) - (def: #export (portal init) (All [i o z] (-> i @@ -74,17 +88,3 @@ (k [nexus val]))] _ (k [nexus init])] (wrap (undefined)))))) - -(def: #export (reset scope) - (All [i o] (-> (Cont i i) (Cont i o))) - (function (_ k) - (k (run scope)))) - -(def: #export (shift f) - (All [a] - (-> (-> (-> a (Cont a a)) - (Cont a a)) - (Cont a a))) - (function (_ oc) - (f (function (_ a) (function (_ ic) (ic (oc a)))) - id))) diff --git a/stdlib/source/lux/data/collection/sequence.lux b/stdlib/source/lux/data/collection/sequence.lux index 30b2bf46e..bd2c7ae03 100644 --- a/stdlib/source/lux/data/collection/sequence.lux +++ b/stdlib/source/lux/data/collection/sequence.lux @@ -1,16 +1,15 @@ (.module: [lux #* [control - functor - monad - comonad + [functor (#+ Functor)] + [comonad (#+ CoMonad)] ["." continuation (#+ pending Cont)] ["p" parser]] [macro (#+ with-gensyms) ["." code] ["s" syntax (#+ syntax: Syntax)]] [data - bit + ["." bit] [collection [list ("list/." monad)]]]]) @@ -22,8 +21,11 @@ (All [a] (-> a (List a) a (List a) (Sequence a))) (case xs - #.Nil (pending [x (cycle' init full init full)]) - (#.Cons x' xs') (pending [x (cycle' x' xs' init full)]))) + #.Nil + (pending [x (cycle' init full init full)]) + + (#.Cons x' xs') + (pending [x (cycle' x' xs' init full)]))) (def: #export (iterate f x) {#.doc "Create a sequence by applying a function to a value, and to its result, on and on..."} @@ -43,8 +45,11 @@ (All [a] (-> (List a) (Maybe (Sequence a)))) (case xs - #.Nil #.None - (#.Cons x xs') (#.Some (cycle' x xs' x xs')))) + #.Nil + #.None + + (#.Cons x xs') + (#.Some (cycle' x xs' x xs')))) (do-template [ ] [(def: #export ( s) @@ -106,12 +111,12 @@ (pending [x (filter p xs')]) (filter p xs')))) -(def: #export (partition p xs) +(def: #export (partition left? xs) {#.doc (doc "Split a sequence in two based on a predicate." "The left side contains all entries for which the predicate is #1." "The right side contains all entries for which the predicate is #0.")} (All [a] (-> (-> a Bit) (Sequence a) [(Sequence a) (Sequence a)])) - [(filter p xs) (filter (complement p) xs)]) + [(filter left? xs) (filter (bit.complement left?) xs)]) (structure: #export functor (Functor Sequence) (def: (map f fa) diff --git a/stdlib/source/lux/data/format/markdown.lux b/stdlib/source/lux/data/format/markdown.lux index 757fca9b3..5fcf85cbf 100644 --- a/stdlib/source/lux/data/format/markdown.lux +++ b/stdlib/source/lux/data/format/markdown.lux @@ -38,14 +38,20 @@ Text + (def: #export empty + Markdown + (:abstraction "")) + (def: #export text (-> Text (Markdown Span)) (|>> ..sanitize :abstraction)) + (def: blank-line (format text.new-line text.new-line)) + (do-template [ ] [(def: #export ( content) (-> Text Markdown) - (:abstraction (format (..sanitize content) text.new-line)))] + (:abstraction (format " " (..sanitize content) ..blank-line)))] [heading/1 "#"] [heading/2 "##"] @@ -55,8 +61,6 @@ [heading/6 "######"] ) - (def: blank-line (format text.new-line text.new-line)) - (def: (block content) (-> Text (Markdown Block)) (:abstraction (format content ..blank-line))) @@ -136,7 +140,9 @@ (def: #export code {#.doc "A block of code."} (-> Text (Markdown Block)) - (|>> ..indent ..block)) + (let [open (format "```" text.new-line) + close (format text.new-line "```")] + (|>> (text.enclose [open close]) ..block))) (def: #export (image description url) (-> Text URL (Markdown Span)) diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux index 921e7c96c..a87aa0626 100644 --- a/stdlib/source/lux/data/text.lux +++ b/stdlib/source/lux/data/text.lux @@ -150,9 +150,6 @@ #.None (#.Cons sample #.Nil))) -(def: #export split-lines - (..split-all-with ..new-line)) - (def: #export (replace-once pattern value template) (-> Text Text Text Text) (<| (maybe.default template) diff --git a/stdlib/source/lux/macro.lux b/stdlib/source/lux/macro.lux index abfcd4d86..a4b439c62 100644 --- a/stdlib/source/lux/macro.lux +++ b/stdlib/source/lux/macro.lux @@ -185,7 +185,7 @@ [get-record-ann #.Record (List [Code Code])] ) -(def: #export (get-doc anns) +(def: #export (get-documentation anns) {#.doc "Looks-up a definition's documentation."} (-> Code (Maybe Text)) (get-text-ann (name-of #.doc) anns)) @@ -201,12 +201,12 @@ (-> Code Bit) (flag-set? (name-of )))] - [export? #.export? "exported"] - [macro? #.macro? "a macro"] - [type? #.type? "a type"] - [struct? #.struct? "a structure"] - [type-rec? #.type-rec? "a recursive type"] - [sig? #.sig? "a signature"] + [export? #.export? "exported"] + [macro? #.macro? "a macro"] + [type? #.type? "a type"] + [structure? #.struct? "a structure"] + [recursive-type? #.type-rec? "a recursive type"] + [signature? #.sig? "a signature"] ) (def: #export (aliased? annotations) @@ -242,9 +242,9 @@ args (parse-tuple _args)] (monad.map @ parse-text args))))] - [func-args #.func-args "Looks up the arguments of a function."] - [type-args #.type-args "Looks up the arguments of a parameterized type."] - [declared-tags #.tags "Looks up the tags of a tagged (variant or record) type."] + [function-arguments #.func-args "Looks up the arguments of a function."] + [type-arguments #.type-args "Looks up the arguments of a parameterized type."] + [declared-tags #.tags "Looks up the tags of a tagged (variant or record) type."] ) (def: (find-macro' modules this-module module name) diff --git a/stdlib/source/program/scriptum.lux b/stdlib/source/program/scriptum.lux new file mode 100644 index 000000000..a9a72ca36 --- /dev/null +++ b/stdlib/source/program/scriptum.lux @@ -0,0 +1,518 @@ +(.module: + [lux #* + [control + [pipe (#+ when>)] + ["." monad (#+ do)] + ["ex" exception (#+ exception:)] + [security + ["!" capability]]] + [cli (#+ program:)] + [data + ["." maybe] + ["." product] + ["." error (#+ Error)] + [format + ["md" markdown (#+ Markdown Span Block)]] + ["." text ("text/." equivalence) + format + ["." encoding]] + [collection + ["." sequence (#+ Sequence) ("sequence/." functor)] + ["." list ("list/." functor fold)]]] + ["." function] + ["." type] + ["." macro] + ["." io (#+ IO io)] + [world + ["." file (#+ File)]]]) + +(def: name-options "abcdefghijklmnopqrstuvwxyz") +(def: name-options-count (text.size name-options)) + +(def: (parameter-type-name id) + (-> Nat Text) + (case (text.nth id ..name-options) + (#.Some char) + (text.from-code 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.iterate inc) (sequence/map parameter-type-name))) + +(do-template [ ] + [(def: ( id) + (-> Nat Bit) + ( 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.nth arg-id type-function-arguments) + (#.Some found) + found + + _ + (|> type-var-names + (sequence.filter (function (_ var-name) + (not (list.member? text.equivalence type-function-arguments var-name)))) + (sequence.nth arg-id)))) + type-func-name)) + +(def: (level->args offset level) + (-> Nat Nat (List Text)) + (if (n/= 0 level) + (list) + (|> level + dec + (list.n/range 0) + (list/map (|>> (n/+ (inc offset)) parameter-type-name))))) + +(def: (prefix-lines prefix lines) + (-> Text Text Text) + (|> lines + (text.split-all-with text.new-line) + (list/map (|>> (format prefix))) + (text.join-with text.new-line))) + +(def: (pprint-type-definition level type-func-info tags module signature? recursive-type? type) + (-> Nat [Text (List Text)] (List Name) Text Bit Bit Type Text) + (case tags + (^ (list [_ single-tag])) + (if signature? + (format "(: " (pprint-type-definition level type-func-info #.None module signature? recursive-type? type) text.new-line " " single-tag ")") + (format "{#" single-tag " " (pprint-type-definition level type-func-info #.None module signature? recursive-type? type) "}")) + + _ + (case [recursive-type? type] + [_ (#.Primitive name params)] + (case params + #.Nil + (format "(primitive " (%t name) ")") + + _ + (format "(primitive " (%t name) " " (|> params (list/map (pprint-type-definition level type-func-info #.None module signature? recursive-type?)) (text.join-with " ")) ")")) + + [_ (#.Sum _)] + (let [members (type.flatten-variant type)] + (case tags + #.Nil + (format "(| " + (|> members + (list/map (pprint-type-definition level type-func-info #.None module signature? recursive-type?)) + (text.join-with " ")) + ")") + + _ + (|> members + (list.zip2 tags) + (list/map (function (_ [[_ t-name] type]) + (case type + (#.Product _) + (let [types (type.flatten-tuple type)] + (format "(#" t-name " " + (|> types + (list/map (pprint-type-definition level type-func-info #.None module signature? recursive-type?)) + (text.join-with " ")) + ")")) + + _ + (format "(#" t-name " " (pprint-type-definition level type-func-info #.None module signature? recursive-type? type) ")")))) + (text.join-with text.new-line)))) + + [_ (#.Product _)] + (let [members (type.flatten-tuple type)] + (case tags + #.Nil + (format "[" (|> members (list/map (pprint-type-definition level type-func-info #.None module signature? recursive-type?)) (text.join-with " ")) "]") + + _ + (let [member-docs (|> members + (list.zip2 tags) + (list/map (function (_ [[_ t-name] type]) + (if signature? + (format "(: " (pprint-type-definition level type-func-info #.None module signature? recursive-type? type) text.new-line " " t-name ")") + (format "#" t-name " " (pprint-type-definition level type-func-info #.None module signature? recursive-type? type))))) + (text.join-with (format text.new-line " ")))] + (if signature? + member-docs + (format "{" member-docs "}"))))) + + [_ (#.Function input output)] + (let [[ins out] (type.flatten-function type)] + (format "(-> " (|> ins (list/map (pprint-type-definition level type-func-info #.None module signature? recursive-type?)) (text.join-with " ")) + " " + (pprint-type-definition level type-func-info #.None module signature? recursive-type? out) + ")")) + + [_ (#.Parameter idx)] + (parameter->name type-func-info level idx) + + (^template [ 
 ]
+        [_ ( id)]
+        (format 
 (%n id) ))
+      ([#.Var "⌈v:" "⌋"]
+       [#.Ex  "⟨e:" "⟩"])
+
+      (^template [  ]
+        [_ ( _)]
+        (let [[level' body] ( type)
+              args (level->args level level')
+              body-doc (pprint-type-definition (n/+ level level') type-func-info tags module signature? recursive-type? body)]
+          (format "("  " " "[" (text.join-with " " args) "]"
+                  (case tags
+                    #.Nil
+                    (format " " body-doc)
+
+                    _
+                    (format text.new-line (prefix-lines "  " body-doc)))
+                  ")")))
+      ([#.UnivQ "All" type.flatten-univ-q]
+       [#.ExQ   "Ex"  type.flatten-ex-q])
+
+      [true (#.Apply (#.Parameter 1) (#.Parameter 0))]
+      (product.left type-func-info)
+
+      [_ (#.Apply param fun)]
+      (let [[type-func type-arguments] (type.flatten-application type)]
+        (format  "(" (pprint-type-definition level type-func-info tags module signature? recursive-type? type-func) " " (|> type-arguments (list/map (pprint-type-definition level type-func-info #.None module signature? recursive-type?)) (text.join-with " ")) ")"))
+
+      [_ (#.Named [_module _name] type)]
+      (if (text/= module _module)
+        _name
+        (%name [_module _name]))
+      )))
+
+(def: (pprint-type level type-func-name module type)
+  (-> Nat Text Text Type Text)
+  (case type
+    (#.Primitive name params)
+    (case params
+      #.Nil
+      (format "(primitive " (%t name) ")")
+
+      _
+      (format "(primitive " (%t name) " " (|> params (list/map (pprint-type level type-func-name module)) (list.interpose " ") (text.join-with "")) ")"))
+
+    (#.Sum _)
+    (let [members (type.flatten-variant type)]
+      (format "(| " (|> members (list/map (pprint-type level type-func-name module)) (list.interpose " ") (text.join-with "")) ")"))
+
+    (#.Product _)
+    (let [members (type.flatten-tuple type)]
+      (format "[" (|> members (list/map (pprint-type level type-func-name module)) (list.interpose " ") (text.join-with "")) "]"))
+
+    (#.Function input output)
+    (let [[ins out] (type.flatten-function type)]
+      (format  "(-> "
+               (|> ins (list/map (pprint-type level type-func-name module)) (list.interpose " ") (text.join-with ""))
+               " "
+               (pprint-type level type-func-name module out)
+               ")"))
+
+    (#.Parameter idx)
+    (parameter->name [type-func-name (list)] level idx)
+
+    (^template [ 
 ]
+      ( id)
+      (format 
 (%n id) ))
+    ([#.Var "⌈" "⌋"]
+     [#.Ex  "⟨" "⟩"])
+
+    (^template [  ]
+      ( _)
+      (let [[level' body] ( type)
+            args (level->args level level')
+            body-doc (pprint-type (n/+ level level') type-func-name module body)]
+        (format "("  " " "[" (|> args (list.interpose " ") (text.join-with "")) "]"
+                (format " " body-doc)
+                ")")))
+    ([#.UnivQ "All" type.flatten-univ-q]
+     [#.ExQ   "Ex"  type.flatten-ex-q])
+
+    (#.Apply param fun)
+    (let [[type-func type-arguments] (type.flatten-application type)]
+      (format  "(" (pprint-type level type-func-name module type-func) " " (|> type-arguments (list/map (pprint-type level type-func-name module)) (list.interpose " ") (text.join-with "")) ")"))
+
+    (#.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])
+   #structures (List Value)
+   #values (List Value)})
+
+(def: (lux-module? module-name)
+  (-> Text Bit)
+  (or (text/= "lux" module-name)
+      (text.starts-with? "lux/" module-name)))
+
+(def: (add-definition [name [def-type def-annotations def-value]] organization)
+  (-> [Text Definition] Organization Organization)
+  (cond (macro.type? def-annotations)
+        (update@ #types
+                 (: (Mutation (List Value))
+                    (|>> (#.Cons [name def-annotations (:coerce Type def-value)])))
+                 organization)
+
+        (macro.macro? def-annotations)
+        (update@ #macros
+                 (: (Mutation (List [Text Code]))
+                    (|>> (#.Cons [name def-annotations])))
+                 organization)
+
+        (macro.structure? def-annotations)
+        (update@ #structures
+                 (: (Mutation (List Value))
+                    (|>> (#.Cons [name def-annotations def-type])))
+                 organization)
+
+        ## else
+        (update@ #values
+                 (: (Mutation (List Value))
+                    (|>> (#.Cons [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)
+              #structures (list)
+              #values (list)}]
+    (|> (list/fold add-definition init defs)
+        (update@ #types (list.sort name-sort))
+        (update@ #macros (list.sort name-sort))
+        (update@ #structures (list.sort name-sort))
+        (update@ #values (list.sort name-sort)))))
+
+(def: (unravel-type-func level type)
+  (-> Nat Type Type)
+  (if (n/> 0 level)
+    (case type
+      (#.UnivQ _env _type)
+      (unravel-type-func (dec level) _type)
+
+      _
+      type)
+    type))
+
+(def: (unrecurse-type type)
+  (-> Type Type)
+  (case type
+    (#.Apply _ (#.UnivQ _env _type))
+    _type
+
+    _
+    type))
+
+(exception: #export (anonymous-type-definition {type Type})
+  (ex.report ["Type" (%type type)]))
+
+(def: (document-type module type def-annotations)
+  (-> Text Type Code (Meta (Markdown Block)))
+  (case type
+    (#.Named type-name type)
+    (do macro.monad
+      [tags (macro.tags-of type-name)
+       #let [[_ _name] type-name
+             recursive-type? (macro.recursive-type? def-annotations)
+             ## type (: Type
+             ##         (case [recursive-type? type]
+             ##           [#1 (#.Apply dummyT (#.UnivQ _closure recursiveT))]
+             ##           recursiveT
+
+             ##           _
+             ##           type))
+             type-arguments (macro.type-arguments def-annotations)
+             signature? (macro.signature? def-annotations)
+             usage (case type-arguments
+                     #.Nil
+                     _name
+
+                     _
+                     (format "(" (text.join-with " " (list& _name type-arguments)) ")"))
+             nesting (list.size type-arguments)]]
+      (wrap (md.code (format (if signature? "(signature: " "(type: ")
+                             (if recursive-type? "#rec " "")
+                             usage text.new-line
+                             (|> type
+                                 (unravel-type-func nesting)
+                                 (when> recursive-type? [unrecurse-type])
+                                 (pprint-type-definition (dec nesting) [_name type-arguments] (maybe.default (list) tags) module signature? recursive-type?)
+                                 (text.split-all-with text.new-line)
+                                 (list/map (|>> (format "  ")))
+                                 (text.join-with text.new-line))
+                             ")"))))
+
+    _
+    (macro.fail (ex.construct anonymous-type-definition type))))
+
+(def: (document-types module types)
+  (-> Text (List Value) (Meta (Markdown Block)))
+  (do macro.monad
+    [type-docs (monad.map @
+                          (: (-> Value (Meta (Markdown Block)))
+                             (function (_ [name def-annotations type])
+                               (do macro.monad
+                                 [#let [?doc (macro.get-documentation def-annotations)]
+                                  type-code (document-type module type def-annotations)]
+                                 (wrap ($_ md.then
+                                           (md.heading/3 name)
+                                           (case ?doc
+                                             (#.Some doc)
+                                             (md.paragraph (md.text doc))
+
+                                             _
+                                             md.empty)
+                                           type-code)))))
+                          types)]
+    (wrap (list/fold (function.flip md.then)
+                     (md.heading/2 "Types")
+                     type-docs))))
+
+(def: (document-macros module-name names)
+  (-> Text (List [Text Code]) (Markdown Block))
+  (|> names
+      (list/map (: (-> [Text Code] (Markdown Block))
+                   (function (_ [name def-annotations])
+                     ($_ md.then
+                         (md.heading/3 name)
+                         (<| (: (Markdown Block))
+                             (maybe.default md.empty)
+                             (do maybe.monad
+                               [documentation (macro.get-documentation def-annotations)]
+                               (wrap (md.code documentation))))))))
+      (list/fold (function.flip md.then)
+                 (md.heading/2 "Macros"))))
+
+(do-template [  
]
+  [(def: ( module type)
+     (-> Text Type (Markdown Block))
+     (md.code (pprint-type (dec 0) "?" module type)))
+
+   (def: ( module values)
+     (-> Text (List Value) (Markdown Block))
+     (|> values
+         (list/map (function (_ [name def-annotations value-type])
+                     (let [?doc (macro.get-documentation def-annotations)
+                           usage (case (macro.function-arguments def-annotations)
+                                   #.Nil
+                                   name
+
+                                   args
+                                   (format "(" (text.join-with " " (list& name args)) ")"))]
+                       ($_ md.then
+                           (md.heading/3 usage)
+                           (case ?doc
+                             (#.Some doc)
+                             (md.code doc)
+
+                             _
+                             md.empty)
+                           ( module value-type)))))
+         (list/fold (function.flip md.then)
+                    (md.heading/2 
))))]
+
+  [document-structure document-structures "Structures"]
+  [document-value     document-values     "Values"]
+  )
+
+(def: (enclose-lines pre+post block)
+  (-> [Text Text] Text Text)
+  (|> block
+      (text.split-all-with text.new-line)
+      (list/map (text.enclose pre+post))
+      (text.join-with text.new-line)))
+
+(def: (document-module [[module-name module] organization])
+  (-> [[Text Module] Organization] (Meta [Text (Markdown Block)]))
+  (do macro.monad
+    [#let [(^slots [#types #macros #structures #values]) organization
+           annotations (|> module
+                           (get@ #.module-annotations)
+                           (maybe.default (' {}))
+                           macro.get-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)
+                           (wrap 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? structures) empty-block (document-structures module-name structures))
+                             (if (list.empty? values) empty-block (document-values module-name values)))]]
+    (wrap [module-name
+           ($_ md.then
+               (md.heading/1 module-name)
+               description
+               documentation)])))
+
+(exception: #export (io-error {error Text})
+  error)
+
+(def: (save-documentation! [module-name documentation])
+  (-> [Text (Markdown Block)] (IO Any))
+  (let [path (format (text.replace-all "/" "_" module-name) ".md")]
+    (do io.monad
+      [outcome (do (error.with-error io.monad)
+                 [target (: (IO (Error (File IO)))
+                            (file.get-file io.monad file.system path))]
+                 (!.use (:: target over-write) (encoding.to-utf8 (md.markdown documentation))))]
+      (case outcome
+        (#error.Failure error)
+        (wrap (log! (ex.construct io-error error)))
+
+        (#error.Success _)
+        (wrap [])))))
+
+(macro: (gen-documentation! _)
+  (do macro.monad
+    [all-modules macro.modules
+     #let [lux-modules (|> all-modules
+                           (list.filter (function.compose lux-module? product.left))
+                           (list.sort name-sort))]
+     lux-exports (monad.map @ (function.compose macro.exports product.left)
+                            lux-modules)
+     module-documentation (|> (list/map organize-definitions lux-exports)
+                              (list.zip2 lux-modules)
+                              (monad.map @ document-module))
+     #let [_ (io.run (monad.map io.monad save-documentation! module-documentation))]]
+    (wrap (list))))
+
+(gen-documentation!)
+
+(program: args
+  (io (log! "Done!")))
-- 
cgit v1.2.3