From 7b870a7bd124f35939d9089a2e21f0806a4c6e85 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Sun, 29 Oct 2017 22:21:14 -0400
Subject: - Fixed some bugs. - Improved error reporting. - Implemented
macro-expansion (for JVM). - Implemented "let" compilation.
---
new-luxc/source/luxc/analyser/case.lux | 32 ++++--
new-luxc/source/luxc/analyser/function.lux | 13 ++-
new-luxc/source/luxc/analyser/inference.lux | 158 ++++++++++++++++++----------
new-luxc/source/luxc/analyser/reference.lux | 22 ++--
new-luxc/source/luxc/analyser/structure.lux | 71 +++++++------
5 files changed, 185 insertions(+), 111 deletions(-)
(limited to 'new-luxc/source/luxc/analyser')
diff --git a/new-luxc/source/luxc/analyser/case.lux b/new-luxc/source/luxc/analyser/case.lux
index b65b9ff94..b17dbcbfd 100644
--- a/new-luxc/source/luxc/analyser/case.lux
+++ b/new-luxc/source/luxc/analyser/case.lux
@@ -1,6 +1,7 @@
(;module:
lux
(lux (control [monad #+ do]
+ ["ex" exception #+ exception:]
eq)
(data [bool]
[number]
@@ -21,10 +22,15 @@
["&;" structure])
(. ["&&;" coverage]))
+(exception: #export Cannot-Match-Type-With-Pattern)
+(exception: #export Sum-Type-Has-No-Case)
+(exception: #export Unrecognized-Pattern-Syntax)
+
(def: (pattern-error type pattern)
(-> Type Code Text)
- (format "Cannot match this type: " (%type type) "\n"
- " With this pattern: " (%code pattern)))
+ (Cannot-Match-Type-With-Pattern
+ (format " Type: " (%type type) "\n"
+ "Pattern: " (%code pattern))))
## Type-checking on the input value is done during the analysis of a
## "case" expression, to ensure that the patterns being used make
@@ -56,6 +62,14 @@
tc;existential)]
(simplify-case-type (maybe;assume (type;apply (list exT) type))))
+ (#;Apply inputT funcT)
+ (case (type;apply (list inputT) funcT)
+ (#;Some outputT)
+ (:: meta;Monad wrap outputT)
+
+ #;None
+ (&;fail (format "Cannot apply type " (%type funcT) " to type " (%type inputT))))
+
_
(:: meta;Monad wrap type)))
@@ -122,7 +136,7 @@
[inputT' (simplify-case-type inputT)]
(case inputT'
(#;Product _)
- (let [sub-types (type;flatten-tuple inputT)
+ (let [sub-types (type;flatten-tuple inputT')
num-sub-types (maybe;default (list;size sub-types)
num-tags)
num-sub-patterns (list;size sub-patterns)
@@ -175,7 +189,7 @@
[inputT' (simplify-case-type inputT)]
(case inputT'
(#;Sum _)
- (let [flat-sum (type;flatten-variant inputT)
+ (let [flat-sum (type;flatten-variant inputT')
size-sum (list;size flat-sum)
num-cases (maybe;default size-sum num-tags)]
(case (list;nth idx flat-sum)
@@ -196,7 +210,9 @@
nextA])))
_
- (&;fail (format "Cannot match index " (%n idx) " against type: " (%type inputT)))))
+ (&;throw Sum-Type-Has-No-Case
+ (format "Case: " (%n idx) "\n"
+ "Type: " (%type inputT)))))
_
(&;fail (pattern-error inputT pattern)))))
@@ -211,10 +227,10 @@
(analyse-pattern (#;Some (list;size group)) inputT (` ((~ (code;nat idx)) (~@ values))) next)))
_
- (&;fail (format "Unrecognized pattern syntax: " (%code pattern)))
+ (&;throw Unrecognized-Pattern-Syntax (%code pattern))
))
-(def: #export (analyse-case analyse input branches)
+(def: #export (analyse-case analyse inputC branches)
(-> &;Analyser Code (List [Code Code]) (Meta la;Analysis))
(case branches
#;Nil
@@ -223,7 +239,7 @@
(#;Cons [patternH bodyH] branchesT)
(do meta;Monad
[[inputT inputA] (&common;with-unknown-type
- (analyse input))
+ (analyse inputC))
outputH (analyse-pattern #;None inputT patternH (analyse bodyH))
outputT (monad;map @
(function [[patternT bodyT]]
diff --git a/new-luxc/source/luxc/analyser/function.lux b/new-luxc/source/luxc/analyser/function.lux
index 1432308f8..55896480e 100644
--- a/new-luxc/source/luxc/analyser/function.lux
+++ b/new-luxc/source/luxc/analyser/function.lux
@@ -1,6 +1,7 @@
(;module:
lux
- (lux (control monad)
+ (lux (control monad
+ ["ex" exception #+ exception:])
(data [maybe]
[text]
text/format
@@ -14,6 +15,9 @@
(analyser ["&;" common]
["&;" inference])))
+(exception: #export Invalid-Function-Type)
+(exception: #export Cannot-Apply-Function)
+
## [Analysers]
(def: #export (analyse-function analyse func-name arg-name body)
(-> &;Analyser Text Text Code (Meta Analysis))
@@ -21,7 +25,7 @@
[functionT meta;expected-type]
(loop [expectedT functionT]
(&;with-stacked-errors
- (function [_] (format "Functions require function types: " (type;to-text expectedT)))
+ (function [_] (Invalid-Function-Type (%type expectedT)))
(case expectedT
(#;Named name unnamedT)
(recur unnamedT)
@@ -92,8 +96,9 @@
(def: #export (analyse-apply analyse funcT funcA args)
(-> &;Analyser Type Analysis (List Code) (Meta Analysis))
(&;with-stacked-errors
- (function [_] (format "Cannot apply function " (%type funcT)
- " to args: " (|> args (list/map %code) (text;join-with " "))))
+ (function [_]
+ (Cannot-Apply-Function (format " Function: " (%type funcT) "\n"
+ "Arguments: " (|> args (list/map %code) (text;join-with " ")))))
(do Monad
[expected meta;expected-type
[applyT argsA] (&inference;apply-function analyse funcT args)
diff --git a/new-luxc/source/luxc/analyser/inference.lux b/new-luxc/source/luxc/analyser/inference.lux
index 86832ae9e..049abec28 100644
--- a/new-luxc/source/luxc/analyser/inference.lux
+++ b/new-luxc/source/luxc/analyser/inference.lux
@@ -1,9 +1,11 @@
(;module:
lux
- (lux (control monad)
+ (lux (control [monad #+ do]
+ ["ex" exception #+ exception:])
(data [maybe]
+ [text]
text/format
- (coll [list "L/" Functor]))
+ (coll [list "list/" Functor]))
[meta #+ Monad]
(meta [type]
(type ["tc" check])))
@@ -11,6 +13,10 @@
(lang ["la" analysis #+ Analysis])
(analyser ["&;" common])))
+(exception: #export Cannot-Infer)
+(exception: #export Cannot-Infer-Argument)
+(exception: #export Smaller-Variant-Than-Expected)
+
## When doing inference, type-variables often need to be created in
## order to figure out which types are present in the expression being
## inferred.
@@ -23,7 +29,7 @@
(-> Nat Nat Type Type)
(case type
(#;Primitive name params)
- (#;Primitive name (L/map (replace-var var-id bound-idx) params))
+ (#;Primitive name (list/map (replace-var var-id bound-idx) params))
(^template []
( left right)
@@ -41,15 +47,41 @@
(^template []
( env quantified)
- ( (L/map (replace-var var-id bound-idx) env)
+ ( (list/map (replace-var var-id bound-idx) env)
(replace-var var-id (n.+ +2 bound-idx) quantified)))
([#;UnivQ]
[#;ExQ])
- (#;Named name unnamedT)
- (#;Named name
- (replace-var var-id bound-idx unnamedT))
+ _
+ type))
+(def: (replace-bound bound-idx replacementT type)
+ (-> Nat Type Type Type)
+ (case type
+ (#;Primitive name params)
+ (#;Primitive name (list/map (replace-bound bound-idx replacementT) params))
+
+ (^template []
+ ( left right)
+ ( (replace-bound bound-idx replacementT left)
+ (replace-bound bound-idx replacementT right)))
+ ([#;Sum]
+ [#;Product]
+ [#;Function]
+ [#;Apply])
+
+ (#;Bound idx)
+ (if (n.= bound-idx idx)
+ replacementT
+ type)
+
+ (^template []
+ ( env quantified)
+ ( (list/map (replace-bound bound-idx replacementT) env)
+ (replace-bound (n.+ +2 bound-idx) replacementT quantified)))
+ ([#;UnivQ]
+ [#;ExQ])
+
_
type))
@@ -66,7 +98,7 @@
#;Nil
(:: Monad wrap [funcT (list)])
- (#;Cons arg args')
+ (#;Cons argC args')
(case funcT
(#;Named name unnamedT)
(apply-function analyse unnamedT args)
@@ -104,29 +136,31 @@
(do Monad
[[outputT' args'A] (apply-function analyse outputT args')
argA (&;with-stacked-errors
- (function [_] (format "Expected type: " (%type inputT) "\n"
- " For argument: " (%code arg)))
+ (function [_] (Cannot-Infer-Argument
+ (format "Inferred Type: " (%type inputT) "\n"
+ " Argument: " (%code argC))))
(&;with-expected-type inputT
- (analyse arg)))]
+ (analyse argC)))]
(wrap [outputT' (list& argA args'A)]))
_
- (&;fail (format "Cannot apply a non-function: " (%type funcT))))
+ (&;throw Cannot-Infer (format "Inference Type: " (%type funcT)
+ " Arguments: " (|> args (list/map %code) (text;join-with " ")))))
))
## Turns a record type into the kind of function type suitable for inference.
-(def: #export (record-inference-type type)
+(def: #export (record type)
(-> Type (Meta Type))
(case type
(#;Named name unnamedT)
(do Monad
- [unnamedT+ (record-inference-type unnamedT)]
- (wrap (#;Named name unnamedT+)))
+ [unnamedT+ (record unnamedT)]
+ (wrap unnamedT+))
(^template []
( env bodyT)
(do Monad
- [bodyT+ (record-inference-type bodyT)]
+ [bodyT+ (record bodyT)]
(wrap ( env bodyT+))))
([#;UnivQ]
[#;ExQ])
@@ -138,47 +172,57 @@
(&;fail (format "Not a record type: " (%type type)))))
## Turns a variant type into the kind of function type suitable for inference.
-(def: #export (variant-inference-type tag expected-size type)
+(def: #export (variant tag expected-size type)
(-> Nat Nat Type (Meta Type))
- (case type
- (#;Named name unnamedT)
- (do Monad
- [unnamedT+ (variant-inference-type tag expected-size unnamedT)]
- (wrap (#;Named name unnamedT+)))
-
- (^template []
- ( env bodyT)
+ (loop [depth +0
+ currentT type]
+ (case currentT
+ (#;Named name unnamedT)
(do Monad
- [bodyT+ (variant-inference-type tag expected-size bodyT)]
- (wrap ( env bodyT+))))
- ([#;UnivQ]
- [#;ExQ])
-
- (#;Sum _)
- (let [cases (type;flatten-variant type)
- actual-size (list;size cases)
- boundary (n.dec expected-size)]
- (cond (or (n.= expected-size actual-size)
- (and (n.> expected-size actual-size)
- (n.< boundary tag)))
- (case (list;nth tag cases)
- (#;Some caseT)
- (:: Monad wrap (type;function (list caseT) type))
-
- #;None
- (&common;variant-out-of-bounds-error type expected-size tag))
-
- (n.< expected-size actual-size)
- (&;fail (format "Variant type is smaller than expected." "\n"
- "Expected: " (%i (nat-to-int expected-size)) "\n"
- " Actual: " (%i (nat-to-int actual-size))))
-
- (n.= boundary tag)
- (let [caseT (type;variant (list;drop boundary cases))]
- (:: Monad wrap (type;function (list caseT) type)))
-
- ## else
- (&common;variant-out-of-bounds-error type expected-size tag)))
+ [unnamedT+ (recur depth unnamedT)]
+ (wrap unnamedT+))
+
+ (^template []
+ ( env bodyT)
+ (do Monad
+ [bodyT+ (recur (n.inc depth) bodyT)]
+ (wrap ( env bodyT+))))
+ ([#;UnivQ]
+ [#;ExQ])
+
+ (#;Sum _)
+ (let [cases (type;flatten-variant currentT)
+ actual-size (list;size cases)
+ boundary (n.dec expected-size)]
+ (cond (or (n.= expected-size actual-size)
+ (and (n.> expected-size actual-size)
+ (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)))))
+
+ #;None
+ (&common;variant-out-of-bounds-error type expected-size tag))
+
+ (n.< expected-size actual-size)
+ (&;throw Smaller-Variant-Than-Expected
+ (format "Expected: " (%i (nat-to-int expected-size)) "\n"
+ " Actual: " (%i (nat-to-int actual-size))))
+
+ (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))))))
+
+ ## else
+ (&common;variant-out-of-bounds-error type expected-size tag)))
- _
- (&;fail (format "Not a variant type: " (%type type)))))
+ _
+ (&;fail (format "Not a variant type: " (%type type))))))
diff --git a/new-luxc/source/luxc/analyser/reference.lux b/new-luxc/source/luxc/analyser/reference.lux
index 9756a1b9c..4a2f6dbc5 100644
--- a/new-luxc/source/luxc/analyser/reference.lux
+++ b/new-luxc/source/luxc/analyser/reference.lux
@@ -1,8 +1,8 @@
(;module:
lux
(lux (control monad)
- [meta #+ Monad]
- (meta (type ["TC" check])))
+ [meta]
+ (meta (type ["tc" check])))
(luxc ["&" base]
(lang ["la" analysis #+ Analysis])
["&;" scope]))
@@ -10,23 +10,23 @@
## [Analysers]
(def: (analyse-definition def-name)
(-> Ident (Meta Analysis))
- (do Monad
- [actual (meta;find-def-type def-name)
- expected meta;expected-type
+ (do meta;Monad
+ [actualT (meta;find-def-type def-name)
+ expectedT meta;expected-type
_ (&;with-type-env
- (TC;check expected actual))]
+ (tc;check expectedT actualT))]
(wrap (#la;Definition def-name))))
(def: (analyse-variable var-name)
(-> Text (Meta (Maybe Analysis)))
- (do Monad
+ (do meta;Monad
[?var (&scope;find var-name)]
(case ?var
- (#;Some [actual ref])
+ (#;Some [actualT ref])
(do @
- [expected meta;expected-type
+ [expectedT meta;expected-type
_ (&;with-type-env
- (TC;check expected actual))]
+ (tc;check expectedT actualT))]
(wrap (#;Some (#la;Variable ref))))
#;None
@@ -36,7 +36,7 @@
(-> Ident (Meta Analysis))
(case reference
["" simple-name]
- (do Monad
+ (do meta;Monad
[?var (analyse-variable simple-name)]
(case ?var
(#;Some analysis)
diff --git a/new-luxc/source/luxc/analyser/structure.lux b/new-luxc/source/luxc/analyser/structure.lux
index 8c1f7118c..7720202d8 100644
--- a/new-luxc/source/luxc/analyser/structure.lux
+++ b/new-luxc/source/luxc/analyser/structure.lux
@@ -1,6 +1,7 @@
(;module:
lux
(lux (control [monad #+ do]
+ ["ex" exception #+ exception:]
pipe)
[function]
(concurrency ["A" atom])
@@ -23,13 +24,13 @@
(analyser ["&;" common]
["&;" inference])))
+(exception: #export Not-Variant-Type)
+(exception: #export Not-Tuple-Type)
+(exception: #export Cannot-Infer-Numeric-Tag)
+
(type: Type-Error
(-> Type Text))
-(def: (not-variant type)
- Type-Error
- (format "Invalid type for variant: " (%type type)))
-
(def: (not-quantified type)
Type-Error
(format "Not a quantified type: " (%type type)))
@@ -37,12 +38,14 @@
(def: #export (analyse-sum analyse tag valueC)
(-> &;Analyser Nat Code (Meta la;Analysis))
(do meta;Monad
- [expected meta;expected-type]
+ [expectedT meta;expected-type]
(&;with-stacked-errors
- (function [_] (not-variant expected))
- (case expected
+ (function [_] (Not-Variant-Type (format " Tag: " (%n tag) "\n"
+ "Value: " (%code valueC) "\n"
+ " Type: " (%type expectedT))))
+ (case expectedT
(#;Sum _)
- (let [flat (type;flatten-variant expected)
+ (let [flat (type;flatten-variant expectedT)
type-size (list;size flat)]
(case (list;nth tag flat)
(#;Some variant-type)
@@ -53,7 +56,7 @@
(wrap (la;sum tag type-size temp valueA)))
#;None
- (&common;variant-out-of-bounds-error expected type-size tag)))
+ (&common;variant-out-of-bounds-error expectedT type-size tag)))
(#;Named name unnamedT)
(&;with-expected-type unnamedT
@@ -65,26 +68,28 @@
(tc;bound? id))]
(if bound?
(do @
- [expected' (&;with-type-env
- (tc;read id))]
- (&;with-expected-type expected'
+ [expectedT' (&;with-type-env
+ (tc;read id))]
+ (&;with-expected-type expectedT'
(analyse-sum analyse tag valueC)))
## 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.
- (&;fail (not-variant expected))))
+ (&;throw Cannot-Infer-Numeric-Tag (format " Tag: " (%n tag) "\n"
+ "Value: " (%code valueC) "\n"
+ " Type: " (%type expectedT)))))
(#;UnivQ _)
(do @
[[var-id var] (&;with-type-env
tc;existential)]
- (&;with-expected-type (maybe;assume (type;apply (list var) expected))
+ (&;with-expected-type (maybe;assume (type;apply (list var) expectedT))
(analyse-sum analyse tag valueC)))
(#;ExQ _)
(&common;with-var
(function [[var-id var]]
- (&;with-expected-type (maybe;assume (type;apply (list var) expected))
+ (&;with-expected-type (maybe;assume (type;apply (list var) expectedT))
(analyse-sum analyse tag valueC))))
(#;Apply inputT funT)
@@ -97,15 +102,17 @@
(analyse-sum analyse tag valueC)))
_
- (&;fail "")))))
+ (&;throw Not-Variant-Type (format " Tag: " (%n tag) "\n"
+ "Value: " (%code valueC) "\n"
+ " Type: " (%type expectedT)))))))
(def: (analyse-typed-product analyse members)
(-> &;Analyser (List Code) (Meta la;Analysis))
(do meta;Monad
- [expected meta;expected-type]
- (loop [expected expected
+ [expectedT meta;expected-type]
+ (loop [expectedT expectedT
members members]
- (case [expected members]
+ (case [expectedT members]
## If the type and the code are still ongoing, match each
## sub-expression to its corresponding type.
[(#;Product leftT rightT) (#;Cons leftC rightC)]
@@ -150,10 +157,11 @@
(def: #export (analyse-product analyse membersC)
(-> &;Analyser (List Code) (Meta la;Analysis))
(do meta;Monad
- [expected meta;expected-type]
+ [expectedT meta;expected-type]
(&;with-stacked-errors
- (function [_] (format "Invalid type for tuple: " (%type expected)))
- (case expected
+ (function [_] (Not-Tuple-Type (format " Type: " (%type expectedT) "\n"
+ "Value: " (%code (` [(~@ membersC)])))))
+ (case expectedT
(#;Product _)
(analyse-typed-product analyse membersC)
@@ -167,16 +175,16 @@
(tc;bound? id))]
(if bound?
(do @
- [expected' (&;with-type-env
- (tc;read id))]
- (&;with-expected-type expected'
+ [expectedT' (&;with-type-env
+ (tc;read id))]
+ (&;with-expected-type expectedT'
(analyse-product analyse membersC)))
## Must do inference...
(do @
[membersTA (monad;map @ (|>. analyse &common;with-unknown-type)
membersC)
_ (&;with-type-env
- (tc;check expected
+ (tc;check expectedT
(type;tuple (list/map product;left membersTA))))]
(wrap (la;product (list/map product;right membersTA))))))
@@ -184,13 +192,13 @@
(do @
[[var-id var] (&;with-type-env
tc;existential)]
- (&;with-expected-type (maybe;assume (type;apply (list var) expected))
+ (&;with-expected-type (maybe;assume (type;apply (list var) expectedT))
(analyse-product analyse membersC)))
(#;ExQ _)
(&common;with-var
(function [[var-id var]]
- (&;with-expected-type (maybe;assume (type;apply (list var) expected))
+ (&;with-expected-type (maybe;assume (type;apply (list var) expectedT))
(analyse-product analyse membersC))))
(#;Apply inputT funT)
@@ -203,7 +211,8 @@
(analyse-product analyse membersC)))
_
- (&;fail "")
+ (&;throw Not-Tuple-Type (format " Type: " (%type expectedT) "\n"
+ "Value: " (%code (` [(~@ membersC)]))))
))))
(def: #export (analyse-tagged-sum analyse tag valueC)
@@ -216,7 +225,7 @@
(#;Var _)
(do @
[#let [case-size (list;size group)]
- inferenceT (&inference;variant-inference-type idx case-size variantT)
+ inferenceT (&inference;variant idx case-size variantT)
[inferredT valueA+] (&inference;apply-function analyse inferenceT (list valueC))
_ (&;with-type-env
(tc;check expectedT inferredT))
@@ -295,7 +304,7 @@
[members (normalize members)
[members recordT] (order members)
expectedT meta;expected-type
- inferenceT (&inference;record-inference-type recordT)
+ inferenceT (&inference;record recordT)
[inferredT membersA] (&inference;apply-function analyse inferenceT members)
_ (&;with-type-env
(tc;check expectedT inferredT))]
--
cgit v1.2.3