From 530a14bfe7714f94babdb34c237b88321408a685 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Mon, 13 Nov 2017 23:45:12 -0400
Subject: - More refactoring.
---
new-luxc/source/luxc/lang/analysis/common.lux | 3 +-
new-luxc/source/luxc/lang/analysis/function.lux | 19 ++++----
new-luxc/source/luxc/lang/analysis/inference.lux | 50 +++++++++++-----------
.../luxc/lang/analysis/procedure/host.jvm.lux | 49 ++++++++-------------
new-luxc/source/luxc/lang/analysis/structure.lux | 4 +-
5 files changed, 53 insertions(+), 72 deletions(-)
(limited to 'new-luxc/source/luxc')
diff --git a/new-luxc/source/luxc/lang/analysis/common.lux b/new-luxc/source/luxc/lang/analysis/common.lux
index 1eb2b8b37..b14524559 100644
--- a/new-luxc/source/luxc/lang/analysis/common.lux
+++ b/new-luxc/source/luxc/lang/analysis/common.lux
@@ -13,8 +13,7 @@
(def: #export (with-unknown-type action)
(All [a] (-> (Meta Analysis) (Meta [Type Analysis])))
(do meta;Monad
- [[var-id var-type] (&;with-type-env
- tc;var)
+ [[var-id var-type] (&;with-type-env tc;var)
analysis (&;with-expected-type var-type
action)
analysis-type (&;with-type-env
diff --git a/new-luxc/source/luxc/lang/analysis/function.lux b/new-luxc/source/luxc/lang/analysis/function.lux
index 0bb46aba1..2a9826683 100644
--- a/new-luxc/source/luxc/lang/analysis/function.lux
+++ b/new-luxc/source/luxc/lang/analysis/function.lux
@@ -39,17 +39,14 @@
#;None
(&;throw Invalid-Function-Type (%type expectedT)))
-
- (#;UnivQ _)
- (do @
- [[var-id var] (&;with-type-env
- tc;existential)]
- (recur (maybe;assume (type;apply (list var) expectedT))))
- (#;ExQ _)
- (do @
- [[var-id var] (&;with-type-env tc;var)]
- (recur (maybe;assume (type;apply (list var) expectedT))))
+ (^template [ ]
+ ( _)
+ (do @
+ [[_ instanceT] (&;with-type-env )]
+ (recur (maybe;assume (type;apply (list instanceT) expectedT)))))
+ ([#;UnivQ tc;existential]
+ [#;ExQ tc;var])
(#;Var id)
(do @
@@ -106,5 +103,5 @@
(format "\n " (%n idx) " " (%code argC))))
(text;join-with "")))))
(do meta;Monad
- [[applyT argsA] (&inference;apply-function analyse funcT args)]
+ [[applyT argsA] (&inference;general analyse funcT args)]
(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 934ecafa5..5152de0b6 100644
--- a/new-luxc/source/luxc/lang/analysis/inference.lux
+++ b/new-luxc/source/luxc/lang/analysis/inference.lux
@@ -6,7 +6,7 @@
[text]
text/format
(coll [list "list/" Functor]))
- [meta #+ Monad]
+ [meta "meta/" Monad]
(meta [type]
(type ["tc" check])))
(luxc ["&" base]
@@ -95,23 +95,23 @@
## tagged variants).
## 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 inferT args)
+(def: #export (general analyse inferT args)
(-> &;Analyser Type (List Code) (Meta [Type (List Analysis)]))
(case args
#;Nil
- (do Monad
+ (do meta;Monad
[_ (&;infer inferT)]
(wrap [inferT (list)]))
(#;Cons argC args')
(case inferT
(#;Named name unnamedT)
- (apply-function analyse unnamedT args)
+ (general analyse unnamedT args)
(#;UnivQ _)
- (do Monad
+ (do meta;Monad
[[var-id varT] (&;with-type-env tc;var)
- [outputT argsA] (apply-function analyse (maybe;assume (type;apply (list varT) inferT)) args)]
+ [outputT argsA] (general analyse (maybe;assume (type;apply (list varT) inferT)) args)]
(do @
[? (&;with-type-env
(tc;concrete? var-id))
@@ -124,15 +124,15 @@
(wrap [outputT' argsA])))
(#;ExQ _)
- (do Monad
+ (do meta;Monad
[[ex-id exT] (&;with-type-env
tc;existential)]
- (apply-function analyse (maybe;assume (type;apply (list exT) inferT)) args))
+ (general 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)
+ (general analyse outputT args)
#;None
(&;throw Invalid-Type-Application (%type inferT)))
@@ -145,8 +145,8 @@
## avoided in Lux code, since the inference algorithm can piece
## things together more easily.
(#;Function inputT outputT)
- (do Monad
- [[outputT' args'A] (apply-function analyse outputT args')
+ (do meta;Monad
+ [[outputT' args'A] (general analyse outputT args')
argA (&;with-stacked-errors
(function [_] (Cannot-Infer-Argument
(format "Inferred Type: " (%type inputT) "\n"
@@ -174,14 +174,14 @@
(^template []
( env bodyT)
- (do Monad
+ (do meta;Monad
[bodyT+ (record bodyT)]
(wrap ( env bodyT+))))
([#;UnivQ]
[#;ExQ])
(#;Product _)
- (:: Monad wrap (type;function (type;flatten-tuple type) type))
+ (meta/wrap (type;function (type;flatten-tuple type) type))
_
(&;throw Not-A-Record-Type (%type type))))
@@ -193,13 +193,13 @@
currentT type]
(case currentT
(#;Named name unnamedT)
- (do Monad
+ (do meta;Monad
[unnamedT+ (recur depth unnamedT)]
(wrap unnamedT+))
(^template []
( env bodyT)
- (do Monad
+ (do meta;Monad
[bodyT+ (recur (n.inc depth) bodyT)]
(wrap ( env bodyT+))))
([#;UnivQ]
@@ -214,11 +214,11 @@
(n.< boundary tag)))
(case (list;nth tag cases)
(#;Some caseT)
- (:: Monad wrap (if (n.= +0 depth)
- (type;function (list caseT) currentT)
- (let [replace! (replace-bound (|> depth n.dec (n.* +2)) type)]
- (type;function (list (replace! caseT))
- (replace! currentT)))))
+ (meta/wrap (if (n.= +0 depth)
+ (type;function (list caseT) currentT)
+ (let [replace! (replace-bound (|> depth n.dec (n.* +2)) type)]
+ (type;function (list (replace! caseT))
+ (replace! currentT)))))
#;None
(&common;variant-out-of-bounds-error type expected-size tag))
@@ -230,11 +230,11 @@
(n.= boundary tag)
(let [caseT (type;variant (list;drop boundary cases))]
- (:: Monad wrap (if (n.= +0 depth)
- (type;function (list caseT) currentT)
- (let [replace! (replace-bound (|> depth n.dec (n.* +2)) type)]
- (type;function (list (replace! caseT))
- (replace! currentT))))))
+ (meta/wrap (if (n.= +0 depth)
+ (type;function (list caseT) currentT)
+ (let [replace! (replace-bound (|> depth n.dec (n.* +2)) type)]
+ (type;function (list (replace! caseT))
+ (replace! currentT))))))
## else
(&common;variant-out-of-bounds-error type expected-size tag)))
diff --git a/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux
index fa10a7a1c..39ca0eb43 100644
--- a/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/lang/analysis/procedure/host.jvm.lux
@@ -24,7 +24,7 @@
["&;" host]
(lang ["la" analysis]
(analysis ["&;" common]
- ["&;" inference])))
+ [";A" inference])))
["@" ../common]
)
@@ -367,11 +367,8 @@
(^ (list objectC))
(do meta;Monad
[_ (&;infer Bool)
- [var-id varT] (&;with-type-env tc;var)
- objectA (&;with-expected-type varT
- (analyse objectC))
- objectT (&;with-type-env
- (tc;read var-id))
+ [objectT objectA] (&common;with-unknown-type
+ (analyse objectC))
_ (check-object objectT)]
(wrap (la;procedure proc (list objectA))))
@@ -384,11 +381,8 @@
(case args
(^ (list monitorC exprC))
(do meta;Monad
- [[var-id varT] (&;with-type-env tc;var)
- monitorA (&;with-expected-type varT
- (analyse monitorC))
- monitorT (&;with-type-env
- (tc;read var-id))
+ [[monitorT monitorA] (&common;with-unknown-type
+ (analyse monitorC))
_ (check-object monitorT)
exprA (analyse exprC)]
(wrap (la;procedure proc (list monitorA exprA))))
@@ -483,11 +477,8 @@
(^ (list exceptionC))
(do meta;Monad
[_ (&;infer Bottom)
- [var-id varT] (&;with-type-env tc;var)
- exceptionA (&;with-expected-type varT
- (analyse exceptionC))
- exceptionT (&;with-type-env
- (tc;read var-id))
+ [exceptionT exceptionA] (&common;with-unknown-type
+ (analyse exceptionC))
exception-class (check-object exceptionT)
? (sub-class? "java.lang.Throwable" exception-class)
_ (: (Meta Unit)
@@ -793,15 +784,12 @@
(def: (analyse-object class analyse sourceC)
(-> Text &;Analyser Code (Meta [Type la;Analysis]))
(do meta;Monad
- [[var-id varT] (&;with-type-env tc;var)
- target-class (load-class class)
+ [target-class (load-class class)
targetT (java-type-to-lux-type fresh-mappings
(:! java.lang.reflect.Type
target-class))
- sourceA (&;with-expected-type varT
- (analyse sourceC))
- sourceT (&;with-type-env
- (tc;read var-id))
+ [sourceT sourceA] (&common;with-unknown-type
+ (analyse sourceC))
[unboxed castT] (cast #Out targetT sourceT)
_ (&;assert Cannot-Cast (cannot-cast targetT sourceT)
(not (dict;contains? unboxed boxes)))]
@@ -810,11 +798,8 @@
(def: (analyse-input analyse targetT sourceC)
(-> &;Analyser Type Code (Meta [Type Text la;Analysis]))
(do meta;Monad
- [[var-id varT] (&;with-type-env tc;var)
- sourceA (&;with-expected-type varT
- (analyse sourceC))
- sourceT (&;with-type-env
- (tc;read var-id))
+ [[sourceT sourceA] (&common;with-unknown-type
+ (analyse sourceC))
[unboxed castT] (cast #In targetT sourceT)]
(wrap [castT unboxed sourceA])))
@@ -1134,7 +1119,7 @@
(do meta;Monad
[#let [argsT (list/map product;left argsTC)]
[methodT exceptionsT] (methods class method #Static argsT)
- [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list/map product;right argsTC))
+ [outputT argsA] (inferenceA;general (sub-type-analyser analyse) methodT (list/map product;right argsTC))
[unboxed castT] (infer-out outputT)]
(wrap (la;procedure proc (list& (code;text class) (code;text method)
(code;text unboxed) (decorate-inputs argsT argsA)))))
@@ -1151,7 +1136,7 @@
(do meta;Monad
[#let [argsT (list/map product;left argsTC)]
[methodT exceptionsT] (methods class method #Virtual argsT)
- [outputT allA] (&inference;apply-function (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC)))
+ [outputT allA] (inferenceA;general (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC)))
#let [[objectA argsA] (case allA
(#;Cons objectA argsA)
[objectA argsA]
@@ -1174,7 +1159,7 @@
(do meta;Monad
[#let [argsT (list/map product;left argsTC)]
[methodT exceptionsT] (methods class method #Special argsT)
- [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC)))
+ [outputT argsA] (inferenceA;general (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC)))
[unboxed castT] (infer-out outputT)]
(wrap (la;procedure proc (list& (code;text class) (code;text method)
(code;text unboxed) (decorate-inputs argsT argsA)))))
@@ -1194,7 +1179,7 @@
_ (&;assert Non-Interface class-name
(Modifier.isInterface [(Class.getModifiers [] class)]))
[methodT exceptionsT] (methods class-name method #Interface argsT)
- [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC)))
+ [outputT argsA] (inferenceA;general (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC)))
[unboxed castT] (infer-out outputT)]
(wrap (la;procedure proc
(list& (code;text class-name) (code;text method) (code;text unboxed)
@@ -1212,7 +1197,7 @@
(do meta;Monad
[#let [argsT (list/map product;left argsTC)]
[methodT exceptionsT] (constructor-methods class argsT)
- [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list/map product;right argsTC))
+ [outputT argsA] (inferenceA;general (sub-type-analyser analyse) methodT (list/map product;right argsTC))
[unboxed castT] (infer-out outputT)]
(wrap (la;procedure proc (list& (code;text class) (decorate-inputs argsT argsA)))))
diff --git a/new-luxc/source/luxc/lang/analysis/structure.lux b/new-luxc/source/luxc/lang/analysis/structure.lux
index b7047e105..e1f4de1d7 100644
--- a/new-luxc/source/luxc/lang/analysis/structure.lux
+++ b/new-luxc/source/luxc/lang/analysis/structure.lux
@@ -217,7 +217,7 @@
(do @
[#let [case-size (list;size group)]
inferenceT (&inference;variant idx case-size variantT)
- [inferredT valueA+] (&inference;apply-function analyse inferenceT (list valueC))
+ [inferredT valueA+] (&inference;general analyse inferenceT (list valueC))
temp &scope;next-local]
(wrap (la;sum idx case-size temp (|> valueA+ list;head maybe;assume))))
@@ -303,7 +303,7 @@
(#;Var _)
(do @
[inferenceT (&inference;record recordT)
- [inferredT membersA] (&inference;apply-function analyse inferenceT membersC)]
+ [inferredT membersA] (&inference;general analyse inferenceT membersC)]
(wrap (la;product membersA)))
_
--
cgit v1.2.3