diff options
Diffstat (limited to 'stdlib/source')
198 files changed, 3533 insertions, 3249 deletions
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index b7de70c5d..334632272 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -1635,7 +1635,7 @@ ($' m a) ($' m b))))))) -(def:''' Monad<Maybe> +(def:''' maybe-monad #Nil ($' Monad Maybe) {#wrap @@ -1647,7 +1647,7 @@ (#Some a) (f a)} ma))}) -(def:''' Monad<Meta> +(def:''' meta-monad #Nil ($' Monad Meta) {#wrap @@ -1852,17 +1852,17 @@ (return (tag$ ["lux" "Nil"])) (#Cons lastI inits) - (do Monad<Meta> + (do meta-monad [lastO ({[_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))] (let' [[[_module-name _ _] _] spliced] (wrap spliced)) _ - (do Monad<Meta> + (do meta-monad [lastO (untemplate lastI)] (wrap (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list lastO (tag$ ["lux" "Nil"])))))))} lastI)] - (monad/fold Monad<Meta> + (monad/fold meta-monad (function' [leftI rightO] ({[_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))] (let' [[[_module-name _ _] _] spliced] @@ -1871,7 +1871,7 @@ rightO)))) _ - (do Monad<Meta> + (do meta-monad [leftO (untemplate leftI)] (wrap (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list leftO rightO))))))} leftI)) @@ -1879,8 +1879,8 @@ inits))} (list/reverse elems)) #0 - (do Monad<Meta> - [=elems (monad/map Monad<Meta> untemplate elems)] + (do meta-monad + [=elems (monad/map meta-monad untemplate elems)] (wrap (untemplate-list =elems)))} replace?)) @@ -1923,7 +1923,7 @@ (return (wrap-meta (form$ (list (tag$ ["lux" "Tag"]) (tuple$ (list (text$ module') (text$ name)))))))) [#1 [_ (#Identifier [module name])]] - (do Monad<Meta> + (do meta-monad [real-name ({"" (if (text/= "" subst) (wrap [module name]) @@ -1942,7 +1942,7 @@ (return unquoted) [#1 [_ (#Form (#Cons [[_ (#Identifier ["" "~!"])] (#Cons [dependent #Nil])]))]] - (do Monad<Meta> + (do meta-monad [independent (untemplate replace? subst dependent)] (wrap (wrap-meta (form$ (list (tag$ ["lux" "Form"]) (untemplate-list (list (untemplate-text "lux in-module") @@ -1953,24 +1953,24 @@ (untemplate #0 subst keep-quoted) [_ [meta (#Form elems)]] - (do Monad<Meta> + (do meta-monad [output (splice replace? (untemplate replace? subst) elems) #let [[_ output'] (wrap-meta (form$ (list (tag$ ["lux" "Form"]) output)))]] (wrap [meta output'])) [_ [meta (#Tuple elems)]] - (do Monad<Meta> + (do meta-monad [output (splice replace? (untemplate replace? subst) elems) #let [[_ output'] (wrap-meta (form$ (list (tag$ ["lux" "Tuple"]) output)))]] (wrap [meta output'])) [_ [_ (#Record fields)]] - (do Monad<Meta> - [=fields (monad/map Monad<Meta> + (do meta-monad + [=fields (monad/map meta-monad ("lux check" (-> (& Code Code) ($' Meta Code)) (function' [kv] (let' [[k v] kv] - (do Monad<Meta> + (do meta-monad [=k (untemplate replace? subst k) =v (untemplate replace? subst v)] (wrap (tuple$ (list =k =v))))))) @@ -2016,7 +2016,7 @@ "## All unprefixed macros will receive their parent module's prefix if imported; otherwise will receive the prefix of the module on which the quasi-quote is being used." __paragraph "(` (def: (~ name) (function ((~' _) (~+ args)) (~ body))))"))]) ({(#Cons template #Nil) - (do Monad<Meta> + (do meta-monad [current-module current-module-name =template (untemplate #1 current-module template)] (wrap (list (form$ (list (text$ "lux check") @@ -2033,7 +2033,7 @@ "## Unhygienic quasi-quotation as a macro. Unquote (~) and unquote-splice (~+) must also be used as forms." __paragraph "(`' (def: (~ name) (function (_ (~+ args)) (~ body))))"))]) ({(#Cons template #Nil) - (do Monad<Meta> + (do meta-monad [=template (untemplate #1 "" template)] (wrap (list (form$ (list (text$ "lux check") (identifier$ ["lux" "Code"]) =template))))) @@ -2047,7 +2047,7 @@ "## Quotation as a macro." __paragraph "(' YOLO)"))]) ({(#Cons template #Nil) - (do Monad<Meta> + (do meta-monad [=template (untemplate #0 "" template)] (wrap (list (form$ (list (text$ "lux check") (identifier$ ["lux" "Code"]) =template))))) @@ -2278,8 +2278,8 @@ _ (fail "Wrong syntax for do-template")} - [(monad/map Monad<Maybe> get-short bindings) - (monad/map Monad<Maybe> tuple->list data)]) + [(monad/map maybe-monad get-short bindings) + (monad/map maybe-monad tuple->list data)]) _ (fail "Wrong syntax for do-template")} @@ -2621,7 +2621,7 @@ (-> ($' List (& Text Module)) Text Text Text ($' Maybe Macro)) - (do Monad<Maybe> + (do maybe-monad [$module (get module modules) gdef (let' [{#module-hash _ #module-aliases _ #definitions bindings #imports _ #tags tags #types types #module-annotations _ #module-state _} ("lux check" Module $module)] (get name bindings))] @@ -2650,7 +2650,7 @@ #Nil (-> Name ($' Meta Name)) ({["" name] - (do Monad<Meta> + (do meta-monad [module-name current-module-name] (wrap [module-name name])) @@ -2661,7 +2661,7 @@ (def:''' (find-macro full-name) #Nil (-> Name ($' Meta ($' Maybe Macro))) - (do Monad<Meta> + (do meta-monad [current-module current-module-name] (let' [[module name] full-name] (function' [state] @@ -2676,7 +2676,7 @@ (def:''' (macro? name) #Nil (-> Name ($' Meta Bit)) - (do Monad<Meta> + (do meta-monad [name (normalize name) output (find-macro name)] (wrap ({(#Some _) #1 @@ -2707,7 +2707,7 @@ #Nil (-> Code ($' Meta ($' List Code))) ({[_ (#Form (#Cons [_ (#Identifier macro-name)] args))] - (do Monad<Meta> + (do meta-monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] ({(#Some macro) @@ -2725,13 +2725,13 @@ #Nil (-> Code ($' Meta ($' List Code))) ({[_ (#Form (#Cons [_ (#Identifier macro-name)] args))] - (do Monad<Meta> + (do meta-monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] ({(#Some macro) - (do Monad<Meta> + (do meta-monad [expansion (macro args) - expansion' (monad/map Monad<Meta> macro-expand expansion)] + expansion' (monad/map meta-monad macro-expand expansion)] (wrap (list/join expansion'))) #None @@ -2746,37 +2746,37 @@ #Nil (-> Code ($' Meta ($' List Code))) ({[_ (#Form (#Cons [_ (#Identifier macro-name)] args))] - (do Monad<Meta> + (do meta-monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] ({(#Some macro) - (do Monad<Meta> + (do meta-monad [expansion (macro args) - expansion' (monad/map Monad<Meta> macro-expand-all expansion)] + expansion' (monad/map meta-monad macro-expand-all expansion)] (wrap (list/join expansion'))) #None - (do Monad<Meta> - [args' (monad/map Monad<Meta> macro-expand-all args)] + (do meta-monad + [args' (monad/map meta-monad macro-expand-all args)] (wrap (list (form$ (#Cons (identifier$ macro-name) (list/join args'))))))} ?macro)) [_ (#Form members)] - (do Monad<Meta> - [members' (monad/map Monad<Meta> macro-expand-all members)] + (do meta-monad + [members' (monad/map meta-monad macro-expand-all members)] (wrap (list (form$ (list/join members'))))) [_ (#Tuple members)] - (do Monad<Meta> - [members' (monad/map Monad<Meta> macro-expand-all members)] + (do meta-monad + [members' (monad/map meta-monad macro-expand-all members)] (wrap (list (tuple$ (list/join members'))))) [_ (#Record pairs)] - (do Monad<Meta> - [pairs' (monad/map Monad<Meta> + (do meta-monad + [pairs' (monad/map meta-monad (function' [kv] (let' [[key val] kv] - (do Monad<Meta> + (do meta-monad [val' (macro-expand-all val)] ({(#Cons val'' #Nil) (return [key val'']) @@ -2825,7 +2825,7 @@ "## Takes a type expression and returns it's representation as data-structure." __paragraph "(type (All [a] (Maybe (List a))))"))]) ({(#Cons type #Nil) - (do Monad<Meta> + (do meta-monad [type+ (macro-expand-all type)] ({(#Cons type' #Nil) (wrap (list (walk-type type'))) @@ -2882,8 +2882,8 @@ #Nil (-> ($' List Code) ($' Meta (& Code ($' Maybe ($' List Text))))) ({(#Cons [_ (#Record pairs)] #Nil) - (do Monad<Meta> - [members (monad/map Monad<Meta> + (do meta-monad + [members (monad/map meta-monad (: (-> [Code Code] (Meta [Text Code])) (function' [pair] ({[[_ (#Tag "" member-name)] member-type] @@ -2908,8 +2908,8 @@ type) (#Cons case cases) - (do Monad<Meta> - [members (monad/map Monad<Meta> + (do meta-monad + [members (monad/map meta-monad (: (-> Code (Meta [Text Code])) (function' [case] ({[_ (#Tag "" member-name)] @@ -3093,25 +3093,25 @@ ({(#Cons [_ (#Form (#Cons [_ (#Identifier macro-name)] macro-args))] (#Cons body branches')) - (do Monad<Meta> + (do meta-monad [??? (macro? macro-name)] (if ??? - (do Monad<Meta> + (do meta-monad [init-expansion (macro-expand-once (form$ (list& (identifier$ macro-name) (form$ macro-args) body branches')))] (expander init-expansion)) - (do Monad<Meta> + (do meta-monad [sub-expansion (expander branches')] (wrap (list& (form$ (list& (identifier$ macro-name) macro-args)) body sub-expansion))))) (#Cons pattern (#Cons body branches')) - (do Monad<Meta> + (do meta-monad [sub-expansion (expander branches')] (wrap (list& pattern body sub-expansion))) #Nil - (do Monad<Meta> [] (wrap (list))) + (do meta-monad [] (wrap (list))) _ (fail ($_ text/compose "'lux.case' expects an even number of tokens: " (|> branches @@ -3132,7 +3132,7 @@ " " "_" ..new-line " " "#None)"))]) ({(#Cons value branches) - (do Monad<Meta> + (do meta-monad [expansion (expander branches)] (wrap (list (` ((~ (record$ (as-pairs expansion))) (~ value)))))) @@ -3153,7 +3153,7 @@ " #None)"))]) (case tokens (#Cons [_ (#Form (#Cons pattern #Nil))] (#Cons body branches)) - (do Monad<Meta> + (do meta-monad [pattern+ (macro-expand-all pattern)] (case pattern+ (#Cons pattern' #Nil) @@ -3514,11 +3514,11 @@ #None))] (case ?parts (#Some name args meta sigs) - (do Monad<Meta> + (do meta-monad [name+ (normalize name) - sigs' (monad/map Monad<Meta> macro-expand sigs) + sigs' (monad/map meta-monad macro-expand sigs) members (: (Meta (List [Text Code])) - (monad/map Monad<Meta> + (monad/map meta-monad (: (-> Code (Meta [Text Code])) (function (_ token) (case token @@ -3723,7 +3723,7 @@ (#Some (beta-reduce (list& type-fn param env) body)) (#Apply A F) - (do Monad<Maybe> + (do maybe-monad [type-fn* (apply-type F A)] (apply-type type-fn* param)) @@ -3765,7 +3765,7 @@ (#Some (flatten-tuple type)) (#Apply arg func) - (do Monad<Maybe> + (do maybe-monad [output (apply-type func arg)] (resolve-struct-type output)) @@ -3800,13 +3800,13 @@ (def: get-current-module (Meta Module) - (do Monad<Meta> + (do meta-monad [module-name current-module-name] (find-module module-name))) (def: (resolve-tag [module name]) (-> Name (Meta [Nat (List Name) Bit Type])) - (do Monad<Meta> + (do meta-monad [=module (find-module module) #let [{#module-hash _ #module-aliases _ #definitions bindings #imports _ #tags tags-table #types types #module-annotations _ #module-state _} =module]] (case (get name tags-table) @@ -3829,7 +3829,7 @@ (resolve-type-tags body) (#Named [module name] unnamed) - (do Monad<Meta> + (do meta-monad [=module (find-module module) #let [{#module-hash _ #module-aliases _ #definitions bindings #imports _ #tags tags #types types #module-annotations _ #module-state _} =module]] (case (get name types) @@ -3863,8 +3863,8 @@ (macro: #export (structure tokens) {#.doc "Not meant to be used directly. Prefer 'structure:'."} - (do Monad<Meta> - [tokens' (monad/map Monad<Meta> macro-expand tokens) + (do meta-monad + [tokens' (monad/map meta-monad macro-expand tokens) struct-type get-expected-type tags+type (resolve-type-tags struct-type) tags (: (Meta (List Name)) @@ -3877,7 +3877,7 @@ #let [tag-mappings (: (List [Text Code]) (list/map (function (_ tag) [(second tag) (tag$ tag)]) tags))] - members (monad/map Monad<Meta> + members (monad/map meta-monad (: (-> Code (Meta [Code Code])) (function (_ token) (case token @@ -3909,8 +3909,8 @@ (macro: #export (structure: tokens) {#.doc (text$ ($_ "lux text concat" "## Definition of structures ala ML." ..new-line - "(structure: #export Ord<Int> (Ord Int)" ..new-line - " (def: eq Equivalence<Int>)" ..new-line + "(structure: #export order (Order Int)" ..new-line + " (def: &equivalence equivalence)" ..new-line " (def: (< test subject)" ..new-line " (lux.i/< test subject))" ..new-line " (def: (<= test subject)" ..new-line @@ -3940,47 +3940,17 @@ #None))] (case ?parts (#Some [name args type meta definitions]) - (case (case name - [_ (#Identifier ["" "_"])] - (case type - (^ [_ (#Form (list& [_ (#Identifier [_ sig-name])] sig-args))]) - (case (: (Maybe (List Text)) - (monad/map Monad<Maybe> - (function (_ sa) - (case sa - [_ (#Identifier [_ arg-name])] - (#Some arg-name) + (let [usage (case args + #Nil + name - _ - #None)) - sig-args)) - (^ (#Some params)) - (#Some (identifier$ ["" ($_ text/compose sig-name "<" (|> params (interpose ",") (text/join-with "")) ">")])) - - _ - #None) - - _ - #None) - - _ - (#Some name) - ) - (#Some name) - (let [usage (case args - #Nil - name - - _ - (` ((~ name) (~+ args))))] - (return (list (` (..def: (~+ (export exported?)) (~ usage) - (~ (meta-code-merge (` {#.struct? #1}) - meta)) - (~ type) - (structure (~+ definitions))))))) - - #None - (fail "Cannot infer name, so struct must have a name other than '_'!")) + _ + (` ((~ name) (~+ args))))] + (return (list (` (..def: (~+ (export exported?)) (~ usage) + (~ (meta-code-merge (` {#.struct? #1}) + meta)) + (~ type) + (structure (~+ definitions))))))) #None (fail "Wrong syntax for structure:")))) @@ -4022,7 +3992,7 @@ #None))] (case parts (#Some name args meta type-codes) - (do Monad<Meta> + (do meta-monad [type+tags?? (unfold-type-def type-codes) module-name current-module-name] (let [type-name (identifier$ ["" name]) @@ -4100,7 +4070,7 @@ (def: (extract-defs defs) (-> (List Code) (Meta (List Text))) - (monad/map Monad<Meta> + (monad/map meta-monad (: (-> Code (Meta Text)) (function (_ def) (case def @@ -4116,13 +4086,13 @@ (case tokens (^or (^ (list& [_ (#Form (list& [_ (#Tag ["" "+"])] defs))] tokens')) (^ (list& [_ (#Form (list& [_ (#Tag ["" "only"])] defs))] tokens'))) - (do Monad<Meta> + (do meta-monad [defs' (extract-defs defs)] (return [(#Only defs') tokens'])) (^or (^ (list& [_ (#Form (list& [_ (#Tag ["" "-"])] defs))] tokens')) (^ (list& [_ (#Form (list& [_ (#Tag ["" "exclude"])] defs))] tokens'))) - (do Monad<Meta> + (do meta-monad [defs' (extract-defs defs)] (return [(#Exclude defs') tokens'])) @@ -4140,8 +4110,8 @@ (return [#.Nil #.Nil]) (^ (list& [_ (#Form (list& [_ (#Text prefix)] structs))] parts')) - (do Monad<Meta> - [structs' (monad/map Monad<Meta> + (do meta-monad + [structs' (monad/map meta-monad (function (_ struct) (case struct [_ (#Identifier ["" struct-name])] @@ -4165,7 +4135,7 @@ (def: (split-with token sample) (-> Text Text (Maybe [Text Text])) - (do ..Monad<Maybe> + (do ..maybe-monad [index (..index-of token sample) #let [[pre post'] (split! index sample) [_ post] (split! ("lux text size" token) post')]] @@ -4259,14 +4229,14 @@ (def: (parse-imports nested? relative-root imports) (-> Bit Text (List Code) (Meta (List Importation))) - (do Monad<Meta> - [imports' (monad/map Monad<Meta> + (do meta-monad + [imports' (monad/map meta-monad (: (-> Code (Meta (List Importation))) (function (_ token) (case token ## Simple [_ (#Identifier ["" m-name])] - (do Monad<Meta> + (do meta-monad [m-name (clean-module nested? relative-root m-name)] (wrap (list {#import-name m-name #import-alias #None @@ -4275,7 +4245,7 @@ ## Nested (^ [_ (#Tuple (list& [_ (#Identifier ["" m-name])] extra))]) - (do Monad<Meta> + (do meta-monad [import-name (clean-module nested? relative-root m-name) referral+extra (parse-referrals extra) #let [[referral extra] referral+extra] @@ -4291,7 +4261,7 @@ sub-imports)))) (^ [_ (#Tuple (list& [_ (#Text alias)] [_ (#Identifier ["" m-name])] extra))]) - (do Monad<Meta> + (do meta-monad [import-name (clean-module nested? relative-root m-name) referral+extra (parse-referrals extra) #let [[referral extra] referral+extra] @@ -4308,25 +4278,25 @@ (^ [_ (#Record (list [[_ (#Tuple (list [_ (#Nat alteration)] [_ (#Tag ["" domain])]))] parallel-tree]))]) - (do Monad<Meta> + (do meta-monad [parallel-imports (parse-imports nested? relative-root (list parallel-tree))] (wrap (list/map (alter-domain alteration domain) parallel-imports))) (^ [_ (#Record (list [[_ (#Nat alteration)] parallel-tree]))]) - (do Monad<Meta> + (do meta-monad [parallel-imports (parse-imports nested? relative-root (list parallel-tree))] (wrap (list/map (alter-domain alteration "") parallel-imports))) (^ [_ (#Record (list [[_ (#Tag ["" domain])] parallel-tree]))]) - (do Monad<Meta> + (do meta-monad [parallel-imports (parse-imports nested? relative-root (list parallel-tree)) #let [alteration (list/size (text/split-all-with ..module-separator domain))]] (wrap (list/map (alter-domain alteration domain) parallel-imports))) _ - (do Monad<Meta> + (do meta-monad [current-module current-module-name] (fail (text/compose "Wrong syntax for import @ " current-module)))))) imports)] @@ -4460,7 +4430,7 @@ (def: (find-type full-name) (-> Name (Meta Type)) - (do Monad<Meta> + (do meta-monad [#let [[module name] full-name] current-module current-module-name] (function (_ compiler) @@ -4569,12 +4539,12 @@ " (range' <= succ from to))"))} (case tokens (^ (list& [_ (#Form (list [_ (#Text alias)]))] body branches)) - (do Monad<Meta> + (do meta-monad [g!temp (gensym "temp")] (wrap (list& g!temp (` (..^open (~ g!temp) (~ (text$ alias)) (~ body))) branches))) (^ (list [_ (#Identifier name)] [_ (#Text alias)] body)) - (do Monad<Meta> + (do meta-monad [init-type (find-type name) struct-evidence (resolve-type-tags init-type)] (case struct-evidence @@ -4582,17 +4552,17 @@ (fail (text/compose "Can only 'open' structs: " (type/encode init-type))) (#Some tags&members) - (do Monad<Meta> + (do meta-monad [full-body ((: (-> Name [(List Name) (List Type)] Code (Meta Code)) (function (recur source [tags members] target) (let [pattern (record$ (list/map (function (_ [t-module t-name]) [(tag$ [t-module t-name]) (identifier$ ["" (de-alias t-name alias)])]) tags))] - (do Monad<Meta> - [enhanced-target (monad/fold Monad<Meta> + (do meta-monad + [enhanced-target (monad/fold meta-monad (function (_ [[_ m-name] m-type] enhanced-target) - (do Monad<Meta> + (do meta-monad [m-structure (resolve-type-tags m-type)] (case m-structure (#Some m-tags&members) @@ -4659,7 +4629,7 @@ " (getter my-record))"))} (case tokens (^ (list [_ (#Tag slot')] record)) - (do Monad<Meta> + (do meta-monad [slot (normalize slot') output (resolve-tag slot) #let [[idx tags exported? type] output] @@ -4687,7 +4657,7 @@ slots))) (^ (list selector)) - (do Monad<Meta> + (do meta-monad [g!_ (gensym "_") g!record (gensym "record")] (wrap (list (` (function ((~ g!_) (~ g!record)) (..get@ (~ selector) (~ g!record))))))) @@ -4697,13 +4667,13 @@ (def: (open-field alias [module name] source type) (-> Text Name Code Type (Meta (List Code))) - (do Monad<Meta> + (do meta-monad [output (resolve-type-tags type) #let [source+ (` (get@ (~ (tag$ [module name])) (~ source)))]] (case output (#Some [tags members]) - (do Monad<Meta> - [decls' (monad/map Monad<Meta> + (do meta-monad + [decls' (monad/map meta-monad (: (-> [Name Type] (Meta (List Code))) (function (_ [sname stype]) (open-field alias sname source+ stype))) (zip2 tags members))] @@ -4719,27 +4689,27 @@ "## Opens a structure and generates a definition for each of its members (including nested members)." __paragraph "## For example:" ..new-line - "(open: ''i:.'' Number<Int>)" + "(open: ''i:.'' number)" __paragraph "## Will generate:" ..new-line - "(def: i:+ (:: Number<Int> +))" ..new-line - "(def: i:- (:: Number<Int> -))" ..new-line - "(def: i:* (:: Number<Int> *))" ..new-line + "(def: i:+ (:: number +))" ..new-line + "(def: i:- (:: number -))" ..new-line + "(def: i:* (:: number *))" ..new-line "..."))} (case tokens (^ (list [_ (#Text alias)] struct)) (case struct [_ (#Identifier struct-name)] - (do Monad<Meta> + (do meta-monad [struct-type (find-type struct-name) output (resolve-type-tags struct-type) #let [source (identifier$ struct-name)]] (case output (#Some [tags members]) - (do Monad<Meta> - [decls' (monad/map Monad<Meta> (: (-> [Name Type] (Meta (List Code))) - (function (_ [sname stype]) - (open-field alias sname source stype))) + (do meta-monad + [decls' (monad/map meta-monad (: (-> [Name Type] (Meta (List Code))) + (function (_ [sname stype]) + (open-field alias sname source stype))) (zip2 tags members))] (return (list/join decls'))) @@ -4747,7 +4717,7 @@ (fail (text/compose "Can only 'open:' structs: " (type/encode struct-type))))) _ - (do Monad<Meta> + (do meta-monad [g!struct (gensym "struct")] (return (list (` ("lux def" (~ g!struct) (~ struct) [(~ cursor-code) (#.Record #Nil)])) @@ -4762,7 +4732,7 @@ "(|>> (list/map int/encode) (interpose '' '') (fold text/compose ''''))" ..new-line "## =>" ..new-line "(function (_ <arg>) (fold text/compose '''' (interpose '' '' (list/map int/encode <arg>))))"))} - (do Monad<Meta> + (do meta-monad [g!_ (gensym "_") g!arg (gensym "arg")] (return (list (` (function ((~ g!_) (~ g!arg)) (|> (~ g!arg) (~+ tokens)))))))) @@ -4773,21 +4743,21 @@ "(<<| (fold text/compose '''') (interpose '' '') (list/map int/encode))" ..new-line "## =>" ..new-line "(function (_ <arg>) (fold text/compose '''' (interpose '' '' (list/map int/encode <arg>))))"))} - (do Monad<Meta> + (do meta-monad [g!_ (gensym "_") g!arg (gensym "arg")] (return (list (` (function ((~ g!_) (~ g!arg)) (<| (~+ tokens) (~ g!arg)))))))) (def: (imported-by? import-name module-name) (-> Text Text (Meta Bit)) - (do Monad<Meta> + (do meta-monad [module (find-module module-name) #let [{#module-hash _ #module-aliases _ #definitions _ #imports imports #tags _ #types _ #module-annotations _ #module-state _} module]] (wrap (is-member? imports import-name)))) (def: (read-refer module-name options) (-> Text (List Code) (Meta Refer)) - (do Monad<Meta> + (do meta-monad [referral+options (parse-referrals options) #let [[referral options] referral+options] openings+options (parse-openings options) @@ -4795,7 +4765,7 @@ current-module current-module-name #let [test-referrals (: (-> Text (List Text) (List Text) (Meta (List Any))) (function (_ module-name all-defs referred-defs) - (monad/map Monad<Meta> + (monad/map meta-monad (: (-> Text (Meta Any)) (function (_ _def) (if (is-member? all-defs _def) @@ -4816,11 +4786,11 @@ (def: (write-refer module-name [r-defs r-opens]) (-> Text Refer (Meta (List Code))) - (do Monad<Meta> + (do meta-monad [current-module current-module-name #let [test-referrals (: (-> Text (List Text) (List Text) (Meta (List Any))) (function (_ module-name all-defs referred-defs) - (monad/map Monad<Meta> + (monad/map meta-monad (: (-> Text (Meta Any)) (function (_ _def) (if (is-member? all-defs _def) @@ -4832,13 +4802,13 @@ (exported-definitions module-name) (#Only +defs) - (do Monad<Meta> + (do meta-monad [*defs (exported-definitions module-name) _ (test-referrals module-name *defs +defs)] (wrap +defs)) (#Exclude -defs) - (do Monad<Meta> + (do meta-monad [*defs (exported-definitions module-name) _ (test-referrals module-name *defs -defs)] (wrap (filter (|>> (is-member? -defs) not) *defs))) @@ -4866,7 +4836,7 @@ (macro: #export (refer tokens) (case tokens (^ (list& [_ (#Text module-name)] options)) - (do Monad<Meta> + (do meta-monad [=refer (read-refer module-name options)] (write-refer module-name =refer)) @@ -4908,12 +4878,12 @@ " [''M'' monad #*]]" ..new-line " [data" ..new-line " maybe" ..new-line - " [''.'' name (''name/.'' Codec<Text,Name>)]]" ..new-line + " [''.'' name (''name/.'' codec)]]" ..new-line " [macro" ..new-line " code]]" ..new-line " [//" ..new-line - " [type (''.'' Equivalence<Type>)]])"))} - (do Monad<Meta> + " [type (''.'' equivalence)]])"))} + (do meta-monad [#let [[_meta _imports] (: [(List [Code Code]) (List Code)] (case tokens (^ (list& [_ (#Record _meta)] _imports)) @@ -4940,10 +4910,10 @@ (macro: #export (:: tokens) {#.doc (text$ ($_ "lux text concat" "## Allows accessing the value of a structure's member." ..new-line - "(:: Codec<Text,Int> encode)" + "(:: codec encode)" __paragraph "## Also allows using that value as a function." ..new-line - "(:: Codec<Text,Int> encode +123)"))} + "(:: codec encode +123)"))} (case tokens (^ (list struct [_ (#Identifier member)])) (return (list (` (let [(^open ".") (~ struct)] (~ (identifier$ member)))))) @@ -4967,17 +4937,17 @@ "(let [setter (set@ [#foo #bar #baz])] (setter value my-record))"))} (case tokens (^ (list [_ (#Tag slot')] value record)) - (do Monad<Meta> + (do meta-monad [slot (normalize slot') output (resolve-tag slot) #let [[idx tags exported? type] output]] (case (resolve-struct-type type) (#Some members) - (do Monad<Meta> - [pattern' (monad/map Monad<Meta> + (do meta-monad + [pattern' (monad/map meta-monad (: (-> [Name [Nat Type]] (Meta [Name Nat Code])) (function (_ [r-slot-name [r-idx r-type]]) - (do Monad<Meta> + (do meta-monad [g!slot (gensym "")] (return [r-slot-name r-idx g!slot])))) (zip2 tags (enumerate members)))] @@ -5004,8 +4974,8 @@ (fail "Wrong syntax for set@") _ - (do Monad<Meta> - [bindings (monad/map Monad<Meta> + (do meta-monad + [bindings (monad/map meta-monad (: (-> Code (Meta Code)) (function (_ _) (gensym "temp"))) slots) @@ -5026,13 +4996,13 @@ (~ update-expr))))))) (^ (list selector value)) - (do Monad<Meta> + (do meta-monad [g!_ (gensym "_") g!record (gensym "record")] (wrap (list (` (function ((~ g!_) (~ g!record)) (..set@ (~ selector) (~ value) (~ g!record))))))) (^ (list selector)) - (do Monad<Meta> + (do meta-monad [g!_ (gensym "_") g!value (gensym "value") g!record (gensym "record")] @@ -5054,17 +5024,17 @@ "(let [updater (update@ [#foo #bar #baz])] (updater func my-record))"))} (case tokens (^ (list [_ (#Tag slot')] fun record)) - (do Monad<Meta> + (do meta-monad [slot (normalize slot') output (resolve-tag slot) #let [[idx tags exported? type] output]] (case (resolve-struct-type type) (#Some members) - (do Monad<Meta> - [pattern' (monad/map Monad<Meta> + (do meta-monad + [pattern' (monad/map meta-monad (: (-> [Name [Nat Type]] (Meta [Name Nat Code])) (function (_ [r-slot-name [r-idx r-type]]) - (do Monad<Meta> + (do meta-monad [g!slot (gensym "")] (return [r-slot-name r-idx g!slot])))) (zip2 tags (enumerate members)))] @@ -5091,7 +5061,7 @@ (fail "Wrong syntax for update@") _ - (do Monad<Meta> + (do meta-monad [g!record (gensym "record") g!temp (gensym "temp")] (wrap (list (` (let [(~ g!record) (~ record) @@ -5099,13 +5069,13 @@ (set@ [(~+ slots)] ((~ fun) (~ g!temp)) (~ g!record)))))))) (^ (list selector fun)) - (do Monad<Meta> + (do meta-monad [g!_ (gensym "_") g!record (gensym "record")] (wrap (list (` (function ((~ g!_) (~ g!record)) (..update@ (~ selector) (~ fun) (~ g!record))))))) (^ (list selector)) - (do Monad<Meta> + (do meta-monad [g!_ (gensym "_") g!fun (gensym "fun") g!record (gensym "record")] @@ -5154,9 +5124,9 @@ [_ (#Form data)] branches)) (case (: (Maybe (List Code)) - (do Monad<Maybe> - [bindings' (monad/map Monad<Maybe> get-short bindings) - data' (monad/map Monad<Maybe> tuple->list data)] + (do maybe-monad + [bindings' (monad/map maybe-monad get-short bindings) + data' (monad/map maybe-monad tuple->list data)] (if (every? (n/= (list/size bindings')) (list/map list/size data')) (let [apply (: (-> RepEnv (List Code)) (function (_ env) (list/map (apply-template env) templates)))] @@ -5426,20 +5396,20 @@ vars (list/map first pairs) inits (list/map second pairs)] (if (every? identifier? inits) - (do Monad<Meta> + (do meta-monad [inits' (: (Meta (List Name)) - (case (monad/map Monad<Maybe> get-name inits) + (case (monad/map maybe-monad get-name inits) (#Some inits') (return inits') #None (fail "Wrong syntax for loop"))) - init-types (monad/map Monad<Meta> find-type inits') + init-types (monad/map meta-monad find-type inits') expected get-expected-type] (return (list (` (("lux check" (-> (~+ (list/map type-to-code init-types)) (~ (type-to-code expected))) (function ((~ name) (~+ vars)) (~ body))) (~+ inits)))))) - (do Monad<Meta> - [aliases (monad/map Monad<Meta> + (do meta-monad + [aliases (monad/map meta-monad (: (-> Code (Meta Code)) (function (_ _) (gensym ""))) inits)] @@ -5457,12 +5427,12 @@ (f foo bar baz)))} (case tokens (^ (list& [_ (#Form (list [_ (#Tuple (list& hslot' tslots'))]))] body branches)) - (do Monad<Meta> + (do meta-monad [slots (: (Meta [Name (List Name)]) (case (: (Maybe [Name (List Name)]) - (do Monad<Maybe> + (do maybe-monad [hslot (get-tag hslot') - tslots (monad/map Monad<Maybe> get-tag tslots')] + tslots (monad/map maybe-monad get-tag tslots')] (wrap [hslot tslots]))) (#Some slots) (return slots) @@ -5471,7 +5441,7 @@ (fail "Wrong syntax for ^slots"))) #let [[hslot tslots] slots] hslot (normalize hslot) - tslots (monad/map Monad<Meta> normalize tslots) + tslots (monad/map meta-monad normalize tslots) output (resolve-tag hslot) g!_ (gensym "_") #let [[idx tags exported? type] output @@ -5504,18 +5474,18 @@ (^template [<tag> <ctor>] [_ (<tag> elems)] - (do Monad<Maybe> - [placements (monad/map Monad<Maybe> (place-tokens label tokens) elems)] + (do maybe-monad + [placements (monad/map maybe-monad (place-tokens label tokens) elems)] (wrap (list (<ctor> (list/join placements)))))) ([#Tuple tuple$] [#Form form$]) [_ (#Record pairs)] - (do Monad<Maybe> - [=pairs (monad/map Monad<Maybe> + (do maybe-monad + [=pairs (monad/map maybe-monad (: (-> [Code Code] (Maybe [Code Code])) (function (_ [slot value]) - (do Monad<Maybe> + (do maybe-monad [slot' (place-tokens label tokens slot) value' (place-tokens label tokens value)] (case [slot' value'] @@ -5537,7 +5507,7 @@ [<tests> (do-template [<expr> <text> <pattern>] [(compare <pattern> <expr>) (compare <text> (:: Code/encode encode <expr>)) - (compare #1 (:: Equivalence<Code> = <expr> <expr>))] + (compare #1 (:: equivalence = <expr> <expr>))] [(bit #1) "#1" [_ (#.Bit #1)]] [(bit #0) "#0" [_ (#.Bit #0)]] @@ -5557,7 +5527,7 @@ (^ (list& [_ (#Tuple bindings)] bodies)) (case bindings (^ (list& [_ (#Identifier ["" var-name])] macro-expr bindings')) - (do Monad<Meta> + (do meta-monad [expansion (macro-expand-once macro-expr)] (case (place-tokens var-name expansion (` (.with-expansions [(~+ bindings')] @@ -5598,7 +5568,7 @@ (def: (anti-quote-def name) (-> Name (Meta Code)) - (do Monad<Meta> + (do meta-monad [type+value (find-def-value name) #let [[type value] type+value]] (case (flatten-alias type) @@ -5620,38 +5590,38 @@ (case token [_ (#Identifier [def-prefix def-name])] (if (text/= "" def-prefix) - (do Monad<Meta> + (do meta-monad [current-module current-module-name] (anti-quote-def [current-module def-name])) (anti-quote-def [def-prefix def-name])) (^template [<tag>] [meta (<tag> parts)] - (do Monad<Meta> - [=parts (monad/map Monad<Meta> anti-quote parts)] + (do meta-monad + [=parts (monad/map meta-monad anti-quote parts)] (wrap [meta (<tag> =parts)]))) ([#Form] [#Tuple]) [meta (#Record pairs)] - (do Monad<Meta> - [=pairs (monad/map Monad<Meta> + (do meta-monad + [=pairs (monad/map meta-monad (: (-> [Code Code] (Meta [Code Code])) (function (_ [slot value]) - (do Monad<Meta> + (do meta-monad [=value (anti-quote value)] (wrap [slot =value])))) pairs)] (wrap [meta (#Record =pairs)])) _ - (:: Monad<Meta> return token) + (:: meta-monad return token) )) (macro: #export (static tokens) (case tokens (^ (list pattern)) - (do Monad<Meta> + (do meta-monad [pattern' (anti-quote pattern)] (wrap (list pattern'))) @@ -5678,8 +5648,8 @@ (fail "Multi-level patterns cannot be empty.") (#Cons init extras) - (do Monad<Meta> - [extras' (monad/map Monad<Meta> case-level^ extras)] + (do meta-monad + [extras' (monad/map meta-monad case-level^ extras)] (wrap [init extras'])))) (def: (multi-level-case$ g!_ [[init-pattern levels] body]) @@ -5716,7 +5686,7 @@ (#.Left (format "Static part " (%t static) " does not match URI: " uri))))} (case tokens (^ (list& [_meta (#Form levels)] body next-branches)) - (do Monad<Meta> + (do meta-monad [mlc (multi-level-case^ levels) expected get-expected-type g!temp (gensym "temp")] @@ -5804,7 +5774,7 @@ list)))} (case tokens (^ (list [_ (#Nat idx)])) - (do Monad<Meta> + (do meta-monad [stvs get-scope-type-vars] (case (list-at idx (list/reverse stvs)) (#Some var-id) @@ -5864,7 +5834,7 @@ (: Dinosaur (:assume (list +1 +2 +3))))} (case tokens (^ (list expr)) - (do Monad<Meta> + (do meta-monad [type get-expected-type] (wrap (list (` ("lux coerce" (~ (type-to-code type)) (~ expr)))))) @@ -5899,12 +5869,12 @@ Int)} (case tokens (^ (list [_ (#Identifier var-name)])) - (do Monad<Meta> + (do meta-monad [var-type (find-type var-name)] (wrap (list (type-to-code var-type)))) (^ (list expression)) - (do Monad<Meta> + (do meta-monad [g!temp (gensym "g!temp")] (wrap (list (` (let [(~ g!temp) (~ expression)] (..:of (~ g!temp))))))) @@ -5916,8 +5886,8 @@ (-> (List Code) (Meta [[Text (List Text)] (List Code)])) (case tokens (^ (list& [_ (#Form (list& [_ (#Identifier ["" name])] args'))] tokens')) - (do Monad<Meta> - [args (monad/map Monad<Meta> + (do meta-monad + [args (monad/map meta-monad (function (_ arg') (case arg' [_ (#Identifier ["" arg-name])] @@ -5977,7 +5947,7 @@ "For simple macros that do not need any fancy features." (template: (square x) (i/* x x)))} - (do Monad<Meta> + (do meta-monad [#let [[export? tokens] (export^ tokens)] name+args|tokens (parse-complex-declaration tokens) #let [[[name args] tokens] name+args|tokens] @@ -6051,7 +6021,7 @@ )) (macro: #export (for tokens) - (do Monad<Meta> + (do meta-monad [target target] (case tokens (^ (list [_ (#Record options)])) @@ -6081,23 +6051,23 @@ (-> Code (Meta [(List [Code Code]) Code])) (case code (^ [ann (#Form (list [_ (#Identifier ["" "~~"])] expansion))]) - (do Monad<Meta> + (do meta-monad [g!expansion (gensym "g!expansion")] (wrap [(list [g!expansion expansion]) g!expansion])) (^template [<tag>] [ann (<tag> parts)] - (do Monad<Meta> - [=parts (monad/map Monad<Meta> label-code parts)] + (do meta-monad + [=parts (monad/map meta-monad label-code parts)] (wrap [(list/fold list/compose (list) (list/map left =parts)) [ann (<tag> (list/map right =parts))]]))) ([#Form] [#Tuple]) [ann (#Record kvs)] - (do Monad<Meta> - [=kvs (monad/map Monad<Meta> + (do meta-monad + [=kvs (monad/map meta-monad (function (_ [key val]) - (do Monad<Meta> + (do meta-monad [=key (label-code key) =val (label-code val) #let [[key-labels key-labelled] =key @@ -6113,7 +6083,7 @@ (macro: #export (`` tokens) (case tokens (^ (list raw)) - (do Monad<Meta> + (do meta-monad [=raw (label-code raw) #let [[labels labelled] =raw]] (wrap (list (` (with-expansions [(~+ (|> labels @@ -6143,7 +6113,7 @@ (case pattern (^template [<tag> <name> <gen>] [_ (<tag> value)] - (do Monad<Meta> + (do meta-monad [g!meta (gensym "g!meta")] (wrap (` [(~ g!meta) (<tag> (~ (<gen> value)))])))) ([#Bit "Bit" bit$] @@ -6156,10 +6126,10 @@ [#Identifier "Identifier" name$]) [_ (#Record fields)] - (do Monad<Meta> - [=fields (monad/map Monad<Meta> + (do meta-monad + [=fields (monad/map meta-monad (function (_ [key value]) - (do Monad<Meta> + (do meta-monad [=key (untemplate-pattern key) =value (untemplate-pattern value)] (wrap (` [(~ =key) (~ =value)])))) @@ -6178,14 +6148,14 @@ (case (list/reverse elems) (#Cons [_ (#Form (#Cons [[_ (#Identifier ["" "~+"])] (#Cons [spliced #Nil])]))] inits) - (do Monad<Meta> - [=inits (monad/map Monad<Meta> untemplate-pattern (list/reverse inits)) + (do meta-monad + [=inits (monad/map meta-monad untemplate-pattern (list/reverse inits)) g!meta (gensym "g!meta")] (wrap (` [(~ g!meta) (<tag> (~ (untemplate-list& spliced =inits)))]))) _ - (do Monad<Meta> - [=elems (monad/map Monad<Meta> untemplate-pattern elems) + (do meta-monad + [=elems (monad/map meta-monad untemplate-pattern elems) g!meta (gensym "g!meta")] (wrap (` [(~ g!meta) (<tag> (~ (untemplate-list =elems)))]))))) ([#Tuple] [#Form]) @@ -6194,12 +6164,12 @@ (macro: #export (^code tokens) (case tokens (^ (list& [_meta (#Form (list template))] body branches)) - (do Monad<Meta> + (do meta-monad [pattern (untemplate-pattern template)] (wrap (list& pattern body branches))) (^ (list template)) - (do Monad<Meta> + (do meta-monad [pattern (untemplate-pattern template)] (wrap (list pattern))) diff --git a/stdlib/source/lux/cli.lux b/stdlib/source/lux/cli.lux index b86b2a51b..b6c6693ee 100644 --- a/stdlib/source/lux/cli.lux +++ b/stdlib/source/lux/cli.lux @@ -7,8 +7,8 @@ ["." process]]] [data [collection - [list ("list/." Monoid<List> Monad<List>)]] - ["." text ("text/." Equivalence<Text>) + [list ("list/." monoid monad)]] + ["." text ("text/." equivalence) format] ["." error (#+ Error)]] [macro (#+ with-gensyms) @@ -54,7 +54,7 @@ {#.doc "Parses the next input with a parsing function."} (All [a] (-> (-> Text (Error a)) (CLI a))) (function (_ inputs) - (do error.Monad<Error> + (do error.monad [[remaining raw] (any inputs) output (parser raw)] (wrap [remaining output])))) @@ -63,7 +63,7 @@ {#.doc "Checks that a token is in the inputs."} (-> Text (CLI Any)) (function (_ inputs) - (do error.Monad<Error> + (do error.monad [[remaining raw] (any inputs)] (if (text/= reference raw) (wrap [remaining []]) @@ -84,7 +84,7 @@ (#error.Failure error) (#.Cons to-omit immediate') - (do error.Monad<Error> + (do error.monad [[remaining output] (recur immediate')] (wrap [(#.Cons to-omit remaining) output]))))))) @@ -117,7 +117,7 @@ (def: program-args^ (Syntax Program-Args) (p.or s.local-identifier - (s.tuple (p.some (p.either (do p.Monad<Parser> + (s.tuple (p.some (p.either (do p.monad [name s.local-identifier] (wrap [(code.identifier ["" name]) (` any)])) (s.record (p.and s.any s.any))))))) @@ -128,7 +128,7 @@ {#.doc (doc "Defines the entry-point to a program (similar to the 'main' function/method in other programming languages)." "Can take a list of all the input parameters to the program, or can destructure them using CLI-option combinators from the lux/cli module." (program: all-args - (do Monad<IO> + (do io.monad [foo init-program bar (do-something all-args)] (wrap []))) @@ -137,7 +137,7 @@ (io (log! (text/compose "Hello, " name)))) (program: [{config config^}] - (do Monad<IO> + (do io.monad [data (init-program config)] (do-something data))))} (with-gensyms [g!program] @@ -145,7 +145,7 @@ (#Raw args) (wrap (list (` ("lux program" (.function ((~ g!program) (~ (code.identifier ["" args]))) - ((~! do) (~! io.Monad<IO>) + ((~! do) (~! io.monad) [] (~ body))))))) @@ -154,13 +154,13 @@ (wrap (list (` ("lux program" (.function ((~ g!program) (~ g!args)) (case ((: (~! (..CLI (io.IO .Any))) - ((~! do) (~! p.Monad<Parser>) + ((~! do) (~! p.monad) [(~+ (|> args (list/map (function (_ [binding parser]) (list binding parser))) list/join)) (~ g!_) ..end] - ((~' wrap) ((~! do) (~! io.Monad<IO>) + ((~' wrap) ((~! do) (~! io.monad) [(~ g!output) (~ body) (~+ (`` (for {(~~ (static host.jvm)) (list)} diff --git a/stdlib/source/lux/control/apply.lux b/stdlib/source/lux/control/apply.lux index 39ea39991..5eb42b63d 100644 --- a/stdlib/source/lux/control/apply.lux +++ b/stdlib/source/lux/control/apply.lux @@ -7,29 +7,30 @@ (signature: #export (Apply f) {#.doc "Applicative functors."} (: (Functor f) - functor) + &functor) (: (All [a b] (-> (f (-> a b)) (f a) (f b))) apply)) -(structure: #export (compose Monad<F> Apply<F> Apply<G>) +(structure: #export (compose f-monad f-apply g-apply) {#.doc "Applicative functor composition."} (All [F G] (-> (Monad F) (Apply F) (Apply G) + ## TODO: Replace (All [a] (F (G a))) with (functor.Then F G) (Apply (All [a] (F (G a)))))) - (def: functor (functor.compose (get@ #functor Apply<F>) (get@ #functor Apply<G>))) + (def: &functor (functor.compose (get@ #&functor f-apply) (get@ #&functor g-apply))) (def: (apply fgf fgx) ## TODO: Switch from this version to the one below (in comments) ASAP. - (let [fgf' (:: Apply<F> apply - (:: Monad<F> wrap (:: Apply<G> apply)) + (let [fgf' (:: f-apply apply + (:: f-monad wrap (:: g-apply apply)) fgf)] - (:: Apply<F> apply fgf' fgx)) - ## (let [applyF (:: Apply<F> apply) - ## applyG (:: Apply<G> apply)] + (:: f-apply apply fgf' fgx)) + ## (let [applyF (:: f-apply apply) + ## applyG (:: g-apply apply)] ## ($_ applyF - ## (:: Monad<F> wrap applyG) + ## (:: f-monad wrap applyG) ## fgf ## fgx)) )) diff --git a/stdlib/source/lux/control/codec.lux b/stdlib/source/lux/control/codec.lux index d2641fe38..b51f76d97 100644 --- a/stdlib/source/lux/control/codec.lux +++ b/stdlib/source/lux/control/codec.lux @@ -14,16 +14,16 @@ decode)) ## [Values] -(structure: #export (compose Codec<c,b> Codec<b,a>) +(structure: #export (compose cb-codec ba-codec) {#.doc "Codec composition."} (All [a b c] (-> (Codec c b) (Codec b a) (Codec c a))) (def: encode - (|>> (:: Codec<b,a> encode) - (:: Codec<c,b> encode))) + (|>> (:: ba-codec encode) + (:: cb-codec encode))) (def: (decode cy) - (do error.Monad<Error> - [by (:: Codec<c,b> decode cy)] - (:: Codec<b,a> decode by)))) + (do error.monad + [by (:: cb-codec decode cy)] + (:: ba-codec decode by)))) diff --git a/stdlib/source/lux/control/comonad.lux b/stdlib/source/lux/control/comonad.lux index 2d96364ad..853c43615 100644 --- a/stdlib/source/lux/control/comonad.lux +++ b/stdlib/source/lux/control/comonad.lux @@ -2,7 +2,8 @@ [lux #* [data [collection - ["." list ("list/." Fold<List>)]]]] + ["." list ("list/." Fold)] + ["." sequence]]]] [// ["F" functor]]) @@ -30,7 +31,7 @@ (macro: #export (be tokens state) {#.doc (doc "A co-monadic parallel to the 'do' macro." (let [square (function (_ n) (i/* n n))] - (be CoMonad<Stream> + (be sequence.comonad [inputs (iterate inc +2)] (square (head inputs)))))} (case tokens diff --git a/stdlib/source/lux/control/concatenative.lux b/stdlib/source/lux/control/concatenative.lux index 80fa1b40e..1a628b88a 100644 --- a/stdlib/source/lux/control/concatenative.lux +++ b/stdlib/source/lux/control/concatenative.lux @@ -5,15 +5,15 @@ r/+ r/- r/* r// r/% r/= r/< r/<= r/> r/>= f/+ f/- f/* f// f/% f/= f/< f/<= f/> f/>=) [control - ["p" parser ("parser/." Monad<Parser>)] + ["p" parser ("parser/." monad)] ["." monad]] [data ["." text format] - ["." maybe ("maybe/." Monad<Maybe>)] + ["." maybe ("maybe/." monad)] [collection - ["." list ("list/." Fold<List> Functor<List>)]]] - ["." macro (#+ with-gensyms Monad<Meta>) + ["." list ("list/." fold functor)]]] + ["." macro (#+ with-gensyms) ["." code] ["s" syntax (#+ syntax:)] [syntax @@ -56,7 +56,7 @@ (def: (singleton expander) (-> (Meta (List Code)) (Meta Code)) - (monad.do Monad<Meta> + (monad.do ..monad [expansion expander] (case expansion (#.Cons singleton #.Nil) diff --git a/stdlib/source/lux/control/concurrency/actor.lux b/stdlib/source/lux/control/concurrency/actor.lux index 9b20dcfde..3e288ca42 100644 --- a/stdlib/source/lux/control/concurrency/actor.lux +++ b/stdlib/source/lux/control/concurrency/actor.lux @@ -3,15 +3,15 @@ [control monad ["p" parser] ["ex" exception (#+ exception:)]] - ["." io (#- run) ("io/." Monad<IO>)] + ["." io ("io/." monad)] [data ["." product] ["e" error] [text format] [collection - ["." list ("list/." Monoid<List> Monad<List> Fold<List>)]]] - ["." macro (#+ with-gensyms Monad<Meta>) + ["." list ("list/." monoid monad fold)]]] + ["." macro (#+ with-gensyms monad) ["." code] ["s" syntax (#+ syntax: Syntax)] [syntax @@ -23,7 +23,7 @@ abstract]] [// ["." atom (#+ Atom atom)] - ["." promise (#+ Promise Resolver) ("promise/." Monad<Promise>)] + ["." promise (#+ Promise Resolver) ("promise/." monad)] ["." task (#+ Task)]]) (exception: #export poisoned) @@ -33,7 +33,6 @@ (ex.report ["Actor" actor-name] ["Message" message-name])) -## [Types] (with-expansions [<Message> (as-is (-> s (Actor s) (Task s))) <Obituary> (as-is [Text s (List <Message>)]) @@ -90,7 +89,7 @@ (promise.promise [])) process (loop [state init [|mailbox| _] (io.run (atom.read (get@ #mailbox (:representation self))))] - (do promise.Monad<Promise> + (do promise.monad [[head tail] |mailbox| ?state' (handle head state self)] (case ?state' @@ -120,7 +119,7 @@ (All [s] (-> (Message s) (Actor s) (IO Bit))) (if (alive? actor) (let [entry [message (promise.promise [])]] - (do Monad<IO> + (do io.monad [|mailbox|&resolve (atom.read (get@ #mailbox (:representation actor)))] (loop [[|mailbox| resolve] |mailbox|&resolve] (case (promise.poll |mailbox|) @@ -139,7 +138,6 @@ ) ) -## [Values] (def: (default-handle message state self) (All [s] (-> (Message s) s (Actor s) (Task s))) (message state self)) @@ -161,7 +159,6 @@ (task.throw poisoned [])) actor)) -## [Syntax] (do-template [<with> <resolve> <tag> <desc>] [(def: #export (<with> name) (-> Name cs.Annotations cs.Annotations) @@ -170,7 +167,7 @@ (def: #export (<resolve> name) (-> Name (Meta Name)) - (do Monad<Meta> + (do io.monad [[_ annotations _] (macro.find-def name)] (case (macro.get-tag-ann (name-of <tag>) annotations) (#.Some actor-name) @@ -186,7 +183,7 @@ (def: actor-decl^ (Syntax [Text (List Text)]) (p.either (s.form (p.and s.local-identifier (p.some s.local-identifier))) - (p.and s.local-identifier (:: p.Monad<Parser> wrap (list))))) + (p.and s.local-identifier (:: p.monad wrap (list))))) (do-template [<name> <desc>] [(def: #export <name> @@ -227,7 +224,7 @@ Nat ((stop cause state) - (:: promise.Monad<Promise> wrap + (:: promise.monad wrap (log! (if (ex.match? ..poisoned cause) (format "Counter was poisoned: " (%n state)) cause))))) @@ -236,7 +233,7 @@ (List a) ((handle message state self) - (do task.Monad<Task> + (do task.monad [#let [_ (log! "BEFORE")] output (message state self) #let [_ (log! "AFTER")]] @@ -268,7 +265,7 @@ (~ (code.local-identifier messageN)) (~ (code.local-identifier stateN)) (~ (code.local-identifier selfN))) - (do task.Monad<Task> + (do task.monad [] (~ bodyC)))))) #..end (~ (case ?stop @@ -279,7 +276,7 @@ (` (function ((~ g!_) (~ (code.local-identifier causeN)) (~ (code.local-identifier stateN))) - (do promise.Monad<Promise> + (do promise.monad [] (~ bodyC))))))})) (` (def: (~+ (csw.export export)) ((~ g!new) (~ g!init)) @@ -309,7 +306,7 @@ (def: reference^ (s.Syntax [Name (List Text)]) (p.either (s.form (p.and s.identifier (p.some s.local-identifier))) - (p.and s.identifier (:: p.Monad<Parser> wrap (list))))) + (p.and s.identifier (:: p.monad wrap (list))))) (syntax: #export (message: {export csr.export} @@ -367,12 +364,12 @@ (let [[(~ g!task) (~ g!resolve)] (: [(task.Task (~ g!outputT)) (task.Resolver (~ g!outputT))] (task.task []))] - (io.run (do io.Monad<IO> + (io.run (do io.monad [(~ g!sent?) (..send (function ((~ g!_) (~ g!state) (~ g!self)) - (do promise.Monad<Promise> + (do promise.monad [(~ g!return) (: (Task [((~ g!type) (~+ g!actor-refs)) (~ g!outputT)]) - (do task.Monad<Task> + (do task.monad [] (~ body)))] (case (~ g!return) diff --git a/stdlib/source/lux/control/concurrency/atom.lux b/stdlib/source/lux/control/concurrency/atom.lux index b1692b6e3..61152d7b6 100644 --- a/stdlib/source/lux/control/concurrency/atom.lux +++ b/stdlib/source/lux/control/concurrency/atom.lux @@ -46,7 +46,7 @@ "The retries will be done with the new values of the atom, as they show up.")} (All [a] (-> (-> a a) (Atom a) (IO a))) (loop [_ []] - (do io.Monad<IO> + (do io.monad [old (read atom) #let [new (f old)] swapped? (compare-and-swap old new atom)] diff --git a/stdlib/source/lux/control/concurrency/frp.lux b/stdlib/source/lux/control/concurrency/frp.lux index 18b385a65..84def78d1 100644 --- a/stdlib/source/lux/control/concurrency/frp.lux +++ b/stdlib/source/lux/control/concurrency/frp.lux @@ -8,14 +8,14 @@ [equivalence (#+ Equivalence)]] ["." io (#+ IO)] [data - [maybe ("maybe/." Functor<Maybe>)] + [maybe ("maybe/." functor)] [collection - [list ("list/." Monoid<List>)]]] + [list ("list/." monoid)]]] [type (#+ :share) abstract]] [// ["." atom (#+ Atom)] - ["." promise (#+ Promise) ("promise/." Functor<Promise>)]]) + ["." promise (#+ Promise) ("promise/." functor)]]) (type: #export (Channel a) {#.doc "An asynchronous channel to distribute values."} @@ -35,7 +35,7 @@ (structure (def: close (loop [_ []] - (do io.Monad<IO> + (do io.monad [current (atom.read source) stopped? (current #.None)] (if stopped? @@ -52,7 +52,7 @@ (def: (feed value) (loop [_ []] - (do io.Monad<IO> + (do io.monad [current (atom.read source) #let [[next resolve-next] (:share [a] {(promise.Resolver (Maybe [a (Channel a)])) @@ -82,7 +82,7 @@ (All [a] (-> (-> a (IO Any)) (Channel a) (IO Any))) (io.io (exec (: (Promise Any) (loop [channel channel] - (do promise.Monad<Promise> + (do promise.monad [cons channel] (case cons (#.Some [head tail]) @@ -93,18 +93,18 @@ (wrap []))))) []))) -(structure: #export _ (Functor Channel) +(structure: #export functor (Functor Channel) (def: (map f) (promise/map (maybe/map (function (_ [head tail]) [(f head) (map f tail)]))))) -(structure: #export _ (Apply Channel) - (def: functor Functor<Channel>) +(structure: #export apply (Apply Channel) + (def: &functor ..functor) (def: (apply ff fa) - (do promise.Monad<Promise> + (do promise.monad [cons-f ff cons-a fa] (case [cons-f cons-a] @@ -114,8 +114,8 @@ _ (wrap #.None))))) -(structure: #export _ (Monad Channel) - (def: functor Functor<Channel>) +(structure: #export monad (Monad Channel) + (def: &functor ..functor) (def: (wrap a) (promise.resolved (#.Some [a (promise.resolved #.None)]))) @@ -128,7 +128,7 @@ (def: #export (filter pass? channel) (All [a] (-> (Predicate a) (Channel a) (Channel a))) - (do promise.Monad<Promise> + (do promise.monad [cons channel] (case cons (#.Some [head tail]) @@ -151,7 +151,7 @@ (All [a b] (-> (-> b a (Promise a)) a (Channel b) (Promise a))) - (do promise.Monad<Promise> + (do promise.monad [cons channel] (case cons #.None @@ -167,7 +167,7 @@ (All [a b] (-> (-> b a (Promise a)) a (Channel b) (Channel a))) - (do promise.Monad<Promise> + (do promise.monad [cons channel] (case cons #.None @@ -182,7 +182,7 @@ (All [a] (-> Nat (IO a) (Channel a))) (let [[output source] (channel [])] (exec (io.run (loop [_ []] - (do io.Monad<IO> + (do io.monad [value action _ (:: source feed value)] (promise.await recur (promise.wait milli-seconds))))) @@ -194,7 +194,7 @@ (def: #export (iterate f init) (All [a] (-> (-> a (Promise (Maybe a))) a (Channel a))) - (do promise.Monad<Promise> + (do promise.monad [?next (f init)] (case ?next (#.Some next) @@ -205,7 +205,7 @@ (def: (distinct' equivalence previous channel) (All [a] (-> (Equivalence a) a (Channel a) (Channel a))) - (do promise.Monad<Promise> + (do promise.monad [cons channel] (case cons (#.Some [head tail]) @@ -218,7 +218,7 @@ (def: #export (distinct equivalence channel) (All [a] (-> (Equivalence a) (Channel a) (Channel a))) - (do promise.Monad<Promise> + (do promise.monad [cons channel] (case cons (#.Some [head tail]) @@ -230,7 +230,7 @@ (def: #export (consume channel) {#.doc "Reads the entirety of a channel's content and returns it as a list."} (All [a] (-> (Channel a) (Promise (List a)))) - (do promise.Monad<Promise> + (do promise.monad [cons channel] (case cons (#.Some [head tail]) @@ -247,6 +247,6 @@ (promise.resolved #.None) (#.Cons head tail) - (promise.resolved (#.Some [head (do promise.Monad<Promise> + (promise.resolved (#.Some [head (do promise.monad [_ (promise.wait milli-seconds)] (sequential milli-seconds tail))])))) diff --git a/stdlib/source/lux/control/concurrency/process.lux b/stdlib/source/lux/control/concurrency/process.lux index a67734747..d1d2ac245 100644 --- a/stdlib/source/lux/control/concurrency/process.lux +++ b/stdlib/source/lux/control/concurrency/process.lux @@ -87,7 +87,7 @@ (def: #export run! (IO Any) (loop [_ []] - (do io.Monad<IO> + (do io.monad [processes (atom.read runner)] (case processes ## And... we're done! diff --git a/stdlib/source/lux/control/concurrency/promise.lux b/stdlib/source/lux/control/concurrency/promise.lux index 33a04190b..244951139 100644 --- a/stdlib/source/lux/control/concurrency/promise.lux +++ b/stdlib/source/lux/control/concurrency/promise.lux @@ -25,7 +25,7 @@ {#.doc "Sets an promise's value if it has not been done yet."} (All [a] (-> (Promise a) (Resolver a))) (function (resolve value) - (do io.Monad<IO> + (do io.monad [(^@ old [_value _observers]) (atom.read promise)] (case _value (#.Some _) @@ -82,14 +82,14 @@ (#.Some _) #1)) -(structure: #export _ (Functor Promise) +(structure: #export functor (Functor Promise) (def: (map f fa) (let [[fb resolve] (..promise [])] (exec (io.run (await (|>> f resolve) fa)) fb)))) -(structure: #export _ (Apply Promise) - (def: functor Functor<Promise>) +(structure: #export apply (Apply Promise) + (def: &functor ..functor) (def: (apply ff fa) (let [[fb resolve] (..promise [])] @@ -98,8 +98,8 @@ ff)) fb)))) -(structure: #export _ (Monad Promise) - (def: functor Functor<Promise>) +(structure: #export monad (Monad Promise) + (def: &functor ..functor) (def: wrap ..resolved) @@ -113,7 +113,7 @@ (def: #export (and left right) {#.doc "Sequencing combinator."} (All [a b] (-> (Promise a) (Promise b) (Promise [a b]))) - (do Monad<Promise> + (do ..monad [a left b right] (wrap [a b]))) @@ -148,7 +148,7 @@ "Returns a Promise that will eventually host its result.")} (All [a] (-> Nat (IO a) (Promise a))) (let [[!out resolve] (..promise [])] - (exec (|> (do io.Monad<IO> + (exec (|> (do io.monad [value computation] (resolve value)) (process.schedule millis-delay) diff --git a/stdlib/source/lux/control/concurrency/semaphore.lux b/stdlib/source/lux/control/concurrency/semaphore.lux index 46762ecf3..ddc73b300 100644 --- a/stdlib/source/lux/control/concurrency/semaphore.lux +++ b/stdlib/source/lux/control/concurrency/semaphore.lux @@ -29,7 +29,7 @@ (io.run (loop [signal (: (Promise Any) (promise.promise #.None))] - (do io.Monad<IO> + (do io.monad [state (atom.read semaphore) #let [[ready? state'] (: [Bit State] (case (get@ #open-positions state) @@ -50,7 +50,7 @@ (let [semaphore (:representation semaphore)] (promise.future (loop [_ []] - (do io.Monad<IO> + (do io.monad [state (atom.read semaphore) #let [[?signal state'] (: [(Maybe (Promise Any)) State] (case (get@ #waiting-list state) @@ -91,7 +91,7 @@ (def: #export (synchronize mutex procedure) (All [a] (-> Mutex (IO (Promise a)) (Promise a))) - (do promise.Monad<Promise> + (do promise.monad [_ (acquire mutex) output (io.run procedure) _ (release mutex)] @@ -120,15 +120,15 @@ (-> Nat Semaphore (Promise Any)) (loop [step 0] (if (n/< times step) - (do promise.Monad<Promise> + (do promise.monad [_ (signal turnstile)] (recur (inc step))) - (:: promise.Monad<Promise> wrap [])))) + (:: promise.monad wrap [])))) (do-template [<phase> <update> <goal> <turnstile>] [(def: (<phase> (^:representation barrier)) (-> Barrier (Promise Any)) - (do promise.Monad<Promise> + (do promise.monad [#let [limit (refinement.un-refine (get@ #limit barrier)) goal <goal> count (io.run (atom.update <update> (get@ #count barrier)))] @@ -143,7 +143,7 @@ (def: #export (block barrier) (-> Barrier (Promise Any)) - (do promise.Monad<Promise> + (do promise.monad [_ (start barrier)] (end barrier))) ) diff --git a/stdlib/source/lux/control/concurrency/stm.lux b/stdlib/source/lux/control/concurrency/stm.lux index 34122abd4..5bb537025 100644 --- a/stdlib/source/lux/control/concurrency/stm.lux +++ b/stdlib/source/lux/control/concurrency/stm.lux @@ -15,7 +15,7 @@ [// ["." atom (#+ Atom atom)] ["." promise (#+ Promise Resolver)] - ["." frp ("frp/." Functor<Channel>)]]) + ["." frp ("frp/." functor)]]) (type: #export (Observer a) (-> a (IO Any))) @@ -39,11 +39,11 @@ (All [a] (-> (Var a) (IO a))) (|> var atom.read - (:: io.Functor<IO> map product.left))) + (:: io.functor map product.left))) (def: (write! new-value (^:representation var)) (All [a] (-> a (Var a) (IO Any))) - (do io.Monad<IO> + (do io.monad [(^@ old [_value _observers]) (atom.read var) succeeded? (atom.compare-and-swap old [new-value _observers] var)] (if succeeded? @@ -55,7 +55,7 @@ (def: #export (follow target) {#.doc "Creates a channel that will receive all changes to the value of the given var."} (All [a] (-> (Var a) (IO (frp.Channel a)))) - (do io.Monad<IO> + (do io.monad [#let [[channel source] (frp.channel []) target (:representation target)] _ (atom.update (function (_ [value observers]) @@ -82,8 +82,8 @@ (list.find (function (_ [_var _original _current]) (is? (:coerce (Var Any) var) (:coerce (Var Any) _var)))) - (:: maybe.Monad<Maybe> map (function (_ [_var _original _current]) - _current)) + (:: maybe.monad map (function (_ [_var _original _current]) + _current)) (:assume) )) @@ -137,8 +137,8 @@ (let [[tx' a] (fa tx)] [tx' (f a)])))) -(structure: #export _ (Apply STM) - (def: functor Functor<STM>) +(structure: #export apply (Apply STM) + (def: &functor ..functor) (def: (apply ff fa) (function (_ tx) @@ -146,8 +146,8 @@ [tx'' a] (fa tx')] [tx'' (f a)])))) -(structure: #export _ (Monad STM) - (def: functor Functor<STM>) +(structure: #export monad (Monad STM) + (def: &functor ..functor) (def: (wrap a) (function (_ tx) [tx a])) @@ -160,7 +160,7 @@ (def: #export (update f var) {#.doc "Will update a Var's value, and return a tuple with the old and the new values."} (All [a] (-> (-> a a) (Var a) (STM [a a]))) - (do Monad<STM> + (do ..monad [a (read var) #let [a' (f a)] _ (write a' var)] @@ -198,12 +198,12 @@ (def: (issue-commit commit) (All [a] (-> (Commit a) (IO Any))) (let [entry [commit (promise.promise [])]] - (do io.Monad<IO> + (do io.monad [|commits|&resolve (atom.read pending-commits)] (loop [[|commits| resolve] |commits|&resolve] (case (promise.poll |commits|) #.None - (do io.Monad<IO> + (do io.monad [resolved? (resolve entry)] (if resolved? (atom.write (product.right entry) pending-commits) @@ -217,14 +217,14 @@ (let [[stm-proc output resolve] commit [finished-tx value] (stm-proc fresh-tx)] (if (can-commit? finished-tx) - (do io.Monad<IO> + (do io.monad [_ (monad.map @ commit-var! finished-tx)] (resolve value)) (issue-commit commit)))) (def: init-processor! (IO Any) - (do io.Monad<IO> + (do io.monad [flag (atom.read commit-processor-flag)] (if flag (wrap []) @@ -247,7 +247,7 @@ "For this reason, it's important to note that transactions must be free from side-effects, such as I/O.")} (All [a] (-> (STM a) (Promise a))) (let [[output resolver] (promise.promise [])] - (exec (io.run (do io.Monad<IO> + (exec (io.run (do io.monad [_ init-processor!] (issue-commit [stm-proc output resolver]))) output))) diff --git a/stdlib/source/lux/control/concurrency/task.lux b/stdlib/source/lux/control/concurrency/task.lux index a5bf17819..1f16da8ca 100644 --- a/stdlib/source/lux/control/concurrency/task.lux +++ b/stdlib/source/lux/control/concurrency/task.lux @@ -29,16 +29,15 @@ (def: #export (throw exception message) (All [e a] (-> (Exception e) e (Task a))) - (:: promise.Monad<Promise> wrap - (ex.throw exception message))) + (:: promise.monad wrap (ex.throw exception message))) (def: #export (try computation) (All [a] (-> (Task a) (Task (Error a)))) - (:: promise.Functor<Promise> map (|>> #error.Success) computation)) + (:: promise.functor map (|>> #error.Success) computation)) -(structure: #export _ (Functor Task) +(structure: #export functor (Functor Task) (def: (map f fa) - (:: promise.Functor<Promise> map + (:: promise.functor map (function (_ fa') (case fa' (#error.Failure error) @@ -48,25 +47,25 @@ (#error.Success (f a)))) fa))) -(structure: #export _ (Apply Task) - (def: functor Functor<Task>) +(structure: #export apply (Apply Task) + (def: &functor ..functor) (def: (apply ff fa) - (do promise.Monad<Promise> + (do promise.monad [ff' ff fa' fa] - (wrap (do error.Monad<Error> + (wrap (do error.monad [f ff' a fa'] (wrap (f a))))))) -(structure: #export _ (Monad Task) - (def: functor Functor<Task>) +(structure: #export monad (Monad Task) + (def: &functor ..functor) (def: wrap return) (def: (join mma) - (do promise.Monad<Promise> + (do promise.monad [mma' mma] (case mma' (#error.Failure error) @@ -81,4 +80,4 @@ (def: #export (from-promise promise) (All [a] (-> (Promise a) (Task a))) - (:: promise.Functor<Promise> map (|>> #error.Success) promise)) + (:: promise.functor map (|>> #error.Success) promise)) diff --git a/stdlib/source/lux/control/continuation.lux b/stdlib/source/lux/control/continuation.lux index beaab50fb..66233773a 100644 --- a/stdlib/source/lux/control/continuation.lux +++ b/stdlib/source/lux/control/continuation.lux @@ -23,12 +23,12 @@ (All [a] (-> (Cont a a) a)) (cont id)) -(structure: #export Functor<Cont> (All [o] (Functor (All [i] (Cont i o)))) +(structure: #export functor (All [o] (Functor (All [i] (Cont i o)))) (def: (map f fv) (function (_ k) (fv (compose k f))))) -(structure: #export Apply<Cont> (All [o] (Apply (All [i] (Cont i o)))) - (def: functor Functor<Cont>) +(structure: #export apply (All [o] (Apply (All [i] (Cont i o)))) + (def: &functor ..functor) (def: (apply ff fv) (function (_ k) @@ -36,8 +36,8 @@ (function (_ v)) fv (function (_ f)) ff)))) -(structure: #export Monad<Cont> (All [o] (Monad (All [i] (Cont i o)))) - (def: functor Functor<Cont>) +(structure: #export monad (All [o] (Monad (All [i] (Cont i o)))) + (def: &functor ..functor) (def: (wrap value) (function (_ k) (k value))) @@ -69,7 +69,7 @@ i] z))) (call/cc (function (_ k) - (do Monad<Cont> + (do ..monad [#let [nexus (function (nexus val) (k [nexus val]))] _ (k [nexus init])] diff --git a/stdlib/source/lux/control/enum.lux b/stdlib/source/lux/control/enum.lux index b5b69faf1..9f2845b01 100644 --- a/stdlib/source/lux/control/enum.lux +++ b/stdlib/source/lux/control/enum.lux @@ -3,14 +3,12 @@ [control ["." order]]]) -## [Signatures] (signature: #export (Enum e) {#.doc "Enumerable types, with a notion of moving forward and backwards through a type's instances."} - (: (order.Order e) order) + (: (order.Order e) &order) (: (-> e e) succ) (: (-> e e) pred)) -## [Functions] (def: (range' <= succ from to) (All [a] (-> (-> a a Bit) (-> a a) a a (List a))) (if (<= to from) diff --git a/stdlib/source/lux/control/equivalence.lux b/stdlib/source/lux/control/equivalence.lux index 1b1cc45d3..57db7a925 100644 --- a/stdlib/source/lux/control/equivalence.lux +++ b/stdlib/source/lux/control/equivalence.lux @@ -35,8 +35,8 @@ (def: (= left right) (sub (rec sub) left right)))) -(structure: #export _ (Contravariant Equivalence) - (def: (map-1 f Equivalence<b>) +(structure: #export contravariant (Contravariant Equivalence) + (def: (map-1 f equivalence) (structure (def: (= reference sample) - (:: Equivalence<b> = (f reference) (f sample)))))) + (:: equivalence = (f reference) (f sample)))))) diff --git a/stdlib/source/lux/control/exception.lux b/stdlib/source/lux/control/exception.lux index c5fa9632c..bac945de2 100644 --- a/stdlib/source/lux/control/exception.lux +++ b/stdlib/source/lux/control/exception.lux @@ -7,9 +7,9 @@ ["//" error (#+ Error)] ["." maybe] ["." product] - ["." text ("text/." Monoid<Text>)] + ["." text ("text/." monoid)] [collection - ["." list ("list/." Functor<List> Fold<List>)]]] + ["." list ("list/." functor fold)]]] ["." macro ["." code] ["s" syntax (#+ syntax: Syntax)] diff --git a/stdlib/source/lux/control/functor.lux b/stdlib/source/lux/control/functor.lux index 415d57c93..1ade0a45b 100644 --- a/stdlib/source/lux/control/functor.lux +++ b/stdlib/source/lux/control/functor.lux @@ -9,21 +9,21 @@ (type: #export (Fix f) (f (Fix f))) -(type: #export (<&> f g) +(type: #export (And f g) (All [a] (& (f a) (g a)))) -(type: #export (<|> f g) +(type: #export (Or f g) (All [a] (| (f a) (g a)))) -(type: #export (<$> f g) +(type: #export (Then f g) (All [a] (f (g a)))) -(structure: #export (compose Functor<F> Functor<G>) +(def: #export (compose f-functor g-functor) {#.doc "Functor composition."} - (All [F G] (-> (Functor F) (Functor G) (Functor (All [a] (F (G a)))))) - - (def: (map f fga) - (:: Functor<F> map (:: Functor<G> map f) fga))) + (All [F G] (-> (Functor F) (Functor G) (Functor (..Then F G)))) + (structure + (def: (map f fga) + (:: f-functor map (:: g-functor map f) fga)))) (signature: #export (Contravariant f) (: (All [a b] diff --git a/stdlib/source/lux/control/hash.lux b/stdlib/source/lux/control/hash.lux index 4e50c3658..d2dee3bcb 100644 --- a/stdlib/source/lux/control/hash.lux +++ b/stdlib/source/lux/control/hash.lux @@ -1,12 +1,13 @@ (.module: lux - [// [equivalence (#+ Equivalence)]]) + [// + [equivalence (#+ Equivalence)]]) ## [Signatures] (signature: #export (Hash a) {#.doc (doc "A way to produce hash-codes for a type's instances." "A necessity when working with some data-structures, such as dictionaries or sets.")} (: (Equivalence a) - eq) + &equivalence) (: (-> a Nat) hash)) diff --git a/stdlib/source/lux/control/identity.lux b/stdlib/source/lux/control/identity.lux index 094ede9a6..ff79bedca 100644 --- a/stdlib/source/lux/control/identity.lux +++ b/stdlib/source/lux/control/identity.lux @@ -12,7 +12,7 @@ code - (structure: #export (Equivalence<ID> Equivalence<code>) + (structure: #export (equivalence Equivalence<code>) (All [code entity storage] (-> (Equivalence code) (Equivalence (ID code entity storage)))) diff --git a/stdlib/source/lux/control/interval.lux b/stdlib/source/lux/control/interval.lux index 5e94aea90..940b85a21 100644 --- a/stdlib/source/lux/control/interval.lux +++ b/stdlib/source/lux/control/interval.lux @@ -9,7 +9,7 @@ (signature: #export (Interval a) {#.doc "A representation of top and bottom boundaries for an ordered type."} (: (Enum a) - enum) + &enum) (: a bottom) @@ -17,15 +17,15 @@ (: a top)) -(def: #export (between Enum<a> bottom top) +(def: #export (between enum bottom top) (All [a] (-> (Enum a) a a (Interval a))) - (structure (def: enum Enum<a>) + (structure (def: &enum enum) (def: bottom bottom) (def: top top))) -(def: #export (singleton Enum<a> elem) +(def: #export (singleton enum elem) (All [a] (-> (Enum a) a (Interval a))) - (structure (def: enum Enum<a>) + (structure (def: &enum enum) (def: bottom elem) (def: top elem))) @@ -72,20 +72,20 @@ (def: #export (union left right) (All [a] (-> (Interval a) (Interval a) (Interval a))) - (structure (def: enum (get@ #enum right)) - (def: bottom (order.min (:: right order) (:: left bottom) (:: right bottom))) - (def: top (order.max (:: right order) (:: left top) (:: right top))))) + (structure (def: &enum (get@ #&enum right)) + (def: bottom (order.min (:: right &order) (:: left bottom) (:: right bottom))) + (def: top (order.max (:: right &order) (:: left top) (:: right top))))) (def: #export (intersection left right) (All [a] (-> (Interval a) (Interval a) (Interval a))) - (structure (def: enum (get@ #enum right)) - (def: bottom (order.max (:: right order) (:: left bottom) (:: right bottom))) - (def: top (order.min (:: right order) (:: left top) (:: right top))))) + (structure (def: &enum (get@ #&enum right)) + (def: bottom (order.max (:: right &order) (:: left bottom) (:: right bottom))) + (def: top (order.min (:: right &order) (:: left top) (:: right top))))) (def: #export (complement interval) (All [a] (-> (Interval a) (Interval a))) (let [(^open ".") interval] - (structure (def: enum (get@ #enum interval)) + (structure (def: &enum (get@ #&enum interval)) (def: bottom (succ top)) (def: top (pred bottom))))) @@ -134,7 +134,7 @@ [after? >] ) -(structure: #export Equivalence<Interval> (All [a] (Equivalence (Interval a))) +(structure: #export equivalence (All [a] (Equivalence (Interval a))) (def: (= reference sample) (let [(^open ".") reference] (and (= bottom (:: sample bottom)) @@ -164,7 +164,7 @@ (def: #export (overlaps? reference sample) (All [a] (-> (Interval a) (Interval a) Bit)) (let [(^open ".") reference] - (and (not (:: Equivalence<Interval> = reference sample)) + (and (not (:: ..equivalence = reference sample)) (cond (singleton? sample) #0 diff --git a/stdlib/source/lux/control/monad.lux b/stdlib/source/lux/control/monad.lux index 6e0992444..67f1fb047 100644 --- a/stdlib/source/lux/control/monad.lux +++ b/stdlib/source/lux/control/monad.lux @@ -3,7 +3,6 @@ [// ["." functor (#+ Functor)]]) -## [Utils] (def: (list/fold f init xs) (All [a b] (-> (-> b a a) a (List b) a)) @@ -41,10 +40,9 @@ _ #.Nil)) -## [Signatures] (signature: #export (Monad m) (: (Functor m) - functor) + &functor) (: (All [a] (-> a (m a))) wrap) @@ -52,12 +50,11 @@ (-> (m (m a)) (m a))) join)) -## [Syntax] (def: _cursor Cursor ["" 0 0]) (macro: #export (do tokens state) {#.doc (doc "Macro for easy concatenation of monadic operations." - (do Monad<Maybe> + (do monad [y (f1 x) z (f2 z)] (wrap (f3 z))))} @@ -80,7 +77,7 @@ body (reverse (as-pairs bindings)))] (#.Right [state (#.Cons (` ({(~' @) - ({{#..functor {#functor.map (~ g!map)} + ({{#..&functor {#functor.map (~ g!map)} #..wrap (~' wrap) #..join (~ g!join)} (~ body')} @@ -92,7 +89,6 @@ _ (#.Left "Wrong syntax for 'do'"))) -## [Functions] (def: #export (seq monad) {#.doc "Run all the monadic values in the list and produce a list of the base values."} (All [M a] @@ -162,11 +158,11 @@ [init' (f x init)] (fold monad f init' xs')))) -(def: #export (lift Monad<M> f) +(def: #export (lift monad f) {#.doc "Lift a normal function into the space of monads."} (All [M a b] (-> (Monad M) (-> a b) (-> (M a) (M b)))) (function (_ ma) - (do Monad<M> + (do monad [a ma] (wrap (f a))))) diff --git a/stdlib/source/lux/control/monad/free.lux b/stdlib/source/lux/control/monad/free.lux index b30de7b1f..214261450 100644 --- a/stdlib/source/lux/control/monad/free.lux +++ b/stdlib/source/lux/control/monad/free.lux @@ -10,7 +10,7 @@ (#Pure a) (#Effect (F (Free F a)))) -(structure: #export (Functor<Free> dsl) +(structure: #export (functor dsl) (All [F] (-> (Functor F) (Functor (Free F)))) (def: (map f ea) @@ -21,10 +21,10 @@ (#Effect value) (#Effect (:: dsl map (map f) value))))) -(structure: #export (Apply<Free> dsl) +(structure: #export (apply dsl) (All [F] (-> (Functor F) (Apply (Free F)))) - (def: functor (Functor<Free> dsl)) + (def: &functor (..functor dsl)) (def: (apply ef ea) (case [ef ea] @@ -33,7 +33,7 @@ [(#Pure f) (#Effect fa)] (#Effect (:: dsl map - (:: (Functor<Free> dsl) map f) + (:: (..functor dsl) map f) fa)) [(#Effect ff) _] @@ -42,10 +42,10 @@ ff)) ))) -(structure: #export (Monad<Free> dsl) +(structure: #export (monad dsl) (All [F] (-> (Functor F) (Monad (Free F)))) - (def: functor (Functor<Free> dsl)) + (def: &functor (..functor dsl)) (def: (wrap a) (#Pure a)) @@ -62,6 +62,6 @@ (#Effect fefa) (#Effect (:: dsl map - (:: (Monad<Free> dsl) join) + (:: (monad dsl) join) fefa)) ))) diff --git a/stdlib/source/lux/control/monad/indexed.lux b/stdlib/source/lux/control/monad/indexed.lux index ef2acb904..bd18ab72c 100644 --- a/stdlib/source/lux/control/monad/indexed.lux +++ b/stdlib/source/lux/control/monad/indexed.lux @@ -5,7 +5,7 @@ ["p" parser]] [data [collection - ["." list ("list/." Functor<List> Fold<List>)]]] + ["." list ("list/." functor fold)]]] ["." macro ["s" syntax (#+ Syntax syntax:)]]]) diff --git a/stdlib/source/lux/control/order.lux b/stdlib/source/lux/control/order.lux index 4375f4e7c..a56f512cb 100644 --- a/stdlib/source/lux/control/order.lux +++ b/stdlib/source/lux/control/order.lux @@ -6,12 +6,11 @@ [// ["." equivalence (#+ Equivalence)]]) -## [Signatures] (`` (signature: #export (Order a) {#.doc "A signature for types that possess some sense of ordering among their elements."} (: (Equivalence a) - eq) + &equivalence) (~~ (do-template [<name>] [(: (-> a a Bit) <name>)] @@ -20,20 +19,23 @@ )) )) -## [Values] -(def: #export (order eq <) +(def: #export (order equivalence <) (All [a] (-> (Equivalence a) (-> a a Bit) (Order a))) (let [> (flip <)] - (structure (def: eq eq) + (structure (def: &equivalence equivalence) + (def: < <) + (def: (<= test subject) (or (< test subject) - (:: eq = test subject))) + (:: equivalence = test subject))) + (def: > >) + (def: (>= test subject) (or (> test subject) - (:: eq = test subject)))))) + (:: equivalence = test subject)))))) (do-template [<name> <op>] [(def: #export (<name> order x y) @@ -45,14 +47,14 @@ [max >] ) -(`` (structure: #export _ (Contravariant Order) - (def: (map-1 f Order<b>) +(`` (structure: #export contravariant (Contravariant Order) + (def: (map-1 f order) (structure - (def: eq (:: equivalence.Contravariant<Equivalence> map-1 f (:: Order<b> eq))) + (def: &equivalence (:: equivalence.contravariant map-1 f (:: order &equivalence))) (~~ (do-template [<name>] [(def: (<name> reference sample) - (:: Order<b> <name> (f reference) (f sample)))] + (:: order <name> (f reference) (f sample)))] [<] [<=] [>] [>=] )))))) diff --git a/stdlib/source/lux/control/parser.lux b/stdlib/source/lux/control/parser.lux index 4b4ef0d34..4ea39a006 100644 --- a/stdlib/source/lux/control/parser.lux +++ b/stdlib/source/lux/control/parser.lux @@ -3,11 +3,11 @@ [control [functor (#+ Functor)] [apply (#+ Apply)] - [monad (#+ do Monad)] + [monad (#+ Monad do)] [codec (#+ Codec)]] [data [collection - ["." list ("list/." Functor<List> Monoid<List>)]] + ["." list ("list/." functor monoid)]] ["." product] ["." error (#+ Error)]]]) @@ -15,8 +15,7 @@ {#.doc "A generic parser."} (-> s (Error [s a]))) -## [Structures] -(structure: #export Functor<Parser> (All [s] (Functor (Parser s))) +(structure: #export functor (All [s] (Functor (Parser s))) (def: (map f ma) (function (_ input) (case (ma input) @@ -26,8 +25,8 @@ (#error.Success [input' a]) (#error.Success [input' (f a)]))))) -(structure: #export Apply<Parser> (All [s] (Apply (Parser s))) - (def: functor Functor<Parser>) +(structure: #export apply (All [s] (Apply (Parser s))) + (def: &functor ..functor) (def: (apply ff fa) (function (_ input) @@ -43,8 +42,8 @@ (#error.Failure msg) (#error.Failure msg))))) -(structure: #export Monad<Parser> (All [s] (Monad (Parser s))) - (def: functor Functor<Parser>) +(structure: #export monad (All [s] (Monad (Parser s))) + (def: &functor ..functor) (def: (wrap x) (function (_ input) @@ -59,7 +58,6 @@ (#error.Success [input' ma]) (ma input'))))) -## [Parsers] (def: #export (assert message test) {#.doc "Fails with the given message if the test is #0."} (All [s] (-> Text Bit (Parser s Any))) @@ -96,7 +94,7 @@ (#error.Success [input' x]) (run input' - (do Monad<Parser> + (do ..monad [xs (some p)] (wrap (list& x xs))) )))) @@ -105,7 +103,7 @@ {#.doc "1-or-more combinator."} (All [s a] (-> (Parser s a) (Parser s (List a)))) - (do Monad<Parser> + (do ..monad [x p xs (some p)] (wrap (list& x xs)))) @@ -114,7 +112,7 @@ {#.doc "Sequencing combinator."} (All [s a b] (-> (Parser s a) (Parser s b) (Parser s [a b]))) - (do Monad<Parser> + (do ..monad [x1 p1 x2 p2] (wrap [x1 x2]))) @@ -130,7 +128,7 @@ (#error.Failure _) (run tokens - (do Monad<Parser> + (do ..monad [x2 p2] (wrap (1 x2)))) ))) @@ -152,16 +150,16 @@ {#.doc "Parse exactly N times."} (All [s a] (-> Nat (Parser s a) (Parser s (List a)))) (if (n/> 0 n) - (do Monad<Parser> + (do ..monad [x p xs (exactly (dec n) p)] (wrap (#.Cons x xs))) - (:: Monad<Parser> wrap (list)))) + (:: ..monad wrap (list)))) (def: #export (at-least n p) {#.doc "Parse at least N times."} (All [s a] (-> Nat (Parser s a) (Parser s (List a)))) - (do Monad<Parser> + (do ..monad [min (exactly n p) extra (some p)] (wrap (list/compose min extra)))) @@ -177,24 +175,24 @@ (#error.Success [input' x]) (run input' - (do Monad<Parser> + (do ..monad [xs (at-most (dec n) p)] (wrap (#.Cons x xs)))) )) - (:: Monad<Parser> wrap (list)))) + (:: ..monad wrap (list)))) (def: #export (between from to p) {#.doc "Parse between N and M times."} (All [s a] (-> Nat Nat (Parser s a) (Parser s (List a)))) - (do Monad<Parser> + (do ..monad [min-xs (exactly from p) max-xs (at-most (n/- from to) p)] - (wrap (:: list.Monad<List> join (list min-xs max-xs))))) + (wrap (:: list.monad join (list min-xs max-xs))))) (def: #export (sep-by sep p) {#.doc "Parsers instances of 'p' that are separated by instances of 'sep'."} (All [s a b] (-> (Parser s b) (Parser s a) (Parser s (List a)))) - (do Monad<Parser> + (do ..monad [?x (maybe p)] (case ?x #.None @@ -255,20 +253,20 @@ (def: #export (after param subject) (All [s _ a] (-> (Parser s _) (Parser s a) (Parser s a))) - (do Monad<Parser> + (do ..monad [_ param] subject)) (def: #export (before param subject) (All [s _ a] (-> (Parser s _) (Parser s a) (Parser s a))) - (do Monad<Parser> + (do ..monad [output subject _ param] (wrap output))) (def: #export (filter test parser) (All [s a] (-> (-> a Bit) (Parser s a) (Parser s a))) - (do Monad<Parser> + (do ..monad [output parser _ (assert "Constraint failed." (test output))] (wrap output))) diff --git a/stdlib/source/lux/control/pipe.lux b/stdlib/source/lux/control/pipe.lux index a5f9eca95..ec1e787e2 100644 --- a/stdlib/source/lux/control/pipe.lux +++ b/stdlib/source/lux/control/pipe.lux @@ -6,7 +6,7 @@ [data ["e" error] [collection - ["." list ("list/." Fold<List> Monad<List>)]]] + ["." list ("list/." fold monad)]]] [macro (#+ with-gensyms) ["s" syntax (#+ syntax: Syntax)] ["." code]]]) @@ -54,7 +54,7 @@ [(new> -1)])))} (with-gensyms [g!temp] (wrap (list (` (let [(~ g!temp) (~ prev)] - (cond (~+ (do list.Monad<List> + (cond (~+ (do list.monad [[test then] branches] (list (` (|> (~ g!temp) (~+ test))) (` (|> (~ g!temp) (~+ then)))))) @@ -90,14 +90,14 @@ {#.doc (doc "Monadic pipes." "Each steps in the monadic computation is a pipe and must be given inside a tuple." (|> +5 - (do> Monad<Identity> + (do> monad [(i/* +3)] [(i/+ +4)] [inc])))} (with-gensyms [g!temp] (case (list.reverse steps) (^ (list& last-step prev-steps)) - (let [step-bindings (do list.Monad<List> + (let [step-bindings (do list.monad [step (list.reverse prev-steps)] (list g!temp (` (|> (~ g!temp) (~+ step)))))] (wrap (list (` ((~! do) (~ monad) diff --git a/stdlib/source/lux/control/reader.lux b/stdlib/source/lux/control/reader.lux index 1d19b5594..d8ce527cc 100644 --- a/stdlib/source/lux/control/reader.lux +++ b/stdlib/source/lux/control/reader.lux @@ -1,8 +1,8 @@ (.module: [lux #* [control - ["F" functor] - ["A" apply] + [functor (#+ Functor)] + [apply (#+ Apply)] ["." monad (#+ do Monad)]]]) ## [Types] @@ -11,26 +11,26 @@ (-> r a)) ## [Structures] -(structure: #export Functor<Reader> - (All [r] (F.Functor (Reader r))) +(structure: #export functor + (All [r] (Functor (Reader r))) (def: (map f fa) (function (_ env) (f (fa env))))) -(structure: #export Apply<Reader> - (All [r] (A.Apply (Reader r))) +(structure: #export apply + (All [r] (Apply (Reader r))) - (def: functor Functor<Reader>) + (def: &functor ..functor) (def: (apply ff fa) (function (_ env) ((ff env) (fa env))))) -(structure: #export Monad<Reader> +(structure: #export monad (All [r] (Monad (Reader r))) - (def: functor Functor<Reader>) + (def: &functor ..functor) (def: (wrap x) (function (_ env) x)) @@ -54,21 +54,21 @@ (All [r a] (-> r (Reader r a) a)) (proc env)) -(structure: #export (ReaderT Monad<M>) +(structure: #export (ReaderT monad) {#.doc "Monad transformer for Reader."} (All [M] (-> (Monad M) (All [e] (Monad (All [a] (Reader e (M a))))))) - (def: functor (F.compose Functor<Reader> (get@ #monad.functor Monad<M>))) + (def: &functor (F.compose ..functor (get@ #monad.&functor monad))) - (def: wrap (|>> (:: Monad<M> wrap) (:: Monad<Reader> wrap))) + (def: wrap (|>> (:: monad wrap) (:: ..monad wrap))) (def: (join eMeMa) (function (_ env) - (do Monad<M> + (do monad [eMa (run env eMeMa)] (run env eMa))))) (def: #export lift {#.doc "Lift monadic values to the Reader wrapper."} (All [M e a] (-> (M a) (Reader e (M a)))) - (:: Monad<Reader> wrap)) + (:: ..monad wrap)) diff --git a/stdlib/source/lux/control/region.lux b/stdlib/source/lux/control/region.lux index e014777dd..126344514 100644 --- a/stdlib/source/lux/control/region.lux +++ b/stdlib/source/lux/control/region.lux @@ -10,7 +10,7 @@ ["." text format] [collection - [list ("list/." Fold<List>)]]]]) + [list ("list/." fold)]]]]) (type: (Cleaner r m) (-> r (m (Error Any)))) @@ -66,7 +66,7 @@ cleaners) (#error.Success value)]))) -(structure: #export (Functor<Region> Functor<m>) +(structure: #export (functor Functor<m>) (All [m] (-> (Functor m) (All [r] (Functor (Region r m))))) @@ -84,13 +84,13 @@ (#error.Failure error))]) (fa region+cleaners)))))) -(structure: #export (Apply<Region> Monad<m>) +(structure: #export (apply Monad<m>) (All [m] (-> (Monad m) (All [r] (Apply (Region r m))))) - (def: functor - (Functor<Region> (get@ #monad.functor Monad<m>))) + (def: &functor + (..functor (get@ #monad.functor Monad<m>))) (def: (apply ff fa) (function (_ [region cleaners]) @@ -105,13 +105,13 @@ [_ (#error.Failure error)]) (wrap [cleaners (#error.Failure error)])))))) -(structure: #export (Monad<Region> Monad<m>) +(structure: #export (monad Monad<m>) (All [m] (-> (Monad m) (All [r] (Monad (Region r m))))) - (def: functor - (Functor<Region> (get@ #monad.functor Monad<m>))) + (def: &functor + (..functor (get@ #monad.&functor Monad<m>))) (def: (wrap value) (function (_ [region cleaners]) diff --git a/stdlib/source/lux/control/remember.lux b/stdlib/source/lux/control/remember.lux index a355a705b..8085ad176 100644 --- a/stdlib/source/lux/control/remember.lux +++ b/stdlib/source/lux/control/remember.lux @@ -2,7 +2,7 @@ [lux #* [control [monad (#+ do)] - ["p" parser ("p/." Functor<Parser>)] + ["p" parser ("p/." functor)] ["ex" exception (#+ exception:)]] [data ["." error] @@ -10,7 +10,7 @@ format]] [time ["." instant] - ["." date (#+ Date) ("date/." Order<Date> Codec<Text,Date>)]] + ["." date (#+ Date) ("date/." order codec)]] ["." macro ["." code] ["s" syntax (#+ Syntax syntax:)]] @@ -30,9 +30,9 @@ ($_ p.either (p/map (|>> instant.from-millis instant.date) s.int) - (do p.Monad<Parser> + (do p.monad [raw s.text] - (case (:: date.Codec<Text,Date> decode raw) + (case (:: date.codec decode raw) (#error.Success date) (wrap date) @@ -54,13 +54,13 @@ (do-template [<name> <message>] [(syntax: #export (<name> {deadline ..deadline} {message s.text} {focus (p.maybe s.any)}) (wrap (list (` (..remember (~ (code.text (date/encode deadline))) - (~ (code.text (format <message> " " message))) - (~+ (case focus - (#.Some focus) - (list focus) + (~ (code.text (format <message> " " message))) + (~+ (case focus + (#.Some focus) + (list focus) - #.None - (list))))))))] + #.None + (list))))))))] [to-do "TODO"] [fix-me "FIXME"] diff --git a/stdlib/source/lux/control/security/capability.lux b/stdlib/source/lux/control/security/capability.lux index 847dbf714..f757ced19 100644 --- a/stdlib/source/lux/control/security/capability.lux +++ b/stdlib/source/lux/control/security/capability.lux @@ -7,7 +7,7 @@ [text format] [collection - [list ("list/." Functor<List>)]]] + [list ("list/." functor)]]] [type abstract] ["." macro diff --git a/stdlib/source/lux/control/security/integrity.lux b/stdlib/source/lux/control/security/integrity.lux index b78351b38..81dee0c16 100644 --- a/stdlib/source/lux/control/security/integrity.lux +++ b/stdlib/source/lux/control/security/integrity.lux @@ -32,18 +32,18 @@ (All [a] (-> (Dirty a) a)) (|>> :representation)) - (structure: #export _ (Functor Dirty) + (structure: #export functor (Functor Dirty) (def: (map f fa) (|> fa :representation f :abstraction))) - (structure: #export _ (Apply Dirty) - (def: functor Functor<Dirty>) + (structure: #export apply (Apply Dirty) + (def: &functor ..functor) (def: (apply ff fa) (:abstraction ((:representation ff) (:representation fa))))) - (structure: #export _ (Monad Dirty) - (def: functor Functor<Dirty>) + (structure: #export monad (Monad Dirty) + (def: &functor ..functor) (def: wrap (|>> :abstraction)) diff --git a/stdlib/source/lux/control/security/privacy.lux b/stdlib/source/lux/control/security/privacy.lux index e24d49acb..51d530673 100644 --- a/stdlib/source/lux/control/security/privacy.lux +++ b/stdlib/source/lux/control/security/privacy.lux @@ -74,24 +74,24 @@ (-> Type Type) (type (All [label] (constructor (All [value] (Private value label)))))) - (structure: #export Functor<Private> + (structure: #export functor (:~ (privatize Functor)) (def: (map f fa) (|> fa :representation f :abstraction))) - (structure: #export Apply<Private> + (structure: #export apply (:~ (privatize Apply)) - (def: functor Functor<Private>) + (def: &functor ..functor) (def: (apply ff fa) (:abstraction ((:representation ff) (:representation fa))))) - (structure: #export Monad<Private> + (structure: #export monad (:~ (privatize Monad)) - (def: functor Functor<Private>) + (def: &functor ..functor) (def: wrap (|>> :abstraction)) diff --git a/stdlib/source/lux/control/state.lux b/stdlib/source/lux/control/state.lux index 94330ff96..c0db18a43 100644 --- a/stdlib/source/lux/control/state.lux +++ b/stdlib/source/lux/control/state.lux @@ -1,28 +1,26 @@ (.module: [lux #* [control - ["F" functor] - ["A" apply] - [monad (#+ do Monad)]]]) + [functor (#+ Functor)] + [apply (#+ Apply)] + [monad (#+ Monad do)]]]) -## [Types] (type: #export (State s a) {#.doc "Stateful computations."} (-> s [s a])) -## [Structures] -(structure: #export Functor<State> - (All [s] (F.Functor (State s))) +(structure: #export functor + (All [s] (Functor (State s))) (def: (map f ma) (function (_ state) (let [[state' a] (ma state)] [state' (f a)])))) -(structure: #export Apply<State> - (All [s] (A.Apply (State s))) +(structure: #export apply + (All [s] (Apply (State s))) - (def: functor Functor<State>) + (def: &functor ..functor) (def: (apply ff fa) (function (_ state) @@ -30,10 +28,10 @@ [state'' a] (fa state')] [state'' (f a)])))) -(structure: #export Monad<State> +(structure: #export monad (All [s] (Monad (State s))) - (def: functor Functor<State>) + (def: &functor ..functor) (def: (wrap a) (function (_ state) @@ -44,7 +42,6 @@ (let [[state' ma] (mma state)] (ma state'))))) -## [Values] (def: #export get {#.doc "Read the current state."} (All [s] (State s s)) @@ -81,22 +78,22 @@ (All [s a] (-> s (State s a) [s a])) (action state)) -(structure: (Functor<State'> Functor<M>) - (All [M s] (-> (F.Functor M) (F.Functor (All [a] (-> s (M [s a])))))) +(structure: (with-state//functor functor) + (All [M s] (-> (Functor M) (Functor (All [a] (-> s (M [s a])))))) (def: (map f sfa) (function (_ state) - (:: Functor<M> map (function (_ [s a]) [s (f a)]) + (:: functor map (function (_ [s a]) [s (f a)]) (sfa state))))) -(structure: (Apply<State'> Monad<M>) - (All [M s] (-> (Monad M) (A.Apply (All [a] (-> s (M [s a])))))) +(structure: (with-state//apply monad) + (All [M s] (-> (Monad M) (Apply (All [a] (-> s (M [s a])))))) - (def: functor (Functor<State'> (:: Monad<M> functor))) + (def: &functor (with-state//functor (:: monad &functor))) (def: (apply sFf sFa) (function (_ state) - (do Monad<M> + (do monad [[state f] (sFf state) [state a] (sFa state)] (wrap [state (f a)]))))) @@ -110,33 +107,33 @@ (All [M s a] (-> s (State' M s a) (M [s a]))) (action state)) -(structure: #export (Monad<State'> Monad<M>) +(structure: #export (with-state monad) {#.doc "A monad transformer to create composite stateful computations."} (All [M s] (-> (Monad M) (Monad (State' M s)))) - (def: functor (Functor<State'> (:: Monad<M> functor))) + (def: &functor (with-state//functor (:: monad &functor))) (def: (wrap a) (function (_ state) - (:: Monad<M> wrap [state a]))) + (:: monad wrap [state a]))) (def: (join sMsMa) (function (_ state) - (do Monad<M> + (do monad [[state' sMa] (sMsMa state)] (sMa state'))))) -(def: #export (lift Monad<M> ma) +(def: #export (lift monad ma) {#.doc "Lift monadic values to the State' wrapper."} (All [M s a] (-> (Monad M) (M a) (State' M s a))) (function (_ state) - (do Monad<M> + (do monad [a ma] (wrap [state a])))) (def: #export (while condition body) (All [s] (-> (State s Bit) (State s Any) (State s Any))) - (do Monad<State> + (do ..monad [execute? condition] (if execute? (do @ @@ -146,6 +143,6 @@ (def: #export (do-while condition body) (All [s] (-> (State s Bit) (State s Any) (State s Any))) - (do Monad<State> + (do ..monad [_ body] (while condition body))) diff --git a/stdlib/source/lux/control/thread.lux b/stdlib/source/lux/control/thread.lux index 9aad8aca0..708f385a2 100644 --- a/stdlib/source/lux/control/thread.lux +++ b/stdlib/source/lux/control/thread.lux @@ -47,7 +47,7 @@ a)) (thread [])) -(structure: #export Functor<Thread> +(structure: #export functor (All [!] (Functor (Thread !))) (def: (map f) @@ -55,19 +55,19 @@ (function (_ !) (f (fa !)))))) -(structure: #export Apply<Thread> +(structure: #export apply (All [!] (Apply (Thread !))) - (def: functor Functor<Thread>) + (def: &functor ..functor) (def: (apply ff fa) (function (_ !) ((ff !) (fa !))))) -(structure: #export Monad<Thread> +(structure: #export monad (All [!] (Monad (Thread !))) - (def: functor Functor<Thread>) + (def: &functor ..functor) (def: (wrap value) (function (_ !) @@ -79,7 +79,7 @@ (def: #export (update f box) (All [a] (-> (-> a a) (All [!] (-> (Box ! a) (Thread ! a))))) - (do Monad<Thread> + (do ..monad [old (read box) _ (write (f old) box)] (wrap old))) diff --git a/stdlib/source/lux/control/writer.lux b/stdlib/source/lux/control/writer.lux index 4007cb6cb..152bc9e71 100644 --- a/stdlib/source/lux/control/writer.lux +++ b/stdlib/source/lux/control/writer.lux @@ -2,39 +2,39 @@ [lux #* [control monoid - ["F" functor] - ["A" apply] - ["." monad (#+ do Monad)]]]) + [functor (#+ Functor)] + [apply (#+ Apply)] + ["." monad (#+ Monad do)]]]) (type: #export (Writer l a) {#.doc "Represents a value with an associated 'log' value to record arbitrary information."} {#log l #value a}) -(structure: #export Functor<Writer> +(structure: #export functor (All [l] - (F.Functor (Writer l))) + (Functor (Writer l))) (def: (map f fa) (let [[log datum] fa] [log (f datum)]))) -(structure: #export (Apply<Writer> mon) +(structure: #export (apply mon) (All [l] - (-> (Monoid l) (A.Apply (Writer l)))) + (-> (Monoid l) (Apply (Writer l)))) - (def: functor Functor<Writer>) + (def: &functor ..functor) (def: (apply ff fa) (let [[log1 f] ff [log2 a] fa] [(:: mon compose log1 log2) (f a)]))) -(structure: #export (Monad<Writer> mon) +(structure: #export (monad mon) (All [l] (-> (Monoid l) (Monad (Writer l)))) - (def: functor Functor<Writer>) + (def: &functor ..functor) (def: (wrap x) [(:: mon identity) x]) @@ -48,17 +48,17 @@ (All [l] (-> l (Writer l Any))) [l []]) -(structure: #export (WriterT Monoid<l> Monad<M>) +(structure: #export (with-writer Monoid<l> monad) (All [l M] (-> (Monoid l) (Monad M) (Monad (All [a] (M (Writer l a)))))) - (def: functor (F.compose (get@ #monad.functor Monad<M>) Functor<Writer>)) + (def: &functor (F.compose (get@ #monad.&functor monad) ..functor)) (def: wrap - (let [monad (Monad<Writer> Monoid<l>)] - (|>> (:: monad wrap) (:: Monad<M> wrap)))) + (let [monad (..monad Monoid<l>)] + (|>> (:: monad wrap) (:: monad wrap)))) (def: (join MlMla) - (do Monad<M> + (do monad [## TODO: Remove once new-luxc is the standard compiler. [l1 Mla] (: (($ 1) (Writer ($ 0) (($ 1) (Writer ($ 0) ($ 2))))) MlMla) @@ -66,9 +66,9 @@ [l2 a] Mla] (wrap [(:: Monoid<l> compose l1 l2) a])))) -(def: #export (lift Monoid<l> Monad<M>) +(def: #export (lift Monoid<l> monad) (All [l M a] (-> (Monoid l) (Monad M) (-> (M a) (M (Writer l a))))) (function (_ ma) - (do Monad<M> + (do monad [a ma] (wrap [(:: Monoid<l> identity) a])))) diff --git a/stdlib/source/lux/data/bit.lux b/stdlib/source/lux/data/bit.lux index 8cf671429..613d923b3 100644 --- a/stdlib/source/lux/data/bit.lux +++ b/stdlib/source/lux/data/bit.lux @@ -7,15 +7,14 @@ [codec (#+ Codec)]] function]) -## [Structures] -(structure: #export _ (Equivalence Bit) +(structure: #export equivalence (Equivalence Bit) (def: (= x y) (if x y (not y)))) -(structure: #export _ (Hash Bit) - (def: eq Equivalence<Bit>) +(structure: #export hash (Hash Bit) + (def: &equivalence ..equivalence) (def: (hash value) (case value #1 1 @@ -24,14 +23,13 @@ (do-template [<name> <identity> <op>] [(structure: #export <name> (Monoid Bit) (def: identity <identity>) - (def: (compose x y) - (<op> x y)))] + (def: (compose x y) (<op> x y)))] - [ Or@Monoid<Bit> #0 or] - [And@Monoid<Bit> #1 and] + [ or-monoid #0 or] + [and-monoid #1 and] ) -(structure: #export _ (Codec Text Bit) +(structure: #export codec (Codec Text Bit) (def: (encode x) (if x "#1" @@ -43,7 +41,6 @@ "#0" (#.Right #0) _ (#.Left "Wrong syntax for Bit.")))) -## [Values] (def: #export complement {#.doc (doc "Generates the complement of a predicate." "That is a predicate that returns the oposite of the original predicate.")} diff --git a/stdlib/source/lux/data/collection/array.lux b/stdlib/source/lux/data/collection/array.lux index 8c1b5c2b3..65ca3b0f6 100644 --- a/stdlib/source/lux/data/collection/array.lux +++ b/stdlib/source/lux/data/collection/array.lux @@ -10,7 +10,7 @@ ["." product] ["." maybe] [collection - ["." list ("list/." Fold<List>)]]] + ["." list ("list/." fold)]]] [platform [compiler ["." host]]]]) @@ -211,7 +211,7 @@ (#.Cons (maybe.default default (read idx array)) output))))) -(structure: #export (Equivalence<Array> Equivalence<a>) +(structure: #export (equivalence Equivalence<a>) (All [a] (-> (Equivalence a) (Equivalence (Array a)))) (def: (= xs ys) (let [sxs (size xs) @@ -231,7 +231,7 @@ #1 (list.indices sxs)))))) -(structure: #export Monoid<Array> (All [a] (Monoid (Array a))) +(structure: #export monoid (All [a] (Monoid (Array a))) (def: identity (new 0)) (def: (compose xs ys) @@ -241,7 +241,7 @@ (copy sxs 0 xs 0) (copy sxy 0 ys sxs))))) -(structure: #export _ (Functor Array) +(structure: #export functor (Functor Array) (def: (map f ma) (let [arr-size (size ma)] (if (n/= 0 arr-size) @@ -257,7 +257,7 @@ (list.indices arr-size)) )))) -(structure: #export _ (Fold Array) +(structure: #export fold (Fold Array) (def: (fold f init xs) (let [arr-size (size xs)] (loop [so-far init diff --git a/stdlib/source/lux/data/collection/bits.lux b/stdlib/source/lux/data/collection/bits.lux index 8855c0593..0837a4dbb 100644 --- a/stdlib/source/lux/data/collection/bits.lux +++ b/stdlib/source/lux/data/collection/bits.lux @@ -10,7 +10,7 @@ [text format] [collection - ["." array (#+ Array) ("array/." Fold<Array>)]]]]) + ["." array (#+ Array) ("array/." fold)]]]]) (type: #export Chunk I64) @@ -156,7 +156,7 @@ [xor i64.xor] ) -(structure: #export _ (Equivalence Bits) +(structure: #export equivalence (Equivalence Bits) (def: (= reference sample) (let [size (n/max (array.size reference) (array.size sample))] diff --git a/stdlib/source/lux/data/collection/dictionary.lux b/stdlib/source/lux/data/collection/dictionary.lux index b0f0920fb..21aaecf39 100644 --- a/stdlib/source/lux/data/collection/dictionary.lux +++ b/stdlib/source/lux/data/collection/dictionary.lux @@ -9,8 +9,8 @@ ["." number ["." i64]] [collection - ["." list ("list/." Fold<List> Functor<List> Monoid<List>)] - ["." array (#+ Array) ("array/." Functor<Array> Fold<Array>)]]] + ["." list ("list/." fold functor monoid)] + ["." array (#+ Array) ("array/." functor fold)]]] ]) ## This implementation of Hash Array Mapped Trie (HAMT) is based on @@ -210,7 +210,7 @@ ## Produces the index of a KV-pair within a #Collisions node. (def: (collision-index Hash<k> key colls) (All [k v] (-> (Hash k) k (Collisions k v) (Maybe Index))) - (:: maybe.Monad<Maybe> map product.left + (:: maybe.monad map product.left (array.find+ (function (_ idx [key' val']) (:: Hash<k> = key key')) colls))) @@ -491,7 +491,7 @@ ## For #Collisions nodes, do a linear scan of all the known KV-pairs. (#Collisions _hash _colls) - (:: maybe.Monad<Maybe> map product.right + (:: maybe.monad map product.right (array.find (|>> product.left (:: Hash<k> = key)) _colls)) )) @@ -668,7 +668,7 @@ keys))) ## [Structures] -(structure: #export (Equivalence<Dictionary> Equivalence<v>) (All [k v] (-> (Equivalence v) (Equivalence (Dictionary k v)))) +(structure: #export (equivalence Equivalence<v>) (All [k v] (-> (Equivalence v) (Equivalence (Dictionary k v)))) (def: (= test subject) (and (n/= (size test) (size subject)) diff --git a/stdlib/source/lux/data/collection/dictionary/ordered.lux b/stdlib/source/lux/data/collection/dictionary/ordered.lux index 25c50367b..b6cda46d1 100644 --- a/stdlib/source/lux/data/collection/dictionary/ordered.lux +++ b/stdlib/source/lux/data/collection/dictionary/ordered.lux @@ -1,14 +1,14 @@ (.module: [lux #* [control - [monad (#+ do Monad)] + [monad (#+ Monad do)] equivalence [order (#+ Order)]] [data ["p" product] ["." maybe] [collection - [list ("list/." Monoid<List> Fold<List>)]]] + [list ("list/." monoid fold)]]] ["." macro ["." code] ["s" syntax (#+ syntax: Syntax)]]]) @@ -352,7 +352,7 @@ (#.Some (right-balance (get@ #key right) (get@ #value right) (get@ #right right>>left) - (:: maybe.Functor<Maybe> map redden (get@ #right right))))) + (:: maybe.functor map redden (get@ #right right))))) _ (error! error-message)) @@ -379,7 +379,7 @@ (get@ #value left>>right) (#.Some (left-balance (get@ #key left) (get@ #value left) - (:: maybe.Functor<Maybe> map redden (get@ #left left)) + (:: maybe.functor map redden (get@ #left left)) (get@ #left left>>right))) (#.Some (black key value (get@ #right left>>right) ?right))) @@ -399,7 +399,7 @@ [(#.Some left) (#.Some right)] (case [(get@ #color left) (get@ #color right)] [#Red #Red] - (do maybe.Monad<Maybe> + (do maybe.monad [fused (prepend (get@ #right left) (get@ #right right))] (case (get@ #color fused) #Red @@ -438,7 +438,7 @@ (get@ #right right))) [#Black #Black] - (do maybe.Monad<Maybe> + (do maybe.monad [fused (prepend (get@ #right left) (get@ #left right))] (case (get@ #color fused) #Red @@ -524,7 +524,7 @@ (def: #export (update key transform dict) (All [k v] (-> k (-> v v) (Dictionary k v) (Maybe (Dictionary k v)))) - (do maybe.Monad<Maybe> + (do maybe.monad [old (get key dict)] (wrap (put key (transform old) dict)))) @@ -554,7 +554,7 @@ [values v (get@ #value node')] ) -(structure: #export (Equivalence<Dictionary> Equivalence<v>) (All [k v] (-> (Equivalence v) (Equivalence (Dictionary k v)))) +(structure: #export (equivalence Equivalence<v>) (All [k v] (-> (Equivalence v) (Equivalence (Dictionary k v)))) (def: (= reference sample) (let [Equivalence<k> (:: sample eq)] (loop [entriesR (entries reference) diff --git a/stdlib/source/lux/data/collection/dictionary/plist.lux b/stdlib/source/lux/data/collection/dictionary/plist.lux index 2f4593fac..7b11ee208 100644 --- a/stdlib/source/lux/data/collection/dictionary/plist.lux +++ b/stdlib/source/lux/data/collection/dictionary/plist.lux @@ -2,9 +2,9 @@ [lux #* [data ["." product] - [text ("text/." Equivalence<Text>)] + [text ("text/." equivalence)] [collection - [list ("list/." Functor<List>)]]]]) + [list ("list/." functor)]]]]) (type: #export (PList a) (List [Text a])) diff --git a/stdlib/source/lux/data/collection/list.lux b/stdlib/source/lux/data/collection/list.lux index a92175d53..6d3b4cf85 100644 --- a/stdlib/source/lux/data/collection/list.lux +++ b/stdlib/source/lux/data/collection/list.lux @@ -9,16 +9,14 @@ [fold (#+ Fold)] [predicate (#+ Predicate)]] [data - bit + ["." bit] ["." product]]]) -## [Types] ## (type: (List a) ## #Nil ## (#Cons a (List a))) -## [Functions] -(structure: #export _ (Fold List) +(structure: #export fold (Fold List) (def: (fold f init xs) (case xs #.Nil @@ -27,8 +25,6 @@ (#.Cons [x xs']) (fold f (f x init) xs')))) -(open: "." Fold<List>) - (def: #export (reverse xs) (All [a] (-> (List a) (List a))) @@ -36,7 +32,7 @@ #.Nil xs)) -(def: #export (filter predicate xs) +(def: #export (filter keep? xs) (All [a] (-> (Predicate a) (List a) (List a))) (case xs @@ -44,15 +40,22 @@ #.Nil (#.Cons [x xs']) - (if (predicate x) - (#.Cons x (filter predicate xs')) - (filter predicate xs')))) + (if (keep? x) + (#.Cons x (filter keep? xs')) + (filter keep? xs')))) -(def: #export (partition predicate xs) +(def: #export (partition satisfies? list) {#.doc "Divide the list into all elements that satisfy a predicate, and all elements that do not."} (All [a] (-> (Predicate a) (List a) [(List a) (List a)])) - [(filter predicate xs) - (filter (complement predicate) xs)]) + (case list + #.Nil + [#.Nil #.Nil] + + (#.Cons head tail) + (let [[in out] (partition satisfies? tail)] + (if (satisfies? head) + [(list& head in) out] + [in (list& head out)])))) (def: #export (as-pairs xs) {#.doc (doc "Cut the list into pairs of 2." @@ -266,8 +269,7 @@ (#.Some x) (nth (dec i) xs')))) -## [Structures] -(structure: #export (Equivalence<List> Equivalence<a>) +(structure: #export (equivalence Equivalence<a>) (All [a] (-> (Equivalence a) (Equivalence (List a)))) (def: (= xs ys) (case [xs ys] @@ -282,26 +284,25 @@ #0 ))) -(structure: #export Monoid<List> (All [a] - (Monoid (List a))) +(structure: #export monoid (All [a] (Monoid (List a))) (def: identity #.Nil) (def: (compose xs ys) (case xs #.Nil ys (#.Cons x xs') (#.Cons x (compose xs' ys))))) -(open: "." Monoid<List>) +(open: "." monoid) -(structure: #export _ (Functor List) +(structure: #export functor (Functor List) (def: (map f ma) (case ma #.Nil #.Nil (#.Cons a ma') (#.Cons (f a) (map f ma'))))) -(open: "." Functor<List>) +(open: "." ..functor) -(structure: #export _ (Apply List) - (def: functor Functor<List>) +(structure: #export apply (Apply List) + (def: &functor ..functor) (def: (apply ff fa) (case ff @@ -311,15 +312,14 @@ (#.Cons f ff') (compose (map f fa) (apply ff' fa))))) -(structure: #export _ (Monad List) - (def: functor Functor<List>) +(structure: #export monad (Monad List) + (def: &functor ..functor) (def: (wrap a) (#.Cons a #.Nil)) (def: join (|>> reverse (fold compose identity)))) -## [Functions] (def: #export (sort < xs) (All [a] (-> (-> a a Bit) (List a) (List a))) (case xs @@ -387,7 +387,6 @@ (list) (|> size dec (n/range 0)))) -## [Syntax] (def: (identifier$ name) (-> Text Code) [["" 0 0] (#.Identifier "" name)]) @@ -422,7 +421,7 @@ (case tokens (^ (list [_ (#.Nat num-lists)])) (if (n/> 0 num-lists) - (let [(^open ".") Functor<List> + (let [(^open ".") ..functor indices (..indices num-lists) type-vars (: (List Code) (map (|>> nat/encode identifier$) indices)) zip-type (` (All [(~+ type-vars)] @@ -466,7 +465,7 @@ (case tokens (^ (list [_ (#.Nat num-lists)])) (if (n/> 0 num-lists) - (let [(^open ".") Functor<List> + (let [(^open ".") ..functor indices (..indices num-lists) g!return-type (identifier$ "0return-type0") g!func (identifier$ "0func0") @@ -539,17 +538,17 @@ (def: #export (concat xss) (All [a] (-> (List (List a)) (List a))) - (:: Monad<List> join xss)) + (:: ..monad join xss)) -(structure: #export (ListT Monad<M>) +(structure: #export (with-list monad) (All [M] (-> (Monad M) (Monad (All [a] (M (List a)))))) - (def: functor (functor.compose (get@ #monad.functor Monad<M>) Functor<List>)) + (def: &functor (functor.compose (get@ #monad.&functor monad) ..functor)) - (def: wrap (|>> (:: Monad<List> wrap) (:: Monad<M> wrap))) + (def: wrap (|>> (:: ..monad wrap) (:: monad wrap))) (def: (join MlMla) - (do Monad<M> + (do monad [lMla MlMla ## TODO: Remove this version ASAP and use one below. lla (: (($ 0) (List (List ($ 1)))) @@ -558,9 +557,9 @@ ] (wrap (concat lla))))) -(def: #export (lift Monad<M>) +(def: #export (lift monad) (All [M a] (-> (Monad M) (-> (M a) (M (List a))))) - (monad.lift Monad<M> (:: Monad<List> wrap))) + (monad.lift monad (:: ..monad wrap))) (def: (enumerate' idx xs) (All [a] (-> Nat (List a) (List [Nat a]))) diff --git a/stdlib/source/lux/data/collection/queue.lux b/stdlib/source/lux/data/collection/queue.lux index 4973b925e..ce66391c8 100644 --- a/stdlib/source/lux/data/collection/queue.lux +++ b/stdlib/source/lux/data/collection/queue.lux @@ -2,10 +2,10 @@ [lux #* [control [equivalence (#+ Equivalence)] - ["F" functor]] + [functor (#+ Functor)]] [data [collection - ["." list ("list/." Monoid<List> Functor<List>)]]]]) + ["." list ("list/." monoid functor)]]]]) (type: #export (Queue a) {#front (List a) @@ -70,12 +70,12 @@ _ (update@ #rear (|>> (#.Cons val)) queue))) -(structure: #export (Equivalence<Queue> Equivalence<a>) +(structure: #export (equivalence Equivalence<a>) (All [a] (-> (Equivalence a) (Equivalence (Queue a)))) (def: (= qx qy) - (:: (list.Equivalence<List> Equivalence<a>) = (to-list qx) (to-list qy)))) + (:: (list.equivalence Equivalence<a>) = (to-list qx) (to-list qy)))) -(structure: #export _ (F.Functor Queue) +(structure: #export functor (Functor Queue) (def: (map f fa) {#front (|> fa (get@ #front) (list/map f)) #rear (|> fa (get@ #rear) (list/map f))})) diff --git a/stdlib/source/lux/data/collection/queue/priority.lux b/stdlib/source/lux/data/collection/queue/priority.lux index 1af9acaab..59167d2e7 100644 --- a/stdlib/source/lux/data/collection/queue/priority.lux +++ b/stdlib/source/lux/data/collection/queue/priority.lux @@ -5,7 +5,8 @@ [monad (#+ do Monad)]] [data ["." maybe] - ["." number ("nat/." Interval<Nat>)] + [number + ["." nat ("nat/." interval)]] [collection [tree ["." finger (#+ Tree)]]]]]) @@ -24,7 +25,7 @@ (def: #export (peek queue) (All [a] (-> (Queue a) (Maybe a))) - (do maybe.Monad<Maybe> + (do maybe.monad [fingers queue] (wrap (maybe.assume (finger.search (n/= (finger.tag fingers)) fingers))))) @@ -61,7 +62,7 @@ (def: #export (pop queue) (All [a] (-> (Queue a) (Queue a))) - (do maybe.Monad<Maybe> + (do maybe.monad [fingers queue #let [highest-priority (finger.tag fingers)] node' (loop [node (get@ #finger.node fingers)] @@ -96,7 +97,7 @@ (def: #export (push priority value queue) (All [a] (-> Priority a (Queue a) (Queue a))) - (let [addition {#finger.monoid number.Max@Monoid<Nat> + (let [addition {#finger.monoid nat.maximum #finger.node (#finger.Leaf priority value)}] (case queue #.None diff --git a/stdlib/source/lux/data/collection/row.lux b/stdlib/source/lux/data/collection/row.lux index f495cf755..b3cbfedf1 100644 --- a/stdlib/source/lux/data/collection/row.lux +++ b/stdlib/source/lux/data/collection/row.lux @@ -15,8 +15,8 @@ [number ["." i64]] [collection - ["." list ("list/." Fold<List> Functor<List> Monoid<List>)] - ["." array (#+ Array) ("array/." Functor<Array> Fold<Array>)]]] + ["." list ("list/." fold functor monoid)] + ["." array (#+ Array) ("array/." functor fold)]]] [macro (#+ with-gensyms) ["." code] ["s" syntax (#+ syntax: Syntax)]]]) @@ -141,7 +141,7 @@ #.None (n/> branching-exponent level) - (do maybe.Monad<Maybe> + (do maybe.monad [base|hierarchy (array.read sub-idx hierarchy) sub (case base|hierarchy (#Hierarchy sub) @@ -250,7 +250,7 @@ (def: #export (nth idx vec) (All [a] (-> Nat (Row a) (Maybe a))) - (do maybe.Monad<Maybe> + (do maybe.monad [base (base-for idx vec)] (array.read (branch-idx idx) base))) @@ -297,7 +297,7 @@ (set@ #tail (|> (array.new new-tail-size) (array.copy new-tail-size 0 old-tail 0))))) (maybe.assume - (do maybe.Monad<Maybe> + (do maybe.monad [new-tail (base-for (n/- 2 vec-size) vec) #let [[level' root'] (let [init-level (get@ #level vec)] (loop [level init-level @@ -345,28 +345,28 @@ (wrap (list (` (from-list (list (~+ elems))))))) ## [Structures] -(structure: #export (Equivalence<Node> Equivalence<a>) (All [a] (-> (Equivalence a) (Equivalence (Node a)))) +(structure: #export (node-equivalence Equivalence<a>) (All [a] (-> (Equivalence a) (Equivalence (Node a)))) (def: (= v1 v2) (case [v1 v2] [(#Base b1) (#Base b2)] - (:: (array.Equivalence<Array> Equivalence<a>) = b1 b2) + (:: (array.equivalence Equivalence<a>) = b1 b2) [(#Hierarchy h1) (#Hierarchy h2)] - (:: (array.Equivalence<Array> (Equivalence<Node> Equivalence<a>)) = h1 h2) + (:: (array.equivalence (node-equivalence Equivalence<a>)) = h1 h2) _ #0))) -(structure: #export (Equivalence<Row> Equivalence<a>) (All [a] (-> (Equivalence a) (Equivalence (Row a)))) +(structure: #export (equivalence Equivalence<a>) (All [a] (-> (Equivalence a) (Equivalence (Row a)))) (def: (= v1 v2) (and (n/= (get@ #size v1) (get@ #size v2)) - (let [(^open "Node/.") (Equivalence<Node> Equivalence<a>)] + (let [(^open "Node/.") (node-equivalence Equivalence<a>)] (and (Node/= (#Base (get@ #tail v1)) (#Base (get@ #tail v2))) (Node/= (#Hierarchy (get@ #root v1)) (#Hierarchy (get@ #root v2)))))))) -(structure: _ (Fold Node) +(structure: node-fold (Fold Node) (def: (fold f init xs) (case xs (#Base base) @@ -377,21 +377,22 @@ init hierarchy)))) -(structure: #export _ (Fold Row) +(structure: #export fold (Fold Row) (def: (fold f init xs) - (let [(^open ".") Fold<Node>] + (let [(^open ".") node-fold] (fold f (fold f init (#Hierarchy (get@ #root xs))) (#Base (get@ #tail xs)))))) -(structure: #export Monoid<Row> (All [a] (Monoid (Row a))) +(structure: #export monoid (All [a] (Monoid (Row a))) (def: identity ..empty) + (def: (compose xs ys) (list/fold add xs (..to-list ys)))) -(structure: _ (Functor Node) +(structure: node-functor (Functor Node) (def: (map f xs) (case xs (#Base base) @@ -400,40 +401,40 @@ (#Hierarchy hierarchy) (#Hierarchy (array/map (map f) hierarchy))))) -(structure: #export _ (Functor Row) +(structure: #export functor (Functor Row) (def: (map f xs) {#level (get@ #level xs) #size (get@ #size xs) - #root (|> xs (get@ #root) (array/map (:: Functor<Node> map f))) + #root (|> xs (get@ #root) (array/map (:: node-functor map f))) #tail (|> xs (get@ #tail) (array/map f))})) -(structure: #export _ (Apply Row) - (def: functor Functor<Row>) +(structure: #export apply (Apply Row) + (def: &functor ..functor) (def: (apply ff fa) - (let [(^open ".") Functor<Row> - (^open ".") Fold<Row> - (^open ".") Monoid<Row> + (let [(^open ".") ..functor + (^open ".") ..fold + (^open ".") ..monoid results (map (function (_ f) (map f fa)) ff)] (fold compose identity results)))) -(structure: #export _ (Monad Row) - (def: functor Functor<Row>) +(structure: #export monad (Monad Row) + (def: &functor ..functor) (def: wrap (|>> row)) (def: join - (let [(^open ".") Fold<Row> - (^open ".") Monoid<Row>] + (let [(^open ".") ..fold + (^open ".") ..monoid] (fold (function (_ post pre) (compose pre post)) identity)))) ## TODO: This definition of 'reverse' shouldn't work correctly. ## Investigate if/why it does. (def: #export reverse (All [a] (-> (Row a) (Row a))) - (let [(^open ".") Fold<Row> - (^open ".") Monoid<Row>] + (let [(^open ".") ..fold + (^open ".") ..monoid] (fold add identity))) (do-template [<name> <array> <init> <op>] diff --git a/stdlib/source/lux/data/collection/sequence.lux b/stdlib/source/lux/data/collection/sequence.lux index 06209f4d6..30b2bf46e 100644 --- a/stdlib/source/lux/data/collection/sequence.lux +++ b/stdlib/source/lux/data/collection/sequence.lux @@ -12,14 +12,12 @@ [data bit [collection - [list ("list/." Monad<List>)]]]]) + [list ("list/." monad)]]]]) -## [Types] (type: #export (Sequence a) {#.doc "An infinite sequence of values."} (Cont [a (Sequence a)])) -## [Utils] (def: (cycle' x xs init full) (All [a] (-> a (List a) a (List a) (Sequence a))) @@ -27,7 +25,6 @@ #.Nil (pending [x (cycle' init full init full)]) (#.Cons x' xs') (pending [x (cycle' x' xs' init full)]))) -## [Functions] (def: #export (iterate f x) {#.doc "Create a sequence by applying a function to a value, and to its result, on and on..."} (All [a] @@ -116,20 +113,18 @@ (All [a] (-> (-> a Bit) (Sequence a) [(Sequence a) (Sequence a)])) [(filter p xs) (filter (complement p) xs)]) -## [Structures] -(structure: #export _ (Functor Sequence) +(structure: #export functor (Functor Sequence) (def: (map f fa) (let [[h t] (continuation.run fa)] (pending [(f h) (map f t)])))) -(structure: #export _ (CoMonad Sequence) - (def: functor Functor<Sequence>) +(structure: #export comonad (CoMonad Sequence) + (def: &functor ..functor) (def: unwrap head) (def: (split wa) (let [[head tail] (continuation.run wa)] (pending [wa (split tail)])))) -## [Pattern-matching] (syntax: #export (^sequence& {patterns (s.form (p.many s.any))} body {branches (p.some s.any)}) diff --git a/stdlib/source/lux/data/collection/set.lux b/stdlib/source/lux/data/collection/set.lux index 6de27eb24..01a588cc1 100644 --- a/stdlib/source/lux/data/collection/set.lux +++ b/stdlib/source/lux/data/collection/set.lux @@ -7,7 +7,7 @@ [data [collection ["dict" dictionary (#+ Dictionary)] - ["." list ("list/." Fold<List>)]]] + ["." list ("list/." fold)]]] [type abstract]]) @@ -53,18 +53,18 @@ (:abstraction (dict.select (dict.keys (:representation filter)) (:representation base)))) - (structure: #export Equivalence<Set> (All [a] (Equivalence (Set a))) + (structure: #export equivalence (All [a] (Equivalence (Set a))) (def: (= reference sample) - (let [[Hash<a> _] (:representation reference)] - (:: (list.Equivalence<List> (get@ #hash.eq Hash<a>)) = + (let [[hash _] (:representation reference)] + (:: (list.equivalence (get@ #hash.&equivalence hash)) = (..to-list reference) (..to-list sample))))) - (structure: #export Hash<Set> (All [a] (Hash (Set a))) - (def: eq ..Equivalence<Set>) + (structure: #export hash (All [a] (Hash (Set a))) + (def: &equivalence ..equivalence) (def: (hash set) - (let [[Hash<a> _] (:representation set)] - (list/fold (function (_ elem acc) (n/+ (:: Hash<a> hash elem) acc)) + (let [[hash _] (:representation set)] + (list/fold (function (_ elem acc) (n/+ (:: hash hash elem) acc)) 0 (..to-list set))))) ) @@ -73,9 +73,9 @@ (All [a] (-> (Set a) Bit)) (|>> ..size (n/= 0))) -(def: #export (from-list Hash<a> xs) +(def: #export (from-list hash elements) (All [a] (-> (Hash a) (List a) (Set a))) - (list/fold ..add (..new Hash<a>) xs)) + (list/fold ..add (..new hash) elements)) (def: #export (sub? super sub) (All [a] (-> (Set a) (Set a) Bit)) diff --git a/stdlib/source/lux/data/collection/set/multi.lux b/stdlib/source/lux/data/collection/set/multi.lux index d152c8506..de770e30a 100644 --- a/stdlib/source/lux/data/collection/set/multi.lux +++ b/stdlib/source/lux/data/collection/set/multi.lux @@ -10,7 +10,7 @@ [//// ["." maybe]] [/// - ["." list ("list/." Fold<List>)] + ["." list ("list/." fold)] ["." dictionary (#+ Dictionary)]] ["." //]) @@ -115,7 +115,7 @@ dictionary.keys (//.from-list Hash<a>)))) - (structure: #export Equivalence<Set> (All [a] (Equivalence (Set a))) + (structure: #export equivalence (All [a] (Equivalence (Set a))) (def: (= (^:representation reference) (^:representation sample)) (and (n/= (dictionary.size reference) (dictionary.size sample)) @@ -127,8 +127,8 @@ (maybe.default 0) (n/= count)))))))) - (structure: #export Hash<Set> (All [a] (Hash (Set a))) - (def: eq ..Equivalence<Set>) + (structure: #export hash (All [a] (Hash (Set a))) + (def: &equivalence ..equivalence) (def: (hash (^:representation set)) (let [[Hash<a> _] set] diff --git a/stdlib/source/lux/data/collection/set/ordered.lux b/stdlib/source/lux/data/collection/set/ordered.lux index 02b0307f9..a16a42ead 100644 --- a/stdlib/source/lux/data/collection/set/ordered.lux +++ b/stdlib/source/lux/data/collection/set/ordered.lux @@ -5,7 +5,7 @@ [order (#+ Order)]] [data [collection - ["." list ("list/." Fold<List>)] + ["." list ("list/." fold)] [dictionary ["//" ordered]]]] [type @@ -74,9 +74,9 @@ (list.filter (|>> (..member? param) not)) (..from-list (get@ #//.order (:representation subject))))) - (structure: #export Equivalence<Set> (All [a] (Equivalence (Set a))) + (structure: #export equivalence (All [a] (Equivalence (Set a))) (def: (= reference sample) - (:: (list.Equivalence<List> (:: (:representation sample) eq)) + (:: (list.equivalence (:: (:representation sample) eq)) = (..to-list reference) (..to-list sample)))) ) diff --git a/stdlib/source/lux/data/collection/tree/rose.lux b/stdlib/source/lux/data/collection/tree/rose.lux index fc25f414f..18ab2bf44 100644 --- a/stdlib/source/lux/data/collection/tree/rose.lux +++ b/stdlib/source/lux/data/collection/tree/rose.lux @@ -8,7 +8,7 @@ fold] [data [collection - ["." list ("list/." Monad<List> Fold<List>)]]] + ["." list ("list/." monad fold)]]] ["." macro ["." code] ["s" syntax (#+ syntax: Syntax)]]]) @@ -57,18 +57,18 @@ #children (list (~+ (list/map recur children)))}))))))) ## [Structs] -(structure: #export (Equivalence<Tree> Equivalence<a>) (All [a] (-> (Equivalence a) (Equivalence (Tree a)))) +(structure: #export (equivalence Equivalence<a>) (All [a] (-> (Equivalence a) (Equivalence (Tree a)))) (def: (= tx ty) (and (:: Equivalence<a> = (get@ #value tx) (get@ #value ty)) - (:: (list.Equivalence<List> (Equivalence<Tree> Equivalence<a>)) = (get@ #children tx) (get@ #children ty))))) + (:: (list.equivalence (equivalence Equivalence<a>)) = (get@ #children tx) (get@ #children ty))))) -(structure: #export _ (Functor Tree) +(structure: #export functor (Functor Tree) (def: (map f fa) {#value (f (get@ #value fa)) #children (list/map (map f) (get@ #children fa))})) -(structure: #export _ (Fold Tree) +(structure: #export fold (Fold Tree) (def: (fold f init tree) (list/fold (function (_ tree' init') (fold f init' tree')) (f (get@ #value tree) diff --git a/stdlib/source/lux/data/collection/tree/rose/zipper.lux b/stdlib/source/lux/data/collection/tree/rose/zipper.lux index f9380577b..e5d16a07a 100644 --- a/stdlib/source/lux/data/collection/tree/rose/zipper.lux +++ b/stdlib/source/lux/data/collection/tree/rose/zipper.lux @@ -4,14 +4,14 @@ functor comonad] [data - ["." maybe ("maybe/." Monad<Maybe>)] + ["." maybe ("maybe/." monad)] [collection - ["." list ("list/." Functor<List> Fold<List> Monoid<List>)] + ["." list ("list/." functor fold monoid)] ["." stack (#+ Stack)]]] ["." macro ["." code] - ["s" syntax (#+ syntax: Syntax)]]] - ["." // (#+ Tree) ("tree/." Functor<Tree>)]) + ["s" syntax (#+ Syntax syntax:)]]] + ["." // (#+ Tree) ("tree/." functor)]) ## Adapted from the clojure.zip namespace in the Clojure standard library. @@ -214,7 +214,7 @@ [insert-right #rights] ) -(structure: #export _ (Functor Zipper) +(structure: #export functor (Functor Zipper) (def: (map f fa) {#parent (|> fa (get@ #parent) (maybe/map (map f))) #lefts (|> fa (get@ #lefts) (list/map (tree/map f))) @@ -222,8 +222,8 @@ #node (tree/map f (get@ #node fa))})) ## TODO: Add again once new-luxc becomes the standard compiler. -## (structure: #export _ (CoMonad Zipper) -## (def: functor Functor<Zipper>) +## (structure: #export comonad (CoMonad Zipper) +## (def: &functor ..functor) ## (def: unwrap (get@ [#node #//.value])) diff --git a/stdlib/source/lux/data/color.lux b/stdlib/source/lux/data/color.lux index 0c96f46c4..e0de8ac88 100644 --- a/stdlib/source/lux/data/color.lux +++ b/stdlib/source/lux/data/color.lux @@ -3,9 +3,10 @@ [control [equivalence (#+ Equivalence)]] [data - [number ("rev/." Interval<Rev>)] + [number + [rev ("rev/." interval)]] [collection - ["." list ("list/." Functor<List>)]]] + ["." list ("list/." functor)]]] ["." math] [type abstract]]) @@ -55,7 +56,7 @@ (-> Color RGB) (|>> :representation)) - (structure: #export _ (Equivalence Color) + (structure: #export equivalence (Equivalence Color) (def: (= reference sample) (let [[rr rg rb] (:representation reference) [sr sg sb] (:representation sample)] diff --git a/stdlib/source/lux/data/env.lux b/stdlib/source/lux/data/env.lux index 134220215..2c8d01fcd 100644 --- a/stdlib/source/lux/data/env.lux +++ b/stdlib/source/lux/data/env.lux @@ -1,18 +1,19 @@ (.module: [lux #* - [control ["F" functor] + [control + [functor (#+ Functor)] comonad]]) (type: #export (Env e a) {#env e #value a}) -(structure: #export Functor<Env> (All [e] (F.Functor (Env e))) +(structure: #export functor (All [e] (Functor (Env e))) (def: (map f fa) (update@ #value f fa))) -(structure: #export CoMonad<Env> (All [e] (CoMonad (Env e))) - (def: functor Functor<Env>) +(structure: #export comonad (All [e] (CoMonad (Env e))) + (def: &functor ..functor) (def: unwrap (get@ #value)) diff --git a/stdlib/source/lux/data/error.lux b/stdlib/source/lux/data/error.lux index fc30718af..98f05869f 100644 --- a/stdlib/source/lux/data/error.lux +++ b/stdlib/source/lux/data/error.lux @@ -1,17 +1,15 @@ (.module: [lux #* [control - ["F" functor] - ["A" apply] - ["M" monad (#+ do Monad)]]]) + ["." functor (#+ Functor)] + [apply (#+ Apply)] + ["." monad (#+ Monad do)]]]) -## [Types] (type: #export (Error a) (#Failure Text) (#Success a)) -## [Structures] -(structure: #export _ (F.Functor Error) +(structure: #export functor (Functor Error) (def: (map f ma) (case ma (#Failure msg) @@ -20,8 +18,8 @@ (#Success datum) (#Success (f datum))))) -(structure: #export _ (A.Apply Error) - (def: functor Functor<Error>) +(structure: #export apply (Apply Error) + (def: &functor ..functor) (def: (apply ff fa) (case ff @@ -37,8 +35,8 @@ (#Failure msg)) )) -(structure: #export _ (Monad Error) - (def: functor Functor<Error>) +(structure: #export monad (Monad Error) + (def: &functor ..functor) (def: (wrap a) (#Success a)) @@ -51,15 +49,16 @@ (#Success ma) ma))) -(structure: #export (ErrorT Monad<M>) +(structure: #export (with-error monad) + ## TODO: Replace (All [a] (M (Error a))) with (functor.Then M Error) (All [M] (-> (Monad M) (Monad (All [a] (M (Error a)))))) - (def: functor (F.compose (get@ #M.functor Monad<M>) Functor<Error>)) + (def: &functor (functor.compose (get@ #monad.&functor monad) ..functor)) - (def: wrap (|>> (:: Monad<Error> wrap) (:: Monad<M> wrap))) + (def: wrap (|>> (:: ..monad wrap) (:: monad wrap))) (def: (join MeMea) - (do Monad<M> + (do monad [eMea MeMea] (case eMea (#Failure error) @@ -68,16 +67,16 @@ (#Success Mea) Mea)))) -(def: #export (lift Monad<M>) +(def: #export (lift monad) (All [M a] (-> (Monad M) (-> (M a) (M (Error a))))) - (M.lift Monad<M> (:: Monad<Error> wrap))) + (monad.lift monad (:: ..monad wrap))) (def: #export (succeed value) (All [a] (-> a (Error a))) (#Success value)) (def: #export (fail message) - (All [a] (-> Text (Error a))) + (-> Text Error) (#Failure message)) (def: #export (assume error) @@ -92,10 +91,10 @@ (macro: #export (default tokens compiler) {#.doc (doc "Allows you to provide a default value that will be used" "if a (Error x) value turns out to be #Failure." - (is? +10 - (default +20 (#Success +10))) - (is? +20 - (default +20 (#Failure "KABOOM!"))))} + (= "foo" + (default "foo" (#Success "bar"))) + (= "foo" + (default "foo" (#Failure "KABOOM!"))))} (case tokens (^ (list else error)) (#Success [compiler (list (` (case (~ error) diff --git a/stdlib/source/lux/data/format/binary.lux b/stdlib/source/lux/data/format/binary.lux index 7c6d463b3..834dbcbe9 100644 --- a/stdlib/source/lux/data/format/binary.lux +++ b/stdlib/source/lux/data/format/binary.lux @@ -4,19 +4,20 @@ [monoid (#+ Monoid)] ["." fold] [monad (#+ do Monad)] - ["." parser (#+ Parser) ("parser/." Functor<Parser>)] + ["." parser (#+ Parser) ("parser/." functor)] ["ex" exception (#+ exception:)] [equivalence (#+ Equivalence)]] [data ["." error (#+ Error)] - ["." number - ["." i64]] + [number + ["." i64] + ["." frac]] [text ["." encoding] [format (#+ %n)]] [collection ["." list] - ["." row (#+ Row) ("row/." Functor<Row>)]]] + ["." row (#+ Row) ("row/." functor)]]] [type (#+ :share)] [world ["." binary (#+ Binary)]]]) @@ -52,7 +53,7 @@ Mutation [0 (function (_ offset data) data)]) -(structure: #export _ (Monoid Mutation) +(structure: #export monoid (Monoid Mutation) (def: identity ..no-op) @@ -98,7 +99,6 @@ (let [[valueS valueT] ((get@ #writer format) value)] (|> valueS binary.create (valueT 0)))) -## Primitives (do-template [<name> <size> <read> <write>] [(def: #export <name> (Format (I64 Any)) @@ -122,10 +122,9 @@ [bits/64 size/64 binary.read/64 binary.write/64] ) -## Combinators (def: #export (or leftB rightB) (All [l r] (-> (Format l) (Format r) (Format (| l r)))) - {#reader (do parser.Monad<Parser> + {#reader (do parser.monad [flag (get@ #reader bits/8)] (case flag 0 (:: @ map (|>> #.Left) (get@ #reader leftB)) @@ -213,19 +212,19 @@ (def: #export frac (Format Frac) (let [(^slots [#reader #writer]) ..bits/64] - {#reader (:: parser.Monad<Parser> map number.bits-to-frac reader) - #writer (|>> number.frac-to-bits writer)})) + {#reader (:: parser.monad map frac.bits-to-frac reader) + #writer (|>> frac.frac-to-bits writer)})) (do-template [<name> <bits> <size> <write>] [(def: #export <name> (Format Binary) (let [mask (..mask <size>)] - {#reader (do parser.Monad<Parser> + {#reader (do parser.monad [size (:coerce (Reader Nat) ## TODO: Remove coercion. (get@ #reader <bits>))] (function (_ [offset binary]) - (do error.Monad<Error> + (do error.monad [#let [end (n/+ size offset)] output (binary.slice offset (.dec end) binary)] (wrap [[end binary] output])))) @@ -234,7 +233,7 @@ [(n/+ <size> size) (function (_ offset binary) (error.assume - (do error.Monad<Error> + (do error.monad [_ (<write> offset size binary)] (binary.copy size 0 value (n/+ <size> offset) binary))))]))}))] @@ -248,7 +247,7 @@ [(def: #export <name> (Format Text) (let [(^open "binary/.") <binary>] - {#reader (do parser.Monad<Parser> + {#reader (do parser.monad [utf8 binary/reader] (parser.lift (encoding.from-utf8 utf8))) #writer (|>> encoding.to-utf8 binary/writer)}))] @@ -264,7 +263,7 @@ (do-template [<name> <with-offset> <bits> <size> <write>] [(def: #export (<with-offset> extra-count valueF) (All [v] (-> Nat (Format v) (Format (Row v)))) - {#reader (do parser.Monad<Parser> + {#reader (do parser.monad [count (|> (get@ #reader <bits>) ## TODO: Remove coercion. (:coerce (Reader Nat)) @@ -276,11 +275,11 @@ {(Row v) row.empty})] (if (n/< count index) - (do parser.Monad<Parser> + (do parser.monad [value (get@ #reader valueF)] (recur (.inc index) (row.add value output))) - (:: parser.Monad<Parser> wrap output)))) + (:: parser.monad wrap output)))) #writer (function (_ value) (let [original-count (row.size value) capped-count (i64.and (..mask <size>) @@ -288,17 +287,17 @@ value (if (n/= original-count capped-count) value (|> value row.to-list (list.take capped-count) row.from-list)) - (^open "mutation/.") ..Monoid<Mutation> + (^open "mutation/.") ..monoid [size mutation] (|> value (row/map (get@ #writer valueF)) - (:: row.Fold<Row> fold + (:: row.fold fold (function (_ post pre) (mutation/compose pre post)) mutation/identity))] [(n/+ <size> size) (function (_ offset binary) (error.assume - (do error.Monad<Error> + (do error.monad [_ (<write> offset (n/+ extra-count capped-count) binary)] (wrap (mutation (n/+ <size> offset) binary)))))]))}) diff --git a/stdlib/source/lux/data/format/context.lux b/stdlib/source/lux/data/format/context.lux index 715489072..a89675393 100644 --- a/stdlib/source/lux/data/format/context.lux +++ b/stdlib/source/lux/data/format/context.lux @@ -22,7 +22,7 @@ (def: #export empty Context - (dictionary.new text.Hash<Text>)) + (dictionary.new text.hash)) (def: #export (property name) (-> Text (Property Text)) diff --git a/stdlib/source/lux/data/format/css.lux b/stdlib/source/lux/data/format/css.lux index 3623a2f5d..4dcd01b05 100644 --- a/stdlib/source/lux/data/format/css.lux +++ b/stdlib/source/lux/data/format/css.lux @@ -2,12 +2,13 @@ [lux (#- and) [data ["." maybe] - ["." number] + [number + ["." nat]] ["." text format ["." encoding (#+ Encoding)]] [collection - [list ("list/." Functor<List>)]]] + [list ("list/." functor)]]] [type abstract] [world @@ -27,6 +28,8 @@ Text + (def: #export css (-> (CSS Any) Text) (|>> :representation)) + (def: #export empty (CSS Common) (:abstraction "")) (def: #export (rule selector style) @@ -44,8 +47,8 @@ (-> Font (CSS Special)) (let [with-unicode (case (get@ #/font.unicode-range font) (#.Some unicode-range) - (let [unicode-range' (format "U+" (:: number.Hex@Codec<Text,Nat> encode (get@ #/font.start unicode-range)) - "-" (:: number.Hex@Codec<Text,Nat> encode (get@ #/font.end unicode-range)))] + (let [unicode-range' (format "U+" (:: nat.hex encode (get@ #/font.start unicode-range)) + "-" (:: nat.hex encode (get@ #/font.end unicode-range)))] (list ["unicode-range" unicode-range'])) #.None @@ -104,7 +107,7 @@ (|> css :representation (text.split-all-with ..css-separator) - (list/map (|>> (format (/selector.selector (combinator selector (/selector.tag "")))))) + (list/map (|>> (format (/selector.selector (|> selector (combinator (/selector.tag ""))))))) (text.join-with ..css-separator) :abstraction)) diff --git a/stdlib/source/lux/data/format/css/value.lux b/stdlib/source/lux/data/format/css/value.lux index 0d1c773be..e9e6ccfbe 100644 --- a/stdlib/source/lux/data/format/css/value.lux +++ b/stdlib/source/lux/data/format/css/value.lux @@ -4,11 +4,12 @@ ["." color] ["." product] ["." maybe] - ["." number] + [number + ["." rev]] ["." text format] [collection - ["." list ("list/." Functor<List>)]]] + ["." list ("list/." functor)]]] [type abstract] [macro @@ -828,7 +829,7 @@ (..apply "rgba" (list (%n red) (%n green) (%n blue) - (if (r/= (:: number.Interval<Rev> top) alpha) + (if (r/= (:: rev.interval top) alpha) "1.0" (format "0" (%r alpha))))))) diff --git a/stdlib/source/lux/data/format/html.lux b/stdlib/source/lux/data/format/html.lux index 4adb63b7a..73820c6c8 100644 --- a/stdlib/source/lux/data/format/html.lux +++ b/stdlib/source/lux/data/format/html.lux @@ -6,15 +6,18 @@ ["." text format] [collection - [list ("list/." Functor<List> Fold<List>)]]] + [list ("list/." functor fold)]]] ["." function] [type abstract] + [macro + ["." template]] [world [net (#+ URL)]]] [// - ["." css (#+ CSS) - ["." selector]] + [css + ["." selector] + ["." style (#+ Style)]] ["." xml (#+ XML)]]) (type: #export Tag selector.Tag) @@ -93,24 +96,25 @@ [Document Document'] ) - (abstract: #export (Element' brand) {} Any) - (type: #export Element (HTML (Element' Any))) + (do-template [<super> <super-raw> <sub>+] + [(abstract: #export (<super-raw> brand) {} Any) + (type: #export <super> (HTML (<super-raw> Any))) - (abstract: #export Content' {} Any) - (type: #export Content (HTML (Element' Content'))) + (`` (do-template [<sub> <sub-raw>] + [(abstract: #export <sub-raw> {} Any) + (type: #export <sub> (HTML (<super-raw> <sub-raw>)))] - (abstract: #export Image' {} Any) - (type: #export Image (HTML (Element' Image'))) + (~~ (template.splice <sub>+))))] - (abstract: #export (Media' brand) {} Any) - (type: #export Media (HTML (Media' Any))) + [Element Element' + [[Content Content'] + [Image Image']]] - (abstract: #export Source' {} Any) - (type: #export Source (HTML (Media' Source'))) + [Media Media' + [[Source Source'] + [Track Track']]] + ) - (abstract: #export Track' {} Any) - (type: #export Track (HTML (Media' Track'))) - (def: #export html (-> Document Text) (|>> :representation)) @@ -176,8 +180,8 @@ (..simple "base" full))) (def: #export style - (-> CSS Meta) - (..raw "style" (list))) + (-> Style Meta) + (|>> style.inline (..raw "style" (list)))) (def: #export (script attributes inline) (-> Attributes (Maybe Script) Meta) @@ -210,7 +214,7 @@ (def: #export (svg attributes content) (-> Attributes XML Element) (|> content - (:: xml.Codec<Text,XML> encode) + (:: xml.codec encode) (..raw "svg" attributes))) (type: #export Coord diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux index edafe3178..a4aad7c83 100644 --- a/stdlib/source/lux/data/format/json.lux +++ b/stdlib/source/lux/data/format/json.lux @@ -2,10 +2,10 @@ "For more information, please see: http://www.json.org/")} [lux #* [control - ["." monad (#+ do Monad)] + ["." monad (#+ Monad do)] [equivalence (#+ Equivalence)] codec - ["p" parser ("parser/." Monad<Parser>)] + ["p" parser ("parser/." monad)] ["ex" exception (#+ exception:)]] [data ["." bit] @@ -13,14 +13,15 @@ ["." error (#+ Error)] ["." sum] ["." product] - ["." number ("frac/." Codec<Text,Frac>) ("nat/." Codec<Text,Nat>)] - ["." text ("text/." Equivalence<Text> Monoid<Text>) + [number + ["." frac ("frac/." decimal)]] + ["." text ("text/." equivalence monoid) ["l" lexer]] [collection - ["." list ("list/." Fold<List> Monad<List>)] - ["." row (#+ Row row) ("row/." Monad<Row>)] + ["." list ("list/." fold monad)] + ["." row (#+ Row row) ("row/." monad)] ["." dictionary (#+ Dictionary)]]] - ["." macro (#+ Monad<Meta> with-gensyms) + ["." macro (#+ monad with-gensyms) ["s" syntax (#+ syntax:)] ["." code]]]) @@ -61,7 +62,7 @@ (json ["this" "is" "an" "array"]) (json {"this" "is" "an" "object"}))} - (let [(^open ".") Monad<Meta> + (let [(^open ".") ..monad wrapper (function (_ x) (` (..json (~ x))))] (case token (^template [<ast-tag> <ctor> <json-tag>] @@ -78,7 +79,7 @@ (wrap (list (` (: JSON (#Array (row (~+ (list/map wrapper members)))))))) [_ (#.Record pairs)] - (do Monad<Meta> + (do ..monad [pairs' (monad.map @ (function (_ [slot value]) (case slot @@ -88,7 +89,7 @@ _ (macro.fail "Wrong syntax for JSON object."))) pairs)] - (wrap (list (` (: JSON (#Object (dictionary.from-list text.Hash<Text> (list (~+ pairs'))))))))) + (wrap (list (` (: JSON (#Object (dictionary.from-list text.hash (list (~+ pairs'))))))))) _ (wrap (list token)) @@ -150,7 +151,7 @@ [get-object #Object Object "objects"] ) -(structure: #export _ (Equivalence JSON) +(structure: #export equivalence (Equivalence JSON) (def: (= x y) (case [x y] [#Null #Null] @@ -159,16 +160,16 @@ (^template [<tag> <struct>] [(<tag> x') (<tag> y')] (:: <struct> = x' y')) - ([#Boolean bit.Equivalence<Bit>] - [#Number number.Equivalence<Frac>] - [#String text.Equivalence<Text>]) + ([#Boolean bit.equivalence] + [#Number frac.equivalence] + [#String text.equivalence]) [(#Array xs) (#Array ys)] (and (n/= (row.size xs) (row.size ys)) (list/fold (function (_ idx prev) (and prev (maybe.default #0 - (do maybe.Monad<Maybe> + (do maybe.monad [x' (row.nth idx xs) y' (row.nth idx ys)] (wrap (= x' y')))))) @@ -203,7 +204,7 @@ [(def: <name> (-> <type> Text) <codec>)] [show-boolean Boolean encode-boolean] - [show-number Number (:: number.Codec<Text,Frac> encode)] + [show-number Number (:: frac.decimal encode)] [show-string String text.encode]) (def: (show-array show-json elems) @@ -281,7 +282,7 @@ [(def: #export <name> {#.doc (code.text ($_ text/compose "Reads a JSON value as " <desc> "."))} (Reader <type>) - (do p.Monad<Parser> + (do p.monad [head any] (case head (<tag> value) @@ -300,7 +301,7 @@ [(def: #export (<test> test) {#.doc (code.text ($_ text/compose "Asks whether a JSON value is a " <desc> "."))} (-> <type> (Reader Bit)) - (do p.Monad<Parser> + (do p.monad [head any] (case head (<tag> value) @@ -312,7 +313,7 @@ (def: #export (<check> test) {#.doc (code.text ($_ text/compose "Ensures a JSON value is a " <desc> "."))} (-> <type> (Reader Any)) - (do p.Monad<Parser> + (do p.monad [head any] (case head (<tag> value) @@ -323,9 +324,9 @@ _ (fail ($_ text/compose "JSON value is not a " <desc> ".")))))] - [boolean? boolean! Bit bit.Equivalence<Bit> encode-boolean #Boolean "boolean"] - [number? number! Frac number.Equivalence<Frac> (:: number.Codec<Text,Frac> encode) #Number "number"] - [string? string! Text text.Equivalence<Text> text.encode #String "string"] + [boolean? boolean! Bit bit.equivalence encode-boolean #Boolean "boolean"] + [number? number! Frac frac.equivalence (:: frac.decimal encode) #Number "number"] + [string? string! Text text.equivalence text.encode #String "string"] ) (def: #export (nullable parser) @@ -336,7 +337,7 @@ (def: #export (array parser) {#.doc "Parses a JSON array."} (All [a] (-> (Reader a) (Reader a))) - (do p.Monad<Parser> + (do p.monad [head any] (case head (#Array values) @@ -358,7 +359,7 @@ (def: #export (object parser) {#.doc "Parses a JSON object. Use this with the 'field' combinator."} (All [a] (-> (Reader a) (Reader a))) - (do p.Monad<Parser> + (do p.monad [head any] (case head (#Object kvs) @@ -398,7 +399,7 @@ (#error.Failure error) (#error.Failure error)) - (do error.Monad<Error> + (do error.monad [[inputs'' output] (recur inputs')] (wrap [(list& (#String key) value inputs'') output]))) @@ -423,14 +424,14 @@ (def: null~ (l.Lexer Null) - (do p.Monad<Parser> + (do p.monad [_ (l.this "null")] (wrap []))) (do-template [<name> <token> <value>] [(def: <name> (l.Lexer Boolean) - (do p.Monad<Parser> + (do p.monad [_ (l.this <token>)] (wrap <value>)))] @@ -444,7 +445,7 @@ (def: number~ (l.Lexer Number) - (do p.Monad<Parser> + (do p.monad [signed? (l.this? "-") digits (l.many l.decimal) decimals (p.default "0" @@ -486,7 +487,7 @@ (l.Lexer String) (<| (l.enclosed [text.double-quote text.double-quote]) (loop [_ []]) - (do p.Monad<Parser> + (do p.monad [chars (l.some (l.none-of (text/compose "\" text.double-quote))) stop l.peek]) (if (text/= "\" stop) @@ -498,7 +499,7 @@ (def: (kv~ json~) (-> (-> Any (l.Lexer JSON)) (l.Lexer [String JSON])) - (do p.Monad<Parser> + (do p.monad [key string~ _ space~ _ (l.this ":") @@ -509,7 +510,7 @@ (do-template [<name> <type> <open> <close> <elem-parser> <prep>] [(def: (<name> json~) (-> (-> Any (l.Lexer JSON)) (l.Lexer <type>)) - (do p.Monad<Parser> + (do p.monad [_ (l.this <open>) _ space~ elems (p.sep-by data-sep <elem-parser>) @@ -518,13 +519,13 @@ (wrap (<prep> elems))))] [array~ Array "[" "]" (json~ []) row.from-list] - [object~ Object "{" "}" (kv~ json~) (dictionary.from-list text.Hash<Text>)] + [object~ Object "{" "}" (kv~ json~) (dictionary.from-list text.hash)] ) (def: (json~' _) (-> Any (l.Lexer JSON)) ($_ p.or null~ boolean~ number~ string~ (array~ json~') (object~ json~'))) -(structure: #export _ (Codec Text JSON) +(structure: #export codec (Codec Text JSON) (def: encode show-json) (def: decode (function (_ input) (l.run input (json~' []))))) diff --git a/stdlib/source/lux/data/format/xml.lux b/stdlib/source/lux/data/format/xml.lux index e1cbda0db..56d603331 100644 --- a/stdlib/source/lux/data/format/xml.lux +++ b/stdlib/source/lux/data/format/xml.lux @@ -4,23 +4,24 @@ monad [equivalence (#+ Equivalence)] codec - ["p" parser ("parser/." Monad<Parser>)] + ["p" parser ("parser/." monad)] ["ex" exception (#+ exception:)]] [data - ["." number] ["." error (#+ Error)] ["." product] - ["." name ("name/." Equivalence<Name> Codec<Text,Name>)] - ["." text ("text/." Equivalence<Text> Monoid<Text>) + ["." name ("name/." equivalence codec)] + [number + ["." int]] + ["." text ("text/." equivalence monoid) ["l" lexer]] [collection - ["." list ("list/." Monad<List>)] + ["." list ("list/." monad)] ["d" dictionary]]]]) (type: #export Tag Name) (type: #export Attrs (d.Dictionary Name Text)) -(def: #export attrs Attrs (d.new name.Hash<Name>)) +(def: #export attrs Attrs (d.new name.hash)) (type: #export #rec XML (#Text Text) @@ -37,14 +38,14 @@ (def: xml-unicode-escape-char^ (l.Lexer Text) - (|> (do p.Monad<Parser> + (|> (do p.monad [hex? (p.maybe (l.this "x")) code (case hex? #.None - (p.codec number.Codec<Text,Int> (l.many l.decimal)) + (p.codec int.decimal (l.many l.decimal)) (#.Some _) - (p.codec number.Hex@Codec<Text,Int> (l.many l.hexadecimal)))] + (p.codec int.decimal (l.many l.hexadecimal)))] (wrap (|> code .nat text.from-code))) (p.before (l.this ";")) (p.after (l.this "&#")))) @@ -61,7 +62,7 @@ (def: xml-identifier (l.Lexer Text) - (do p.Monad<Parser> + (do p.monad [head (p.either (l.one-of "_") l.alpha) tail (l.some (p.either (l.one-of "_.-") @@ -70,7 +71,7 @@ (def: namespaced-symbol^ (l.Lexer Name) - (do p.Monad<Parser> + (do p.monad [first-part xml-identifier ?second-part (<| p.maybe (p.after (l.this ":")) xml-identifier)] (case ?second-part @@ -97,7 +98,7 @@ (def: attrs^ (l.Lexer Attrs) - (<| (:: p.Monad<Parser> map (d.from-list name.Hash<Name>)) + (<| (:: p.monad map (d.from-list name.hash)) p.some (p.and (spaced^ attr-name^)) (p.after (l.this "=")) @@ -105,7 +106,7 @@ (def: (close-tag^ expected) (-> Tag (l.Lexer [])) - (do p.Monad<Parser> + (do p.monad [actual (|> tag^ spaced^ (p.after (l.this "/")) @@ -149,14 +150,14 @@ (function (_ node^) (p.either text^ (spaced^ - (do p.Monad<Parser> + (do p.monad [_ (l.this "<") tag (spaced^ tag^) attrs (spaced^ attrs^) - #let [no-children^ (do p.Monad<Parser> + #let [no-children^ (do p.monad [_ (l.this "/>")] (wrap (#Node tag attrs (list)))) - with-children^ (do p.Monad<Parser> + with-children^ (do p.monad [_ (l.this ">") children (p.some node^) _ (close-tag^ tag)] @@ -222,11 +223,11 @@ (text.join-with "")) "</" tag ">"))))))) -(structure: #export _ (Codec Text XML) +(structure: #export codec (Codec Text XML) (def: encode write) (def: decode read)) -(structure: #export _ (Equivalence XML) +(structure: #export equivalence (Equivalence XML) (def: (= reference sample) (case [reference sample] [(#Text reference/value) (#Text sample/value)] @@ -235,7 +236,7 @@ [(#Node reference/tag reference/attrs reference/children) (#Node sample/tag sample/attrs sample/children)] (and (name/= reference/tag sample/tag) - (:: (d.Equivalence<Dictionary> text.Equivalence<Text>) = reference/attrs sample/attrs) + (:: (d.equivalence text.equivalence) = reference/attrs sample/attrs) (n/= (list.size reference/children) (list.size sample/children)) (|> (list.zip2 reference/children sample/children) @@ -258,7 +259,7 @@ (exception: #export (unconsumed-inputs {inputs (List XML)}) (|> inputs - (list/map (:: Codec<Text,XML> encode)) + (list/map (:: ..codec encode)) (text.join-with blank-line))) (def: #export text @@ -337,7 +338,7 @@ (ex.throw unexpected-input []) (#Node _tag _attrs _children) - (do error.Monad<Error> + (do error.monad [output (run' _children reader)] (wrap [tail output])))))) diff --git a/stdlib/source/lux/data/identity.lux b/stdlib/source/lux/data/identity.lux index 7a41cb69f..6f1fc60ef 100644 --- a/stdlib/source/lux/data/identity.lux +++ b/stdlib/source/lux/data/identity.lux @@ -1,8 +1,8 @@ (.module: [lux #* [control - ["F" functor] - ["A" apply] + [functor (#+ Functor)] + [apply (#+ Apply)] ["M" monad #*] ["CM" comonad #*]]]) @@ -11,20 +11,20 @@ a) ## [Structures] -(structure: #export _ (F.Functor Identity) +(structure: #export functor (Functor Identity) (def: map id)) -(structure: #export _ (A.Apply Identity) - (def: functor Functor<Identity>) +(structure: #export apply (Apply Identity) + (def: &functor ..functor) (def: (apply ff fa) (ff fa))) -(structure: #export _ (Monad Identity) - (def: functor Functor<Identity>) +(structure: #export monad (Monad Identity) + (def: &functor ..functor) (def: wrap id) (def: join id)) -(structure: #export _ (CoMonad Identity) - (def: functor Functor<Identity>) +(structure: #export comonad (CoMonad Identity) + (def: &functor ..functor) (def: unwrap id) (def: split id)) diff --git a/stdlib/source/lux/data/lazy.lux b/stdlib/source/lux/data/lazy.lux index 66fac2989..c8f5746b1 100644 --- a/stdlib/source/lux/data/lazy.lux +++ b/stdlib/source/lux/data/lazy.lux @@ -36,16 +36,16 @@ (with-gensyms [g!_] (wrap (list (` ((~! freeze') (function ((~ g!_) (~ g!_)) (~ expr)))))))) -(structure: #export _ (Functor Lazy) +(structure: #export functor (Functor Lazy) (def: (map f fa) (freeze (f (thaw fa))))) -(structure: #export _ (Apply Lazy) - (def: functor Functor<Lazy>) +(structure: #export apply (Apply Lazy) + (def: &functor ..functor) (def: (apply ff fa) (freeze ((thaw ff) (thaw fa))))) -(structure: #export _ (Monad Lazy) - (def: functor Functor<Lazy>) +(structure: #export monad (Monad Lazy) + (def: &functor ..functor) (def: wrap (|>> freeze)) (def: join thaw)) diff --git a/stdlib/source/lux/data/maybe.lux b/stdlib/source/lux/data/maybe.lux index d0dfe1886..5b780e999 100644 --- a/stdlib/source/lux/data/maybe.lux +++ b/stdlib/source/lux/data/maybe.lux @@ -4,30 +4,32 @@ [monoid (#+ Monoid)] ["." functor (#+ Functor)] [apply (#+ Apply)] - ["." monad (#+ do Monad)] + ["." monad (#+ Monad do)] [equivalence (#+ Equivalence)]]]) -## [Types] ## (type: (Maybe a) ## #.None ## (#.Some a)) -## [Structures] -(structure: #export Monoid<Maybe> (All [a] (Monoid (Maybe a))) +(structure: #export monoid (All [a] (Monoid (Maybe a))) (def: identity #.None) - (def: (compose xs ys) - (case xs - #.None ys - (#.Some x) (#.Some x)))) + + (def: (compose mx my) + (case mx + #.None + my + + (#.Some x) + (#.Some x)))) -(structure: #export _ (Functor Maybe) +(structure: #export functor (Functor Maybe) (def: (map f ma) (case ma #.None #.None (#.Some a) (#.Some (f a))))) -(structure: #export _ (Apply Maybe) - (def: functor Functor<Maybe>) +(structure: #export apply (Apply Maybe) + (def: &functor ..functor) (def: (apply ff fa) (case [ff fa] @@ -37,38 +39,41 @@ _ #.None))) -(structure: #export _ (Monad Maybe) - (def: functor Functor<Maybe>) +(structure: #export monad (Monad Maybe) + (def: &functor ..functor) (def: (wrap x) (#.Some x)) (def: (join mma) (case mma - #.None #.None - (#.Some xs) xs))) + #.None + #.None + + (#.Some mx) + mx))) -(structure: #export (Equivalence<Maybe> Equivalence<a>) (All [a] (-> (Equivalence a) (Equivalence (Maybe a)))) +(structure: #export (equivalence a-equivalence) (All [a] (-> (Equivalence a) (Equivalence (Maybe a)))) (def: (= mx my) (case [mx my] [#.None #.None] #1 [(#.Some x) (#.Some y)] - (:: Equivalence<a> = x y) + (:: a-equivalence = x y) _ #0))) -(structure: #export (MaybeT Monad<M>) +(structure: #export (with-maybe monad) (All [M] (-> (Monad M) (Monad (All [a] (M (Maybe a)))))) - (def: functor (functor.compose (get@ #monad.functor Monad<M>) Functor<Maybe>)) + (def: &functor (functor.compose (get@ #monad.&functor monad) ..functor)) - (def: wrap (|>> (:: Monad<Maybe> wrap) (:: Monad<M> wrap))) + (def: wrap (|>> (:: ..monad wrap) (:: monad wrap))) (def: (join MmMma) - (do Monad<M> + (do monad [mMma MmMma] (case mMma #.None @@ -77,9 +82,9 @@ (#.Some Mma) Mma)))) -(def: #export (lift Monad<M>) +(def: #export (lift monad) (All [M a] (-> (Monad M) (-> (M a) (M (Maybe a))))) - (monad.lift Monad<M> (:: Monad<Maybe> wrap))) + (monad.lift monad (:: ..monad wrap))) (macro: #export (default tokens state) {#.doc (doc "Allows you to provide a default value that will be used" diff --git a/stdlib/source/lux/data/name.lux b/stdlib/source/lux/data/name.lux index 0129bc5cc..5ecea23ba 100644 --- a/stdlib/source/lux/data/name.lux +++ b/stdlib/source/lux/data/name.lux @@ -5,7 +5,7 @@ [codec (#+ Codec)] hash] [data - ["." text ("text/." Monoid<Text> Hash<Text>)]]]) + ["." text ("text/." monoid hash)]]]) ## [Types] ## (type: Name @@ -22,12 +22,12 @@ ) ## [Structures] -(structure: #export _ (Equivalence Name) +(structure: #export equivalence (Equivalence Name) (def: (= [xmodule xname] [ymodule yname]) (and (text/= xmodule ymodule) (text/= xname yname)))) -(structure: #export _ (Codec Text Name) +(structure: #export codec (Codec Text Name) (def: (encode [module short]) (case module "" short @@ -46,8 +46,8 @@ _ (#.Left (text/compose "Invalid format for Name: " input)))))) -(structure: #export _ (Hash Name) - (def: eq Equivalence<Name>) +(structure: #export hash (Hash Name) + (def: &equivalence ..equivalence) (def: (hash [module name]) (n/+ (text/hash module) (text/hash name)))) diff --git a/stdlib/source/lux/data/number.lux b/stdlib/source/lux/data/number.lux index f297f2788..9e658bd52 100644 --- a/stdlib/source/lux/data/number.lux +++ b/stdlib/source/lux/data/number.lux @@ -1,670 +1,15 @@ -(.module: {#.doc "Implementations of common structures for Lux's primitive number types."} +(.module: [lux #* [control - number - [monoid (#+ Monoid)] - [equivalence (#+ Equivalence)] - hash - ["." order (#+ Order)] - enum - interval [codec (#+ Codec)]] [data ["." error (#+ Error)] - ["." maybe] - ["." text (#+ Char)] - [collection - ["." array (#+ Array)]]] - ["." function] - ["." math]] + ["." text]]] [/ - ["." i64]]) - -(do-template [<type> <test>] - [(structure: #export _ (Equivalence <type>) - (def: = <test>))] - - [ Nat n/=] - [ Int i/=] - [ Rev r/=] - [Frac f/=] - ) - -(do-template [<type> <eq> <lt> <lte> <gt> <gte>] - [(structure: #export _ (Order <type>) - (def: eq <eq>) - (def: < <lt>) - (def: <= <lte>) - (def: > <gt>) - (def: >= <gte>))] - - [ Nat Equivalence<Nat> n/< n/<= n/> n/>=] - [ Int Equivalence<Int> i/< i/<= i/> i/>=] - [Rev Equivalence<Rev> r/< r/<= r/> r/>=] - [Frac Equivalence<Frac> f/< f/<= f/> f/>=] - ) - -(do-template [<type> <order> <succ> <pred>] - [(structure: #export _ (Enum <type>) - (def: order <order>) - (def: succ <succ>) - (def: pred <pred>))] - - [Nat Order<Nat> inc dec] - [Int Order<Int> inc dec] - [Frac Order<Frac> (f/+ ("lux frac smallest")) (f/- ("lux frac smallest"))] - [Rev Order<Rev> inc dec] - ) - -(do-template [<type> <enum> <top> <bottom>] - [(structure: #export _ (Interval <type>) - (def: enum <enum>) - (def: top <top>) - (def: bottom <bottom>))] - - [ Nat Enum<Nat> (:coerce Nat -1) 0] - [ Int Enum<Int> +9_223_372_036_854_775_807 -9_223_372_036_854_775_808] - [Frac Enum<Frac> ("lux frac max") ("lux frac min")] - [ Rev Enum<Rev> (:coerce Rev -1) (:coerce Rev 0)] - ) - -(structure: #export _ (Number Nat) - (def: + n/+) - (def: - n/-) - (def: * n/*) - (def: / n//) - (def: % n/%) - (def: (negate value) (n/- (:: Interval<Nat> top) value)) - (def: abs function.identity) - (def: (signum x) - (case x - 0 0 - _ 1)) - ) - -(do-template [<type> <order> <+> <-> <*> </> <%> <=> <<> <0> <1> <-1>] - [(structure: #export _ (Number <type>) - (def: + <+>) - (def: - <->) - (def: * <*>) - (def: / </>) - (def: % <%>) - (def: negate (<*> <-1>)) - (def: (abs x) - (if (<<> <0> x) - (<*> <-1> x) - x)) - (def: (signum x) - (cond (<=> <0> x) <0> - (<<> <0> x) <-1> - ## else - <1>)) - )] - - [ Int Order<Int> i/+ i/- i/* i// i/% i/= i/< +0 +1 -1] - [Frac Order<Frac> f/+ f/- f/* f// f/% f/= f/< +0.0 +1.0 -1.0] - ) - -(structure: #export _ (Number Rev) - (def: + r/+) - (def: - r/-) - (def: * r/*) - (def: / r//) - (def: % r/%) - (def: (negate x) (r/- x (:coerce Rev -1))) - (def: abs function.identity) - (def: (signum x) - (:coerce Rev -1))) - -(do-template [<name> <type> <identity> <compose>] - [(structure: #export <name> (Monoid <type>) - (def: identity <identity>) - (def: compose <compose>))] - - [ Add@Monoid<Nat> Nat 0 n/+] - [ Mul@Monoid<Nat> Nat 1 n/*] - [ Max@Monoid<Nat> Nat (:: Interval<Nat> bottom) n/max] - [ Min@Monoid<Nat> Nat (:: Interval<Nat> top) n/min] - [ Add@Monoid<Int> Int +0 i/+] - [ Mul@Monoid<Int> Int +1 i/*] - [ Max@Monoid<Int> Int (:: Interval<Int> bottom) i/max] - [ Min@Monoid<Int> Int (:: Interval<Int> top) i/min] - [Add@Monoid<Frac> Frac +0.0 f/+] - [Mul@Monoid<Frac> Frac +1.0 f/*] - [Max@Monoid<Frac> Frac (:: Interval<Frac> bottom) f/max] - [Min@Monoid<Frac> Frac (:: Interval<Frac> top) f/min] - [ Add@Monoid<Rev> Rev (:: Interval<Rev> bottom) r/+] - [ Mul@Monoid<Rev> Rev (:: Interval<Rev> top) r/*] - [ Max@Monoid<Rev> Rev (:: Interval<Rev> bottom) r/max] - [ Min@Monoid<Rev> Rev (:: Interval<Rev> top) r/min] - ) - -(do-template [<name> <numerator> <doc>] - [(def: #export <name> - {#.doc <doc>} - Frac - (f// +0.0 <numerator>))] - - [not-a-number +0.0 "Not a number."] - [positive-infinity +1.0 "Positive infinity."] - [negative-infinity -1.0 "Negative infinity."] - ) - -(def: #export (not-a-number? number) - {#.doc "Tests whether a frac is actually not-a-number."} - (-> Frac Bit) - (not (f/= number number))) - -(def: #export (frac? value) - (-> Frac Bit) - (not (or (not-a-number? value) - (f/= positive-infinity value) - (f/= negative-infinity value)))) - -(do-template [<type> <encoder> <decoder> <error>] - [(structure: #export _ (Codec Text <type>) - (def: (encode x) - (<encoder> [x])) - - (def: (decode input) - (case (<decoder> [input]) - (#.Some value) - (#error.Success value) - - #.None - (#error.Failure <error>))))] - - [Frac "lux frac encode" "lux frac decode" "Could not decode Frac"] - ) - -(def: (get-char! full idx) - (-> Text Nat Char) - ("lux text char" full idx)) - -(def: (binary-character value) - (-> Nat (Maybe Text)) - (case value - 0 (#.Some "0") - 1 (#.Some "1") - _ #.None)) - -(def: (binary-value digit) - (-> Char (Maybe Nat)) - (case digit - (^ (char "0")) (#.Some 0) - (^ (char "1")) (#.Some 1) - _ #.None)) - -(def: (octal-character value) - (-> Nat (Maybe Text)) - (case value - 0 (#.Some "0") - 1 (#.Some "1") - 2 (#.Some "2") - 3 (#.Some "3") - 4 (#.Some "4") - 5 (#.Some "5") - 6 (#.Some "6") - 7 (#.Some "7") - _ #.None)) - -(def: (octal-value digit) - (-> Char (Maybe Nat)) - (case digit - (^ (char "0")) (#.Some 0) - (^ (char "1")) (#.Some 1) - (^ (char "2")) (#.Some 2) - (^ (char "3")) (#.Some 3) - (^ (char "4")) (#.Some 4) - (^ (char "5")) (#.Some 5) - (^ (char "6")) (#.Some 6) - (^ (char "7")) (#.Some 7) - _ #.None)) - -(def: (decimal-character value) - (-> Nat (Maybe Text)) - (case value - 0 (#.Some "0") - 1 (#.Some "1") - 2 (#.Some "2") - 3 (#.Some "3") - 4 (#.Some "4") - 5 (#.Some "5") - 6 (#.Some "6") - 7 (#.Some "7") - 8 (#.Some "8") - 9 (#.Some "9") - _ #.None)) - -(def: (decimal-value digit) - (-> Char (Maybe Nat)) - (case digit - (^ (char "0")) (#.Some 0) - (^ (char "1")) (#.Some 1) - (^ (char "2")) (#.Some 2) - (^ (char "3")) (#.Some 3) - (^ (char "4")) (#.Some 4) - (^ (char "5")) (#.Some 5) - (^ (char "6")) (#.Some 6) - (^ (char "7")) (#.Some 7) - (^ (char "8")) (#.Some 8) - (^ (char "9")) (#.Some 9) - _ #.None)) - -(def: (hexadecimal-character value) - (-> Nat (Maybe Text)) - (case value - 0 (#.Some "0") - 1 (#.Some "1") - 2 (#.Some "2") - 3 (#.Some "3") - 4 (#.Some "4") - 5 (#.Some "5") - 6 (#.Some "6") - 7 (#.Some "7") - 8 (#.Some "8") - 9 (#.Some "9") - 10 (#.Some "A") - 11 (#.Some "B") - 12 (#.Some "C") - 13 (#.Some "D") - 14 (#.Some "E") - 15 (#.Some "F") - _ #.None)) - -(def: (hexadecimal-value digit) - (-> Char (Maybe Nat)) - (case digit - (^ (char "0")) (#.Some 0) - (^ (char "1")) (#.Some 1) - (^ (char "2")) (#.Some 2) - (^ (char "3")) (#.Some 3) - (^ (char "4")) (#.Some 4) - (^ (char "5")) (#.Some 5) - (^ (char "6")) (#.Some 6) - (^ (char "7")) (#.Some 7) - (^ (char "8")) (#.Some 8) - (^ (char "9")) (#.Some 9) - (^or (^ (char "a")) (^ (char "A"))) (#.Some 10) - (^or (^ (char "b")) (^ (char "B"))) (#.Some 11) - (^or (^ (char "c")) (^ (char "C"))) (#.Some 12) - (^or (^ (char "d")) (^ (char "D"))) (#.Some 13) - (^or (^ (char "e")) (^ (char "E"))) (#.Some 14) - (^or (^ (char "f")) (^ (char "F"))) (#.Some 15) - _ #.None)) - -(do-template [<struct> <base> <to-character> <to-value> <error>] - [(structure: #export <struct> (Codec Text Nat) - (def: (encode value) - (loop [input value - output ""] - (let [digit (maybe.assume (<to-character> (n/% <base> input))) - output' ("lux text concat" digit output) - input' (n// <base> input)] - (if (n/= 0 input') - output' - (recur input' output'))))) - - (def: (decode repr) - (let [input-size ("lux text size" repr)] - (if (n/> 0 input-size) - (loop [idx 0 - output 0] - (if (n/< input-size idx) - (case (<to-value> (get-char! repr idx)) - #.None - (#error.Failure ("lux text concat" <error> repr)) - - (#.Some digit-value) - (recur (inc idx) - (|> output (n/* <base>) (n/+ digit-value)))) - (#error.Success output))) - (#error.Failure ("lux text concat" <error> repr))))))] - - [Binary@Codec<Text,Nat> 2 binary-character binary-value "Invalid binary syntax for Nat: "] - [Octal@Codec<Text,Nat> 8 octal-character octal-value "Invalid octal syntax for Nat: "] - [_ 10 decimal-character decimal-value "Invalid syntax for Nat: "] - [Hex@Codec<Text,Nat> 16 hexadecimal-character hexadecimal-value "Invalid hexadecimal syntax for Nat: "] - ) - -(def: (int/sign!! value) - (-> Int Text) - (if (i/< +0 value) - "-" - "+")) - -(def: (int/sign?? representation) - (-> Text (Maybe Int)) - (case (get-char! representation 0) - (^ (char "-")) - (#.Some -1) - - (^ (char "+")) - (#.Some +1) - - _ - #.None)) - -(def: (int-decode-loop input-size repr sign <base> <to-value> <error>) - (-> Nat Text Int Int (-> Char (Maybe Nat)) Text (Error Int)) - (loop [idx 1 - output +0] - (if (n/< input-size idx) - (case (<to-value> (get-char! repr idx)) - #.None - (#error.Failure <error>) - - (#.Some digit-value) - (recur (inc idx) - (|> output (i/* <base>) (i/+ (.int digit-value))))) - (#error.Success (i/* sign output))))) - -(do-template [<struct> <base> <to-character> <to-value> <error>] - [(structure: #export <struct> (Codec Text Int) - (def: (encode value) - (if (i/= +0 value) - "+0" - (loop [input (|> value (i// <base>) (:: Number<Int> abs)) - output (|> value (i/% <base>) (:: Number<Int> abs) .nat - <to-character> - maybe.assume)] - (if (i/= +0 input) - ("lux text concat" (int/sign!! value) output) - (let [digit (maybe.assume (<to-character> (.nat (i/% <base> input))))] - (recur (i// <base> input) - ("lux text concat" digit output))))))) - - (def: (decode repr) - (let [input-size ("lux text size" repr)] - (if (n/> 1 input-size) - (case (int/sign?? repr) - (#.Some sign) - (int-decode-loop input-size repr sign <base> <to-value> <error>) - - #.None - (#error.Failure <error>)) - (#error.Failure <error>)))))] - - [Binary@Codec<Text,Int> +2 binary-character binary-value "Invalid binary syntax for Int: "] - [Octal@Codec<Text,Int> +8 octal-character octal-value "Invalid octal syntax for Int: "] - [_ +10 decimal-character decimal-value "Invalid syntax for Int: "] - [Hex@Codec<Text,Int> +16 hexadecimal-character hexadecimal-value "Invalid hexadecimal syntax for Int: "] - ) - -(def: (de-prefix input) - (-> Text Text) - ("lux text clip" input 1 ("lux text size" input))) - -(do-template [<struct> <nat> <char-bit-size> <error>] - [(with-expansions [<error-output> (as-is (#error.Failure ("lux text concat" <error> repr)))] - (structure: #export <struct> (Codec Text Rev) - (def: (encode value) - (let [raw-output (de-prefix (:: <nat> encode (:coerce Nat value))) - max-num-chars (n// <char-bit-size> 64) - raw-size ("lux text size" raw-output) - zero-padding (loop [zeroes-left (n/- raw-size max-num-chars) - output ""] - (if (n/= 0 zeroes-left) - output - (recur (dec zeroes-left) - ("lux text concat" "0" output)))) - padded-output ("lux text concat" zero-padding raw-output)] - ("lux text concat" "." padded-output))) - - (def: (decode repr) - (let [repr-size ("lux text size" repr)] - (if (n/>= 2 repr-size) - (case ("lux text char" repr 0) - (^ (char ".")) - (case (:: <nat> decode (de-prefix repr)) - (#error.Success output) - (#error.Success (:coerce Rev output)) - - _ - <error-output>) - - _ - <error-output>) - <error-output>)))))] - - [Binary@Codec<Text,Rev> Binary@Codec<Text,Nat> 1 "Invalid binary syntax: "] - [Octal@Codec<Text,Rev> Octal@Codec<Text,Nat> 3 "Invalid octal syntax: "] - [Hex@Codec<Text,Rev> Hex@Codec<Text,Nat> 4 "Invalid hexadecimal syntax: "] - ) - -(do-template [<struct> <int> <base> <char-set> <error>] - [(structure: #export <struct> (Codec Text Frac) - (def: (encode value) - (let [whole (frac-to-int value) - whole-part (:: <int> encode whole) - decimal (:: Number<Frac> abs (f/% +1.0 value)) - decimal-part (if (f/= +0.0 decimal) - ".0" - (loop [dec-left decimal - output ""] - (if (f/= +0.0 dec-left) - ("lux text concat" "." output) - (let [shifted (f/* <base> dec-left) - digit-idx (|> shifted (f/% <base>) frac-to-int .nat)] - (recur (f/% +1.0 shifted) - ("lux text concat" output ("lux text clip" <char-set> digit-idx (inc digit-idx))))))))] - ("lux text concat" whole-part decimal-part))) - - (def: (decode repr) - (case ("lux text index" repr "." 0) - (#.Some split-index) - (let [whole-part ("lux text clip" repr 0 split-index) - decimal-part ("lux text clip" repr (inc split-index) ("lux text size" repr))] - (case [(:: <int> decode whole-part) - (:: <int> decode decimal-part)] - (^multi [(#error.Success whole) (#error.Success decimal)] - (i/>= +0 decimal)) - (let [sign (if (i/< +0 whole) - -1.0 - +1.0) - div-power (loop [muls-left ("lux text size" decimal-part) - output +1.0] - (if (n/= 0 muls-left) - output - (recur (dec muls-left) - (f/* <base> output)))) - adjusted-decimal (|> decimal int-to-frac (f// div-power)) - dec-rev (case (:: Hex@Codec<Text,Rev> decode ("lux text concat" "." decimal-part)) - (#error.Success dec-rev) - dec-rev - - (#error.Failure error) - (error! error))] - (#error.Success (f/+ (int-to-frac whole) - (f/* sign adjusted-decimal)))) - - _ - (#error.Failure ("lux text concat" <error> repr)))) - - _ - (#error.Failure ("lux text concat" <error> repr)))))] - - [Binary@Codec<Text,Frac> Binary@Codec<Text,Int> +2.0 "01" "Invalid binary syntax: "] - ) - -(def: (segment-digits chunk-size digits) - (-> Nat Text (List Text)) - (case digits - "" - (list) - - _ - (let [num-digits ("lux text size" digits)] - (if (n/<= chunk-size num-digits) - (list digits) - (let [boundary (n/- chunk-size num-digits) - chunk ("lux text clip" digits boundary num-digits) - remaining ("lux text clip" digits 0 boundary)] - (list& chunk (segment-digits chunk-size remaining))))))) - -(def: (bin-segment-to-hex input) - (-> Text Text) - (case input - "0000" "0" - "0001" "1" - "0010" "2" - "0011" "3" - "0100" "4" - "0101" "5" - "0110" "6" - "0111" "7" - "1000" "8" - "1001" "9" - "1010" "A" - "1011" "B" - "1100" "C" - "1101" "D" - "1110" "E" - "1111" "F" - _ (undefined))) - -(def: (hex-segment-to-bin input) - (-> Text Text) - (case input - "0" "0000" - "1" "0001" - "2" "0010" - "3" "0011" - "4" "0100" - "5" "0101" - "6" "0110" - "7" "0111" - "8" "1000" - "9" "1001" - (^or "a" "A") "1010" - (^or "b" "B") "1011" - (^or "c" "C") "1100" - (^or "d" "D") "1101" - (^or "e" "E") "1110" - (^or "f" "F") "1111" - _ (undefined))) - -(def: (bin-segment-to-octal input) - (-> Text Text) - (case input - "000" "0" - "001" "1" - "010" "2" - "011" "3" - "100" "4" - "101" "5" - "110" "6" - "111" "7" - _ (undefined))) - -(def: (octal-segment-to-bin input) - (-> Text Text) - (case input - "0" "000" - "1" "001" - "2" "010" - "3" "011" - "4" "100" - "5" "101" - "6" "110" - "7" "111" - _ (undefined))) - -(def: (map f xs) - (All [a b] (-> (-> a b) (List a) (List b))) - (case xs - #.Nil - #.Nil - - (#.Cons x xs') - (#.Cons (f x) (map f xs')))) - -(def: (re-join-chunks xs) - (-> (List Text) Text) - (case xs - #.Nil - "" - - (#.Cons x xs') - ("lux text concat" x (re-join-chunks xs')))) - -(do-template [<from> <from-translator> <to> <to-translator> <base-bits>] - [(def: (<from> on-left? input) - (-> Bit Text Text) - (let [max-num-chars (n// <base-bits> 64) - input-size ("lux text size" input) - zero-padding (let [num-digits-that-need-padding (n/% <base-bits> input-size)] - (if (n/= 0 num-digits-that-need-padding) - "" - (loop [zeroes-left (n/- num-digits-that-need-padding - <base-bits>) - output ""] - (if (n/= 0 zeroes-left) - output - (recur (dec zeroes-left) - ("lux text concat" "0" output)))))) - padded-input (if on-left? - ("lux text concat" zero-padding input) - ("lux text concat" input zero-padding))] - (|> padded-input - (segment-digits <base-bits>) - (map <from-translator>) - re-join-chunks))) - - (def: <to> - (-> Text Text) - (|>> (segment-digits 1) - (map <to-translator>) - re-join-chunks))] - - [binary-to-hex bin-segment-to-hex hex-to-binary hex-segment-to-bin 4] - [binary-to-octal bin-segment-to-octal octal-to-binary octal-segment-to-bin 3] - ) - -(do-template [<struct> <error> <from> <to>] - [(structure: #export <struct> (Codec Text Frac) - (def: (encode value) - (let [sign (:: Number<Frac> signum value) - raw-bin (:: Binary@Codec<Text,Frac> encode value) - dot-idx (maybe.assume ("lux text index" raw-bin "." 0)) - whole-part ("lux text clip" raw-bin - (if (f/= -1.0 sign) 1 0) - dot-idx) - decimal-part ("lux text clip" raw-bin (inc dot-idx) ("lux text size" raw-bin)) - hex-output (|> (<from> #0 decimal-part) - ("lux text concat" ".") - ("lux text concat" (<from> #1 whole-part)) - ("lux text concat" (if (f/= -1.0 sign) "-" "")))] - hex-output)) - - (def: (decode repr) - (let [sign (case ("lux text index" repr "-" 0) - (#.Some 0) - -1.0 - - _ - +1.0)] - (case ("lux text index" repr "." 0) - (#.Some split-index) - (let [whole-part ("lux text clip" repr 1 split-index) - decimal-part ("lux text clip" repr (inc split-index) ("lux text size" repr)) - as-binary (|> (<to> decimal-part) - ("lux text concat" ".") - ("lux text concat" (<to> whole-part)) - ("lux text concat" (if (f/= -1.0 sign) "-" "+")))] - (case (:: Binary@Codec<Text,Frac> decode as-binary) - (#error.Failure _) - (#error.Failure ("lux text concat" <error> repr)) - - output - output)) - - _ - (#error.Failure ("lux text concat" <error> repr))))))] - - [Octal@Codec<Text,Frac> "Invalid octaladecimal syntax: " binary-to-octal octal-to-binary] - [Hex@Codec<Text,Frac> "Invalid hexadecimal syntax: " binary-to-hex hex-to-binary] - ) + ["/." nat] + ["/." int] + ["/." rev] + ["/." frac]]) (macro: (encoding-doc tokens state) (case tokens @@ -725,301 +70,13 @@ _ (#error.Failure <error>)))] - [bin Binary@Codec<Text,Nat> Binary@Codec<Text,Int> Binary@Codec<Text,Rev> Binary@Codec<Text,Frac> + [bin /nat.binary /int.binary /rev.binary /frac.binary "Invalid binary syntax." (encoding-doc "binary" (bin "+11001001") (bin "+11_00_10_01"))] - [oct Octal@Codec<Text,Nat> Octal@Codec<Text,Int> Octal@Codec<Text,Rev> Octal@Codec<Text,Frac> + [oct /nat.octal /int.octal /rev.octal /frac.octal "Invalid octal syntax." (encoding-doc "octal" (oct "+615243") (oct "+615_243"))] - [hex Hex@Codec<Text,Nat> Hex@Codec<Text,Int> Hex@Codec<Text,Rev> Hex@Codec<Text,Frac> + [hex /nat.hex /int.hex /rev.hex /frac.hex "Invalid hexadecimal syntax." (encoding-doc "hexadecimal" (hex "deadBEEF") (hex "dead_BEEF"))] ) - -## The following code allows one to encode/decode Rev numbers as text. -## This is not a simple algorithm, and it requires subverting the Rev -## abstraction a bit. -## It takes into account the fact that Rev numbers are represented by -## Lux as 64-bit integers. -## A valid way to model them is as Lux's Nat type. -## This is a somewhat hackish way to do things, but it allows one to -## write the encoding/decoding algorithm once, in pure Lux, rather -## than having to implement it on the compiler for every platform -## targeted by Lux. -(type: Digits (Array Nat)) - -(def: (make-digits _) - (-> Any Digits) - (array.new i64.width)) - -(def: (digits-get idx digits) - (-> Nat Digits Nat) - (|> digits (array.read idx) (maybe.default 0))) - -(def: digits-put - (-> Nat Nat Digits Digits) - array.write) - -(def: (prepend left right) - (-> Text Text Text) - ("lux text concat" left right)) - -(def: (digits-times-5! idx output) - (-> Nat Digits Digits) - (loop [idx idx - carry 0 - output output] - (if (i/>= +0 (:coerce Int idx)) - (let [raw (|> (digits-get idx output) - (n/* 5) - (n/+ carry))] - (recur (dec idx) - (n// 10 raw) - (digits-put idx (n/% 10 raw) output))) - output))) - -(def: (digits-power power) - (-> Nat Digits) - (loop [times power - output (|> (make-digits []) - (digits-put power 1))] - (if (i/>= +0 (:coerce Int times)) - (recur (dec times) - (digits-times-5! power output)) - output))) - -(def: (digits-to-text digits) - (-> Digits Text) - (loop [idx (dec i64.width) - all-zeroes? #1 - output ""] - (if (i/>= +0 (:coerce Int idx)) - (let [digit (digits-get idx digits)] - (if (and (n/= 0 digit) - all-zeroes?) - (recur (dec idx) #1 output) - (recur (dec idx) - #0 - ("lux text concat" - (:: Codec<Text,Int> encode (:coerce Int digit)) - output)))) - (if all-zeroes? - "0" - output)))) - -(def: (digits-add param subject) - (-> Digits Digits Digits) - (loop [idx (dec i64.width) - carry 0 - output (make-digits [])] - (if (i/>= +0 (:coerce Int idx)) - (let [raw ($_ n/+ - carry - (digits-get idx param) - (digits-get idx subject))] - (recur (dec idx) - (n// 10 raw) - (digits-put idx (n/% 10 raw) output))) - output))) - -(def: (text-to-digits input) - (-> Text (Maybe Digits)) - (let [length ("lux text size" input)] - (if (n/<= i64.width length) - (loop [idx 0 - output (make-digits [])] - (if (n/< length idx) - (case ("lux text index" "+0123456789" ("lux text clip" input idx (inc idx)) 0) - #.None - #.None - - (#.Some digit) - (recur (inc idx) - (digits-put idx digit output))) - (#.Some output))) - #.None))) - -(def: (digits-lt param subject) - (-> Digits Digits Bit) - (loop [idx 0] - (and (n/< i64.width idx) - (let [pd (digits-get idx param) - sd (digits-get idx subject)] - (if (n/= pd sd) - (recur (inc idx)) - (n/< pd sd)))))) - -(def: (digits-sub-once! idx param subject) - (-> Nat Nat Digits Digits) - (let [sd (digits-get idx subject)] - (if (n/>= param sd) - (digits-put idx (n/- param sd) subject) - (let [diff (|> sd - (n/+ 10) - (n/- param))] - (|> subject - (digits-put idx diff) - (digits-sub-once! (dec idx) 1)))))) - -(def: (digits-sub! param subject) - (-> Digits Digits Digits) - (loop [idx (dec i64.width) - output subject] - (if (i/>= +0 (.int idx)) - (recur (dec idx) - (digits-sub-once! idx (digits-get idx param) output)) - output))) - -(structure: #export _ (Codec Text Rev) - (def: (encode input) - (let [input (:coerce Nat input) - last-idx (dec i64.width)] - (if (n/= 0 input) - ".0" - (loop [idx last-idx - digits (make-digits [])] - (if (i/>= +0 (:coerce Int idx)) - (if (i64.set? idx input) - (let [digits' (digits-add (digits-power (n/- idx last-idx)) - digits)] - (recur (dec idx) - digits')) - (recur (dec idx) - digits)) - ("lux text concat" "." (digits-to-text digits)) - ))))) - - (def: (decode input) - (let [length ("lux text size" input) - dotted? (case ("lux text index" input "." 0) - (#.Some 0) - #1 - - _ - #0)] - (if (and dotted? - (n/<= (inc i64.width) length)) - (case (text-to-digits ("lux text clip" input 1 length)) - (#.Some digits) - (loop [digits digits - idx 0 - output 0] - (if (n/< i64.width idx) - (let [power (digits-power idx)] - (if (digits-lt power digits) - ## Skip power - (recur digits (inc idx) output) - (recur (digits-sub! power digits) - (inc idx) - (i64.set (n/- idx (dec i64.width)) output)))) - (#error.Success (:coerce Rev output)))) - - #.None - (#error.Failure ("lux text concat" "Wrong syntax for Rev: " input))) - (#error.Failure ("lux text concat" "Wrong syntax for Rev: " input)))) - )) - -(def: (log2 input) - (-> Frac Frac) - (f// (math.log +2.0) - (math.log input))) - -(def: double-bias Nat 1023) - -(def: mantissa-size Nat 52) -(def: exponent-size Nat 11) - -(def: #export (frac-to-bits input) - (-> Frac I64) - (i64 (cond (not-a-number? input) - (hex "7FF7FFFFFFFFFFFF") - - (f/= positive-infinity input) - (hex "7FF0000000000000") - - (f/= negative-infinity input) - (hex "FFF0000000000000") - - (f/= +0.0 input) - (let [reciprocal (f// input +1.0)] - (if (f/= positive-infinity reciprocal) - ## Positive zero - (hex "0000000000000000") - ## Negative zero - (hex "8000000000000000"))) - - ## else - (let [sign (:: Number<Frac> signum input) - input (:: Number<Frac> abs input) - exponent (math.floor (log2 input)) - exponent-mask (|> 1 (i64.left-shift exponent-size) dec) - mantissa (|> input - ## Normalize - (f// (math.pow exponent +2.0)) - ## Make it int-equivalent - (f/* (math.pow +52.0 +2.0))) - sign-bit (if (f/= -1.0 sign) 1 0) - exponent-bits (|> exponent frac-to-int .nat (n/+ double-bias) (i64.and exponent-mask)) - mantissa-bits (|> mantissa frac-to-int .nat)] - ($_ i64.or - (i64.left-shift 63 sign-bit) - (i64.left-shift mantissa-size exponent-bits) - (i64.clear mantissa-size mantissa-bits))) - ))) - -(do-template [<getter> <mask> <size> <offset>] - [(def: <mask> (|> 1 (i64.left-shift <size>) dec (i64.left-shift <offset>))) - (def: (<getter> input) - (-> (I64 Any) I64) - (|> input (i64.and <mask>) (i64.logical-right-shift <offset>) i64))] - - [mantissa mantissa-mask mantissa-size 0] - [exponent exponent-mask exponent-size mantissa-size] - [sign sign-mask 1 (n/+ exponent-size mantissa-size)] - ) - -(def: #export (bits-to-frac input) - (-> (I64 Any) Frac) - (let [S (sign input) - E (exponent input) - M (mantissa input)] - (cond (n/= (hex "7FF") E) - (if (n/= 0 M) - (if (n/= 0 S) - positive-infinity - negative-infinity) - not-a-number) - - (and (n/= 0 E) (n/= 0 M)) - (if (n/= 0 S) - +0.0 - (f/* -1.0 +0.0)) - - ## else - (let [normalized (|> M (i64.set mantissa-size) - .int int-to-frac - (f// (math.pow +52.0 +2.0))) - power (math.pow (|> E (n/- double-bias) - .int int-to-frac) - +2.0) - shifted (f/* power - normalized)] - (if (n/= 0 S) - shifted - (f/* -1.0 shifted)))))) - -(structure: #export _ (Hash Nat) - (def: eq Equivalence<Nat>) - (def: hash function.identity)) - -(structure: #export _ (Hash Int) - (def: eq Equivalence<Int>) - (def: hash .nat)) - -(structure: #export _ (Hash Frac) - (def: eq Equivalence<Frac>) - (def: hash frac-to-bits)) - -(structure: #export _ (Hash Rev) - (def: eq Equivalence<Rev>) - (def: hash (|>> (:coerce Nat)))) diff --git a/stdlib/source/lux/data/number/complex.lux b/stdlib/source/lux/data/number/complex.lux index aeefa03d6..a7993dcaf 100644 --- a/stdlib/source/lux/data/number/complex.lux +++ b/stdlib/source/lux/data/number/complex.lux @@ -5,14 +5,15 @@ [equivalence (#+ Equivalence)] number codec - ["M" monad (#+ do Monad)] + ["M" monad (#+ Monad do)] ["p" parser]] [data ["." maybe] - ["." number ("frac/." Number<Frac>)] - [text ("text/." Monoid<Text>)] + [number + ["." frac ("frac/." number)]] + [text ("text/." monoid)] [collection - ["." list ("list/." Functor<List>)]]] + ["." list ("list/." functor)]]] ["." macro ["." code] ["s" syntax (#+ syntax: Syntax)]]]) @@ -37,8 +38,8 @@ (def: #export zero Complex (complex +0.0 +0.0)) (def: #export (not-a-number? complex) - (or (number.not-a-number? (get@ #real complex)) - (number.not-a-number? (get@ #imaginary complex)))) + (or (frac.not-a-number? (get@ #real complex)) + (frac.not-a-number? (get@ #imaginary complex)))) (def: #export (= param input) (-> Complex Complex Bit) @@ -59,7 +60,7 @@ [- f/-] ) -(structure: #export _ (Equivalence Complex) +(structure: #export equivalence (Equivalence Complex) (def: = ..=)) (def: #export negate @@ -190,7 +191,7 @@ (frac/abs real)))) )))) -(structure: #export _ (Number Complex) +(structure: #export number (Number Complex) (def: + ..+) (def: - ..-) (def: * ..*) diff --git a/stdlib/source/lux/data/number/frac.lux b/stdlib/source/lux/data/number/frac.lux new file mode 100644 index 000000000..a2bd659b0 --- /dev/null +++ b/stdlib/source/lux/data/number/frac.lux @@ -0,0 +1,441 @@ +(.module: + [lux #* + [control + [hash (#+ Hash)] + [number (#+ Number)] + [enum (#+ Enum)] + [interval (#+ Interval)] + [monoid (#+ Monoid)] + [equivalence (#+ Equivalence)] + ["." order (#+ Order)] + [codec (#+ Codec)]] + [data + ["." error (#+ Error)] + ["." maybe]] + ["." math]] + [// + ["//." i64] + ["//." nat] + ["//." int] + ["//." rev]]) + +(structure: #export equivalence (Equivalence Frac) + (def: = f/=)) + +(structure: #export order (Order Frac) + (def: &equivalence ..equivalence) + (def: < f/<) + (def: <= f/<=) + (def: > f/>) + (def: >= f/>=)) + +(structure: #export enum (Enum Frac) + (def: &order ..order) + (def: succ (f/+ ("lux frac smallest"))) + (def: pred (f/- ("lux frac smallest")))) + +(structure: #export interval (Interval Frac) + (def: &enum ..enum) + (def: top ("lux frac max")) + (def: bottom ("lux frac min"))) + +(structure: #export number (Number Frac) + (def: + f/+) + (def: - f/-) + (def: * f/*) + (def: / f//) + (def: % f/%) + (def: negate (f/* -1.0)) + (def: (abs x) + (if (f/< +0.0 x) + (f/* -1.0 x) + x)) + (def: (signum x) + (cond (f/= +0.0 x) +0.0 + (f/< +0.0 x) -1.0 + ## else + +1.0)) + ) + +(do-template [<name> <compose> <identity>] + [(structure: #export <name> (Monoid Frac) + (def: identity <identity>) + (def: compose <compose>))] + + [addition f/+ +0.0] + [multiplication f/* +1.0] + [maximum f/max (:: ..interval bottom)] + [minimum f/min (:: ..interval top)] + ) + +(do-template [<name> <numerator> <doc>] + [(def: #export <name> + {#.doc <doc>} + Frac + (f// +0.0 <numerator>))] + + [not-a-number +0.0 "Not a number."] + [positive-infinity +1.0 "Positive infinity."] + [negative-infinity -1.0 "Negative infinity."] + ) + +(def: #export (not-a-number? number) + {#.doc "Tests whether a frac is actually not-a-number."} + (-> Frac Bit) + (not (f/= number number))) + +(def: #export (frac? value) + (-> Frac Bit) + (not (or (not-a-number? value) + (f/= positive-infinity value) + (f/= negative-infinity value)))) + +(structure: #export decimal (Codec Text Frac) + (def: (encode x) + ("lux frac encode" [x])) + + (def: (decode input) + (case ("lux frac decode" [input]) + (#.Some value) + (#error.Success value) + + #.None + (#error.Failure "Could not decode Frac")))) + +(do-template [<struct> <int> <base> <char-set> <error>] + [(structure: #export <struct> (Codec Text Frac) + (def: (encode value) + (let [whole (frac-to-int value) + whole-part (:: <int> encode whole) + decimal (:: ..number abs (f/% +1.0 value)) + decimal-part (if (f/= +0.0 decimal) + ".0" + (loop [dec-left decimal + output ""] + (if (f/= +0.0 dec-left) + ("lux text concat" "." output) + (let [shifted (f/* <base> dec-left) + digit-idx (|> shifted (f/% <base>) frac-to-int .nat)] + (recur (f/% +1.0 shifted) + ("lux text concat" output ("lux text clip" <char-set> digit-idx (inc digit-idx))))))))] + ("lux text concat" whole-part decimal-part))) + + (def: (decode repr) + (case ("lux text index" repr "." 0) + (#.Some split-index) + (let [whole-part ("lux text clip" repr 0 split-index) + decimal-part ("lux text clip" repr (inc split-index) ("lux text size" repr))] + (case [(:: <int> decode whole-part) + (:: <int> decode decimal-part)] + (^multi [(#error.Success whole) (#error.Success decimal)] + (i/>= +0 decimal)) + (let [sign (if (i/< +0 whole) + -1.0 + +1.0) + div-power (loop [muls-left ("lux text size" decimal-part) + output +1.0] + (if (n/= 0 muls-left) + output + (recur (dec muls-left) + (f/* <base> output)))) + adjusted-decimal (|> decimal int-to-frac (f// div-power)) + dec-rev (case (:: //rev.hex decode ("lux text concat" "." decimal-part)) + (#error.Success dec-rev) + dec-rev + + (#error.Failure error) + (error! error))] + (#error.Success (f/+ (int-to-frac whole) + (f/* sign adjusted-decimal)))) + + _ + (#error.Failure ("lux text concat" <error> repr)))) + + _ + (#error.Failure ("lux text concat" <error> repr)))))] + + [binary //int.binary +2.0 "01" "Invalid binary syntax: "] + ) + +(def: (segment-digits chunk-size digits) + (-> Nat Text (List Text)) + (case digits + "" + (list) + + _ + (let [num-digits ("lux text size" digits)] + (if (n/<= chunk-size num-digits) + (list digits) + (let [boundary (n/- chunk-size num-digits) + chunk ("lux text clip" digits boundary num-digits) + remaining ("lux text clip" digits 0 boundary)] + (list& chunk (segment-digits chunk-size remaining))))))) + +(def: (bin-segment-to-hex input) + (-> Text Text) + (case input + "0000" "0" + "0001" "1" + "0010" "2" + "0011" "3" + "0100" "4" + "0101" "5" + "0110" "6" + "0111" "7" + "1000" "8" + "1001" "9" + "1010" "A" + "1011" "B" + "1100" "C" + "1101" "D" + "1110" "E" + "1111" "F" + _ (undefined))) + +(def: (hex-segment-to-bin input) + (-> Text Text) + (case input + "0" "0000" + "1" "0001" + "2" "0010" + "3" "0011" + "4" "0100" + "5" "0101" + "6" "0110" + "7" "0111" + "8" "1000" + "9" "1001" + (^or "a" "A") "1010" + (^or "b" "B") "1011" + (^or "c" "C") "1100" + (^or "d" "D") "1101" + (^or "e" "E") "1110" + (^or "f" "F") "1111" + _ (undefined))) + +(def: (bin-segment-to-octal input) + (-> Text Text) + (case input + "000" "0" + "001" "1" + "010" "2" + "011" "3" + "100" "4" + "101" "5" + "110" "6" + "111" "7" + _ (undefined))) + +(def: (octal-segment-to-bin input) + (-> Text Text) + (case input + "0" "000" + "1" "001" + "2" "010" + "3" "011" + "4" "100" + "5" "101" + "6" "110" + "7" "111" + _ (undefined))) + +(def: (map f xs) + (All [a b] (-> (-> a b) (List a) (List b))) + (case xs + #.Nil + #.Nil + + (#.Cons x xs') + (#.Cons (f x) (map f xs')))) + +(def: (re-join-chunks xs) + (-> (List Text) Text) + (case xs + #.Nil + "" + + (#.Cons x xs') + ("lux text concat" x (re-join-chunks xs')))) + +(do-template [<from> <from-translator> <to> <to-translator> <base-bits>] + [(def: (<from> on-left? input) + (-> Bit Text Text) + (let [max-num-chars (n// <base-bits> 64) + input-size ("lux text size" input) + zero-padding (let [num-digits-that-need-padding (n/% <base-bits> input-size)] + (if (n/= 0 num-digits-that-need-padding) + "" + (loop [zeroes-left (n/- num-digits-that-need-padding + <base-bits>) + output ""] + (if (n/= 0 zeroes-left) + output + (recur (dec zeroes-left) + ("lux text concat" "0" output)))))) + padded-input (if on-left? + ("lux text concat" zero-padding input) + ("lux text concat" input zero-padding))] + (|> padded-input + (segment-digits <base-bits>) + (map <from-translator>) + re-join-chunks))) + + (def: <to> + (-> Text Text) + (|>> (segment-digits 1) + (map <to-translator>) + re-join-chunks))] + + [binary-to-hex bin-segment-to-hex hex-to-binary hex-segment-to-bin 4] + [binary-to-octal bin-segment-to-octal octal-to-binary octal-segment-to-bin 3] + ) + +(do-template [<struct> <error> <from> <to>] + [(structure: #export <struct> (Codec Text Frac) + (def: (encode value) + (let [sign (:: ..number signum value) + raw-bin (:: ..binary encode value) + dot-idx (maybe.assume ("lux text index" raw-bin "." 0)) + whole-part ("lux text clip" raw-bin + (if (f/= -1.0 sign) 1 0) + dot-idx) + decimal-part ("lux text clip" raw-bin (inc dot-idx) ("lux text size" raw-bin)) + hex-output (|> (<from> #0 decimal-part) + ("lux text concat" ".") + ("lux text concat" (<from> #1 whole-part)) + ("lux text concat" (if (f/= -1.0 sign) "-" "")))] + hex-output)) + + (def: (decode repr) + (let [sign (case ("lux text index" repr "-" 0) + (#.Some 0) + -1.0 + + _ + +1.0)] + (case ("lux text index" repr "." 0) + (#.Some split-index) + (let [whole-part ("lux text clip" repr 1 split-index) + decimal-part ("lux text clip" repr (inc split-index) ("lux text size" repr)) + as-binary (|> (<to> decimal-part) + ("lux text concat" ".") + ("lux text concat" (<to> whole-part)) + ("lux text concat" (if (f/= -1.0 sign) "-" "+")))] + (case (:: ..binary decode as-binary) + (#error.Failure _) + (#error.Failure ("lux text concat" <error> repr)) + + output + output)) + + _ + (#error.Failure ("lux text concat" <error> repr))))))] + + [octal "Invalid octaladecimal syntax: " binary-to-octal octal-to-binary] + [hex "Invalid hexadecimal syntax: " binary-to-hex hex-to-binary] + ) + +(def: (log2 input) + (-> Frac Frac) + (f// (math.log +2.0) + (math.log input))) + +(def: double-bias Nat 1023) + +(def: mantissa-size Nat 52) +(def: exponent-size Nat 11) + +(do-template [<hex> <name>] + [(def: <name> (|> <hex> (:: //nat.hex decode) error.assume .i64))] + + ["7FF7FFFFFFFFFFFF" not-a-number-bits] + ["7FF0000000000000" positive-infinity-bits] + ["FFF0000000000000" negative-infinity-bits] + ["0000000000000000" positive-zero-bits] + ["8000000000000000" negative-zero-bits] + ["7FF" special-exponent-bits] + ) + +(def: #export (frac-to-bits input) + (-> Frac I64) + (i64 (cond (not-a-number? input) + ..not-a-number-bits + + (f/= positive-infinity input) + ..positive-infinity-bits + + (f/= negative-infinity input) + ..negative-infinity-bits + + (f/= +0.0 input) + (let [reciprocal (f// input +1.0)] + (if (f/= positive-infinity reciprocal) + ## Positive zero + ..positive-zero-bits + ## Negative zero + ..negative-zero-bits)) + + ## else + (let [sign (:: ..number signum input) + input (:: ..number abs input) + exponent (math.floor (log2 input)) + exponent-mask (|> 1 (//i64.left-shift exponent-size) dec) + mantissa (|> input + ## Normalize + (f// (math.pow exponent +2.0)) + ## Make it int-equivalent + (f/* (math.pow +52.0 +2.0))) + sign-bit (if (f/= -1.0 sign) 1 0) + exponent-bits (|> exponent frac-to-int .nat (n/+ double-bias) (//i64.and exponent-mask)) + mantissa-bits (|> mantissa frac-to-int .nat)] + ($_ //i64.or + (//i64.left-shift 63 sign-bit) + (//i64.left-shift mantissa-size exponent-bits) + (//i64.clear mantissa-size mantissa-bits))) + ))) + +(do-template [<getter> <mask> <size> <offset>] + [(def: <mask> (|> 1 (//i64.left-shift <size>) dec (//i64.left-shift <offset>))) + (def: (<getter> input) + (-> (I64 Any) I64) + (|> input (//i64.and <mask>) (//i64.logical-right-shift <offset>) i64))] + + [mantissa mantissa-mask mantissa-size 0] + [exponent exponent-mask exponent-size mantissa-size] + [sign sign-mask 1 (n/+ exponent-size mantissa-size)] + ) + +(def: #export (bits-to-frac input) + (-> (I64 Any) Frac) + (let [S (sign input) + E (exponent input) + M (mantissa input)] + (cond (n/= ..special-exponent-bits E) + (if (n/= 0 M) + (if (n/= 0 S) + ..positive-infinity + ..negative-infinity) + ..not-a-number) + + (and (n/= 0 E) (n/= 0 M)) + (if (n/= 0 S) + +0.0 + (f/* -1.0 +0.0)) + + ## else + (let [normalized (|> M (//i64.set mantissa-size) + .int int-to-frac + (f// (math.pow +52.0 +2.0))) + power (math.pow (|> E (n/- double-bias) + .int int-to-frac) + +2.0) + shifted (f/* power + normalized)] + (if (n/= 0 S) + shifted + (f/* -1.0 shifted)))))) + +(structure: #export hash (Hash Frac) + (def: &equivalence ..equivalence) + (def: hash frac-to-bits)) diff --git a/stdlib/source/lux/data/number/int.lux b/stdlib/source/lux/data/number/int.lux new file mode 100644 index 000000000..1047b68f9 --- /dev/null +++ b/stdlib/source/lux/data/number/int.lux @@ -0,0 +1,134 @@ +(.module: + [lux #* + [control + [hash (#+ Hash)] + [number (#+ Number)] + [enum (#+ Enum)] + [interval (#+ Interval)] + [monoid (#+ Monoid)] + [equivalence (#+ Equivalence)] + ["." order (#+ Order)] + [codec (#+ Codec)]] + [data + ["." error (#+ Error)] + ["." maybe] + [text (#+ Char)]]] + [// + ["." nat]]) + +(structure: #export equivalence (Equivalence Int) + (def: = i/=)) + +(structure: #export order (Order Int) + (def: &equivalence ..equivalence) + (def: < i/<) + (def: <= i/<=) + (def: > i/>) + (def: >= i/>=)) + +(structure: #export enum (Enum Int) + (def: &order ..order) + (def: succ inc) + (def: pred dec)) + +(structure: #export interval (Interval Int) + (def: &enum ..enum) + (def: top +9_223_372_036_854_775_807) + (def: bottom -9_223_372_036_854_775_808)) + +(structure: #export number (Number Int) + (def: + i/+) + (def: - i/-) + (def: * i/*) + (def: / i//) + (def: % i/%) + (def: negate (i/* -1)) + (def: (abs x) + (if (i/< +0 x) + (i/* -1 x) + x)) + (def: (signum x) + (cond (i/= +0 x) +0 + (i/< +0 x) -1 + ## else + +1)) + ) + +(do-template [<name> <compose> <identity>] + [(structure: #export <name> (Monoid Int) + (def: identity <identity>) + (def: compose <compose>))] + + [addition i/+ +0] + [multiplication i/* +1] + [maximum i/max (:: ..interval bottom)] + [minimum i/min (:: ..interval top)] + ) + +(def: (int/sign!! value) + (-> Int Text) + (if (i/< +0 value) + "-" + "+")) + +(def: (int/sign?? representation) + (-> Text (Maybe Int)) + (case ("lux text char" representation 0) + (^ (char "-")) + (#.Some -1) + + (^ (char "+")) + (#.Some +1) + + _ + #.None)) + +(def: (int-decode-loop input-size repr sign <base> <to-value> <error>) + (-> Nat Text Int Int (-> Char (Maybe Nat)) Text (Error Int)) + (loop [idx 1 + output +0] + (if (n/< input-size idx) + (case (<to-value> ("lux text char" repr idx)) + #.None + (#error.Failure <error>) + + (#.Some digit-value) + (recur (inc idx) + (|> output (i/* <base>) (i/+ (.int digit-value))))) + (#error.Success (i/* sign output))))) + +(do-template [<struct> <base> <to-character> <to-value> <error>] + [(structure: #export <struct> (Codec Text Int) + (def: (encode value) + (if (i/= +0 value) + "+0" + (loop [input (|> value (i// <base>) (:: ..number abs)) + output (|> value (i/% <base>) (:: ..number abs) .nat + <to-character> + maybe.assume)] + (if (i/= +0 input) + ("lux text concat" (int/sign!! value) output) + (let [digit (maybe.assume (<to-character> (.nat (i/% <base> input))))] + (recur (i// <base> input) + ("lux text concat" digit output))))))) + + (def: (decode repr) + (let [input-size ("lux text size" repr)] + (if (n/> 1 input-size) + (case (int/sign?? repr) + (#.Some sign) + (int-decode-loop input-size repr sign <base> <to-value> <error>) + + #.None + (#error.Failure <error>)) + (#error.Failure <error>)))))] + + [binary +2 nat.binary-character nat.binary-value "Invalid binary syntax for Int: "] + [octal +8 nat.octal-character nat.octal-value "Invalid octal syntax for Int: "] + [decimal +10 nat.decimal-character nat.decimal-value "Invalid syntax for Int: "] + [hex +16 nat.hexadecimal-character nat.hexadecimal-value "Invalid hexadecimal syntax for Int: "] + ) + +(structure: #export hash (Hash Int) + (def: &equivalence ..equivalence) + (def: hash .nat)) diff --git a/stdlib/source/lux/data/number/nat.lux b/stdlib/source/lux/data/number/nat.lux new file mode 100644 index 000000000..9e249b207 --- /dev/null +++ b/stdlib/source/lux/data/number/nat.lux @@ -0,0 +1,211 @@ +(.module: + [lux #* + [control + [hash (#+ Hash)] + [number (#+ Number)] + [enum (#+ Enum)] + [interval (#+ Interval)] + [monoid (#+ Monoid)] + [equivalence (#+ Equivalence)] + [codec (#+ Codec)] + ["." order (#+ Order)]] + [data + ["." error (#+ Error)] + ["." maybe] + ["." text (#+ Char)]] + ["." function]]) + +(structure: #export equivalence (Equivalence Nat) + (def: = n/=)) + +(structure: #export order (Order Nat) + (def: &equivalence ..equivalence) + (def: < n/<) + (def: <= n/<=) + (def: > n/>) + (def: >= n/>=)) + +(structure: #export enum (Enum Nat) + (def: &order ..order) + (def: succ inc) + (def: pred dec)) + +(structure: #export interval (Interval Nat) + (def: &enum ..enum) + (def: top (.nat -1)) + (def: bottom 0)) + +(structure: #export number (Number Nat) + (def: + n/+) + (def: - n/-) + (def: * n/*) + (def: / n//) + (def: % n/%) + (def: (negate value) (n/- (:: ..interval top) value)) + (def: abs function.identity) + (def: (signum x) + (case x + 0 0 + _ 1)) + ) + +(do-template [<name> <compose> <identity>] + [(structure: #export <name> (Monoid Nat) + (def: identity <identity>) + (def: compose <compose>))] + + [addition n/+ 0] + [multiplication n/* 1] + [maximum n/max (:: ..interval bottom)] + [minimum n/min (:: ..interval top)] + ) + +(def: #export (binary-character value) + (-> Nat (Maybe Text)) + (case value + 0 (#.Some "0") + 1 (#.Some "1") + _ #.None)) + +(def: #export (binary-value digit) + (-> Char (Maybe Nat)) + (case digit + (^ (char "0")) (#.Some 0) + (^ (char "1")) (#.Some 1) + _ #.None)) + +(def: #export (octal-character value) + (-> Nat (Maybe Text)) + (case value + 0 (#.Some "0") + 1 (#.Some "1") + 2 (#.Some "2") + 3 (#.Some "3") + 4 (#.Some "4") + 5 (#.Some "5") + 6 (#.Some "6") + 7 (#.Some "7") + _ #.None)) + +(def: #export (octal-value digit) + (-> Char (Maybe Nat)) + (case digit + (^ (char "0")) (#.Some 0) + (^ (char "1")) (#.Some 1) + (^ (char "2")) (#.Some 2) + (^ (char "3")) (#.Some 3) + (^ (char "4")) (#.Some 4) + (^ (char "5")) (#.Some 5) + (^ (char "6")) (#.Some 6) + (^ (char "7")) (#.Some 7) + _ #.None)) + +(def: #export (decimal-character value) + (-> Nat (Maybe Text)) + (case value + 0 (#.Some "0") + 1 (#.Some "1") + 2 (#.Some "2") + 3 (#.Some "3") + 4 (#.Some "4") + 5 (#.Some "5") + 6 (#.Some "6") + 7 (#.Some "7") + 8 (#.Some "8") + 9 (#.Some "9") + _ #.None)) + +(def: #export (decimal-value digit) + (-> Char (Maybe Nat)) + (case digit + (^ (char "0")) (#.Some 0) + (^ (char "1")) (#.Some 1) + (^ (char "2")) (#.Some 2) + (^ (char "3")) (#.Some 3) + (^ (char "4")) (#.Some 4) + (^ (char "5")) (#.Some 5) + (^ (char "6")) (#.Some 6) + (^ (char "7")) (#.Some 7) + (^ (char "8")) (#.Some 8) + (^ (char "9")) (#.Some 9) + _ #.None)) + +(def: #export (hexadecimal-character value) + (-> Nat (Maybe Text)) + (case value + 0 (#.Some "0") + 1 (#.Some "1") + 2 (#.Some "2") + 3 (#.Some "3") + 4 (#.Some "4") + 5 (#.Some "5") + 6 (#.Some "6") + 7 (#.Some "7") + 8 (#.Some "8") + 9 (#.Some "9") + 10 (#.Some "A") + 11 (#.Some "B") + 12 (#.Some "C") + 13 (#.Some "D") + 14 (#.Some "E") + 15 (#.Some "F") + _ #.None)) + +(def: #export (hexadecimal-value digit) + (-> Char (Maybe Nat)) + (case digit + (^ (char "0")) (#.Some 0) + (^ (char "1")) (#.Some 1) + (^ (char "2")) (#.Some 2) + (^ (char "3")) (#.Some 3) + (^ (char "4")) (#.Some 4) + (^ (char "5")) (#.Some 5) + (^ (char "6")) (#.Some 6) + (^ (char "7")) (#.Some 7) + (^ (char "8")) (#.Some 8) + (^ (char "9")) (#.Some 9) + (^or (^ (char "a")) (^ (char "A"))) (#.Some 10) + (^or (^ (char "b")) (^ (char "B"))) (#.Some 11) + (^or (^ (char "c")) (^ (char "C"))) (#.Some 12) + (^or (^ (char "d")) (^ (char "D"))) (#.Some 13) + (^or (^ (char "e")) (^ (char "E"))) (#.Some 14) + (^or (^ (char "f")) (^ (char "F"))) (#.Some 15) + _ #.None)) + +(do-template [<struct> <base> <to-character> <to-value> <error>] + [(structure: #export <struct> (Codec Text Nat) + (def: (encode value) + (loop [input value + output ""] + (let [digit (maybe.assume (<to-character> (n/% <base> input))) + output' ("lux text concat" digit output) + input' (n// <base> input)] + (if (n/= 0 input') + output' + (recur input' output'))))) + + (def: (decode repr) + (let [input-size ("lux text size" repr)] + (if (n/> 0 input-size) + (loop [idx 0 + output 0] + (if (n/< input-size idx) + (case (<to-value> ("lux text char" repr idx)) + #.None + (#error.Failure ("lux text concat" <error> repr)) + + (#.Some digit-value) + (recur (inc idx) + (|> output (n/* <base>) (n/+ digit-value)))) + (#error.Success output))) + (#error.Failure ("lux text concat" <error> repr))))))] + + [binary 2 binary-character binary-value "Invalid binary syntax for Nat: "] + [octal 8 octal-character octal-value "Invalid octal syntax for Nat: "] + [decimal 10 decimal-character decimal-value "Invalid syntax for Nat: "] + [hex 16 hexadecimal-character hexadecimal-value "Invalid hexadecimal syntax for Nat: "] + ) + +(structure: #export hash (Hash Nat) + (def: &equivalence ..equivalence) + (def: hash function.identity)) diff --git a/stdlib/source/lux/data/number/ratio.lux b/stdlib/source/lux/data/number/ratio.lux index 1447040e6..773baef15 100644 --- a/stdlib/source/lux/data/number/ratio.lux +++ b/stdlib/source/lux/data/number/ratio.lux @@ -1,4 +1,4 @@ -(.module: {#.doc "Rational arithmetic."} +(.module: {#.doc "Rational numbers."} [lux #* [control [equivalence (#+ Equivalence)] @@ -11,14 +11,15 @@ ["." error] ["." product] ["." maybe] - [number ("nat/." Codec<Text,Nat>)] - ["." text ("text/." Monoid<Text>) + [number + [nat ("nat/." decimal)]] + ["." text ("text/." monoid) format]] ["." function] ["." math] ["." macro ["." code] - ["s" syntax (#+ syntax: Syntax)]]]) + ["s" syntax (#+ Syntax syntax:)]]]) (type: #export Ratio {#numerator Nat @@ -103,17 +104,17 @@ [max >] ) -(structure: #export _ (Equivalence Ratio) +(structure: #export equivalence (Equivalence Ratio) (def: = ..=)) -(structure: #export _ (Order Ratio) - (def: eq Equivalence<Ratio>) +(structure: #export order (Order Ratio) + (def: &equivalence ..equivalence) (def: < ..<) (def: <= ..<=) (def: > ..>) (def: >= ..>=)) -(structure: #export _ (Number Ratio) +(structure: #export number (Number Ratio) (def: + ..+) (def: - ..-) (def: * ..*) @@ -133,14 +134,14 @@ (-> Nat Text) (|>> nat/encode (text.split 1) maybe.assume product.right)) -(structure: #export _ (Codec Text Ratio) +(structure: #export codec (Codec Text Ratio) (def: (encode (^slots [#numerator #denominator])) ($_ text/compose (part-encode numerator) separator (part-encode denominator))) (def: (decode input) (case (text.split-with separator input) (#.Some [num denom]) - (do error.Monad<Error> + (do error.monad [numerator (nat/decode num) denominator (nat/decode denom)] (wrap (normalize {#numerator numerator diff --git a/stdlib/source/lux/data/number/rev.lux b/stdlib/source/lux/data/number/rev.lux new file mode 100644 index 000000000..dbfb5a93a --- /dev/null +++ b/stdlib/source/lux/data/number/rev.lux @@ -0,0 +1,291 @@ +(.module: + [lux #* + [control + [hash (#+ Hash)] + [number (#+ Number)] + [enum (#+ Enum)] + [interval (#+ Interval)] + [monoid (#+ Monoid)] + [equivalence (#+ Equivalence)] + ["." order (#+ Order)] + [codec (#+ Codec)]] + [data + ["." error (#+ Error)] + ["." maybe] + [collection + ["." array (#+ Array)]]] + ["." function]] + [// + ["//." i64] + ["//." nat] + ["//." int]]) + +(structure: #export equivalence (Equivalence Rev) + (def: = r/=)) + +(structure: #export order (Order Rev) + (def: &equivalence ..equivalence) + (def: < r/<) + (def: <= r/<=) + (def: > r/>) + (def: >= r/>=)) + +(structure: #export enum (Enum Rev) + (def: &order ..order) + (def: succ inc) + (def: pred dec)) + +(structure: #export interval (Interval Rev) + (def: &enum ..enum) + (def: top (.rev -1)) + (def: bottom (.rev 0))) + +(structure: #export number (Number Rev) + (def: + r/+) + (def: - r/-) + (def: * r/*) + (def: / r//) + (def: % r/%) + (def: (negate x) (r/- x (:coerce Rev -1))) + (def: abs function.identity) + (def: (signum x) + (:coerce Rev -1))) + +(do-template [<name> <compose> <identity>] + [(structure: #export <name> (Monoid Rev) + (def: identity <identity>) + (def: compose <compose>))] + + [addition r/+ (:: interval bottom)] + [multiplication r/* (:: interval top)] + [maximum r/max (:: interval bottom)] + [minimum r/min (:: interval top)] + ) + +(def: (de-prefix input) + (-> Text Text) + ("lux text clip" input 1 ("lux text size" input))) + +(do-template [<struct> <nat> <char-bit-size> <error>] + [(with-expansions [<error-output> (as-is (#error.Failure ("lux text concat" <error> repr)))] + (structure: #export <struct> (Codec Text Rev) + (def: (encode value) + (let [raw-output (de-prefix (:: <nat> encode (:coerce Nat value))) + max-num-chars (n// <char-bit-size> 64) + raw-size ("lux text size" raw-output) + zero-padding (loop [zeroes-left (n/- raw-size max-num-chars) + output ""] + (if (n/= 0 zeroes-left) + output + (recur (dec zeroes-left) + ("lux text concat" "0" output)))) + padded-output ("lux text concat" zero-padding raw-output)] + ("lux text concat" "." padded-output))) + + (def: (decode repr) + (let [repr-size ("lux text size" repr)] + (if (n/>= 2 repr-size) + (case ("lux text char" repr 0) + (^ (char ".")) + (case (:: <nat> decode (de-prefix repr)) + (#error.Success output) + (#error.Success (:coerce Rev output)) + + _ + <error-output>) + + _ + <error-output>) + <error-output>)))))] + + [binary //nat.binary 1 "Invalid binary syntax: "] + [octal //nat.octal 3 "Invalid octal syntax: "] + [hex //nat.hex 4 "Invalid hexadecimal syntax: "] + ) + +## The following code allows one to encode/decode Rev numbers as text. +## This is not a simple algorithm, and it requires subverting the Rev +## abstraction a bit. +## It takes into account the fact that Rev numbers are represented by +## Lux as 64-bit integers. +## A valid way to model them is as Lux's Nat type. +## This is a somewhat hackish way to do things, but it allows one to +## write the encoding/decoding algorithm once, in pure Lux, rather +## than having to implement it on the compiler for every platform +## targeted by Lux. +(type: Digits (Array Nat)) + +(def: (make-digits _) + (-> Any Digits) + (array.new //i64.width)) + +(def: (digits-get idx digits) + (-> Nat Digits Nat) + (|> digits (array.read idx) (maybe.default 0))) + +(def: digits-put + (-> Nat Nat Digits Digits) + array.write) + +(def: (prepend left right) + (-> Text Text Text) + ("lux text concat" left right)) + +(def: (digits-times-5! idx output) + (-> Nat Digits Digits) + (loop [idx idx + carry 0 + output output] + (if (i/>= +0 (.int idx)) + (let [raw (|> (digits-get idx output) + (n/* 5) + (n/+ carry))] + (recur (dec idx) + (n// 10 raw) + (digits-put idx (n/% 10 raw) output))) + output))) + +(def: (digits-power power) + (-> Nat Digits) + (loop [times power + output (|> (make-digits []) + (digits-put power 1))] + (if (i/>= +0 (.int times)) + (recur (dec times) + (digits-times-5! power output)) + output))) + +(def: (digits-to-text digits) + (-> Digits Text) + (loop [idx (dec //i64.width) + all-zeroes? #1 + output ""] + (if (i/>= +0 (.int idx)) + (let [digit (digits-get idx digits)] + (if (and (n/= 0 digit) + all-zeroes?) + (recur (dec idx) #1 output) + (recur (dec idx) + #0 + ("lux text concat" + (:: //int.decimal encode (.int digit)) + output)))) + (if all-zeroes? + "0" + output)))) + +(def: (digits-add param subject) + (-> Digits Digits Digits) + (loop [idx (dec //i64.width) + carry 0 + output (make-digits [])] + (if (i/>= +0 (.int idx)) + (let [raw ($_ n/+ + carry + (digits-get idx param) + (digits-get idx subject))] + (recur (dec idx) + (n// 10 raw) + (digits-put idx (n/% 10 raw) output))) + output))) + +(def: (text-to-digits input) + (-> Text (Maybe Digits)) + (let [length ("lux text size" input)] + (if (n/<= //i64.width length) + (loop [idx 0 + output (make-digits [])] + (if (n/< length idx) + (case ("lux text index" "+0123456789" ("lux text clip" input idx (inc idx)) 0) + #.None + #.None + + (#.Some digit) + (recur (inc idx) + (digits-put idx digit output))) + (#.Some output))) + #.None))) + +(def: (digits-lt param subject) + (-> Digits Digits Bit) + (loop [idx 0] + (and (n/< //i64.width idx) + (let [pd (digits-get idx param) + sd (digits-get idx subject)] + (if (n/= pd sd) + (recur (inc idx)) + (n/< pd sd)))))) + +(def: (digits-sub-once! idx param subject) + (-> Nat Nat Digits Digits) + (let [sd (digits-get idx subject)] + (if (n/>= param sd) + (digits-put idx (n/- param sd) subject) + (let [diff (|> sd + (n/+ 10) + (n/- param))] + (|> subject + (digits-put idx diff) + (digits-sub-once! (dec idx) 1)))))) + +(def: (digits-sub! param subject) + (-> Digits Digits Digits) + (loop [idx (dec //i64.width) + output subject] + (if (i/>= +0 (.int idx)) + (recur (dec idx) + (digits-sub-once! idx (digits-get idx param) output)) + output))) + +(structure: #export decimal (Codec Text Rev) + (def: (encode input) + (let [input (:coerce Nat input) + last-idx (dec //i64.width)] + (if (n/= 0 input) + ".0" + (loop [idx last-idx + digits (make-digits [])] + (if (i/>= +0 (.int idx)) + (if (//i64.set? idx input) + (let [digits' (digits-add (digits-power (n/- idx last-idx)) + digits)] + (recur (dec idx) + digits')) + (recur (dec idx) + digits)) + ("lux text concat" "." (digits-to-text digits)) + ))))) + + (def: (decode input) + (let [length ("lux text size" input) + dotted? (case ("lux text index" input "." 0) + (#.Some 0) + #1 + + _ + #0)] + (if (and dotted? + (n/<= (inc //i64.width) length)) + (case (text-to-digits ("lux text clip" input 1 length)) + (#.Some digits) + (loop [digits digits + idx 0 + output 0] + (if (n/< //i64.width idx) + (let [power (digits-power idx)] + (if (digits-lt power digits) + ## Skip power + (recur digits (inc idx) output) + (recur (digits-sub! power digits) + (inc idx) + (//i64.set (n/- idx (dec //i64.width)) output)))) + (#error.Success (:coerce Rev output)))) + + #.None + (#error.Failure ("lux text concat" "Wrong syntax for Rev: " input))) + (#error.Failure ("lux text concat" "Wrong syntax for Rev: " input)))) + )) + +(structure: #export hash (Hash Rev) + (def: &equivalence ..equivalence) + (def: hash .nat)) diff --git a/stdlib/source/lux/data/store.lux b/stdlib/source/lux/data/store.lux index 4cacb8329..69ad7d734 100644 --- a/stdlib/source/lux/data/store.lux +++ b/stdlib/source/lux/data/store.lux @@ -1,7 +1,7 @@ (.module: [lux #* [control - ["F" functor] + [functor (#+ Functor)] comonad] [type implicit]]) @@ -15,14 +15,14 @@ {#cursor (get@ #cursor wa) #peek (function (_ s) (f (set@ #cursor s wa)))}) -(structure: #export Functor<Store> (All [s] (F.Functor (Store s))) +(structure: #export functor (All [s] (Functor (Store s))) (def: (map f fa) (extend (function (_ store) (f (:: store peek (:: store cursor)))) fa))) -(structure: #export CoMonad<Store> (All [s] (CoMonad (Store s))) - (def: functor Functor<Store>) +(structure: #export comonad (All [s] (CoMonad (Store s))) + (def: &functor ..functor) (def: (unwrap wa) (::: peek (::: cursor))) @@ -41,5 +41,5 @@ (|> store (::: split) (peeks change))) (def: #export (experiment Functor<f> change store) - (All [f s a] (-> (F.Functor f) (-> s (f s)) (Store s a) (f a))) + (All [f s a] (-> (Functor f) (-> s (f s)) (Store s a) (f a))) (:: Functor<f> map (::: peek) (change (::: cursor)))) diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux index 777c7da22..921e7c96c 100644 --- a/stdlib/source/lux/data/text.lux +++ b/stdlib/source/lux/data/text.lux @@ -12,7 +12,7 @@ [number ["." i64]] [collection - ["." list ("list/." Fold<List>)]]] + ["." list ("list/." fold)]]] [platform [compiler ["." host]]]]) @@ -135,7 +135,7 @@ (def: #export (split-with token sample) (-> Text Text (Maybe [Text Text])) - (do maybe.Monad<Maybe> + (do maybe.monad [index (index-of token sample) [pre post'] (split index sample) [_ post] (split (size token) post')] @@ -156,7 +156,7 @@ (def: #export (replace-once pattern value template) (-> Text Text Text Text) (<| (maybe.default template) - (do maybe.Monad<Maybe> + (do maybe.monad [[pre post] (split-with pattern template)] (wrap ($_ "lux text concat" pre value post))))) @@ -169,12 +169,12 @@ #.None template)) -(structure: #export _ (Equivalence Text) +(structure: #export equivalence (Equivalence Text) (def: (= test subject) ("lux text =" subject test))) -(structure: #export _ (Order Text) - (def: eq Equivalence<Text>) +(structure: #export order (Order Text) + (def: &equivalence ..equivalence) (def: (< test subject) ("lux text <" subject test)) @@ -191,13 +191,14 @@ ("lux text =" test subject))) ) -(structure: #export _ (Monoid Text) +(structure: #export monoid (Monoid Text) (def: identity "") + (def: (compose left right) ("lux text concat" left right))) -(structure: #export _ (Hash Text) - (def: eq Equivalence<Text>) +(structure: #export hash (Hash Text) + (def: &equivalence ..equivalence) (def: (hash input) (`` (for {(~~ (static host.jvm)) @@ -220,7 +221,7 @@ (def: #export concat (-> (List Text) Text) - (let [(^open ".") Monoid<Text>] + (let [(^open ".") ..monoid] (|>> list.reverse (list/fold compose identity)))) (def: #export (join-with sep texts) @@ -236,7 +237,7 @@ (def: #export (enclose [left right] content) {#.doc "Surrounds the given content text with left and right side additions."} (-> [Text Text] Text Text) - (let [(^open ".") Monoid<Text>] + (let [(^open ".") ..monoid] ($_ "lux text concat" left content right))) (def: #export (enclose' boundary content) diff --git a/stdlib/source/lux/data/text/buffer.lux b/stdlib/source/lux/data/text/buffer.lux index 02b0001d0..9534f1e3e 100644 --- a/stdlib/source/lux/data/text/buffer.lux +++ b/stdlib/source/lux/data/text/buffer.lux @@ -5,7 +5,7 @@ [text format] [collection - ["." row (#+ Row) ("row/." Fold<Row>)]]] + ["." row (#+ Row) ("row/." fold)]]] [compiler ["_" host]] [type diff --git a/stdlib/source/lux/data/text/format.lux b/stdlib/source/lux/data/text/format.lux index 234a639f2..ca0c7b151 100644 --- a/stdlib/source/lux/data/text/format.lux +++ b/stdlib/source/lux/data/text/format.lux @@ -6,13 +6,17 @@ [data ["." bit] ["." name] - ["." number] + [number + ["." nat] + ["." int] + ["." rev] + ["." frac]] ["." text] [format ["." xml] ["." json]] [collection - [list ("list/." Monad<List>)]]] + [list ("list/." monad)]]] [time ["." instant] ["." duration] @@ -40,22 +44,22 @@ (Format <type>) <formatter>)] - [%b Bit (:: bit.Codec<Text,Bit> encode)] - [%n Nat (:: number.Codec<Text,Nat> encode)] - [%i Int (:: number.Codec<Text,Int> encode)] - [%r Rev (:: number.Codec<Text,Rev> encode)] - [%f Frac (:: number.Codec<Text,Frac> encode)] + [%b Bit (:: bit.codec encode)] + [%n Nat (:: nat.decimal encode)] + [%i Int (:: int.decimal encode)] + [%r Rev (:: rev.decimal encode)] + [%f Frac (:: frac.decimal encode)] [%t Text text.encode] - [%name Name (:: name.Codec<Text,Name> encode)] + [%name Name (:: name.codec encode)] [%code Code code.to-text] [%type Type type.to-text] - [%bin Nat (:: number.Binary@Codec<Text,Nat> encode)] - [%oct Nat (:: number.Octal@Codec<Text,Nat> encode)] - [%hex Nat (:: number.Hex@Codec<Text,Nat> encode)] - [%xml xml.XML (:: xml.Codec<Text,XML> encode)] - [%json json.JSON (:: json.Codec<Text,JSON> encode)] + [%bin Nat (:: nat.binary encode)] + [%oct Nat (:: nat.octal encode)] + [%hex Nat (:: nat.hex encode)] + [%xml xml.XML (:: xml.codec encode)] + [%json json.JSON (:: json.codec encode)] [%instant instant.Instant instant.to-text] - [%date date.Date (:: date.Codec<Text,Date> encode)] + [%date date.Date (:: date.codec encode)] ) (def: #export %duration @@ -71,7 +75,7 @@ (def: #export (%mod modular) (All [m] (Format (modular.Mod m))) (let [[_ modulus] (modular.un-mod modular)] - (:: (modular.Codec<Text,Mod> modulus) encode modular))) + (:: (modular.codec modulus) encode modular))) (def: #export (%list formatter) (All [a] (-> (Format a) (Format (List a)))) diff --git a/stdlib/source/lux/data/text/lexer.lux b/stdlib/source/lux/data/text/lexer.lux index 9ecbb99c7..b5b0434e4 100644 --- a/stdlib/source/lux/data/text/lexer.lux +++ b/stdlib/source/lux/data/text/lexer.lux @@ -8,12 +8,13 @@ ["." product] ["." maybe] ["." error (#+ Error)] - [number ("nat/." Codec<Text,Nat>)] + [number + [nat ("nat/." decimal)]] [collection - ["." list ("list/." Fold<List>)]]] + ["." list ("list/." fold)]]] [macro ["." code]]] - ["." // ("text/." Monoid<Text>)]) + ["." // ("text/." monoid)]) (type: #export Offset Nat) @@ -55,7 +56,7 @@ (def: (with-slices lexer) (-> (Lexer (List Slice)) (Lexer Slice)) - (do p.Monad<Parser> + (do p.monad [offset ..offset slices lexer] (wrap (list/fold (function (_ [slice::basis slice::distance] @@ -160,7 +161,7 @@ (def: #export (range bottom top) {#.doc "Only lex characters within a range."} (-> Nat Nat (Lexer Text)) - (do p.Monad<Parser> + (do p.monad [char any #let [char' (maybe.assume (//.nth 0 char))] _ (p.assert ($_ text/compose "Character is not within range: " (//.from-code bottom) "-" (//.from-code top)) @@ -262,14 +263,14 @@ (def: #export (and left right) (-> (Lexer Text) (Lexer Text) (Lexer Text)) - (do p.Monad<Parser> + (do p.monad [=left left =right right] (wrap ($_ text/compose =left =right)))) (def: #export (and! left right) (-> (Lexer Slice) (Lexer Slice) (Lexer Slice)) - (do p.Monad<Parser> + (do p.monad [[left::basis left::distance] left [right::basis right::distance] right] (wrap [left::basis ("lux i64 +" left::distance right::distance)]))) @@ -278,7 +279,7 @@ [(def: #export (<name> lexer) {#.doc (code.text ($_ text/compose "Lex " <doc-modifier> " characters as a single continuous text."))} (-> (Lexer Text) (Lexer Text)) - (|> lexer <base> (:: p.Monad<Parser> map //.concat)))] + (|> lexer <base> (:: p.monad map //.concat)))] [some p.some "some"] [many p.many "many"] @@ -298,7 +299,7 @@ [(def: #export (<name> amount lexer) {#.doc (code.text ($_ text/compose "Lex " <doc-modifier> " N characters."))} (-> Nat (Lexer Text) (Lexer Text)) - (|> lexer (<base> amount) (:: p.Monad<Parser> map //.concat)))] + (|> lexer (<base> amount) (:: p.monad map //.concat)))] [exactly p.exactly "exactly"] [at-most p.at-most "at most"] @@ -319,7 +320,7 @@ (def: #export (between from to lexer) {#.doc "Lex between N and M characters."} (-> Nat Nat (Lexer Text) (Lexer Text)) - (|> lexer (p.between from to) (:: p.Monad<Parser> map //.concat))) + (|> lexer (p.between from to) (:: p.monad map //.concat))) (def: #export (between! from to lexer) {#.doc "Lex between N and M characters."} @@ -345,7 +346,7 @@ (def: #export (slice lexer) (-> (Lexer Slice) (Lexer Text)) - (do p.Monad<Parser> + (do p.monad [[basis distance] lexer] (function (_ (^@ input [offset tape])) (case (//.clip basis ("lux i64 +" basis distance) tape) diff --git a/stdlib/source/lux/data/text/regex.lux b/stdlib/source/lux/data/text/regex.lux index 22aa4c87c..9b2abb52e 100644 --- a/stdlib/source/lux/data/text/regex.lux +++ b/stdlib/source/lux/data/text/regex.lux @@ -2,14 +2,14 @@ [lux #* [control monad - ["p" parser ("parser/." Monad<Parser>)]] + ["p" parser ("parser/." monad)]] [data ["." product] ["." error] ["." maybe] - ["." number (#+ hex) ("int/." Codec<Text,Int>)] + ["." number (#+ hex) ("int/." codec)] [collection - ["." list ("list/." Fold<List> Monad<List>)]]] + ["." list ("list/." fold monad)]]] ["." macro (#+ with-gensyms) ["." code] ["s" syntax (#+ syntax:)]]] @@ -24,7 +24,7 @@ (def: escaped-char^ (l.Lexer Text) - (do p.Monad<Parser> + (do p.monad [? (l.this? "\")] (if ? l.any @@ -32,7 +32,7 @@ (def: (refine^ refinement^ base^) (All [a] (-> (l.Lexer a) (l.Lexer Text) (l.Lexer Text))) - (do p.Monad<Parser> + (do p.monad [output base^ _ (l.local output refinement^)] (wrap output))) @@ -48,7 +48,7 @@ (def: (join-text^ part^) (-> (l.Lexer (List Text)) (l.Lexer Text)) - (do p.Monad<Parser> + (do p.monad [parts part^] (wrap (//.join-with "" parts)))) @@ -58,7 +58,7 @@ (def: name-part^ (l.Lexer Text) - (do p.Monad<Parser> + (do p.monad [head (refine^ (l.not l.decimal) name-char^) tail (l.some name-char^)] @@ -74,13 +74,13 @@ (def: (re-var^ current-module) (-> Text (l.Lexer Code)) - (do p.Monad<Parser> + (do p.monad [name (l.enclosed ["\@<" ">"] (name^ current-module))] (wrap (` (: (l.Lexer Text) (~ (code.identifier name))))))) (def: re-range^ (l.Lexer Code) - (do p.Monad<Parser> + (do p.monad [from (|> regex-char^ (:: @ map (|>> (//.nth 0) maybe.assume))) _ (l.this "-") to (|> regex-char^ (:: @ map (|>> (//.nth 0) maybe.assume)))] @@ -88,19 +88,19 @@ (def: re-char^ (l.Lexer Code) - (do p.Monad<Parser> + (do p.monad [char escaped-char^] (wrap (` ((~! ..copy) (~ (code.text char))))))) (def: re-options^ (l.Lexer Code) - (do p.Monad<Parser> + (do p.monad [options (l.many escaped-char^)] (wrap (` (l.one-of (~ (code.text options))))))) (def: re-user-class^' (l.Lexer Code) - (do p.Monad<Parser> + (do p.monad [negate? (p.maybe (l.this "^")) parts (p.many ($_ p.either re-range^ @@ -111,7 +111,7 @@ (def: re-user-class^ (l.Lexer Code) - (do p.Monad<Parser> + (do p.monad [_ (wrap []) init re-user-class^' rest (p.some (p.after (l.this "&&") (l.enclosed ["[" "]"] re-user-class^')))] @@ -149,7 +149,7 @@ (def: re-system-class^ (l.Lexer Code) - (do p.Monad<Parser> + (do p.monad [] ($_ p.either (p.after (l.this ".") (wrap (` l.any))) @@ -184,15 +184,15 @@ (def: number^ (l.Lexer Nat) (|> (l.many l.decimal) - (p.codec number.Codec<Text,Nat>))) + (p.codec number.codec))) (def: re-back-reference^ (l.Lexer Code) - (p.either (do p.Monad<Parser> + (p.either (do p.monad [_ (l.this "\") id number^] (wrap (` ((~! ..copy) (~ (code.identifier ["" (int/encode (.int id))])))))) - (do p.Monad<Parser> + (do p.monad [_ (l.this "\k<") captured-name name-part^ _ (l.this ">")] @@ -209,7 +209,7 @@ (def: (re-simple-quantified^ current-module) (-> Text (l.Lexer Code)) - (do p.Monad<Parser> + (do p.monad [base (re-simple^ current-module) quantifier (l.one-of "?*+")] (case quantifier @@ -226,7 +226,7 @@ (def: (re-counted-quantified^ current-module) (-> Text (l.Lexer Code)) - (do p.Monad<Parser> + (do p.monad [base (re-simple^ current-module)] (l.enclosed ["{" "}"] ($_ p.either @@ -265,7 +265,7 @@ (-> Text (l.Lexer [Re-Group Code])) Text (l.Lexer [Nat Code])) - (do p.Monad<Parser> + (do p.monad [parts (p.many (p.or (re-complex^ current-module) (re-scoped^ current-module))) #let [g!total (code.identifier ["" "0total"]) @@ -279,7 +279,7 @@ [idx names (list& (list g!temp complex - (' #let) (` [(~ g!total) (:: (~! //.Monoid<Text>) (~' compose) (~ g!total) (~ g!temp))])) + (' #let) (` [(~ g!total) (:: (~! //.monoid) (~' compose) (~ g!total) (~ g!temp))])) steps)] (#.Right [(#Capturing [?name num-captures]) scoped]) @@ -295,7 +295,7 @@ [idx! (list& name! names) (list& (list name! scoped - (' #let) (` [(~ g!total) (:: (~! //.Monoid<Text>) (~' compose) (~ g!total) (~ access))])) + (' #let) (` [(~ g!total) (:: (~! //.monoid) (~' compose) (~ g!total) (~ access))])) steps)]) ))) [+0 @@ -305,7 +305,7 @@ (wrap [(if capturing? (list.size names) 0) - (` (do p.Monad<Parser> + (` (do p.monad [(~ (' #let)) [(~ g!total) ""] (~+ (|> steps list.reverse list/join))] ((~ (' wrap)) [(~ g!total) (~+ (list.reverse names))])))]) @@ -313,7 +313,7 @@ (def: (unflatten^ lexer) (-> (l.Lexer Text) (l.Lexer [Text Any])) - (p.and lexer (:: p.Monad<Parser> wrap []))) + (p.and lexer (:: p.monad wrap []))) (def: (|||^ left right) (All [l r] (-> (l.Lexer [Text l]) (l.Lexer [Text r]) (l.Lexer [Text (| l r)]))) @@ -356,7 +356,7 @@ (-> Text (l.Lexer [Re-Group Code])) Text (l.Lexer [Nat Code])) - (do p.Monad<Parser> + (do p.monad [#let [sub^ (re-sequential^ capturing? re-scoped^ current-module)] head sub^ tail (p.some (p.after (l.this "|") sub^)) @@ -374,22 +374,22 @@ (def: (re-scoped^ current-module) (-> Text (l.Lexer [Re-Group Code])) ($_ p.either - (do p.Monad<Parser> + (do p.monad [_ (l.this "(?:") [_ scoped] (re-alternative^ #0 re-scoped^ current-module) _ (l.this ")")] (wrap [#Non-Capturing scoped])) - (do p.Monad<Parser> + (do p.monad [complex (re-complex^ current-module)] (wrap [#Non-Capturing complex])) - (do p.Monad<Parser> + (do p.monad [_ (l.this "(?<") captured-name name-part^ _ (l.this ">") [num-captures pattern] (re-alternative^ #1 re-scoped^ current-module) _ (l.this ")")] (wrap [(#Capturing [(#.Some captured-name) num-captures]) pattern])) - (do p.Monad<Parser> + (do p.monad [_ (l.this "(") [num-captures pattern] (re-alternative^ #1 re-scoped^ current-module) _ (l.this ")")] @@ -397,7 +397,7 @@ (def: (regex^ current-module) (-> Text (l.Lexer Code)) - (:: p.Monad<Parser> map product.right (re-alternative^ #1 re-scoped^ current-module))) + (:: p.monad map product.right (re-alternative^ #1 re-scoped^ current-module))) ## [Syntax] (syntax: #export (regex {pattern s.text}) diff --git a/stdlib/source/lux/data/text/unicode.lux b/stdlib/source/lux/data/text/unicode.lux index 4cc1f66bc..cc783e177 100644 --- a/stdlib/source/lux/data/text/unicode.lux +++ b/stdlib/source/lux/data/text/unicode.lux @@ -4,29 +4,29 @@ ["." interval (#+ Interval)] [monoid (#+ Monoid)]] [data - ["." number (#+ hex) ("nat/." Interval<Nat>)] + [number (#+ hex) + ["." nat ("nat/." interval)]] [collection ["." list] [tree ["." finger (#+ Tree)]]]] [type - abstract]]) - -(type: #export Char Nat) + abstract]] + [// (#+ Char)]) (abstract: #export Segment {} (Interval Char) - (def: empty (:abstraction (interval.between number.Enum<Nat> nat/top nat/bottom))) + (def: empty (:abstraction (interval.between nat.enum nat/top nat/bottom))) - (structure: _ (Monoid Segment) + (structure: monoid (Monoid Segment) (def: identity ..empty) (def: (compose left right) (let [left (:representation left) right (:representation right)] (:abstraction - (interval.between number.Enum<Nat> + (interval.between nat.enum (n/min (:: left bottom) (:: right bottom)) (n/max (:: left top) @@ -34,7 +34,7 @@ (def: #export (segment start end) (-> Char Char Segment) - (:abstraction (interval.between number.Enum<Nat> (n/min start end) (n/max start end)))) + (:abstraction (interval.between nat.enum (n/min start end) (n/max start end)))) (do-template [<name> <slot>] [(def: #export <name> @@ -192,20 +192,20 @@ (def: (singleton segment) (-> Segment Set) - {#finger.monoid Monoid<Segment> + {#finger.monoid ..monoid #finger.node (#finger.Leaf segment [])}) (def: #export (set segments) (-> (List Segment) Set) (case segments (^ (list)) - (..singleton (:: Monoid<Segment> identity)) + (..singleton (:: ..monoid identity)) (^ (list singleton)) (..singleton singleton) (^ (list left right)) - (..singleton (:: Monoid<Segment> compose left right)) + (..singleton (:: ..monoid compose left right)) _ (let [[sides extra] (n//% 2 (list.size segments)) diff --git a/stdlib/source/lux/data/trace.lux b/stdlib/source/lux/data/trace.lux index 36d5acdf0..055d1758c 100644 --- a/stdlib/source/lux/data/trace.lux +++ b/stdlib/source/lux/data/trace.lux @@ -10,12 +10,12 @@ {#monoid (Monoid t) #trace (-> t a)}) -(structure: #export Functor<Trace> (All [t] (Functor (Trace t))) +(structure: #export functor (All [t] (Functor (Trace t))) (def: (map f fa) (update@ #trace (compose f) fa))) -(structure: #export CoMonad<Trace> (All [t] (CoMonad (Trace t))) - (def: functor Functor<Trace>) +(structure: #export comonad (All [t] (CoMonad (Trace t))) + (def: &functor ..functor) (def: (unwrap wa) ((get@ #trace wa) diff --git a/stdlib/source/lux/function.lux b/stdlib/source/lux/function.lux index ca6ebb73e..65202e361 100644 --- a/stdlib/source/lux/function.lux +++ b/stdlib/source/lux/function.lux @@ -34,6 +34,6 @@ (-> (-> a b c) (-> b a c))) (function (_ x y) (f y x))) -(structure: #export Monoid<Function> (All [a] (Monoid (-> a a))) +(structure: #export monoid (All [a] (Monoid (-> a a))) (def: identity ..identity) (def: compose ..compose)) diff --git a/stdlib/source/lux/host.js.lux b/stdlib/source/lux/host.js.lux index 0302064b3..eb6123ef8 100644 --- a/stdlib/source/lux/host.js.lux +++ b/stdlib/source/lux/host.js.lux @@ -5,7 +5,7 @@ ["p" parser]] [data [collection - [list #* ("list/." Fold<List>)]]] + [list #* ("list/." fold)]]] [macro (#+ with-gensyms) ["." code] ["s" syntax (#+ syntax: Syntax)]]]) diff --git a/stdlib/source/lux/host.jvm.lux b/stdlib/source/lux/host.jvm.lux index 6da77945f..7c27c9f63 100644 --- a/stdlib/source/lux/host.jvm.lux +++ b/stdlib/source/lux/host.jvm.lux @@ -8,16 +8,16 @@ ["." maybe] ["." product] ["." error (#+ Error)] - [bit ("bit/." Codec<Text,Bit>)] + [bit ("bit/." codec)] number - ["." text ("text/." Equivalence<Text> Monoid<Text>) + ["." text ("text/." equivalence monoid) format] [collection ["." array (#+ Array)] - ["." list ("list/." Monad<List> Fold<List> Monoid<List>)]]] + ["." list ("list/." monad fold monoid)]]] ["." function] - ["." type ("type/." Equivalence<Type>)] - ["." macro (#+ with-gensyms Functor<Meta> Monad<Meta>) + ["." type ("type/." equivalence)] + ["." macro (#+ with-gensyms) ["." code] ["s" syntax (#+ syntax: Syntax)]] ["." io]]) @@ -25,10 +25,8 @@ (do-template [<name> <op> <from> <to>] [(def: #export (<name> value) {#.doc (doc "Type converter." - "From:" - <from> - "To:" - <to>)} + (: <to> + (<name> (: <from> foo))))} (-> (primitive <from>) (primitive <to>)) (<op> value))] @@ -352,7 +350,7 @@ (def: (get-import name imports) (-> Text Class-Imports (Maybe Text)) - (:: maybe.Functor<Maybe> map product.right + (:: maybe.functor map product.right (list.find (|>> product.left (text/= name)) imports))) @@ -364,7 +362,7 @@ (-> Lux Class-Imports) (case (macro.run compiler (: (Meta Class-Imports) - (do Monad<Meta> + (do macro.monad [current-module macro.current-module-name definitions (macro.definitions current-module)] (wrap (list/fold (: (-> [Text Definition] Class-Imports Class-Imports) @@ -465,7 +463,7 @@ (def: (qualify imports name) (-> Class-Imports Text Text) - (if (list.member? text.Equivalence<Text> java/lang/* name) + (if (list.member? text.equivalence java/lang/* name) (format "java/lang/" name) (maybe.default name (get-import name imports)))) @@ -517,21 +515,21 @@ (def: (make-get-const-parser class-name field-name) (-> Text Text (Syntax Code)) - (do p.Monad<Parser> + (do p.monad [#let [dotted-name (format "::" field-name)] _ (s.this (code.identifier ["" dotted-name]))] (wrap (`' ((~ (code.text (format "jvm getstatic" ":" class-name ":" field-name)))))))) (def: (make-get-var-parser class-name field-name) (-> Text Text (Syntax Code)) - (do p.Monad<Parser> + (do p.monad [#let [dotted-name (format "::" field-name)] _ (s.this (code.identifier ["" dotted-name]))] (wrap (`' ((~ (code.text (format "jvm getfield" ":" class-name ":" field-name))) _jvm_this))))) (def: (make-put-var-parser class-name field-name) (-> Text Text (Syntax Code)) - (do p.Monad<Parser> + (do p.monad [#let [dotted-name (format "::" field-name)] [_ _ value] (: (Syntax [Any Any Code]) (s.form ($_ p.and (s.this (' :=)) (s.this (code.identifier ["" dotted-name])) s.any)))] @@ -577,7 +575,7 @@ (def: (make-constructor-parser params class-name arg-decls) (-> (List Type-Paramameter) Text (List ArgDecl) (Syntax Code)) - (do p.Monad<Parser> + (do p.monad [args (: (Syntax (List Code)) (s.form (p.after (s.this (' ::new!)) (s.tuple (p.exactly (list.size arg-decls) s.any))))) @@ -587,7 +585,7 @@ (def: (make-static-method-parser params class-name method-name arg-decls) (-> (List Type-Paramameter) Text Text (List ArgDecl) (Syntax Code)) - (do p.Monad<Parser> + (do p.monad [#let [dotted-name (format "::" method-name "!")] args (: (Syntax (List Code)) (s.form (p.after (s.this (code.identifier ["" dotted-name])) @@ -599,7 +597,7 @@ (do-template [<name> <jvm-op>] [(def: (<name> params class-name method-name arg-decls) (-> (List Type-Paramameter) Text Text (List ArgDecl) (Syntax Code)) - (do p.Monad<Parser> + (do p.monad [#let [dotted-name (format "::" method-name "!")] args (: (Syntax (List Code)) (s.form (p.after (s.this (code.identifier ["" dotted-name])) @@ -634,13 +632,13 @@ ## Syntaxes (def: (full-class-name^ imports) (-> Class-Imports (Syntax Text)) - (do p.Monad<Parser> + (do p.monad [name s.local-identifier] (wrap (qualify imports name)))) (def: privacy-modifier^ (Syntax PrivacyModifier) - (let [(^open ".") p.Monad<Parser>] + (let [(^open ".") p.monad] ($_ p.or (s.this (' #public)) (s.this (' #private)) @@ -649,7 +647,7 @@ (def: inheritance-modifier^ (Syntax InheritanceModifier) - (let [(^open ".") p.Monad<Parser>] + (let [(^open ".") p.monad] ($_ p.or (s.this (' #final)) (s.this (' #abstract)) @@ -668,21 +666,21 @@ (def: (generic-type^ imports type-vars) (-> Class-Imports (List Type-Paramameter) (Syntax GenericType)) ($_ p.either - (do p.Monad<Parser> + (do p.monad [_ (s.this (' ?))] (wrap (#GenericWildcard #.None))) - (s.tuple (do p.Monad<Parser> + (s.tuple (do p.monad [_ (s.this (' ?)) bound-kind bound-kind^ bound (generic-type^ imports type-vars)] (wrap (#GenericWildcard (#.Some [bound-kind bound]))))) - (do p.Monad<Parser> + (do p.monad [name (full-class-name^ imports) _ (assert-no-periods name)] - (if (list.member? text.Equivalence<Text> (list/map product.left type-vars) name) + (if (list.member? text.equivalence (list/map product.left type-vars) name) (wrap (#GenericTypeVar name)) (wrap (#GenericClass name (list))))) - (s.form (do p.Monad<Parser> + (s.form (do p.monad [name (s.this (' Array)) component (generic-type^ imports type-vars)] (case component @@ -700,21 +698,21 @@ _ (wrap (#GenericArray component))))) - (s.form (do p.Monad<Parser> + (s.form (do p.monad [name (full-class-name^ imports) _ (assert-no-periods name) params (p.some (generic-type^ imports type-vars)) _ (p.assert (format name " cannot be a type-parameter!") - (not (list.member? text.Equivalence<Text> (list/map product.left type-vars) name)))] + (not (list.member? text.equivalence (list/map product.left type-vars) name)))] (wrap (#GenericClass name params)))) )) (def: (type-param^ imports) (-> Class-Imports (Syntax Type-Paramameter)) - (p.either (do p.Monad<Parser> + (p.either (do p.monad [param-name s.local-identifier] (wrap [param-name (list)])) - (s.tuple (do p.Monad<Parser> + (s.tuple (do p.monad [param-name s.local-identifier _ (s.this (' <)) bounds (p.many (generic-type^ imports (list)))] @@ -726,11 +724,11 @@ (def: (class-decl^ imports) (-> Class-Imports (Syntax Class-Declaration)) - (p.either (do p.Monad<Parser> + (p.either (do p.monad [name (full-class-name^ imports) _ (assert-no-periods name)] (wrap [name (list)])) - (s.form (do p.Monad<Parser> + (s.form (do p.monad [name (full-class-name^ imports) _ (assert-no-periods name) params (p.some (type-param^ imports))] @@ -739,11 +737,11 @@ (def: (super-class-decl^ imports type-vars) (-> Class-Imports (List Type-Paramameter) (Syntax Super-Class-Decl)) - (p.either (do p.Monad<Parser> + (p.either (do p.monad [name (full-class-name^ imports) _ (assert-no-periods name)] (wrap [name (list)])) - (s.form (do p.Monad<Parser> + (s.form (do p.monad [name (full-class-name^ imports) _ (assert-no-periods name) params (p.some (generic-type^ imports type-vars))] @@ -755,7 +753,7 @@ (def: (annotation^ imports) (-> Class-Imports (Syntax Annotation)) - (p.either (do p.Monad<Parser> + (p.either (do p.monad [ann-name (full-class-name^ imports)] (wrap [ann-name (list)])) (s.form (p.and (full-class-name^ imports) @@ -763,31 +761,31 @@ (def: (annotations^' imports) (-> Class-Imports (Syntax (List Annotation))) - (do p.Monad<Parser> + (do p.monad [_ (s.this (' #ann))] (s.tuple (p.some (annotation^ imports))))) (def: (annotations^ imports) (-> Class-Imports (Syntax (List Annotation))) - (do p.Monad<Parser> + (do p.monad [anns?? (p.maybe (annotations^' imports))] (wrap (maybe.default (list) anns??)))) (def: (throws-decl'^ imports type-vars) (-> Class-Imports (List Type-Paramameter) (Syntax (List GenericType))) - (do p.Monad<Parser> + (do p.monad [_ (s.this (' #throws))] (s.tuple (p.some (generic-type^ imports type-vars))))) (def: (throws-decl^ imports type-vars) (-> Class-Imports (List Type-Paramameter) (Syntax (List GenericType))) - (do p.Monad<Parser> + (do p.monad [exs? (p.maybe (throws-decl'^ imports type-vars))] (wrap (maybe.default (list) exs?)))) (def: (method-decl^ imports type-vars) (-> Class-Imports (List Type-Paramameter) (Syntax [Member-Declaration MethodDecl])) - (s.form (do p.Monad<Parser> + (s.form (do p.monad [tvars (p.default (list) (type-params^ imports)) name s.local-identifier anns (annotations^ imports) @@ -804,18 +802,18 @@ ($_ p.or (s.this (' #volatile)) (s.this (' #final)) - (:: p.Monad<Parser> wrap []))) + (:: p.monad wrap []))) (def: (field-decl^ imports type-vars) (-> Class-Imports (List Type-Paramameter) (Syntax [Member-Declaration FieldDecl])) - (p.either (s.form (do p.Monad<Parser> + (p.either (s.form (do p.monad [_ (s.this (' #const)) name s.local-identifier anns (annotations^ imports) type (generic-type^ imports type-vars) body s.any] (wrap [[name #PublicPM anns] (#ConstantField [type body])]))) - (s.form (do p.Monad<Parser> + (s.form (do p.monad [pm privacy-modifier^ sm state-modifier^ name s.local-identifier @@ -842,7 +840,7 @@ (def: (constructor-method^ imports class-vars) (-> Class-Imports (List Type-Paramameter) (Syntax [Member-Declaration Method-Definition])) - (s.form (do p.Monad<Parser> + (s.form (do p.monad [pm privacy-modifier^ strict-fp? (s.this? (' #strict)) method-vars (p.default (list) (type-params^ imports)) @@ -860,7 +858,7 @@ (def: (virtual-method-def^ imports class-vars) (-> Class-Imports (List Type-Paramameter) (Syntax [Member-Declaration Method-Definition])) - (s.form (do p.Monad<Parser> + (s.form (do p.monad [pm privacy-modifier^ strict-fp? (s.this? (' #strict)) final? (s.this? (' #final)) @@ -879,7 +877,7 @@ (def: (overriden-method-def^ imports) (-> Class-Imports (Syntax [Member-Declaration Method-Definition])) - (s.form (do p.Monad<Parser> + (s.form (do p.monad [strict-fp? (s.this? (' #strict)) owner-class (class-decl^ imports) method-vars (p.default (list) (type-params^ imports)) @@ -897,7 +895,7 @@ (def: (static-method-def^ imports) (-> Class-Imports (Syntax [Member-Declaration Method-Definition])) - (s.form (do p.Monad<Parser> + (s.form (do p.monad [pm privacy-modifier^ strict-fp? (s.this? (' #strict)) _ (s.this (' #static)) @@ -916,7 +914,7 @@ (def: (abstract-method-def^ imports) (-> Class-Imports (Syntax [Member-Declaration Method-Definition])) - (s.form (do p.Monad<Parser> + (s.form (do p.monad [pm privacy-modifier^ _ (s.this (' #abstract)) method-vars (p.default (list) (type-params^ imports)) @@ -933,7 +931,7 @@ (def: (native-method-def^ imports) (-> Class-Imports (Syntax [Member-Declaration Method-Definition])) - (s.form (do p.Monad<Parser> + (s.form (do p.monad [pm privacy-modifier^ _ (s.this (' #native)) method-vars (p.default (list) (type-params^ imports)) @@ -964,17 +962,17 @@ (def: class-kind^ (Syntax Class-Kind) - (p.either (do p.Monad<Parser> + (p.either (do p.monad [_ (s.this (' #class))] (wrap #Class)) - (do p.Monad<Parser> + (do p.monad [_ (s.this (' #interface))] (wrap #Interface)) )) (def: import-member-alias^ (Syntax (Maybe Text)) - (p.maybe (do p.Monad<Parser> + (p.maybe (do p.monad [_ (s.this (' #as))] s.local-identifier))) @@ -994,11 +992,11 @@ (def: (import-member-decl^ imports owner-vars) (-> Class-Imports (List Type-Paramameter) (Syntax Import-Member-Declaration)) ($_ p.either - (s.form (do p.Monad<Parser> + (s.form (do p.monad [_ (s.this (' #enum)) enum-members (p.some s.local-identifier)] (wrap (#EnumDecl enum-members)))) - (s.form (do p.Monad<Parser> + (s.form (do p.monad [tvars (p.default (list) (type-params^ imports)) _ (s.this (' new)) ?alias import-member-alias^ @@ -1016,7 +1014,7 @@ #import-member-io? io?} {}])) )) - (s.form (do p.Monad<Parser> + (s.form (do p.monad [kind (: (Syntax ImportMethodKind) (p.or (s.this (' #static)) (wrap []))) @@ -1039,7 +1037,7 @@ {#import-method-name name #import-method-return return }])))) - (s.form (do p.Monad<Parser> + (s.form (do p.monad [static? (s.this? (' #static)) name s.local-identifier ?prim-mode (p.maybe primitive-mode^) @@ -1207,7 +1205,7 @@ (code.to-text (pre-walk-replace replacer body))))) (#OverridenMethod strict-fp? class-decl type-vars arg-decls return-type body exs) - (let [super-replacer (parser->replacer (s.form (do p.Monad<Parser> + (let [super-replacer (parser->replacer (s.form (do p.monad [_ (s.this (' ::super!)) args (s.tuple (p.exactly (list.size arg-decls) s.any)) #let [arg-decls' (: (List Text) (list/map (|>> product.right (simple-class$ (list))) @@ -1324,7 +1322,7 @@ "(::new! []) for calling the class's constructor." "(::resolve! container [value]) for calling the 'resolve' method." )} - (do Monad<Meta> + (do macro.monad [current-module macro.current-module-name #let [fully-qualified-class-name (format (sanitize current-module) "." full-class-name) field-parsers (list/map (field->parser fully-qualified-class-name) fields) @@ -1522,7 +1520,7 @@ (case member (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) (let [(^slots [#import-member-tvars #import-member-args]) commons] - (do Monad<Meta> + (do macro.monad [arg-inputs (monad.map @ (: (-> [Bit GenericType] (Meta [Bit Code])) (function (_ [maybe? _]) @@ -1542,7 +1540,7 @@ (wrap [arg-inputs arg-classes arg-types]))) _ - (:: Monad<Meta> wrap [(list) (list) (list)]))) + (:: macro.monad wrap [(list) (list) (list)]))) (def: (decorate-return-maybe member return-term) (-> Import-Member-Declaration Code Code) @@ -1628,7 +1626,7 @@ (list/map type-param->type-arg))] (case member (#EnumDecl enum-members) - (do Monad<Meta> + (do macro.monad [#let [enum-type (: Code (case class-tvars #.Nil @@ -1648,7 +1646,7 @@ (wrap (list/map getter-interop enum-members))) (#ConstructorDecl [commons _]) - (do Monad<Meta> + (do macro.monad [#let [def-name (code.identifier ["" (format method-prefix member-separator (get@ #import-member-alias commons))]) jvm-extension (code.text (format "jvm new" ":" full-name ":" (text.join-with "," arg-classes))) jvm-interop (|> (` ((~ jvm-extension) @@ -1696,7 +1694,7 @@ ((~' wrap) (.list (.` (~ jvm-interop)))))))))) (#FieldAccessDecl fad) - (do Monad<Meta> + (do macro.monad [#let [(^open ".") fad base-gtype (class->type import-field-mode type-params import-field-type) classC (class-decl-type$ class) @@ -1757,7 +1755,7 @@ method-prefix (if long-name? full-name (short-class-name full-name))] - (do Monad<Meta> + (do macro.monad [=args (member-def-arg-bindings type-params class member)] (member-def-interop type-params kind class =args member method-prefix)))) @@ -1774,7 +1772,7 @@ (let [class-name (sanitize class-name)] (case (load-class class-name) (#.Right class) - (:: Monad<Meta> wrap (if (interface? class) + (:: macro.monad wrap (if (interface? class) #Interface #Class)) @@ -1835,7 +1833,7 @@ (java/util/List::size [] my-list) Character$UnicodeScript::LATIN )} - (do Monad<Meta> + (do macro.monad [kind (class-kind class-decl) =members (monad.map @ (member-import$ (product.right class-decl) long-name? kind class-decl) members)] (wrap (list& (class-import$ long-name? class-decl) (list/join =members))))) @@ -1869,10 +1867,10 @@ (def: (type->class-name type) (-> Type (Meta Text)) (if (type/= Any type) - (:: Monad<Meta> wrap "java.lang.Object") + (:: macro.monad wrap "java.lang.Object") (case type (#.Primitive name params) - (:: Monad<Meta> wrap name) + (:: macro.monad wrap name) (#.Apply A F) (case (type.apply (list A) F) @@ -1893,7 +1891,7 @@ (array-read 10 my-array))} (case array [_ (#.Identifier array-name)] - (do Monad<Meta> + (do macro.monad [array-type (macro.find-type array-name) array-jvm-type (type->class-name array-type)] (case array-jvm-type @@ -1922,7 +1920,7 @@ (array-write 10 my-object my-array))} (case array [_ (#.Identifier array-name)] - (do Monad<Meta> + (do macro.monad [array-type (macro.find-type array-name) array-jvm-type (type->class-name array-type)] (case array-jvm-type @@ -1957,7 +1955,7 @@ "Afterwards, closes all resources (assumed to be subclasses of java.io.Closeable), and returns the value resulting from running the body." (with-open [my-res1 (res1-constructor ___) my-res2 (res1-constructor ___)] - (do io.Monad<IO> + (do io.monad [foo (do-something my-res1) bar (do-something-else my-res2)] (do-one-last-thing foo bar))))} @@ -1968,7 +1966,7 @@ closes (list/map (function (_ res) (` (try ("jvm invokevirtual:java.io.Closeable:close:" (~ (code.identifier ["" (product.left res)])))))) bindings)] - (wrap (list (` (do (~! io.Monad<IO>) + (wrap (list (` (do (~! io.monad) [(~+ inits) (~ g!output) (~ body) (~' #let) [(~ g!_) (exec (~+ (list.reverse closes)) [])]] @@ -1991,7 +1989,7 @@ => "java.lang.String")} (-> Text (Meta Text)) - (do Monad<Meta> + (do macro.monad [*compiler* get-compiler] (wrap (qualify (class-imports *compiler*) class)))) diff --git a/stdlib/source/lux/host/jvm/attribute.lux b/stdlib/source/lux/host/jvm/attribute.lux index 41928e704..9008dd658 100644 --- a/stdlib/source/lux/host/jvm/attribute.lux +++ b/stdlib/source/lux/host/jvm/attribute.lux @@ -22,13 +22,13 @@ #length U4 #info about}) -(def: #export (Equivalence<Info> Equivalence<about>) +(def: #export (info-equivalence Equivalence<about>) (All [about] (-> (Equivalence about) (Equivalence (Info about)))) ($_ equivalence.product - //index.Equivalence<Index> - //encoding.Equivalence<U4> + //index.equivalence + //encoding.u4-equivalence Equivalence<about>)) (def: (info-format about) @@ -43,9 +43,9 @@ (type: #export Constant (Info (Index (Value Any)))) -(def: #export Equivalence<Constant> +(def: #export constant-equivalence (Equivalence Constant) - (..Equivalence<Info> //index.Equivalence<Index>)) + (..info-equivalence //index.equivalence)) (def: constant-format (Format Constant) @@ -76,14 +76,14 @@ ## <Code>) ) -(def: #export Equivalence<Attribute> +(def: #export equivalence (Equivalence Attribute) - ..Equivalence<Constant>) + ..constant-equivalence) (def: #export (constant index) (-> (Index (Value Any)) (State Pool Attribute)) - (do state.Monad<State> + (do state.monad [@name (//pool.utf8 "ConstantValue")] (wrap (#Constant {#name @name #length (//encoding.to-u4 //encoding.u2-bytes) @@ -91,7 +91,7 @@ ## (def: #export (code specification) ## (-> Code' (State Pool Attribute)) -## (do state.Monad<State> +## (do state.monad ## [@name (//pool.utf8 "Code")] ## (wrap (#Code {#name @name ## #length (undefined) diff --git a/stdlib/source/lux/host/jvm/class.lux b/stdlib/source/lux/host/jvm/class.lux index 30959c8ef..0c7bfd0da 100644 --- a/stdlib/source/lux/host/jvm/class.lux +++ b/stdlib/source/lux/host/jvm/class.lux @@ -52,27 +52,27 @@ #methods (Row Method) #attributes (Row Attribute)}) -(def: #export Equivalence<Class> +(def: #export equivalence (Equivalence Class) ($_ equivalence.product - //encoding.Equivalence<U4> - //encoding.Equivalence<U2> - //encoding.Equivalence<U2> - //pool.Equivalence<Pool> - ..Equivalence<Modifier> - //index.Equivalence<Index> - //index.Equivalence<Index> - (row.Equivalence<Row> //index.Equivalence<Index>) - (row.Equivalence<Row> //field.Equivalence<Field>) - (row.Equivalence<Row> //method.Equivalence<Method>) - (row.Equivalence<Row> //attribute.Equivalence<Attribute>))) + //encoding.u4-equivalence + //encoding.u2-equivalence + //encoding.u2-equivalence + //pool.equivalence + ..modifier-equivalence + //index.equivalence + //index.equivalence + (row.equivalence //index.equivalence) + (row.equivalence //field.equivalence) + (row.equivalence //method.equivalence) + (row.equivalence //attribute.equivalence))) (def: default-minor-version Minor (//version.version 0)) (def: (install-classes this super interfaces) (-> Internal Internal (List Internal) (State Pool [(Index //constant.Class) (Index //constant.Class) (Row (Index //constant.Class))])) - (do state.Monad<State> + (do state.monad [@this (//pool.class (//name.read this)) @super (//pool.class (//name.read super)) @interfaces (: (State Pool (Row (Index //constant.Class))) @@ -95,9 +95,9 @@ Class) (let [[pool [@this @super @interfaces] =fields] (state.run //pool.empty - (do state.Monad<State> + (do state.monad [classes (install-classes this super interfaces) - =fields (monad.seq state.Monad<State> fields)] + =fields (monad.seq state.monad fields)] (wrap [classes =fields])))] {#magic //magic.code #minor-version ..default-minor-version diff --git a/stdlib/source/lux/host/jvm/constant.lux b/stdlib/source/lux/host/jvm/constant.lux index 7f87136a5..1395e6d5a 100644 --- a/stdlib/source/lux/host/jvm/constant.lux +++ b/stdlib/source/lux/host/jvm/constant.lux @@ -5,10 +5,12 @@ ["." parser] ["." equivalence (#+ Equivalence)]] [data - ["." number] + [number + ["." int] + ["." frac]] ["." text] [format - ["." binary (#+ Format) ("mutation/." Monoid<Mutation>)]] + ["." binary (#+ Format) ("mutation/." monoid)]] [collection ["." row (#+ Row)]]] [type @@ -18,7 +20,7 @@ ["//." index (#+ Index)] [descriptor (#+ Descriptor)]] [/ - ["/." tag ("tag/." Equivalence<Tag>)]]) + ["/." tag ("tag/." equivalence)]]) (type: #export UTF8 Text) @@ -35,11 +37,11 @@ (-> (Index UTF8) Class) (|>> :abstraction)) - (def: #export Equivalence<Class> + (def: #export class-equivalence (Equivalence Class) - (:: equivalence.Contravariant<Equivalence> map-1 + (:: equivalence.contravariant map-1 (|>> :representation) - //index.Equivalence<Index>)) + //index.equivalence)) (def: class-format (Format Class) @@ -58,11 +60,11 @@ (All [kind] (-> (Value kind) kind)) (|>> :representation)) - (def: #export (Equivalence<Value> Equivalence<kind>) + (def: #export (value-equivalence Equivalence<kind>) (All [kind] (-> (Equivalence kind) (Equivalence (Value kind)))) - (:: equivalence.Contravariant<Equivalence> map-1 + (:: equivalence.contravariant map-1 (|>> :representation) Equivalence<kind>)) @@ -88,7 +90,7 @@ <base>))] [long-format Long .int (<|) binary.bits/64] - [double-format Double number.bits-to-frac number.frac-to-bits binary.bits/64] + [double-format Double frac.bits-to-frac frac.frac-to-bits binary.bits/64] [string-format String (<|) (<|) //index.format] ) ) @@ -105,8 +107,8 @@ [(def: #export <equivalence> (Equivalence <type>) ($_ equivalence.product - //index.Equivalence<Index> - //index.Equivalence<Index>)) + //index.equivalence + //index.equivalence)) (def: #export <format> (Format <type>) @@ -114,8 +116,8 @@ //index.format //index.format))] - [Name-And-Type Equivalence<Name-And-Type> name-and-type-format] - [Reference Equivalence<Reference> reference-format] + [Name-And-Type name-and-type-equivalence name-and-type-format] + [Reference reference-equivalence reference-format] ) (type: #export Constant @@ -129,27 +131,27 @@ (#Interface-Method Reference) (#Name-And-Type Name-And-Type)) -(def: #export Equivalence<Constant> +(def: #export equivalence (Equivalence Constant) ($_ equivalence.sum ## #UTF8 - text.Equivalence<Text> + text.equivalence ## #Long - (..Equivalence<Value> number.Equivalence<Int>) + (..value-equivalence int.equivalence) ## #Double - (..Equivalence<Value> number.Equivalence<Frac>) + (..value-equivalence frac.equivalence) ## #Class - ..Equivalence<Class> + ..class-equivalence ## #String - (..Equivalence<Value> //index.Equivalence<Index>) + (..value-equivalence //index.equivalence) ## #Field - ..Equivalence<Reference> + ..reference-equivalence ## #Method - ..Equivalence<Reference> + ..reference-equivalence ## #Interface-Method - ..Equivalence<Reference> + ..reference-equivalence ## #Name-And-Type - ..Equivalence<Name-And-Type> + ..name-and-type-equivalence )) (def: #export format @@ -169,7 +171,7 @@ ## TODO: Method-Type ## TODO: Invoke-Dynamic )] - {#binary.reader (do parser.Monad<Parser> + {#binary.reader (do parser.monad [tag (get@ #binary.reader /tag.format)] (`` (cond (~~ (do-template [<case> <tag> <format>] [(tag/= <tag> tag) diff --git a/stdlib/source/lux/host/jvm/constant/pool.lux b/stdlib/source/lux/host/jvm/constant/pool.lux index d1da6f606..7e3119222 100644 --- a/stdlib/source/lux/host/jvm/constant/pool.lux +++ b/stdlib/source/lux/host/jvm/constant/pool.lux @@ -5,15 +5,15 @@ [monad (#+ do)] ["." state (#+ State)]] [data - [text ("text/." Equivalence<Text>)] + [text ("text/." equivalence)] [format ["." binary (#+ Format)]] [collection - [list ("list/." Fold<List>)] + [list ("list/." fold)] ["." row (#+ Row)]]] [type abstract]] - ["." // (#+ UTF8 Class Constant) ("class/." Equivalence<Class>) + ["." // (#+ UTF8 Class Constant) ("class/." class-equivalence) [// ["." encoding] ["." index (#+ Index)] @@ -23,9 +23,9 @@ (type: #export Pool (Row Constant)) -(def: #export Equivalence<Pool> +(def: #export equivalence (Equivalence Pool) - (row.Equivalence<Row> //.Equivalence<Constant>)) + (row.equivalence //.equivalence)) (template: (!add <value> <tag> <=>) (function (_ pool) @@ -58,7 +58,7 @@ (def: #export (class name) (-> UTF8 (State Pool (Index Class))) - (do state.Monad<State> + (do state.monad [@name (utf8 name)] (class' (//.class @name)))) diff --git a/stdlib/source/lux/host/jvm/constant/tag.lux b/stdlib/source/lux/host/jvm/constant/tag.lux index 8e34d975d..3862f5158 100644 --- a/stdlib/source/lux/host/jvm/constant/tag.lux +++ b/stdlib/source/lux/host/jvm/constant/tag.lux @@ -8,14 +8,14 @@ [type abstract]] [/// - ["." encoding (#+ U1) ("u1/." Equivalence<U1>)]]) + ["." encoding (#+ U1) ("u1/." u1-equivalence)]]) (abstract: #export Tag {} U1 - (structure: #export _ (Equivalence Tag) + (structure: #export equivalence (Equivalence Tag) (def: (= reference sample) (u1/= (:representation reference) (:representation sample)))) diff --git a/stdlib/source/lux/host/jvm/descriptor.lux b/stdlib/source/lux/host/jvm/descriptor.lux index 9b6e4088f..ffa7e566e 100644 --- a/stdlib/source/lux/host/jvm/descriptor.lux +++ b/stdlib/source/lux/host/jvm/descriptor.lux @@ -4,7 +4,7 @@ ["." text format] [collection - [list ("list/." Functor<List>)]]] + [list ("list/." functor)]]] [type abstract]] [// diff --git a/stdlib/source/lux/host/jvm/encoding.lux b/stdlib/source/lux/host/jvm/encoding.lux index 2b2c487ec..ca6875eca 100644 --- a/stdlib/source/lux/host/jvm/encoding.lux +++ b/stdlib/source/lux/host/jvm/encoding.lux @@ -2,7 +2,7 @@ [lux #* [control [equivalence (#+ Equivalence)] - [parser ("parser/." Functor<Parser>)]] + [parser ("parser/." functor)]] [data [number ["." i64]] @@ -11,7 +11,7 @@ [type abstract]]) -(do-template [<bytes> <name> <size> <to> <from>] +(do-template [<bytes> <name> <size> <to> <from> <equivalence>] [(abstract: #export <name> {} @@ -30,14 +30,14 @@ (-> <name> (I64 Any)) (|>> :representation)) - (structure: #export _ (Equivalence <name>) + (structure: #export <equivalence> (Equivalence <name>) (def: (= reference sample) ("lux i64 =" (:representation reference) (:representation sample)))) )] - [1 U1 u1-bytes to-u1 from-u1] - [2 U2 u2-bytes to-u2 from-u2] - [4 U4 u4-bytes to-u4 from-u4] + [1 U1 u1-bytes to-u1 from-u1 u1-equivalence] + [2 U2 u2-bytes to-u2 from-u2 u2-equivalence] + [4 U4 u4-bytes to-u4 from-u4 u4-equivalence] ) (do-template [<name> <type> <format> <pre-write> <post-read>] diff --git a/stdlib/source/lux/host/jvm/field.lux b/stdlib/source/lux/host/jvm/field.lux index 3e1de173a..69e0400ea 100644 --- a/stdlib/source/lux/host/jvm/field.lux +++ b/stdlib/source/lux/host/jvm/field.lux @@ -42,13 +42,13 @@ #descriptor (Index (Descriptor (Value Any))) #attributes (Row Attribute)}) -(def: #export Equivalence<Field> +(def: #export equivalence (Equivalence Field) ($_ equivalence.product - ..Equivalence<Modifier> - //index.Equivalence<Index> - //index.Equivalence<Index> - (row.Equivalence<Row> //attribute.Equivalence<Attribute>))) + ..modifier-equivalence + //index.equivalence + //index.equivalence + (row.equivalence //attribute.equivalence))) (def: #export format (Format Field) @@ -61,7 +61,7 @@ (def: #export (field modifier name descriptor attributes) (-> Modifier UTF8 (Descriptor (Value Any)) (Row Attribute) (State Pool Field)) - (do state.Monad<State> + (do state.monad [@name (//pool.utf8 name) @descriptor (//pool.descriptor descriptor)] (wrap {#modifier modifier diff --git a/stdlib/source/lux/host/jvm/index.lux b/stdlib/source/lux/host/jvm/index.lux index 3bf7e150b..69232edb4 100644 --- a/stdlib/source/lux/host/jvm/index.lux +++ b/stdlib/source/lux/host/jvm/index.lux @@ -19,11 +19,11 @@ (All [kind] (-> U2 (Index kind))) (|>> :abstraction)) - (def: #export Equivalence<Index> + (def: #export equivalence (All [kind] (Equivalence (Index kind))) - (:: equivalence.Contravariant<Equivalence> map-1 + (:: equivalence.contravariant map-1 (|>> :representation) - //encoding.Equivalence<U2>)) + //encoding.u2-equivalence)) (def: #export format (All [kind] (Format (Index kind))) diff --git a/stdlib/source/lux/host/jvm/loader.jvm.lux b/stdlib/source/lux/host/jvm/loader.jvm.lux index b4d5089d4..1a19c2e1e 100644 --- a/stdlib/source/lux/host/jvm/loader.jvm.lux +++ b/stdlib/source/lux/host/jvm/loader.jvm.lux @@ -11,7 +11,7 @@ format] [collection ["." array] - ["." list ("list/." Functor<List>)] + ["." list ("list/." functor)] ["." dictionary (#+ Dictionary)]]] ["." io (#+ IO)] [world @@ -87,7 +87,7 @@ (def: #export (new-library _) (-> Any Library) - (atom.atom (dictionary.new text.Hash<Text>))) + (atom.atom (dictionary.new text.hash))) (def: #export (memory library) (-> Library java/lang/ClassLoader) @@ -110,7 +110,7 @@ (def: #export (store name bytecode library) (-> Text Binary Library (IO (Error Any))) - (do io.Monad<IO> + (do io.monad [library' (atom.read library)] (if (dictionary.contains? name library') (wrap (ex.throw ..already-stored name)) diff --git a/stdlib/source/lux/host/jvm/method.lux b/stdlib/source/lux/host/jvm/method.lux index 7bdc147da..c2342cd03 100644 --- a/stdlib/source/lux/host/jvm/method.lux +++ b/stdlib/source/lux/host/jvm/method.lux @@ -44,13 +44,13 @@ #descriptor (Index (Descriptor //descriptor.Method)) #attributes (Row Attribute)}) -(def: #export Equivalence<Method> +(def: #export equivalence (Equivalence Method) ($_ equivalence.product - ..Equivalence<Modifier> - //index.Equivalence<Index> - //index.Equivalence<Index> - (row.Equivalence<Row> //attribute.Equivalence<Attribute>))) + ..modifier-equivalence + //index.equivalence + //index.equivalence + (row.equivalence //attribute.equivalence))) (def: #export format (Format Method) diff --git a/stdlib/source/lux/host/jvm/modifier.lux b/stdlib/source/lux/host/jvm/modifier.lux index 8451c3107..41d84a59b 100644 --- a/stdlib/source/lux/host/jvm/modifier.lux +++ b/stdlib/source/lux/host/jvm/modifier.lux @@ -10,7 +10,7 @@ [format ["." binary]] [collection - [list ("list/." Functor<List>)]]] + [list ("list/." functor)]]] [type ["." abstract]] [macro (#+ with-gensyms) @@ -56,15 +56,15 @@ (.do-template [(~ g!<code>) (~ g!<name>)] [(.def: (~' #export) (~ g!<name>) (~ g!name) - (.|> (number.hex (~ g!<code>)) //encoding.to-u2 abstract.:abstraction))] + (.|> ((~! number.hex) (~ g!<code>)) //encoding.to-u2 abstract.:abstraction))] ["0000" (~ g!empty)] (~+ (list/map ..code options)) ) - (.structure: (~' #export) (~' _) (equivalence.Equivalence (~ g!name)) + (.structure: (~' #export) (~' modifier-equivalence) (equivalence.Equivalence (~ g!name)) (.def: ((~' =) (~' reference) (~' sample)) - (.:: //encoding.Equivalence<U2> (~' =) + (.:: //encoding.u2-equivalence (~' =) (abstract.:representation (~' reference)) (abstract.:representation (~' sample))))) @@ -72,7 +72,7 @@ (binary.Format (~ g!name)) (.let [(.^open "_/.") //encoding.u2-format] {#binary.reader (|> (~' _/reader) - (:: parser.Functor<Parser> (~' map) + (:: parser.functor (~' map) (|>> abstract.:abstraction))) #binary.writer (|>> abstract.:representation (~' _/writer))})))) diff --git a/stdlib/source/lux/io.lux b/stdlib/source/lux/io.lux index 21d3d8f4a..7fdccda95 100644 --- a/stdlib/source/lux/io.lux +++ b/stdlib/source/lux/io.lux @@ -4,10 +4,7 @@ [control [functor (#+ Functor)] [apply (#+ Apply)] - [monad (#+ do Monad)] - ["ex" exception (#+ Exception)]] - [data - ["." error (#+ Error)]]]) + [monad (#+ do Monad)]]]) (type: #export (IO a) {#.doc "A type that represents synchronous, effectful computations that may interact with the outside world."} @@ -27,18 +24,18 @@ _ (#.Left "Wrong syntax for io"))) -(structure: #export _ (Functor IO) +(structure: #export functor (Functor IO) (def: (map f ma) (io (f (ma (:coerce Nothing [])))))) -(structure: #export _ (Apply IO) - (def: functor Functor<IO>) +(structure: #export apply (Apply IO) + (def: &functor ..functor) (def: (apply ff fa) (io ((ff (:coerce Nothing [])) (fa (:coerce Nothing [])))))) -(structure: #export _ (Monad IO) - (def: functor Functor<IO>) +(structure: #export monad (Monad IO) + (def: &functor ..functor) (def: (wrap x) (io x)) @@ -54,43 +51,3 @@ (def: #export (exit code) (-> Int (IO Nothing)) (io ("lux io exit" code))) - -## Process -(type: #export (Process a) - (IO (Error a))) - -(structure: #export _ (Functor Process) - (def: (map f ma) - (io (:: error.Functor<Error> map f (run ma))))) - -(structure: #export _ (Apply Process) - (def: functor Functor<Process>) - - (def: (apply ff fa) - (io (:: error.Apply<Error> apply (run ff) (run fa))))) - -(structure: #export _ (Monad Process) - (def: functor Functor<Process>) - - (def: (wrap x) - (io (:: error.Monad<Error> wrap x))) - - (def: (join mma) - (case (run mma) - (#error.Success ma) - ma - - (#error.Failure error) - (io (#error.Failure error))))) - -(def: #export from-io - (All [a] (-> (IO a) (Process a))) - (:: Functor<IO> map (|>> #error.Success))) - -(def: #export (fail error) - (All [a] (-> Text (Process a))) - (io (#error.Failure error))) - -(def: #export (throw exception message) - (All [e a] (-> (Exception e) e (Process a))) - (io (ex.throw exception message))) diff --git a/stdlib/source/lux/locale.lux b/stdlib/source/lux/locale.lux index 30d9abcd3..3d0f3e532 100644 --- a/stdlib/source/lux/locale.lux +++ b/stdlib/source/lux/locale.lux @@ -42,14 +42,14 @@ (-> Locale Text) (|>> :representation)) - (structure: #export _ (Equivalence Locale) + (structure: #export equivalence (Equivalence Locale) (def: (= reference sample) - (:: text.Equivalence<Text> = (:representation reference) (:representation sample)))) + (:: text.equivalence = (:representation reference) (:representation sample)))) - (structure: #export _ (Hash Locale) - (def: eq Equivalence<Locale>) + (structure: #export hash (Hash Locale) + (def: &equivalence ..equivalence) (def: hash (|>> :representation - (:: text.Hash<Text> hash)))) + (:: text.hash hash)))) ) diff --git a/stdlib/source/lux/locale/language.lux b/stdlib/source/lux/locale/language.lux index 8c37efaef..57857fcc3 100644 --- a/stdlib/source/lux/locale/language.lux +++ b/stdlib/source/lux/locale/language.lux @@ -516,14 +516,14 @@ ["zza" zaza [[dimili] [dimli] [kirdki] [kirmanjki] [zazaki]]] ) - (structure: #export _ (Equivalence Language) + (structure: #export equivalence (Equivalence Language) (def: (= reference sample) (is? reference sample))) - (structure: #export _ (Hash Language) - (def: eq Equivalence<Language>) + (structure: #export hash (Hash Language) + (def: &equivalence ..equivalence) (def: hash (|>> :representation - (:: text.Hash<Text> hash)))) + (:: text.hash hash)))) ) diff --git a/stdlib/source/lux/locale/territory.lux b/stdlib/source/lux/locale/territory.lux index 8c1f802ed..d2cd5b347 100644 --- a/stdlib/source/lux/locale/territory.lux +++ b/stdlib/source/lux/locale/territory.lux @@ -295,15 +295,15 @@ ["ZW" "ZWE" 716 "Zimbabwe" zimbabwe []] ) - (structure: #export _ (Equivalence Territory) + (structure: #export equivalence (Equivalence Territory) (def: (= reference sample) (is? reference sample))) - (structure: #export _ (Hash Territory) - (def: eq Equivalence<Territory>) + (structure: #export hash (Hash Territory) + (def: &equivalence ..equivalence) (def: hash (|>> :representation (get@ #long) - (:: text.Hash<Text> hash)))) + (:: text.hash hash)))) ) diff --git a/stdlib/source/lux/macro.lux b/stdlib/source/lux/macro.lux index 7ad35eec9..abfcd4d86 100644 --- a/stdlib/source/lux/macro.lux +++ b/stdlib/source/lux/macro.lux @@ -3,23 +3,24 @@ [control [functor (#+ Functor)] [apply (#+ Apply)] - ["." monad (#+ do Monad)]] + ["." monad (#+ Monad do)]] [data ["." product] - [name ("name/." Codec<Text,Name> Equivalence<Name>)] + [name ("name/." codec equivalence)] ["." maybe] ["." error (#+ Error)] - ["." number ("nat/." Codec<Text,Nat>)] - ["." text ("text/." Monoid<Text> Equivalence<Text>)] + [number + ["." nat ("nat/." decimal)]] + ["." text ("text/." monoid equivalence)] [collection - ["." list ("list/." Monoid<List> Monad<List>)]]]] + ["." list ("list/." monoid monad)]]]] [/ ["." code]]) ## (type: (Meta a) ## (-> Lux (Error [Lux a]))) -(structure: #export _ (Functor Meta) +(structure: #export functor (Functor Meta) (def: (map f fa) (function (_ compiler) (case (fa compiler) @@ -29,8 +30,8 @@ (#error.Success [compiler' a]) (#error.Success [compiler' (f a)]))))) -(structure: #export _ (Apply Meta) - (def: functor Functor<Meta>) +(structure: #export apply (Apply Meta) + (def: &functor ..functor) (def: (apply ff fa) (function (_ compiler) @@ -46,8 +47,8 @@ (#error.Failure msg) (#error.Failure msg))))) -(structure: #export _ (Monad Meta) - (def: functor Functor<Meta>) +(structure: #export monad (Monad Meta) + (def: &functor ..functor) (def: (wrap x) (function (_ compiler) @@ -136,7 +137,7 @@ (def: #export current-module (Meta Module) - (do Monad<Meta> + (do ..monad [this-module-name current-module-name] (find-module this-module-name))) @@ -236,7 +237,7 @@ {#.doc <desc>} (-> Code (List Text)) (maybe.default (list) - (do maybe.Monad<Maybe> + (do maybe.monad [_args (get-ann (name-of <tag>) anns) args (parse-tuple _args)] (monad.map @ parse-text args))))] @@ -249,7 +250,7 @@ (def: (find-macro' modules this-module module name) (-> (List [Text Module]) Text Text Text (Maybe Macro)) - (do maybe.Monad<Maybe> + (do maybe.monad [$module (get module modules) [def-type def-anns def-value] (: (Maybe Definition) (|> (: Module $module) (get@ #.definitions) (get name)))] (if (and (macro? def-anns) @@ -269,16 +270,16 @@ (-> Name (Meta Name)) (case name ["" name] - (do Monad<Meta> + (do ..monad [module-name current-module-name] (wrap [module-name name])) _ - (:: Monad<Meta> wrap name))) + (:: ..monad wrap name))) (def: #export (find-macro full-name) (-> Name (Meta (Maybe Macro))) - (do Monad<Meta> + (do ..monad [[module name] (normalize full-name) this-module current-module-name] (: (Meta (Maybe Macro)) @@ -291,17 +292,17 @@ (-> Code (Meta (List Code))) (case syntax [_ (#.Form (#.Cons [[_ (#.Identifier name)] args]))] - (do Monad<Meta> + (do ..monad [?macro (find-macro name)] (case ?macro (#.Some macro) (macro args) #.None - (:: Monad<Meta> wrap (list syntax)))) + (:: ..monad wrap (list syntax)))) _ - (:: Monad<Meta> wrap (list syntax)))) + (:: ..monad wrap (list syntax)))) (def: #export (expand syntax) {#.doc (doc "Given code that requires applying a macro, expands repeatedly until no more direct macro-calls are left." @@ -309,53 +310,53 @@ (-> Code (Meta (List Code))) (case syntax [_ (#.Form (#.Cons [[_ (#.Identifier name)] args]))] - (do Monad<Meta> + (do ..monad [?macro (find-macro name)] (case ?macro (#.Some macro) - (do Monad<Meta> + (do ..monad [expansion (macro args) - expansion' (monad.map Monad<Meta> expand expansion)] + expansion' (monad.map ..monad expand expansion)] (wrap (list/join expansion'))) #.None - (:: Monad<Meta> wrap (list syntax)))) + (:: ..monad wrap (list syntax)))) _ - (:: Monad<Meta> wrap (list syntax)))) + (:: ..monad wrap (list syntax)))) (def: #export (expand-all syntax) {#.doc "Expands all macro-calls everywhere recursively, until only primitive/base code remains."} (-> Code (Meta (List Code))) (case syntax [_ (#.Form (#.Cons [[_ (#.Identifier name)] args]))] - (do Monad<Meta> + (do ..monad [?macro (find-macro name)] (case ?macro (#.Some macro) - (do Monad<Meta> + (do ..monad [expansion (macro args) - expansion' (monad.map Monad<Meta> expand-all expansion)] + expansion' (monad.map ..monad expand-all expansion)] (wrap (list/join expansion'))) #.None - (do Monad<Meta> - [parts' (monad.map Monad<Meta> expand-all (list& (code.identifier name) args))] + (do ..monad + [parts' (monad.map ..monad expand-all (list& (code.identifier name) args))] (wrap (list (code.form (list/join parts'))))))) [_ (#.Form (#.Cons [harg targs]))] - (do Monad<Meta> + (do ..monad [harg+ (expand-all harg) - targs+ (monad.map Monad<Meta> expand-all targs)] + targs+ (monad.map ..monad expand-all targs)] (wrap (list (code.form (list/compose harg+ (list/join (: (List (List Code)) targs+))))))) [_ (#.Tuple members)] - (do Monad<Meta> - [members' (monad.map Monad<Meta> expand-all members)] + (do ..monad + [members' (monad.map ..monad expand-all members)] (wrap (list (code.tuple (list/join members'))))) _ - (:: Monad<Meta> wrap (list syntax)))) + (:: ..monad wrap (list syntax)))) (def: #export count (Meta Nat) @@ -371,7 +372,7 @@ (#error.Success [(update@ #.seed inc compiler) (|> compiler (get@ #.seed) - (:: number.Codec<Text,Nat> encode) + (:: nat.decimal encode) ($_ text/compose "__gensym__" prefix) [""] code.identifier)]))) @@ -379,7 +380,7 @@ (-> Code (Meta Text)) (case ast [_ (#.Identifier [_ name])] - (:: Monad<Meta> wrap name) + (:: ..monad wrap name) _ (fail (text/compose "Code is not a local identifier: " (code.to-text ast))))) @@ -401,12 +402,12 @@ )))} (case tokens (^ (list [_ (#.Tuple identifiers)] body)) - (do Monad<Meta> + (do ..monad [identifier-names (monad.map @ get-local-identifier identifiers) #let [identifier-defs (list/join (list/map (: (-> Text (List Code)) (function (_ name) (list (code.identifier ["" name]) (` (gensym (~ (code.text name))))))) identifier-names))]] - (wrap (list (` ((~! do) (~! Monad<Meta>) + (wrap (list (` ((~! do) (~! ..monad) [(~+ identifier-defs)] (~ body)))))) @@ -416,7 +417,7 @@ (def: #export (expand-1 token) {#.doc "Works just like expand, except that it ensures that the output is a single Code token."} (-> Code (Meta Code)) - (do Monad<Meta> + (do ..monad [token+ (expand token)] (case token+ (^ (list token')) @@ -468,7 +469,7 @@ (#error.Success [compiler type']))) _ - (:: Monad<Meta> wrap type))) + (:: ..monad wrap type))) (def: #export (find-var-type name) {#.doc "Looks-up the type of a local variable somewhere in the environment."} @@ -476,7 +477,7 @@ (function (_ compiler) (let [test (: (-> [Text [Type Any]] Bit) (|>> product.left (text/= name)))] - (case (do maybe.Monad<Maybe> + (case (do maybe.monad [scope (list.find (function (_ env) (or (list.any? test (: (List [Text [Type Any]]) (get@ [#.locals #.mappings] env))) @@ -498,11 +499,11 @@ (def: #export (find-def name) {#.doc "Looks-up a definition's whole data in the available modules (including the current one)."} (-> Name (Meta Definition)) - (do Monad<Meta> + (do ..monad [name (normalize name)] (function (_ compiler) (case (: (Maybe Definition) - (do maybe.Monad<Maybe> + (do maybe.monad [#let [[v-prefix v-name] name] (^slots [#.definitions]) (get v-prefix (get@ #.modules compiler))] (get v-name definitions))) @@ -527,14 +528,14 @@ (def: #export (find-def-type name) {#.doc "Looks-up a definition's type in the available modules (including the current one)."} (-> Name (Meta Type)) - (do Monad<Meta> + (do ..monad [[def-type def-data def-value] (find-def name)] (clean-type def-type))) (def: #export (find-type name) {#.doc "Looks-up the type of either a local variable or a definition."} (-> Name (Meta Type)) - (do Monad<Meta> + (do ..monad [#let [[_ _name] name]] (case name ["" _name] @@ -547,7 +548,7 @@ (def: #export (find-type-def name) {#.doc "Finds the value of a type definition (such as Int, Any or Lux)."} (-> Name (Meta Type)) - (do Monad<Meta> + (do ..monad [[def-type def-data def-value] (find-def name)] (wrap (:coerce Type def-value)))) @@ -563,7 +564,7 @@ (def: #export (exports module-name) {#.doc "All the exported definitions in a module."} (-> Text (Meta (List [Text Definition]))) - (do Monad<Meta> + (do ..monad [definitions (definitions module-name)] (wrap (list.filter (function (_ [name [def-type def-anns def-value]]) (export? def-anns)) @@ -581,7 +582,7 @@ (def: #export (tags-of type-name) {#.doc "All the tags associated with a type definition."} (-> Name (Meta (Maybe (List Name)))) - (do Monad<Meta> + (do ..monad [#let [[module name] type-name] module (find-module module)] (case (get name (get@ #.types module)) @@ -611,19 +612,19 @@ (def: #export (imported-modules module-name) {#.doc "All the modules imported by a specified module."} (-> Text (Meta (List Text))) - (do Monad<Meta> + (do ..monad [(^slots [#.imports]) (find-module module-name)] (wrap imports))) (def: #export (imported-by? import module) (-> Text Text (Meta Bit)) - (do Monad<Meta> + (do ..monad [(^slots [#.imports]) (find-module module)] (wrap (list.any? (text/= import) imports)))) (def: #export (imported? import) (-> Text (Meta Bit)) - (let [(^open ".") Monad<Meta>] + (let [(^open ".") ..monad] (|> current-module-name (map find-module) join (map (|>> (get@ #.imports) (list.any? (text/= import))))))) @@ -631,7 +632,7 @@ (def: #export (resolve-tag tag) {#.doc "Given a tag, finds out what is its index, its related tag-list and it's associated type."} (-> Name (Meta [Nat (List Name) Type])) - (do Monad<Meta> + (do ..monad [#let [[module name] tag] =module (find-module module) this-module-name current-module-name @@ -649,7 +650,7 @@ (def: #export (tag-lists module) {#.doc "All the tag-lists defined in a module, with their associated types."} (-> Text (Meta (List [(List Name) Type]))) - (do Monad<Meta> + (do ..monad [=module (find-module module) this-module-name current-module-name] (wrap (|> (get@ #.types =module) @@ -677,7 +678,7 @@ (def: #export (un-alias def-name) {#.doc "Given an aliased definition's name, returns the original definition being referenced."} (-> Name (Meta Name)) - (do Monad<Meta> + (do ..monad [[_ def-anns _] (find-def def-name)] (case (get-identifier-ann (name-of #.alias) def-anns) (#.Some real-def-name) @@ -718,7 +719,7 @@ _ #.None)) (#.Some [omit? token]) - (do Monad<Meta> + (do ..monad [cursor ..cursor output (<func> token) #let [_ (log! ($_ text/compose (name/encode (name-of <macro>)) " @ " (.cursor-description cursor))) diff --git a/stdlib/source/lux/macro/code.lux b/stdlib/source/lux/macro/code.lux index 7e78fe617..34dd35a3b 100644 --- a/stdlib/source/lux/macro/code.lux +++ b/stdlib/source/lux/macro/code.lux @@ -3,14 +3,17 @@ [control ["." equivalence (#+ Equivalence)]] [data - bit - number - name - ["." text (#+ Equivalence<Text>) ("text/." Monoid<Text>)] + ["." bit] + ["." name] + [number + ["." nat] + ["." int] + ["." rev] + ["." frac]] + ["." text ("text/." monoid)] [collection - ["." list ("list/." Functor<List> Fold<List>)]]]]) + ["." list ("list/." functor fold)]]]]) -## [Types] ## (type: (Code' w) ## (#.Bit Bit) ## (#.Nat Nat) @@ -26,10 +29,8 @@ ## (type: Code ## (Ann Cursor (Code' (Ann Cursor)))) -## [Utils] (def: _cursor Cursor ["" 0 0]) -## [Functions] (do-template [<name> <type> <tag>] [(def: #export (<name> x) (-> <type> Code) @@ -57,54 +58,52 @@ [local-identifier #.Identifier "Produces a local identifier (an identifier with no module prefix)."] [local-tag #.Tag "Produces a local tag (a tag with no module prefix)."]) -## [Structures] -(structure: #export _ (Equivalence Code) +(structure: #export equivalence (Equivalence Code) (def: (= x y) (case [x y] (^template [<tag> <eq>] [[_ (<tag> x')] [_ (<tag> y')]] (:: <eq> = x' y')) - ([#.Bit Equivalence<Bit>] - [#.Nat Equivalence<Nat>] - [#.Int Equivalence<Int>] - [#.Rev Equivalence<Rev>] - [#.Frac Equivalence<Frac>] - [#.Text Equivalence<Text>] - [#.Identifier Equivalence<Name>] - [#.Tag Equivalence<Name>]) + ([#.Bit bit.equivalence] + [#.Nat nat.equivalence] + [#.Int int.equivalence] + [#.Rev rev.equivalence] + [#.Frac frac.equivalence] + [#.Text text.equivalence] + [#.Identifier name.equivalence] + [#.Tag name.equivalence]) (^template [<tag>] [[_ (<tag> xs')] [_ (<tag> ys')]] - (:: (list.Equivalence<List> =) = xs' ys')) + (:: (list.equivalence =) = xs' ys')) ([#.Form] [#.Tuple]) [[_ (#.Record xs')] [_ (#.Record ys')]] - (:: (list.Equivalence<List> (equivalence.product = =)) + (:: (list.equivalence (equivalence.product = =)) = xs' ys') _ #0))) -## [Values] (def: #export (to-text ast) (-> Code Text) (case ast (^template [<tag> <struct>] [_ (<tag> value)] (:: <struct> encode value)) - ([#.Bit Codec<Text,Bit>] - [#.Nat Codec<Text,Nat>] - [#.Int Codec<Text,Int>] - [#.Rev Codec<Text,Rev>] - [#.Frac Codec<Text,Frac>] - [#.Identifier Codec<Text,Name>]) + ([#.Bit bit.codec] + [#.Nat nat.decimal] + [#.Int int.decimal] + [#.Rev rev.decimal] + [#.Frac frac.decimal] + [#.Identifier name.codec]) [_ (#.Text value)] (text.encode value) [_ (#.Tag name)] - (text/compose "#" (:: Codec<Text,Name> encode name)) + (text/compose "#" (:: name.codec encode name)) (^template [<tag> <open> <close>] [_ (<tag> members)] @@ -132,7 +131,7 @@ (def: #export (replace original substitute ast) {#.doc "Replaces all code that looks like the 'original' with the 'substitute'."} (-> Code Code Code Code) - (if (:: Equivalence<Code> = original ast) + (if (:: ..equivalence = original ast) substitute (case ast (^template [<tag>] diff --git a/stdlib/source/lux/macro/poly.lux b/stdlib/source/lux/macro/poly.lux index be33751cc..02ffb21fb 100644 --- a/stdlib/source/lux/macro/poly.lux +++ b/stdlib/source/lux/macro/poly.lux @@ -1,7 +1,7 @@ (.module: [lux (#- function) [control - ["." monad (#+ do Monad)] + ["." monad (#+ Monad do)] [equivalence] ["p" parser] ["ex" exception (#+ exception:)]] @@ -10,23 +10,24 @@ ["." product] ["." bit] ["." maybe] - [name ("name/." Codec<Text,Name>)] + [name ("name/." codec)] ["." error (#+ Error)] - ["." number (#+ hex) ("nat/." Codec<Text,Nat>)] - ["." text ("text/." Monoid<Text>) + ["." number (#+ hex) + ["." nat ("nat/." decimal)]] + ["." text ("text/." monoid) format] [collection - ["." list ("list/." Fold<List> Monad<List> Monoid<List>)] + ["." list ("list/." fold monad monoid)] ["dict" dictionary (#+ Dictionary)]]] ["." macro (#+ with-gensyms) ["." code] - ["s" syntax (#+ syntax: Syntax)] + ["s" syntax (#+ Syntax syntax:)] [syntax ["cs" common] [common ["csr" reader] ["csw" writer]]]] - ["." type ("type/." Equivalence<Type>) + ["." type ("type/." equivalence) ["." check]]]) (do-template [<name>] @@ -64,7 +65,7 @@ (type: #export (Poly a) (p.Parser [Env (List Type)] a)) -(def: #export fresh Env (dict.new number.Hash<Nat>)) +(def: #export fresh Env (dict.new nat.hash)) (def: (run' env types poly) (All [a] (-> Env (List Type) (Poly a) (Error a))) @@ -150,7 +151,7 @@ (do-template [<name> <flattener> <tag> <exception>] [(def: #export (<name> poly) (All [a] (-> (Poly a) (Poly a))) - (do p.Monad<Parser> + (do p.monad [headT any] (let [members (<flattener> (type.un-name headT))] (if (n/> 1 (list.size members)) @@ -163,7 +164,7 @@ (def: polymorphic' (Poly [Nat Type]) - (do p.Monad<Parser> + (do p.monad [headT any #let [[num-arg bodyT] (type.flatten-univ-q (type.un-name headT))]] (if (n/= 0 num-arg) @@ -172,7 +173,7 @@ (def: #export (polymorphic poly) (All [a] (-> (Poly a) (Poly [Code (List Code) a]))) - (do p.Monad<Parser> + (do p.monad [headT any funcI (:: @ map dict.size ..env) [num-args non-poly] (local (list headT) polymorphic') @@ -209,7 +210,7 @@ (def: #export (function in-poly out-poly) (All [i o] (-> (Poly i) (Poly o) (Poly [i o]))) - (do p.Monad<Parser> + (do p.monad [headT any #let [[inputsT outputT] (type.flatten-function (type.un-name headT))]] (if (n/> 0 (list.size inputsT)) @@ -219,7 +220,7 @@ (def: #export (apply poly) (All [a] (-> (Poly a) (Poly a))) - (do p.Monad<Parser> + (do p.monad [headT any #let [[funcT paramsT] (type.flatten-application (type.un-name headT))]] (if (n/= 0 (list.size paramsT)) @@ -229,7 +230,7 @@ (do-template [<name> <test>] [(def: #export (<name> expected) (-> Type (Poly Any)) - (do p.Monad<Parser> + (do p.monad [actual any] (if (<test> expected actual) (wrap []) @@ -249,7 +250,7 @@ (def: #export parameter (Poly Code) - (do p.Monad<Parser> + (do p.monad [env ..env headT any] (case headT @@ -266,7 +267,7 @@ (def: #export (parameter! id) (-> Nat (Poly Any)) - (do p.Monad<Parser> + (do p.monad [env ..env headT any] (case headT @@ -280,7 +281,7 @@ (def: #export existential (Poly Nat) - (do p.Monad<Parser> + (do p.monad [headT any] (case headT (#.Ex ex-id) @@ -291,7 +292,7 @@ (def: #export named (Poly [Name Type]) - (do p.Monad<Parser> + (do p.monad [inputT any] (case inputT (#.Named name anonymousT) @@ -302,7 +303,7 @@ (def: #export (recursive poly) (All [a] (-> (Poly a) (Poly [Code a]))) - (do p.Monad<Parser> + (do p.monad [headT any] (case (type.un-name headT) (#.Apply (#.Named ["lux" "Nothing"] _) (#.UnivQ _ headT')) @@ -318,7 +319,7 @@ (def: #export recursive-self (Poly Code) - (do p.Monad<Parser> + (do p.monad [env ..env headT any] (case (type.un-name headT) @@ -332,7 +333,7 @@ (def: #export recursive-call (Poly Code) - (do p.Monad<Parser> + (do p.monad [env ..env [funcT argsT] (apply (p.and any (p.many any))) _ (local (list funcT) (..parameter! 0)) @@ -344,26 +345,25 @@ (def: #export log (All [a] (Poly a)) - (do p.Monad<Parser> + (do p.monad [current any #let [_ (log! ($_ text/compose "{" (name/encode (name-of ..log)) "} " (%type current)))]] (p.fail "LOGGING"))) -## [Syntax] (syntax: #export (poly: {export csr.export} {name s.local-identifier} body) (with-gensyms [g!_ g!type g!output] (let [g!name (code.identifier ["" name])] (wrap (.list (` (syntax: (~+ (csw.export export)) ((~ g!name) {(~ g!type) s.identifier}) - (do macro.Monad<Meta> + (do macro.monad [(~ g!type) (macro.find-type-def (~ g!type))] (case (|> (~ body) (.function ((~ g!_) (~ g!name))) p.rec - (do p.Monad<Parser> []) + (do p.monad []) (..run (~ g!type)) (: (.Either .Text .Code))) (#.Left (~ g!output)) @@ -410,7 +410,6 @@ {#.struct? #1} (~ impl))))))) -## [Derivers] (def: #export (to-code env type) (-> Env Type Code) (case type diff --git a/stdlib/source/lux/macro/poly/equivalence.lux b/stdlib/source/lux/macro/poly/equivalence.lux index 4b5b80e13..5d95b6256 100644 --- a/stdlib/source/lux/macro/poly/equivalence.lux +++ b/stdlib/source/lux/macro/poly/equivalence.lux @@ -8,11 +8,15 @@ ["." product] ["." bit] ["." maybe] - ["." number ("nat/." Codec<Text,Nat>)] - ["." text ("text/." Monoid<Text>) + [number + ["." nat ("nat/." codec)] + ["." int] + ["." rev] + ["." frac]] + ["." text ("text/." monoid) format] [collection - ["." list ("list/." Monad<List>)] + ["." list ("list/." monad)] ["." row] ["." array] ["." queue] @@ -50,12 +54,12 @@ <eq>))))] [(poly.exactly Any) (function ((~ g!_) (~ g!_) (~ g!_)) #1)] - [(poly.sub Bit) (~! bit.Equivalence<Bit>)] - [(poly.sub Nat) (~! number.Equivalence<Nat>)] - [(poly.sub Int) (~! number.Equivalence<Int>)] - [(poly.sub Rev) (~! number.Equivalence<Rev>)] - [(poly.sub Frac) (~! number.Equivalence<Frac>)] - [(poly.sub Text) (~! text.Equivalence<Text>)])) + [(poly.sub Bit) (~! bit.equivalence)] + [(poly.sub Nat) (~! nat.equivalence)] + [(poly.sub Int) (~! int.equivalence)] + [(poly.sub Rev) (~! rev.equivalence)] + [(poly.sub Frac) (~! frac.equivalence)] + [(poly.sub Text) (~! text.equivalence)])) ## Composite types (~~ (do-template [<name> <eq>] [(do @ @@ -64,13 +68,13 @@ (wrap (` (: (~ (@Equivalence inputT)) (<eq> (~ argC))))))] - [.Maybe (~! maybe.Equivalence<Maybe>)] - [.List (~! list.Equivalence<List>)] - [row.Row (~! row.Equivalence<Row>)] - [array.Array (~! array.Equivalence<Array>)] - [queue.Queue (~! queue.Equivalence<Queue>)] - [set.Set (~! set.Equivalence<Set>)] - [rose.Tree (~! rose.Equivalence<Tree>)] + [.Maybe (~! maybe.equivalence)] + [.List (~! list.equivalence)] + [row.Row (~! row.equivalence)] + [array.Array (~! array.equivalence)] + [queue.Queue (~! queue.equivalence)] + [set.Set (~! set.equivalence)] + [rose.Tree (~! rose.equivalence)] )) (do @ [[_ _ valC] (poly.apply ($_ p.and @@ -78,7 +82,7 @@ poly.any Equivalence<?>))] (wrap (` (: (~ (@Equivalence inputT)) - ((~! dict.Equivalence<Dictionary>) (~ valC)))))) + ((~! dict.equivalence) (~ valC)))))) ## Models (~~ (do-template [<type> <eq>] [(do @ @@ -86,16 +90,16 @@ (wrap (` (: (~ (@Equivalence inputT)) <eq>))))] - [du.Duration du.Equivalence<Duration>] - [i.Instant i.Equivalence<Instant>] - [da.Date da.Equivalence<Date>] - [da.Day da.Equivalence<Day>] - [da.Month da.Equivalence<Month>])) + [du.Duration du.equivalence] + [i.Instant i.equivalence] + [da.Date da.equivalence] + [da.Day da.equivalence] + [da.Month da.equivalence])) (do @ [_ (poly.apply (p.and (poly.exactly unit.Qty) poly.any))] (wrap (` (: (~ (@Equivalence inputT)) - unit.Equivalence<Qty>)))) + unit.equivalence)))) ## Variants (do @ [members (poly.variant (p.many Equivalence<?>)) diff --git a/stdlib/source/lux/macro/poly/functor.lux b/stdlib/source/lux/macro/poly/functor.lux index d866db45c..61aba1753 100644 --- a/stdlib/source/lux/macro/poly/functor.lux +++ b/stdlib/source/lux/macro/poly/functor.lux @@ -9,7 +9,7 @@ ["." text format] [collection - ["." list ("list/." Monad<List> Monoid<List>)]]] + ["." list ("list/." monad monoid)]]] ["." macro ["." code] [syntax (#+ syntax: Syntax) @@ -38,7 +38,7 @@ (function (Arg<?> valueC) ($_ p.either ## Type-var - (do p.Monad<Parser> + (do p.monad [#let [varI (|> num-vars (n/* 2) dec)] _ (poly.parameter! varI)] (wrap (` ((~ funcC) (~ valueC))))) @@ -52,7 +52,7 @@ (` ((~ (code.nat tag)) (~ memberC))))) (list.enumerate membersC)))))))) ## Tuples - (do p.Monad<Parser> + (do p.monad [pairsCC (: (poly.Poly (List [Code Code])) (poly.tuple (loop [idx 0 pairsCC (: (List [Code Code]) @@ -81,11 +81,11 @@ (let [(~ outL) ((~ valueC) (~+ inC+))] (~ outC)))))) ## Recursion - (do p.Monad<Parser> + (do p.monad [_ poly.recursive-call] (wrap (` ((~' map) (~ funcC) (~ valueC))))) ## Parameters - (do p.Monad<Parser> + (do p.monad [_ poly.any] (wrap valueC)) )))] diff --git a/stdlib/source/lux/macro/poly/json.lux b/stdlib/source/lux/macro/poly/json.lux index 6ef9b249e..22b07f064 100644 --- a/stdlib/source/lux/macro/poly/json.lux +++ b/stdlib/source/lux/macro/poly/json.lux @@ -1,7 +1,7 @@ (.module: {#.doc "Codecs for values in the JSON format."} [lux #* [control - [monad (#+ do Monad)] + [monad (#+ Monad do)] [equivalence (#+ Equivalence)] codec ["p" parser]] @@ -11,16 +11,16 @@ ["e" error] ["." sum] ["." product] - [number ("frac/." Codec<Text,Frac>) ("nat/." Codec<Text,Nat>) + [number ("frac/." codec) ("nat/." codec) ["." i64]] - ["." text ("text/." Equivalence<Text>) + ["." text ("text/." equivalence) ["l" lexer] format] [format ["//" json (#+ JSON)]] [collection - ["." list ("list/." Fold<List> Monad<List>)] - ["." row (#+ Row row) ("row/." Monad<Row>)] + ["." list ("list/." fold monad)] + ["." row (#+ Row row) ("row/." monad)] ["d" dictionary]]] [time ## ["i" instant] @@ -47,7 +47,7 @@ (def: low-mask Nat (|> 1 (i64.left-shift 32) dec)) (def: high-mask Nat (|> low-mask (i64.left-shift 32))) -(structure: _ (Codec JSON Nat) +(structure: nat-codec (Codec JSON Nat) (def: (encode input) (let [high (|> input (i64.and high-mask) (i64.logical-right-shift 32)) low (i64.and low-mask input)] @@ -56,16 +56,16 @@ (def: (decode input) (<| (//.run input) //.array - (do p.Monad<Parser> + (do p.monad [high //.number low //.number]) (wrap (n/+ (|> high frac-to-int .nat (i64.left-shift 32)) (|> low frac-to-int .nat)))))) -(structure: _ (Codec JSON Int) - (def: encode (|>> .nat (:: Codec<JSON,Nat> encode))) +(structure: int-codec (Codec JSON Int) + (def: encode (|>> .nat (:: nat-codec encode))) (def: decode - (|>> (:: Codec<JSON,Nat> decode) (:: e.Functor<Error> map .int)))) + (|>> (:: nat-codec decode) (:: e.functor map .int)))) (def: (nullable writer) {#.doc "Builds a JSON generator for potentially inexistent values."} @@ -75,15 +75,15 @@ #.None #//.Null (#.Some value) (writer value)))) -(structure: Codec<JSON,Qty> +(structure: qty-codec (All [unit] (Codec JSON (unit.Qty unit))) (def: encode - (|>> unit.out (:: Codec<JSON,Int> encode))) + (|>> unit.out (:: ..int-codec encode))) (def: decode - (|>> (:: Codec<JSON,Int> decode) (:: e.Functor<Error> map unit.in)))) + (|>> (:: ..int-codec decode) (:: e.functor map unit.in)))) -(poly: Codec<JSON,?>//encode +(poly: codec//encode (with-expansions [<basic> (do-template [<matcher> <encoder>] [(do @ @@ -94,8 +94,8 @@ [(poly.exactly Any) (function ((~ g!_) (~ (code.identifier ["" "0"]))) #//.Null)] [(poly.sub Bit) (|>> #//.Boolean)] - [(poly.sub Nat) (:: (~! ..Codec<JSON,Nat>) (~' encode))] - [(poly.sub Int) (:: (~! ..Codec<JSON,Int>) (~' encode))] + [(poly.sub Nat) (:: (~! ..nat-codec) (~' encode))] + [(poly.sub Int) (:: (~! ..int-codec) (~' encode))] [(poly.sub Frac) (|>> #//.Number)] [(poly.sub Text) (|>> #//.String)]) <time> (do-template [<type> <codec>] @@ -104,11 +104,11 @@ (wrap (` (: (~ (@JSON//encode inputT)) (|>> (:: <codec> (~' encode)) #//.String)))))] - ## [du.Duration du.Codec<Text,Duration>] - ## [i.Instant i.Codec<Text,Instant>] - [da.Date da.Codec<Text,Date>] - [da.Day da.Codec<Text,Day>] - [da.Month da.Codec<Text,Month>])] + ## [du.Duration du.codec] + ## [i.Instant i.codec] + [da.Date da.date-codec] + [da.Day da.day-codec] + [da.Month da.month-codec])] (do @ [*env* poly.env #let [@JSON//encode (: (-> Type Code) @@ -122,7 +122,7 @@ [unitT (poly.apply (p.after (poly.exactly unit.Qty) poly.any))] (wrap (` (: (~ (@JSON//encode inputT)) - (:: (~! Codec<JSON,Qty>) (~' encode)))))) + (:: (~! qty-codec) (~' encode)))))) (do @ [#let [g!_ (code.local-identifier "_______") g!key (code.local-identifier "_______key") @@ -130,29 +130,29 @@ [_ _ =val=] (poly.apply ($_ p.and (poly.exactly d.Dictionary) (poly.exactly .Text) - Codec<JSON,?>//encode))] + codec//encode))] (wrap (` (: (~ (@JSON//encode inputT)) (|>> d.entries ((~! list/map) (function ((~ g!_) [(~ g!key) (~ g!val)]) [(~ g!key) ((~ =val=) (~ g!val))])) - (d.from-list text.Hash<Text>) + (d.from-list text.hash) #//.Object))))) (do @ [[_ =sub=] (poly.apply ($_ p.and (poly.exactly .Maybe) - Codec<JSON,?>//encode))] + codec//encode))] (wrap (` (: (~ (@JSON//encode inputT)) ((~! ..nullable) (~ =sub=)))))) (do @ [[_ =sub=] (poly.apply ($_ p.and (poly.exactly .List) - Codec<JSON,?>//encode))] + codec//encode))] (wrap (` (: (~ (@JSON//encode inputT)) (|>> ((~! list/map) (~ =sub=)) row.from-list #//.Array))))) (do @ [#let [g!_ (code.local-identifier "_______") g!input (code.local-identifier "_______input")] - members (poly.variant (p.many Codec<JSON,?>//encode))] + members (poly.variant (p.many codec//encode))] (wrap (` (: (~ (@JSON//encode inputT)) (function ((~ g!_) (~ g!input)) (case (~ g!input) @@ -162,7 +162,7 @@ ((~ g!encode) (~ g!input))])))) (list.enumerate members)))))))))) (do @ - [g!encoders (poly.tuple (p.many Codec<JSON,?>//encode)) + [g!encoders (poly.tuple (p.many codec//encode)) #let [g!_ (code.local-identifier "_______") g!members (|> (list.size g!encoders) list.indices @@ -174,7 +174,7 @@ (list.zip2 g!members g!encoders)))])))))) ## Type recursion (do @ - [[selfC non-recC] (poly.recursive Codec<JSON,?>//encode) + [[selfC non-recC] (poly.recursive codec//encode) #let [g! (code.local-identifier "____________")]] (wrap (` (: (~ (@JSON//encode inputT)) ((~! ..rec-encode) (.function ((~ g!) (~ selfC)) @@ -182,11 +182,11 @@ poly.recursive-self ## Type applications (do @ - [partsC (poly.apply (p.many Codec<JSON,?>//encode))] + [partsC (poly.apply (p.many codec//encode))] (wrap (` ((~+ partsC))))) ## Polymorphism (do @ - [[funcC varsC bodyC] (poly.polymorphic Codec<JSON,?>//encode)] + [[funcC varsC bodyC] (poly.polymorphic codec//encode)] (wrap (` (: (All [(~+ varsC)] (-> (~+ (list/map (function (_ varC) (` (-> (~ varC) //.JSON))) varsC)) @@ -200,7 +200,7 @@ (p.fail (format "Cannot create JSON encoder for: " (type.to-text inputT))) )))) -(poly: Codec<JSON,?>//decode +(poly: codec//decode (with-expansions [<basic> (do-template [<matcher> <decoder>] [(do @ @@ -210,8 +210,8 @@ [(poly.exactly Any) //.null] [(poly.sub Bit) //.boolean] - [(poly.sub Nat) (p.codec (~! ..Codec<JSON,Nat>) //.any)] - [(poly.sub Int) (p.codec (~! ..Codec<JSON,Int>) //.any)] + [(poly.sub Nat) (p.codec (~! ..nat-codec) //.any)] + [(poly.sub Int) (p.codec (~! ..int-codec) //.any)] [(poly.sub Frac) //.number] [(poly.sub Text) //.string]) <time> (do-template [<type> <codec>] @@ -220,11 +220,11 @@ (wrap (` (: (~ (@JSON//decode inputT)) (p.codec <codec> //.string)))))] - ## [du.Duration du.Codec<Text,Duration>] - ## [i.Instant i.Codec<Text,Instant>] - [da.Date da.Codec<Text,Date>] - [da.Day da.Codec<Text,Day>] - [da.Month da.Codec<Text,Month>])] + ## [du.Duration du.codec] + ## [i.Instant i.codec] + [da.Date da.date-codec] + [da.Day da.day-codec] + [da.Month da.month-codec])] (do @ [*env* poly.env #let [@JSON//decode (: (-> Type Code) @@ -238,26 +238,26 @@ [unitT (poly.apply (p.after (poly.exactly unit.Qty) poly.any))] (wrap (` (: (~ (@JSON//decode inputT)) - (p.codec (~! Codec<JSON,Qty>) //.any))))) + (p.codec (~! qty-codec) //.any))))) (do @ [[_ _ valC] (poly.apply ($_ p.and (poly.exactly d.Dictionary) (poly.exactly .Text) - Codec<JSON,?>//decode))] + codec//decode))] (wrap (` (: (~ (@JSON//decode inputT)) (//.object (~ valC)))))) (do @ [[_ subC] (poly.apply (p.and (poly.exactly .Maybe) - Codec<JSON,?>//decode))] + codec//decode))] (wrap (` (: (~ (@JSON//decode inputT)) (//.nullable (~ subC)))))) (do @ [[_ subC] (poly.apply (p.and (poly.exactly .List) - Codec<JSON,?>//decode))] + codec//decode))] (wrap (` (: (~ (@JSON//decode inputT)) (//.array (p.some (~ subC))))))) (do @ - [members (poly.variant (p.many Codec<JSON,?>//decode))] + [members (poly.variant (p.many codec//decode))] (wrap (` (: (~ (@JSON//decode inputT)) ($_ p.or (~+ (list/map (function (_ [tag memberC]) @@ -266,12 +266,12 @@ //.array))) (list.enumerate members)))))))) (do @ - [g!decoders (poly.tuple (p.many Codec<JSON,?>//decode))] + [g!decoders (poly.tuple (p.many codec//decode))] (wrap (` (: (~ (@JSON//decode inputT)) (//.array ($_ p.and (~+ g!decoders))))))) ## Type recursion (do @ - [[selfC bodyC] (poly.recursive Codec<JSON,?>//decode) + [[selfC bodyC] (poly.recursive codec//decode) #let [g! (code.local-identifier "____________")]] (wrap (` (: (~ (@JSON//decode inputT)) (p.rec (.function ((~ g!) (~ selfC)) @@ -279,11 +279,11 @@ poly.recursive-self ## Type applications (do @ - [[funcC argsC] (poly.apply (p.and Codec<JSON,?>//decode (p.many Codec<JSON,?>//decode)))] + [[funcC argsC] (poly.apply (p.and codec//decode (p.many codec//decode)))] (wrap (` ((~ funcC) (~+ argsC))))) ## Polymorphism (do @ - [[funcC varsC bodyC] (poly.polymorphic Codec<JSON,?>//decode)] + [[funcC varsC bodyC] (poly.polymorphic codec//decode)] (wrap (` (: (All [(~+ varsC)] (-> (~+ (list/map (|>> (~) //.Reader (`)) varsC)) (//.Reader ((~ (poly.to-code *env* inputT)) (~+ varsC))))) @@ -295,7 +295,7 @@ (p.fail (format "Cannot create JSON decoder for: " (type.to-text inputT))) )))) -(syntax: #export (Codec<JSON,?> inputT) +(syntax: #export (codec inputT) {#.doc (doc "A macro for automatically producing JSON codecs." (type: Variant (#Case0 Bit) @@ -312,9 +312,9 @@ #tuple [Bit Frac Text] #dict (Dictionary Text Frac)}) - (derived: (Codec<JSON,?> Record)))} + (derived: (..codec Record)))} (with-gensyms [g!inputs] (wrap (list (` (: (Codec //.JSON (~ inputT)) - (structure (def: (~' encode) ((~! Codec<JSON,?>//encode) (~ inputT))) - (def: ((~' decode) (~ g!inputs)) (//.run (~ g!inputs) ((~! Codec<JSON,?>//decode) (~ inputT)))) + (structure (def: (~' encode) ((~! ..codec) (~ inputT))) + (def: ((~' decode) (~ g!inputs)) (//.run (~ g!inputs) ((~! ..codec) (~ inputT)))) ))))))) diff --git a/stdlib/source/lux/macro/syntax.lux b/stdlib/source/lux/macro/syntax.lux index cb235043f..704f6d245 100644 --- a/stdlib/source/lux/macro/syntax.lux +++ b/stdlib/source/lux/macro/syntax.lux @@ -1,7 +1,7 @@ (.module: [lux (#- nat int rev) [control - ["." monad (#+ do Monad)] + ["." monad (#+ Monad do)] [equivalence (#+ Equivalence)] ["p" parser]] [data @@ -9,12 +9,16 @@ ["." name] ["." maybe] ["." error (#+ Error)] - ["." number] - ["." text ("text/." Monoid<Text>)] + [number + ["." nat] + ["." int] + ["." rev] + ["." frac]] + ["." text ("text/." monoid)] [collection - ["." list ("list/." Functor<List>)]]]] + ["." list ("list/." functor)]]]] ["." // (#+ with-gensyms) - ["." code ("code/." Equivalence<Code>)]]) + ["." code ("code/." equivalence)]]) ## [Utils] (def: (join-pairs pairs) @@ -55,14 +59,14 @@ _ (#error.Failure ($_ text/compose "Cannot parse " <desc> (remaining-inputs tokens))))))] - [ bit Bit #.Bit bit.Equivalence<Bit> "bit"] - [ nat Nat #.Nat number.Equivalence<Nat> "nat"] - [ int Int #.Int number.Equivalence<Int> "int"] - [ rev Rev #.Rev number.Equivalence<Rev> "rev"] - [ frac Frac #.Frac number.Equivalence<Frac> "frac"] - [ text Text #.Text text.Equivalence<Text> "text"] - [identifier Name #.Identifier name.Equivalence<Name> "identifier"] - [ tag Name #.Tag name.Equivalence<Name> "tag"] + [ bit Bit #.Bit bit.equivalence "bit"] + [ nat Nat #.Nat nat.equivalence "nat"] + [ int Int #.Int int.equivalence "int"] + [ rev Rev #.Rev rev.equivalence "rev"] + [ frac Frac #.Frac frac.equivalence "frac"] + [ text Text #.Text text.equivalence "text"] + [identifier Name #.Identifier name.equivalence "identifier"] + [ tag Name #.Tag name.equivalence "tag"] ) (def: #export (this? ast) @@ -190,7 +194,7 @@ {#.doc "Run a syntax parser with the given list of inputs, instead of the real ones."} (All [a] (-> (List Code) (Syntax a) (Syntax a))) (function (_ real) - (do error.Monad<Error> + (do error.monad [value (run inputs syntax)] (wrap [real value])))) @@ -198,7 +202,7 @@ (macro: #export (syntax: tokens) {#.doc (doc "A more advanced way to define macros than 'macro:'." "The inputs to the macro can be parsed in complex ways through the use of syntax parsers." - "The macro body is also (implicitly) run in the Monad<Meta>, to save some typing." + "The macro body is also (implicitly) run in the Meta monad, to save some typing." "Also, the compiler state can be accessed through the *compiler* binding." (syntax: #export (object {#let [imports (class-imports *compiler*)]} {#let [class-vars (list)]} @@ -235,7 +239,7 @@ (case ?parts (#.Some [name args meta body]) (with-gensyms [g!tokens g!body g!error] - (do //.Monad<Meta> + (do //.monad [vars+parsers (monad.map @ (: (-> Code (Meta [Code Code])) (function (_ arg) @@ -265,9 +269,9 @@ (#error.Failure ((~! text.join-with) ": " (list (~ error-msg) (~ g!error))))} ((~! ..run) (~ g!tokens) (: ((~! ..Syntax) (Meta (List Code))) - ((~! do) (~! p.Monad<Parser>) + ((~! do) (~! p.monad) [(~+ (join-pairs vars+parsers))] - ((~' wrap) ((~! do) (~! //.Monad<Meta>) + ((~' wrap) ((~! do) (~! //.monad) [] (~ body))))))))))))) diff --git a/stdlib/source/lux/macro/syntax/common/reader.lux b/stdlib/source/lux/macro/syntax/common/reader.lux index bbbe3f6d7..93e2ffa09 100644 --- a/stdlib/source/lux/macro/syntax/common/reader.lux +++ b/stdlib/source/lux/macro/syntax/common/reader.lux @@ -2,9 +2,9 @@ [lux #* [control monad - ["p" parser ("parser/." Monad<Parser>)]] + ["p" parser ("parser/." monad)]] [data - [name ("name/." Equivalence<Name>)] + [name ("name/." equivalence)] ["." product] ["." maybe] [collection @@ -40,7 +40,7 @@ ## Definitions (def: check^ (Syntax [(Maybe Code) Code]) - (p.either (s.form (do p.Monad<Parser> + (p.either (s.form (do p.monad [_ (s.this (' "lux check")) type s.any value s.any] @@ -55,7 +55,7 @@ (def: (_definition-anns^ _) (-> Any (Syntax //.Annotations)) (p.or (s.this (' #.Nil)) - (s.form (do p.Monad<Parser> + (s.form (do p.monad [_ (s.this (' #.Cons)) [head tail] (p.and (s.tuple (p.and _definition-anns-tag^ s.any)) (_definition-anns^ []))] @@ -64,10 +64,10 @@ (def: (flat-list^ _) (-> Any (Syntax (List Code))) - (p.either (do p.Monad<Parser> + (p.either (do p.monad [_ (s.this (' #.Nil))] (wrap (list))) - (s.form (do p.Monad<Parser> + (s.form (do p.monad [_ (s.this (' #.Cons)) [head tail] (s.tuple (p.and s.any s.any)) tail (s.local (list tail) (flat-list^ []))] @@ -79,7 +79,7 @@ (<| s.tuple (p.after s.any) s.form - (do p.Monad<Parser> + (do p.monad [_ (s.this (' <tag>))] <then>)))] @@ -105,7 +105,7 @@ (def: #export (definition compiler) {#.doc "A reader that first macro-expands and then analyses the input Code, to ensure it's a definition."} (-> Lux (Syntax //.Definition)) - (do p.Monad<Parser> + (do p.monad [definition-raw s.any me-definition-raw (|> definition-raw ////.expand-all @@ -129,7 +129,7 @@ (def: #export (typed-definition compiler) {#.doc "A reader for definitions that ensures the input syntax is typed."} (-> Lux (Syntax //.Definition)) - (do p.Monad<Parser> + (do p.monad [_definition (definition compiler) _ (case (get@ #//.definition-type _definition) (#.Some _) diff --git a/stdlib/source/lux/macro/syntax/common/writer.lux b/stdlib/source/lux/macro/syntax/common/writer.lux index 3affd97f7..3a9e2b0a0 100644 --- a/stdlib/source/lux/macro/syntax/common/writer.lux +++ b/stdlib/source/lux/macro/syntax/common/writer.lux @@ -3,7 +3,7 @@ [lux #* [data [collection - [list ("list/." Functor<List>)]] + [list ("list/." functor)]] ["." product]] ["." function] [macro diff --git a/stdlib/source/lux/macro/template.lux b/stdlib/source/lux/macro/template.lux index b5fca4e69..21621ba07 100644 --- a/stdlib/source/lux/macro/template.lux +++ b/stdlib/source/lux/macro/template.lux @@ -1,6 +1,6 @@ (.module: [lux #*] - ["." // ("meta/." Monad<Meta>)]) + ["." // ("meta/." monad)]) (macro: #export (splice tokens) (case tokens diff --git a/stdlib/source/lux/math/infix.lux b/stdlib/source/lux/math/infix.lux index 145b8f579..dec158d52 100644 --- a/stdlib/source/lux/math/infix.lux +++ b/stdlib/source/lux/math/infix.lux @@ -2,11 +2,11 @@ [lux #* [control monad - ["p" parser ("parser/." Functor<Parser>)]] + ["p" parser ("parser/." functor)]] [data ["." product] [collection - [list ("list/." Fold<List>)]]] + [list ("list/." fold)]]] [macro ["s" syntax (#+ syntax: Syntax)] ["." code]]]) @@ -33,7 +33,7 @@ (s.form (p.many s.any)) (s.tuple (p.and s.any infix^)) (s.tuple ($_ p.either - (do p.Monad<Parser> + (do p.monad [_ (s.this (' #and)) init-subject infix^ init-op s.any @@ -45,7 +45,7 @@ (#Binary subject op param)]]) [init-param [init-subject init-op init-param]] steps)))) - (do p.Monad<Parser> + (do p.monad [init-subject infix^ init-op s.any init-param infix^ diff --git a/stdlib/source/lux/math/logic/continuous.lux b/stdlib/source/lux/math/logic/continuous.lux index edc31f2a7..2f384742a 100644 --- a/stdlib/source/lux/math/logic/continuous.lux +++ b/stdlib/source/lux/math/logic/continuous.lux @@ -1,6 +1,8 @@ (.module: [lux (#- false true or and not) - [data [number ("rev/." Interval<Rev>)]]]) + [data + [number + [rev ("rev/." interval)]]]]) (def: #export true Rev rev/top) (def: #export false Rev rev/bottom) diff --git a/stdlib/source/lux/math/modular.lux b/stdlib/source/lux/math/modular.lux index 6222ed87b..8c0922af2 100644 --- a/stdlib/source/lux/math/modular.lux +++ b/stdlib/source/lux/math/modular.lux @@ -7,8 +7,9 @@ [monad (#+ do)]] [data ["." error (#+ Error)] - ["." number ("int/." Codec<Text,Int>)] - [text ("text/." Monoid<Text>) + [number + ["." int ("int/." decimal)]] + [text ("text/." monoid) ["l" lexer (#+ Lexer)]]] [type abstract] @@ -62,7 +63,7 @@ (def: intL (Lexer Int) - (p.codec number.Codec<Text,Int> + (p.codec int.decimal (p.either (l.and (l.one-of "-") (l.many l.decimal)) (l.many l.decimal)))) @@ -84,7 +85,7 @@ (def: separator Text " mod ") - (structure: #export (Codec<Text,Mod> modulus) + (structure: #export (codec modulus) (All [m] (-> (Modulus m) (Codec Text (Mod m)))) (def: (encode modular) @@ -96,7 +97,7 @@ (def: (decode text) (<| (l.run text) - (do p.Monad<Parser> + (do p.monad [[remainder _ _modulus] ($_ p.and intL (l.this separator) intL) _ (p.assert (ex.construct incorrect-modulus [modulus _modulus]) (i/= (to-int modulus) _modulus))] diff --git a/stdlib/source/lux/math/random.lux b/stdlib/source/lux/math/random.lux index b73e7df02..433cba425 100644 --- a/stdlib/source/lux/math/random.lux +++ b/stdlib/source/lux/math/random.lux @@ -8,14 +8,15 @@ [data ["." product] ["." maybe] - ["." number (#+ hex) + [number (#+ hex) ["." i64] ["r" ratio] - ["c" complex]] - ["." text ("text/." Monoid<Text>) - ["." unicode (#+ Char Segment)]] + ["c" complex] + ["." frac]] + ["." text (#+ Char) ("text/." monoid) + ["." unicode (#+ Segment)]] [collection - ["." list ("list/." Fold<List>)] + ["." list ("list/." fold)] ["." array (#+ Array)] ["." dictionary (#+ Dictionary)] ["." queue (#+ Queue)] @@ -35,14 +36,14 @@ {#.doc "A producer of random values based on a PRNG."} (-> PRNG [PRNG a])) -(structure: #export _ (Functor Random) +(structure: #export functor (Functor Random) (def: (map f fa) (function (_ state) (let [[state' a] (fa state)] [state' (f a)])))) -(structure: #export _ (Apply Random) - (def: functor Functor<Random>) +(structure: #export apply (Apply Random) + (def: &functor ..functor) (def: (apply ff fa) (function (_ state) @@ -50,8 +51,8 @@ [state'' a] (fa state')] [state'' (f a)])))) -(structure: #export _ (Monad Random) - (def: functor Functor<Random>) +(structure: #export monad (Monad Random) + (def: &functor ..functor) (def: (wrap a) (function (_ state) @@ -65,7 +66,7 @@ (def: #export (filter pred gen) {#.doc "Retries the generator until the output satisfies a predicate."} (All [a] (-> (-> a Bit) (Random a) (Random a))) - (do Monad<Random> + (do ..monad [sample gen] (if (pred sample) (wrap sample) @@ -74,7 +75,7 @@ (def: #export (refine refiner gen) {#.doc "Retries the generator until the output can be refined."} (All [t r] (-> (Refiner t r) (Random t) (Random (Refined t r)))) - (do Monad<Random> + (do ..monad [sample gen] (case (refiner sample) (#.Some refined) @@ -101,7 +102,7 @@ (do-template [<name> <type> <cast>] [(def: #export <name> (Random <type>) - (:: Monad<Random> map <cast> ..i64))] + (:: ..monad map <cast> ..i64))] [nat Nat .nat] [int Int .int] @@ -110,7 +111,7 @@ (def: #export frac (Random Frac) - (:: Monad<Random> map number.bits-to-frac nat)) + (:: ..monad map frac.bits-to-frac ..nat)) (def: #export (char set) (-> unicode.Set (Random Char)) @@ -120,7 +121,7 @@ in-range (: (-> Char Char) (|>> (n/% size) (n/+ start)))] (|> nat - (:: Monad<Random> map in-range) + (:: ..monad map in-range) (..filter (function (_ char) (finger.found? (function (_ segment) (unicode.within? segment char)) @@ -129,8 +130,8 @@ (def: #export (text char-gen size) (-> (Random Char) Nat (Random Text)) (if (n/= 0 size) - (:: Monad<Random> wrap "") - (do Monad<Random> + (:: ..monad wrap "") + (do ..monad [x char-gen xs (text char-gen (dec size))] (wrap (text/compose (text.from-code x) xs))))) @@ -150,7 +151,7 @@ (do-template [<name> <type> <ctor> <gen>] [(def: #export <name> (Random <type>) - (do Monad<Random> + (do ..monad [left <gen> right <gen>] (wrap (<ctor> left right))))] @@ -162,7 +163,7 @@ (def: #export (and left right) {#.doc "Sequencing combinator."} (All [a b] (-> (Random a) (Random b) (Random [a b]))) - (do Monad<Random> + (do ..monad [=left left =right right] (wrap [=left =right]))) @@ -170,7 +171,7 @@ (def: #export (or left right) {#.doc "Heterogeneous alternative combinator."} (All [a b] (-> (Random a) (Random b) (Random (| a b)))) - (do Monad<Random> + (do ..monad [? bit] (if ? (do @ @@ -183,7 +184,7 @@ (def: #export (either left right) {#.doc "Homogeneous alternative combinator."} (All [a] (-> (Random a) (Random a) (Random a))) - (do Monad<Random> + (do ..monad [? bit] (if ? left @@ -198,7 +199,7 @@ (def: #export (maybe value-gen) (All [a] (-> (Random a) (Random (Maybe a)))) - (do Monad<Random> + (do ..monad [some? bit] (if some? (do @ @@ -210,11 +211,11 @@ [(def: #export (<name> size value-gen) (All [a] (-> Nat (Random a) (Random (<type> a)))) (if (n/> 0 size) - (do Monad<Random> + (do ..monad [x value-gen xs (<name> (dec size) value-gen)] (wrap (<plus> x xs))) - (:: Monad<Random> wrap <zero>)))] + (:: ..monad wrap <zero>)))] [list List (.list) #.Cons] [row Row row.empty row.add] @@ -223,7 +224,7 @@ (do-template [<name> <type> <ctor>] [(def: #export (<name> size value-gen) (All [a] (-> Nat (Random a) (Random (<type> a)))) - (do Monad<Random> + (do ..monad [values (list size value-gen)] (wrap (|> values <ctor>))))] @@ -235,7 +236,7 @@ (def: #export (set Hash<a> size value-gen) (All [a] (-> (Hash a) Nat (Random a) (Random (Set a)))) (if (n/> 0 size) - (do Monad<Random> + (do ..monad [xs (set Hash<a> (dec size) value-gen)] (loop [_ []] (do @ @@ -244,12 +245,12 @@ (if (n/= size (set.size xs+)) (wrap xs+) (recur []))))) - (:: Monad<Random> wrap (set.new Hash<a>)))) + (:: ..monad wrap (set.new Hash<a>)))) (def: #export (dictionary Hash<a> size key-gen value-gen) (All [k v] (-> (Hash k) Nat (Random k) (Random v) (Random (Dictionary k v)))) (if (n/> 0 size) - (do Monad<Random> + (do ..monad [kv (dictionary Hash<a> (dec size) key-gen value-gen)] (loop [_ []] (do @ @@ -259,7 +260,7 @@ (if (n/= size (dictionary.size kv+)) (wrap kv+) (recur []))))) - (:: Monad<Random> wrap (dictionary.new Hash<a>)))) + (:: ..monad wrap (dictionary.new Hash<a>)))) (def: #export (run prng calc) (All [a] (-> PRNG (Random a) [PRNG a])) diff --git a/stdlib/source/lux/platform/compiler.lux b/stdlib/source/lux/platform/compiler.lux index d6c6d82d9..b4fdd541e 100644 --- a/stdlib/source/lux/platform/compiler.lux +++ b/stdlib/source/lux/platform/compiler.lux @@ -7,7 +7,6 @@ [collection ["." dictionary (#+ Dictionary)]]] [world - ["." binary (#+ Binary)] ["." file (#+ File)]]] [/ [meta @@ -16,29 +15,32 @@ [descriptor (#+ Module)] [document (#+ Document)]]]]) -(type: #export Code Text) +(type: #export Code + Text) -(type: #export Parameter Text) +(type: #export Parameter + Text) (type: #export Input {#module Module #file File + #hash Nat #code Code}) -(type: #export Output - (Dictionary Text Binary)) +(type: #export (Output o) + (Dictionary Text o)) -(type: #export (Compilation d) +(type: #export (Compilation d o) {#dependencies (List Module) #process (-> Archive - (Error (Either (Compilation d) - [(Document d) Output])))}) + (Error (Either (Compilation d o) + [(Document d) (Output o)])))}) -(type: #export (Compiler d) - (-> (Key d) (List Parameter) Input (Compilation d))) +(type: #export (Compiler d o) + (-> Input (Compilation d o))) -(type: #export (Importer !) - (-> (file.System !) Module Archive (! (Error Archive)))) +(type: #export (Instancer d o) + (-> (Key d) (List Parameter) (Compiler d o))) (exception: #export (cannot-compile {module Module}) (ex.report ["Module" module])) diff --git a/stdlib/source/lux/platform/compiler/cli.lux b/stdlib/source/lux/platform/compiler/cli.lux index 55ce35145..7e92b2c34 100644 --- a/stdlib/source/lux/platform/compiler/cli.lux +++ b/stdlib/source/lux/platform/compiler/cli.lux @@ -4,10 +4,12 @@ ["p" parser]] ["." cli (#+ CLI)] [world - [file (#+ File)]]]) + [file (#+ File)]]] + [/// + [importer (#+ Source)]]) (type: #export Configuration - {#sources (List File) + {#sources (List Source) #target File #module Text}) diff --git a/stdlib/source/lux/platform/compiler/default/evaluation.lux b/stdlib/source/lux/platform/compiler/default/evaluation.lux index 157596e84..1f21304ca 100644 --- a/stdlib/source/lux/platform/compiler/default/evaluation.lux +++ b/stdlib/source/lux/platform/compiler/default/evaluation.lux @@ -25,12 +25,12 @@ (translation.Phase anchor expression statement) Eval)) (function (eval count type exprC) - (do phase.Monad<Operation> + (do phase.monad [exprA (type.with-type type (expressionA.compile exprC))] - (phase.lift (do error.Monad<Error> + (phase.lift (do error.monad [exprS (|> exprA expressionS.phase (phase.run synthesis-state))] (phase.run translation-state - (do phase.Monad<Operation> + (do phase.monad [exprO (translate exprS)] (translation.evaluate! (format "eval" (%n count)) exprO)))))))) diff --git a/stdlib/source/lux/platform/compiler/default/init.lux b/stdlib/source/lux/platform/compiler/default/init.lux index 012ab3ea9..b71596150 100644 --- a/stdlib/source/lux/platform/compiler/default/init.lux +++ b/stdlib/source/lux/platform/compiler/default/init.lux @@ -6,7 +6,7 @@ [data ["." product] ["." error (#+ Error)] - ["." text ("text/." Hash<Text>)] + ["." text ("text/." hash)] [collection ["." dictionary]]] ["." macro] @@ -54,7 +54,7 @@ (def: refresh (All [anchor expression statement] (statement.Operation anchor expression statement Any)) - (do phase.Monad<Operation> + (do phase.monad [[bundle state] phase.get-state #let [eval (evaluation.evaluator (get@ [#statement.synthesis #statement.state] state) (get@ [#statement.translation #statement.state] state) @@ -114,7 +114,7 @@ (def: (begin hash input) (-> Nat ///.Input <Operation>) (statement.lift-analysis - (do phase.Monad<Operation> + (do phase.monad [#let [module (get@ #///.module input)] _ (module.create hash module) _ (analysis.set-current-module module)] @@ -127,7 +127,7 @@ (def: (iteration reader) (-> Reader <Operation>) - (do phase.Monad<Operation> + (do phase.monad [code (statement.lift-analysis (..read reader)) _ (totalS.phase code)] @@ -135,7 +135,7 @@ (def: (loop module) (-> Module <Operation>) - (do phase.Monad<Operation> + (do phase.monad [reader (statement.lift-analysis (..reader module syntax.no-aliases))] (function (_ state) @@ -151,7 +151,7 @@ (def: (compile hash input) (-> Nat ///.Input <Operation>) - (do phase.Monad<Operation> + (do phase.monad [#let [module (get@ #///.module input)] _ (..begin hash input) _ (..loop module)] @@ -174,11 +174,11 @@ dependencies (default-dependencies prelude input)] {#///.dependencies dependencies #///.process (function (_ archive) - (do error.Monad<Error> + (do error.monad [[state' analysis-module] (phase.run' state (: (All [anchor expression statement] (statement.Operation anchor expression statement .Module)) - (do phase.Monad<Operation> + (do phase.monad [_ (compile hash input)] (statement.lift-analysis (extension.lift @@ -189,7 +189,7 @@ #descriptor.references dependencies #descriptor.state #.Compiled}]] (wrap (#.Right [(document.write key descriptor analysis-module) - (dictionary.new text.Hash<Text>)]))))}))) + (dictionary.new text.hash)]))))}))) (def: #export key (Key .Module) diff --git a/stdlib/source/lux/platform/compiler/default/platform.lux b/stdlib/source/lux/platform/compiler/default/platform.lux index 10dfd6ebb..7e3846c09 100644 --- a/stdlib/source/lux/platform/compiler/default/platform.lux +++ b/stdlib/source/lux/platform/compiler/default/platform.lux @@ -28,7 +28,7 @@ ## (def: (write-module target-dir file-name module-name module outputs) ## (-> File Text Text Module Outputs (Process Any)) -## (do io.Monad<Process> +## (do (error.with-error io.monad) ## [_ (monad.map @ (product.uncurry (&io.write target-dir)) ## (dictionary.entries outputs))] ## (&io.write target-dir @@ -48,7 +48,7 @@ (phase.run' (init.state (get@ #host platform) (get@ #phase platform) translation-bundle)) - (:: error.Functor<Error> map product.left) + (:: error.functor map product.left) (:: (get@ #file-system platform) lift)) ## (case (runtimeT.translate ## (initL.compiler (io.run js.init)) diff --git a/stdlib/source/lux/platform/compiler/default/syntax.lux b/stdlib/source/lux/platform/compiler/default/syntax.lux index a1bb9f3ea..c76857aab 100644 --- a/stdlib/source/lux/platform/compiler/default/syntax.lux +++ b/stdlib/source/lux/platform/compiler/default/syntax.lux @@ -31,7 +31,11 @@ ["ex" exception (#+ exception:)]] [data ["." error (#+ Error)] - ["." number] + [number + ["." nat] + ["." int] + ["." rev] + ["." frac]] ["." text [lexer (#+ Offset)] format] @@ -82,7 +86,7 @@ ) (type: #export Aliases (Dictionary Text Text)) -(def: #export no-aliases Aliases (dictionary.new text.Hash<Text>)) +(def: #export no-aliases Aliases (dictionary.new text.hash)) (def: #export prelude "lux") @@ -302,8 +306,8 @@ (def: no-exponent Offset 0) -(with-expansions [<int-output> (as-is (!number-output start end number.Codec<Text,Int> #.Int)) - <frac-output> (as-is (!number-output start end number.Codec<Text,Frac> #.Frac)) +(with-expansions [<int-output> (as-is (!number-output start end int.decimal #.Int)) + <frac-output> (as-is (!number-output start end frac.decimal #.Frac)) <failure> (ex.throw unrecognized-input [where "Frac" source-code offset])] (def: (parse-frac source-code//size start [where offset source-code]) (-> Nat Offset Parser) @@ -351,8 +355,8 @@ (recur (!inc g!end)) (!number-output start g!end <codec> <tag>)))))] - [!parse-nat number.Codec<Text,Nat> #.Nat] - [!parse-rev number.Codec<Text,Rev> #.Rev] + [!parse-nat nat.decimal #.Nat] + [!parse-rev rec.decimal #.Rev] ) (template: (!parse-signed source-code//size offset where source-code @end) diff --git a/stdlib/source/lux/platform/compiler/host/scheme.lux b/stdlib/source/lux/platform/compiler/host/scheme.lux index 8d5cbdbcd..f3550ad88 100644 --- a/stdlib/source/lux/platform/compiler/host/scheme.lux +++ b/stdlib/source/lux/platform/compiler/host/scheme.lux @@ -7,7 +7,7 @@ ["." text format] [collection - ["." list ("list/." Functor<List> Fold<List>)]]] + ["." list ("list/." functor fold)]]] [type abstract]]) diff --git a/stdlib/source/lux/platform/compiler/meta/archive.lux b/stdlib/source/lux/platform/compiler/meta/archive.lux index f36a0b754..c318bfaf7 100644 --- a/stdlib/source/lux/platform/compiler/meta/archive.lux +++ b/stdlib/source/lux/platform/compiler/meta/archive.lux @@ -38,14 +38,14 @@ (abstract: #export Archive {} - (Dictionary Text <Document>) + (Dictionary Text [Descriptor <Document>]) (def: #export empty Archive - (:abstraction (dictionary.new text.Hash<Text>))) + (:abstraction (dictionary.new text.hash))) - (def: #export (add name document archive) - (-> Module <Document> Archive (Error Archive)) + (def: #export (add name descriptor document archive) + (-> Module Descriptor <Document> Archive (Error Archive)) (case (dictionary.get name (:representation archive)) (#.Some existing) (if (is? document existing) @@ -53,11 +53,13 @@ (ex.throw cannot-replace-document [name existing document])) #.None - (#error.Success (:abstraction (dictionary.put name document - (:representation archive)))))) + (#error.Success (|> archive + :representation + (dictionary.put name [descriptor document]) + :abstraction)))) (def: #export (find name archive) - (-> Module Archive (Error <Document>)) + (-> Module Archive (Error [Descriptor <Document>])) (case (dictionary.get name (:representation archive)) (#.Some document) (#error.Success document) @@ -67,9 +69,9 @@ (def: #export (merge additions archive) (-> Archive Archive (Error Archive)) - (monad.fold error.Monad<Error> - (function (_ [name' document'] archive') - (..add name' document' archive')) + (monad.fold error.monad + (function (_ [name' descriptor+document'] archive') + (..add name' descriptor+document' archive')) archive (dictionary.entries (:representation additions)))) )) diff --git a/stdlib/source/lux/platform/compiler/meta/archive/descriptor.lux b/stdlib/source/lux/platform/compiler/meta/archive/descriptor.lux index 6c7e6744e..328240e6c 100644 --- a/stdlib/source/lux/platform/compiler/meta/archive/descriptor.lux +++ b/stdlib/source/lux/platform/compiler/meta/archive/descriptor.lux @@ -1,5 +1,8 @@ (.module: [lux (#- Module) + [data + [collection + [set (#+ Set)]]] [world [file (#+ File)]]]) @@ -9,5 +12,5 @@ {#hash Nat #name Module #file File - #references (List Module) + #references (Set Module) #state Module-State}) diff --git a/stdlib/source/lux/platform/compiler/meta/archive/document.lux b/stdlib/source/lux/platform/compiler/meta/archive/document.lux index b99ff9b72..5c077080f 100644 --- a/stdlib/source/lux/platform/compiler/meta/archive/document.lux +++ b/stdlib/source/lux/platform/compiler/meta/archive/document.lux @@ -11,25 +11,23 @@ [// ["." signature (#+ Signature)] ["." key (#+ Key)] - ["." descriptor (#+ Module Descriptor)]]) + [descriptor (#+ Module)]]) ## Document -(exception: #export (invalid-signature {module Module} {expected Signature} {actual Signature}) - (ex.report ["Module" module] - ["Expected" (signature.description expected)] +(exception: #export (invalid-signature {expected Signature} {actual Signature}) + (ex.report ["Expected" (signature.description expected)] ["Actual" (signature.description actual)])) (abstract: #export (Document d) {} {#signature Signature - #descriptor Descriptor #content d} (def: #export (read key document) (All [d] (-> (Key d) (Document Any) (Error d))) - (let [[document//signature document//descriptor document//content] (:representation document)] - (if (:: signature.Equivalence<Signature> = + (let [[document//signature document//content] (:representation document)] + (if (:: signature.equivalence = (key.signature key) document//signature) (#error.Success (:share [e] @@ -37,14 +35,12 @@ key} {e document//content})) - (ex.throw invalid-signature [(get@ #descriptor.name document//descriptor) - (key.signature key) + (ex.throw invalid-signature [(key.signature key) document//signature])))) - (def: #export (write key descriptor content) - (All [d] (-> (Key d) Descriptor d (Document d))) + (def: #export (write key content) + (All [d] (-> (Key d) d (Document d))) (:abstraction {#signature (key.signature key) - #descriptor descriptor #content content})) (def: #export signature diff --git a/stdlib/source/lux/platform/compiler/meta/archive/signature.lux b/stdlib/source/lux/platform/compiler/meta/archive/signature.lux index 5332b79c3..fb96aec58 100644 --- a/stdlib/source/lux/platform/compiler/meta/archive/signature.lux +++ b/stdlib/source/lux/platform/compiler/meta/archive/signature.lux @@ -14,9 +14,9 @@ {#name Name #version Version}) -(def: #export Equivalence<Signature> +(def: #export equivalence (Equivalence Signature) - (equivalence.product name.Equivalence<Name> text.Equivalence<Text>)) + (equivalence.product name.equivalence text.equivalence)) (def: #export (description signature) (-> Signature Text) diff --git a/stdlib/source/lux/platform/compiler/meta/cache.lux b/stdlib/source/lux/platform/compiler/meta/cache.lux index ceed96164..c54fac935 100644 --- a/stdlib/source/lux/platform/compiler/meta/cache.lux +++ b/stdlib/source/lux/platform/compiler/meta/cache.lux @@ -5,7 +5,7 @@ ["ex" exception (#+ exception:)] pipe] [data - ["." bit ("bit/." Equivalence<Bit>)] + ["." bit ("bit/." equivalence)] ["." maybe] ["." error] ["." product] @@ -14,7 +14,7 @@ ["." text [format (#- Format)]] [collection - ["." list ("list/." Functor<List> Fold<List>)] + ["." list ("list/." functor fold)] ["dict" dictionary (#+ Dictionary)] ["." set (#+ Set)]]] [world @@ -122,12 +122,12 @@ (do (:: System<m> &monad) [document' (:: System<m> read (io/archive.document System<m> root module)) [module' source-code] (io/context.read System<m> contexts module) - #let [current-hash (:: text.Hash<Text> hash source-code)]] - (case (do error.Monad<Error> + #let [current-hash (:: text.hash hash source-code)]] + (case (do error.monad [[signature descriptor content] (binary.read (..document binary) document') #let [[document-hash _file references _state] descriptor] _ (ex.assert mismatched-signature [module (get@ #archive.signature key) signature] - (:: archive.Equivalence<Signature> = + (:: archive.equivalence = (get@ #archive.signature key) signature)) _ (ex.assert stale-document [module current-hash document-hash] @@ -157,13 +157,13 @@ #.None archive)) (: (Dictionary Text [(List Module) (Ex [d] (Document d))]) - (dict.new text.Hash<Text>))))])) + (dict.new text.hash))))])) #let [candidate-entries (dict.entries candidate) candidate-dependencies (list/map (product.both id product.left) candidate-entries) candidate-archive (|> candidate-entries (list/map (product.both id product.right)) - (dict.from-list text.Hash<Text>)) + (dict.from-list text.hash)) graph (|> candidate dict.entries (list/map (product.both id product.left)) diff --git a/stdlib/source/lux/platform/compiler/meta/cache/dependency.lux b/stdlib/source/lux/platform/compiler/meta/cache/dependency.lux index e63fa192b..d18b92d59 100644 --- a/stdlib/source/lux/platform/compiler/meta/cache/dependency.lux +++ b/stdlib/source/lux/platform/compiler/meta/cache/dependency.lux @@ -3,14 +3,14 @@ [data ["." text] [collection - [list ("list/." Functor<List> Fold<List>)] + [list ("list/." functor fold)] ["dict" dictionary (#+ Dictionary)]]]] [///io (#+ Module)] [///archive (#+ Archive)]) (type: #export Graph (Dictionary Module (List Module))) -(def: #export empty Graph (dict.new text.Hash<Text>)) +(def: #export empty Graph (dict.new text.hash)) (def: #export (add to from) (-> Module Module Graph Graph) diff --git a/stdlib/source/lux/platform/compiler/phase.lux b/stdlib/source/lux/platform/compiler/phase.lux index a81d5dfa7..203ed73bc 100644 --- a/stdlib/source/lux/platform/compiler/phase.lux +++ b/stdlib/source/lux/platform/compiler/phase.lux @@ -6,7 +6,7 @@ [monad (#+ do)]] [data ["." product] - ["." error (#+ Error) ("error/." Functor<Error>)] + ["." error (#+ Error) ("error/." functor)] ["." text format]] [time @@ -19,8 +19,8 @@ (type: #export (Operation s o) (state.State' Error s o)) -(def: #export Monad<Operation> - (state.Monad<State'> error.Monad<Error>)) +(def: #export monad + (state.monad error.monad)) (type: #export (Phase s i o) (-> i (Operation s o))) @@ -35,7 +35,7 @@ (-> s (Operation s o) (Error o))) (|> state operation - (:: error.Monad<Error> map product.right))) + (:: error.monad map product.right))) (def: #export get-state (All [s o] @@ -55,17 +55,17 @@ (Operation s' o) (Operation s o))) (function (_ state) - (do error.Monad<Error> + (do error.monad [[state' output] (operation (get state))] (wrap [(set state' state) output])))) (def: #export fail (-> Text Operation) - (|>> error.fail (state.lift error.Monad<Error>))) + (|>> error.fail (state.lift error.monad))) (def: #export (throw exception parameters) (All [e] (-> (Exception e) e Operation)) - (state.lift error.Monad<Error> + (state.lift error.monad (ex.throw exception parameters))) (def: #export (lift error) @@ -75,7 +75,7 @@ (syntax: #export (assert exception message test) (wrap (list (` (if (~ test) - (:: ..Monad<Operation> (~' wrap) []) + (:: ..monad (~' wrap) []) (..throw (~ exception) (~ message))))))) (def: #export (with-stack exception message action) @@ -94,7 +94,7 @@ (Phase s1 t o) (Phase [s0 s1] i o))) (function (_ input [pre/state post/state]) - (do error.Monad<Error> + (do error.monad [[pre/state' temp] (pre input pre/state) [post/state' output] (post temp post/state)] (wrap [[pre/state' post/state'] output])))) @@ -102,7 +102,7 @@ (def: #export (timed definition description operation) (All [s a] (-> Name Text (Operation s a) (Operation s a))) - (do Monad<Operation> + (do ..monad [_ (wrap []) #let [pre (io.run instant.now)] output operation diff --git a/stdlib/source/lux/platform/compiler/phase/analysis.lux b/stdlib/source/lux/platform/compiler/phase/analysis.lux index c5256436f..d1bd6a986 100644 --- a/stdlib/source/lux/platform/compiler/phase/analysis.lux +++ b/stdlib/source/lux/platform/compiler/phase/analysis.lux @@ -6,10 +6,10 @@ ["." product] ["." error] ["." maybe] - ["." text ("text/." Equivalence<Text>) + ["." text ("text/." equivalence) format] [collection - ["." list ("list/." Functor<List> Fold<List>)]]] + ["." list ("list/." functor fold)]]] ["." function]] [// ["." extension (#+ Extension)] diff --git a/stdlib/source/lux/platform/compiler/phase/analysis/case.lux b/stdlib/source/lux/platform/compiler/phase/analysis/case.lux index d7b020932..343d4c813 100644 --- a/stdlib/source/lux/platform/compiler/phase/analysis/case.lux +++ b/stdlib/source/lux/platform/compiler/phase/analysis/case.lux @@ -10,7 +10,7 @@ [text format] [collection - ["." list ("list/." Fold<List> Monoid<List> Functor<List>)]]] + ["." list ("list/." fold monoid functor)]]] ["." type ["." check]] ["." macro @@ -69,7 +69,7 @@ caseT caseT] (.case caseT (#.Var id) - (do ///.Monad<Operation> + (do ///.monad [?caseT' (//type.with-env (check.read id))] (.case ?caseT' @@ -86,7 +86,7 @@ (recur (#.Cons env envs) unquantifiedT) (#.ExQ _) - (do ///.Monad<Operation> + (do ///.monad [[ex-id exT] (//type.with-env check.existential)] (recur envs (maybe.assume (type.apply (list exT) caseT)))) @@ -94,9 +94,9 @@ (#.Apply inputT funcT) (.case funcT (#.Var funcT-id) - (do ///.Monad<Operation> + (do ///.monad [funcT' (//type.with-env - (do check.Monad<Check> + (do check.monad [?funct' (check.read funcT-id)] (.case ?funct' (#.Some funct') @@ -119,15 +119,15 @@ type.flatten-tuple (list/map (re-quantify envs)) type.tuple - (:: ///.Monad<Operation> wrap)) + (:: ///.monad wrap)) _ - (:: ///.Monad<Operation> wrap (re-quantify envs caseT))))) + (:: ///.monad wrap (re-quantify envs caseT))))) (def: (analyse-primitive type inputT cursor output next) (All [a] (-> Type Type Cursor Pattern (Operation a) (Operation [Pattern a]))) (//.with-cursor cursor - (do ///.Monad<Operation> + (do ///.monad [_ (//type.with-env (check.check inputT type)) outputA next] @@ -154,7 +154,7 @@ (.case pattern [cursor (#.Identifier ["" name])] (//.with-cursor cursor - (do ///.Monad<Operation> + (do ///.monad [outputA (scope.with-local [name inputT] next) idx scope.next-local] @@ -176,7 +176,7 @@ [cursor (#.Tuple sub-patterns)] (//.with-cursor cursor - (do ///.Monad<Operation> + (do ///.monad [inputT' (simplify-case inputT)] (.case inputT' (#.Product _) @@ -216,7 +216,7 @@ ))) [cursor (#.Record record)] - (do ///.Monad<Operation> + (do ///.monad [record (structure.normalize record) [members recordT] (structure.order record) _ (//type.with-env @@ -229,7 +229,7 @@ (^ [cursor (#.Form (list& [_ (#.Nat idx)] values))]) (//.with-cursor cursor - (do ///.Monad<Operation> + (do ///.monad [inputT' (simplify-case inputT)] (.case inputT' (#.Sum _) @@ -239,7 +239,7 @@ (.case (list.nth idx flat-sum) (^multi (#.Some caseT) (n/< num-cases idx)) - (do ///.Monad<Operation> + (do ///.monad [[testP nextA] (if (and (n/> num-cases size-sum) (n/= (dec num-cases) idx)) (analyse-pattern #.None @@ -262,7 +262,7 @@ (^ [cursor (#.Form (list& [_ (#.Tag tag)] values))]) (//.with-cursor cursor - (do ///.Monad<Operation> + (do ///.monad [tag (extension.lift (macro.normalize tag)) [idx group variantT] (extension.lift (macro.resolve-tag tag)) _ (//type.with-env @@ -277,7 +277,7 @@ (-> Phase Code (List [Code Code]) (Operation Analysis)) (.case branches (#.Cons [patternH bodyH] branchesT) - (do ///.Monad<Operation> + (do ///.monad [[inputT inputA] (//type.with-inference (analyse inputC)) outputH (analyse-pattern #.None inputT patternH (analyse bodyH)) @@ -287,7 +287,7 @@ branchesT) outputHC (|> outputH product.left coverage.determine) outputTC (monad.map @ (|>> product.left coverage.determine) outputT) - _ (.case (monad.fold error.Monad<Error> coverage.merge outputHC outputTC) + _ (.case (monad.fold error.monad coverage.merge outputHC outputTC) (#error.Success coverage) (///.assert non-exhaustive-pattern-matching [inputC branches coverage] (coverage.exhaustive? coverage)) diff --git a/stdlib/source/lux/platform/compiler/phase/analysis/case/coverage.lux b/stdlib/source/lux/platform/compiler/phase/analysis/case/coverage.lux index bdf524f73..b21df1fcd 100644 --- a/stdlib/source/lux/platform/compiler/phase/analysis/case/coverage.lux +++ b/stdlib/source/lux/platform/compiler/phase/analysis/case/coverage.lux @@ -5,16 +5,16 @@ ["ex" exception (#+ exception:)] equivalence] [data - [bit ("bit/." Equivalence<Bit>)] + [bit ("bit/." equivalence)] ["." number] - ["." error (#+ Error) ("error/." Monad<Error>)] + ["." error (#+ Error) ("error/." monad)] ["." maybe] ["." text format] [collection - ["." list ("list/." Functor<List> Fold<List>)] + ["." list ("list/." functor fold)] ["." dictionary (#+ Dictionary)]]]] - ["." //// ("operation/." Monad<Operation>)] + ["." //// ("operation/." monad)] ["." /// (#+ Pattern Variant Operation)]) (exception: #export (invalid-tuple-pattern) @@ -119,11 +119,11 @@ (////.throw invalid-tuple-pattern []) (#.Cons lastP prevsP+) - (do ////.Monad<Operation> + (do ////.monad [lastC (determine lastP)] - (monad.fold ////.Monad<Operation> + (monad.fold ////.monad (function (_ leftP rightC) - (do ////.Monad<Operation> + (do ////.monad [leftC (determine leftP)] (case rightC #Exhaustive @@ -136,7 +136,7 @@ ## Variant patterns can be shown to be exhaustive if all the possible ## cases are handled exhaustively. (#///.Complex (#///.Variant [lefts right? value])) - (do ////.Monad<Operation> + (do ////.monad [value-coverage (determine value) #let [idx (if right? (inc lefts) @@ -144,7 +144,7 @@ (wrap (#Variant (if right? (#.Some idx) #.None) - (|> (dictionary.new number.Hash<Nat>) + (|> (dictionary.new number.hash) (dictionary.put idx value-coverage))))))) (def: (xor left right) @@ -183,7 +183,7 @@ [(#Variant allR casesR) (#Variant allS casesS)] (and (n/= (cases allR) (cases allS)) - (:: (dictionary.Equivalence<Dictionary> =) = casesR casesS)) + (:: (dictionary.equivalence =) = casesR casesS)) [(#Seq leftR rightR) (#Seq leftS rightS)] (and (= leftR leftS) @@ -200,7 +200,7 @@ _ #0))) -(open: "coverage/." Equivalence<Coverage>) +(open: "coverage/." ..equivalence) (exception: #export (variants-do-not-match {addition-cases Nat} {so-far-cases Nat}) (ex.report ["So-far Cases" (%n so-far-cases)] @@ -229,11 +229,11 @@ (not (n/= addition-cases so-far-cases))) (ex.throw variants-do-not-match [addition-cases so-far-cases]) - (:: (dictionary.Equivalence<Dictionary> Equivalence<Coverage>) = casesSF casesA) + (:: (dictionary.equivalence ..equivalence) = casesSF casesA) (ex.throw redundant-pattern [so-far addition]) ## else - (do error.Monad<Error> + (do error.monad [casesM (monad.fold @ (function (_ [tagA coverageA] casesSF') (case (dictionary.get tagA casesSF') @@ -263,7 +263,7 @@ (case [(coverage/= leftSF leftA) (coverage/= rightSF rightA)] ## Same prefix [#1 #0] - (do error.Monad<Error> + (do error.monad [rightM (merge rightA rightSF)] (if (exhaustive? rightM) ## If all that follows is exhaustive, then it can be safely dropped @@ -274,7 +274,7 @@ ## Same suffix [#0 #1] - (do error.Monad<Error> + (do error.monad [leftM (merge leftA leftSF)] (wrap (#Seq leftM rightA))) @@ -314,7 +314,7 @@ ## This process must be repeated until no further productive ## merges can be done. [_ (#Alt leftS rightS)] - (do error.Monad<Error> + (do error.monad [#let [fuse-once (: (-> Coverage (List Coverage) (Error [(Maybe Coverage) (List Coverage)])) diff --git a/stdlib/source/lux/platform/compiler/phase/analysis/expression.lux b/stdlib/source/lux/platform/compiler/phase/analysis/expression.lux index 1da6520a5..3ce70fe9b 100644 --- a/stdlib/source/lux/platform/compiler/phase/analysis/expression.lux +++ b/stdlib/source/lux/platform/compiler/phase/analysis/expression.lux @@ -26,7 +26,7 @@ (def: #export (compile code) Phase - (do ///.Monad<Operation> + (do ///.monad [expectedT (extension.lift macro.expected-type)] (let [[cursor code'] code] ## The cursor must be set in the state for the sake diff --git a/stdlib/source/lux/platform/compiler/phase/analysis/function.lux b/stdlib/source/lux/platform/compiler/phase/analysis/function.lux index a996457d9..a95412e42 100644 --- a/stdlib/source/lux/platform/compiler/phase/analysis/function.lux +++ b/stdlib/source/lux/platform/compiler/phase/analysis/function.lux @@ -8,7 +8,7 @@ ["." text format] [collection - ["." list ("list/." Fold<List> Monoid<List> Monad<List>)]]] + ["." list ("list/." fold monoid monad)]]] ["." type ["." check]] ["." macro]] @@ -35,7 +35,7 @@ (def: #export (function analyse function-name arg-name body) (-> Phase Text Text Code (Operation Analysis)) - (do ///.Monad<Operation> + (do ///.monad [functionT (extension.lift macro.expected-type)] (loop [expectedT functionT] (///.with-stack cannot-analyse [expectedT function-name arg-name body] @@ -97,6 +97,6 @@ (def: #export (apply analyse functionT functionA argsC+) (-> Phase Type Analysis (List Code) (Operation Analysis)) (<| (///.with-stack cannot-apply [functionT argsC+]) - (do ///.Monad<Operation> + (do ///.monad [[applyT argsA+] (inference.general analyse functionT argsC+)]) (wrap (//.apply [functionA argsA+])))) diff --git a/stdlib/source/lux/platform/compiler/phase/analysis/inference.lux b/stdlib/source/lux/platform/compiler/phase/analysis/inference.lux index 010bdc437..7ce10cb32 100644 --- a/stdlib/source/lux/platform/compiler/phase/analysis/inference.lux +++ b/stdlib/source/lux/platform/compiler/phase/analysis/inference.lux @@ -8,11 +8,11 @@ ["." text format] [collection - ["." list ("list/." Functor<List>)]]] + ["." list ("list/." functor)]]] ["." type ["." check]] ["." macro]] - ["." /// ("operation/." Monad<Operation>) + ["." /// ("operation/." monad) ["." extension]] [// (#+ Tag Analysis Operation Phase)] ["." //type]) @@ -84,7 +84,7 @@ (def: new-named-type (Operation Type) - (do ///.Monad<Operation> + (do ///.monad [cursor (extension.lift macro.cursor) [ex-id _] (//type.with-env check.existential)] (wrap (named-type cursor ex-id)))) @@ -100,7 +100,7 @@ (-> Phase Type (List Code) (Operation [Type (List Analysis)])) (case args #.Nil - (do ///.Monad<Operation> + (do ///.monad [_ (//type.infer inferT)] (wrap [inferT (list)])) @@ -110,12 +110,12 @@ (general analyse unnamedT args) (#.UnivQ _) - (do ///.Monad<Operation> + (do ///.monad [[var-id varT] (//type.with-env check.var)] (general analyse (maybe.assume (type.apply (list varT) inferT)) args)) (#.ExQ _) - (do ///.Monad<Operation> + (do ///.monad [[var-id varT] (//type.with-env check.var) output (general analyse (maybe.assume (type.apply (list varT) inferT)) @@ -146,7 +146,7 @@ ## avoided in Lux code, since the inference algorithm can piece ## things together more easily. (#.Function inputT outputT) - (do ///.Monad<Operation> + (do ///.monad [[outputT' args'A] (general analyse outputT args') argA (<| (///.with-stack cannot-infer-argument [inputT argC]) (//type.with-type inputT) @@ -154,7 +154,7 @@ (wrap [outputT' (list& argA args'A)])) (#.Var infer-id) - (do ///.Monad<Operation> + (do ///.monad [?inferT' (//type.with-env (check.read infer-id))] (case ?inferT' (#.Some inferT') @@ -176,7 +176,7 @@ (^template [<tag>] (<tag> env bodyT) - (do ///.Monad<Operation> + (do ///.monad [bodyT+ (record bodyT)] (wrap (<tag> env bodyT+)))) ([#.UnivQ] @@ -203,13 +203,13 @@ currentT inferT] (case currentT (#.Named name unnamedT) - (do ///.Monad<Operation> + (do ///.monad [unnamedT+ (recur depth unnamedT)] (wrap unnamedT+)) (^template [<tag>] (<tag> env bodyT) - (do ///.Monad<Operation> + (do ///.monad [bodyT+ (recur (inc depth) bodyT)] (wrap (<tag> env bodyT+)))) ([#.UnivQ] diff --git a/stdlib/source/lux/platform/compiler/phase/analysis/macro.lux b/stdlib/source/lux/platform/compiler/phase/analysis/macro.lux index 64dabaf43..d02478454 100644 --- a/stdlib/source/lux/platform/compiler/phase/analysis/macro.lux +++ b/stdlib/source/lux/platform/compiler/phase/analysis/macro.lux @@ -9,7 +9,7 @@ format] [collection [array (#+ Array)] - [list ("list/." Functor<List>)]]] + [list ("list/." functor)]]] ["." macro] ["." host (#+ import:)]] ["." ///]) @@ -49,7 +49,7 @@ (def: #export (expand name macro inputs) (-> Name Macro (List Code) (Meta (List Code))) (function (_ state) - (do error.Monad<Error> + (do error.monad [apply-method (|> macro (:coerce Object) (Object::getClass) @@ -69,7 +69,7 @@ (def: #export (expand-one name macro inputs) (-> Name Macro (List Code) (Meta Code)) - (do macro.Monad<Meta> + (do macro.monad [expansion (expand name macro inputs)] (case expansion (^ (list single)) diff --git a/stdlib/source/lux/platform/compiler/phase/analysis/module.lux b/stdlib/source/lux/platform/compiler/phase/analysis/module.lux index a8f6bda03..9905ee2dc 100644 --- a/stdlib/source/lux/platform/compiler/phase/analysis/module.lux +++ b/stdlib/source/lux/platform/compiler/phase/analysis/module.lux @@ -5,11 +5,11 @@ ["ex" exception (#+ exception:)] pipe] [data - ["." text ("text/." Equivalence<Text>) + ["." text ("text/." equivalence) format] ["." error] [collection - ["." list ("list/." Fold<List> Functor<List>)] + ["." list ("list/." fold functor)] [dictionary ["." plist]]]] ["." macro]] @@ -63,7 +63,7 @@ (def: #export (set-annotations annotations) (-> Code (Operation Any)) - (do ///.Monad<Operation> + (do ///.monad [self-name (extension.lift macro.current-module-name) self (extension.lift macro.current-module)] (case (get@ #.module-annotations self) @@ -80,7 +80,7 @@ (def: #export (import module) (-> Text (Operation Any)) - (do ///.Monad<Operation> + (do ///.monad [self-name (extension.lift macro.current-module-name)] (extension.lift (function (_ state) @@ -91,7 +91,7 @@ (def: #export (alias alias module) (-> Text Text (Operation Any)) - (do ///.Monad<Operation> + (do ///.monad [self-name (extension.lift macro.current-module-name)] (extension.lift (function (_ state) @@ -113,7 +113,7 @@ (def: #export (define name definition) (-> Text Definition (Operation Any)) - (do ///.Monad<Operation> + (do ///.monad [self-name (extension.lift macro.current-module-name) self (extension.lift macro.current-module)] (extension.lift @@ -144,7 +144,7 @@ (def: #export (with-module hash name action) (All [a] (-> Nat Text (Operation a) (Operation [Module a]))) - (do ///.Monad<Operation> + (do ///.monad [_ (create hash name) output (//.with-current-module name action) @@ -210,7 +210,7 @@ (def: (ensure-undeclared-tags module-name tags) (-> Text (List Tag) (Operation Any)) - (do ///.Monad<Operation> + (do ///.monad [bindings (..tags module-name) _ (monad.map @ (function (_ tag) @@ -225,7 +225,7 @@ (def: #export (declare-tags tags exported? type) (-> (List Tag) Bit Type (Operation Any)) - (do ///.Monad<Operation> + (do ///.monad [self-name (extension.lift macro.current-module-name) [type-module type-name] (case type (#.Named type-name _) diff --git a/stdlib/source/lux/platform/compiler/phase/analysis/primitive.lux b/stdlib/source/lux/platform/compiler/phase/analysis/primitive.lux index bd42825d3..b46983293 100644 --- a/stdlib/source/lux/platform/compiler/phase/analysis/primitive.lux +++ b/stdlib/source/lux/platform/compiler/phase/analysis/primitive.lux @@ -10,7 +10,7 @@ (do-template [<name> <type> <tag>] [(def: #export (<name> value) (-> <type> (Operation Analysis)) - (do ///.Monad<Operation> + (do ///.monad [_ (typeA.infer <type>)] (wrap (#//.Primitive (<tag> value)))))] @@ -24,6 +24,6 @@ (def: #export unit (Operation Analysis) - (do ///.Monad<Operation> + (do ///.monad [_ (typeA.infer Any)] (wrap (#//.Primitive #//.Unit)))) diff --git a/stdlib/source/lux/platform/compiler/phase/analysis/reference.lux b/stdlib/source/lux/platform/compiler/phase/analysis/reference.lux index 30da3e60f..b7f41a81a 100644 --- a/stdlib/source/lux/platform/compiler/phase/analysis/reference.lux +++ b/stdlib/source/lux/platform/compiler/phase/analysis/reference.lux @@ -5,7 +5,7 @@ ["ex" exception (#+ exception:)]] ["." macro] [data - [text ("text/." Equivalence<Text>) + [text ("text/." equivalence) format]]] ["." // (#+ Analysis Operation) ["." scope] @@ -26,7 +26,7 @@ (def: (definition def-name) (-> Name (Operation Analysis)) (with-expansions [<return> (wrap (|> def-name reference.constant #//.Reference))] - (do ///.Monad<Operation> + (do ///.monad [[actualT def-anns _] (extension.lift (macro.find-def def-name))] (case (macro.get-identifier-ann (name-of #.alias) def-anns) (#.Some real-def-name) @@ -49,7 +49,7 @@ (def: (variable var-name) (-> Text (Operation (Maybe Analysis))) - (do ///.Monad<Operation> + (do ///.monad [?var (scope.find var-name)] (case ?var (#.Some [actualT ref]) @@ -64,7 +64,7 @@ (-> Name (Operation Analysis)) (case reference ["" simple-name] - (do ///.Monad<Operation> + (do ///.monad [?var (variable simple-name)] (case ?var (#.Some varA) diff --git a/stdlib/source/lux/platform/compiler/phase/analysis/scope.lux b/stdlib/source/lux/platform/compiler/phase/analysis/scope.lux index 8cd55e198..c724edad2 100644 --- a/stdlib/source/lux/platform/compiler/phase/analysis/scope.lux +++ b/stdlib/source/lux/platform/compiler/phase/analysis/scope.lux @@ -4,13 +4,13 @@ monad ["ex" exception (#+ exception:)]] [data - [text ("text/." Equivalence<Text>) + [text ("text/." equivalence) format] - ["." maybe ("maybe/." Monad<Maybe>)] + ["." maybe ("maybe/." monad)] ["." product] ["e" error] [collection - ["." list ("list/." Functor<List> Fold<List> Monoid<List>)] + ["." list ("list/." functor fold monoid)] [dictionary ["." plist]]]]] [// (#+ Operation Phase) diff --git a/stdlib/source/lux/platform/compiler/phase/analysis/structure.lux b/stdlib/source/lux/platform/compiler/phase/analysis/structure.lux index 43cb8e0d2..21b2b6e2b 100644 --- a/stdlib/source/lux/platform/compiler/phase/analysis/structure.lux +++ b/stdlib/source/lux/platform/compiler/phase/analysis/structure.lux @@ -13,7 +13,7 @@ [text format] [collection - ["." list ("list/." Functor<List>)] + ["." list ("list/." functor)] ["dict" dictionary (#+ Dictionary)]]] ["." type ["." check]] @@ -82,7 +82,7 @@ (def: #export (sum analyse tag valueC) (-> Phase Nat Code (Operation Analysis)) - (do ///.Monad<Operation> + (do ///.monad [expectedT (extension.lift macro.expected-type)] (///.with-stack cannot-analyse-variant [expectedT tag valueC] (case expectedT @@ -160,7 +160,7 @@ (def: (typed-product analyse members) (-> Phase (List Code) (Operation Analysis)) - (do ///.Monad<Operation> + (do ///.monad [expectedT (extension.lift macro.expected-type) membersA+ (: (Operation (List Analysis)) (loop [membersT+ (type.flatten-tuple expectedT) @@ -187,7 +187,7 @@ (def: #export (product analyse membersC) (-> Phase (List Code) (Operation Analysis)) - (do ///.Monad<Operation> + (do ///.monad [expectedT (extension.lift macro.expected-type)] (///.with-stack cannot-analyse-tuple [expectedT membersC] (case expectedT @@ -254,7 +254,7 @@ (def: #export (tagged-sum analyse tag valueC) (-> Phase Name Code (Operation Analysis)) - (do ///.Monad<Operation> + (do ///.monad [tag (extension.lift (macro.normalize tag)) [idx group variantT] (extension.lift (macro.resolve-tag tag)) expectedT (extension.lift macro.expected-type)] @@ -279,11 +279,11 @@ ## canonical form (with their corresponding module identified). (def: #export (normalize record) (-> (List [Code Code]) (Operation (List [Name Code]))) - (monad.map ///.Monad<Operation> + (monad.map ///.monad (function (_ [key val]) (case key [_ (#.Tag key)] - (do ///.Monad<Operation> + (do ///.monad [key (extension.lift (macro.normalize key))] (wrap [key val])) @@ -299,10 +299,10 @@ (case record ## empty-record = empty-tuple = unit = [] #.Nil - (:: ///.Monad<Operation> wrap [(list) Any]) + (:: ///.monad wrap [(list) Any]) (#.Cons [head-k head-v] _) - (do ///.Monad<Operation> + (do ///.monad [head-k (extension.lift (macro.normalize head-k)) [_ tag-set recordT] (extension.lift (macro.resolve-tag head-k)) #let [size-record (list.size record) @@ -311,7 +311,7 @@ (wrap []) (///.throw record-size-mismatch [size-ts size-record recordT record])) #let [tuple-range (list.indices size-ts) - tag->idx (dict.from-list name.Hash<Name> (list.zip2 tag-set tuple-range))] + tag->idx (dict.from-list name.hash (list.zip2 tag-set tuple-range))] idx->val (monad.fold @ (function (_ [key val] idx->val) (do @ @@ -325,7 +325,7 @@ #.None (///.throw tag-does-not-belong-to-record [key recordT])))) (: (Dictionary Nat Code) - (dict.new number.Hash<Nat>)) + (dict.new number.hash)) record) #let [ordered-tuple (list/map (function (_ idx) (maybe.assume (dict.get idx idx->val))) tuple-range)]] @@ -334,7 +334,7 @@ (def: #export (record analyse members) (-> Phase (List [Code Code]) (Operation Analysis)) - (do ///.Monad<Operation> + (do ///.monad [members (normalize members) [membersC recordT] (order members)] (case membersC diff --git a/stdlib/source/lux/platform/compiler/phase/analysis/type.lux b/stdlib/source/lux/platform/compiler/phase/analysis/type.lux index c3219f5ac..75d691628 100644 --- a/stdlib/source/lux/platform/compiler/phase/analysis/type.lux +++ b/stdlib/source/lux/platform/compiler/phase/analysis/type.lux @@ -35,14 +35,14 @@ (def: #export (infer actualT) (-> Type (Operation Any)) - (do ///.Monad<Operation> + (do ///.monad [expectedT (extension.lift macro.expected-type)] (with-env (tc.check expectedT actualT)))) (def: #export (with-inference action) (All [a] (-> (Operation a) (Operation [Type a]))) - (do ///.Monad<Operation> + (do ///.monad [[_ varT] (..with-env tc.var) output (with-type varT diff --git a/stdlib/source/lux/platform/compiler/phase/extension.lux b/stdlib/source/lux/platform/compiler/phase/extension.lux index ec7323b1e..4e5721c5e 100644 --- a/stdlib/source/lux/platform/compiler/phase/extension.lux +++ b/stdlib/source/lux/platform/compiler/phase/extension.lux @@ -5,10 +5,10 @@ ["ex" exception (#+ exception:)]] [data ["." error (#+ Error)] - ["." text ("text/." Order<Text>) + ["." text ("text/." order) format] [collection - ["." list ("list/." Functor<List>)] + ["." list ("list/." functor)] ["." dictionary (#+ Dictionary)]]] ["." function]] ["." //]) diff --git a/stdlib/source/lux/platform/compiler/phase/extension/analysis/common.lux b/stdlib/source/lux/platform/compiler/phase/extension/analysis/common.lux index 73f0d6c9d..426c8af9e 100644 --- a/stdlib/source/lux/platform/compiler/phase/extension/analysis/common.lux +++ b/stdlib/source/lux/platform/compiler/phase/extension/analysis/common.lux @@ -6,7 +6,7 @@ ["." text format] [collection - ["." list ("list/." Functor<List>)] + ["." list ("list/." functor)] ["." dictionary (#+ Dictionary)]]] [type ["." check]] @@ -30,7 +30,7 @@ (function (_ extension-name analyse args) (let [num-actual (list.size args)] (if (n/= num-expected num-actual) - (do ////.Monad<Operation> + (do ////.monad [_ (typeA.infer outputT) argsA (monad.map @ (function (_ [argT argC]) @@ -61,7 +61,7 @@ (def: lux::is Handler (function (_ extension-name analyse args) - (do ////.Monad<Operation> + (do ////.monad [[var-id varT] (typeA.with-env check.var)] ((binary varT varT Bit extension-name) analyse args)))) @@ -73,7 +73,7 @@ (function (_ extension-name analyse args) (case args (^ (list opC)) - (do ////.Monad<Operation> + (do ////.monad [[var-id varT] (typeA.with-env check.var) _ (typeA.infer (type (Either Text varT))) opA (typeA.with-type (type (IO varT)) @@ -100,7 +100,7 @@ (function (_ extension-name analyse args) (case args (^ (list typeC valueC)) - (do ////.Monad<Operation> + (do ////.monad [count (///.lift macro.count) actualT (:: @ map (|>> (:coerce Type)) (eval count Type typeC)) @@ -120,7 +120,7 @@ (function (_ extension-name analyse args) (case args (^ (list valueC)) - (do ////.Monad<Operation> + (do ////.monad [_ (typeA.infer Type) valueA (typeA.with-type Type (analyse valueC))] diff --git a/stdlib/source/lux/platform/compiler/phase/extension/analysis/host.jvm.lux b/stdlib/source/lux/platform/compiler/phase/extension/analysis/host.jvm.lux index 2981dc89b..6b4b7ad36 100644 --- a/stdlib/source/lux/platform/compiler/phase/extension/analysis/host.jvm.lux +++ b/stdlib/source/lux/platform/compiler/phase/extension/analysis/host.jvm.lux @@ -9,10 +9,10 @@ ["." error (#+ Error)] ["." maybe] ["." product] - ["." text ("text/." Equivalence<Text>) + ["." text ("text/." equivalence) format] [collection - ["." list ("list/." Fold<List> Functor<List> Monoid<List>)] + ["." list ("list/." fold functor monoid)] ["." array (#+ Array)] ["." dictionary (#+ Dictionary)]]] ["." type @@ -24,7 +24,7 @@ ["." common] ["/." // ["." bundle] - ["//." // ("operation/." Monad<Operation>) + ["//." // ("operation/." monad) ["." analysis (#+ Analysis Operation Handler Bundle) [".A" type] [".A" inference]]]]] @@ -216,14 +216,14 @@ ["float" "java.lang.Float"] ["double" "java.lang.Double"] ["char" "java.lang.Character"]) - (dictionary.from-list text.Hash<Text>))) + (dictionary.from-list text.hash))) (def: array::length Handler (function (_ extension-name analyse args) (case args (^ (list arrayC)) - (do ////.Monad<Operation> + (do ////.monad [_ (typeA.infer Nat) [var-id varT] (typeA.with-env check.var) arrayA (typeA.with-type (type (Array varT)) @@ -238,7 +238,7 @@ (function (_ extension-name analyse args) (case args (^ (list lengthC)) - (do ////.Monad<Operation> + (do ////.monad [lengthA (typeA.with-type Nat (analyse lengthC)) expectedT (///.lift macro.expected-type) @@ -303,7 +303,7 @@ (def: (check-object objectT) (-> Type (Operation Text)) - (do ////.Monad<Operation> + (do ////.monad [name (check-jvm objectT)] (if (dictionary.contains? name boxes) (////.throw primitives-are-not-objects name) @@ -331,7 +331,7 @@ (function (_ extension-name analyse args) (case args (^ (list arrayC idxC)) - (do ////.Monad<Operation> + (do ////.monad [[var-id varT] (typeA.with-env check.var) _ (typeA.infer varT) arrayA (typeA.with-type (type (Array varT)) @@ -351,7 +351,7 @@ (function (_ extension-name analyse args) (case args (^ (list arrayC idxC valueC)) - (do ////.Monad<Operation> + (do ////.monad [[var-id varT] (typeA.with-env check.var) _ (typeA.infer (type (Array varT))) arrayA (typeA.with-type (type (Array varT)) @@ -383,7 +383,7 @@ (function (_ extension-name analyse args) (case args (^ (list)) - (do ////.Monad<Operation> + (do ////.monad [expectedT (///.lift macro.expected-type) _ (check-object expectedT)] (wrap (#analysis.Extension extension-name (list)))) @@ -396,7 +396,7 @@ (function (_ extension-name analyse args) (case args (^ (list objectC)) - (do ////.Monad<Operation> + (do ////.monad [_ (typeA.infer Bit) [objectT objectA] (typeA.with-inference (analyse objectC)) @@ -411,7 +411,7 @@ (function (_ extension-name analyse args) (case args (^ (list monitorC exprC)) - (do ////.Monad<Operation> + (do ////.monad [[monitorT monitorA] (typeA.with-inference (analyse monitorC)) _ (check-object monitorT) @@ -482,7 +482,7 @@ (def: (load-class name) (-> Text (Operation (Class Object))) - (do ////.Monad<Operation> + (do ////.monad [] (case (Class::forName name) (#error.Success [class]) @@ -493,7 +493,7 @@ (def: (sub-class? super sub) (-> Text Text (Operation Bit)) - (do ////.Monad<Operation> + (do ////.monad [super (load-class super) sub (load-class sub)] (wrap (Class::isAssignableFrom sub super)))) @@ -503,7 +503,7 @@ (function (_ extension-name analyse args) (case args (^ (list exceptionC)) - (do ////.Monad<Operation> + (do ////.monad [_ (typeA.infer Nothing) [exceptionT exceptionA] (typeA.with-inference (analyse exceptionC)) @@ -525,7 +525,7 @@ (^ (list classC)) (case classC [_ (#.Text class)] - (do ////.Monad<Operation> + (do ////.monad [_ (typeA.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list))))) _ (load-class class)] (wrap (#analysis.Extension extension-name (list (analysis.text class))))) @@ -543,7 +543,7 @@ (^ (list classC objectC)) (case classC [_ (#.Text class)] - (do ////.Monad<Operation> + (do ////.monad [_ (typeA.infer Bit) [objectT objectA] (typeA.with-inference (analyse objectC)) @@ -573,7 +573,7 @@ (type: Mappings (Dictionary Text Type)) -(def: fresh-mappings Mappings (dictionary.new text.Hash<Text>)) +(def: fresh-mappings Mappings (dictionary.new text.hash)) (def: (java-type-to-lux-type mappings java-type) (-> Mappings java/lang/reflect/Type (Operation Type)) @@ -614,7 +614,7 @@ (let [java-type (:coerce ParameterizedType java-type) raw (ParameterizedType::getRawType java-type)] (if (host.instance? Class raw) - (do ////.Monad<Operation> + (do ////.monad [paramsT (|> java-type ParameterizedType::getActualTypeArguments array.to-list @@ -624,7 +624,7 @@ (////.throw jvm-type-is-not-a-class raw))) (host.instance? GenericArrayType java-type) - (do ////.Monad<Operation> + (do ////.monad [innerT (|> (:coerce GenericArrayType java-type) GenericArrayType::getGenericComponentType (java-type-to-lux-type mappings))] @@ -656,7 +656,7 @@ ## else (operation/wrap (|> params (list.zip2 (list/map (|>> TypeVariable::getName) class-params)) - (dictionary.from-list text.Hash<Text>))) + (dictionary.from-list text.hash))) )) _ @@ -667,7 +667,7 @@ (function (_ extension-name analyse args) (case args (^ (list valueC)) - (do ////.Monad<Operation> + (do ////.monad [toT (///.lift macro.expected-type) to-name (check-jvm toT) [valueT valueA] (typeA.with-inference @@ -756,7 +756,7 @@ (def: (find-field class-name field-name) (-> Text Text (Operation [(Class Object) Field])) - (do ////.Monad<Operation> + (do ////.monad [class (load-class class-name)] (case (Class::getDeclaredField field-name class) (#error.Success field) @@ -773,7 +773,7 @@ (def: (static-field class-name field-name) (-> Text Text (Operation [Type Bit])) - (do ////.Monad<Operation> + (do ////.monad [[class fieldJ] (find-field class-name field-name) #let [modifiers (Field::getModifiers fieldJ)]] (if (Modifier::isStatic modifiers) @@ -785,7 +785,7 @@ (def: (virtual-field class-name field-name objectT) (-> Text Text Type (Operation [Type Bit])) - (do ////.Monad<Operation> + (do ////.monad [[class fieldJ] (find-field class-name field-name) #let [modifiers (Field::getModifiers fieldJ)]] (if (not (Modifier::isStatic modifiers)) @@ -808,7 +808,7 @@ " Type: " (%type objectT)) (n/= num-params num-vars))] (wrap (|> (list.zip2 var-names _class-params) - (dictionary.from-list text.Hash<Text>)))) + (dictionary.from-list text.hash)))) _ (////.throw non-object objectT))) @@ -823,7 +823,7 @@ (^ (list classC fieldC)) (case [classC fieldC] [[_ (#.Text class)] [_ (#.Text field)]] - (do ////.Monad<Operation> + (do ////.monad [[fieldT final?] (static-field class field)] (wrap (#analysis.Extension extension-name (list (analysis.text class) (analysis.text field))))) @@ -840,7 +840,7 @@ (^ (list classC fieldC valueC)) (case [classC fieldC] [[_ (#.Text class)] [_ (#.Text field)]] - (do ////.Monad<Operation> + (do ////.monad [_ (typeA.infer Any) [fieldT final?] (static-field class field) _ (////.assert cannot-set-a-final-field (format class "#" field) @@ -862,7 +862,7 @@ (^ (list classC fieldC objectC)) (case [classC fieldC] [[_ (#.Text class)] [_ (#.Text field)]] - (do ////.Monad<Operation> + (do ////.monad [[objectT objectA] (typeA.with-inference (analyse objectC)) [fieldT final?] (virtual-field class field objectT)] @@ -881,7 +881,7 @@ (^ (list classC fieldC valueC objectC)) (case [classC fieldC] [[_ (#.Text class)] [_ (#.Text field)]] - (do ////.Monad<Operation> + (do ////.monad [[objectT objectA] (typeA.with-inference (analyse objectC)) _ (typeA.infer objectT) @@ -911,7 +911,7 @@ (operation/wrap "java.lang.Object") (host.instance? GenericArrayType type) - (do ////.Monad<Operation> + (do ////.monad [componentP (java-type-to-parameter (GenericArrayType::getGenericComponentType (:coerce GenericArrayType type)))] (wrap (format componentP "[]"))) @@ -927,7 +927,7 @@ (def: (check-method class method-name method-style arg-classes method) (-> (Class Object) Text Method-Style (List Text) Method (Operation Bit)) - (do ////.Monad<Operation> + (do ////.monad [parameters (|> (Method::getGenericParameterTypes method) array.to-list (monad.map @ java-type-to-parameter)) @@ -956,7 +956,7 @@ (def: (check-constructor class arg-classes constructor) (-> (Class Object) (List Text) (Constructor Object) (Operation Bit)) - (do ////.Monad<Operation> + (do ////.monad [parameters (|> (Constructor::getGenericParameterTypes constructor) array.to-list (monad.map @ java-type-to-parameter))] @@ -1006,8 +1006,8 @@ (|> (list/compose owner-tvarsT method-tvarsT) list.reverse (list.zip2 all-tvars) - (dictionary.from-list text.Hash<Text>))))] - (do ////.Monad<Operation> + (dictionary.from-list text.hash))))] + (do ////.monad [inputsT (|> (Method::getGenericParameterTypes method) array.to-list (monad.map @ (java-type-to-lux-type mappings))) @@ -1046,7 +1046,7 @@ (def: (method-candidate class-name method-name method-style arg-classes) (-> Text Text Method-Style (List Text) (Operation Method-Signature)) - (do ////.Monad<Operation> + (do ////.monad [class (load-class class-name) candidates (|> class Class::getDeclaredMethods @@ -1094,8 +1094,8 @@ (|> (list/compose owner-tvarsT constructor-tvarsT) list.reverse (list.zip2 all-tvars) - (dictionary.from-list text.Hash<Text>))))] - (do ////.Monad<Operation> + (dictionary.from-list text.hash))))] + (do ////.monad [inputsT (|> (Constructor::getGenericParameterTypes constructor) array.to-list (monad.map @ (java-type-to-lux-type mappings))) @@ -1112,7 +1112,7 @@ (def: (constructor-candidate class-name arg-classes) (-> Text (List Text) (Operation Method-Signature)) - (do ////.Monad<Operation> + (do ////.monad [class (load-class class-name) candidates (|> class Class::getConstructors @@ -1146,7 +1146,7 @@ (case (: (Error [Text Text (List [Text Code])]) (s.run args ($_ p.and s.text s.text (p.some (s.tuple (p.and s.text s.any)))))) (#error.Success [class method argsTC]) - (do ////.Monad<Operation> + (do ////.monad [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (method-candidate class method #Static argsT) [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC)) @@ -1163,7 +1163,7 @@ (case (: (Error [Text Text Code (List [Text Code])]) (s.run args ($_ p.and s.text s.text s.any (p.some (s.tuple (p.and s.text s.any)))))) (#error.Success [class method objectC argsTC]) - (do ////.Monad<Operation> + (do ////.monad [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (method-candidate class method #Virtual argsT) [outputT allA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) @@ -1186,7 +1186,7 @@ (case (: (Error [(List Code) [Text Text Code (List [Text Code]) Any]]) (p.run args ($_ p.and s.text s.text s.any (p.some (s.tuple (p.and s.text s.any))) s.end!))) (#error.Success [_ [class method objectC argsTC _]]) - (do ////.Monad<Operation> + (do ////.monad [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (method-candidate class method #Special argsT) [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) @@ -1203,7 +1203,7 @@ (case (: (Error [Text Text Code (List [Text Code])]) (s.run args ($_ p.and s.text s.text s.any (p.some (s.tuple (p.and s.text s.any)))))) (#error.Success [class-name method objectC argsTC]) - (do ////.Monad<Operation> + (do ////.monad [#let [argsT (list/map product.left argsTC)] class (load-class class-name) _ (////.assert non-interface class-name @@ -1224,7 +1224,7 @@ (case (: (Error [Text (List [Text Code])]) (s.run args ($_ p.and s.text (p.some (s.tuple (p.and s.text s.any)))))) (#error.Success [class argsTC]) - (do ////.Monad<Operation> + (do ////.monad [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (constructor-candidate class argsT) [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC))] diff --git a/stdlib/source/lux/platform/compiler/phase/extension/bundle.lux b/stdlib/source/lux/platform/compiler/phase/extension/bundle.lux index 582526694..41879fa0c 100644 --- a/stdlib/source/lux/platform/compiler/phase/extension/bundle.lux +++ b/stdlib/source/lux/platform/compiler/phase/extension/bundle.lux @@ -6,13 +6,13 @@ ["." text format] [collection - [list ("list/." Functor<List>)] + [list ("list/." functor)] ["." dictionary (#+ Dictionary)]]]] [// (#+ Handler Bundle)]) (def: #export empty Bundle - (dictionary.new text.Hash<Text>)) + (dictionary.new text.hash)) (def: #export (install name anonymous) (All [s i o] @@ -25,4 +25,4 @@ (-> Text (-> (Bundle s i o) (Bundle s i o)))) (|>> dictionary.entries (list/map (function (_ [key val]) [(format prefix " " key) val])) - (dictionary.from-list text.Hash<Text>))) + (dictionary.from-list text.hash))) diff --git a/stdlib/source/lux/platform/compiler/phase/extension/statement.lux b/stdlib/source/lux/platform/compiler/phase/extension/statement.lux index e5963e96c..02edd7565 100644 --- a/stdlib/source/lux/platform/compiler/phase/extension/statement.lux +++ b/stdlib/source/lux/platform/compiler/phase/extension/statement.lux @@ -7,7 +7,7 @@ [text format] [collection - [list ("list/." Functor<List>)] + [list ("list/." functor)] ["." dictionary]]] ["." macro] [type (#+ :share) @@ -25,7 +25,7 @@ (def: (evaluate! type codeC) (All [anchor expression statement] (-> Type Code (Operation anchor expression statement [Type expression Any]))) - (do ///.Monad<Operation> + (do ///.monad [state (//.lift ///.get-state) #let [analyse (get@ [#statement.analysis #statement.phase] state) synthesize (get@ [#statement.synthesis #statement.phase] state) @@ -51,7 +51,7 @@ (All [anchor expression statement] (-> Name (Maybe Type) Code (Operation anchor expression statement [Type expression Text Any]))) - (do ///.Monad<Operation> + (do ///.monad [state (//.lift ///.get-state) #let [analyse (get@ [#statement.analysis #statement.phase] state) synthesize (get@ [#statement.synthesis #statement.phase] state) @@ -86,7 +86,7 @@ (function (_ extension-name phase inputsC+) (case inputsC+ (^ (list [_ (#.Identifier ["" short-name])] valueC annotationsC)) - (do ///.Monad<Operation> + (do ///.monad [current-module (statement.lift-analysis (//.lift macro.current-module-name)) #let [full-name [current-module short-name]] @@ -117,7 +117,7 @@ (def: (alias! alias def-name) (-> Text Name (analysis.Operation Any)) - (do ///.Monad<Operation> + (do ///.monad [definition (//.lift (macro.find-def def-name))] (module.define alias definition))) @@ -126,7 +126,7 @@ (function (_ extension-name phase inputsC+) (case inputsC+ (^ (list annotationsC)) - (do ///.Monad<Operation> + (do ///.monad [[_ annotationsT annotationsV] (evaluate! Code annotationsC) _ (statement.lift-analysis (module.set-annotations (:coerce Code annotationsV)))] @@ -155,7 +155,7 @@ (function (handler extension-name phase inputsC+) (case inputsC+ (^ (list [_ (#.Text name)] valueC)) - (do ///.Monad<Operation> + (do ///.monad [[_ handlerT handlerV] (evaluate! (:of (:share [anchor expression statement] {(Handler anchor expression statement) handler} diff --git a/stdlib/source/lux/platform/compiler/phase/statement/total.lux b/stdlib/source/lux/platform/compiler/phase/statement/total.lux index 15f116aa1..c494b01c6 100644 --- a/stdlib/source/lux/platform/compiler/phase/statement/total.lux +++ b/stdlib/source/lux/platform/compiler/phase/statement/total.lux @@ -31,7 +31,7 @@ (extension.apply "Statement" phase [name inputs]) (^ [_ (#.Form (list& macro inputs))]) - (do ///.Monad<Operation> + (do ///.monad [expansion (//.lift-analysis (do @ [macroA (type.with-type Macro diff --git a/stdlib/source/lux/platform/compiler/phase/synthesis.lux b/stdlib/source/lux/platform/compiler/phase/synthesis.lux index cf29ad74b..f1239fdfe 100644 --- a/stdlib/source/lux/platform/compiler/phase/synthesis.lux +++ b/stdlib/source/lux/platform/compiler/phase/synthesis.lux @@ -5,11 +5,11 @@ [equivalence (#+ Equivalence)] ["ex" exception (#+ exception:)]] [data - [bit ("bit/." Equivalence<Bit>)] - ["." text ("text/." Equivalence<Text>) + [bit ("bit/." equivalence)] + ["." text ("text/." equivalence) format] [collection - [list ("list/." Functor<List>)] + [list ("list/." functor)] ["." dictionary (#+ Dictionary)]]]] ["." // ["." analysis (#+ Environment Arity Composite Analysis)] @@ -24,7 +24,7 @@ (def: #export fresh-resolver Resolver - (dictionary.new reference.Hash<Variable>)) + (dictionary.new reference.hash)) (def: #export init State @@ -192,7 +192,7 @@ (def: #export with-new-local (All [a] (-> (Operation a) (Operation a))) - (<<| (do //.Monad<Operation> + (<<| (do //.monad [locals ..locals]) (..with-locals (inc locals)))) @@ -388,7 +388,7 @@ (Format Path) (%path' %synthesis)) -(structure: #export _ (Equivalence Primitive) +(structure: #export primitive-equivalence (Equivalence Primitive) (def: (= reference sample) (case [reference sample] (^template [<tag> <eq> <format>] @@ -404,7 +404,7 @@ _ false))) -(structure: #export _ (Equivalence Access) +(structure: #export access-equivalence (Equivalence Access) (def: (= reference sample) (case [reference sample] (^template [<tag>] @@ -424,7 +424,7 @@ _ false))) -(structure: #export (Equivalence<Path'> Equivalence<a>) +(structure: #export (path'-equivalence Equivalence<a>) (All [a] (-> (Equivalence a) (Equivalence (Path' a)))) (def: (= reference sample) @@ -435,8 +435,8 @@ (^template [<tag> <equivalence>] [(<tag> reference') (<tag> sample')] (:: <equivalence> = reference' sample')) - ([#Test Equivalence<Primitive>] - [#Access Equivalence<Access>] + ([#Test primitive-equivalence] + [#Access access-equivalence] [#Then Equivalence<a>]) [(#Bind reference') (#Bind sample')] @@ -452,17 +452,17 @@ _ false))) -(structure: #export _ (Equivalence Synthesis) +(structure: #export equivalence (Equivalence Synthesis) (def: (= reference sample) (case [reference sample] (^template [<tag> <equivalence>] [(<tag> reference') (<tag> sample')] (:: <equivalence> = reference' sample')) - ([#Primitive Equivalence<Primitive>]) + ([#Primitive primitive-equivalence]) _ false))) -(def: #export Equivalence<Path> +(def: #export path-equivalence (Equivalence Path) - (Equivalence<Path'> Equivalence<Synthesis>)) + (path'-equivalence equivalence)) diff --git a/stdlib/source/lux/platform/compiler/phase/synthesis/case.lux b/stdlib/source/lux/platform/compiler/phase/synthesis/case.lux index e9e941a30..95adf33f3 100644 --- a/stdlib/source/lux/platform/compiler/phase/synthesis/case.lux +++ b/stdlib/source/lux/platform/compiler/phase/synthesis/case.lux @@ -6,15 +6,15 @@ ["." monad (#+ do)]] [data ["." product] - [bit ("bit/." Equivalence<Bit>)] - [text ("text/." Equivalence<Text>) + [bit ("bit/." equivalence)] + [text ("text/." equivalence) format] - [number ("frac/." Equivalence<Frac>)] + [number ("frac/." equivalence)] [collection - ["." list ("list/." Fold<List> Monoid<List>)]]]] + ["." list ("list/." fold monoid)]]]] ["." // (#+ Path Synthesis Operation Phase) ["." function] - ["/." // ("operation/." Monad<Operation>) + ["/." // ("operation/." monad) ["." analysis (#+ Pattern Match Analysis)] [// ["." reference]]]]) @@ -43,7 +43,7 @@ [#analysis.Text #//.Text])) (#analysis.Bind register) - (<| (:: ///.Monad<Operation> map (|>> (#//.Seq (#//.Bind register)))) + (<| (:: ///.monad map (|>> (#//.Seq (#//.Bind register)))) //.with-new-local thenC) @@ -121,7 +121,7 @@ (def: #export (synthesize synthesize^ inputA [headB tailB+]) (-> Phase Analysis Match (Operation Synthesis)) - (do ///.Monad<Operation> + (do ///.monad [inputS (synthesize^ inputA)] (with-expansions [<unnecesary-let> (as-is (^multi (^ (#analysis.Reference (reference.local outputR))) diff --git a/stdlib/source/lux/platform/compiler/phase/synthesis/expression.lux b/stdlib/source/lux/platform/compiler/phase/synthesis/expression.lux index 672bc9e87..7b836b29a 100644 --- a/stdlib/source/lux/platform/compiler/phase/synthesis/expression.lux +++ b/stdlib/source/lux/platform/compiler/phase/synthesis/expression.lux @@ -7,12 +7,12 @@ ["." maybe] ["." error] [collection - ["." list ("list/." Functor<List>)] + ["." list ("list/." functor)] ["." dictionary (#+ Dictionary)]]]] ["." // (#+ Synthesis Phase) ["." function] ["." case] - ["/." // ("operation/." Monad<Operation>) + ["/." // ("operation/." monad) ["." analysis (#+ Analysis)] ["." extension] [// @@ -47,14 +47,14 @@ (#analysis.Structure structure) (case structure (#analysis.Variant variant) - (do ///.Monad<Operation> + (do ///.monad [valueS (phase (get@ #analysis.value variant))] (wrap (//.variant (set@ #analysis.value valueS variant)))) (#analysis.Tuple tuple) (|> tuple - (monad.map ///.Monad<Operation> phase) - (:: ///.Monad<Operation> map (|>> //.tuple)))) + (monad.map ///.monad phase) + (:: ///.monad map (|>> //.tuple)))) (#analysis.Reference reference) (operation/wrap (#//.Reference reference)) @@ -80,7 +80,7 @@ (#error.Failure error) (<| (///.run' state) - (do ///.Monad<Operation> + (do ///.monad [argsS+ (monad.map @ phase args)] (wrap (#//.Extension [name argsS+]))))))) )) diff --git a/stdlib/source/lux/platform/compiler/phase/synthesis/function.lux b/stdlib/source/lux/platform/compiler/phase/synthesis/function.lux index 267d941fc..ccc7835a4 100644 --- a/stdlib/source/lux/platform/compiler/phase/synthesis/function.lux +++ b/stdlib/source/lux/platform/compiler/phase/synthesis/function.lux @@ -8,11 +8,11 @@ ["." text format] [collection - ["." list ("list/." Functor<List> Monoid<List> Fold<List>)] + ["." list ("list/." functor monoid fold)] ["dict" dictionary (#+ Dictionary)]]]] ["." // (#+ Path Synthesis Operation Phase) ["." loop (#+ Transform)] - ["/." // ("operation/." Monad<Operation>) + ["/." // ("operation/." monad) ["." analysis (#+ Environment Arity Analysis)] [// ["." reference (#+ Register Variable)]]]]) @@ -40,7 +40,7 @@ (-> Phase Phase) (function (_ exprA) (let [[funcA argsA] (analysis.application exprA)] - (do ///.Monad<Operation> + (do ///.monad [funcS (phase funcA) argsS (monad.map @ phase argsA) ## locals //.locals @@ -75,7 +75,7 @@ (^template [<tag>] (<tag> left right) - (do ///.Monad<Operation> + (do ///.monad [left' (grow-path grow left) right' (grow-path grow right)] (wrap (<tag> left' right')))) @@ -91,7 +91,7 @@ (def: (grow-sub-environment super sub) (-> Environment Environment (Operation Environment)) - (monad.map ///.Monad<Operation> + (monad.map ///.monad (function (_ variable) (case variable (#reference.Local register) @@ -113,7 +113,7 @@ (#analysis.Tuple membersS+) (|> membersS+ - (monad.map ///.Monad<Operation> (grow environment)) + (monad.map ///.monad (grow environment)) (operation/map (|>> //.tuple)))) (^ (..self-reference)) @@ -139,20 +139,20 @@ (#//.Branch branch) (case branch (#//.Let [inputS register bodyS]) - (do ///.Monad<Operation> + (do ///.monad [inputS' (grow environment inputS) bodyS' (grow environment bodyS)] (wrap (//.branch/let [inputS' (inc register) bodyS']))) (#//.If [testS thenS elseS]) - (do ///.Monad<Operation> + (do ///.monad [testS' (grow environment testS) thenS' (grow environment thenS) elseS' (grow environment elseS)] (wrap (//.branch/if [testS' thenS' elseS']))) (#//.Case [inputS pathS]) - (do ///.Monad<Operation> + (do ///.monad [inputS' (grow environment inputS) pathS' (grow-path (grow environment) pathS)] (wrap (//.branch/case [inputS' pathS'])))) @@ -160,20 +160,20 @@ (#//.Loop loop) (case loop (#//.Scope [start initsS+ iterationS]) - (do ///.Monad<Operation> + (do ///.monad [initsS+' (monad.map @ (grow environment) initsS+) iterationS' (grow environment iterationS)] (wrap (//.loop/scope [start initsS+' iterationS']))) (#//.Recur argumentsS+) (|> argumentsS+ - (monad.map ///.Monad<Operation> (grow environment)) + (monad.map ///.monad (grow environment)) (operation/map (|>> //.loop/recur)))) (#//.Function function) (case function (#//.Abstraction [_env _arity _body]) - (do ///.Monad<Operation> + (do ///.monad [_env' (grow-sub-environment environment _env)] (wrap (//.function/abstraction [_env' _arity _body]))) @@ -184,14 +184,14 @@ (list/compose pre-argsS+ argsS+)])) _ - (do ///.Monad<Operation> + (do ///.monad [funcS' (grow environment funcS) argsS+' (monad.map @ (grow environment) argsS+)] (wrap (//.function/apply [funcS' argsS+'])))))) (#//.Extension name argumentsS+) (|> argumentsS+ - (monad.map ///.Monad<Operation> (grow environment)) + (monad.map ///.monad (grow environment)) (operation/map (|>> (#//.Extension name)))) _ @@ -199,7 +199,7 @@ (def: #export (abstraction phase environment bodyA) (-> Phase Environment Analysis (Operation Synthesis)) - (do ///.Monad<Operation> + (do ///.monad [bodyS (phase bodyA)] (case bodyS (^ (//.function/abstraction [env' down-arity' bodyS'])) diff --git a/stdlib/source/lux/platform/compiler/phase/synthesis/loop.lux b/stdlib/source/lux/platform/compiler/phase/synthesis/loop.lux index cd57c1d29..924a9b413 100644 --- a/stdlib/source/lux/platform/compiler/phase/synthesis/loop.lux +++ b/stdlib/source/lux/platform/compiler/phase/synthesis/loop.lux @@ -4,9 +4,9 @@ ["." monad (#+ do)] ["p" parser]] [data - ["." maybe ("maybe/." Monad<Maybe>)] + ["." maybe ("maybe/." monad)] [collection - ["." list ("list/." Functor<List>)]]] + ["." list ("list/." functor)]]] [macro ["." code] ["." syntax]]] @@ -179,7 +179,7 @@ (^template [<tag>] (<tag> leftS rightS) - (do maybe.Monad<Maybe> + (do maybe.monad [leftS' (recur leftS) rightS' (recur rightS)] (wrap (<tag> leftS' rightS')))) @@ -198,7 +198,7 @@ (#//.Structure structureS) (case structureS (#analysis.Variant variantS) - (do maybe.Monad<Maybe> + (do maybe.monad [valueS' (|> variantS (get@ #analysis.value) recur)] (wrap (|> variantS (set@ #analysis.value valueS') @@ -207,7 +207,7 @@ (#analysis.Tuple membersS+) (|> membersS+ - (monad.map maybe.Monad<Maybe> recur) + (monad.map maybe.monad recur) (maybe/map (|>> #analysis.Tuple #//.Structure)))) (#//.Reference reference) @@ -224,29 +224,29 @@ (maybe/map (|>> #reference.Variable #//.Reference)))) (^ (//.branch/case [inputS pathS])) - (do maybe.Monad<Maybe> + (do maybe.monad [inputS' (recur inputS) pathS' (adjust-path recur offset pathS)] (wrap (|> pathS' [inputS'] //.branch/case))) (^ (//.branch/let [inputS register bodyS])) - (do maybe.Monad<Maybe> + (do maybe.monad [inputS' (recur inputS) bodyS' (recur bodyS)] (wrap (//.branch/let [inputS' register bodyS']))) (^ (//.branch/if [inputS thenS elseS])) - (do maybe.Monad<Maybe> + (do maybe.monad [inputS' (recur inputS) thenS' (recur thenS) elseS' (recur elseS)] (wrap (//.branch/if [inputS' thenS' elseS']))) (^ (//.loop/scope scopeS)) - (do maybe.Monad<Maybe> + (do maybe.monad [inits' (|> scopeS (get@ #//.inits) - (monad.map maybe.Monad<Maybe> recur)) + (monad.map maybe.monad recur)) iteration' (recur (get@ #//.iteration scopeS))] (wrap (//.loop/scope {#//.start (|> scopeS (get@ #//.start) (n/+ offset)) #//.inits inits' @@ -254,26 +254,26 @@ (^ (//.loop/recur argsS)) (|> argsS - (monad.map maybe.Monad<Maybe> recur) + (monad.map maybe.monad recur) (maybe/map (|>> //.loop/recur))) (^ (//.function/abstraction [environment arity bodyS])) - (do maybe.Monad<Maybe> - [environment' (monad.map maybe.Monad<Maybe> + (do maybe.monad + [environment' (monad.map maybe.monad (resolve scope-environment) environment)] (wrap (//.function/abstraction [environment' arity bodyS]))) (^ (//.function/apply [function arguments])) - (do maybe.Monad<Maybe> + (do maybe.monad [function' (recur function) - arguments' (monad.map maybe.Monad<Maybe> recur arguments)] + arguments' (monad.map maybe.monad recur arguments)] (wrap (//.function/apply [function' arguments']))) (#//.Extension [name argsS]) (|> argsS - (monad.map maybe.Monad<Maybe> recur) + (monad.map maybe.monad recur) (maybe/map (|>> [name] #//.Extension))) _ diff --git a/stdlib/source/lux/platform/compiler/phase/translation.lux b/stdlib/source/lux/platform/compiler/phase/translation.lux index c7fb60c08..79c343d5a 100644 --- a/stdlib/source/lux/platform/compiler/phase/translation.lux +++ b/stdlib/source/lux/platform/compiler/phase/translation.lux @@ -6,7 +6,7 @@ [data ["." product] ["." error (#+ Error)] - ["." name ("name/." Equivalence<Name>)] + ["." name ("name/." equivalence)] ["." text format] [collection @@ -92,9 +92,9 @@ #anchor #.None #host host #buffer #.None - #outputs (dictionary.new text.Hash<Text>) + #outputs (dictionary.new text.hash) #counter 0 - #name-cache (dictionary.new name.Hash<Name>)}) + #name-cache (dictionary.new name.hash)}) (def: #export (with-context expr) (All [anchor expression statement output] @@ -166,7 +166,7 @@ (def: #export next (All [anchor expression statement] (Operation anchor expression statement Nat)) - (do //.Monad<Operation> + (do //.monad [count (extension.read (get@ #counter)) _ (extension.update (update@ #counter inc))] (wrap count))) @@ -201,7 +201,7 @@ (def: #export (save! name code) (All [anchor expression statement] (-> Name statement (Operation anchor expression statement Any))) - (do //.Monad<Operation> + (do //.monad [count ..next _ (execute! (format "save" (%n count)) code) ?buffer (extension.read (get@ #buffer))] @@ -217,7 +217,7 @@ (def: #export (save-buffer! target) (All [anchor expression statement] (-> File (Operation anchor expression statement Any))) - (do //.Monad<Operation> + (do //.monad [buffer ..buffer] (extension.update (update@ #outputs (dictionary.put target buffer))))) diff --git a/stdlib/source/lux/platform/compiler/phase/translation/scheme/case.jvm.lux b/stdlib/source/lux/platform/compiler/phase/translation/scheme/case.jvm.lux index 4a963d507..b50e4485a 100644 --- a/stdlib/source/lux/platform/compiler/phase/translation/scheme/case.jvm.lux +++ b/stdlib/source/lux/platform/compiler/phase/translation/scheme/case.jvm.lux @@ -8,12 +8,12 @@ ["." text format] [collection - [list ("list/." Functor<List> Fold<List>)] + [list ("list/." functor fold)] [set (#+ Set)]]]] [// ["." runtime (#+ Operation Phase)] ["." reference] - ["/." /// ("operation/." Monad<Operation>) + ["/." /// ("operation/." monad) ["." synthesis (#+ Synthesis Path)] [// [reference (#+ Register)] @@ -24,7 +24,7 @@ (def: #export (let translate [valueS register bodyS]) (-> Phase [Synthesis Register Synthesis] (Operation Computation)) - (do ////.Monad<Operation> + (do ////.monad [valueO (translate valueS) bodyO (translate bodyS)] (wrap (_.let (list [(reference.local' register) valueO]) @@ -33,7 +33,7 @@ (def: #export (record-get translate valueS pathP) (-> Phase Synthesis (List [Nat Bit]) (Operation Expression)) - (do ////.Monad<Operation> + (do ////.monad [valueO (translate valueS)] (wrap (list/fold (function (_ [idx tail?] source) (.let [method (.if tail? @@ -46,7 +46,7 @@ (def: #export (if translate [testS thenS elseS]) (-> Phase [Synthesis Synthesis Synthesis] (Operation Computation)) - (do ////.Monad<Operation> + (do ////.monad [testO (translate testS) thenO (translate thenS) elseO (translate elseS)] @@ -143,7 +143,7 @@ (^template [<tag> <computation>] (^ (<tag> leftP rightP)) - (do ////.Monad<Operation> + (do ////.monad [leftO (pattern-matching' translate leftP) rightO (pattern-matching' translate rightP)] (wrap <computation>))) @@ -161,7 +161,7 @@ (def: (pattern-matching translate pathP) (-> Phase Path (Operation Computation)) - (do ////.Monad<Operation> + (do ////.monad [pattern-matching! (pattern-matching' translate pathP)] (wrap (_.with-exception-handler (pm-catch (_.raise/1 (_.string "Invalid expression for pattern-matching."))) @@ -170,7 +170,7 @@ (def: #export (case translate [valueS pathP]) (-> Phase [Synthesis Path] (Operation Computation)) - (do ////.Monad<Operation> + (do ////.monad [valueO (translate valueS)] (<| (:: @ map (_.let (list [@cursor (_.list/* (list valueO))] [@savepoint (_.list/* (list))]))) diff --git a/stdlib/source/lux/platform/compiler/phase/translation/scheme/extension/common.jvm.lux b/stdlib/source/lux/platform/compiler/phase/translation/scheme/extension/common.jvm.lux index a503949dd..46f0c8102 100644 --- a/stdlib/source/lux/platform/compiler/phase/translation/scheme/extension/common.jvm.lux +++ b/stdlib/source/lux/platform/compiler/phase/translation/scheme/extension/common.jvm.lux @@ -10,7 +10,7 @@ format] [number (#+ hex)] [collection - ["." list ("list/." Functor<List>)] + ["." list ("list/." functor)] ["dict" dictionary (#+ Dictionary)]]] ["." macro (#+ with-gensyms) ["." code] @@ -26,7 +26,6 @@ [host ["_" scheme (#+ Expression Computation)]]]]]) -## [Types] (syntax: (Vector {size s.nat} elemT) (wrap (list (` [(~+ (list.repeat size elemT))])))) @@ -36,7 +35,6 @@ (type: #export Trinary (-> (Vector 3 Expression) Computation)) (type: #export Variadic (-> (List Expression) Computation)) -## [Utils] (syntax: (arity: {name s.local-identifier} {arity s.nat}) (with-gensyms [g!_ g!extension g!name g!phase g!inputs] (do @ @@ -47,7 +45,7 @@ (function ((~ g!_) (~ g!name) (~ g!phase) (~ g!inputs)) (case (~ g!inputs) (^ (list (~+ g!input+))) - (do /////.Monad<Operation> + (do /////.monad [(~+ (|> g!input+ (list/map (function (_ g!input) (list g!input (` ((~ g!phase) (~ g!input)))))) @@ -66,19 +64,16 @@ (-> Variadic Handler) (function (_ extension-name) (function (_ phase inputsS) - (do /////.Monad<Operation> + (do /////.monad [inputsI (monad.map @ phase inputsS)] (wrap (extension inputsI)))))) -## [Bundle] -## [[Lux]] (def: bundle::lux Bundle (|> bundle.empty (bundle.install "is?" (binary (product.uncurry _.eq?/2))) (bundle.install "try" (unary runtime.lux//try)))) -## [[Bits]] (do-template [<name> <op>] [(def: (<name> [subjectO paramO]) Binary @@ -115,7 +110,6 @@ (bundle.install "arithmetic-right-shift" (binary bit::arithmetic-right-shift)) ))) -## [[Numbers]] (import: java/lang/Double (#static MIN_VALUE Double) (#static MAX_VALUE Double)) @@ -202,7 +196,6 @@ (bundle.install "encode" (unary _.number->string/1)) (bundle.install "decode" (unary runtime.frac//decode))))) -## [[Text]] (def: (text::char [subjectO paramO]) Binary (_.string/1 (_.string-ref/2 subjectO paramO))) @@ -222,7 +215,6 @@ (bundle.install "char" (binary text::char)) (bundle.install "clip" (trinary text::clip))))) -## [[IO]] (def: (io::log input) Unary (_.begin (list (_.display/1 input) @@ -241,7 +233,6 @@ (bundle.install "exit" (unary _.exit/1)) (bundle.install "current-time" (nullary (function (_ _) (runtime.io//current-time (_.string synthesis.unit)))))))) -## [Bundles] (def: #export bundle Bundle (<| (bundle.prefix "lux") diff --git a/stdlib/source/lux/platform/compiler/phase/translation/scheme/function.jvm.lux b/stdlib/source/lux/platform/compiler/phase/translation/scheme/function.jvm.lux index 7eeb5a8ed..8d19558dd 100644 --- a/stdlib/source/lux/platform/compiler/phase/translation/scheme/function.jvm.lux +++ b/stdlib/source/lux/platform/compiler/phase/translation/scheme/function.jvm.lux @@ -8,12 +8,12 @@ [text format] [collection - ["." list ("list/." Functor<List>)]]]] + ["." list ("list/." functor)]]]] [// ["." runtime (#+ Operation Phase)] ["." reference] ["/." // - ["//." // ("operation/." Monad<Operation>) + ["//." // ("operation/." monad) [analysis (#+ Variant Tuple Environment Arity Abstraction Application Analysis)] [synthesis (#+ Synthesis)] [// @@ -25,7 +25,7 @@ (def: #export (apply translate [functionS argsS+]) (-> Phase (Application Synthesis) (Operation Computation)) - (do ////.Monad<Operation> + (do ////.monad [functionO (translate functionS) argsO+ (monad.map @ translate argsS+)] (wrap (_.apply/* functionO argsO+)))) @@ -54,7 +54,7 @@ (def: #export (function translate [environment arity bodyS]) (-> Phase (Abstraction Synthesis) (Operation Computation)) - (do ////.Monad<Operation> + (do ////.monad [[function-name bodyO] (///.with-context (do @ [function-name ///.context] diff --git a/stdlib/source/lux/platform/compiler/phase/translation/scheme/loop.jvm.lux b/stdlib/source/lux/platform/compiler/phase/translation/scheme/loop.jvm.lux index 91757d291..e25b96254 100644 --- a/stdlib/source/lux/platform/compiler/phase/translation/scheme/loop.jvm.lux +++ b/stdlib/source/lux/platform/compiler/phase/translation/scheme/loop.jvm.lux @@ -7,7 +7,7 @@ ["." text format] [collection - ["." list ("list/." Functor<List>)]]]] + ["." list ("list/." functor)]]]] [// [runtime (#+ Operation Phase)] ["." reference] @@ -22,7 +22,7 @@ (def: #export (scope translate [start initsS+ bodyS]) (-> Phase (Scope Synthesis) (Operation Computation)) - (do ////.Monad<Operation> + (do ////.monad [initsO+ (monad.map @ translate initsS+) bodyO (///.with-anchor @scope (translate bodyS))] @@ -35,7 +35,7 @@ (def: #export (recur translate argsS+) (-> Phase (List Synthesis) (Operation Computation)) - (do ////.Monad<Operation> + (do ////.monad [@scope ///.anchor argsO+ (monad.map @ translate argsS+)] (wrap (_.apply/* @scope argsO+)))) diff --git a/stdlib/source/lux/platform/compiler/phase/translation/scheme/primitive.jvm.lux b/stdlib/source/lux/platform/compiler/phase/translation/scheme/primitive.jvm.lux index c16c696c4..caa71f74f 100644 --- a/stdlib/source/lux/platform/compiler/phase/translation/scheme/primitive.jvm.lux +++ b/stdlib/source/lux/platform/compiler/phase/translation/scheme/primitive.jvm.lux @@ -3,7 +3,7 @@ [// [runtime (#+ Operation)] [// (#+ State) - [// ("operation/." Monad<Operation>) + [// ("operation/." monad) [/// [host ["_" scheme (#+ Expression)]]]]]]) diff --git a/stdlib/source/lux/platform/compiler/phase/translation/scheme/reference.jvm.lux b/stdlib/source/lux/platform/compiler/phase/translation/scheme/reference.jvm.lux index 6d4088189..88e091e83 100644 --- a/stdlib/source/lux/platform/compiler/phase/translation/scheme/reference.jvm.lux +++ b/stdlib/source/lux/platform/compiler/phase/translation/scheme/reference.jvm.lux @@ -8,7 +8,7 @@ [// [runtime (#+ Operation)] ["/." // - [// ("operation/." Monad<Operation>) + [// ("operation/." monad) [analysis (#+ Variant Tuple)] [synthesis (#+ Synthesis)] [// diff --git a/stdlib/source/lux/platform/compiler/phase/translation/scheme/runtime.jvm.lux b/stdlib/source/lux/platform/compiler/phase/translation/scheme/runtime.jvm.lux index 43748c3b1..97e53d143 100644 --- a/stdlib/source/lux/platform/compiler/phase/translation/scheme/runtime.jvm.lux +++ b/stdlib/source/lux/platform/compiler/phase/translation/scheme/runtime.jvm.lux @@ -1,14 +1,14 @@ (.module: [lux #* [control - ["p" parser ("parser/." Monad<Parser>)] + ["p" parser ("parser/." monad)] [monad (#+ do)]] [data [number (#+ hex)] [text format] [collection - ["." list ("list/." Monad<List>)]]] + ["." list ("list/." monad)]]] ["." function] [macro ["." code] @@ -138,16 +138,16 @@ (with-vars [error] (_.with-exception-handler (_.lambda [(list error) #.None] - (..left error)) + (..left error)) (_.lambda [(list) #.None] - (..right (_.apply/* op (list ..unit))))))) + (..right (_.apply/* op (list ..unit))))))) (runtime: (lux//program-args program-args) (with-vars [@loop @input @output] (_.letrec (list [@loop (_.lambda [(list @input @output) #.None] - (_.if (_.eqv?/2 _.nil @input) - @output - (_.apply/2 @loop (_.cdr/1 @input) (..some (_.vector/* (list (_.car/1 @input) @output))))))]) + (_.if (_.eqv?/2 _.nil @input) + @output + (_.apply/2 @loop (_.cdr/1 @input) (..some (_.vector/* (list (_.car/1 @input) @output))))))]) (_.apply/2 @loop (_.reverse/1 program-args) ..none)))) (def: runtime//lux @@ -317,6 +317,6 @@ (def: #export translate (Operation Any) (///.with-buffer - (do ////.Monad<Operation> + (do ////.monad [_ (///.save! ["" ..prefix] ..runtime)] (///.save-buffer! "")))) diff --git a/stdlib/source/lux/platform/compiler/phase/translation/scheme/structure.jvm.lux b/stdlib/source/lux/platform/compiler/phase/translation/scheme/structure.jvm.lux index 3991ea281..dc1b88591 100644 --- a/stdlib/source/lux/platform/compiler/phase/translation/scheme/structure.jvm.lux +++ b/stdlib/source/lux/platform/compiler/phase/translation/scheme/structure.jvm.lux @@ -22,12 +22,12 @@ (translate singletonS) _ - (do ///.Monad<Operation> + (do ///.monad [elemsT+ (monad.map @ translate elemsS+)] (wrap (_.vector/* elemsT+))))) (def: #export (variant translate [lefts right? valueS]) (-> Phase (Variant Synthesis) (Operation Expression)) - (do ///.Monad<Operation> + (do ///.monad [valueT (translate valueS)] (wrap (runtime.variant [lefts right? valueT])))) diff --git a/stdlib/source/lux/platform/compiler/reference.lux b/stdlib/source/lux/platform/compiler/reference.lux index b945c1327..a20691986 100644 --- a/stdlib/source/lux/platform/compiler/reference.lux +++ b/stdlib/source/lux/platform/compiler/reference.lux @@ -18,7 +18,7 @@ (#Variable Variable) (#Constant Name)) -(structure: #export _ (Equivalence Variable) +(structure: #export equivalence (Equivalence Variable) (def: (= reference sample) (case [reference sample] (^template [<tag>] @@ -29,8 +29,8 @@ _ #0))) -(structure: #export _ (Hash Variable) - (def: eq Equivalence<Variable>) +(structure: #export hash (Hash Variable) + (def: &equivalence ..equivalence) (def: (hash var) (case var (#Local register) diff --git a/stdlib/source/lux/platform/interpreter.lux b/stdlib/source/lux/platform/interpreter.lux index a75cbc01e..87206750d 100644 --- a/stdlib/source/lux/platform/interpreter.lux +++ b/stdlib/source/lux/platform/interpreter.lux @@ -5,7 +5,7 @@ ["ex" exception (#+ exception:)]] [data ["." error (#+ Error)] - ["." text ("text/." Equivalence<Text>) + ["." text ("text/." equivalence) format]] [type (#+ :share) ["." check]] @@ -56,7 +56,7 @@ (All [anchor expression statement] (Operation anchor expression statement Any)) (statement.lift-analysis - (do phase.Monad<Operation> + (do phase.monad [_ (module.create 0 ..module)] (analysis.set-current-module ..module)))) @@ -87,7 +87,7 @@ (def: (interpret-statement code) (All [anchor expression statement] (-> Code <Interpretation>)) - (do phase.Monad<Operation> + (do phase.monad [_ (total.phase code) _ init.refresh] (wrap [Any []]))) @@ -95,7 +95,7 @@ (def: (interpret-expression code) (All [anchor expression statement] (-> Code <Interpretation>)) - (do phase.Monad<Operation> + (do phase.monad [state (extension.lift phase.get-state) #let [analyse (get@ [#statement.analysis #statement.phase] state) synthesize (get@ [#statement.synthesis #statement.phase] state) @@ -146,7 +146,7 @@ (def: (execute configuration code) (All [anchor expression statement] (-> Configuration Code (Operation anchor expression statement Text))) - (do phase.Monad<Operation> + (do phase.monad [[codeT codeV] (interpret configuration code) state phase.get-state] (wrap (/type.represent (get@ [#extension.state @@ -165,7 +165,7 @@ (def: (read-eval-print context) (All [anchor expression statement] (-> <Context> (Error [<Context> Text]))) - (do error.Monad<Error> + (do error.monad [#let [[_where _offset _code] (get@ #source context)] [source' input] (syntax.parse ..module syntax.no-aliases (text.size _code) (get@ #source context)) [state' representation] (let [## TODO: Simplify ASAP diff --git a/stdlib/source/lux/platform/interpreter/type.lux b/stdlib/source/lux/platform/interpreter/type.lux index 698238e1c..f6a66a76a 100644 --- a/stdlib/source/lux/platform/interpreter/type.lux +++ b/stdlib/source/lux/platform/interpreter/type.lux @@ -32,12 +32,12 @@ (def: primitive-representation (Poly Representation) (`` ($_ p.either - (do p.Monad<Parser> + (do p.monad [_ (poly.exactly Any)] (wrap (function.constant "[]"))) (~~ (do-template [<type> <formatter>] - [(do p.Monad<Parser> + [(do p.monad [_ (poly.sub <type>)] (wrap (|>> (:coerce <type>) <formatter>)))] @@ -52,7 +52,7 @@ (-> (Poly Representation) (Poly Representation)) (`` ($_ p.either (~~ (do-template [<type> <formatter>] - [(do p.Monad<Parser> + [(do p.monad [_ (poly.sub <type>)] (wrap (|>> (:coerce <type>) <formatter>)))] @@ -64,12 +64,12 @@ [JSON %json] [XML %xml])) - (do p.Monad<Parser> + (do p.monad [[_ elemT] (poly.apply (p.and (poly.exactly List) poly.any)) elemR (poly.local (list elemT) representation)] (wrap (|>> (:coerce (List Any)) (%list elemR)))) - (do p.Monad<Parser> + (do p.monad [[_ elemT] (poly.apply (p.and (poly.exactly Maybe) poly.any)) elemR (poly.local (list elemT) representation)] (wrap (|>> (:coerce (Maybe Any)) @@ -81,7 +81,7 @@ (def: (record-representation tags representation) (-> (List Name) (Poly Representation) (Poly Representation)) - (do p.Monad<Parser> + (do p.monad [membersR+ (poly.tuple (p.many representation)) _ (p.assert "Number of tags does not match record type size." (n/= (list.size tags) (list.size membersR+)))] @@ -103,7 +103,7 @@ (def: (variant-representation tags representation) (-> (List Name) (Poly Representation) (Poly Representation)) - (do p.Monad<Parser> + (do p.monad [casesR+ (poly.variant (p.many representation)) #let [num-tags (list.size tags)] _ (p.assert "Number of tags does not match variant type size." @@ -131,7 +131,7 @@ (def: (tagged-representation compiler representation) (-> Lux (Poly Representation) (Poly Representation)) - (do p.Monad<Parser> + (do p.monad [[name anonymous] poly.named] (case (macro.run compiler (macro.tags-of name)) (#error.Success ?tags) @@ -149,7 +149,7 @@ (def: (tuple-representation representation) (-> (Poly Representation) (Poly Representation)) - (do p.Monad<Parser> + (do p.monad [membersR+ (poly.tuple (p.many representation))] (wrap (function (_ tupleV) (let [tuple-body (loop [representations membersR+ @@ -176,7 +176,7 @@ (tagged-representation compiler representation) (tuple-representation representation) - (do p.Monad<Parser> + (do p.monad [[funcT inputsT+] (poly.apply (p.and poly.any (p.many poly.any)))] (case (type.apply inputsT+ funcT) (#.Some outputT) @@ -185,7 +185,7 @@ #.None (p.fail ""))) - (do p.Monad<Parser> + (do p.monad [[name anonymous] poly.named] (poly.local (list anonymous) representation)) diff --git a/stdlib/source/lux/platform/mediator.lux b/stdlib/source/lux/platform/mediator.lux new file mode 100644 index 000000000..4481b6e2e --- /dev/null +++ b/stdlib/source/lux/platform/mediator.lux @@ -0,0 +1,20 @@ +(.module: + [lux (#- Source Module) + [data + ["." error (#+ Error)]] + [world + ["." binary (#+ Binary)] + ["." file (#+ File)]]] + [// + [compiler (#+ Compiler) + [meta + ["." archive (#+ Archive) + [descriptor (#+ Module)]]]]]) + +(type: #export Source File) + +(type: #export (Mediator !) + (-> Archive Module (! Archive))) + +(type: #export (Instancer ! d o) + (-> (file.System !) (List Source) (Compiler d o) (Mediator !))) diff --git a/stdlib/source/lux/platform/mediator/parallelism.lux b/stdlib/source/lux/platform/mediator/parallelism.lux new file mode 100644 index 000000000..251ec1f9f --- /dev/null +++ b/stdlib/source/lux/platform/mediator/parallelism.lux @@ -0,0 +1,169 @@ +(.module: + [lux (#- Source Module) + [control + ["." monad (#+ Monad do)] + ["ex" exception (#+ exception:)]] + [concurrency + ["." promise (#+ Promise) ("promise/." functor)] + ["." task (#+ Task)] + ["." stm (#+ Var STM)]] + [data + ["." error (#+ Error) ("error/." monad)] + ["." text ("text/." equivalence) + format] + [collection + [list ("list/." functor)] + ["." dictionary (#+ Dictionary)]]] + ["." io]] + ["." // (#+ Source Mediator) + [// + ["." compiler (#+ Input Output Compilation Compiler) + [meta + ["." archive (#+ Archive) + ["." descriptor (#+ Module Descriptor)] + [document (#+ Document)]] + [io + ["." context]]]]]]) + +(exception: #export (self-dependency {module Module}) + (ex.report ["Module" module])) + +(exception: #export (circular-dependency {module Module} {dependency Module}) + (ex.report ["Module" module] + ["Dependency" dependency])) + +(type: Pending-Compilation + (Promise (Error (Ex [d] (Document d))))) + +(type: Active-Compilations + (Dictionary Module [Descriptor Pending-Compilation])) + +(def: (self-dependence? module dependency) + (-> Module Module Bit) + (text/= module dependency)) + +(def: (circular-dependence? active dependency) + (-> Active-Compilations Module Bit) + (case (dictionary.get dependency active) + (#.Some [descriptor pending]) + (case (get@ #descriptor.state descriptor) + #.Active + true + + _ + false) + + #.None + false)) + +(def: (ensure-valid-dependencies! active dependencies module) + (-> Active-Compilations (List Module) Module (Task Any)) + (do task.monad + [_ (: (Task Any) + (if (list.any? (self-dependence? module) dependencies) + (task.throw self-dependency module) + (wrap [])))] + (: (Task Any) + (case (list.find (circular-dependence? active) dependencies) + (#.Some dependency) + (task.throw circular-dependency module dependency) + + #.None + (wrap []))))) + +(def: (share-compilation archive pending) + (-> Active-Compilations Pending-Compilation (Task Archive)) + (promise/map (|>> (error/map (function (_ document) + (archive.add module document archive))) + error/join) + pending)) + +(def: (import Monad<!> mediate archive dependencies) + (All [!] (-> (Monad !) (Mediator !) Active-Compilations (List Module) (! (List Archive)))) + (|> dependencies + (list/map (mediate archive)) + (monad.seq Monad<!>))) + +(def: (step-compilation archive imports [dependencies process]) + (All [d o] (-> Archive (List Archive) (Compilation d o) + [Archive (Either (Compilation d o) + [(Document d) (Output o)])])) + (do error.monad + [archive' (monad.fold error.monad archive.merge archive imports) + outcome (process archive')] + (case outcome + (#.Right [document output]) + (do @ + [archive'' (archive.add module document archive')] + (wrap [archive'' (#.Right [document output])])) + + (#.Left continue) + (wrap [archive' outcome])))) + +(def: (request-compilation file-system sources module compilations) + (All [!] + (-> (file.System Task) (List Source) Module (Var Active-Compilations) + (Task (Either Pending-Compilation + [Pending-Compilation Active-Compilations Input])))) + (do (:: file-system &monad) + [current (|> (stm.read compilations) + stm.commit + task.from-promise)] + (case (dictionary.get module current) + (#.Some [descriptor pending]) + (wrap (#.Left pending)) + + #.None + (do @ + [input (context.read file-system sources module)] + (do stm.monad + [stale (stm.read compilations)] + (case (dictionary.get module stale) + (#.Some [descriptor pending]) + (wrap (#.Left [pending current])) + + #.None + (do @ + [#let [base-descriptor {#descriptor.hash (get@ #compiler.hash input) + #descriptor.name (get@ #compiler.module input) + #descriptor.file (get@ #compiler.file input) + #descriptor.references (list) + #descriptor.state #.Active} + pending (promise.promise (: (Maybe (Error (Ex [d] (Document d)))) + #.None))] + updated (stm.update (dictionary.put (get@ #compiler.module input) + [base-descriptor pending]) + compilations)] + (wrap (is? current stale) + (#.Right [pending updated input]))))))))) + +(def: (mediate-compilation Monad<!> mediate compiler input archive pending) + (All [! d o] (-> (Monad !) (Mediator ! d o) (Compiler d o) Input Archive Pending-Compilation (Task Archive))) + (loop [archive archive + compilation (compiler input)] + (do Monad<!> + [#let [[dependencies process] compilation] + _ (ensure-valid-dependencies! active dependencies (get@ #compiler.module input)) + imports (import @ mediate archive dependencies) + [archive' next] (promise/wrap (step-compilation archive imports compilation))] + (case next + (#.Left continue) + (recur archive' continue) + + (#.Right [document output]) + (exec (io.run (promise.resolve (#error.Success document) pending)) + (wrap archive')))))) + +(def: #export (mediator file-system sources compiler) + (//.Instancer Task) + (let [compilations (: (Var Active-Compilations) + (stm.var (dictionary.new text.hash)))] + (function (mediate archive module) + (do (:: file-system &monad) + [request (request-compilation file-system sources module compilations)] + (case request + (#.Left pending) + (share-compilation archive pending) + + (#.Right [pending active input]) + (mediate-compilation @ mediate compiler input archive pending)))))) diff --git a/stdlib/source/lux/test.lux b/stdlib/source/lux/test.lux index a96af556b..86957c223 100644 --- a/stdlib/source/lux/test.lux +++ b/stdlib/source/lux/test.lux @@ -4,18 +4,18 @@ ["." monad (#+ Monad do)] ["ex" exception (#+ exception:)] [concurrency - ["." promise (#+ Promise) ("promise/." Monad<Promise>)]]] + ["." promise (#+ Promise) ("promise/." monad)]]] [data ["." product] ["." text format] [collection - ["." list ("list/." Functor<List>)]]] + ["." list ("list/." functor)]]] [time ["." instant] ["." duration]] [math - ["r" random ("random/." Monad<Random>)]] + ["r" random ("random/." monad)]] ["." io]]) (type: #export Counters @@ -47,10 +47,10 @@ (def: #export (and left right) {#.doc "Sequencing combinator."} (-> Test Test Test) - (do r.Monad<Random> + (do r.monad [left left right right] - (wrap (do promise.Monad<Promise> + (wrap (do promise.monad [[l-counter l-documentation] left [r-counter r-documentation] right] (wrap [(add-counters l-counter r-counter) @@ -88,7 +88,7 @@ (def: #export (test message condition) {#.doc "Check that a condition is #1, and fail with the given message otherwise."} (-> Text Bit Test) - (:: r.Monad<Random> wrap (assert message condition))) + (:: r.monad wrap (assert message condition))) (def: pcg-32-magic-inc Nat 12345) @@ -123,11 +123,11 @@ test ## else - (do r.Monad<Random> + (do r.monad [seed r.nat] (function (_ prng) (let [[prng' instance] (r.run (r.pcg-32 [..pcg-32-magic-inc seed]) test)] - [prng' (do promise.Monad<Promise> + [prng' (do promise.monad [[counters documentation] instance] (if (failed? counters) (wrap [counters (times-failure seed documentation)]) @@ -146,7 +146,7 @@ (def: #export (run! test) (-> Test (Promise Nothing)) - (do promise.Monad<Promise> + (do promise.monad [pre (promise.future instant.now) #let [seed (instant.to-millis pre) prng (r.pcg-32 [..pcg-32-magic-inc seed])] diff --git a/stdlib/source/lux/time/date.lux b/stdlib/source/lux/time/date.lux index 27113d336..1bee129e4 100644 --- a/stdlib/source/lux/time/date.lux +++ b/stdlib/source/lux/time/date.lux @@ -1,198 +1,37 @@ (.module: [lux #* [control - equivalence - order - enum + [equivalence (#+ Equivalence)] + [order (#+ Order)] + [enum (#+ Enum)] codec - ["p" parser ("p/." Functor<Parser>)] + ["p" parser ("p/." functor)] [monad (#+ do)]] [data ["." error (#+ Error)] ["." maybe] - ["." number ("nat/." Codec<Text,Nat>) ("int/." Codec<Text,Int>)] - [text ("text/." Monoid<Text>) + [number + ["." nat ("nat/." decimal)] + ["." int ("int/." decimal)]] + [text ("text/." monoid) ["l" lexer]] [collection - ["." row (#+ Row row)]]]]) + ["." row (#+ Row row)]]]] + [// + ["//." month (#+ Month)]]) (type: #export Year Int) -(type: #export Month - #January - #February - #March - #April - #May - #June - #July - #August - #September - #October - #November - #December) - -(structure: #export _ (Equivalence Month) - (def: (= reference sample) - (case [reference sample] - (^template [<tag>] - [<tag> <tag>] - #1) - ([#January] - [#February] - [#March] - [#April] - [#May] - [#June] - [#July] - [#August] - [#September] - [#October] - [#November] - [#December]) - - _ - #0))) - -(def: (month-to-nat month) - (-> Month Nat) - (case month - #January 00 - #February 01 - #March 02 - #April 03 - #May 04 - #June 05 - #July 06 - #August 07 - #September 08 - #October 09 - #November 10 - #December 11)) - -(`` (structure: #export _ (Order Month) - (def: eq Equivalence<Month>) - (~~ (do-template [<name> <comp>] - [(def: (<name> reference sample) - (<comp> (month-to-nat reference) (month-to-nat sample)))] - - [< n/<] - [<= n/<=] - [> n/>] - [>= n/>=] - )))) - -(structure: #export _ (Enum Month) - (def: order Order<Month>) - (def: (succ month) - (case month - #January #February - #February #March - #March #April - #April #May - #May #June - #June #July - #July #August - #August #September - #September #October - #October #November - #November #December - #December #January)) - (def: (pred month) - (case month - #February #January - #March #February - #April #March - #May #April - #June #May - #July #June - #August #July - #September #August - #October #September - #November #October - #December #November - #January #December))) - -(type: #export Day - #Sunday - #Monday - #Tuesday - #Wednesday - #Thursday - #Friday - #Saturday) - -(structure: #export _ (Equivalence Day) - (def: (= reference sample) - (case [reference sample] - (^template [<tag>] - [<tag> <tag>] - #1) - ([#Sunday] - [#Monday] - [#Tuesday] - [#Wednesday] - [#Thursday] - [#Friday] - [#Saturday]) - - _ - #0))) - -(def: (day-to-nat day) - (-> Day Nat) - (case day - #Sunday 0 - #Monday 1 - #Tuesday 2 - #Wednesday 3 - #Thursday 4 - #Friday 5 - #Saturday 6)) - -(`` (structure: #export _ (Order Day) - (def: eq Equivalence<Day>) - (~~ (do-template [<name> <comp>] - [(def: (<name> reference sample) - (<comp> (day-to-nat reference) (day-to-nat sample)))] - - [< n/<] - [<= n/<=] - [> n/>] - [>= n/>=] - )))) - -(structure: #export _ (Enum Day) - (def: order Order<Day>) - (def: (succ day) - (case day - #Sunday #Monday - #Monday #Tuesday - #Tuesday #Wednesday - #Wednesday #Thursday - #Thursday #Friday - #Friday #Saturday - #Saturday #Sunday)) - (def: (pred day) - (case day - #Monday #Sunday - #Tuesday #Monday - #Wednesday #Tuesday - #Thursday #Wednesday - #Friday #Thursday - #Saturday #Friday - #Sunday #Saturday))) - (type: #export Date {#year Year #month Month #day Nat}) -(structure: #export _ (Equivalence Date) +(structure: #export equivalence (Equivalence Date) (def: (= reference sample) (and (i/= (get@ #year reference) (get@ #year sample)) - (:: Equivalence<Month> = + (:: //month.equivalence = (get@ #month reference) (get@ #month sample)) (n/= (get@ #day reference) @@ -202,23 +41,23 @@ (-> Date Date Bit) (or (i/< (get@ #year reference) (get@ #year sample)) - (:: Order<Month> < + (:: //month.order < (get@ #month reference) (get@ #month sample)) (n/< (get@ #day reference) (get@ #day sample)))) -(structure: #export _ (Order Date) - (def: eq Equivalence<Date>) +(structure: #export order (Order Date) + (def: &equivalence ..equivalence) (def: < date/<) (def: (> reference sample) (date/< sample reference)) (def: (<= reference sample) (or (date/< reference sample) - (:: Equivalence<Date> = reference sample))) + (:: ..equivalence = reference sample))) (def: (>= reference sample) (or (date/< sample reference) - (:: Equivalence<Date> = sample reference)))) + (:: ..equivalence = sample reference)))) ## Based on this: https://stackoverflow.com/a/42936293/6823464 (def: (pad value) @@ -235,14 +74,14 @@ (int/encode year) (nat/encode (.nat year))) "-" - (pad (|> month month-to-nat inc .int)) "-" + (pad (|> month //month.number inc .int)) "-" (pad (|> day .int)))) (def: lex-year (l.Lexer Int) - (do p.Monad<Parser> + (do p.monad [sign (p.maybe (l.this "-")) - raw-year (p.codec number.Codec<Text,Nat> (l.many l.decimal)) + raw-year (p.codec nat.decimal (l.many l.decimal)) #let [signum (case sign (#.Some _) -1 @@ -253,7 +92,7 @@ (def: lex-section (l.Lexer Int) - (p/map .int (p.codec number.Codec<Text,Nat> (l.exactly 2 l.decimal)))) + (p/map .int (p.codec nat.decimal (l.exactly 2 l.decimal)))) (def: (leap-years year) (-> Int Int) @@ -285,13 +124,24 @@ ## Based on: https://stackoverflow.com/a/3309340/6823464 (def: lex-date (l.Lexer Date) - (do p.Monad<Parser> + (do p.monad [utc-year lex-year _ (l.this "-") utc-month lex-section - _ (p.assert "Invalid month." - (and (i/>= +1 utc-month) - (i/<= +12 utc-month))) + month (case utc-month + +01 (wrap #//month.January) + +02 (wrap #//month.February) + +03 (wrap #//month.March) + +04 (wrap #//month.April) + +05 (wrap #//month.May) + +06 (wrap #//month.June) + +07 (wrap #//month.July) + +08 (wrap #//month.August) + +09 (wrap #//month.September) + +10 (wrap #//month.October) + +11 (wrap #//month.November) + +12 (wrap #//month.December) + _ (p.fail "Invalid month.")) #let [months (if (leap-year? utc-year) leap-year-months normal-months) @@ -304,27 +154,14 @@ (and (i/>= +1 utc-day) (i/<= (.int month-days) utc-day)))] (wrap {#year utc-year - #month (case utc-month - +01 #January - +02 #February - +03 #March - +04 #April - +05 #May - +06 #June - +07 #July - +08 #August - +09 #September - +10 #October - +11 #November - +12 #December - _ (undefined)) + #month month #day (.nat utc-day)}))) (def: (decode input) (-> Text (Error Date)) (l.run input ..lex-date)) -(structure: #export _ +(structure: #export codec {#.doc (doc "Based on ISO 8601." "For example: 2017-01-15")} (Codec Text Date) diff --git a/stdlib/source/lux/time/day.lux b/stdlib/source/lux/time/day.lux new file mode 100644 index 000000000..2288111d7 --- /dev/null +++ b/stdlib/source/lux/time/day.lux @@ -0,0 +1,76 @@ +(.module: + [lux #* + [control + [equivalence (#+ Equivalence)] + [order (#+ Order)] + [enum (#+ Enum)]]]) + +(type: #export Day + #Sunday + #Monday + #Tuesday + #Wednesday + #Thursday + #Friday + #Saturday) + +(structure: #export equivalence (Equivalence Day) + (def: (= reference sample) + (case [reference sample] + (^template [<tag>] + [<tag> <tag>] + #1) + ([#Sunday] + [#Monday] + [#Tuesday] + [#Wednesday] + [#Thursday] + [#Friday] + [#Saturday]) + + _ + #0))) + +(def: (day-to-nat day) + (-> Day Nat) + (case day + #Sunday 0 + #Monday 1 + #Tuesday 2 + #Wednesday 3 + #Thursday 4 + #Friday 5 + #Saturday 6)) + +(`` (structure: #export order (Order Day) + (def: &equivalence ..equivalence) + (~~ (do-template [<name> <comp>] + [(def: (<name> reference sample) + (<comp> (day-to-nat reference) (day-to-nat sample)))] + + [< n/<] + [<= n/<=] + [> n/>] + [>= n/>=] + )))) + +(structure: #export enum (Enum Day) + (def: &order ..order) + (def: (succ day) + (case day + #Sunday #Monday + #Monday #Tuesday + #Tuesday #Wednesday + #Wednesday #Thursday + #Thursday #Friday + #Friday #Saturday + #Saturday #Sunday)) + (def: (pred day) + (case day + #Monday #Sunday + #Tuesday #Monday + #Wednesday #Tuesday + #Thursday #Wednesday + #Friday #Thursday + #Saturday #Friday + #Sunday #Saturday))) diff --git a/stdlib/source/lux/time/duration.lux b/stdlib/source/lux/time/duration.lux index 9821bc33d..3c3fab0dd 100644 --- a/stdlib/source/lux/time/duration.lux +++ b/stdlib/source/lux/time/duration.lux @@ -8,8 +8,10 @@ ["p" parser] [monad (#+ do)]] [data - ["." number ("nat/." Codec<Text,Nat>) ("int/." Codec<Text,Int> Number<Int>)] - [text ("text/." Monoid<Text>) + [number + ["." nat ("nat/." decimal)] + ["." int ("int/." decimal number)]] + [text ("text/." monoid) ["l" lexer]] ["e" error]] [type @@ -57,12 +59,12 @@ (-> Duration Duration Int) (i// (:representation param) (:representation subject))) - (structure: #export _ (Equivalence Duration) + (structure: #export equivalence (Equivalence Duration) (def: (= param subject) (i/= (:representation param) (:representation subject)))) - (`` (structure: #export _ (Order Duration) - (def: eq Equivalence<Duration>) + (`` (structure: #export order (Order Duration) + (def: &equivalence ..equivalence) (~~ (do-template [<name> <op>] [(def: (<name> param subject) (<op> (:representation param) (:representation subject)))] @@ -73,7 +75,7 @@ [>= i/>=] )))) - (open: "duration/." Order<Duration>) + (open: "duration/." ..order) (do-template [<name> <op>] [(def: #export (<name> left right) @@ -113,13 +115,13 @@ (def: #export leap-year (merge day normal-year)) -(structure: #export _ (Monoid Duration) - (def: identity empty) - (def: compose merge)) +(structure: #export monoid (Monoid Duration) + (def: identity ..empty) + (def: compose ..merge)) (def: #export (encode duration) (-> Duration Text) - (if (:: Equivalence<Duration> = empty duration) + (if (:: ..equivalence = empty duration) "+0ms" (let [signed? (negative? duration) [days time-left] [(query day duration) (frame day duration)] diff --git a/stdlib/source/lux/time/instant.lux b/stdlib/source/lux/time/instant.lux index d8fb0fe98..b85e3edd1 100644 --- a/stdlib/source/lux/time/instant.lux +++ b/stdlib/source/lux/time/instant.lux @@ -2,26 +2,29 @@ [lux #* [io (#+ IO io)] [control - equivalence - order - enum + [equivalence (#+ Equivalence)] + [order (#+ Order)] + [enum (#+ Enum)] codec [monad (#+ do Monad)] ["p" parser]] [data ["." error (#+ Error)] ["." maybe] - ["." number ("int/." Codec<Text,Int>)] - [text ("text/." Monoid<Text>) + [number + ["." int ("int/." decimal)]] + [text ("text/." monoid) ["l" lexer]] [collection - ["." list ("list/." Fold<List>)] - ["." row (#+ Row row) ("row/." Functor<Row> Fold<Row>)]]] + ["." list ("list/." fold)] + ["." row (#+ Row row) ("row/." functor fold)]]] [type abstract]] [// - ["." duration ("duration/." Order<Duration>)] - ["." date]]) + ["." duration ("duration/." order)] + ["." date (#+ Date)] + ["." month (#+ Month)] + ["." day (#+ Day)]]) (abstract: #export Instant {#.doc "Instant is defined as milliseconds since the epoch."} @@ -51,24 +54,24 @@ (-> duration.Duration Instant) (|> offset duration.to-millis :abstraction)) - (structure: #export _ (Equivalence Instant) + (structure: #export equivalence (Equivalence Instant) (def: (= param subject) - (:: number.Equivalence<Int> = (:representation param) (:representation subject)))) + (:: int.equivalence = (:representation param) (:representation subject)))) - (`` (structure: #export _ (Order Instant) - (def: eq Equivalence<Instant>) + (`` (structure: #export order (Order Instant) + (def: &equivalence ..equivalence) (~~ (do-template [<name>] [(def: (<name> param subject) - (:: number.Order<Int> <name> (:representation param) (:representation subject)))] + (:: int.order <name> (:representation param) (:representation subject)))] [<] [<=] [>] [>=] )))) - (`` (structure: #export _ (Enum Instant) - (def: order Order<Instant>) + (`` (structure: #export enum (Enum Instant) + (def: &order ..order) (~~ (do-template [<name>] [(def: <name> - (|>> :representation (:: number.Enum<Int> <name>) :abstraction))] + (|>> :representation (:: int.enum <name>) :abstraction))] [succ] [pred] )))) @@ -217,9 +220,9 @@ ## Codec::decode (def: lex-year (l.Lexer Int) - (do p.Monad<Parser> + (do p.monad [sign (p.or (l.this "-") (l.this "+")) - raw-year (p.codec number.Codec<Text,Int> (l.many l.decimal)) + raw-year (p.codec int.decimal (l.many l.decimal)) #let [signum (case sign (#.Left _) -1 (#.Right _) +1)]] @@ -227,14 +230,14 @@ (def: lex-section (l.Lexer Int) - (p.codec number.Codec<Text,Int> (l.exactly 2 l.decimal))) + (p.codec int.decimal (l.exactly 2 l.decimal))) (def: lex-millis (l.Lexer Int) (p.either (|> (l.at-most 3 l.decimal) - (p.codec number.Codec<Text,Int>) + (p.codec int.decimal) (p.after (l.this "."))) - (:: p.Monad<Parser> wrap +0))) + (:: p.monad wrap +0))) (def: (leap-years year) (-> Int Int) @@ -245,7 +248,7 @@ ## Based on: https://stackoverflow.com/a/3309340/6823464 ## (def: lex-instant ## (l.Lexer Instant) -## (do p.Monad<Parser> +## (do p.monad ## [utc-year lex-year ## _ (l.this "-") ## utc-month lex-section @@ -315,32 +318,32 @@ (io (from-millis ("lux io current-time")))) (def: #export (date instant) - (-> Instant date.Date) + (-> Instant Date) (let [[[year month day] _] (extract-date instant)] {#date.year year #date.month (case (dec month) - +0 #date.January - +1 #date.February - +2 #date.March - +3 #date.April - +4 #date.May - +5 #date.June - +6 #date.July - +7 #date.August - +8 #date.September - +9 #date.October - +10 #date.November - +11 #date.December + +0 #month.January + +1 #month.February + +2 #month.March + +3 #month.April + +4 #month.May + +5 #month.June + +6 #month.July + +7 #month.August + +8 #month.September + +9 #month.October + +10 #month.November + +11 #month.December _ (undefined)) #date.day (.nat day)})) (def: #export (month instant) - (-> Instant date.Month) + (-> Instant Month) (let [[year month day] (date instant)] month)) (def: #export (day instant) - (-> Instant date.Day) + (-> Instant Day) (let [offset (relative instant) days (duration.query duration.day offset) day-time (duration.frame duration.day offset) @@ -354,11 +357,11 @@ (i/+ days) (i/% +7) ## This is done to turn negative days into positive days. (i/+ +7) (i/% +7)) - +0 #date.Sunday - +1 #date.Monday - +2 #date.Tuesday - +3 #date.Wednesday - +4 #date.Thursday - +5 #date.Friday - +6 #date.Saturday + +0 #day.Sunday + +1 #day.Monday + +2 #day.Tuesday + +3 #day.Wednesday + +4 #day.Thursday + +5 #day.Friday + +6 #day.Saturday _ (undefined)))) diff --git a/stdlib/source/lux/time/month.lux b/stdlib/source/lux/time/month.lux new file mode 100644 index 000000000..203f5c6cb --- /dev/null +++ b/stdlib/source/lux/time/month.lux @@ -0,0 +1,101 @@ +(.module: + [lux #* + [control + [equivalence (#+ Equivalence)] + [order (#+ Order)] + [enum (#+ Enum)]]]) + +(type: #export Month + #January + #February + #March + #April + #May + #June + #July + #August + #September + #October + #November + #December) + +(structure: #export equivalence (Equivalence Month) + (def: (= reference sample) + (case [reference sample] + (^template [<tag>] + [<tag> <tag>] + #1) + ([#January] + [#February] + [#March] + [#April] + [#May] + [#June] + [#July] + [#August] + [#September] + [#October] + [#November] + [#December]) + + _ + #0))) + +(def: #export (number month) + (-> Month Nat) + (case month + #January 00 + #February 01 + #March 02 + #April 03 + #May 04 + #June 05 + #July 06 + #August 07 + #September 08 + #October 09 + #November 10 + #December 11)) + +(`` (structure: #export order (Order Month) + (def: &equivalence ..equivalence) + (~~ (do-template [<name> <comp>] + [(def: (<name> reference sample) + (<comp> (number reference) (number sample)))] + + [< n/<] + [<= n/<=] + [> n/>] + [>= n/>=] + )))) + +(structure: #export enum (Enum Month) + (def: &order ..order) + (def: (succ month) + (case month + #January #February + #February #March + #March #April + #April #May + #May #June + #June #July + #July #August + #August #September + #September #October + #October #November + #November #December + #December #January)) + (def: (pred month) + (case month + #February #January + #March #February + #April #March + #May #April + #June #May + #July #June + #August #July + #September #August + #October #September + #November #October + #December #November + #January #December))) diff --git a/stdlib/source/lux/type.lux b/stdlib/source/lux/type.lux index 3615ac808..e72eccd55 100644 --- a/stdlib/source/lux/type.lux +++ b/stdlib/source/lux/type.lux @@ -2,21 +2,21 @@ [lux (#- function) [control [equivalence (#+ Equivalence)] - [monad (#+ do Monad)] + [monad (#+ Monad do)] ["p" parser]] [data - ["." text ("text/." Monoid<Text> Equivalence<Text>)] - [name ("name/." Equivalence<Name> Codec<Text,Name>)] - [number ("nat/." Codec<Text,Nat>)] + ["." text ("text/." monoid equivalence)] + [name ("name/." equivalence codec)] + [number + [nat ("nat/." decimal)]] ["." maybe] [collection ["." array] - ["." list ("list/." Functor<List> Monoid<List> Fold<List>)]]] + ["." list ("list/." functor monoid fold)]]] ["." macro ["." code] ["s" syntax (#+ Syntax syntax:)]]]) -## [Utils] (def: (beta-reduce env type) (-> (List Type) Type Type) (case type @@ -48,8 +48,7 @@ type )) -## [Structures] -(structure: #export _ (Equivalence Type) +(structure: #export equivalence (Equivalence Type) (def: (= x y) (case [x y] [(#.Primitive xname xparams) (#.Primitive yname yparams)] @@ -90,7 +89,6 @@ #0 ))) -## [Values] (do-template [<name> <tag>] [(def: #export (<name> type) (-> Type [Nat Type]) @@ -321,7 +319,7 @@ (#.Apply A F) (maybe.default #0 - (do maybe.Monad<Maybe> + (do maybe.monad [applied (apply (list A) F)] (wrap (quantified? applied)))) diff --git a/stdlib/source/lux/type/abstract.lux b/stdlib/source/lux/type/abstract.lux index ccb6b9e18..fb086d2ed 100644 --- a/stdlib/source/lux/type/abstract.lux +++ b/stdlib/source/lux/type/abstract.lux @@ -2,15 +2,15 @@ [lux (#- Scope) [control [monad (#+ Monad do)] - ["p" parser ("p/." Monad<Parser>)] + ["p" parser ("p/." monad)] ["ex" exception (#+ exception:)]] [data - [name ("name/." Codec<Text,Name>)] - [text ("text/." Equivalence<Text> Monoid<Text>)] + [name ("name/." codec)] + [text ("text/." equivalence monoid)] [collection - ["." list ("list/." Functor<List> Monoid<List>)] + ["." list ("list/." functor monoid)] ["." stack (#+ Stack)]]] - ["." macro ("meta/." Monad<Meta>) + ["." macro ("meta/." monad) ["." code] ["s" syntax (#+ Syntax syntax:)] [syntax @@ -166,7 +166,7 @@ (def: declaration (Syntax [Text (List Text)]) (p.either (s.form (p.and s.local-identifier (p.some s.local-identifier))) - (p.and s.local-identifier (:: p.Monad<Parser> wrap (list))))) + (p.and s.local-identifier (:: p.monad wrap (list))))) ## TODO: Make sure the generated code always gets optimized away. ## (This applies to uses of ":abstraction" and ":representation") diff --git a/stdlib/source/lux/type/check.lux b/stdlib/source/lux/type/check.lux index fa6067ab6..d12b19599 100644 --- a/stdlib/source/lux/type/check.lux +++ b/stdlib/source/lux/type/check.lux @@ -3,18 +3,19 @@ [control [functor (#+ Functor)] [apply (#+ Apply)] - ["." monad (#+ do Monad)] + ["." monad (#+ Monad do)] ["ex" exception (#+ exception:)]] [data ["." maybe] ["." product] ["." error (#+ Error)] - ["." number ("nat/." Codec<Text,Nat>)] - ["." text ("text/." Monoid<Text> Equivalence<Text>)] + [number + ["." nat ("nat/." decimal)]] + ["." text ("text/." monoid equivalence)] [collection ["." list] ["." set (#+ Set)]]]] - ["." // ("type/." Equivalence<Type>)]) + ["." // ("type/." equivalence)]) (template: (!n/= reference subject) ("lux i64 =" subject reference)) @@ -51,7 +52,7 @@ (type: #export Type-Vars (List [Var (Maybe Type)])) -(structure: #export _ (Functor Check) +(structure: #export functor (Functor Check) (def: (map f fa) (function (_ context) (case (fa context) @@ -61,8 +62,8 @@ (#error.Failure error) (#error.Failure error))))) -(structure: #export _ (Apply Check) - (def: functor Functor<Check>) +(structure: #export apply (Apply Check) + (def: &functor ..functor) (def: (apply ff fa) (function (_ context) @@ -80,8 +81,8 @@ ))) ) -(structure: #export _ (Monad Check) - (def: functor Functor<Check>) +(structure: #export monad (Monad Check) + (def: &functor ..functor) (def: (wrap x) (function (_ context) @@ -103,7 +104,7 @@ ))) ) -(open: "check/." Monad<Check>) +(open: "check/." ..monad) (def: (var::get id plist) (-> Var Type-Vars (Maybe (Maybe Type))) @@ -148,7 +149,6 @@ #.Nil #.Nil)) -## [[Logic]] (def: #export (run context proc) (All [a] (-> Type-Context (Check a) (Error a))) (case (proc context) @@ -241,7 +241,7 @@ (-> Type Type (Check Type)) (case funcT (#.Var func-id) - (do Monad<Check> + (do ..monad [?funcT' (read func-id)] (case ?funcT' (#.Some funcT') @@ -260,7 +260,7 @@ (type: #export Ring (Set Var)) -(def: empty-ring Ring (set.new number.Hash<Nat>)) +(def: empty-ring Ring (set.new nat.hash)) ## TODO: Optimize this by not using sets anymore. (def: #export (ring start) @@ -341,29 +341,29 @@ (-> Var Type (Check a) (-> Type (Check a)) (Check a))) ($_ either - (do Monad<Check> + (do ..monad [_ (..bind type id)] then) - (do Monad<Check> + (do ..monad [ring (..ring id) _ (assert "" (n/> 1 (set.size ring))) _ (monad.map @ (update type) (set.to-list ring))] then) - (do Monad<Check> + (do ..monad [?bound (read id)] (else (maybe.default (#.Var id) ?bound))))) ## TODO: "link-2" can be optimized... (def: (link-2 left right) (-> Var Var (Check Any)) - (do Monad<Check> + (do ..monad [_ (..bind (#.Var right) left)] (..bind (#.Var left) right))) ## TODO: "link-3" can be optimized... (def: (link-3 interpose to from) (-> Var Var Var (Check Any)) - (do Monad<Check> + (do ..monad [_ (update (#.Var interpose) from)] (update (#.Var to) interpose))) @@ -375,7 +375,7 @@ (Check (List Assumption))) (if (!n/= idE idA) (check/wrap assumptions) - (do Monad<Check> + (do ..monad [ebound (attempt (peek idE)) abound (attempt (peek idA))] (case [ebound abound] @@ -413,7 +413,7 @@ (do @ [ringE (..ring idE) ringA (..ring idA)] - (if (:: set.Equivalence<Set> = ringE ringA) + (if (:: set.equivalence = ringE ringA) (wrap assumptions) ## Fuse 2 rings (do @ @@ -464,43 +464,43 @@ (Check (List Assumption))) (case [eFT aFT] (^or [(#.UnivQ _ _) (#.Ex _)] [(#.UnivQ _ _) (#.Var _)]) - (do Monad<Check> + (do ..monad [eFT' (apply-type! eFT eAT)] (check' assumptions eFT' (#.Apply aAT aFT))) (^or [(#.Ex _) (#.UnivQ _ _)] [(#.Var _) (#.UnivQ _ _)]) - (do Monad<Check> + (do ..monad [aFT' (apply-type! aFT aAT)] (check' assumptions (#.Apply eAT eFT) aFT')) (^or [(#.Ex _) _] [_ (#.Ex _)]) - (do Monad<Check> + (do ..monad [assumptions (check' assumptions eFT aFT)] (check' assumptions eAT aAT)) [(#.Var id) _] - (do Monad<Check> + (do ..monad [?rFT (read id)] (case ?rFT (#.Some rFT) (check' assumptions (#.Apply eAT rFT) (#.Apply aAT aFT)) _ - (do Monad<Check> + (do ..monad [assumptions (check' assumptions eFT aFT) e' (apply-type! aFT eAT) a' (apply-type! aFT aAT)] (check' assumptions e' a')))) [_ (#.Var id)] - (do Monad<Check> + (do ..monad [?rFT (read id)] (case ?rFT (#.Some rFT) (check' assumptions (#.Apply eAT eFT) (#.Apply aAT rFT)) _ - (do Monad<Check> + (do ..monad [assumptions (check' assumptions eFT aFT) e' (apply-type! eFT eAT) a' (apply-type! eFT aAT)] @@ -545,19 +545,19 @@ (let [new-assumption [expected actual]] (if (assumed? new-assumption assumptions) (check/wrap assumptions) - (do Monad<Check> + (do ..monad [expected' (apply-type! F A)] (check' (assume! new-assumption assumptions) expected' actual)))) [_ (#.Apply A F)] - (do Monad<Check> + (do ..monad [actual' (apply-type! F A)] (check' assumptions expected actual')) ## TODO: Refactor-away as cold-code (^template [<tag> <instancer>] [(<tag> _) _] - (do Monad<Check> + (do ..monad [[_ paramT] <instancer> expected' (apply-type! expected paramT)] (check' assumptions expected' actual))) @@ -567,7 +567,7 @@ ## TODO: Refactor-away as cold-code (^template [<tag> <instancer>] [_ (<tag> _)] - (do Monad<Check> + (do ..monad [[_ paramT] <instancer> actual' (apply-type! actual paramT)] (check' assumptions expected actual'))) @@ -584,7 +584,7 @@ (check/wrap assumptions) [(#.Cons e-head e-tail) (#.Cons a-head a-tail)] - (do Monad<Check> + (do ..monad [assumptions' (check' assumptions e-head a-head)] (recur assumptions' e-tail a-tail)) @@ -594,14 +594,14 @@ (^template [<compose>] [(<compose> eL eR) (<compose> aL aR)] - (do Monad<Check> + (do ..monad [assumptions (check' assumptions eL aL)] (check' assumptions eR aR))) ([#.Sum] [#.Product]) [(#.Function eI eO) (#.Function aI aO)] - (do Monad<Check> + (do ..monad [assumptions (check' assumptions aI eI)] (check' assumptions eO aO)) @@ -644,7 +644,7 @@ (case inputT (#.Primitive name paramsT+) (|> paramsT+ - (monad.map Monad<Check> clean) + (monad.map ..monad clean) (check/map (|>> (#.Primitive name)))) (^or (#.Parameter _) (#.Ex _) (#.Named _)) @@ -652,14 +652,14 @@ (^template [<tag>] (<tag> leftT rightT) - (do Monad<Check> + (do ..monad [leftT' (clean leftT)] (|> (clean rightT) (check/map (|>> (<tag> leftT')))))) ([#.Sum] [#.Product] [#.Function] [#.Apply]) (#.Var id) - (do Monad<Check> + (do ..monad [?actualT (read id)] (case ?actualT (#.Some actualT) @@ -670,7 +670,7 @@ (^template [<tag>] (<tag> envT+ unquantifiedT) - (do Monad<Check> + (do ..monad [envT+' (monad.map @ clean envT+)] (wrap (<tag> envT+' unquantifiedT)))) ([#.UnivQ] [#.ExQ]) diff --git a/stdlib/source/lux/type/dynamic.lux b/stdlib/source/lux/type/dynamic.lux index 6fb83f8fb..cda9ac14b 100644 --- a/stdlib/source/lux/type/dynamic.lux +++ b/stdlib/source/lux/type/dynamic.lux @@ -36,7 +36,7 @@ (with-gensyms [g!type g!value] (wrap (list (` (let [[(~ g!type) (~ g!value)] ((~! ..dynamic-representation) (~ value))] (: ((~! error.Error) (~ type)) - (if (:: (~! type.Equivalence<Type>) (~' =) + (if (:: (~! type.equivalence) (~' =) (.type (~ type)) (~ g!type)) (#error.Success (:coerce (~ type) (~ g!value))) ((~! ex.throw) ..wrong-type [(.type (~ type)) (~ g!type)]))))))))) diff --git a/stdlib/source/lux/type/implicit.lux b/stdlib/source/lux/type/implicit.lux index 42db42900..83a8e9998 100644 --- a/stdlib/source/lux/type/implicit.lux +++ b/stdlib/source/lux/type/implicit.lux @@ -8,10 +8,10 @@ ["." product] ["." maybe] ["." number] - ["." text ("text/." Equivalence<Text>) + ["." text ("text/." equivalence) format] [collection - ["." list ("list/." Monad<List> Fold<List>)] + ["." list ("list/." monad fold)] ["dict" dictionary (#+ Dictionary)]]] ["." macro ["." code] @@ -29,7 +29,7 @@ (find-type-var id' env) _ - (:: macro.Monad<Meta> wrap type)) + (:: macro.monad wrap type)) (#.Some [_ #.None]) (macro.fail (format "Unbound type-var " (%n id))) @@ -40,7 +40,7 @@ (def: (resolve-type var-name) (-> Name (Meta Type)) - (do macro.Monad<Meta> + (do macro.monad [raw-type (macro.find-type var-name) compiler macro.get-compiler] (case raw-type @@ -66,23 +66,23 @@ (#.Product left right) (if (n/= 0 idx) - (:: check.Monad<Check> wrap left) + (:: check.monad wrap left) (find-member-type (dec idx) right)) _ (if (n/= 0 idx) - (:: check.Monad<Check> wrap sig-type) + (:: check.monad wrap sig-type) (check.fail (format "Cannot find member type " (%n idx) " for " (%type sig-type)))))) (def: (find-member-name member) (-> Name (Meta Name)) (case member ["" simple-name] - (macro.either (do macro.Monad<Meta> + (macro.either (do macro.monad [member (macro.normalize member) _ (macro.resolve-tag member)] (wrap member)) - (do macro.Monad<Meta> + (do macro.monad [this-module-name macro.current-module-name imp-mods (macro.imported-modules this-module-name) tag-lists (monad.map @ macro.tag-lists imp-mods) @@ -100,11 +100,11 @@ (macro.fail (format "Too many candidate tags: " (%list %name candidates)))))) _ - (:: macro.Monad<Meta> wrap member))) + (:: macro.monad wrap member))) (def: (resolve-member member) (-> Name (Meta [Nat Type])) - (do macro.Monad<Meta> + (do macro.monad [member (find-member-name member) [idx tag-list sig-type] (macro.resolve-tag member)] (wrap [idx sig-type]))) @@ -119,12 +119,12 @@ (def: local-env (Meta (List [Name Type])) - (do macro.Monad<Meta> + (do macro.monad [local-batches macro.locals #let [total-locals (list/fold (function (_ [name type] table) (dict.put~ name type table)) (: (Dictionary Text Type) - (dict.new text.Hash<Text>)) + (dict.new text.hash)) (list/join local-batches))]] (wrap (|> total-locals dict.entries @@ -132,14 +132,14 @@ (def: local-structs (Meta (List [Name Type])) - (do macro.Monad<Meta> + (do macro.monad [this-module-name macro.current-module-name definitions (macro.definitions this-module-name)] (wrap (prepare-definitions this-module-name definitions)))) (def: import-structs (Meta (List [Name Type])) - (do macro.Monad<Meta> + (do macro.monad [this-module-name macro.current-module-name imp-mods (macro.imported-modules this-module-name) export-batches (monad.map @ (function (_ imp-mod) @@ -156,13 +156,13 @@ (apply-function-type func' arg) (#.UnivQ _) - (do check.Monad<Check> + (do check.monad [[id var] check.var] (apply-function-type (maybe.assume (type.apply (list var) func)) arg)) (#.Function input output) - (do check.Monad<Check> + (do check.monad [_ (check.check input arg)] (wrap output)) @@ -173,19 +173,19 @@ (-> Type (Check [(List Nat) Type])) (case type (#.UnivQ _) - (do check.Monad<Check> + (do check.monad [[id var] check.var [ids final-output] (concrete-type (maybe.assume (type.apply (list var) type)))] (wrap [(#.Cons id ids) final-output])) _ - (:: check.Monad<Check> wrap [(list) type]))) + (:: check.monad wrap [(list) type]))) (def: (check-apply member-type input-types output-type) (-> Type (List Type) Type (Check [])) - (do check.Monad<Check> - [member-type' (monad.fold check.Monad<Check> + (do check.monad + [member-type' (monad.fold check.monad (function (_ input member) (apply-function-type member input)) member-type @@ -200,12 +200,12 @@ (-> (-> Lux Type-Context Type (Check Instance)) Type-Context Type (List [Name Type]) (Meta (List Instance))) - (do macro.Monad<Meta> + (do macro.monad [compiler macro.get-compiler] (case (|> alts (list/map (function (_ [alt-name alt-type]) (case (check.run context - (do check.Monad<Check> + (do check.monad [[tvars alt-type] (concrete-type alt-type) #let [[deps alt-type] (type.flatten-function alt-type)] _ (check.check dep alt-type) @@ -228,9 +228,9 @@ (-> Lux Type-Context Type (Check Instance)) (case (macro.run compiler ($_ macro.either - (do macro.Monad<Meta> [alts local-env] (test-provision provision context dep alts)) - (do macro.Monad<Meta> [alts local-structs] (test-provision provision context dep alts)) - (do macro.Monad<Meta> [alts import-structs] (test-provision provision context dep alts)))) + (do macro.monad [alts local-env] (test-provision provision context dep alts)) + (do macro.monad [alts local-structs] (test-provision provision context dep alts)) + (do macro.monad [alts import-structs] (test-provision provision context dep alts)))) (#.Left error) (check.fail error) @@ -240,7 +240,7 @@ (check.fail (format "No candidates for provisioning: " (%type dep))) (#.Cons winner #.Nil) - (:: check.Monad<Check> wrap winner) + (:: check.monad wrap winner) _ (check.fail (format "Too many candidates for provisioning: " (%type dep) " --- " (%list (|>> product.left %name) candidates)))) @@ -248,13 +248,13 @@ (def: (test-alternatives sig-type member-idx input-types output-type alts) (-> Type Nat (List Type) Type (List [Name Type]) (Meta (List Instance))) - (do macro.Monad<Meta> + (do macro.monad [compiler macro.get-compiler context macro.type-context] (case (|> alts (list/map (function (_ [alt-name alt-type]) (case (check.run context - (do check.Monad<Check> + (do check.monad [[tvars alt-type] (concrete-type alt-type) #let [[deps alt-type] (type.flatten-function alt-type)] _ (check.check alt-type sig-type) @@ -279,9 +279,9 @@ (-> Type Nat (List Type) Type (Meta (List Instance))) (let [test (test-alternatives sig-type member-idx input-types output-type)] ($_ macro.either - (do macro.Monad<Meta> [alts local-env] (test alts)) - (do macro.Monad<Meta> [alts local-structs] (test alts)) - (do macro.Monad<Meta> [alts import-structs] (test alts))))) + (do macro.monad [alts local-env] (test alts)) + (do macro.monad [alts local-structs] (test alts)) + (do macro.monad [alts import-structs] (test alts))))) (def: (var? input) (-> Code Bit) @@ -320,7 +320,7 @@ "a compile-time error will be raised, to alert the user." "Examples:" "Nat equivalence" - (:: number.Equivalence<Nat> = x y) + (:: number.equivalence = x y) (::: = x y) "Can optionally add the prefix of the module where the signature was defined." (::: eq.= x y) @@ -366,7 +366,7 @@ (-> Nat (Meta (List Code))) (|> (macro.gensym "g!implicit") (list.repeat amount) - (monad.seq macro.Monad<Meta>))) + (monad.seq macro.monad))) (def: implicits (Syntax (List Code)) diff --git a/stdlib/source/lux/type/quotient.lux b/stdlib/source/lux/type/quotient.lux index 46f485720..7d56a1b24 100644 --- a/stdlib/source/lux/type/quotient.lux +++ b/stdlib/source/lux/type/quotient.lux @@ -49,7 +49,7 @@ (def: (quotient-type constructor-type) (-> Type (Error Type)) (<| (poly.run constructor-type) - (do p.Monad<Parser> + (do p.monad [[valueT classT quotient-ex] (<| poly.apply (p.after (poly.exactly ..Class)) ($_ p.and poly.any poly.any poly.existential))] (wrap (.type (..Quotient valueT classT (:~ (#.Ex quotient-ex)))))))) diff --git a/stdlib/source/lux/type/refinement.lux b/stdlib/source/lux/type/refinement.lux index 4ccfd02be..5f5673785 100644 --- a/stdlib/source/lux/type/refinement.lux +++ b/stdlib/source/lux/type/refinement.lux @@ -6,7 +6,7 @@ ["p" parser]] [data ["." error (#+ Error)]] - ["." type ("type/." Equivalence<Type>) + ["." type ("type/." equivalence) abstract] ["." macro ["s" syntax (#+ syntax:)] @@ -87,7 +87,7 @@ (def: (refinement-type constructor-type) (-> Type (Error Type)) (<| (poly.run constructor-type) - (do p.Monad<Parser> + (do p.monad [[un-refinedT refined-ex] (poly.apply (p.after (poly.exactly ..Refiner) (p.and poly.any poly.existential)))] (wrap (.type (..Refined un-refinedT (#.Ex refined-ex))))))) diff --git a/stdlib/source/lux/type/resource.lux b/stdlib/source/lux/type/resource.lux index d3f7b7ab0..963034dbb 100644 --- a/stdlib/source/lux/type/resource.lux +++ b/stdlib/source/lux/type/resource.lux @@ -16,7 +16,7 @@ ["dict" dictionary (#+ Dictionary)] ["." set] ["." row (#+ Row)] - ["." list ("list/." Functor<List> Fold<List>)]]] + ["." list ("list/." functor fold)]]] [concurrency ["." promise (#+ Promise)]] ["." macro @@ -40,7 +40,7 @@ (All [keys] (Procedure monad [permissions keys] keys value))) -(structure: (IxMonad<Procedure> Monad<m>) +(structure: (indexed Monad<m>) (All [m] (-> (Monad m) (IxMonad (Procedure m)))) (def: (wrap value) @@ -56,7 +56,7 @@ (do-template [<name> <m> <monad> <execute> <lift>] [(def: #export <name> (IxMonad (Procedure <m>)) - (IxMonad<Procedure> <monad>)) + (..indexed <monad>)) (def: #export (<execute> procedure) (All [v] (-> (Linear <m> v) (<m> v))) @@ -71,9 +71,9 @@ [output procedure] (wrap [keys output]))))] - [IxMonad<Pure> Identity identity.Monad<Identity> run-pure lift-pure] - [IxMonad<Sync> IO io.Monad<IO> run-sync lift-sync] - [IxMonad<Async> Promise promise.Monad<Promise> run-async lift-async] + [pure Identity identity.monad run-pure lift-pure] + [sync IO io.monad run-sync lift-sync] + [async Promise promise.monad run-async lift-async] ) (abstract: #export Ordered {} []) @@ -105,12 +105,12 @@ (function (_ keys) (:: <monad> wrap [[(<key> []) keys] (:abstraction value)])))] - [ordered-pure Identity identity.Monad<Identity> Ordered ordered-key] - [ordered-sync IO io.Monad<IO> Ordered ordered-key] - [ordered-async Promise promise.Monad<Promise> Ordered ordered-key] - [commutative-sync IO io.Monad<IO> Commutative commutative-key] - [commutative-pure Identity identity.Monad<Identity> Commutative commutative-key] - [commutative-async Promise promise.Monad<Promise> Commutative commutative-key]) + [ordered-pure Identity identity.monad Ordered ordered-key] + [ordered-sync IO io.monad Ordered ordered-key] + [ordered-async Promise promise.monad Ordered ordered-key] + [commutative-sync IO io.monad Commutative commutative-key] + [commutative-pure Identity identity.monad Commutative commutative-key] + [commutative-async Promise promise.monad Commutative commutative-key]) (do-template [<name> <m> <monad>] [(def: #export (<name> resource) @@ -119,9 +119,9 @@ (function (_ [key keys]) (:: <monad> wrap [keys (:representation resource)])))] - [read-pure Identity identity.Monad<Identity>] - [read-sync IO io.Monad<IO>] - [read-async Promise promise.Monad<Promise>])) + [read-pure Identity identity.monad] + [read-sync IO io.monad] + [read-async Promise promise.monad])) (exception: #export (index-cannot-be-repeated {index Nat}) (%n index)) @@ -130,8 +130,8 @@ (def: indices (Syntax (List Nat)) - (s.tuple (loop [seen (set.new number.Hash<Nat>)] - (do p.Monad<Parser> + (s.tuple (loop [seen (set.new number.hash)] + (do p.monad [done? s.end?] (if done? (wrap (list)) @@ -154,12 +154,12 @@ (wrap (list (` ((~! no-op) <monad>)))) (#.Cons head tail) - (do macro.Monad<Meta> + (do macro.monad [#let [max-idx (list/fold n/max head tail)] g!inputs (<| (monad.seq @) (list.repeat (inc max-idx)) (macro.gensym "input")) - #let [g!outputs (|> (monad.fold maybe.Monad<Maybe> + #let [g!outputs (|> (monad.fold maybe.monad (function (_ from to) - (do maybe.Monad<Maybe> + (do maybe.monad [input (list.nth from g!inputs)] (wrap (row.add input to)))) (: (Row Code) row.empty) @@ -176,13 +176,13 @@ (function ((~ g!_) [(~+ g!inputs) (~ g!context)]) (:: (~! <monad>) (~' wrap) [[(~+ g!outputs) (~ g!context)] []]))))))))))] - [exchange-pure Identity identity.Monad<Identity>] - [exchange-sync IO io.Monad<IO>] - [exchange-async Promise promise.Monad<Promise>]) + [exchange-pure Identity identity.monad] + [exchange-sync IO io.monad] + [exchange-async Promise promise.monad]) (def: amount (Syntax Nat) - (do p.Monad<Parser> + (do p.monad [raw s.nat _ (p.assert (ex.construct amount-cannot-be-zero []) (n/> 0 raw))] @@ -191,7 +191,7 @@ (do-template [<name> <m> <monad> <from> <to>] [(syntax: #export (<name> {amount ..amount}) (macro.with-gensyms [g!_ g!context] - (do macro.Monad<Meta> + (do macro.monad [g!keys (<| (monad.seq @) (list.repeat amount) (macro.gensym "keys"))] (wrap (list (` (: (All [(~+ g!keys) (~ g!context)] (Procedure (~! <m>) @@ -201,10 +201,10 @@ (function ((~ g!_) [<from> (~ g!context)]) (:: (~! <monad>) (~' wrap) [[<to> (~ g!context)] []])))))))))] - [group-pure Identity identity.Monad<Identity> (~+ g!keys) [(~+ g!keys)]] - [group-sync IO io.Monad<IO> (~+ g!keys) [(~+ g!keys)]] - [group-async Promise promise.Monad<Promise> (~+ g!keys) [(~+ g!keys)]] - [un-group-pure Identity identity.Monad<Identity> [(~+ g!keys)] (~+ g!keys)] - [un-group-sync IO io.Monad<IO> [(~+ g!keys)] (~+ g!keys)] - [un-group-async Promise promise.Monad<Promise> [(~+ g!keys)] (~+ g!keys)] + [group-pure Identity identity.monad (~+ g!keys) [(~+ g!keys)]] + [group-sync IO io.monad (~+ g!keys) [(~+ g!keys)]] + [group-async Promise promise.monad (~+ g!keys) [(~+ g!keys)]] + [un-group-pure Identity identity.monad [(~+ g!keys)] (~+ g!keys)] + [un-group-sync IO io.monad [(~+ g!keys)] (~+ g!keys)] + [un-group-async Promise promise.monad [(~+ g!keys)] (~+ g!keys)] ) diff --git a/stdlib/source/lux/type/unit.lux b/stdlib/source/lux/type/unit.lux index d6cd4ac6b..3aece5ff1 100644 --- a/stdlib/source/lux/type/unit.lux +++ b/stdlib/source/lux/type/unit.lux @@ -2,7 +2,7 @@ (.module: [lux #* [control - [monad (#+ do Monad)] + [monad (#+ Monad do)] ["p" parser] [equivalence (#+ Equivalence)] [order (#+ Order)] @@ -83,7 +83,7 @@ (def: ratio^ (s.Syntax r.Ratio) - (s.tuple (do p.Monad<Parser> + (s.tuple (do p.monad [numerator s.int _ (p.assert (format "Numerator must be positive: " (%i numerator)) (i/> +0 numerator)) @@ -164,12 +164,12 @@ (unit: #export Litre) (unit: #export Second) -(structure: #export Equivalence<Unit> (All [unit] (Equivalence (Qty unit))) +(structure: #export equivalence (All [unit] (Equivalence (Qty unit))) (def: (= reference sample) (i/= (out reference) (out sample)))) -(`` (structure: #export Order<Unit> (All [unit] (Order (Qty unit))) - (def: eq Equivalence<Unit>) +(`` (structure: #export order (All [unit] (Order (Qty unit))) + (def: &equivalence ..equivalence) (~~ (do-template [<name> <func>] [(def: (<name> reference sample) @@ -180,7 +180,7 @@ [> i/>] [>= i/>=])))) -(structure: #export Enum<Unit> (All [unit] (Enum (Qty unit))) - (def: order Order<Unit>) +(structure: #export enum (All [unit] (Enum (Qty unit))) + (def: &order ..order) (def: succ (|>> ..out inc ..in)) (def: pred (|>> ..out dec ..in))) diff --git a/stdlib/source/lux/world/binary.lux b/stdlib/source/lux/world/binary.lux index 8e5b3901d..7ccc9e1cb 100644 --- a/stdlib/source/lux/world/binary.lux +++ b/stdlib/source/lux/world/binary.lux @@ -159,12 +159,12 @@ (-> Nat Binary (Error Binary)) (slice from (dec (..!size binary)) binary)) -(structure: #export _ (Equivalence Binary) +(structure: #export equivalence (Equivalence Binary) (def: (= reference sample) (Arrays::equals reference sample))) (def: #export (copy bytes source-offset source target-offset target) (-> Nat Nat Binary Nat Binary (Error Binary)) - (do error.Monad<Error> + (do error.monad [_ (System::arraycopy source (.int source-offset) target (.int target-offset) (.int bytes))] (wrap target))) diff --git a/stdlib/source/lux/world/console.lux b/stdlib/source/lux/world/console.lux index b02f0f69d..dedf3603f 100644 --- a/stdlib/source/lux/world/console.lux +++ b/stdlib/source/lux/world/console.lux @@ -71,7 +71,7 @@ (def: #export system (IO (Error (Console IO))) - (do io.Monad<IO> + (do io.monad [?jvm-console (System::console)] (case ?jvm-console #.None @@ -87,12 +87,12 @@ (def: (read _) (|> jvm-input InputStream::read - (:: io.Functor<Process> map (|>> .nat integrity.taint)))) + (:: (error.with-error io.functor) map (|>> .nat integrity.taint)))) (def: (read-line _) (|> jvm-console java/io/Console::readLine - (:: io.Functor<Process> map integrity.taint))) + (:: (error.with-error io.functor) map integrity.taint))) (def: (write message) (PrintStream::print message jvm-output)) diff --git a/stdlib/source/lux/world/db/jdbc.jvm.lux b/stdlib/source/lux/world/db/jdbc.jvm.lux index 2d3721716..9dd3ce890 100644 --- a/stdlib/source/lux/world/db/jdbc.jvm.lux +++ b/stdlib/source/lux/world/db/jdbc.jvm.lux @@ -6,7 +6,7 @@ [monad (#+ Monad do)] ["ex" exception] [concurrency - ["." promise (#+ Promise) ("promise/." Monad<Promise>)]] + ["." promise (#+ Promise) ("promise/." monad)]] [security [capability (#+ Capability)]]] [data @@ -16,7 +16,7 @@ [text format] [collection - [list ("list/." Fold<List>)]]] + [list ("list/." fold)]]] ["." io (#+ IO)] [world [net (#+ URL)]] @@ -57,7 +57,7 @@ (type: #export ID Int) -(def: #export Equivalence<ID> number.Equivalence<Int>) +(def: #export equivalence number.int-equivalence) (type: #export (Statement input) {#sql sql.Statement @@ -96,7 +96,7 @@ (-> (Statement i) java/sql/Connection (-> java/sql/PreparedStatement (IO (Error a))) (IO (Error a)))) - (do (error.ErrorT io.Monad<IO>) + (do (error.ErrorT io.monad) [prepared (io.io (java/sql/Connection::prepareStatement (sql.sql (get@ #sql statement)) (java/sql/Statement::RETURN_GENERATED_KEYS) conn)) @@ -115,7 +115,7 @@ (def: #export (connect creds) (-> Credentials (IO (Error (DB IO)))) - (do (error.ErrorT io.Monad<IO>) + (do (error.ErrorT io.monad) [connection (java/sql/DriverManager::getConnection (get@ #url creds) (get@ #user creds) (get@ #password creds))] @@ -124,14 +124,14 @@ (def: (execute statement) (with-statement statement connection (function (_ prepared) - (do (error.ErrorT io.Monad<IO>) + (do (error.ErrorT io.monad) [row-count (java/sql/PreparedStatement::executeUpdate prepared)] (wrap (.nat row-count)))))) (def: (insert statement) (with-statement statement connection (function (_ prepared) - (do (error.ErrorT io.Monad<IO>) + (do (error.ErrorT io.monad) [_ (java/sql/PreparedStatement::executeUpdate prepared) result-set (io.io (java/sql/Statement::getGeneratedKeys prepared))] (/output.rows /output.long result-set))))) @@ -142,7 +142,7 @@ (def: (query [statement output]) (with-statement statement connection (function (_ prepared) - (do (error.ErrorT io.Monad<IO>) + (do (error.ErrorT io.monad) [result-set (java/sql/PreparedStatement::executeQuery prepared)] (/output.rows output result-set))))) ))))) @@ -152,7 +152,7 @@ (-> Credentials (-> (DB IO) (IO (Error a))) (IO (Error a)))) - (do (error.ErrorT io.Monad<IO>) + (do (error.ErrorT io.monad) [db (..connect creds) result (action db) _ (:: db close [])] @@ -163,7 +163,7 @@ (-> Credentials (-> (DB Promise) (Promise (Error a))) (Promise (Error a)))) - (do (error.ErrorT promise.Monad<Promise>) + (do (error.ErrorT promise.monad) [db (promise.future (..connect creds)) result (action (..async db)) _ (promise/wrap (io.run (:: db close [])))] diff --git a/stdlib/source/lux/world/db/jdbc/input.jvm.lux b/stdlib/source/lux/world/db/jdbc/input.jvm.lux index d037d4234..ef9db9009 100644 --- a/stdlib/source/lux/world/db/jdbc/input.jvm.lux +++ b/stdlib/source/lux/world/db/jdbc/input.jvm.lux @@ -6,7 +6,7 @@ [data ["." error (#+ Error)] [collection - [list ("list/." Fold<List>)]]] + [list ("list/." fold)]]] [time ["." instant (#+ Instant)]] ["." io (#+ IO)] @@ -57,7 +57,7 @@ (def: #export (and pre post) (All [l r] (-> (Input l) (Input r) (Input [l r]))) (function (_ [left right] context) - (do error.Monad<Error> + (do error.monad [context (pre left context)] (post right context)))) @@ -75,7 +75,7 @@ [(def: #export <function> (Input <type>) (function (_ value [idx statement]) - (do error.Monad<Error> + (do error.monad [_ (<setter> (.int idx) value statement)] (wrap [(.inc idx) statement]))))] @@ -97,7 +97,7 @@ [(def: #export <function> (Input Instant) (function (_ value [idx statement]) - (do error.Monad<Error> + (do error.monad [_ (<setter> (.int idx) (<constructor> (instant.to-millis value)) statement)] diff --git a/stdlib/source/lux/world/db/jdbc/output.jvm.lux b/stdlib/source/lux/world/db/jdbc/output.jvm.lux index a28a6254e..7a45011f5 100644 --- a/stdlib/source/lux/world/db/jdbc/output.jvm.lux +++ b/stdlib/source/lux/world/db/jdbc/output.jvm.lux @@ -50,7 +50,7 @@ (type: #export (Output a) (-> [Nat java/sql/ResultSet] (Error [Nat a]))) -(structure: #export _ (Functor Output) +(structure: #export functor (Functor Output) (def: (map f fa) (function (_ idx+rs) (case (fa idx+rs) @@ -60,8 +60,8 @@ (#error.Success [idx' value]) (#error.Success [idx' (f value)]))))) -(structure: #export _ (Apply Output) - (def: functor Functor<Output>) +(structure: #export apply (Apply Output) + (def: &functor ..functor) (def: (apply ff fa) (function (_ [idx rs]) @@ -77,8 +77,8 @@ (#error.Failure msg) (#error.Failure msg))))) -(structure: #export _ (Monad Output) - (def: functor Functor<Output>) +(structure: #export monad (Monad Output) + (def: &functor ..functor) (def: (wrap a) (function (_ [idx rs]) @@ -101,7 +101,7 @@ (def: #export (and left right) (All [a b] (-> (Output a) (Output b) (Output [a b]))) - (do Monad<Output> + (do ..monad [=left left =right right] (wrap [=left =right]))) @@ -155,35 +155,35 @@ (if has-next? (case (output [1 results]) (#.Some [_ head]) - (do io.Monad<IO> + (do io.monad [?tail (rows output results)] (case ?tail (#error.Success tail) (wrap (ex.return (#.Cons head tail))) (#error.Failure error) - (do io.Monad<IO> + (do io.monad [temp (java/sql/ResultSet::close results)] - (wrap (do error.Monad<Error> + (wrap (do error.monad [_ temp] (error.fail error)))))) (#error.Failure error) - (do io.Monad<IO> + (do io.monad [temp (java/sql/ResultSet::close results)] - (wrap (do error.Monad<Error> + (wrap (do error.monad [_ temp] (error.fail error))))) - (do io.Monad<IO> + (do io.monad [temp (java/sql/ResultSet::close results)] - (wrap (do error.Monad<Error> + (wrap (do error.monad [_ temp] (wrap (list)))))) (#error.Failure error) - (do io.Monad<IO> + (do io.monad [temp (java/sql/ResultSet::close results)] - (wrap (do error.Monad<Error> + (wrap (do error.monad [_ temp] (error.fail error)))) )) diff --git a/stdlib/source/lux/world/db/sql.lux b/stdlib/source/lux/world/db/sql.lux index f4704cd94..dad0e4893 100644 --- a/stdlib/source/lux/world/db/sql.lux +++ b/stdlib/source/lux/world/db/sql.lux @@ -3,10 +3,10 @@ [control [monad (#+ do)]] [data - ["." text ("text/." Equivalence<Text>) + ["." text ("text/." equivalence) format] [collection - [list ("list/." Functor<List>)]]] + [list ("list/." functor)]]] [type abstract]]) diff --git a/stdlib/source/lux/world/environment.jvm.lux b/stdlib/source/lux/world/environment.jvm.lux index 1a373ba8c..3d1181614 100644 --- a/stdlib/source/lux/world/environment.jvm.lux +++ b/stdlib/source/lux/world/environment.jvm.lux @@ -52,5 +52,5 @@ Map::entrySet Set::iterator (consume-iterator entry-to-kv) - (dictionary.from-list text.Hash<Text>) + (dictionary.from-list text.hash) integrity.taint))) diff --git a/stdlib/source/lux/world/file.lux b/stdlib/source/lux/world/file.lux index 78556b742..32adc204c 100644 --- a/stdlib/source/lux/world/file.lux +++ b/stdlib/source/lux/world/file.lux @@ -10,12 +10,12 @@ ["!" capability (#+ capability:)]]] [data ["." maybe] - ["." error (#+ Error) ("error/." Functor<Error>)] + ["." error (#+ Error) ("error/." functor)] ["." text format] [collection ["." array (#+ Array)] - ["." list ("list/." Functor<List>)]]] + ["." list ("list/." functor)]]] [time ["." instant (#+ Instant)] ["." duration]] @@ -23,7 +23,7 @@ ["." template]] [world ["." binary (#+ Binary)]] - ["." io (#+ IO) ("io/." Functor<IO>)] + ["." io (#+ IO) ("io/." functor)] [host (#+ import:)] [platform [compiler @@ -185,14 +185,14 @@ ["Path" file])) (template: (!delete path exception) - (do io.Monad<IO> + (do io.monad [outcome (java/io/File::delete (java/io/File::new path))] (case outcome (#error.Success #1) (wrap (#error.Success [])) _ - (io.throw exception [path])))) + (io.io (ex.throw exception [path]))))) (`` (for {(~~ (static host.jvm)) (as-is (import: #long java/io/File @@ -229,14 +229,14 @@ (import: java/io/FileInputStream (new [java/io/File] #io #try)) - (structure: (File<IO> path) + (structure: (file path) (-> Path (File IO)) (~~ (do-template [<name> <flag>] [(def: <name> (..can-modify (function (<name> data) - (do io.Monad<Process> + (do (error.with-error io.monad) [stream (FileOutputStream::new (java/io/File::new path) <flag>) _ (OutputStream::write data stream) _ (OutputStream::flush stream)] @@ -249,7 +249,7 @@ (def: content (..can-query (function (content _) - (do io.Monad<Process> + (do (error.with-error io.monad) [#let [file (java/io/File::new path)] size (java/io/File::length file) #let [data (binary.create (.nat size))] @@ -266,7 +266,7 @@ (|> path java/io/File::new java/io/File::length - (:: io.Monad<Process> map .nat))))) + (:: (error.with-error io.monad) map .nat))))) (def: last-modified (..can-query @@ -274,7 +274,7 @@ (|> path java/io/File::new (java/io/File::lastModified) - (:: io.Monad<Process> map (|>> duration.from-millis instant.absolute)))))) + (:: (error.with-error io.monad) map (|>> duration.from-millis instant.absolute)))))) (def: can-execute? (..can-query @@ -286,20 +286,20 @@ (def: move (..can-open (function (move destination) - (do io.Monad<IO> + (do io.monad [outcome (java/io/File::renameTo (java/io/File::new destination) (java/io/File::new path))] (case outcome (#error.Success #1) - (wrap (#error.Success (File<IO> destination))) + (wrap (#error.Success (file destination))) _ - (io.throw cannot-move [destination path])))))) + (io.io (ex.throw cannot-move [destination path]))))))) (def: modify (..can-modify (function (modify time-stamp) - (do io.Monad<IO> + (do io.monad [outcome (java/io/File::setLastModified (|> time-stamp instant.relative duration.to-millis) (java/io/File::new path))] (case outcome @@ -307,21 +307,21 @@ (wrap (#error.Success [])) _ - (io.throw cannot-modify [time-stamp path])))))) + (io.io (ex.throw cannot-modify [time-stamp path]))))))) (def: delete (..can-delete (function (delete _) (!delete path cannot-delete-file))))) - (structure: (Directory<IO> path) + (structure: (directory path) (-> Path (Directory IO)) (~~ (do-template [<name> <method> <capability>] [(def: <name> (..can-query (function (<name> _) - (do io.Monad<Process> + (do (error.with-error io.monad) [?children (java/io/File::listFiles (java/io/File::new path))] (case ?children (#.Some children) @@ -332,10 +332,10 @@ (:: @ join)) #.None - (io.throw not-a-directory [path]))))))] + (io.io (ex.throw not-a-directory [path])))))))] - [files java/io/File::isFile File<IO>] - [directories java/io/File::isDirectory Directory<IO>] + [files java/io/File::isFile file] + [directories java/io/File::isDirectory directory] )) (def: discard @@ -343,12 +343,12 @@ (function (discard _) (!delete path cannot-discard-directory))))) - (structure: #export _ (System IO) + (structure: #export system (System IO) (~~ (do-template [<name> <method> <capability> <exception>] [(def: <name> (..can-open (function (<name> path) - (do io.Monad<IO> + (do io.monad [#let [file (java/io/File::new path)] outcome (<method> file)] (case outcome @@ -358,10 +358,10 @@ _ (wrap (ex.throw <exception> [path])))))))] - [file java/io/File::isFile ..File<IO> cannot-find-file] - [create-file java/io/File::createNewFile ..File<IO> cannot-create-file] - [directory java/io/File::isDirectory ..Directory<IO> cannot-find-directory] - [create-directory java/io/File::mkdir ..Directory<IO> cannot-create-directory] + [file java/io/File::isFile ..file cannot-find-file] + [create-file java/io/File::createNewFile ..file cannot-create-file] + [directory java/io/File::isDirectory ..directory cannot-find-directory] + [create-directory java/io/File::mkdir ..directory cannot-create-directory] )) (def: separator (java/io/File::separator)) diff --git a/stdlib/source/lux/world/net/http/cookie.lux b/stdlib/source/lux/world/net/http/cookie.lux index d6b0c979d..315a9e12f 100644 --- a/stdlib/source/lux/world/net/http/cookie.lux +++ b/stdlib/source/lux/world/net/http/cookie.lux @@ -2,7 +2,7 @@ [lux #* [control [monad (#+ do)] - ["p" parser ("p/." Monad<Parser>)]] + ["p" parser ("p/." monad)]] [data ["." error (#+ Error)] [text @@ -65,7 +65,7 @@ (def: (cookie context) (-> Context (Lexer Context)) - (do p.Monad<Parser> + (do p.monad [key (l.slice (l.many! (l.none-of! "="))) _ (l.this "=") value (l.slice (l.many! (l.none-of! ";")))] @@ -74,7 +74,7 @@ (def: (cookies context) (-> Context (Lexer Context)) ($_ p.either - (do p.Monad<Parser> + (do p.monad [context' (..cookie context) _ (l.this "; ")] (cookies context')) diff --git a/stdlib/source/lux/world/net/http/mime.lux b/stdlib/source/lux/world/net/http/mime.lux index 191a998ff..272fd1f60 100644 --- a/stdlib/source/lux/world/net/http/mime.lux +++ b/stdlib/source/lux/world/net/http/mime.lux @@ -1,8 +1,9 @@ (.module: [lux #* [data - [text - ["." encoding (#+ Char-Set)]]] + ["." text + format + ["." encoding (#+ Encoding)]]] [type abstract]]) @@ -91,8 +92,8 @@ [!7z "application/x-7z-compressed"] ) -(def: #export (text char-set) - (-> Char-Set MIME) - (..mime (format "text/plain; charset=" text.double-quotes (encoding.name char-set) text.double-quotes))) +(def: #export (text encoding) + (-> Encoding MIME) + (..mime (format "text/plain; charset=" text.double-quote (encoding.name encoding) text.double-quote))) (def: #export utf-8 MIME (..text encoding.utf-8)) diff --git a/stdlib/source/lux/world/net/http/query.lux b/stdlib/source/lux/world/net/http/query.lux index 7d736f46e..716910c4a 100644 --- a/stdlib/source/lux/world/net/http/query.lux +++ b/stdlib/source/lux/world/net/http/query.lux @@ -6,7 +6,8 @@ ["p" parser]] [data ["." error (#+ Error)] - ["." number] + [number + ["." nat]] ["." text format ["l" lexer (#+ Lexer)]] @@ -19,7 +20,7 @@ (Lexer Text) (p.rec (function (_ component) - (do p.Monad<Parser> + (do p.monad [head (l.some (l.none-of "+%&;"))] ($_ p.either (p.after (p.either l.end @@ -32,7 +33,7 @@ (do @ [_ (l.this "%") code (|> (l.exactly 2 l.hexadecimal) - (p.codec number.Hex@Codec<Text,Nat>) + (p.codec nat.hex) (:: @ map text.from-code)) tail component] (wrap (format head code tail)))))))) @@ -40,10 +41,10 @@ (def: (form context) (-> Context (Lexer Context)) ($_ p.either - (do p.Monad<Parser> + (do p.monad [_ l.end] (wrap context)) - (do p.Monad<Parser> + (do p.monad [key (l.some (l.none-of "=&;")) key (l.local key ..component)] (p.either (do @ @@ -56,7 +57,7 @@ l.end)] (form (dictionary.put key "" context))))) ## if invalid form data, just stop parsing... - (:: p.Monad<Parser> wrap context))) + (:: p.monad wrap context))) (def: #export (parameters raw) (-> Text (Error Context)) diff --git a/stdlib/source/lux/world/net/http/request.lux b/stdlib/source/lux/world/net/http/request.lux index 03c78fca8..6025571f5 100644 --- a/stdlib/source/lux/world/net/http/request.lux +++ b/stdlib/source/lux/world/net/http/request.lux @@ -19,7 +19,7 @@ ["." json (#+ JSON)] ["." context (#+ Context Property)]] [collection - [list ("list/." Functor<List> Fold<List>)] + [list ("list/." functor fold)] ["." dictionary]]] [world ["." binary (#+ Binary)]]] @@ -31,10 +31,10 @@ (def: (merge inputs) (-> (List Binary) Binary) (let [[_ output] (error.assume - (monad.fold error.Monad<Error> + (monad.fold error.monad (function (_ input [offset output]) (let [amount (binary.size input)] - (:: error.Functor<Error> map (|>> [(n/+ amount offset)]) + (:: error.functor map (|>> [(n/+ amount offset)]) (binary.copy amount 0 input offset output)))) [0 (|> inputs (list/map binary.size) @@ -45,7 +45,7 @@ (def: (read-text-body body) (-> Body (Promise (Error Text))) - (do promise.Monad<Promise> + (do promise.monad [blobs (frp.consume body)] (wrap (encoding.from-utf8 (merge blobs))))) @@ -55,11 +55,11 @@ (-> (-> (Dirty JSON) Server) Server) (function (_ request) (let [[identification protocol resource message] (integrity.trust request)] - (do promise.Monad<Promise> + (do promise.monad [?raw (read-text-body (get@ #//.body message))] - (case (do error.Monad<Error> + (case (do error.monad [raw ?raw] - (:: json.Codec<Text,JSON> decode raw)) + (:: json.codec decode raw)) (#error.Success content) (server (integrity.taint content) request) @@ -70,7 +70,7 @@ (-> (-> (Dirty Text) Server) Server) (function (_ request) (let [[identification protocol resource message] (integrity.trust request)] - (do promise.Monad<Promise> + (do promise.monad [?raw (read-text-body (get@ #//.body message))] (case ?raw (#error.Success content) @@ -87,7 +87,7 @@ [uri query] (|> full (text.split-with "?") (maybe.default [full ""]))] - (case (do error.Monad<Error> + (case (do error.monad [query (//query.parameters query) input (context.run query property)] (wrap [(integrity.taint [identification protocol (set@ #//.uri uri resource) message]) @@ -102,9 +102,9 @@ (All [a] (-> (Property a) (-> (Dirty a) Server) Server)) (function (_ request) (let [[identification protocol resource message] (integrity.trust request)] - (do promise.Monad<Promise> + (do promise.monad [?body (read-text-body (get@ #//.body message))] - (case (do error.Monad<Error> + (case (do error.monad [body ?body form (//query.parameters body)] (context.run form property)) @@ -118,7 +118,7 @@ (All [a] (-> (Property a) (-> (Dirty a) Server) Server)) (function (_ request) (let [[identification protocol resource message] (integrity.trust request)] - (case (do error.Monad<Error> + (case (do error.monad [cookies (|> (get@ #//.headers message) (dictionary.get "Cookie") (maybe.default "") diff --git a/stdlib/source/lux/world/net/http/response.lux b/stdlib/source/lux/world/net/http/response.lux index cac7866af..ef394613f 100644 --- a/stdlib/source/lux/world/net/http/response.lux +++ b/stdlib/source/lux/world/net/http/response.lux @@ -2,7 +2,7 @@ [lux #* [control [concurrency - ["." frp ("channel/." Monad<Channel>)]]] + ["." frp ("channel/." monad)]]] [data ["." text format @@ -27,7 +27,7 @@ [status {#//.headers (|> context.empty (header.content-length 0) - (header.content-type mime.text)) + (header.content-type mime.utf-8)) #//.body body}]))) (def: #export (temporary-redirect to) @@ -49,20 +49,18 @@ (def: #export bad-request (-> Text Response) - (|>> encoding.to-utf8 (content status.bad-request mime.text))) + (|>> encoding.to-utf8 (content status.bad-request mime.utf-8))) (def: #export ok (-> MIME Binary Response) (content status.ok)) -(def: #export text - (-> Text Response) - (|>> encoding.to-utf8 (..ok mime.text))) - -(def: #export html - (-> html.Document Response) - (|>> html.html encoding.to-utf8 (..ok mime.html))) +(do-template [<name> <type> <mime> <pre>] + [(def: #export <name> + (-> <type> Response) + (|>> <pre> encoding.to-utf8 (..ok <mime>)))] -(def: #export css - (-> CSS Response) - (|>> encoding.to-utf8 (..ok mime.css))) + [text Text mime.utf-8 (<|)] + [html html.Document mime.html html.html] + [css CSS mime.css css.css] + ) diff --git a/stdlib/source/lux/world/net/http/route.lux b/stdlib/source/lux/world/net/http/route.lux index 1825b2795..d7b674366 100644 --- a/stdlib/source/lux/world/net/http/route.lux +++ b/stdlib/source/lux/world/net/http/route.lux @@ -8,7 +8,7 @@ ["." integrity]]] [data ["." maybe] - ["." text ("text/." Equivalence<Text>)]]] + ["." text ("text/." equivalence)]]] ["." // (#+ URI Server) ["//." status] ["//." response]]) @@ -76,7 +76,7 @@ (def: #export (or primary alternative) (-> Server Server Server) (function (_ request) - (do promise.Monad<Promise> + (do promise.monad [response (primary request) #let [[status message] response]] (if (n/= //status.not-found status) diff --git a/stdlib/source/lux/world/net/tcp.jvm.lux b/stdlib/source/lux/world/net/tcp.jvm.lux index de1d9ffef..bc8468c6b 100644 --- a/stdlib/source/lux/world/net/tcp.jvm.lux +++ b/stdlib/source/lux/world/net/tcp.jvm.lux @@ -64,39 +64,39 @@ (`` (for {(~~ (static host.jvm)) (as-is (def: (tcp socket) (-> Socket (Error (TCP IO))) - (do error.Monad<Error> + (do error.monad [input (Socket::getInputStream socket) output (Socket::getOutputStream socket)] (wrap (: (TCP IO) (structure (def: (read size) - (do io.Monad<Process> + (do (error.with-error io.monad) [#let [data (binary.create size)] bytes-read (InputStream::read data +0 (.int size) input)] (wrap [(.nat bytes-read) (integrity.taint data)]))) (def: (write data) - (do io.Monad<Process> + (do (error.with-error io.monad) [_ (OutputStream::write data +0 (.int (binary.size data)) output)] (Flushable::flush output))) (def: (close _) - (do io.Monad<Process> + (do (error.with-error io.monad) [_ (AutoCloseable::close input) _ (AutoCloseable::close output)] (AutoCloseable::close socket)))))))) (def: #export (client address port) (-> //.Address //.Port (IO (Error (TCP IO)))) - (do io.Monad<Process> + (do (error.with-error io.monad) [socket (Socket::new address (.int port))] (io.io (tcp socket)))) (def: #export (server port) (-> //.Port (IO (Error [(Promise Any) (frp.Channel (TCP IO))]))) - (do io.Monad<Process> + (do (error.with-error io.monad) [server (ServerSocket::new (.int port)) #let [close-signal (: (Promise Any) (promise #.None)) @@ -108,8 +108,8 @@ _ (: (Promise Any) (promise.future (loop [_ []] - (do io.Monad<IO> - [?client (do io.Monad<Process> + (do io.monad + [?client (do (error.with-error io.monad) [socket (ServerSocket::accept server)] (io.io (tcp socket)))] (case ?client diff --git a/stdlib/source/lux/world/net/udp.jvm.lux b/stdlib/source/lux/world/net/udp.jvm.lux index c474c5c79..231593de0 100644 --- a/stdlib/source/lux/world/net/udp.jvm.lux +++ b/stdlib/source/lux/world/net/udp.jvm.lux @@ -75,7 +75,7 @@ (`` (for {(~~ (static host.jvm)) (as-is (def: (resolve address) (-> //.Address (IO (Error InetAddress))) - (do io.Monad<Process> + (do (error.with-error io.monad) [addresses (InetAddress::getAllByName address)] (: (IO (Error InetAddress)) (case (array.size addresses) @@ -88,7 +88,7 @@ (structure (def: (read size) (let [data (binary.create size) packet (DatagramPacket::new|receive data +0 (.int size))] - (do io.Monad<Process> + (do (error.with-error io.monad) [_ (DatagramSocket::receive packet socket) #let [bytes-read (.nat (DatagramPacket::getLength packet))]] (wrap [bytes-read @@ -97,7 +97,7 @@ (integrity.taint data)])))) (def: (write [location data]) - (do io.Monad<Process> + (do (error.with-error io.monad) [address (resolve (get@ #//.address location))] (DatagramSocket::send (DatagramPacket::new|send data +0 (.int (binary.size data)) address (.int (get@ #//.port location))) socket))) @@ -108,11 +108,11 @@ (def: #export client (IO (Error (UDP IO))) (|> (DatagramSocket::new|client) - (:: io.Monad<Process> map udp))) + (:: (error.with-error io.monad) map udp))) (def: #export server (-> //.Port (IO (Error (UDP IO)))) (|>> .int DatagramSocket::new|server - (:: io.Monad<Process> map udp))) + (:: (error.with-error io.monad) map udp))) )})) |