aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/lang/analysis/function.lux10
-rw-r--r--new-luxc/source/luxc/lang/analysis/inference.lux46
-rw-r--r--new-luxc/source/luxc/lang/analysis/structure.lux30
-rw-r--r--new-luxc/source/luxc/lang/analysis/type.lux16
-rw-r--r--new-luxc/source/luxc/lang/synthesis/case.lux90
-rw-r--r--new-luxc/source/luxc/lang/synthesis/expression.lux5
-rw-r--r--new-luxc/source/luxc/lang/translation/case.jvm.lux87
-rw-r--r--stdlib/source/lux.lux559
-rw-r--r--stdlib/source/lux/meta/type.lux58
-rw-r--r--stdlib/source/lux/meta/type/check.lux325
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."}