aboutsummaryrefslogtreecommitdiff
path: root/new-luxc
diff options
context:
space:
mode:
authorEduardo Julian2017-11-12 23:49:34 -0400
committerEduardo Julian2017-11-12 23:49:34 -0400
commitca297162d5416a8c7b8af5f27757900d82d3ad03 (patch)
treeec9e664f09d6c29d91e9ae6be5d3abb6ef0e7ca4 /new-luxc
parent63624fd6b7f9f2563898655472025020483d398f (diff)
- Fixed some bugs.
- Improved error reporting. - Optimized pattern-matching a bit.
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
7 files changed, 151 insertions, 133 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 "")])