diff options
Diffstat (limited to '')
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/function.lux | 10 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/inference.lux | 46 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/structure.lux | 30 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/type.lux | 16 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/synthesis/case.lux | 90 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/synthesis/expression.lux | 5 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/case.jvm.lux | 87 | ||||
| -rw-r--r-- | stdlib/source/lux.lux | 559 | ||||
| -rw-r--r-- | stdlib/source/lux/meta/type.lux | 58 | ||||
| -rw-r--r-- | stdlib/source/lux/meta/type/check.lux | 325 |
10 files changed, 642 insertions, 584 deletions
diff --git a/new-luxc/source/luxc/lang/analysis/function.lux b/new-luxc/source/luxc/lang/analysis/function.lux index 627fb7c0a..5a6df4d3e 100644 --- a/new-luxc/source/luxc/lang/analysis/function.lux +++ b/new-luxc/source/luxc/lang/analysis/function.lux @@ -102,10 +102,14 @@ (&;with-stacked-errors (function [_] (Cannot-Apply-Function (format " Function: " (%type funcT) "\n" - "Arguments: " (|> args (list/map %code) (text;join-with " "))))) + "Arguments:" (|> args + list;enumerate + (list/map (function [[idx argC]] + (format "\n " (%n idx) " " (%code argC)))) + (text;join-with ""))))) (do meta;Monad<Meta> - [expected meta;expected-type + [expectedT meta;expected-type [applyT argsA] (&inference;apply-function analyse funcT args) _ (&;with-type-env - (tc;check expected applyT))] + (tc;check expectedT applyT))] (wrap (la;apply argsA funcA))))) diff --git a/new-luxc/source/luxc/lang/analysis/inference.lux b/new-luxc/source/luxc/lang/analysis/inference.lux index cd484a623..fea685024 100644 --- a/new-luxc/source/luxc/lang/analysis/inference.lux +++ b/new-luxc/source/luxc/lang/analysis/inference.lux @@ -16,6 +16,9 @@ (exception: #export Cannot-Infer) (exception: #export Cannot-Infer-Argument) (exception: #export Smaller-Variant-Than-Expected) +(exception: #export Invalid-Type-Application) +(exception: #export Not-A-Record-Type) +(exception: #export Not-A-Variant-Type) ## When doing inference, type-variables often need to be created in ## order to figure out which types are present in the expression being @@ -90,16 +93,16 @@ ## Function types are used for this, although inference is not always ## done for function application (alternative uses may be records and ## tagged variants). -## But, so long as the type being used for the inference can be trated +## But, so long as the type being used for the inference can be treated ## as a function type, this method of inference should work. -(def: #export (apply-function analyse funcT args) +(def: #export (apply-function analyse inferT args) (-> &;Analyser Type (List Code) (Meta [Type (List Analysis)])) (case args #;Nil - (:: Monad<Meta> wrap [funcT (list)]) + (:: Monad<Meta> wrap [inferT (list)]) (#;Cons argC args') - (case funcT + (case inferT (#;Named name unnamedT) (apply-function analyse unnamedT args) @@ -107,7 +110,7 @@ (&common;with-var (function [[var-id varT]] (do Monad<Meta> - [[outputT argsA] (apply-function analyse (maybe;assume (type;apply (list varT) funcT)) args)] + [[outputT argsA] (apply-function analyse (maybe;assume (type;apply (list varT) inferT)) args)] (do @ [? (&;with-type-env (tc;bound? var-id)) @@ -123,7 +126,15 @@ (do Monad<Meta> [[ex-id exT] (&;with-type-env tc;existential)] - (apply-function analyse (maybe;assume (type;apply (list exT) funcT)) args)) + (apply-function analyse (maybe;assume (type;apply (list exT) inferT)) args)) + + (#;Apply inputT transT) + (case (type;apply (list inputT) transT) + (#;Some outputT) + (apply-function analyse outputT args) + + #;None + (&;throw Invalid-Type-Application (%type inferT))) ## Arguments are inferred back-to-front because, by convention, ## Lux functions take the most important arguments *last*, which @@ -134,18 +145,23 @@ ## things together more easily. (#;Function inputT outputT) (do Monad<Meta> - [[outputT' args'A] (apply-function analyse outputT args') - argA (&;with-stacked-errors + [argA (&;with-stacked-errors (function [_] (Cannot-Infer-Argument (format "Inferred Type: " (%type inputT) "\n" " Argument: " (%code argC)))) (&;with-expected-type inputT - (analyse argC)))] + (analyse argC))) + [outputT' args'A] (apply-function analyse outputT args')] (wrap [outputT' (list& argA args'A)])) _ - (&;throw Cannot-Infer (format "Inference Type: " (%type funcT) - " Arguments: " (|> args (list/map %code) (text;join-with " "))))) + (&;throw Cannot-Infer (format " Type: " (%type inferT) "\n" + "Arguments:" + (|> args + list;enumerate + (list/map (function [[idx argC]] + (format "\n " (%n idx) " " (%code argC)))) + (text;join-with ""))))) )) ## Turns a record type into the kind of function type suitable for inference. @@ -153,9 +169,7 @@ (-> Type (Meta Type)) (case type (#;Named name unnamedT) - (do Monad<Meta> - [unnamedT+ (record unnamedT)] - (wrap unnamedT+)) + (record unnamedT) (^template [<tag>] (<tag> env bodyT) @@ -169,7 +183,7 @@ (:: Monad<Meta> wrap (type;function (type;flatten-tuple type) type)) _ - (&;fail (format "Not a record type: " (%type type))))) + (&;throw Not-A-Record-Type (%type type)))) ## Turns a variant type into the kind of function type suitable for inference. (def: #export (variant tag expected-size type) @@ -225,4 +239,4 @@ (&common;variant-out-of-bounds-error type expected-size tag))) _ - (&;fail (format "Not a variant type: " (%type type)))))) + (&;throw Not-A-Variant-Type (%type type))))) diff --git a/new-luxc/source/luxc/lang/analysis/structure.lux b/new-luxc/source/luxc/lang/analysis/structure.lux index 0284245e1..5cac1a0d3 100644 --- a/new-luxc/source/luxc/lang/analysis/structure.lux +++ b/new-luxc/source/luxc/lang/analysis/structure.lux @@ -40,9 +40,9 @@ (do meta;Monad<Meta> [expectedT meta;expected-type] (&;with-stacked-errors - (function [_] (Not-Variant-Type (format " Tag: " (%n tag) "\n" + (function [_] (Not-Variant-Type (format " Type: " (%type expectedT) "\n" "Value: " (%code valueC) "\n" - " Type: " (%type expectedT)))) + " Tag: " (%n tag)))) (case expectedT (#;Sum _) (let [flat (type;flatten-variant expectedT) @@ -102,9 +102,9 @@ (analyse-sum analyse tag valueC))) _ - (&;throw Not-Variant-Type (format " Tag: " (%n tag) "\n" - "Value: " (%code valueC) "\n" - " Type: " (%type expectedT))))))) + (&;throw Not-Variant-Type (format " Type: " (%type expectedT) "\n" + " Tag: " (%n tag) "\n" + "Value: " (%code valueC))))))) (def: (analyse-typed-product analyse members) (-> &;Analyser (List Code) (Meta la;Analysis)) @@ -302,10 +302,16 @@ (-> &;Analyser (List [Code Code]) (Meta la;Analysis)) (do meta;Monad<Meta> [members (normalize members) - [members recordT] (order members) - expectedT meta;expected-type - inferenceT (&inference;record recordT) - [inferredT membersA] (&inference;apply-function analyse inferenceT members) - _ (&;with-type-env - (tc;check expectedT inferredT))] - (wrap (la;product membersA)))) + [membersC recordT] (order members) + expectedT meta;expected-type] + (case expectedT + (#;Var _) + (do @ + [inferenceT (&inference;record recordT) + [inferredT membersA] (&inference;apply-function analyse inferenceT membersC) + _ (&;with-type-env + (tc;check expectedT inferredT))] + (wrap (la;product membersA))) + + _ + (analyse-product analyse membersC)))) diff --git a/new-luxc/source/luxc/lang/analysis/type.lux b/new-luxc/source/luxc/lang/analysis/type.lux index d0b038d93..74bb712f4 100644 --- a/new-luxc/source/luxc/lang/analysis/type.lux +++ b/new-luxc/source/luxc/lang/analysis/type.lux @@ -12,20 +12,20 @@ (def: #export (analyse-check analyse eval type value) (-> &;Analyser &;Eval Code Code (Meta Analysis)) (do Monad<Meta> - [actual (eval Type type) - #let [actual (:! Type actual)] - expected meta;expected-type + [actualT (eval Type type) + #let [actualT (:! Type actualT)] + expectedT meta;expected-type _ (&;with-type-env - (TC;check expected actual))] - (&;with-expected-type actual + (TC;check expectedT actualT))] + (&;with-expected-type actualT (analyse value)))) (def: #export (analyse-coerce analyse eval type value) (-> &;Analyser &;Eval Code Code (Meta Analysis)) (do Monad<Meta> - [actual (eval Type type) - expected meta;expected-type + [actualT (eval Type type) + expectedT meta;expected-type _ (&;with-type-env - (TC;check expected (:! Type actual)))] + (TC;check expectedT (:! Type actualT)))] (&;with-expected-type Top (analyse value)))) diff --git a/new-luxc/source/luxc/lang/synthesis/case.lux b/new-luxc/source/luxc/lang/synthesis/case.lux index e230e2799..2fd6e19bb 100644 --- a/new-luxc/source/luxc/lang/synthesis/case.lux +++ b/new-luxc/source/luxc/lang/synthesis/case.lux @@ -4,73 +4,77 @@ [text "text/" Eq<Text>] text/format [number] - (coll [list "list/" Fold<List>])) + (coll [list "list/" Fold<List> Monoid<List>])) (meta [code "code/" Eq<Code>])) (luxc (lang [";L" variable #+ Variable] ["la" analysis] ["ls" synthesis] (synthesis [";S" function])))) -(def: #export (path outer-arity pattern) - (-> ls;Arity la;Pattern ls;Path) +(def: popPS ls;Path (' ("lux case pop"))) + +(def: (path' outer-arity pattern) + (-> ls;Arity la;Pattern (List ls;Path)) (case pattern (^code ("lux case tuple" [(~@ membersP)])) - (case (list;reverse membersP) + (case membersP #;Nil - (' ("lux case pop")) + (list popPS) (#;Cons singletonP #;Nil) - (path outer-arity singletonP) + (path' outer-arity singletonP) - (#;Cons lastP prevsP) - (let [length (list;size membersP) - last-idx (n.dec length) - [_ tuple-path] (list/fold (function [current-pattern [current-idx next-path]] + (#;Cons _) + (let [last-idx (n.dec (list;size membersP)) + [_ tuple-path] (list/fold (function [current-pattern [current-idx next]] [(n.dec current-idx) - (` ("lux case seq" - ("lux case tuple left" (~ (code;nat current-idx)) (~ (path outer-arity current-pattern))) - (~ next-path)))]) - [(n.dec last-idx) - (` ("lux case tuple right" (~ (code;nat last-idx)) (~ (path outer-arity lastP))))] - prevsP)] - (` ("lux case seq" - (~ tuple-path) - ("lux case pop"))))) + (|> (list (if (n.= last-idx current-idx) + (` ("lux case tuple right" (~ (code;nat current-idx)))) + (` ("lux case tuple left" (~ (code;nat current-idx)))))) + (list/compose (path' outer-arity current-pattern)) + (list/compose next))]) + [last-idx (list popPS)] + (list;reverse membersP))] + tuple-path)) (^code ("lux case variant" (~ [_ (#;Nat tag)]) (~ [_ (#;Nat num-tags)]) (~ memberP))) - (` ("lux case seq" - (~ (if (n.= (n.dec num-tags) tag) - (` ("lux case variant right" (~ (code;nat tag)) (~ (path outer-arity memberP)))) - (` ("lux case variant left" (~ (code;nat tag)) (~ (path outer-arity memberP)))))) - ("lux case pop"))) + (|> (list (if (n.= (n.dec num-tags) tag) + (` ("lux case variant right" (~ (code;nat tag)))) + (` ("lux case variant left" (~ (code;nat tag)))))) + (list/compose (path' outer-arity memberP)) + (list& popPS)) (^code ("lux case bind" (~ [_ (#;Nat register)]))) - (` ("lux case seq" - ("lux case bind" (~ (if (functionS;nested? outer-arity) - (code;nat (|> register variableL;local (functionS;adjust-var outer-arity) variableL;local-register)) - (code;nat register)))) - ("lux case pop"))) + (list popPS + (` ("lux case bind" (~ (code;nat (if (functionS;nested? outer-arity) + (|> register variableL;local (functionS;adjust-var outer-arity) variableL;local-register) + register)))))) _ - (` ("lux case seq" - (~ pattern) - ("lux case pop"))))) + (list popPS pattern))) + +(def: (clean-unnecessary-pops paths) + (-> (List ls;Path) (List ls;Path)) + (case paths + (#;Cons path paths') + (if (is popPS path) + (clean-unnecessary-pops paths') + paths) + + #;Nil + paths)) + +(def: #export (path outer-arity pattern body) + (-> ls;Arity la;Pattern ls;Synthesis ls;Path) + (|> (path' outer-arity pattern) clean-unnecessary-pops + (list/fold (function [pre post] + (` ("lux case seq" (~ pre) (~ post)))) + (` ("lux case exec" (~ body)))))) (def: #export (weave leftP rightP) (-> ls;Path ls;Path ls;Path) (with-expansions [<default> (as-is (` ("lux case alt" (~ leftP) (~ rightP))))] (case [leftP rightP] - (^template [<special>] - (^ [[_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat left-idx)] left-then))] - [_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat right-idx)] right-then))]]) - (if (n.= left-idx right-idx) - (` (<special> (~ (code;nat left-idx)) (~ (weave left-then right-then)))) - <default>)) - (["lux case tuple left"] - ["lux case tuple right"] - ["lux case variant left"] - ["lux case variant right"]) - (^ [(^code ("lux case seq" (~ preL) (~ postL))) (^code ("lux case seq" (~ preR) (~ postR)))]) (case (weave preL preR) diff --git a/new-luxc/source/luxc/lang/synthesis/expression.lux b/new-luxc/source/luxc/lang/synthesis/expression.lux index f761fb57c..30704a2d2 100644 --- a/new-luxc/source/luxc/lang/synthesis/expression.lux +++ b/new-luxc/source/luxc/lang/synthesis/expression.lux @@ -86,10 +86,7 @@ (#;Cons [lastP lastA] prevsPA) (let [transform-branch (: (-> la;Pattern la;Analysis ls;Path) (function [pattern expr] - (|> (synthesize expr) - (~) ("lux case exec") - ("lux case seq" (~ (caseS;path outer-arity pattern))) - (`)))) + (caseS;path outer-arity pattern (synthesize expr)))) pathS (list/fold caseS;weave (transform-branch lastP lastA) (list/map (product;uncurry transform-branch) prevsPA))] diff --git a/new-luxc/source/luxc/lang/translation/case.jvm.lux b/new-luxc/source/luxc/lang/translation/case.jvm.lux index 7821db70d..cb0aa2198 100644 --- a/new-luxc/source/luxc/lang/translation/case.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/case.jvm.lux @@ -108,57 +108,50 @@ ($i;IFEQ @else))) (^template [<special> <method>] - (^ [_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat idx)] subP))]) - (do meta;Monad<Meta> - [subI (translate-path' translate stack-depth @else @end subP)] - (wrap (case idx - +0 - (|>. peekI - ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple)) - ($i;int 0) - $i;AALOAD - pushI - subI) - - _ - (|>. peekI - ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple)) - ($i;int (nat-to-int idx)) - ($i;INVOKESTATIC hostL;runtime-class - <method> - ($t;method (list ../runtime;$Tuple $t;int) - (#;Some $Object) - (list)) - false) - pushI - subI))))) + (^ [_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat idx)]))]) + (meta/wrap (case idx + +0 + (|>. peekI + ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple)) + ($i;int 0) + $i;AALOAD + pushI) + + _ + (|>. peekI + ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple)) + ($i;int (nat-to-int idx)) + ($i;INVOKESTATIC hostL;runtime-class + <method> + ($t;method (list ../runtime;$Tuple $t;int) + (#;Some $Object) + (list)) + false) + pushI)))) (["lux case tuple left" "pm_left"] ["lux case tuple right" "pm_right"]) (^template [<special> <flag>] - (^ [_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat idx)] subP))]) - (do meta;Monad<Meta> - [subI (translate-path' translate stack-depth @else @end subP)] - (wrap (<| $i;with-label (function [@success]) - $i;with-label (function [@fail]) - (|>. peekI - ($i;CHECKCAST ($t;descriptor ../runtime;$Variant)) - ($i;int (nat-to-int idx)) - <flag> - ($i;INVOKESTATIC hostL;runtime-class "pm_variant" - ($t;method (list ../runtime;$Variant ../runtime;$Tag ../runtime;$Flag) - (#;Some ../runtime;$Datum) - (list)) - false) - $i;DUP - ($i;IFNULL @fail) - ($i;GOTO @success) - ($i;label @fail) - $i;POP - ($i;GOTO @else) - ($i;label @success) - pushI - subI))))) + (^ [_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat idx)]))]) + (meta/wrap (<| $i;with-label (function [@success]) + $i;with-label (function [@fail]) + (|>. peekI + ($i;CHECKCAST ($t;descriptor ../runtime;$Variant)) + ($i;int (nat-to-int idx)) + <flag> + ($i;INVOKESTATIC hostL;runtime-class "pm_variant" + ($t;method (list ../runtime;$Variant ../runtime;$Tag ../runtime;$Flag) + (#;Some ../runtime;$Datum) + (list)) + false) + $i;DUP + ($i;IFNULL @fail) + ($i;GOTO @success) + ($i;label @fail) + $i;POP + ($i;GOTO @else) + ($i;label @success) + pushI)))) (["lux case variant left" $i;NULL] ["lux case variant right" ($i;string "")]) 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<Maybe> @@ -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<Meta> [elems' ("lux check" ($' Meta ($' List Code)) - (mapM Monad<Meta> - ("lux check" (-> Code ($' Meta Code)) - (function' [elem] - ("lux case" elem - {[_ (#Form (#Cons [[_ (#Symbol ["" "~@"])] (#Cons [spliced #Nil])]))] - (wrap spliced) - - _ - (do Monad<Meta> - [=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<Meta> + ("lux check" (-> Code ($' Meta Code)) + (function' [elem] + ("lux case" elem + {[_ (#Form (#Cons [[_ (#Symbol ["" "~@"])] (#Cons [spliced #Nil])]))] + (wrap spliced) + + _ + (do Monad<Meta> + [=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<Meta> - [=elems (mapM Monad<Meta> untemplate elems)] + [=elems (monad/map Monad<Meta> untemplate elems)] (wrap (wrap-meta (form$ (list tag (untemplate-list =elems))))))}) false (do Monad<Meta> - [=elems (mapM Monad<Meta> untemplate elems)] + [=elems (monad/map Monad<Meta> untemplate elems)] (wrap (wrap-meta (form$ (list tag (untemplate-list =elems))))))})) (def:''' (untemplate replace? subst token) @@ -1935,15 +1936,15 @@ [_ [_ (#Record fields)]] (do Monad<Meta> - [=fields (mapM Monad<Meta> - ("lux check" (-> (& Code Code) ($' Meta Code)) - (function' [kv] - (let' [[k v] kv] - (do Monad<Meta> - [=k (untemplate replace? subst k) - =v (untemplate replace? subst v)] - (wrap (tuple$ (list =k =v))))))) - fields)] + [=fields (monad/map Monad<Meta> + ("lux check" (-> (& Code Code) ($' Meta Code)) + (function' [kv] + (let' [[k v] kv] + (do Monad<Meta> + [=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<Maybe> get-name bindings) - (mapM Monad<Maybe> tuple->list data)] + ("lux case" [(monad/map Monad<Maybe> get-name bindings) + (monad/map Monad<Maybe> 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<Meta> [expansion (macro args) - expansion' (mapM Monad<Meta> macro-expand expansion)] + expansion' (monad/map Monad<Meta> macro-expand expansion)] (wrap (list/join expansion'))) #None @@ -2532,38 +2533,38 @@ {(#Some macro) (do Monad<Meta> [expansion (macro args) - expansion' (mapM Monad<Meta> macro-expand-all expansion)] + expansion' (monad/map Monad<Meta> macro-expand-all expansion)] (wrap (list/join expansion'))) #None (do Monad<Meta> - [args' (mapM Monad<Meta> macro-expand-all args)] + [args' (monad/map Monad<Meta> macro-expand-all args)] (wrap (list (form$ (#Cons (symbol$ macro-name) (list/join args'))))))})) [_ (#Form members)] (do Monad<Meta> - [members' (mapM Monad<Meta> macro-expand-all members)] + [members' (monad/map Monad<Meta> macro-expand-all members)] (wrap (list (form$ (list/join members'))))) [_ (#Tuple members)] (do Monad<Meta> - [members' (mapM Monad<Meta> macro-expand-all members)] + [members' (monad/map Monad<Meta> macro-expand-all members)] (wrap (list (tuple$ (list/join members'))))) [_ (#Record pairs)] (do Monad<Meta> - [pairs' (mapM Monad<Meta> - (function' [kv] - (let' [[key val] kv] - (do Monad<Meta> - [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<Meta> + (function' [kv] + (let' [[key val] kv] + (do Monad<Meta> + [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<Meta> - [members (mapM Monad<Meta> - (: (-> [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<Meta> + (: (-> [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<Meta> - [members (mapM Monad<Meta> - (: (-> 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<Meta> + (: (-> 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<Meta> [name+ (normalize name) - sigs' (mapM Monad<Meta> macro-expand sigs) + sigs' (monad/map Monad<Meta> macro-expand sigs) members (: (Meta (List [Text Code])) - (mapM Monad<Meta> - (: (-> Code (Meta [Text Code])) - (function [token] - (case token - (^ [_ (#Form (list [_ (#Text "lux check")] type [_ (#Symbol ["" name])]))]) - (wrap [name type]) + (monad/map Monad<Meta> + (: (-> 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<Meta> - [tokens' (mapM Monad<Meta> macro-expand tokens) + [tokens' (monad/map Monad<Meta> 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<Meta> - (: (-> 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<Meta> + (: (-> 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<Maybe> - (function [sa] - (case sa - [_ (#;Symbol [_ arg-name])] - (#;Some arg-name) - - _ - #;None)) - sig-args)) + (monad/map Monad<Maybe> + (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<Meta> - (: (-> Code (Meta Text)) - (function [def] - (case def - [_ (#Symbol ["" name])] - (return name) + (monad/map Monad<Meta> + (: (-> 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<Meta> - [imports' (mapM Monad<Meta> - (: (-> Code (Meta (List Importation))) - (function [token] - (case token - [_ (#Symbol "" m-name)] - (do Monad<Meta> - [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<Meta> - [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<Meta> - [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<Meta> - [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<Meta> + (: (-> Code (Meta (List Importation))) + (function [token] + (case token + [_ (#Symbol "" m-name)] + (do Monad<Meta> + [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<Meta> + [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<Meta> + [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<Meta> + [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<Meta> - [current-module current-module-name] - (fail (text/compose "Wrong syntax for import @ " current-module)))))) - imports)] + _ + (do Monad<Meta> + [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<Meta> - [decls' (mapM Monad<Meta> - (: (-> [Ident Type] (Meta (List Code))) - (function [[sname stype]] (open-field prefix sname source+ stype))) - (zip2 tags members))] + [decls' (monad/map Monad<Meta> + (: (-> [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<Meta> - [decls' (mapM Monad<Meta> (: (-> [Ident Type] (Meta (List Code))) - (function [[sname stype]] (open-field prefix sname source stype))) - (zip2 tags members))] + [decls' (monad/map Monad<Meta> (: (-> [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<Meta> - (: (-> 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<Meta> + (: (-> 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<Meta> - (: (-> 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<Meta> + (: (-> 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<Meta> - [pattern' (mapM Monad<Meta> - (: (-> [Ident [Nat Type]] (Meta [Ident Nat Code])) - (function [[r-slot-name [r-idx r-type]]] - (do Monad<Meta> - [g!slot (gensym "")] - (return [r-slot-name r-idx g!slot])))) - (zip2 tags (enumerate members)))] + [pattern' (monad/map Monad<Meta> + (: (-> [Ident [Nat Type]] (Meta [Ident Nat Code])) + (function [[r-slot-name [r-idx r-type]]] + (do Monad<Meta> + [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<Meta> - [bindings (mapM Monad<Meta> - (: (-> Code (Meta Code)) - (function [_] (gensym "temp"))) - slots) + [bindings (monad/map Monad<Meta> + (: (-> 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<Meta> - [pattern' (mapM Monad<Meta> - (: (-> [Ident [Nat Type]] (Meta [Ident Nat Code])) - (function [[r-slot-name [r-idx r-type]]] - (do Monad<Meta> - [g!slot (gensym "")] - (return [r-slot-name r-idx g!slot])))) - (zip2 tags (enumerate members)))] + [pattern' (monad/map Monad<Meta> + (: (-> [Ident [Nat Type]] (Meta [Ident Nat Code])) + (function [[r-slot-name [r-idx r-type]]] + (do Monad<Meta> + [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<Maybe> - [bindings' (mapM Monad<Maybe> get-name bindings) - data' (mapM Monad<Maybe> tuple->list data)] + [bindings' (monad/map Monad<Maybe> get-name bindings) + data' (monad/map Monad<Maybe> 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<Meta> [inits' (: (Meta (List Ident)) - (case (mapM Monad<Maybe> get-ident inits) + (case (monad/map Monad<Maybe> get-ident inits) (#Some inits') (return inits') #None (fail "Wrong syntax for loop"))) - init-types (mapM Monad<Meta> find-type inits') + init-types (monad/map Monad<Meta> 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<Meta> - [aliases (mapM Monad<Meta> - (: (-> Code (Meta Code)) - (function [_] (gensym ""))) - inits)] + [aliases (monad/map Monad<Meta> + (: (-> 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<Maybe> [hslot (get-tag hslot') - tslots (mapM Monad<Maybe> get-tag tslots')] + tslots (monad/map Monad<Maybe> 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<Meta> normalize tslots) + tslots (monad/map Monad<Meta> normalize tslots) output (resolve-tag hslot) g!_ (gensym "_") #let [[idx tags exported? type] output @@ -5335,26 +5336,26 @@ (^template [<tag> <ctor>] [_ (<tag> elems)] (do Monad<Maybe> - [placements (mapM Monad<Maybe> (place-tokens label tokens) elems)] + [placements (monad/map Monad<Maybe> (place-tokens label tokens) elems)] (wrap (list (<ctor> (list/join placements)))))) ([#Tuple tuple$] [#Form form$]) [_ (#Record pairs)] (do Monad<Maybe> - [=pairs (mapM Monad<Maybe> - (: (-> [Code Code] (Maybe [Code Code])) - (function [[slot value]] - (do Monad<Maybe> - [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<Maybe> + (: (-> [Code Code] (Maybe [Code Code])) + (function [[slot value]] + (do Monad<Maybe> + [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 [<tag>] [meta (<tag> parts)] (do Monad<Meta> - [=parts (mapM Monad<Meta> anti-quote parts)] + [=parts (monad/map Monad<Meta> anti-quote parts)] (wrap [meta (<tag> =parts)]))) ([#Form] [#Tuple]) [meta (#Record pairs)] (do Monad<Meta> - [=pairs (mapM Monad<Meta> - (: (-> [Code Code] (Meta [Code Code])) - (function [[slot value]] - (do Monad<Meta> - [=value (anti-quote value)] - (wrap [slot =value])))) - pairs)] + [=pairs (monad/map Monad<Meta> + (: (-> [Code Code] (Meta [Code Code])) + (function [[slot value]] + (do Monad<Meta> + [=value (anti-quote value)] + (wrap [slot =value])))) + pairs)] (wrap [meta (#Record =pairs)])) _ @@ -5525,7 +5526,7 @@ (#;Cons init extras) (do Monad<Meta> - [extras' (mapM Monad<Meta> case-level^ extras)] + [extras' (monad/map Monad<Meta> 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<Meta> - [args (mapM Monad<Meta> - (function [arg'] - (case arg' - [_ (#Symbol ["" arg-name])] - (wrap arg-name) + [args (monad/map Monad<Meta> + (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 [<tag>] [ann (<tag> parts)] (do Monad<Meta> - [=parts (mapM Monad<Meta> label-code parts)] + [=parts (monad/map Monad<Meta> label-code parts)] (wrap [(fold list/compose (list) (map left =parts)) [ann (<tag> (map right =parts))]]))) ([#Form] [#Tuple]) [ann (#Record kvs)] (do Monad<Meta> - [=kvs (mapM Monad<Meta> - (function [[key val]] - (do Monad<Meta> - [=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<Meta> + (function [[key val]] + (do Monad<Meta> + [=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<Meta> - [=fields (mapM Monad<Meta> - (function [[key value]] - (do Monad<Meta> - [=key (untemplate-pattern key) - =value (untemplate-pattern value)] - (wrap (` [(~ =key) (~ =value)])))) - fields) + [=fields (monad/map Monad<Meta> + (function [[key value]] + (do Monad<Meta> + [=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<Meta> - [=inits (mapM Monad<Meta> untemplate-pattern (reverse inits)) + [=inits (monad/map Monad<Meta> untemplate-pattern (reverse inits)) g!meta (gensym "g!meta")] (wrap (` [(~ g!meta) (<tag> (~ (untemplate-list& spliced =inits)))]))) _ (do Monad<Meta> - [=elems (mapM Monad<Meta> untemplate-pattern elems) + [=elems (monad/map Monad<Meta> untemplate-pattern elems) g!meta (gensym "g!meta")] (wrap (` [(~ g!meta) (<tag> (~ (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<Text> Eq<Text>] - [ident "Ident/" Eq<Ident>] - [number "Nat/" Codec<Text,Nat>] + [monad #+ do Monad]) + (data [text "text/" Monoid<Text> Eq<Text>] + [ident "ident/" Eq<Ident>] + [number "nat/" Codec<Text,Nat>] [maybe] - (coll [list #+ "List/" Monad<List> Monoid<List> Fold<List>])) + (coll [list #+ "list/" Monad<List> Monoid<List> Fold<List>])) (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 [<tag>] (<tag> 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 [<tag>] @@ -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 [<tag>] <tag> @@ -189,7 +189,7 @@ (^template [<tag> <macro> <flattener>] (<tag> left right) - (` (<macro> (~@ (List/map to-ast (<flattener> type)))))) + (` (<macro> (~@ (list/map to-ast (<flattener> type)))))) ([#;Sum | flatten-variant] [#;Product & flatten-tuple]) @@ -198,7 +198,7 @@ (^template [<tag>] (<tag> env body) - (` (<tag> (list (~@ (List/map to-ast env))) + (` (<tag> (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 [<tag> <open> <close> <flatten>] (<tag> _) - ($_ Text/compose <open> + ($_ text/compose <open> (|> (<flatten> type) - (List/map to-text) + (list/map to-text) list;reverse (list;interpose " ") - (List/fold Text/compose "")) + (list/fold text/compose "")) <close>)) ([#;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 [<tag> <desc>] (<tag> env body) - ($_ Text/compose "(" <desc> " {" (|> env (List/map to-text) (text;join-with " ")) "} " (to-text body) ")")) + ($_ text/compose "(" <desc> " {" (|> 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<Type>]) )) +(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<Check> [? (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<Check> + [assumptions (check' eFT aFT assumptions)] + (check' eAT aAT assumptions)) + + [(#;Var id) _] + (either (do Monad<Check> + [rFT (read id)] + (check' (#;Apply eAT rFT) (#;Apply aAT aFT) assumptions)) + (do Monad<Check> + [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<Check> + [rFT (read id)] + (check' (#;Apply eAT eFT) (#;Apply aAT rFT) assumptions)) + (do Monad<Check> + [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<Check> - [F1 (read id)] - (check' (#;Apply A1 F1) actual assumptions)) - (do Monad<Check> - [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<Check> - [F2 (read id)] - (check' expected (#;Apply A2 F2) assumptions)) - (do Monad<Check> - [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<Check> - [expected' (apply-type! F A)] - (check' expected' actual (assume! fx-pair true assumptions))))) - - [_ (#;Apply A F)] - (do Monad<Check> - [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 [<fe> <fa>] + [(#;Apply A1 <fe>) (#;Apply A2 <fa>)] + (check-apply check' assumptions [A1 <fe>] [A2 <fa>])) + ([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<Check> + [expected' (apply-type! F A)] + (check' expected' actual (assume! fx-pair true assumptions))))) + + [_ (#;Apply A F)] + (do Monad<Check> + [actual' (apply-type! F A)] + (check' expected actual' assumptions)) - [(#;UnivQ _) _] - (do Monad<Check> - [[ex-id ex] existential - expected' (apply-type! expected ex)] - (check' expected' actual assumptions)) - - [_ (#;UnivQ _)] - (with - (function [[var-id var]] - (do Monad<Check> - [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<Check> - [expected' (apply-type! expected var) - assumptions (check' expected' actual assumptions) - _ (clean var-id actual)] - (check/wrap assumptions)))) - - [_ (#;ExQ a!env a!def)] - (do Monad<Check> - [[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<Check> + [[ex-id ex] existential + expected' (apply-type! expected ex)] + (check' expected' actual assumptions)) + + [_ (#;UnivQ _)] + (with + (function [[var-id var]] + (do Monad<Check> + [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<Check> + [expected' (apply-type! expected var) + assumptions (check' expected' actual assumptions) + _ (clean var-id actual)] + (check/wrap assumptions)))) + + [_ (#;ExQ a!env a!def)] (do Monad<Check> - [assumptions (monad;fold Monad<Check> - (function [[e a] assumptions] (check' e a assumptions)) - assumptions - (list;zip2 e-params a-params))] - (check/wrap assumptions)) - (fail-check expected actual)) - - (^template [<identity> <compose>] - [<identity> <identity>] - (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<Check> + [assumptions (monad;fold Monad<Check> + (function [[e a] assumptions] (check' e a assumptions)) + assumptions + (list;zip2 e-params a-params))] + (check/wrap assumptions)) + (fail "")) + + (^template [<identity> <compose>] + [<identity> <identity>] + (check/wrap assumptions) + + [(<compose> eL eR) (<compose> aL aR)] + (do Monad<Check> + [assumptions (check' eL aL assumptions)] + (check' eR aR assumptions))) + ([#;Void #;Sum] + [#;Unit #;Product]) - [(<compose> eL eR) (<compose> aL aR)] + [(#;Function eI eO) (#;Function aI aO)] (do Monad<Check> - [assumptions (check' eL aL assumptions)] - (check' eR aR assumptions))) - ([#;Void #;Sum] - [#;Unit #;Product]) - - [(#;Function eI eO) (#;Function aI aO)] - (do Monad<Check> - [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."} |