aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2019-02-05 02:14:27 -0400
committerEduardo Julian2019-02-05 02:14:27 -0400
commitbe5710d104e6ee085dcb9d871be0b80305e48f8b (patch)
tree4efce24bf16672dd0a3042b36567ec0f136a4ae8
parent55d1b60e0fec6f24f1ab21d299fe04640c3e2ce3 (diff)
Migrated documentation tool's code into stdlib.
-rw-r--r--luxdoc/project.clj11
-rw-r--r--luxdoc/source/program.lux601
-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
11 files changed, 605 insertions, 699 deletions
diff --git a/luxdoc/project.clj b/luxdoc/project.clj
deleted file mode 100644
index de51950bb..000000000
--- a/luxdoc/project.clj
+++ /dev/null
@@ -1,11 +0,0 @@
-(defproject luxdoc "0.5.0"
- :description "Documentation generator for the Lux programming language's ."
- :url "https://github.com/LuxLang/luxdoc"
- :license {:name "Lux License v0.1"
- :url "https://github.com/LuxLang/lux/blob/master/license.txt"}
- :plugins [[com.github.luxlang/lein-luxc "0.5.0"]]
- :dependencies []
- :repositories [["snapshots" "https://oss.sonatype.org/content/repositories/snapshots/"]
- ["releases" "https://oss.sonatype.org/service/local/staging/deploy/maven2/"]]
- :source-paths ["source"]
- :lux {:program "program"})
diff --git a/luxdoc/source/program.lux b/luxdoc/source/program.lux
deleted file mode 100644
index 94b5df37f..000000000
--- a/luxdoc/source/program.lux
+++ /dev/null
@@ -1,601 +0,0 @@
-## Copyright (c) Eduardo Julian. All rights reserved.
-## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-## If a copy of the MPL was not distributed with this file,
-## You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(;module:
- lux
- (lux [cli #+ program:]
- [compiler #+ Monad<Lux>]
- host
- [lexer]
- [macro]
- [math]
- [pipe]
- [random]
- [regex]
- [test]
- [type]
- (codata [cont]
- [env]
- function
- [io #- run]
- [state]
- (struct [stream #+ Stream "Stream/" Functor<Stream>]))
- (concurrency [actor]
- [atom]
- [frp]
- [promise]
- [stm])
- (control [applicative]
- [bounded]
- [codec]
- [comonad]
- [effect]
- [enum]
- [eq]
- [fold]
- [functor]
- [hash]
- monad
- [monoid]
- ["_;" number]
- [ord])
- (data [bit]
- [bool]
- [char]
- [error]
- [ident "Ident/" Codec<Text,Ident>]
- [identity]
- [log]
- maybe
- [number #* "Nat/" Codec<Text,Nat>]
- [product]
- [sum]
- [text "Text/" Monoid<Text> Eq<Text>]
- (error [exception])
- (format [json])
- (struct [array]
- [dict]
- [list #+ "List/" Monoid<List> Functor<List> Fold<List>]
- [queue]
- [set]
- [stack]
- [tree]
- [vector]
- [zipper])
- text/format)
- (macro [ast]
- [poly]
- ["s" syntax]
- (poly ["poly_;" eq]
- ["poly_;" functor]
- ["poly_;" text-encoder])
- (syntax [common]))
- (math [complex]
- [ratio]
- [simple])
- (type [auto]
- [check])
- ))
-
-(def: name-options "abcdefghijklmnopqrstuvwxyz")
-(def: name-options-count (text;size name-options))
-
-(def: (id->name id)
- (-> Nat Text)
- (if (n.> name-options-count id)
- (format (id->name (n./ name-options-count id))
- (id->name (n.% name-options-count id)))
- (char;as-text (default #"?" (text;at id name-options)))))
-
-(def: type-var-names
- (Stream Text)
- (Stream/map id->name (stream;iterate n.inc +0)))
-
-(def: (type-arg? id)
- (-> Nat Bool)
- (n.= +1 (n.% +2 id)))
-
-(def: (arg-id level id)
- (-> Nat Nat Nat)
- (n.- (n./ +2 id) level))
-
-(def: (bound->name [type-fun-name type-fun-args] level id)
- (-> [Text (List Text)] Nat Nat Text)
- (if (type-arg? id)
- (let [_arg-id (arg-id level id)]
- (case (list;at _arg-id type-fun-args)
- (#;Some found)
- found
-
- _
- (|> type-var-names
- (stream;filter (lambda [var-name] (not (list;member? text;Eq<Text> type-fun-args var-name))))
- (stream;at _arg-id))))
- type-fun-name))
-
-(do-template [<name> <base> <tag>]
- [(def: (<base> level type)
- (-> Nat Type [Nat Type])
- (case type
- (<tag> env type')
- (<base> (n.inc level) type')
-
- _
- [level type]))
-
- (def: <name> (<base> +0))]
-
- [unravel-univ unravel-univ' #;UnivQ]
- [unravel-ex unravel-ex' #;ExQ])
-
-(def: (level->args offset level)
- (-> Nat Nat (List Text))
- (if (n.= +0 level)
- (list)
- (|> level
- n.dec
- (list;n.range +0)
- (List/map (|>. (n.+ (n.inc offset)) id->name)))))
-
-(def: (prefix-lines prefix lines)
- (-> Text Text Text)
- (|> lines
- text;split-lines
- (List/map (Text/append prefix))
- ## (list;interpose "\n")
- (text;join-with "")))
-
-(def: (pprint-type-def level type-fun-info tags module sig? type-rec? type)
- (-> Nat [Text (List Text)] (List Ident) Text Bool Bool Type Text)
- (case tags
- (^ (list [_ single-tag]))
- (if sig?
- (format "(: " (pprint-type-def level type-fun-info #;None module sig? type-rec? type) "\n " single-tag ")")
- (format "{#" single-tag " " (pprint-type-def level type-fun-info #;None module sig? type-rec? type) "}"))
-
- _
- (case [type-rec? type]
- [_ (#;HostT name params)]
- (case params
- #;Nil
- (format "(host " name ")")
-
- _
- (format "(host " name " " (|> params (List/map (pprint-type-def level type-fun-info #;None module sig? type-rec?)) (text;join-with " ")) ")"))
-
- [_ #;VoidT]
- "Void"
-
- [_ #;UnitT]
- "Unit"
-
- [_ (#;SumT _)]
- (let [members (type;flatten-variant type)]
- (case tags
- #;Nil
- (format "(| "
- (|> members
- (List/map (pprint-type-def level type-fun-info #;None module sig? type-rec?))
- (text;join-with " "))
- ")")
-
- _
- (|> members
- (list;zip2 tags)
- (List/map (lambda [[[_ t-name] type]]
- (case type
- #;UnitT
- (format "#" t-name)
-
- (#;ProdT _)
- (let [types (type;flatten-tuple type)]
- (format "(#" t-name " "
- (|> types
- (List/map (pprint-type-def level type-fun-info #;None module sig? type-rec?))
- (text;join-with " "))
- ")"))
-
- _
- (format "(#" t-name " " (pprint-type-def level type-fun-info #;None module sig? type-rec? type) ")"))))
- (text;join-with "\n"))))
-
- [_ (#;ProdT _)]
- (let [members (type;flatten-tuple type)]
- (case tags
- #;Nil
- (format "[" (|> members (List/map (pprint-type-def level type-fun-info #;None module sig? type-rec?)) (text;join-with " ")) "]")
-
- _
- (let [member-docs (|> members
- (list;zip2 tags)
- (List/map (lambda [[[_ t-name] type]]
- (if sig?
- (format "(: " (pprint-type-def level type-fun-info #;None module sig? type-rec? type) "\n " t-name ")")
- (format "#" t-name " " (pprint-type-def level type-fun-info #;None module sig? type-rec? type)))))
- (text;join-with "\n "))]
- (if sig?
- member-docs
- (format "{" member-docs "}")))))
-
- [_ (#;LambdaT input output)]
- (let [[ins out] (type;flatten-function type)]
- (format "(-> " (|> ins (List/map (pprint-type-def level type-fun-info #;None module sig? type-rec?)) (text;join-with " "))
- " "
- (pprint-type-def level type-fun-info #;None module sig? type-rec? out)
- ")"))
-
- [_ (#;BoundT idx)]
- (bound->name type-fun-info level idx)
-
- (^template [<tag> <pre> <post>]
- [_ (<tag> id)]
- (format <pre> (Nat/encode id) <post>))
- ([#;VarT "⌈v:" "⌋"]
- [#;ExT "⟨e:" "⟩"])
-
- (^template [<tag> <name> <unravel>]
- [_ (<tag> _)]
- (let [[level' body] (<unravel> type)
- args (level->args level level')
- body-doc (pprint-type-def (n.+ level level') type-fun-info tags module sig? type-rec? body)]
- (format "(" <name> " " "[" (text;join-with " " args) "]"
- (case tags
- #;Nil
- (format " " body-doc)
-
- _
- (format "\n" (prefix-lines " " body-doc)))
- ")")))
- ([#;UnivQ "All" unravel-univ]
- [#;ExQ "Ex" unravel-ex])
-
- [true (#;AppT (#;BoundT +0) (#;BoundT +1))]
- (product;left type-fun-info)
-
- [_ (#;AppT fun param)]
- (let [[type-fun type-args] (type;flatten-application type)]
- (format "(" (pprint-type-def level type-fun-info tags module sig? type-rec? type-fun) " " (|> type-args (List/map (pprint-type-def level type-fun-info #;None module sig? type-rec?)) (text;join-with " ")) ")"))
-
- [_ (#;NamedT [_module _name] type)]
- (if (Text/= module _module)
- _name
- (Ident/encode [_module _name]))
- )))
-
-(def: (pprint-type level type-fun-name module type)
- (-> Nat Text Text Type Text)
- (case type
- (#;HostT name params)
- (case params
- #;Nil
- (format "(host " name ")")
-
- _
- (format "(host " name " " (|> params (List/map (pprint-type level type-fun-name module)) (list;interpose " ") (text;join-with "")) ")"))
-
- #;VoidT
- "Void"
-
- (#;SumT _)
- (let [members (type;flatten-variant type)]
- (format "(| " (|> members (List/map (pprint-type level type-fun-name module)) (list;interpose " ") (text;join-with "")) ")"))
-
- #;UnitT
- "Unit"
-
- (#;ProdT _)
- (let [members (type;flatten-tuple type)]
- (format "[" (|> members (List/map (pprint-type level type-fun-name module)) (list;interpose " ") (text;join-with "")) "]"))
-
- (#;LambdaT input output)
- (let [[ins out] (type;flatten-function type)]
- (format "(-> "
- (|> ins (List/map (pprint-type level type-fun-name module)) (list;interpose " ") (text;join-with ""))
- " "
- (pprint-type level type-fun-name module out)
- ")"))
-
- (#;BoundT idx)
- (bound->name [type-fun-name (list)] level idx)
-
- (^template [<tag> <pre> <post>]
- (<tag> id)
- (format <pre> (Nat/encode id) <post>))
- ([#;VarT "⌈" "⌋"]
- [#;ExT "⟨" "⟩"])
-
- (^template [<tag> <name> <unravel>]
- (<tag> _)
- (let [[level' body] (<unravel> type)
- args (level->args level level')
- body-doc (pprint-type (n.+ level level') type-fun-name module body)]
- (format "(" <name> " " "[" (|> args (list;interpose " ") (text;join-with "")) "]"
- (format " " body-doc)
- ")")))
- ([#;UnivQ "All" unravel-univ]
- [#;ExQ "Ex" unravel-ex])
-
- (#;AppT fun param)
- (let [[type-fun type-args] (type;flatten-application type)]
- (format "(" (pprint-type level type-fun-name module type-fun) " " (|> type-args (List/map (pprint-type level type-fun-name module)) (list;interpose " ") (text;join-with "")) ")"))
-
- (#;NamedT [_module _name] type)
- (if (Text/= module _module)
- _name
- (Ident/encode [_module _name]))
- ))
-
-(type: Markdown
- Text)
-
-(type: DefOrg
- {#types (List [Text Anns Type])
- #macros (List [Text Anns])
- #structs (List [Text Anns Type])
- #values (List [Text Anns Type])})
-
-(def: (lux-module? module-name)
- (-> Text Bool)
- (or (Text/= "lux" module-name)
- (text;starts-with? "lux/" module-name)))
-
-(do-template [<name> <joiner>]
- [(def: (<name> docs)
- (-> (List Markdown) Markdown)
- (text;join-with "\n\n" docs))]
-
- [join-def-docs "\n\n"]
- [join-doc-sections "\n\n"]
- )
-
-(def: (cons h t)
- (All [a] (-> a (List a) (List a)))
- (#;Cons h t))
-
-(def: (add-def [name [def-type def-meta def-value]] org)
- (-> [Text Def] DefOrg DefOrg)
- (cond (compiler;type? def-meta)
- (update@ #types (cons [name def-meta (:coerce Type def-value)]) org)
-
- (compiler;macro? def-meta)
- (update@ #macros (cons [name def-meta]) org)
-
- (compiler;struct? def-meta)
- (update@ #structs (cons [name def-meta def-type]) org)
-
- ## else
- (update@ #values (cons [name def-meta def-type]) org)))
-
-(def: def-sorter
- (All [r] (-> (List [Text r]) (List [Text r])))
- (list;sort (: (All [r] (-> [Text r] [Text r] Bool))
- (lambda [[n1 _] [n2 _]] (:: text;Ord<Text> < n1 n2)))))
-
-(def: (organize-defs defs)
- (-> (List [Text Def]) DefOrg)
- (let [init {#types (list)
- #macros (list)
- #structs (list)
- #values (list)}]
- (|> (List/fold add-def init defs)
- (update@ #types def-sorter)
- (update@ #macros def-sorter)
- (update@ #structs def-sorter)
- (update@ #values def-sorter))))
-
-(def: (unravel-type-func level type)
- (-> Nat Type Type)
- (if (n.> +0 level)
- (case type
- (#;UnivQ _env _type)
- (unravel-type-func (n.dec level) _type)
-
- _
- type)
- type))
-
-(def: (unrecurse-type type)
- (-> Type Type)
- (case type
- (#;AppT (#;UnivQ _env _type) _)
- _type
-
- _
- type))
-
-(def: #export (when! test f x)
- (All [a] (-> Bool (-> a a) a a))
- (if test
- (f x)
- x))
-
-(def: #export (if! test f g x)
- (All [a b] (-> Bool (-> a b) (-> a b) a b))
- (if test
- (f x)
- (g x)))
-
-(def: (doc-type module type def-meta)
- (-> Text Type Anns (Lux Markdown))
- (case type
- (#;NamedT type-name type)
- (do Monad<Lux>
- [tags (compiler;tags-of type-name)
- #let [[_ _name] type-name
- type-rec? (compiler;type-rec? def-meta)
- type-args (compiler;type-args def-meta)
- sig? (compiler;sig? def-meta)
- usage (case type-args
- #;Nil
- _name
-
- _
- (format "(" (text;join-with " " (list& _name type-args)) ")"))
- nesting (list;size type-args)]]
- (wrap (format (if sig? "(signature: " "(type: ") (if type-rec? "#rec " "") usage "\n"
- (|> (pprint-type-def (n.dec nesting)
- [_name type-args]
- tags module sig? type-rec?
- (|> type
- (unravel-type-func nesting)
- (when! type-rec? unrecurse-type)))
- text;split-lines
- (List/map (Text/append " "))
- (text;join-with "\n"))
- ")")))
-
- _
- (compiler;fail (format "A type definition must always be named! - " (type;to-text type)))))
-
-(def: (doc-types module types)
- (-> Text (List [Text Anns Type]) (Lux Markdown))
- (do Monad<Lux>
- [type-docs (mapM @
- (: (-> [Text Anns Type] (Lux Markdown))
- (lambda [[name def-meta type]]
- (do Monad<Lux>
- [#let [?doc (compiler;get-doc def-meta)
- name (|> name
- (text;replace "<" "&lt;")
- (text;replace ">" "&gt;"))]
- type-doc (doc-type module type def-meta)]
- (wrap (format "### " name "\n"
- (case ?doc
- (#;Some doc)
- (format doc "\n")
-
- _
- "")
- "```\n" type-doc "\n```")))))
- types)]
- (|> type-docs
- join-def-docs
- (format "## Types\n")
- wrap)))
-
-(def: (doc-macros module-name names)
- (-> Text (List [Text Anns]) Markdown)
- (|> names
- (List/map (: (-> [Text Anns] Markdown)
- (lambda [[name def-meta]]
- (let [name (|> name
- (text;replace "<" "&lt;")
- (text;replace ">" "&gt;"))]
- (format "### " name "\n"
- (default ""
- (do Monad<Maybe>
- [doc (compiler;get-doc def-meta)]
- (wrap (format "```\n" doc "\n```")))))))))
- join-def-docs
- (format "## Macros\n")))
-
-(do-template [<singular> <plural> <header>]
- [(def: <singular>
- (-> Text Type Markdown)
- (pprint-type (n.dec +0) "?"))
-
- (def: (<plural> module values)
- (-> Text (List [Text Anns Type]) Markdown)
- (|> values
- (List/map (lambda [[name def-meta value-type]]
- (let [?doc (compiler;get-doc def-meta)
- usage (case (compiler;func-args def-meta)
- #;Nil
- name
-
- args
- (format "(" (text;join-with " " (list& name args)) ")"))
- usage (|> usage
- (text;replace "<" "&lt;")
- (text;replace ">" "&gt;"))]
- (format "### " usage "\n"
- (case ?doc
- (#;Some doc)
- (format "```\n" doc "\n```\n")
-
- _
- "")
- "`" (<singular> module value-type) "`"))))
- join-def-docs
- (format <header>)))]
-
- [doc-struct doc-structs "## Structs\n"]
- [doc-value doc-values "## Values\n"]
- )
-
-(def: (enclose-lines pre+post block)
- (-> [Text Text] Text Text)
- (|> block
- text;split-lines
- (List/map (text;enclose pre+post))
- (text;join-with "\n")))
-
-(def: (doc-module [[module-name module] org])
- (-> [[Text Module] DefOrg] (Lux [Text Markdown]))
- (do Monad<Lux>
- [#let [(^slots [#types #macros #structs #values]) org
- anns (|> module (get@ #;module-anns) compiler;get-doc)]
- types-md (if (list;empty? types)
- (wrap "")
- (doc-types module-name types))
- #let [doc-desc (case anns
- #;None
- ""
-
- (#;Some doc)
- (format "\n" (enclose-lines ["> " ""] doc) "\n"))
- doc-body (join-doc-sections (list types-md
- (if (list;empty? macros) "" (doc-macros module-name macros))
- (if (list;empty? structs) "" (doc-structs module-name structs))
- (if (list;empty? values) "" (doc-values module-name values))))]]
- (wrap [module-name
- (format "## " module-name "\n"
- doc-desc "\n"
- doc-body)])))
-
-(jvm-import java.io.File
- (new [java.lang.String]))
-
-(jvm-import java.io.PrintWriter
- (new [java.io.File] #io #try)
- (println [java.lang.String] #io void))
-
-(jvm-import java.io.Writer
- (flush [] #io #try void))
-
-(def: (save-docs! [module-name docs])
- (-> [Text Markdown] (IO Unit))
- (do Monad<IO>
- [?target (|> (format (text;replace "/" "_" module-name) ".md")
- File.new
- PrintWriter.new)]
- (case ?target
- (#;Left _)
- (wrap [])
-
- (#;Right target)
- (do @
- [_ (PrintWriter.println docs target)
- _ (Writer.flush [] target)]
- (wrap [])))))
-
-(macro: (gen-docs! _)
- (do Monad<Lux>
- [all-modules compiler;modules
- #let [lux-modules (|> all-modules
- (list;filter (. lux-module? product;left))
- (list;sort (lambda [[left _] [right _]]
- (:: text;Ord<Text> < left right))))]
- lux-exports (mapM @ (. compiler;exports product;left) lux-modules)
- module-docs (mapM @ doc-module
- (list;zip2 lux-modules
- (List/map organize-defs lux-exports)))
- #let [_ (io;run (mapM Monad<IO> save-docs! module-docs))]]
- (wrap (list))))
-
-(gen-docs!)
-
-(program: args
- (io (log! "Done!")))
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!")))