From e37e3713e080606930a5f8442f03dabc4c26a7f9 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Tue, 21 Nov 2017 16:09:07 -0400
Subject: - Fixed some bugs. - Some small refactoring.
---
new-luxc/source/luxc/lang/analysis/case.lux | 2 +-
new-luxc/source/luxc/lang/analysis/expression.lux | 15 +++---
new-luxc/source/luxc/lang/analysis/function.lux | 6 ++-
.../source/luxc/lang/analysis/procedure/common.lux | 2 +
new-luxc/source/luxc/lang/analysis/reference.lux | 3 +-
new-luxc/source/luxc/lang/analysis/structure.lux | 61 ++++++++++++----------
6 files changed, 52 insertions(+), 37 deletions(-)
(limited to 'new-luxc/source/luxc/lang/analysis')
diff --git a/new-luxc/source/luxc/lang/analysis/case.lux b/new-luxc/source/luxc/lang/analysis/case.lux
index 4a28ce436..5d4c592aa 100644
--- a/new-luxc/source/luxc/lang/analysis/case.lux
+++ b/new-luxc/source/luxc/lang/analysis/case.lux
@@ -239,7 +239,7 @@
(^ [cursor (#;Form (list& [_ (#;Tag tag)] values))])
(&;with-cursor cursor
(do macro;Monad
- [tag (macro;canonical tag)
+ [tag (macro;normalize tag)
[idx group variantT] (macro;resolve-tag tag)
_ (&;with-type-env
(tc;check inputT variantT))]
diff --git a/new-luxc/source/luxc/lang/analysis/expression.lux b/new-luxc/source/luxc/lang/analysis/expression.lux
index 89fb3b93e..6abe8e62b 100644
--- a/new-luxc/source/luxc/lang/analysis/expression.lux
+++ b/new-luxc/source/luxc/lang/analysis/expression.lux
@@ -93,13 +93,14 @@
(case ?macro
(#;Some macro)
(do @
- [expansion (function [compiler]
- (case (macroL;expand macro args compiler)
- (#e;Success [compiler' output])
- (#e;Success [compiler' output])
-
- (#e;Error error)
- ((&;throw Macro-Expansion-Failed error) compiler)))]
+ [expansion (: (Meta (List Code))
+ (function [compiler]
+ (case (macroL;expand macro args compiler)
+ (#e;Error error)
+ ((&;throw Macro-Expansion-Failed error) compiler)
+
+ output
+ output)))]
(case expansion
(^ (list single))
(analyse single)
diff --git a/new-luxc/source/luxc/lang/analysis/function.lux b/new-luxc/source/luxc/lang/analysis/function.lux
index a2aa95c08..b4aa31c90 100644
--- a/new-luxc/source/luxc/lang/analysis/function.lux
+++ b/new-luxc/source/luxc/lang/analysis/function.lux
@@ -17,6 +17,7 @@
["&;" inference])
[";L" variable #+ Variable])))
+(exception: #export Cannot-Analyse-Function)
(exception: #export Invalid-Function-Type)
(exception: #export Cannot-Apply-Function)
@@ -27,7 +28,10 @@
[functionT macro;expected-type]
(loop [expectedT functionT]
(&;with-stacked-errors
- (function [_] (Invalid-Function-Type (%type expectedT)))
+ (function [_] (Cannot-Analyse-Function (format " Type: " (%type expectedT) "\n"
+ "Function: " func-name "\n"
+ "Argument: " arg-name "\n"
+ " Body: " (%code body))))
(case expectedT
(#;Named name unnamedT)
(recur unnamedT)
diff --git a/new-luxc/source/luxc/lang/analysis/procedure/common.lux b/new-luxc/source/luxc/lang/analysis/procedure/common.lux
index 747e9f61d..489414c2a 100644
--- a/new-luxc/source/luxc/lang/analysis/procedure/common.lux
+++ b/new-luxc/source/luxc/lang/analysis/procedure/common.lux
@@ -273,6 +273,8 @@
(install "replace-all" (trinary Text Text Text Text))
(install "char" (binary Text Nat (type (Maybe Nat))))
(install "clip" (trinary Text Nat Nat (type (Maybe Text))))
+ (install "upper" (unary Text Text))
+ (install "lower" (unary Text Text))
)))
(def: (array-get proc)
diff --git a/new-luxc/source/luxc/lang/analysis/reference.lux b/new-luxc/source/luxc/lang/analysis/reference.lux
index 7475f269f..c660408de 100644
--- a/new-luxc/source/luxc/lang/analysis/reference.lux
+++ b/new-luxc/source/luxc/lang/analysis/reference.lux
@@ -21,7 +21,8 @@
_
(do @
- [_ (&;infer actualT)]
+ [_ (&;infer actualT)
+ def-name (macro;normalize def-name)]
(wrap (code;symbol def-name))))))
(def: (analyse-variable var-name)
diff --git a/new-luxc/source/luxc/lang/analysis/structure.lux b/new-luxc/source/luxc/lang/analysis/structure.lux
index 19eebbc46..e6cd2dbad 100644
--- a/new-luxc/source/luxc/lang/analysis/structure.lux
+++ b/new-luxc/source/luxc/lang/analysis/structure.lux
@@ -20,10 +20,13 @@
(analysis ["&;" common]
["&;" inference]))))
-(exception: #export Not-Variant-Type)
-(exception: #export Not-Tuple-Type)
+(exception: #export Invalid-Variant-Type)
+(exception: #export Invalid-Tuple-Type)
(exception: #export Not-Quantified-Type)
+(exception: #export Cannot-Analyse-Variant)
+(exception: #export Cannot-Analyse-Tuple)
+
(exception: #export Cannot-Infer-Numeric-Tag)
(exception: #export Record-Keys-Must-Be-Tags)
(exception: #export Cannot-Repeat-Tag)
@@ -35,9 +38,9 @@
(do macro;Monad
[expectedT macro;expected-type]
(&;with-stacked-errors
- (function [_] (Not-Variant-Type (format " Type: " (%type expectedT) "\n"
- "Value: " (%code valueC) "\n"
- " Tag: " (%n tag))))
+ (function [_] (Cannot-Analyse-Variant (format " Type: " (%type expectedT) "\n"
+ " Tag: " (%n tag) "\n"
+ "Expression: " (%code valueC))))
(case expectedT
(#;Sum _)
(let [flat (type;flatten-variant expectedT)
@@ -70,9 +73,9 @@
## Cannot do inference when the tag is numeric.
## This is because there is no way of knowing how many
## cases the inferred sum type would have.
- (&;throw Cannot-Infer-Numeric-Tag (format " Tag: " (%n tag) "\n"
- "Value: " (%code valueC) "\n"
- " Type: " (%type expectedT)))
+ (&;throw Cannot-Infer-Numeric-Tag (format " Type: " (%type expectedT) "\n"
+ " Tag: " (%n tag) "\n"
+ "Expression: " (%code valueC)))
))
(^template [ ]
@@ -95,9 +98,9 @@
(analyse-sum analyse tag valueC))
_
- (&;throw Not-Variant-Type (format " Type: " (%type expectedT) "\n"
- " Tag: " (%n tag) "\n"
- "Value: " (%code valueC)))))
+ (&;throw Invalid-Variant-Type (format " Type: " (%type expectedT) "\n"
+ " Tag: " (%n tag) "\n"
+ "Expression: " (%code valueC)))))
_
(case (type;apply (list inputT) funT)
@@ -109,9 +112,9 @@
(analyse-sum analyse tag valueC))))
_
- (&;throw Not-Variant-Type (format " Type: " (%type expectedT) "\n"
- " Tag: " (%n tag) "\n"
- "Value: " (%code valueC)))))))
+ (&;throw Invalid-Variant-Type (format " Type: " (%type expectedT) "\n"
+ " Tag: " (%n tag) "\n"
+ "Expression: " (%code valueC)))))))
(def: (analyse-typed-product analyse membersC+)
(-> &;Analyser (List Code) (Meta la;Analysis))
@@ -166,8 +169,8 @@
(do macro;Monad
[expectedT macro;expected-type]
(&;with-stacked-errors
- (function [_] (Not-Tuple-Type (format " Type: " (%type expectedT) "\n"
- "Value: " (%code (` [(~@ membersC)])))))
+ (function [_] (Cannot-Analyse-Tuple (format " Type: " (%type expectedT) "\n"
+ "Expression: " (%code (` [(~@ membersC)])))))
(case expectedT
(#;Product _)
(analyse-typed-product analyse membersC)
@@ -215,8 +218,8 @@
(analyse-product analyse membersC))
_
- (&;throw Not-Tuple-Type (format " Type: " (%type expectedT) "\n"
- "Value: " (%code (` [(~@ membersC)]))))))
+ (&;throw Invalid-Tuple-Type (format " Type: " (%type expectedT) "\n"
+ "Expression: " (%code (` [(~@ membersC)]))))))
_
(case (type;apply (list inputT) funT)
@@ -228,14 +231,14 @@
(analyse-product analyse membersC))))
_
- (&;throw Not-Tuple-Type (format " Type: " (%type expectedT) "\n"
- "Value: " (%code (` [(~@ membersC)]))))
+ (&;throw Invalid-Tuple-Type (format " Type: " (%type expectedT) "\n"
+ "Expression: " (%code (` [(~@ membersC)]))))
))))
(def: #export (analyse-tagged-sum analyse tag valueC)
(-> &;Analyser Ident Code (Meta la;Analysis))
(do macro;Monad
- [tag (macro;canonical tag)
+ [tag (macro;normalize tag)
[idx group variantT] (macro;resolve-tag tag)
expectedT macro;expected-type]
(case expectedT
@@ -261,7 +264,7 @@
(case key
[_ (#;Tag key)]
(do macro;Monad
- [key (macro;canonical key)]
+ [key (macro;normalize key)]
(wrap [key val]))
_
@@ -281,22 +284,26 @@
(#;Cons [head-k head-v] _)
(do macro;Monad
- [head-k (macro;canonical head-k)
+ [head-k (macro;normalize head-k)
[_ tag-set recordT] (macro;resolve-tag head-k)
#let [size-record (list;size record)
size-ts (list;size tag-set)]
_ (if (n.= size-ts size-record)
(wrap [])
(&;throw Record-Size-Mismatch
- (format "Expected: " (|> size-ts nat-to-int %i) "\n"
- " Actual: " (|> size-record nat-to-int %i) "\n"
- " Type: " (%type recordT))))
+ (format " Expected: " (|> size-ts nat-to-int %i) "\n"
+ " Actual: " (|> size-record nat-to-int %i) "\n"
+ " Type: " (%type recordT) "\n"
+ "Expression: " (%code (|> record
+ (list/map (function [[keyI valueC]]
+ [(code;tag keyI) valueC]))
+ code;record)))))
#let [tuple-range (list;n.range +0 (n.dec size-ts))
tag->idx (dict;from-list ident;Hash (list;zip2 tag-set tuple-range))]
idx->val (monad;fold @
(function [[key val] idx->val]
(do @
- [key (macro;canonical key)]
+ [key (macro;normalize key)]
(case (dict;get key tag->idx)
#;None
(&;throw Tag-Does-Not-Belong-To-Record
--
cgit v1.2.3