diff options
Diffstat (limited to '')
| -rw-r--r-- | luxdoc/project.clj | 11 | ||||
| -rw-r--r-- | luxdoc/source/program.lux | 601 | ||||
| -rw-r--r-- | stdlib/project.clj | 9 | ||||
| -rw-r--r-- | stdlib/source/lux.lux | 7 | ||||
| -rw-r--r-- | stdlib/source/lux/control/comonad.lux | 18 | ||||
| -rw-r--r-- | stdlib/source/lux/control/continuation.lux | 78 | ||||
| -rw-r--r-- | stdlib/source/lux/data/collection/sequence.lux | 25 | ||||
| -rw-r--r-- | stdlib/source/lux/data/format/markdown.lux | 14 | ||||
| -rw-r--r-- | stdlib/source/lux/data/text.lux | 3 | ||||
| -rw-r--r-- | stdlib/source/lux/macro.lux | 20 | ||||
| -rw-r--r-- | stdlib/source/program/scriptum.lux | 518 |
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 "<" "<") - (text;replace ">" ">"))] - 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 "<" "<") - (text;replace ">" ">"))] - (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 "<" "<") - (text;replace ">" ">"))] - (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!"))) |