aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
authorEduardo Julian2019-02-05 02:14:27 -0400
committerEduardo Julian2019-02-05 02:14:27 -0400
commitbe5710d104e6ee085dcb9d871be0b80305e48f8b (patch)
tree4efce24bf16672dd0a3042b36567ec0f136a4ae8 /stdlib
parent55d1b60e0fec6f24f1ab21d299fe04640c3e2ce3 (diff)
Migrated documentation tool's code into stdlib.
Diffstat (limited to '')
-rw-r--r--stdlib/project.clj9
-rw-r--r--stdlib/source/lux.lux7
-rw-r--r--stdlib/source/lux/control/comonad.lux18
-rw-r--r--stdlib/source/lux/control/continuation.lux78
-rw-r--r--stdlib/source/lux/data/collection/sequence.lux25
-rw-r--r--stdlib/source/lux/data/format/markdown.lux14
-rw-r--r--stdlib/source/lux/data/text.lux3
-rw-r--r--stdlib/source/lux/macro.lux20
-rw-r--r--stdlib/source/program/scriptum.lux518
9 files changed, 605 insertions, 87 deletions
diff --git a/stdlib/project.clj b/stdlib/project.clj
index e9ed11d34..79319f540 100644
--- a/stdlib/project.clj
+++ b/stdlib/project.clj
@@ -16,9 +16,10 @@
:scm {:name "git"
:url "https://github.com/LuxLang/lux.git"}
- :dependencies []
-
:source-paths ["source"]
- :test-paths ["test"]
- :lux {:tests {:jvm "test"}}
+ :profiles {:library {:dependencies []
+ :test-paths ["test"]
+ :lux {:tests {:jvm "test"}}}
+ :documentation {:dependencies []
+ :lux {:program {:jvm "program/scriptum"}}}}
)
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 [<name> <return> <part>]
[(def: #export (<name> 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 [<name> <prefix>]
[(def: #export (<name> content)
(-> Text Markdown)
- (:abstraction (format <prefix> (..sanitize content) text.new-line)))]
+ (:abstraction (format <prefix> " " (..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 <tag>)))]
- [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 [<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.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 [<tag> <pre> <post>]
+ [_ (<tag> id)]
+ (format <pre> (%n id) <post>))
+ ([#.Var "⌈v:" "⌋"]
+ [#.Ex "⟨e:" "⟩"])
+
+ (^template [<tag> <name> <flatten>]
+ [_ (<tag> _)]
+ (let [[level' body] (<flatten> type)
+ args (level->args level level')
+ body-doc (pprint-type-definition (n/+ level level') type-func-info tags module signature? recursive-type? body)]
+ (format "(" <name> " " "[" (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 [<tag> <pre> <post>]
+ (<tag> id)
+ (format <pre> (%n id) <post>))
+ ([#.Var "⌈" "⌋"]
+ [#.Ex "⟨" "⟩"])
+
+ (^template [<tag> <name> <flatten>]
+ (<tag> _)
+ (let [[level' body] (<flatten> type)
+ args (level->args level level')
+ body-doc (pprint-type (n/+ level level') type-func-name module body)]
+ (format "(" <name> " " "[" (|> 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 [<singular> <plural> <header>]
+ [(def: (<singular> module type)
+ (-> Text Type (Markdown Block))
+ (md.code (pprint-type (dec 0) "?" module type)))
+
+ (def: (<plural> 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)
+ (<singular> module value-type)))))
+ (list/fold (function.flip md.then)
+ (md.heading/2 <header>))))]
+
+ [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!")))