From ca297162d5416a8c7b8af5f27757900d82d3ad03 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 12 Nov 2017 23:49:34 -0400 Subject: - Fixed some bugs. - Improved error reporting. - Optimized pattern-matching a bit. --- stdlib/source/lux.lux | 559 +++++++++++++++++----------------- stdlib/source/lux/meta/type.lux | 58 ++-- stdlib/source/lux/meta/type/check.lux | 325 +++++++++++--------- 3 files changed, 491 insertions(+), 451 deletions(-) (limited to 'stdlib/source') diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index c9a800741..738183410 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -1315,7 +1315,8 @@ (def:'' (reverse list) #;Nil (All [a] (#Function ($' List a) ($' List a))) - (fold (function'' [head tail] (#Cons head tail)) + (fold ("lux check" (All [a] (#Function a (#Function ($' List a) ($' List a)))) + (function'' [head tail] (#Cons head tail))) #Nil list)) @@ -1633,8 +1634,8 @@ (#Named ["lux" "Monad"] (All [m] (& (All [a] (-> a ($' m a))) - (All [a b] (-> (-> a ($' m b)) - ($' m a) + (All [a b] (-> ($' m a) + (-> a ($' m b)) ($' m b))))))) (def:''' Monad @@ -1644,7 +1645,7 @@ (function' [x] (#Some x)) #bind - (function' [f ma] + (function' [ma f] ("lux case" ma {#None #None (#Some a) (f a)}))}) @@ -1658,7 +1659,7 @@ (#Right state x))) #bind - (function' [f ma] + (function' [ma f] (function' [state] ("lux case" (ma state) {(#Left msg) @@ -1681,8 +1682,8 @@ _ (form$ (list g!bind - (form$ (list (text$ "lux function") (symbol$ ["" ""]) var body')) - value))})))) + value + (form$ (list (text$ "lux function") (symbol$ ["" ""]) var body'))))})))) body (reverse (as-pairs bindings)))] (return (list (form$ (list (text$ "lux case") @@ -1693,7 +1694,7 @@ _ (fail "Wrong syntax for do")})) -(def:''' (mapM m f xs) +(def:''' (monad/map m f xs) #Nil ## (All [m a b] ## (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) @@ -1710,9 +1711,9 @@ (#Cons x xs') (do m [y (f x) - ys (mapM m f xs')] - (wrap (#Cons y ys)))} - ))) + ys (monad/map m f xs')] + (wrap (#Cons y ys))) + }))) (macro:' #export (if tokens) (list [(tag$ ["lux" "doc"]) @@ -1840,20 +1841,20 @@ {true (do Monad [elems' ("lux check" ($' Meta ($' List Code)) - (mapM Monad - ("lux check" (-> Code ($' Meta Code)) - (function' [elem] - ("lux case" elem - {[_ (#Form (#Cons [[_ (#Symbol ["" "~@"])] (#Cons [spliced #Nil])]))] - (wrap spliced) - - _ - (do Monad - [=elem (untemplate elem)] - (wrap (form$ (list (text$ "lux check") - (form$ (list (tag$ ["lux" "Apply"]) (tuple$ (list (symbol$ ["lux" "Code"]) (symbol$ ["lux" "List"]))))) - (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list =elem (tag$ ["lux" "Nil"])))))))))}))) - elems))] + (monad/map Monad + ("lux check" (-> Code ($' Meta Code)) + (function' [elem] + ("lux case" elem + {[_ (#Form (#Cons [[_ (#Symbol ["" "~@"])] (#Cons [spliced #Nil])]))] + (wrap spliced) + + _ + (do Monad + [=elem (untemplate elem)] + (wrap (form$ (list (text$ "lux check") + (form$ (list (tag$ ["lux" "Apply"]) (tuple$ (list (symbol$ ["lux" "Code"]) (symbol$ ["lux" "List"]))))) + (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list =elem (tag$ ["lux" "Nil"])))))))))}))) + elems))] (wrap (wrap-meta (form$ (list tag (form$ (list& (symbol$ ["lux" "$_"]) (symbol$ ["lux" "splice-helper"]) @@ -1861,11 +1862,11 @@ false (do Monad - [=elems (mapM Monad untemplate elems)] + [=elems (monad/map Monad untemplate elems)] (wrap (wrap-meta (form$ (list tag (untemplate-list =elems))))))}) false (do Monad - [=elems (mapM Monad untemplate elems)] + [=elems (monad/map Monad untemplate elems)] (wrap (wrap-meta (form$ (list tag (untemplate-list =elems))))))})) (def:''' (untemplate replace? subst token) @@ -1935,15 +1936,15 @@ [_ [_ (#Record fields)]] (do Monad - [=fields (mapM Monad - ("lux check" (-> (& Code Code) ($' Meta Code)) - (function' [kv] - (let' [[k v] kv] - (do Monad - [=k (untemplate replace? subst k) - =v (untemplate replace? subst v)] - (wrap (tuple$ (list =k =v))))))) - fields)] + [=fields (monad/map Monad + ("lux check" (-> (& Code Code) ($' Meta Code)) + (function' [kv] + (let' [[k v] kv] + (do Monad + [=k (untemplate replace? subst k) + =v (untemplate replace? subst v)] + (wrap (tuple$ (list =k =v))))))) + fields)] (wrap (wrap-meta (form$ (list (tag$ ["lux" "Record"]) (untemplate-list =fields))))))} )) @@ -2190,8 +2191,8 @@ [i.dec -1])")]) ("lux case" tokens {(#Cons [[_ (#Tuple bindings)] (#Cons [[_ (#Tuple templates)] data])]) - ("lux case" [(mapM Monad get-name bindings) - (mapM Monad tuple->list data)] + ("lux case" [(monad/map Monad get-name bindings) + (monad/map Monad tuple->list data)] {[(#Some bindings') (#Some data')] (let' [apply ("lux check" (-> RepEnv ($' List Code)) (function' [env] (map (apply-template env) templates))) @@ -2511,7 +2512,7 @@ {(#Some macro) (do Monad [expansion (macro args) - expansion' (mapM Monad macro-expand expansion)] + expansion' (monad/map Monad macro-expand expansion)] (wrap (list/join expansion'))) #None @@ -2532,38 +2533,38 @@ {(#Some macro) (do Monad [expansion (macro args) - expansion' (mapM Monad macro-expand-all expansion)] + expansion' (monad/map Monad macro-expand-all expansion)] (wrap (list/join expansion'))) #None (do Monad - [args' (mapM Monad macro-expand-all args)] + [args' (monad/map Monad macro-expand-all args)] (wrap (list (form$ (#Cons (symbol$ macro-name) (list/join args'))))))})) [_ (#Form members)] (do Monad - [members' (mapM Monad macro-expand-all members)] + [members' (monad/map Monad macro-expand-all members)] (wrap (list (form$ (list/join members'))))) [_ (#Tuple members)] (do Monad - [members' (mapM Monad macro-expand-all members)] + [members' (monad/map Monad macro-expand-all members)] (wrap (list (tuple$ (list/join members'))))) [_ (#Record pairs)] (do Monad - [pairs' (mapM Monad - (function' [kv] - (let' [[key val] kv] - (do Monad - [val' (macro-expand-all val)] - ("lux case" val' - {(#;Cons val'' #;Nil) - (return [key val'']) - - _ - (fail "The value-part of a KV-pair in a record must macro-expand to a single Code.")})))) - pairs)] + [pairs' (monad/map Monad + (function' [kv] + (let' [[key val] kv] + (do Monad + [val' (macro-expand-all val)] + ("lux case" val' + {(#;Cons val'' #;Nil) + (return [key val'']) + + _ + (fail "The value-part of a KV-pair in a record must macro-expand to a single Code.")})))) + pairs)] (wrap (list (record$ pairs')))) _ @@ -2650,16 +2651,16 @@ ("lux case" type-codes {(#Cons [_ (#Record pairs)] #;Nil) (do Monad - [members (mapM Monad - (: (-> [Code Code] (Meta [Text Code])) - (function' [pair] - ("lux case" pair - {[[_ (#Tag "" member-name)] member-type] - (return [member-name member-type]) - - _ - (fail "Wrong syntax for variant case.")}))) - pairs)] + [members (monad/map Monad + (: (-> [Code Code] (Meta [Text Code])) + (function' [pair] + ("lux case" pair + {[[_ (#Tag "" member-name)] member-type] + (return [member-name member-type]) + + _ + (fail "Wrong syntax for variant case.")}))) + pairs)] (return [(` (& (~@ (map second members)))) (#Some (map first members))])) @@ -2676,22 +2677,22 @@ (#Cons case cases) (do Monad - [members (mapM Monad - (: (-> Code (Meta [Text Code])) - (function' [case] - ("lux case" case - {[_ (#Tag "" member-name)] - (return [member-name (` Unit)]) - - [_ (#Form (#Cons [_ (#Tag "" member-name)] (#Cons member-type #Nil)))] - (return [member-name member-type]) - - [_ (#Form (#Cons [_ (#Tag "" member-name)] member-types))] - (return [member-name (` (& (~@ member-types)))]) - - _ - (fail "Wrong syntax for variant case.")}))) - (list& case cases))] + [members (monad/map Monad + (: (-> Code (Meta [Text Code])) + (function' [case] + ("lux case" case + {[_ (#Tag "" member-name)] + (return [member-name (` Unit)]) + + [_ (#Form (#Cons [_ (#Tag "" member-name)] (#Cons member-type #Nil)))] + (return [member-name member-type]) + + [_ (#Form (#Cons [_ (#Tag "" member-name)] member-types))] + (return [member-name (` (& (~@ member-types)))]) + + _ + (fail "Wrong syntax for variant case.")}))) + (list& case cases))] (return [(` (| (~@ (map second members)))) (#Some (map first members))])) @@ -3309,18 +3310,18 @@ (#Some name args meta sigs) (do Monad [name+ (normalize name) - sigs' (mapM Monad macro-expand sigs) + sigs' (monad/map Monad macro-expand sigs) members (: (Meta (List [Text Code])) - (mapM Monad - (: (-> Code (Meta [Text Code])) - (function [token] - (case token - (^ [_ (#Form (list [_ (#Text "lux check")] type [_ (#Symbol ["" name])]))]) - (wrap [name type]) + (monad/map Monad + (: (-> Code (Meta [Text Code])) + (function [token] + (case token + (^ [_ (#Form (list [_ (#Text "lux check")] type [_ (#Symbol ["" name])]))]) + (wrap [name type]) - _ - (fail "Signatures require typed members!")))) - (list/join sigs'))) + _ + (fail "Signatures require typed members!")))) + (list/join sigs'))) #let [[_module _name] name+ def-name (symbol$ name) sig-type (record$ (map (: (-> [Text Code] [Code Code]) @@ -3643,7 +3644,7 @@ (macro: #export (struct tokens) {#;doc "Not meant to be used directly. Prefer \"struct:\"."} (do Monad - [tokens' (mapM Monad macro-expand tokens) + [tokens' (monad/map Monad macro-expand tokens) struct-type get-expected-type tags+type (resolve-type-tags struct-type) tags (: (Meta (List Ident)) @@ -3656,21 +3657,21 @@ #let [tag-mappings (: (List [Text Code]) (map (function [tag] [(second tag) (tag$ tag)]) tags))] - members (mapM Monad - (: (-> Code (Meta [Code Code])) - (function [token] - (case token - (^ [_ (#Form (list [_ (#Text "lux def")] [_ (#Symbol "" tag-name)] value meta))]) - (case (get tag-name tag-mappings) - (#Some tag) - (wrap [tag value]) - - _ - (fail (text/compose "Unknown structure member: " tag-name))) + members (monad/map Monad + (: (-> Code (Meta [Code Code])) + (function [token] + (case token + (^ [_ (#Form (list [_ (#Text "lux def")] [_ (#Symbol "" tag-name)] value meta))]) + (case (get tag-name tag-mappings) + (#Some tag) + (wrap [tag value]) - _ - (fail "Invalid structure member.")))) - (list/join tokens'))] + _ + (fail (text/compose "Unknown structure member: " tag-name))) + + _ + (fail "Invalid structure member.")))) + (list/join tokens'))] (wrap (list (record$ members))))) (def: (text/join parts) @@ -3715,15 +3716,15 @@ (case type (^ [_ (#;Form (list& [_ (#;Symbol [_ sig-name])] sig-args))]) (case (: (Maybe (List Text)) - (mapM Monad - (function [sa] - (case sa - [_ (#;Symbol [_ arg-name])] - (#;Some arg-name) - - _ - #;None)) - sig-args)) + (monad/map Monad + (function [sa] + (case sa + [_ (#;Symbol [_ arg-name])] + (#;Some arg-name) + + _ + #;None)) + sig-args)) (^ (#;Some params)) (#;Some (symbol$ ["" ($_ text/compose sig-name "<" (|> params (interpose ",") text/join) ">")])) @@ -3881,16 +3882,16 @@ (def: (extract-defs defs) (-> (List Code) (Meta (List Text))) - (mapM Monad - (: (-> Code (Meta Text)) - (function [def] - (case def - [_ (#Symbol ["" name])] - (return name) + (monad/map Monad + (: (-> Code (Meta Text)) + (function [def] + (case def + [_ (#Symbol ["" name])] + (return name) - _ - (fail "only/exclude requires symbols.")))) - defs)) + _ + (fail "only/exclude requires symbols.")))) + defs)) (def: (parse-alias tokens) (-> (List Code) (Meta [(Maybe Text) (List Code)])) @@ -4086,64 +4087,64 @@ (def: (parse-imports imports) (-> (List Code) (Meta (List Importation))) (do Monad - [imports' (mapM Monad - (: (-> Code (Meta (List Importation))) - (function [token] - (case token - [_ (#Symbol "" m-name)] - (do Monad - [m-name (clean-module m-name)] - (wrap (list [m-name #None {#refer-defs #All - #refer-open (list)}]))) - - (^ [_ (#Form (list& [_ (#Symbol "" m-name)] extra))]) - (do Monad - [m-name (clean-module m-name) - alias+extra (parse-alias extra) - #let [[alias extra] alias+extra] - referral+extra (parse-referrals extra) - #let [[referral extra] referral+extra] - openings+extra (parse-openings extra) - #let [[openings extra] openings+extra] - sub-imports (parse-imports extra) - #let [sub-imports (decorate-sub-importations m-name sub-imports)]] - (wrap (case [referral alias openings] - [#Nothing #None #Nil] sub-imports - _ (list& {#import-name m-name - #import-alias alias - #import-refer {#refer-defs referral - #refer-open openings}} - sub-imports)))) - - (^ [_ (#Tuple (list& [_ (#Text alias)] [_ (#Symbol "" m-name)] extra))]) - (do Monad - [m-name (clean-module m-name) - referral+extra (parse-short-referrals extra) - #let [[referral extra] referral+extra] - openings+extra (parse-short-openings extra) - #let [[openings extra] openings+extra]] - (wrap (list {#import-name m-name - #import-alias (#;Some (replace-all ";" m-name alias)) - #import-refer {#refer-defs referral - #refer-open openings}}))) - - (^ [_ (#Tuple (list& [_ (#Symbol "" raw-m-name)] extra))]) - (do Monad - [m-name (clean-module raw-m-name) - referral+extra (parse-short-referrals extra) - #let [[referral extra] referral+extra] - openings+extra (parse-short-openings extra) - #let [[openings extra] openings+extra]] - (wrap (list {#import-name m-name - #import-alias (#;Some raw-m-name) - #import-refer {#refer-defs referral - #refer-open openings}}))) + [imports' (monad/map Monad + (: (-> Code (Meta (List Importation))) + (function [token] + (case token + [_ (#Symbol "" m-name)] + (do Monad + [m-name (clean-module m-name)] + (wrap (list [m-name #None {#refer-defs #All + #refer-open (list)}]))) + + (^ [_ (#Form (list& [_ (#Symbol "" m-name)] extra))]) + (do Monad + [m-name (clean-module m-name) + alias+extra (parse-alias extra) + #let [[alias extra] alias+extra] + referral+extra (parse-referrals extra) + #let [[referral extra] referral+extra] + openings+extra (parse-openings extra) + #let [[openings extra] openings+extra] + sub-imports (parse-imports extra) + #let [sub-imports (decorate-sub-importations m-name sub-imports)]] + (wrap (case [referral alias openings] + [#Nothing #None #Nil] sub-imports + _ (list& {#import-name m-name + #import-alias alias + #import-refer {#refer-defs referral + #refer-open openings}} + sub-imports)))) + + (^ [_ (#Tuple (list& [_ (#Text alias)] [_ (#Symbol "" m-name)] extra))]) + (do Monad + [m-name (clean-module m-name) + referral+extra (parse-short-referrals extra) + #let [[referral extra] referral+extra] + openings+extra (parse-short-openings extra) + #let [[openings extra] openings+extra]] + (wrap (list {#import-name m-name + #import-alias (#;Some (replace-all ";" m-name alias)) + #import-refer {#refer-defs referral + #refer-open openings}}))) + + (^ [_ (#Tuple (list& [_ (#Symbol "" raw-m-name)] extra))]) + (do Monad + [m-name (clean-module raw-m-name) + referral+extra (parse-short-referrals extra) + #let [[referral extra] referral+extra] + openings+extra (parse-short-openings extra) + #let [[openings extra] openings+extra]] + (wrap (list {#import-name m-name + #import-alias (#;Some raw-m-name) + #import-refer {#refer-defs referral + #refer-open openings}}))) - _ - (do Monad - [current-module current-module-name] - (fail (text/compose "Wrong syntax for import @ " current-module)))))) - imports)] + _ + (do Monad + [current-module current-module-name] + (fail (text/compose "Wrong syntax for import @ " current-module)))))) + imports)] (wrap (list/join imports')))) (def: (exported-defs module state) @@ -4514,10 +4515,10 @@ (case output (#Some [tags members]) (do Monad - [decls' (mapM Monad - (: (-> [Ident Type] (Meta (List Code))) - (function [[sname stype]] (open-field prefix sname source+ stype))) - (zip2 tags members))] + [decls' (monad/map Monad + (: (-> [Ident Type] (Meta (List Code))) + (function [[sname stype]] (open-field prefix sname source+ stype))) + (zip2 tags members))] (return (list/join decls'))) _ @@ -4549,9 +4550,9 @@ (case output (#Some [tags members]) (do Monad - [decls' (mapM Monad (: (-> [Ident Type] (Meta (List Code))) - (function [[sname stype]] (open-field prefix sname source stype))) - (zip2 tags members))] + [decls' (monad/map Monad (: (-> [Ident Type] (Meta (List Code))) + (function [[sname stype]] (open-field prefix sname source stype))) + (zip2 tags members))] (return (list/join decls'))) _ @@ -4601,13 +4602,13 @@ current-module current-module-name #let [test-referrals (: (-> Text (List Text) (List Text) (Meta (List Unit))) (function [module-name all-defs referred-defs] - (mapM Monad - (: (-> Text (Meta Unit)) - (function [_def] - (if (is-member? all-defs _def) - (return []) - (fail ($_ text/compose _def " is not defined in module " module-name " @ " current-module))))) - referred-defs)))]] + (monad/map Monad + (: (-> Text (Meta Unit)) + (function [_def] + (if (is-member? all-defs _def) + (return []) + (fail ($_ text/compose _def " is not defined in module " module-name " @ " current-module))))) + referred-defs)))]] (case options #;Nil (wrap {#refer-defs referral @@ -4626,13 +4627,13 @@ [current-module current-module-name #let [test-referrals (: (-> Text (List Text) (List Text) (Meta (List Unit))) (function [module-name all-defs referred-defs] - (mapM Monad - (: (-> Text (Meta Unit)) - (function [_def] - (if (is-member? all-defs _def) - (return []) - (fail ($_ text/compose _def " is not defined in module " module-name " @ " current-module))))) - referred-defs)))] + (monad/map Monad + (: (-> Text (Meta Unit)) + (function [_def] + (if (is-member? all-defs _def) + (return []) + (fail ($_ text/compose _def " is not defined in module " module-name " @ " current-module))))) + referred-defs)))] defs' (case r-defs #All (exported-defs module-name) @@ -4791,13 +4792,13 @@ (case (resolve-struct-type type) (#Some members) (do Monad - [pattern' (mapM Monad - (: (-> [Ident [Nat Type]] (Meta [Ident Nat Code])) - (function [[r-slot-name [r-idx r-type]]] - (do Monad - [g!slot (gensym "")] - (return [r-slot-name r-idx g!slot])))) - (zip2 tags (enumerate members)))] + [pattern' (monad/map Monad + (: (-> [Ident [Nat Type]] (Meta [Ident Nat Code])) + (function [[r-slot-name [r-idx r-type]]] + (do Monad + [g!slot (gensym "")] + (return [r-slot-name r-idx g!slot])))) + (zip2 tags (enumerate members)))] (let [pattern (record$ (map (: (-> [Ident Nat Code] [Code Code]) (function [[r-slot-name r-idx r-var]] [(tag$ r-slot-name) r-var])) @@ -4820,10 +4821,10 @@ _ (do Monad - [bindings (mapM Monad - (: (-> Code (Meta Code)) - (function [_] (gensym "temp"))) - slots) + [bindings (monad/map Monad + (: (-> Code (Meta Code)) + (function [_] (gensym "temp"))) + slots) #let [pairs (zip2 slots bindings) update-expr (fold (: (-> [Code Code] Code Code) (function [[s b] v] @@ -4877,13 +4878,13 @@ (case (resolve-struct-type type) (#Some members) (do Monad - [pattern' (mapM Monad - (: (-> [Ident [Nat Type]] (Meta [Ident Nat Code])) - (function [[r-slot-name [r-idx r-type]]] - (do Monad - [g!slot (gensym "")] - (return [r-slot-name r-idx g!slot])))) - (zip2 tags (enumerate members)))] + [pattern' (monad/map Monad + (: (-> [Ident [Nat Type]] (Meta [Ident Nat Code])) + (function [[r-slot-name [r-idx r-type]]] + (do Monad + [g!slot (gensym "")] + (return [r-slot-name r-idx g!slot])))) + (zip2 tags (enumerate members)))] (let [pattern (record$ (map (: (-> [Ident Nat Code] [Code Code]) (function [[r-slot-name r-idx r-var]] [(tag$ r-slot-name) r-var])) @@ -4968,8 +4969,8 @@ branches)) (case (: (Maybe (List Code)) (do Monad - [bindings' (mapM Monad get-name bindings) - data' (mapM Monad tuple->list data)] + [bindings' (monad/map Monad get-name bindings) + data' (monad/map Monad tuple->list data)] (if (every? (i.= (length bindings')) (map length data')) (let [apply (: (-> RepEnv (List Code)) (function [env] (map (apply-template env) templates)))] @@ -5258,10 +5259,10 @@ (if (every? symbol? inits) (do Monad [inits' (: (Meta (List Ident)) - (case (mapM Monad get-ident inits) + (case (monad/map Monad get-ident inits) (#Some inits') (return inits') #None (fail "Wrong syntax for loop"))) - init-types (mapM Monad find-type inits') + init-types (monad/map Monad find-type inits') expected get-expected-type] (return (list (` (("lux check" (-> (~@ (map type-to-code init-types)) (~ (type-to-code expected))) @@ -5269,10 +5270,10 @@ (~ body))) (~@ inits)))))) (do Monad - [aliases (mapM Monad - (: (-> Code (Meta Code)) - (function [_] (gensym ""))) - inits)] + [aliases (monad/map Monad + (: (-> Code (Meta Code)) + (function [_] (gensym ""))) + inits)] (return (list (` (let [(~@ (interleave aliases inits))] (;loop [(~@ (interleave vars aliases))] (~ body))))))))) @@ -5292,7 +5293,7 @@ (case (: (Maybe [Ident (List Ident)]) (do Monad [hslot (get-tag hslot') - tslots (mapM Monad get-tag tslots')] + tslots (monad/map Monad get-tag tslots')] (wrap [hslot tslots]))) (#Some slots) (return slots) @@ -5301,7 +5302,7 @@ (fail "Wrong syntax for ^slots"))) #let [[hslot tslots] slots] hslot (normalize hslot) - tslots (mapM Monad normalize tslots) + tslots (monad/map Monad normalize tslots) output (resolve-tag hslot) g!_ (gensym "_") #let [[idx tags exported? type] output @@ -5335,26 +5336,26 @@ (^template [ ] [_ ( elems)] (do Monad - [placements (mapM Monad (place-tokens label tokens) elems)] + [placements (monad/map Monad (place-tokens label tokens) elems)] (wrap (list ( (list/join placements)))))) ([#Tuple tuple$] [#Form form$]) [_ (#Record pairs)] (do Monad - [=pairs (mapM Monad - (: (-> [Code Code] (Maybe [Code Code])) - (function [[slot value]] - (do Monad - [slot' (place-tokens label tokens slot) - value' (place-tokens label tokens value)] - (case [slot' value'] - (^ [(list =slot) (list =value)]) - (wrap [=slot =value]) + [=pairs (monad/map Monad + (: (-> [Code Code] (Maybe [Code Code])) + (function [[slot value]] + (do Monad + [slot' (place-tokens label tokens slot) + value' (place-tokens label tokens value)] + (case [slot' value'] + (^ [(list =slot) (list =value)]) + (wrap [=slot =value]) - _ - #None)))) - pairs)] + _ + #None)))) + pairs)] (wrap (list (record$ =pairs)))) )) @@ -5456,20 +5457,20 @@ (^template [] [meta ( parts)] (do Monad - [=parts (mapM Monad anti-quote parts)] + [=parts (monad/map Monad anti-quote parts)] (wrap [meta ( =parts)]))) ([#Form] [#Tuple]) [meta (#Record pairs)] (do Monad - [=pairs (mapM Monad - (: (-> [Code Code] (Meta [Code Code])) - (function [[slot value]] - (do Monad - [=value (anti-quote value)] - (wrap [slot =value])))) - pairs)] + [=pairs (monad/map Monad + (: (-> [Code Code] (Meta [Code Code])) + (function [[slot value]] + (do Monad + [=value (anti-quote value)] + (wrap [slot =value])))) + pairs)] (wrap [meta (#Record =pairs)])) _ @@ -5525,7 +5526,7 @@ (#;Cons init extras) (do Monad - [extras' (mapM Monad case-level^ extras)] + [extras' (monad/map Monad case-level^ extras)] (wrap [init extras'])))) (def: (multi-level-case$ g!_ [[init-pattern levels] body]) @@ -5773,15 +5774,15 @@ (case tokens (^ (list& [_ (#Form (list& [_ (#Symbol ["" name])] args'))] tokens')) (do Monad - [args (mapM Monad - (function [arg'] - (case arg' - [_ (#Symbol ["" arg-name])] - (wrap arg-name) + [args (monad/map Monad + (function [arg'] + (case arg' + [_ (#Symbol ["" arg-name])] + (wrap arg-name) - _ - (fail "Could not parse an argument."))) - args')] + _ + (fail "Could not parse an argument."))) + args')] (wrap [[name args] tokens'])) _ @@ -5937,22 +5938,22 @@ (^template [] [ann ( parts)] (do Monad - [=parts (mapM Monad label-code parts)] + [=parts (monad/map Monad label-code parts)] (wrap [(fold list/compose (list) (map left =parts)) [ann ( (map right =parts))]]))) ([#Form] [#Tuple]) [ann (#Record kvs)] (do Monad - [=kvs (mapM Monad - (function [[key val]] - (do Monad - [=key (label-code key) - =val (label-code val) - #let [[key-labels key-labelled] =key - [val-labels val-labelled] =val]] - (wrap [(list/compose key-labels val-labels) [key-labelled val-labelled]]))) - kvs)] + [=kvs (monad/map Monad + (function [[key val]] + (do Monad + [=key (label-code key) + =val (label-code val) + #let [[key-labels key-labelled] =key + [val-labels val-labelled] =val]] + (wrap [(list/compose key-labels val-labels) [key-labelled val-labelled]]))) + kvs)] (wrap [(fold list/compose (list) (map left =kvs)) [ann (#Record (map right =kvs))]])) @@ -6006,13 +6007,13 @@ [_ (#Record fields)] (do Monad - [=fields (mapM Monad - (function [[key value]] - (do Monad - [=key (untemplate-pattern key) - =value (untemplate-pattern value)] - (wrap (` [(~ =key) (~ =value)])))) - fields) + [=fields (monad/map Monad + (function [[key value]] + (do Monad + [=key (untemplate-pattern key) + =value (untemplate-pattern value)] + (wrap (` [(~ =key) (~ =value)])))) + fields) g!meta (gensym "g!meta")] (wrap (` [(~ g!meta) (#;Record (~ (untemplate-list =fields)))]))) @@ -6028,13 +6029,13 @@ (#;Cons [_ (#Form (#Cons [[_ (#Symbol ["" "~@"])] (#Cons [spliced #Nil])]))] inits) (do Monad - [=inits (mapM Monad untemplate-pattern (reverse inits)) + [=inits (monad/map Monad untemplate-pattern (reverse inits)) g!meta (gensym "g!meta")] (wrap (` [(~ g!meta) ( (~ (untemplate-list& spliced =inits)))]))) _ (do Monad - [=elems (mapM Monad untemplate-pattern elems) + [=elems (monad/map Monad untemplate-pattern elems) g!meta (gensym "g!meta")] (wrap (` [(~ g!meta) ( (~ (untemplate-list =elems)))]))))) ([#;Tuple] [#;Form]) diff --git a/stdlib/source/lux/meta/type.lux b/stdlib/source/lux/meta/type.lux index e7c630966..9d6ed5162 100644 --- a/stdlib/source/lux/meta/type.lux +++ b/stdlib/source/lux/meta/type.lux @@ -1,12 +1,12 @@ (;module: {#;doc "Basic functionality for working with types."} [lux #- function] (lux (control [eq #+ Eq] - ["M" monad #+ do Monad]) - (data [text "Text/" Monoid Eq] - [ident "Ident/" Eq] - [number "Nat/" Codec] + [monad #+ do Monad]) + (data [text "text/" Monoid Eq] + [ident "ident/" Eq] + [number "nat/" Codec] [maybe] - (coll [list #+ "List/" Monad Monoid Fold])) + (coll [list #+ "list/" Monad Monoid Fold])) (meta [code]) )) @@ -15,7 +15,7 @@ (-> (List Type) Type Type) (case type (#;Primitive name params) - (#;Primitive name (List/map (beta-reduce env) params)) + (#;Primitive name (list/map (beta-reduce env) params)) (^template [] ( left right) @@ -35,7 +35,7 @@ [#;ExQ]) (#;Bound idx) - (maybe;default (error! (Text/compose "Unknown type var: " (Nat/encode idx))) + (maybe;default (error! (text/compose "Unknown type var: " (nat/encode idx))) (list;nth idx env)) _ @@ -47,9 +47,9 @@ (def: (= x y) (case [x y] [(#;Primitive xname xparams) (#;Primitive yname yparams)] - (and (Text/= xname yname) + (and (text/= xname yname) (n.= (list;size yparams) (list;size xparams)) - (List/fold (;function [[x y] prev] (and prev (= x y))) + (list/fold (;function [[x y] prev] (and prev (= x y))) true (list;zip2 xparams yparams))) @@ -69,7 +69,7 @@ (= xright yright)) [(#;Named xname xtype) (#;Named yname ytype)] - (and (Ident/= xname yname) + (and (ident/= xname yname) (= xtype ytype)) (^template [] @@ -81,7 +81,7 @@ [(#;ExQ xenv xbody) (#;ExQ yenv ybody)]) (and (n.= (list;size yenv) (list;size xenv)) (= xbody ybody) - (List/fold (;function [[x y] prev] (and prev (= x y))) + (list/fold (;function [[x y] prev] (and prev (= x y))) true (list;zip2 xenv yenv))) @@ -121,7 +121,7 @@ (case type (#;Apply arg func') (let [[func args] (flatten-application func')] - [func (List/compose args (list arg))]) + [func (list/compose args (list arg))]) _ [type (list)])) @@ -169,7 +169,7 @@ (case type (#;Primitive name params) (` (#;Primitive (~ (code;text name)) - (list (~@ (List/map to-ast params))))) + (list (~@ (list/map to-ast params))))) (^template [] @@ -189,7 +189,7 @@ (^template [ ] ( left right) - (` ( (~@ (List/map to-ast ( type)))))) + (` ( (~@ (list/map to-ast ( type)))))) ([#;Sum | flatten-variant] [#;Product & flatten-tuple]) @@ -198,7 +198,7 @@ (^template [] ( env body) - (` ( (list (~@ (List/map to-ast env))) + (` ( (list (~@ (list/map to-ast env))) (~ (to-ast body))))) ([#;UnivQ] [#;ExQ]) )) @@ -209,10 +209,10 @@ (#;Primitive name params) (case params #;Nil - ($_ Text/compose "(primitive " name ")") + ($_ text/compose "(primitive " name ")") _ - ($_ Text/compose "(primitive " name " " (|> params (List/map to-text) list;reverse (list;interpose " ") (List/fold Text/compose "")) ")")) + ($_ text/compose "(primitive " name " " (|> params (list/map to-text) list;reverse (list;interpose " ") (list/fold text/compose "")) ")")) #;Void "Void" @@ -222,47 +222,47 @@ (^template [ ] ( _) - ($_ Text/compose + ($_ text/compose (|> ( type) - (List/map to-text) + (list/map to-text) list;reverse (list;interpose " ") - (List/fold Text/compose "")) + (list/fold text/compose "")) )) ([#;Sum "(| " ")" flatten-variant] [#;Product "[" "]" flatten-tuple]) (#;Function input output) (let [[ins out] (flatten-function type)] - ($_ Text/compose "(-> " + ($_ text/compose "(-> " (|> ins - (List/map to-text) + (list/map to-text) list;reverse (list;interpose " ") - (List/fold Text/compose "")) + (list/fold text/compose "")) " " (to-text out) ")")) (#;Bound idx) - (Nat/encode idx) + (nat/encode idx) (#;Var id) - ($_ Text/compose "⌈v:" (Nat/encode id) "⌋") + ($_ text/compose "⌈v:" (nat/encode id) "⌋") (#;Ex id) - ($_ Text/compose "⟨e:" (Nat/encode id) "⟩") + ($_ text/compose "⟨e:" (nat/encode id) "⟩") (#;Apply param fun) (let [[type-func type-args] (flatten-application type)] - ($_ Text/compose "(" (to-text type-func) " " (|> type-args (List/map to-text) list;reverse (list;interpose " ") (List/fold Text/compose "")) ")")) + ($_ text/compose "(" (to-text type-func) " " (|> type-args (list/map to-text) list;reverse (list;interpose " ") (list/fold text/compose "")) ")")) (^template [ ] ( env body) - ($_ Text/compose "(" " {" (|> env (List/map to-text) (text;join-with " ")) "} " (to-text body) ")")) + ($_ text/compose "(" " {" (|> env (list/map to-text) (text;join-with " ")) "} " (to-text body) ")")) ([#;UnivQ "All"] [#;ExQ "Ex"]) (#;Named [module name] type) - ($_ Text/compose module ";" name) + ($_ text/compose module ";" name) )) (def: #export (un-alias type) diff --git a/stdlib/source/lux/meta/type/check.lux b/stdlib/source/lux/meta/type/check.lux index 0fa56b600..b12470418 100644 --- a/stdlib/source/lux/meta/type/check.lux +++ b/stdlib/source/lux/meta/type/check.lux @@ -14,6 +14,14 @@ (meta [type "type/" Eq]) )) +(exception: #export Unknown-Type-Var) +(exception: #export Unbound-Type-Var) +(exception: #export Improper-Ring) +(exception: #export Cannot-Clean-Unbound-Var) +(exception: #export Invalid-Type-Application) +(exception: #export Cannot-Rebind-Var) +(exception: #export Type-Check-Failed) + (type: #export Var Nat) (type: #export Assumptions (List [[Type Type] Bool])) @@ -131,12 +139,17 @@ (#e;Success [context' output]) (#e;Success output))) -(def: (apply-type! t-func t-arg) +(def: #export (throw exception message) + (All [a] (-> ex;Exception Text (Check a))) + (function [context] + (ex;throw exception message))) + +(def: (apply-type! funcT argT) (-> Type Type (Check Type)) (function [context] - (case (type;apply (list t-arg) t-func) + (case (type;apply (list argT) funcT) #;None - (#e;Error ($_ text/compose "Invalid type application: " (type;to-text t-func) " on " (type;to-text t-arg))) + (ex;throw Invalid-Type-Application (type;to-text (#;Apply argT funcT))) (#;Some output) (#e;Success [context output])))) @@ -149,10 +162,6 @@ (#e;Success [(update@ #;ex-counter n.inc context) [id (#;Ex id)]])))) -(exception: #export Unknown-Type-Var) -(exception: #export Unbound-Type-Var) -(exception: #export Improper-Ring) - (def: #export (bound? id) (-> Var (Check Bool)) (function [context] @@ -197,7 +206,11 @@ (function [context] (case (|> context (get@ #;var-bindings) (var::get id)) (#;Some (#;Some bound)) - (#e;Error ($_ text/compose "Cannot re-bind type-var: " (nat/encode id) " | Current type: " (type;to-text bound))) + (ex;throw Cannot-Rebind-Var + ($_ text/compose + " Var: " (nat/encode id) "\n" + " Wanted Type: " (type;to-text type) "\n" + "Current Type: " (type;to-text bound))) (#;Some #;None) (#e;Success [(update@ #;var-bindings (var::put id (#;Some type)) context) @@ -228,13 +241,6 @@ #;None (ex;throw Unknown-Type-Var (nat/encode id))))) -(def: #export (throw exception message) - (All [a] (-> ex;Exception Text (Check a))) - (function [context] - (ex;throw exception message))) - -(exception: #export Cannot-Clean-Unbound-Var) - (def: #export (clean t-id type) (-> Var Type (Check Type)) (case type @@ -244,7 +250,7 @@ [? (bound? id)] (if ? (read id) - (throw Cannot-Clean-Unbound-Var (type;to-text type)))) + (wrap type))) (do Monad [? (concrete? id)] (if ? @@ -414,12 +420,6 @@ (#e;Success [context []]) (#e;Error message)))) -(def: (fail-check expected actual) - (All [a] (-> Type Type (Check a))) - (fail ($_ text/compose - "Expected: " (type;to-text expected) "\n\n" - "Actual: " (type;to-text actual)))) - (def: (either left right) (All [a] (-> (Check a) (Check a) (Check a))) (function [context] @@ -543,141 +543,180 @@ _ (check' etype atype assumptions)))))) +(def: (with-error-stack on-error check) + (All [a] (-> (-> Unit Text) (Check a) (Check a))) + (function [context] + (case (check context) + (#e;Error error) + (#e;Error (case error + "" + (on-error []) + + _ + ($_ text/compose + (on-error []) + "\n\n-----------------------------------------\n\n" + error))) + + output + output))) + +(def: (check-apply check' assumptions [eAT eFT] [aAT aFT]) + (-> (-> Type Type Assumptions (Check Assumptions)) Assumptions + [Type Type] [Type Type] + (Check Assumptions)) + (case [eFT aFT] + (^or [(#;Ex _) _] [_ (#;Ex _)]) + (do Monad + [assumptions (check' eFT aFT assumptions)] + (check' eAT aAT assumptions)) + + [(#;Var id) _] + (either (do Monad + [rFT (read id)] + (check' (#;Apply eAT rFT) (#;Apply aAT aFT) assumptions)) + (do Monad + [assumptions (check' (#;Var id) aFT assumptions) + e' (apply-type! aFT eAT) + a' (apply-type! aFT aAT)] + (check' e' a' assumptions))) + + [_ (#;Var id)] + (either (do Monad + [rFT (read id)] + (check' (#;Apply eAT eFT) (#;Apply aAT rFT) assumptions)) + (do Monad + [assumptions (check' eFT (#;Var id) assumptions) + e' (apply-type! eFT eAT) + a' (apply-type! eFT aAT)] + (check' e' a' assumptions))) + + _ + (fail ""))) + (def: #export (check' expected actual assumptions) {#;doc "Type-check to ensure that the 'expected' type subsumes the 'actual' type."} (-> Type Type Assumptions (Check Assumptions)) (if (is expected actual) (check/wrap assumptions) - (case [expected actual] - [(#;Var idE) (#;Var idA)] - (check-vars check' assumptions idE idA) - - [(#;Var id) _] - (on id actual - (check/wrap assumptions) - (function [bound] - (check' bound actual assumptions))) - - [_ (#;Var id)] - (on id expected - (check/wrap assumptions) - (function [bound] - (check' expected bound assumptions))) - - [(#;Apply eA (#;Ex eid)) (#;Apply aA (#;Ex aid))] - (if (n.= eid aid) - (check' eA aA assumptions) - (fail-check expected actual)) - - [(#;Apply A1 (#;Var id)) (#;Apply A2 F2)] - (either (do Monad - [F1 (read id)] - (check' (#;Apply A1 F1) actual assumptions)) - (do Monad - [assumptions (check' (#;Var id) F2 assumptions) - e' (apply-type! F2 A1) - a' (apply-type! F2 A2)] - (check' e' a' assumptions))) - - [(#;Apply A1 F1) (#;Apply A2 (#;Var id))] - (either (do Monad - [F2 (read id)] - (check' expected (#;Apply A2 F2) assumptions)) - (do Monad - [assumptions (check' F1 (#;Var id) assumptions) - e' (apply-type! F1 A1) - a' (apply-type! F1 A2)] - (check' e' a' assumptions))) - - [(#;Apply A F) _] - (let [fx-pair [expected actual]] - (case (assumed? fx-pair assumptions) - (#;Some ?) - (if ? + (with-error-stack + (function [_] (Type-Check-Failed + ($_ text/compose + "Expected: " (type;to-text expected) "\n\n" + " Actual: " (type;to-text actual)))) + (case [expected actual] + [(#;Var idE) (#;Var idA)] + (check-vars check' assumptions idE idA) + + [(#;Var id) _] + (on id actual (check/wrap assumptions) - (fail-check expected actual)) - - #;None - (do Monad - [expected' (apply-type! F A)] - (check' expected' actual (assume! fx-pair true assumptions))))) - - [_ (#;Apply A F)] - (do Monad - [actual' (apply-type! F A)] - (check' expected actual' assumptions)) + (function [bound] + (check' bound actual assumptions))) + + [_ (#;Var id)] + (on id expected + (check/wrap assumptions) + (function [bound] + (check' expected bound assumptions))) + + (^template [ ] + [(#;Apply A1 ) (#;Apply A2 )] + (check-apply check' assumptions [A1 ] [A2 ])) + ([F1 (#;Ex ex)] + [(#;Ex ex) F2] + [F1 (#;Var id)] + [(#;Var id) F2]) + + [(#;Apply A F) _] + (let [fx-pair [expected actual]] + (case (assumed? fx-pair assumptions) + (#;Some ?) + (if ? + (check/wrap assumptions) + (fail "")) + + #;None + (do Monad + [expected' (apply-type! F A)] + (check' expected' actual (assume! fx-pair true assumptions))))) + + [_ (#;Apply A F)] + (do Monad + [actual' (apply-type! F A)] + (check' expected actual' assumptions)) - [(#;UnivQ _) _] - (do Monad - [[ex-id ex] existential - expected' (apply-type! expected ex)] - (check' expected' actual assumptions)) - - [_ (#;UnivQ _)] - (with - (function [[var-id var]] - (do Monad - [actual' (apply-type! actual var) - assumptions (check' expected actual' assumptions) - _ (clean var-id expected)] - (check/wrap assumptions)))) - - [(#;ExQ e!env e!def) _] - (with - (function [[var-id var]] - (do Monad - [expected' (apply-type! expected var) - assumptions (check' expected' actual assumptions) - _ (clean var-id actual)] - (check/wrap assumptions)))) - - [_ (#;ExQ a!env a!def)] - (do Monad - [[ex-id ex] existential - actual' (apply-type! actual ex)] - (check' expected actual' assumptions)) - - [(#;Primitive e-name e-params) (#;Primitive a-name a-params)] - (if (and (text/= e-name a-name) - (n.= (list;size e-params) - (list;size a-params))) + [(#;UnivQ _) _] + (do Monad + [[ex-id ex] existential + expected' (apply-type! expected ex)] + (check' expected' actual assumptions)) + + [_ (#;UnivQ _)] + (with + (function [[var-id var]] + (do Monad + [actual' (apply-type! actual var) + assumptions (check' expected actual' assumptions) + _ (clean var-id expected)] + (check/wrap assumptions)))) + + [(#;ExQ e!env e!def) _] + (with + (function [[var-id var]] + (do Monad + [expected' (apply-type! expected var) + assumptions (check' expected' actual assumptions) + _ (clean var-id actual)] + (check/wrap assumptions)))) + + [_ (#;ExQ a!env a!def)] (do Monad - [assumptions (monad;fold Monad - (function [[e a] assumptions] (check' e a assumptions)) - assumptions - (list;zip2 e-params a-params))] - (check/wrap assumptions)) - (fail-check expected actual)) - - (^template [ ] - [ ] - (check/wrap assumptions) + [[ex-id ex] existential + actual' (apply-type! actual ex)] + (check' expected actual' assumptions)) + + [(#;Primitive e-name e-params) (#;Primitive a-name a-params)] + (if (and (text/= e-name a-name) + (n.= (list;size e-params) + (list;size a-params))) + (do Monad + [assumptions (monad;fold Monad + (function [[e a] assumptions] (check' e a assumptions)) + assumptions + (list;zip2 e-params a-params))] + (check/wrap assumptions)) + (fail "")) + + (^template [ ] + [ ] + (check/wrap assumptions) + + [( eL eR) ( aL aR)] + (do Monad + [assumptions (check' eL aL assumptions)] + (check' eR aR assumptions))) + ([#;Void #;Sum] + [#;Unit #;Product]) - [( eL eR) ( aL aR)] + [(#;Function eI eO) (#;Function aI aO)] (do Monad - [assumptions (check' eL aL assumptions)] - (check' eR aR assumptions))) - ([#;Void #;Sum] - [#;Unit #;Product]) - - [(#;Function eI eO) (#;Function aI aO)] - (do Monad - [assumptions (check' aI eI assumptions)] - (check' eO aO assumptions)) + [assumptions (check' aI eI assumptions)] + (check' eO aO assumptions)) - [(#;Ex e!id) (#;Ex a!id)] - (if (n.= e!id a!id) - (check/wrap assumptions) - (fail-check expected actual)) + [(#;Ex e!id) (#;Ex a!id)] + (if (n.= e!id a!id) + (check/wrap assumptions) + (fail "")) - [(#;Named _ ?etype) _] - (check' ?etype actual assumptions) + [(#;Named _ ?etype) _] + (check' ?etype actual assumptions) - [_ (#;Named _ ?atype)] - (check' expected ?atype assumptions) + [_ (#;Named _ ?atype)] + (check' expected ?atype assumptions) - _ - (fail-check expected actual)))) + _ + (fail ""))))) (def: #export (check expected actual) {#;doc "Type-check to ensure that the 'expected' type subsumes the 'actual' type."} -- cgit v1.2.3