aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/lang/analysis
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc/lang/analysis')
-rw-r--r--new-luxc/source/luxc/lang/analysis/case.lux105
-rw-r--r--new-luxc/source/luxc/lang/analysis/inference.lux38
-rw-r--r--new-luxc/source/luxc/lang/analysis/procedure/common.lux28
3 files changed, 109 insertions, 62 deletions
diff --git a/new-luxc/source/luxc/lang/analysis/case.lux b/new-luxc/source/luxc/lang/analysis/case.lux
index 5d4c592aa..949e18a26 100644
--- a/new-luxc/source/luxc/lang/analysis/case.lux
+++ b/new-luxc/source/luxc/lang/analysis/case.lux
@@ -35,6 +35,15 @@
(format " Type: " (%type type) "\n"
"Pattern: " (%code pattern)))
+(def: (re-quantify envs baseT)
+ (-> (List (List Type)) Type Type)
+ (case envs
+ #;Nil
+ baseT
+
+ (#;Cons head tail)
+ (re-quantify tail (#;UnivQ head baseT))))
+
## Type-checking on the input value is done during the analysis of a
## "case" expression, to ensure that the patterns being used make
## sense for the type of the input value.
@@ -44,52 +53,74 @@
## type-check the input with respect to the patterns.
(def: (simplify-case-type caseT)
(-> Type (Meta Type))
- (case caseT
- (#;Var id)
- (do macro;Monad<Meta>
- [?caseT' (&;with-type-env
- (tc;read id))]
- (case ?caseT'
- (#;Some caseT')
- (simplify-case-type caseT')
+ (loop [envs (: (List (List Type))
+ (list))
+ caseT caseT]
+ (case caseT
+ (#;Var id)
+ (do macro;Monad<Meta>
+ [?caseT' (&;with-type-env
+ (tc;read id))]
+ (case ?caseT'
+ (#;Some caseT')
+ (recur envs caseT')
- _
- (&;throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT))))
+ _
+ (&;throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT))))
- (#;Named name unnamedT)
- (simplify-case-type unnamedT)
+ (#;Named name unnamedT)
+ (recur envs unnamedT)
- (^or (#;UnivQ _) (#;ExQ _))
- (do macro;Monad<Meta>
- [[ex-id exT] (&;with-type-env
- tc;existential)]
- (simplify-case-type (maybe;assume (type;apply (list exT) caseT))))
+ (#;UnivQ env unquantifiedT)
+ (recur (#;Cons env envs) unquantifiedT)
- (#;Apply inputT funcT)
- (case funcT
- (#;Var funcT-id)
+ ## (^template [<tag> <instancer>]
+ ## (<tag> _)
+ ## (do macro;Monad<Meta>
+ ## [[_ instanceT] (&;with-type-env
+ ## <instancer>)]
+ ## (recur (maybe;assume (type;apply (list instanceT) caseT)))))
+ ## ([#;UnivQ tc;var]
+ ## [#;ExQ tc;existential])
+
+ (#;ExQ _)
(do macro;Monad<Meta>
- [funcT' (&;with-type-env
- (do tc;Monad<Check>
- [?funct' (tc;read funcT-id)]
- (case ?funct'
- (#;Some funct')
- (wrap funct')
+ [[ex-id exT] (&;with-type-env
+ tc;existential)]
+ (recur envs (maybe;assume (type;apply (list exT) caseT))))
- _
- (tc;throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT)))))]
- (simplify-case-type (#;Apply inputT funcT')))
+ (#;Apply inputT funcT)
+ (case funcT
+ (#;Var funcT-id)
+ (do macro;Monad<Meta>
+ [funcT' (&;with-type-env
+ (do tc;Monad<Check>
+ [?funct' (tc;read funcT-id)]
+ (case ?funct'
+ (#;Some funct')
+ (wrap funct')
- _
- (case (type;apply (list inputT) funcT)
- (#;Some outputT)
- (:: macro;Monad<Meta> wrap outputT)
+ _
+ (tc;throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT)))))]
+ (recur envs (#;Apply inputT funcT')))
- #;None
- (&;throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT))))
+ _
+ (case (type;apply (list inputT) funcT)
+ (#;Some outputT)
+ (recur envs outputT)
- _
- (:: macro;Monad<Meta> wrap caseT)))
+ #;None
+ (&;throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT))))
+
+ (#;Product _)
+ (|> caseT
+ type;flatten-tuple
+ (list/map (re-quantify envs))
+ type;tuple
+ (:: macro;Monad<Meta> wrap))
+
+ _
+ (:: macro;Monad<Meta> wrap (re-quantify envs caseT)))))
## This function handles several concerns at once, but it must be that
## way because those concerns are interleaved when doing
diff --git a/new-luxc/source/luxc/lang/analysis/inference.lux b/new-luxc/source/luxc/lang/analysis/inference.lux
index c6f0323f7..e89ab2e1e 100644
--- a/new-luxc/source/luxc/lang/analysis/inference.lux
+++ b/new-luxc/source/luxc/lang/analysis/inference.lux
@@ -132,9 +132,9 @@
))
## Turns a record type into the kind of function type suitable for inference.
-(def: #export (record type)
+(def: #export (record inferT)
(-> Type (Meta Type))
- (case type
+ (case inferT
(#;Named name unnamedT)
(record unnamedT)
@@ -146,17 +146,25 @@
([#;UnivQ]
[#;ExQ])
+ (#;Apply inputT funcT)
+ (case (type;apply (list inputT) funcT)
+ (#;Some outputT)
+ (record outputT)
+
+ #;None
+ (&;throw Invalid-Type-Application (%type inferT)))
+
(#;Product _)
- (macro/wrap (type;function (type;flatten-tuple type) type))
+ (macro/wrap (type;function (type;flatten-tuple inferT) inferT))
_
- (&;throw Not-A-Record-Type (%type type))))
+ (&;throw Not-A-Record-Type (%type inferT))))
## Turns a variant type into the kind of function type suitable for inference.
-(def: #export (variant tag expected-size type)
+(def: #export (variant tag expected-size inferT)
(-> Nat Nat Type (Meta Type))
(loop [depth +0
- currentT type]
+ currentT inferT]
(case currentT
(#;Named name unnamedT)
(do macro;Monad<Meta>
@@ -182,12 +190,12 @@
(#;Some caseT)
(macro/wrap (if (n.= +0 depth)
(type;function (list caseT) currentT)
- (let [replace! (replace-bound (|> depth n.dec (n.* +2)) type)]
+ (let [replace! (replace-bound (|> depth n.dec (n.* +2)) inferT)]
(type;function (list (replace! caseT))
(replace! currentT)))))
#;None
- (&common;variant-out-of-bounds-error type expected-size tag))
+ (&common;variant-out-of-bounds-error inferT expected-size tag))
(n.< expected-size actual-size)
(&;throw Smaller-Variant-Than-Expected
@@ -198,12 +206,20 @@
(let [caseT (type;variant (list;drop boundary cases))]
(macro/wrap (if (n.= +0 depth)
(type;function (list caseT) currentT)
- (let [replace! (replace-bound (|> depth n.dec (n.* +2)) type)]
+ (let [replace! (replace-bound (|> depth n.dec (n.* +2)) inferT)]
(type;function (list (replace! caseT))
(replace! currentT))))))
## else
- (&common;variant-out-of-bounds-error type expected-size tag)))
+ (&common;variant-out-of-bounds-error inferT expected-size tag)))
+
+ (#;Apply inputT funcT)
+ (case (type;apply (list inputT) funcT)
+ (#;Some outputT)
+ (variant tag expected-size outputT)
+
+ #;None
+ (&;throw Invalid-Type-Application (%type inferT)))
_
- (&;throw Not-A-Variant-Type (%type type)))))
+ (&;throw Not-A-Variant-Type (%type inferT)))))
diff --git a/new-luxc/source/luxc/lang/analysis/procedure/common.lux b/new-luxc/source/luxc/lang/analysis/procedure/common.lux
index 489414c2a..f5afca5bf 100644
--- a/new-luxc/source/luxc/lang/analysis/procedure/common.lux
+++ b/new-luxc/source/luxc/lang/analysis/procedure/common.lux
@@ -172,7 +172,7 @@
(|> (dict;new text;Hash<Text>)
(install "log" (unary Text Unit))
(install "error" (unary Text Bottom))
- (install "exit" (unary Nat Bottom))
+ (install "exit" (unary Int Bottom))
(install "current-time" (nullary Int)))))
(def: bit-procs
@@ -202,7 +202,7 @@
(install "min" (nullary Nat))
(install "max" (nullary Nat))
(install "to-int" (unary Nat Int))
- (install "to-text" (unary Nat Text)))))
+ (install "char" (unary Nat Text)))))
(def: int-procs
Bundle
@@ -277,28 +277,28 @@
(install "lower" (unary Text Text))
)))
-(def: (array-get proc)
+(def: (array//get proc)
(-> Text Proc)
(function [analyse eval args]
(do macro;Monad<Meta>
[[var-id varT] (&;with-type-env tc;var)]
- ((binary Nat (type (Array varT)) varT proc)
+ ((binary (type (Array varT)) Nat (type (Maybe varT)) proc)
analyse eval args))))
-(def: (array-put proc)
+(def: (array//put proc)
(-> Text Proc)
(function [analyse eval args]
(do macro;Monad<Meta>
[[var-id varT] (&;with-type-env tc;var)]
- ((trinary Nat varT (type (Array varT)) (type (Array varT)) proc)
+ ((trinary (type (Array varT)) Nat varT (type (Array varT)) proc)
analyse eval args))))
-(def: (array-remove proc)
+(def: (array//remove proc)
(-> Text Proc)
(function [analyse eval args]
(do macro;Monad<Meta>
[[var-id varT] (&;with-type-env tc;var)]
- ((binary Nat (type (Array varT)) (type (Array varT)) proc)
+ ((binary (type (Array varT)) Nat (type (Array varT)) proc)
analyse eval args))))
(def: array-procs
@@ -306,9 +306,9 @@
(<| (prefix "array")
(|> (dict;new text;Hash<Text>)
(install "new" (unary Nat Array))
- (install "get" array-get)
- (install "put" array-put)
- (install "remove" array-remove)
+ (install "get" array//get)
+ (install "put" array//put)
+ (install "remove" array//remove)
(install "size" (unary (type (Ex [a] (Array a))) Nat))
)))
@@ -359,12 +359,12 @@
((unary (type (Atom varT)) varT proc)
analyse eval args))))
-(def: (atom-compare-and-swap proc)
+(def: (atom//compare-and-swap proc)
(-> Text Proc)
(function [analyse eval args]
(do macro;Monad<Meta>
[[var-id varT] (&;with-type-env tc;var)]
- ((trinary varT varT (type (Atom varT)) Bool proc)
+ ((trinary (type (Atom varT)) varT varT Bool proc)
analyse eval args))))
(def: atom-procs
@@ -373,7 +373,7 @@
(|> (dict;new text;Hash<Text>)
(install "new" atom-new)
(install "read" atom-read)
- (install "compare-and-swap" atom-compare-and-swap)
+ (install "compare-and-swap" atom//compare-and-swap)
)))
(def: process-procs
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-05 16:02:51 +0000