aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2017-10-31 22:26:13 -0400
committerEduardo Julian2017-10-31 22:26:13 -0400
commit19c589edc2c1dd77550e26d4f5cf78ec772da337 (patch)
treed070c773c7bd5cec8d33caa1841fbe0e342ec563
parent6c753288a89eadb3f7d70a8844e466c48c809051 (diff)
- Migrated the format of analysis nodes from a custom data-type, to just Code nodes.
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/analyser.lux2
-rw-r--r--new-luxc/source/luxc/analyser/case.lux39
-rw-r--r--new-luxc/source/luxc/analyser/case/coverage.lux82
-rw-r--r--new-luxc/source/luxc/analyser/function.lux16
-rw-r--r--new-luxc/source/luxc/analyser/primitive.lux27
-rw-r--r--new-luxc/source/luxc/analyser/procedure/common.lux17
-rw-r--r--new-luxc/source/luxc/analyser/procedure/host.jvm.lux58
-rw-r--r--new-luxc/source/luxc/analyser/reference.lux10
-rw-r--r--new-luxc/source/luxc/analyser/structure.lux2
-rw-r--r--new-luxc/source/luxc/generator/expression.jvm.lux6
-rw-r--r--new-luxc/source/luxc/generator/function.jvm.lux26
-rw-r--r--new-luxc/source/luxc/generator/procedure/common.jvm.lux1
-rw-r--r--new-luxc/source/luxc/generator/procedure/host.jvm.lux1
-rw-r--r--new-luxc/source/luxc/generator/reference.jvm.lux7
-rw-r--r--new-luxc/source/luxc/lang/analysis.lux120
-rw-r--r--new-luxc/source/luxc/lang/synthesis.lux2
-rw-r--r--new-luxc/source/luxc/lang/variable.lux47
-rw-r--r--new-luxc/source/luxc/synthesizer.lux145
-rw-r--r--new-luxc/source/luxc/synthesizer/case.lux27
-rw-r--r--new-luxc/source/luxc/synthesizer/function.lux43
-rw-r--r--new-luxc/source/luxc/synthesizer/loop.lux14
-rw-r--r--new-luxc/source/luxc/synthesizer/structure.lux28
-rw-r--r--new-luxc/source/luxc/synthesizer/variable.lux44
-rw-r--r--new-luxc/test/test/luxc/analyser/function.lux12
-rw-r--r--new-luxc/test/test/luxc/analyser/primitive.lux51
-rw-r--r--new-luxc/test/test/luxc/analyser/reference.lux4
-rw-r--r--new-luxc/test/test/luxc/analyser/structure.lux48
-rw-r--r--new-luxc/test/test/luxc/analyser/type.lux16
-rw-r--r--new-luxc/test/test/luxc/generator/reference.lux5
-rw-r--r--new-luxc/test/test/luxc/synthesizer/case/special.lux36
-rw-r--r--new-luxc/test/test/luxc/synthesizer/common.lux33
-rw-r--r--new-luxc/test/test/luxc/synthesizer/function.lux42
-rw-r--r--new-luxc/test/test/luxc/synthesizer/loop.lux53
-rw-r--r--new-luxc/test/test/luxc/synthesizer/primitive.lux17
-rw-r--r--new-luxc/test/test/luxc/synthesizer/procedure.lux7
35 files changed, 523 insertions, 565 deletions
diff --git a/new-luxc/source/luxc/analyser.lux b/new-luxc/source/luxc/analyser.lux
index 04d8d58b7..a7b872de5 100644
--- a/new-luxc/source/luxc/analyser.lux
+++ b/new-luxc/source/luxc/analyser.lux
@@ -113,7 +113,7 @@
[[funcT =func] (&&common;with-unknown-type
(analyse func))]
(case =func
- (#la;Definition def-name)
+ [_ (#;Symbol def-name)]
(do @
[[def-type def-anns def-value] (meta;find-def def-name)]
(if (meta;macro? def-anns)
diff --git a/new-luxc/source/luxc/analyser/case.lux b/new-luxc/source/luxc/analyser/case.lux
index b17dbcbfd..29256865a 100644
--- a/new-luxc/source/luxc/analyser/case.lux
+++ b/new-luxc/source/luxc/analyser/case.lux
@@ -25,6 +25,7 @@
(exception: #export Cannot-Match-Type-With-Pattern)
(exception: #export Sum-Type-Has-No-Case)
(exception: #export Unrecognized-Pattern-Syntax)
+(exception: #export Cannot-Simplify-Type-For-Pattern-Matching)
(def: (pattern-error type pattern)
(-> Type Code Text)
@@ -51,7 +52,7 @@
[type' (&;with-type-env
(tc;read id))]
(simplify-case-type type'))
- (&;fail (format "Cannot simplify type for pattern-matching: " (%type type)))))
+ (&;throw Cannot-Simplify-Type-For-Pattern-Matching (%type type))))
(#;Named name unnamedT)
(simplify-case-type unnamedT)
@@ -98,26 +99,26 @@
[outputA (&scope;with-local [name inputT]
next)
idx &scope;next-local]
- (wrap [(#la;BindP idx) outputA])))
+ (wrap [(` ("lux case bind" (~ (code;nat idx)))) outputA])))
[cursor (#;Symbol ident)]
(&;with-cursor cursor
(&;fail (format "Symbols must be unqualified inside patterns: " (%ident ident))))
- (^template [<type> <code-tag> <pattern-tag>]
+ (^template [<type> <code-tag>]
[cursor (<code-tag> test)]
(&;with-cursor cursor
(do meta;Monad<Meta>
[_ (&;with-type-env
(tc;check inputT <type>))
outputA next]
- (wrap [(<pattern-tag> test) outputA]))))
- ([Bool #;Bool #la;BoolP]
- [Nat #;Nat #la;NatP]
- [Int #;Int #la;IntP]
- [Deg #;Deg #la;DegP]
- [Frac #;Frac #la;FracP]
- [Text #;Text #la;TextP])
+ (wrap [pattern outputA]))))
+ ([Bool #;Bool]
+ [Nat #;Nat]
+ [Int #;Int]
+ [Deg #;Deg]
+ [Frac #;Frac]
+ [Text #;Text])
(^ [cursor (#;Tuple (list))])
(&;with-cursor cursor
@@ -125,7 +126,7 @@
[_ (&;with-type-env
(tc;check inputT Unit))
outputA next]
- (wrap [(#la;TupleP (list)) outputA])))
+ (wrap [(` ("lux case tuple" [])) outputA])))
(^ [cursor (#;Tuple (list singleton))])
(analyse-pattern #;None inputT singleton next)
@@ -165,7 +166,8 @@
[nextA next]
(wrap [(list) nextA]))
matches)]
- (wrap [(#la;TupleP memberP+) thenA])))
+ (wrap [(` ("lux case tuple" [(~@ memberP+)]))
+ thenA])))
_
(&;fail (pattern-error inputT pattern))
@@ -202,11 +204,11 @@
(type;variant (list;drop (n.dec num-cases) flat-sum))
(` [(~@ values)])
next)]
- (wrap [(#la;VariantP idx num-cases testP)
+ (wrap [(` ("lux case variant" (~ (code;nat idx)) (~ (code;nat num-cases)) (~ testP)))
nextA]))
(do meta;Monad<Meta>
[[testP nextA] (analyse-pattern #;None case-type (` [(~@ values)]) next)]
- (wrap [(#la;VariantP idx num-cases testP)
+ (wrap [(` ("lux case variant" (~ (code;nat idx)) (~ (code;nat num-cases)) (~ testP)))
nextA])))
_
@@ -245,10 +247,9 @@
(function [[patternT bodyT]]
(analyse-pattern #;None inputT patternT (analyse bodyT)))
branchesT)
- _ (case (monad;fold e;Monad<Error>
- &&coverage;merge
- (|> outputH product;left &&coverage;determine)
- (list/map (|>. product;left &&coverage;determine) outputT))
+ outputHC (|> outputH product;left &&coverage;determine)
+ outputTC (monad;map @ (|>. product;left &&coverage;determine) outputT)
+ _ (case (monad;fold e;Monad<Error> &&coverage;merge outputHC outputTC)
(#e;Success coverage)
(if (&&coverage;exhaustive? coverage)
(wrap [])
@@ -256,4 +257,4 @@
(#e;Error error)
(&;fail error))]
- (wrap (#la;Case inputA (#;Cons outputH outputT))))))
+ (wrap (` ("lux case" (~ inputA) (~ (code;record (list& outputH outputT)))))))))
diff --git a/new-luxc/source/luxc/analyser/case/coverage.lux b/new-luxc/source/luxc/analyser/case/coverage.lux
index cb066a2bf..554aea1a8 100644
--- a/new-luxc/source/luxc/analyser/case/coverage.lux
+++ b/new-luxc/source/luxc/analyser/case/coverage.lux
@@ -1,13 +1,17 @@
(;module:
lux
(lux (control [monad #+ do]
+ ["ex" exception #+ exception:]
eq)
- (data [bool "B/" Eq<Bool>]
+ (data [bool "bool/" Eq<Bool>]
[number]
["e" error "error/" Monad<Error>]
- (coll [list "L/" Fold<List>]
- ["D" dict])))
- (luxc (lang ["la" analysis])))
+ text/format
+ (coll [list "list/" Fold<List>]
+ [dict #+ Dict]))
+ [meta "meta/" Monad<Meta>])
+ (luxc ["&" base]
+ (lang ["la" analysis])))
## The coverage of a pattern-matching expression summarizes how well
## all the possible values of an input are being covered by the
@@ -24,7 +28,7 @@
(type: #export #rec Coverage
#Partial
(#Bool Bool)
- (#Variant Nat (D;Dict Nat Coverage))
+ (#Variant Nat (Dict Nat Coverage))
(#Seq Coverage Coverage)
(#Alt Coverage Coverage)
#Exhaustive)
@@ -38,52 +42,60 @@
_
false))
+(exception: #export Unknown-Pattern)
+
(def: #export (determine pattern)
- (-> la;Pattern Coverage)
+ (-> la;Pattern (Meta Coverage))
(case pattern
## Binding amounts to exhaustive coverage because any value can be
## matched that way.
## Unit [] amounts to exhaustive coverage because there is only one
## possible value, so matching against it covers all cases.
- (^or (#la;BindP _) (^ (#la;TupleP (list))))
- #Exhaustive
+ (^or (^code ("lux case bind" (~ _))) (^code ("lux case tuple" [])))
+ (meta/wrap #Exhaustive)
- (^ (#la;TupleP (list singleton)))
+ (^code ("lux case tuple" [(~ singleton)]))
(determine singleton)
## Primitive patterns always have partial coverage because there
## are too many possibilities as far as values go.
- (^or (#la;NatP _) (#la;IntP _) (#la;DegP _)
- (#la;FracP _) (#la;TextP _))
- #Partial
+ (^or [_ (#;Nat _)] [_ (#;Int _)] [_ (#;Deg _)]
+ [_ (#;Frac _)] [_ (#;Text _)])
+ (meta/wrap #Partial)
## Bools are the exception, since there is only "true" and
## "false", which means it is possible for boolean
## pattern-matching to become exhaustive if complementary parts meet.
- (#la;BoolP value)
- (#Bool value)
+ [_ (#;Bool value)]
+ (meta/wrap (#Bool value))
## Tuple patterns can be exhaustive if there is exhaustiveness for all of
## their sub-patterns.
- (#la;TupleP subs)
+ (^code ("lux case tuple" [(~@ subs)]))
(loop [subs subs]
(case subs
#;Nil
- #Exhaustive
+ (meta/wrap #Exhaustive)
(#;Cons sub subs')
- (let [post (recur subs')]
+ (do meta;Monad<Meta>
+ [pre (determine sub)
+ post (recur subs')]
(if (exhaustive? post)
- (determine sub)
- (#Seq (determine sub)
- post)))))
+ (wrap pre)
+ (wrap (#Seq pre post))))))
## Variant patterns can be shown to be exhaustive if all the possible
## cases are handled exhaustively.
- (#la;VariantP tag-id num-tags sub)
- (#Variant num-tags
- (|> (D;new number;Hash<Nat>)
- (D;put tag-id (determine sub))))))
+ (^code ("lux case variant" (~ [_ (#;Nat tag-id)]) (~ [_ (#;Nat num-tags)]) (~ sub)))
+ (do meta;Monad<Meta>
+ [=sub (determine sub)]
+ (wrap (#Variant num-tags
+ (|> (dict;new number;Hash<Nat>)
+ (dict;put tag-id =sub)))))
+
+ _
+ (&;throw Unknown-Pattern (%code pattern))))
(def: (xor left right)
(-> Bool Bool Bool)
@@ -116,11 +128,11 @@
true
[(#Bool sideR) (#Bool sideS)]
- (B/= sideR sideS)
+ (bool/= sideR sideS)
[(#Variant allR casesR) (#Variant allS casesS)]
(and (n.= allR allS)
- (:: (D;Eq<Dict> =) = casesR casesS))
+ (:: (dict;Eq<Dict> =) = casesR casesS))
[(#Seq leftR rightR) (#Seq leftS rightS)]
(and (= leftR leftS)
@@ -166,23 +178,23 @@
(cond (not (n.= allSF allA))
(e;fail "Variants do not match.")
- (:: (D;Eq<Dict> Eq<Coverage>) = casesSF casesA)
+ (:: (dict;Eq<Dict> Eq<Coverage>) = casesSF casesA)
redundant-pattern
## else
(do e;Monad<Error>
[casesM (monad;fold @
(function [[tagA coverageA] casesSF']
- (case (D;get tagA casesSF')
+ (case (dict;get tagA casesSF')
(#;Some coverageSF)
(do @
[coverageM (merge coverageA coverageSF)]
- (wrap (D;put tagA coverageM casesSF')))
+ (wrap (dict;put tagA coverageM casesSF')))
#;None
- (wrap (D;put tagA coverageA casesSF'))))
- casesSF (D;entries casesA))]
- (wrap (if (let [case-coverages (D;values casesM)]
+ (wrap (dict;put tagA coverageA casesSF'))))
+ casesSF (dict;entries casesA))]
+ (wrap (if (let [case-coverages (dict;values casesM)]
(and (n.= allSF (list;size case-coverages))
(list;every? exhaustive? case-coverages)))
#Exhaustive
@@ -272,9 +284,9 @@
#;None
(case (list;reverse possibilities)
(#;Cons last prevs)
- (wrap (L/fold (function [left right] (#Alt left right))
- last
- prevs))
+ (wrap (list/fold (function [left right] (#Alt left right))
+ last
+ prevs))
#;Nil
(undefined)))))
diff --git a/new-luxc/source/luxc/analyser/function.lux b/new-luxc/source/luxc/analyser/function.lux
index 55896480e..3d2da6326 100644
--- a/new-luxc/source/luxc/analyser/function.lux
+++ b/new-luxc/source/luxc/analyser/function.lux
@@ -6,11 +6,13 @@
[text]
text/format
(coll [list "list/" Fold<List> Monoid<List> Monad<List>]))
- [meta #+ Monad<Meta>]
- (meta [type]
+ [meta]
+ (meta [code]
+ [type]
(type ["tc" check])))
(luxc ["&" base]
- (lang ["la" analysis #+ Analysis])
+ (lang ["la" analysis #+ Analysis]
+ [";L" variable #+ Variable])
["&;" scope]
(analyser ["&;" common]
["&;" inference])))
@@ -21,7 +23,7 @@
## [Analysers]
(def: #export (analyse-function analyse func-name arg-name body)
(-> &;Analyser Text Text Code (Meta Analysis))
- (do Monad<Meta>
+ (do meta;Monad<Meta>
[functionT meta;expected-type]
(loop [expectedT functionT]
(&;with-stacked-errors
@@ -80,7 +82,9 @@
))))))
(#;Function inputT outputT)
- (<| (:: @ map (|>. #la;Function))
+ (<| (:: @ map (function [[scope bodyA]]
+ (` ("lux function" [(~@ (list/map code;int (variableL;environment scope)))]
+ (~ bodyA)))))
&;with-scope
## Functions have access not only to their argument, but
## also to themselves, through a local variable.
@@ -99,7 +103,7 @@
(function [_]
(Cannot-Apply-Function (format " Function: " (%type funcT) "\n"
"Arguments: " (|> args (list/map %code) (text;join-with " ")))))
- (do Monad<Meta>
+ (do meta;Monad<Meta>
[expected meta;expected-type
[applyT argsA] (&inference;apply-function analyse funcT args)
_ (&;with-type-env
diff --git a/new-luxc/source/luxc/analyser/primitive.lux b/new-luxc/source/luxc/analyser/primitive.lux
index 0023e43e0..c7f7243fd 100644
--- a/new-luxc/source/luxc/analyser/primitive.lux
+++ b/new-luxc/source/luxc/analyser/primitive.lux
@@ -1,8 +1,9 @@
(;module:
lux
(lux (control monad)
- [meta #+ Monad<Meta>]
- (meta (type ["TC" check])))
+ [meta]
+ (meta [code]
+ (type ["tc" check])))
(luxc ["&" base]
(lang ["la" analysis #+ Analysis])))
@@ -10,24 +11,24 @@
(do-template [<name> <type> <tag>]
[(def: #export (<name> value)
(-> <type> (Meta Analysis))
- (do Monad<Meta>
+ (do meta;Monad<Meta>
[expected meta;expected-type
_ (&;with-type-env
- (TC;check expected <type>))]
+ (tc;check expected <type>))]
(wrap (<tag> value))))]
- [analyse-bool Bool #la;Bool]
- [analyse-nat Nat #la;Nat]
- [analyse-int Int #la;Int]
- [analyse-deg Deg #la;Deg]
- [analyse-frac Frac #la;Frac]
- [analyse-text Text #la;Text]
+ [analyse-bool Bool code;bool]
+ [analyse-nat Nat code;nat]
+ [analyse-int Int code;int]
+ [analyse-deg Deg code;deg]
+ [analyse-frac Frac code;frac]
+ [analyse-text Text code;text]
)
(def: #export analyse-unit
(Meta Analysis)
- (do Monad<Meta>
+ (do meta;Monad<Meta>
[expected meta;expected-type
_ (&;with-type-env
- (TC;check expected Unit))]
- (wrap #la;Unit)))
+ (tc;check expected Unit))]
+ (wrap (` []))))
diff --git a/new-luxc/source/luxc/analyser/procedure/common.lux b/new-luxc/source/luxc/analyser/procedure/common.lux
index f64c537cb..0fad41958 100644
--- a/new-luxc/source/luxc/analyser/procedure/common.lux
+++ b/new-luxc/source/luxc/analyser/procedure/common.lux
@@ -7,8 +7,9 @@
(coll [list "list/" Functor<List>]
[array]
[dict #+ Dict]))
- [meta #+ Monad<Meta>]
- (meta (type ["tc" check]))
+ [meta]
+ (meta [code]
+ (type ["tc" check]))
[io])
(luxc ["&" base]
(lang ["la" analysis])
@@ -48,7 +49,7 @@
(function [analyse eval args]
(let [num-actual (list;size args)]
(if (n.= num-expected num-actual)
- (do Monad<Meta>
+ (do meta;Monad<Meta>
[argsA (monad;map @
(function [[argT argC]]
(&;with-expected-type argT
@@ -57,7 +58,7 @@
expected meta;expected-type
_ (&;with-type-env
(tc;check expected output-type))]
- (wrap (#la;Procedure proc argsA)))
+ (wrap (la;procedure proc argsA)))
(&;fail (wrong-arity proc num-expected num-actual)))))))
(def: #export (nullary valueT proc)
@@ -95,7 +96,7 @@
(function [[var-id varT]]
(case args
(^ (list opC))
- (do Monad<Meta>
+ (do meta;Monad<Meta>
[opA (&;with-expected-type (type (io;IO varT))
(analyse opC))
outputT (&;with-type-env
@@ -103,7 +104,7 @@
expected meta;expected-type
_ (&;with-type-env
(tc;check expected outputT))]
- (wrap (#la;Procedure proc (list opA))))
+ (wrap (la;procedure proc (list opA))))
_
(&;fail (wrong-arity proc +1 (list;size args))))))))
@@ -352,7 +353,7 @@
(function [[var-id varT]]
(case args
(^ (list initC))
- (do Monad<Meta>
+ (do meta;Monad<Meta>
[initA (&;with-expected-type varT
(analyse initC))
outputT (&;with-type-env
@@ -360,7 +361,7 @@
expected meta;expected-type
_ (&;with-type-env
(tc;check expected outputT))]
- (wrap (#la;Procedure proc (list initA))))
+ (wrap (la;procedure proc (list initA))))
_
(&;fail (wrong-arity proc +1 (list;size args))))))))
diff --git a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
index 4db7b4dda..015379a1b 100644
--- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
@@ -15,7 +15,8 @@
[array]
[dict #+ Dict]))
[meta "meta/" Monad<Meta>]
- (meta ["s" syntax]
+ (meta [code]
+ ["s" syntax]
[type]
(type ["tc" check]))
[host])
@@ -156,7 +157,7 @@
[arrayA (&;with-expected-type (type (Array varT))
(analyse arrayC))
_ (&;infer Nat)]
- (wrap (#la;Procedure proc (list arrayA))))
+ (wrap (la;procedure proc (list arrayA))))
_
(&;fail (@;wrong-arity proc +1 (list;size args))))))))
@@ -196,7 +197,7 @@
(&;fail (invalid-array-type expectedT)))))
_ (&;assert "Must have at least 1 level of nesting in array type."
(n.> +0 level))]
- (wrap (#la;Procedure proc (list (#la;Nat (n.dec level)) (#la;Text elem-class) lengthA))))
+ (wrap (la;procedure proc (list (code;nat (n.dec level)) (code;text elem-class) lengthA))))
_
(&;fail (@;wrong-arity proc +1 (list;size args))))))
@@ -275,7 +276,7 @@
idxA (&;with-expected-type Nat
(analyse idxC))
_ (&;infer elemT)]
- (wrap (#la;Procedure proc (list (#la;Text elem-class) idxA arrayA))))
+ (wrap (la;procedure proc (list (code;text elem-class) idxA arrayA))))
_
(&;fail (@;wrong-arity proc +2 (list;size args))))))))
@@ -298,7 +299,7 @@
valueA (&;with-expected-type valueT
(analyse valueC))
_ (&;infer (type (Array elemT)))]
- (wrap (#la;Procedure proc (list (#la;Text elem-class) idxA valueA arrayA))))
+ (wrap (la;procedure proc (list (code;text elem-class) idxA valueA arrayA))))
_
(&;fail (@;wrong-arity proc +3 (list;size args))))))))
@@ -321,7 +322,7 @@
(do meta;Monad<Meta>
[expectedT meta;expected-type
_ (check-object expectedT)]
- (wrap (#la;Procedure proc (list))))
+ (wrap (la;procedure proc (list))))
_
(&;fail (@;wrong-arity proc +0 (list;size args))))))
@@ -340,7 +341,7 @@
(tc;read var-id))
_ (check-object objectT)
_ (&;infer Bool)]
- (wrap (#la;Procedure proc (list objectA))))
+ (wrap (la;procedure proc (list objectA))))
_
(&;fail (@;wrong-arity proc +1 (list;size args))))))))
@@ -359,7 +360,7 @@
(tc;read var-id))
_ (check-object monitorT)
exprA (analyse exprC)]
- (wrap (#la;Procedure proc (list monitorA exprA))))
+ (wrap (la;procedure proc (list monitorA exprA))))
_
(&;fail (@;wrong-arity proc +2 (list;size args))))))))
@@ -465,7 +466,7 @@
(wrap [])
(&;throw Not-Throwable exception-class)))
_ (&;infer Bottom)]
- (wrap (#la;Procedure proc (list exceptionA))))
+ (wrap (la;procedure proc (list exceptionA))))
_
(&;fail (@;wrong-arity proc +1 (list;size args))))))))
@@ -480,7 +481,7 @@
(do meta;Monad<Meta>
[_ (load-class class)
_ (&;infer (#;Primitive "java.lang.Class" (list (#;Primitive class (list)))))]
- (wrap (#la;Procedure proc (list (#la;Text class)))))
+ (wrap (la;procedure proc (list (code;text class)))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))
@@ -509,7 +510,7 @@
(if ?
(do @
[_ (&;infer Bool)]
- (wrap (#la;Procedure proc (list (#la;Text class)))))
+ (wrap (la;procedure proc (list (code;text class)))))
(&;throw Cannot-Be-Instance (format object-class " !<= " class))))
_
@@ -801,7 +802,8 @@
(do meta;Monad<Meta>
[[fieldT final?] (static-field class field)
[unboxed castT] (infer-out fieldT)]
- (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed)))))
+ (wrap (la;procedure proc (list (code;text class) (code;text field)
+ (code;text unboxed)))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))
@@ -824,7 +826,8 @@
_ (&;with-type-env
(tc;check fieldT valueT))
_ (&;infer Unit)]
- (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed) valueA))))
+ (wrap (la;procedure proc (list (code;text class) (code;text field)
+ (code;text unboxed) valueA))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))
@@ -843,7 +846,8 @@
[[objectT objectA] (analyse-object class analyse objectC)
[fieldT final?] (virtual-field class field objectT)
[unboxed castT] (infer-out fieldT)]
- (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed) objectA))))
+ (wrap (la;procedure proc (list (code;text class) (code;text field)
+ (code;text unboxed) objectA))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))
@@ -867,7 +871,7 @@
_ (&;with-type-env
(tc;check fieldT valueT))
_ (&;infer objectT)]
- (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed) valueA objectA))))
+ (wrap (la;procedure proc (list (code;text class) (code;text field) (code;text unboxed) valueA objectA))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))
@@ -1089,8 +1093,9 @@
(def: (decorate-inputs typesT inputsA)
(-> (List Text) (List la;Analysis) (List la;Analysis))
(|> inputsA
- (list;zip2 (list/map (|>. #la;Text) typesT))
- (list/map (|>. #la;Product))))
+ (list;zip2 (list/map code;text typesT))
+ (list/map (function [[type value]]
+ (la;product (list type value))))))
(def: (sub-type-analyser analyse)
(-> &;Analyser &;Analyser)
@@ -1113,8 +1118,8 @@
[methodT exceptionsT] (methods class method #Static argsT)
[outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list/map product;right argsTC))
[unboxed castT] (infer-out outputT)]
- (wrap (#la;Procedure proc (list& (#la;Text class) (#la;Text method)
- (#la;Text unboxed) (decorate-inputs argsT argsA)))))
+ (wrap (la;procedure proc (list& (code;text class) (code;text method)
+ (code;text unboxed) (decorate-inputs argsT argsA)))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))))
@@ -1136,8 +1141,8 @@
_
(undefined))]
[unboxed castT] (infer-out outputT)]
- (wrap (#la;Procedure proc (list& (#la;Text class) (#la;Text method)
- (#la;Text unboxed) objectA (decorate-inputs argsT argsA)))))
+ (wrap (la;procedure proc (list& (code;text class) (code;text method)
+ (code;text unboxed) objectA (decorate-inputs argsT argsA)))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))))
@@ -1153,8 +1158,8 @@
[methodT exceptionsT] (methods class method #Special argsT)
[outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC)))
[unboxed castT] (infer-out outputT)]
- (wrap (#la;Procedure proc (list& (#la;Text class) (#la;Text method)
- (#la;Text unboxed) (decorate-inputs argsT argsA)))))
+ (wrap (la;procedure proc (list& (code;text class) (code;text method)
+ (code;text unboxed) (decorate-inputs argsT argsA)))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))))
@@ -1175,8 +1180,9 @@
[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)))
[unboxed castT] (infer-out outputT)]
- (wrap (#la;Procedure proc (list& (#la;Text class-name) (#la;Text method)
- (#la;Text unboxed) (decorate-inputs argsT argsA)))))
+ (wrap (la;procedure proc
+ (list& (code;text class-name) (code;text method) (code;text unboxed)
+ (decorate-inputs argsT argsA)))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))))
@@ -1192,7 +1198,7 @@
[methodT exceptionsT] (constructor-methods class argsT)
[outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list/map product;right argsTC))
[unboxed castT] (infer-out outputT)]
- (wrap (#la;Procedure proc (list& (#la;Text class) (decorate-inputs argsT argsA)))))
+ (wrap (la;procedure proc (list& (code;text class) (decorate-inputs argsT argsA)))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))))
diff --git a/new-luxc/source/luxc/analyser/reference.lux b/new-luxc/source/luxc/analyser/reference.lux
index 4a2f6dbc5..5bc1f96c9 100644
--- a/new-luxc/source/luxc/analyser/reference.lux
+++ b/new-luxc/source/luxc/analyser/reference.lux
@@ -2,9 +2,11 @@
lux
(lux (control monad)
[meta]
- (meta (type ["tc" check])))
+ (meta [code]
+ (type ["tc" check])))
(luxc ["&" base]
- (lang ["la" analysis #+ Analysis])
+ (lang ["la" analysis #+ Analysis]
+ [";L" variable #+ Variable])
["&;" scope]))
## [Analysers]
@@ -15,7 +17,7 @@
expectedT meta;expected-type
_ (&;with-type-env
(tc;check expectedT actualT))]
- (wrap (#la;Definition def-name))))
+ (wrap (code;symbol def-name))))
(def: (analyse-variable var-name)
(-> Text (Meta (Maybe Analysis)))
@@ -27,7 +29,7 @@
[expectedT meta;expected-type
_ (&;with-type-env
(tc;check expectedT actualT))]
- (wrap (#;Some (#la;Variable ref))))
+ (wrap (#;Some (` ((~ (code;int (variableL;from-ref ref))))))))
#;None
(wrap #;None))))
diff --git a/new-luxc/source/luxc/analyser/structure.lux b/new-luxc/source/luxc/analyser/structure.lux
index 7720202d8..d523065ea 100644
--- a/new-luxc/source/luxc/analyser/structure.lux
+++ b/new-luxc/source/luxc/analyser/structure.lux
@@ -120,7 +120,7 @@
[leftA (&;with-expected-type leftT
(analyse leftC))
rightA (recur rightT rightC)]
- (wrap (#la;Product leftA rightA)))
+ (wrap (` [(~ leftA) (~ rightA)])))
## If the tuple runs out, whatever expression is the last gets
## matched to the remaining type.
diff --git a/new-luxc/source/luxc/generator/expression.jvm.lux b/new-luxc/source/luxc/generator/expression.jvm.lux
index 624070145..5eb8d7c47 100644
--- a/new-luxc/source/luxc/generator/expression.jvm.lux
+++ b/new-luxc/source/luxc/generator/expression.jvm.lux
@@ -9,10 +9,10 @@
(meta ["s" syntax]))
(luxc ["&" base]
(host ["$" jvm])
- (lang ["ls" synthesis])
+ (lang ["ls" synthesis]
+ [";L" variable #+ Variable Register])
["&;" analyser]
["&;" synthesizer]
- (synthesizer [";S" function])
(generator ["&;" common]
["&;" primitive]
["&;" structure]
@@ -50,7 +50,7 @@
(&structure;generate-tuple generate members)
(^ [_ (#;Form (list [_ (#;Int var)]))])
- (if (functionS;captured? var)
+ (if (variableL;captured? var)
(&reference;generate-captured var)
(&reference;generate-variable var))
diff --git a/new-luxc/source/luxc/generator/function.jvm.lux b/new-luxc/source/luxc/generator/function.jvm.lux
index 1b0939856..ed90d3aa2 100644
--- a/new-luxc/source/luxc/generator/function.jvm.lux
+++ b/new-luxc/source/luxc/generator/function.jvm.lux
@@ -11,10 +11,10 @@
["$d" def]
["$i" inst]))
(lang ["la" analysis]
- ["ls" synthesis])
+ ["ls" synthesis]
+ [";L" variable #+ Variable])
["&;" analyser]
["&;" synthesizer]
- (synthesizer [function])
(generator ["&;" common]
["&;" runtime])))
@@ -40,11 +40,11 @@
($t;method (list) (#;Some ($t;class class (list))) (list)))
(def: (captured-args env)
- (-> (List ls;Variable) (List $;Type))
+ (-> (List Variable) (List $;Type))
(list;repeat (list;size env) $Object))
(def: (init-method env arity)
- (-> (List ls;Variable) ls;Arity $;Method)
+ (-> (List Variable) ls;Arity $;Method)
(if (poly-arg? arity)
($t;method (list;concat (list (captured-args env)
(list $t;int)
@@ -95,7 +95,7 @@
$i;fuse))
(def: (with-captured env)
- (-> (List ls;Variable) $;Def)
+ (-> (List Variable) $;Def)
(|> (list;enumerate env)
(list/map (function [[env-idx env-source]]
($d;field #$;Private $;finalF (captured env-idx) $Object)))
@@ -111,11 +111,11 @@
id))
(def: (instance class arity env)
- (-> Text ls;Arity (List ls;Variable) $;Inst)
+ (-> Text ls;Arity (List Variable) $;Inst)
(let [captureI (|> env
(list/map (function [source]
- (if (function;captured? source)
- ($i;GETFIELD class (captured (function;captured-idx source)) $Object)
+ (if (variableL;captured? source)
+ ($i;GETFIELD class (captured (variableL;captured-register source)) $Object)
($i;ALOAD (int-to-nat source)))))
$i;fuse)
argsI (if (poly-arg? arity)
@@ -130,7 +130,7 @@
($i;INVOKESPECIAL class "<init>" (init-method env arity) false))))
(def: (with-reset class arity env)
- (-> Text ls;Arity (List ls;Variable) $;Def)
+ (-> Text ls;Arity (List Variable) $;Def)
($d;method #$;Public $;noneM "reset" (reset-method class)
(if (poly-arg? arity)
(let [env-size (list;size env)
@@ -173,7 +173,7 @@
($i;INVOKESPECIAL hostL;function-class "<init>" function-init-method false))))
(def: (with-init class env arity)
- (-> Text (List ls;Variable) ls;Arity $;Def)
+ (-> Text (List Variable) ls;Arity $;Def)
(let [env-size (list;size env)
offset-partial (: (-> Nat Nat)
(|>. n.inc (n.+ env-size)))
@@ -202,7 +202,7 @@
$i;RETURN))))
(def: (with-apply class env function-arity @begin bodyI apply-arity)
- (-> Text (List ls;Variable) ls;Arity $;Label $;Inst ls;Arity
+ (-> Text (List Variable) ls;Arity $;Label $;Inst ls;Arity
$;Def)
(let [num-partials (n.dec function-arity)
@default ($;new-label [])
@@ -270,7 +270,7 @@
(def: #export (with-function generate class env arity body)
(-> (-> ls;Synthesis (Meta $;Inst))
- Text (List ls;Variable) ls;Arity ls;Synthesis
+ Text (List Variable) ls;Arity ls;Synthesis
(Meta [$;Def $;Inst]))
(do meta;Monad<Meta>
[@begin $i;make-label
@@ -299,7 +299,7 @@
(def: #export (generate-function generate env arity body)
(-> (-> ls;Synthesis (Meta $;Inst))
- (List ls;Variable) ls;Arity ls;Synthesis
+ (List Variable) ls;Arity ls;Synthesis
(Meta $;Inst))
(do meta;Monad<Meta>
[function-class (:: @ map %code (meta;gensym "function"))
diff --git a/new-luxc/source/luxc/generator/procedure/common.jvm.lux b/new-luxc/source/luxc/generator/procedure/common.jvm.lux
index d94ded890..a61b7f0fe 100644
--- a/new-luxc/source/luxc/generator/procedure/common.jvm.lux
+++ b/new-luxc/source/luxc/generator/procedure/common.jvm.lux
@@ -19,7 +19,6 @@
["ls" synthesis])
["&;" analyser]
["&;" synthesizer]
- (synthesizer [function])
(generator ["&;" common]
["&;" runtime])))
diff --git a/new-luxc/source/luxc/generator/procedure/host.jvm.lux b/new-luxc/source/luxc/generator/procedure/host.jvm.lux
index 5fb779d41..bc57d6a2b 100644
--- a/new-luxc/source/luxc/generator/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/generator/procedure/host.jvm.lux
@@ -25,7 +25,6 @@
["&;" analyser]
(analyser (procedure ["&;" host]))
["&;" synthesizer]
- (synthesizer [function])
(generator ["&;" common]
["&;" runtime]))
["@" ../common])
diff --git a/new-luxc/source/luxc/generator/reference.jvm.lux b/new-luxc/source/luxc/generator/reference.jvm.lux
index 3c8cbc552..9af511167 100644
--- a/new-luxc/source/luxc/generator/reference.jvm.lux
+++ b/new-luxc/source/luxc/generator/reference.jvm.lux
@@ -7,12 +7,13 @@
(host ["$" jvm]
(jvm ["$t" type]
["$i" inst]))
- (lang ["ls" synthesis])
+ (lang ["ls" synthesis]
+ [";L" variable #+ Variable])
(generator [";G" common]
[";G" function])))
(def: #export (generate-captured variable)
- (-> ls;Variable (Meta $;Inst))
+ (-> Variable (Meta $;Inst))
(do meta;Monad<Meta>
[function-class commonG;function]
(wrap (|>. ($i;ALOAD +0)
@@ -21,7 +22,7 @@
commonG;$Object)))))
(def: #export (generate-variable variable)
- (-> ls;Variable (Meta $;Inst))
+ (-> Variable (Meta $;Inst))
(meta/wrap ($i;ALOAD (int-to-nat variable))))
(def: #export (generate-definition [def-module def-name])
diff --git a/new-luxc/source/luxc/lang/analysis.lux b/new-luxc/source/luxc/lang/analysis.lux
index 7a4ae37ac..03e4c867f 100644
--- a/new-luxc/source/luxc/lang/analysis.lux
+++ b/new-luxc/source/luxc/lang/analysis.lux
@@ -1,35 +1,13 @@
(;module:
lux
(lux [function]
- (data (coll [list "L/" Fold<List>]))))
-
-(type: #export #rec Pattern
- (#BoolP Bool)
- (#NatP Nat)
- (#IntP Int)
- (#DegP Deg)
- (#FracP Frac)
- (#TextP Text)
- (#TupleP (List Pattern))
- (#VariantP Nat Nat Pattern)
- (#BindP Nat))
-
-(type: #export #rec Analysis
- #Unit
- (#Bool Bool)
- (#Nat Nat)
- (#Int Int)
- (#Deg Deg)
- (#Frac Frac)
- (#Text Text)
- (#Sum (Either Analysis Analysis))
- (#Product Analysis Analysis)
- (#Case Analysis (List [Pattern Analysis]))
- (#Function Scope Analysis)
- (#Apply Analysis Analysis)
- (#Procedure Text (List Analysis))
- (#Variable Ref)
- (#Definition Ident))
+ (data (coll [list "list/" Fold<List>]))
+ (meta [code]))
+ (luxc (lang [";L" variable #+ Variable])))
+
+(type: #export Pattern Code)
+
+(type: #export Analysis Code)
## Variants get analysed as binary sum types for the sake of semantic
## simplicity.
@@ -39,28 +17,34 @@
(do-template [<name> <side>]
[(def: (<name> inner)
(-> Analysis Analysis)
- (#Sum (<side> inner)))]
+ (` (<side> (~ inner))))]
+
+ [sum-left "lux sum left"]
+ [sum-right "lux sum right"])
- [sum-left #;Left]
- [sum-right #;Right])
+(def: (local-variable idx)
+ (-> Nat Int)
+ (nat-to-int idx))
(def: #export (sum tag size temp value)
(-> Nat Nat Nat Analysis Analysis)
(if (n.= (n.dec size) tag)
(if (n.= +1 tag)
(sum-right value)
- (L/fold (function;const sum-left)
- (sum-right value)
- (list;n.range +0 (n.- +2 tag))))
- (L/fold (function;const sum-left)
- (case value
- (#Sum _)
- (#Case value (list [(#BindP temp)
- (#Variable (#;Local temp))]))
-
- _
- value)
- (list;n.range +0 tag))))
+ (list/fold (function;const sum-left)
+ (sum-right value)
+ (list;n.range +0 (n.- +2 tag))))
+ (list/fold (function;const sum-left)
+ (case value
+ (^or (^code ("lux sum left" (~ inner)))
+ (^code ("lux sum right" (~ inner))))
+ (` ("lux case" (~ value)
+ {("lux case bind" (~ (code;nat temp)))
+ ((~ (code;int (local-variable temp))))}))
+
+ _
+ value)
+ (list;n.range +0 tag))))
## Tuples get analysed into binary products for the sake of semantic
## simplicity, since products/pairs can encode tuples of any length
@@ -70,13 +54,13 @@
(-> (List Analysis) Analysis)
(case members
#;Nil
- #Unit
+ (` [])
(#;Cons singleton #;Nil)
singleton
(#;Cons left right)
- (#Product left (product right))))
+ (` [(~ left) (~ (product right))])))
## Function application gets analysed into single-argument
## applications, since every other kind of application can be encoded
@@ -84,6 +68,44 @@
(def: #export (apply args func)
(-> (List Analysis) Analysis Analysis)
- (L/fold (function [arg func] (#Apply arg func))
- func
- args))
+ (list/fold (function [arg func]
+ (` ("lux apply" (~ arg) (~ func))))
+ func
+ args))
+
+(def: #export (procedure name args)
+ (-> Text (List Analysis) Analysis)
+ (` ((~ (code;text name)) (~@ args))))
+
+(def: #export (var idx)
+ (-> Variable Analysis)
+ (` ((~ (code;int idx)))))
+
+(def: #export (unfold-tuple analysis)
+ (-> Analysis (List Analysis))
+ (case analysis
+ (^code [(~ left) (~ right)])
+ (#;Cons left (unfold-tuple right))
+
+ _
+ (list analysis)))
+
+(def: #export (unfold-variant analysis)
+ (-> Analysis (Maybe [Nat Bool Analysis]))
+ (loop [so-far +0
+ variantA analysis]
+ (case variantA
+ (^code ("lux sum left" (~ valueA)))
+ (case valueA
+ (^or (^code ("lux sum left" (~ _)))
+ (^code ("lux sum right" (~ _))))
+ (recur (n.inc so-far) valueA)
+
+ _
+ (#;Some [so-far false valueA]))
+
+ (^code ("lux sum right" (~ valueA)))
+ (#;Some [(n.inc so-far) true valueA])
+
+ _
+ #;None)))
diff --git a/new-luxc/source/luxc/lang/synthesis.lux b/new-luxc/source/luxc/lang/synthesis.lux
index 96053edc0..3207c41b4 100644
--- a/new-luxc/source/luxc/lang/synthesis.lux
+++ b/new-luxc/source/luxc/lang/synthesis.lux
@@ -2,8 +2,6 @@
lux)
(def: #export Arity Nat)
-(def: #export Register Nat)
-(def: #export Variable Int)
(type: #export Synthesis Code)
diff --git a/new-luxc/source/luxc/lang/variable.lux b/new-luxc/source/luxc/lang/variable.lux
new file mode 100644
index 000000000..c04269e63
--- /dev/null
+++ b/new-luxc/source/luxc/lang/variable.lux
@@ -0,0 +1,47 @@
+(;module:
+ lux
+ (lux (data (coll [list "list/" Functor<List>]))))
+
+(def: #export Variable Int)
+(def: #export Register Nat)
+
+(def: #export (captured register)
+ (-> Nat Variable)
+ (|> register n.inc nat-to-int (i.* -1)))
+
+(def: #export (local register)
+ (-> Nat Variable)
+ (nat-to-int register))
+
+(def: #export (local-register variable)
+ (-> Variable Register)
+ (int-to-nat variable))
+
+(def: #export (captured-register variable)
+ (-> Variable Register)
+ (|> variable (i.* -1) int-to-nat n.dec))
+
+(do-template [<name> <comp>]
+ [(def: #export (<name> var)
+ (-> Variable Bool)
+ (<comp> 0 var))]
+
+ [self? i.=]
+ [local? i.>]
+ [captured? i.<]
+ )
+
+(def: #export (from-ref ref)
+ (-> Ref Variable)
+ (case ref
+ (#;Local register)
+ (local register)
+
+ (#;Captured register)
+ (captured register)))
+
+(def: #export (environment scope)
+ (-> Scope (List Variable))
+ (|> scope
+ (get@ [#;captured #;mappings])
+ (list/map (function [[_ [_ ref]]] (from-ref ref)))))
diff --git a/new-luxc/source/luxc/synthesizer.lux b/new-luxc/source/luxc/synthesizer.lux
index e1eb67bd7..e6730c5a3 100644
--- a/new-luxc/source/luxc/synthesizer.lux
+++ b/new-luxc/source/luxc/synthesizer.lux
@@ -12,14 +12,14 @@
["s" syntax]))
(luxc ["&" base]
(lang ["la" analysis]
- ["ls" synthesis])
- (synthesizer ["&&;" structure]
- ["&&;" case]
+ ["ls" synthesis]
+ [";L" variable #+ Variable])
+ (synthesizer ["&&;" case]
["&&;" function]
["&&;" loop])
))
-(def: init-env (List ls;Variable) (list))
+(def: init-env (List Variable) (list))
(def: init-resolver (Dict Int Int) (dict;new number;Hash<Int>))
(def: (prepare-body inner-arity arity body)
@@ -28,10 +28,6 @@
body
(&&loop;reify-recursion arity body)))
-(def: (parse-environment env)
- (-> (List Code) (e;Error (List ls;Variable)))
- (s;run env (p;some s;int)))
-
(def: (let$ register inputS bodyS)
(-> Nat ls;Synthesis ls;Synthesis ls;Synthesis)
(` ("lux let" (~ (code;nat register)) (~ inputS) (~ bodyS))))
@@ -43,7 +39,7 @@
(~ elseS))))
(def: (function$ arity environment body)
- (-> ls;Arity (List ls;Variable) ls;Synthesis ls;Synthesis)
+ (-> ls;Arity (List Variable) ls;Synthesis ls;Synthesis)
(` ("lux function" (~ (code;nat arity))
[(~@ (list/map code;int environment))]
(~ body))))
@@ -53,7 +49,7 @@
(` ((~ (code;nat tag)) (~ (code;bool last?)) (~ valueS))))
(def: (var$ var)
- (-> ls;Variable ls;Synthesis)
+ (-> Variable ls;Synthesis)
(` ((~ (code;int var)))))
(def: (procedure$ name argsS)
@@ -70,16 +66,17 @@
ls;Synthesis)
(let [inputS (synthesize inputA)]
(case (list;reverse branchesA)
- (^multi (^ (list [(#la;BindP input-register)
- (#la;Variable (#;Local output-register))]))
- (n.= input-register output-register))
+ (^multi (^ (list [(^code ("lux case bind" (~ [_ (#;Nat input-register)])))
+ (^code ((~ [_ (#;Int var)])))]))
+ (variableL;local? var)
+ (n.= input-register (int-to-nat var)))
inputS
- (^ (list [(#la;BindP register) bodyA]))
+ (^ (list [(^code ("lux case bind" (~ [_ (#;Nat register)]))) bodyA]))
(let$ register inputS (synthesize bodyA))
- (^or (^ (list [(#la;BoolP true) thenA] [(#la;BoolP false) elseA]))
- (^ (list [(#la;BoolP false) elseA] [(#la;BoolP true) thenA])))
+ (^or (^ (list [(^code true) thenA] [(^code false) elseA]))
+ (^ (list [(^code false) elseA] [(^code true) thenA])))
(if$ inputS (synthesize thenA) (synthesize elseA))
(#;Cons [lastP lastA] prevsPA)
@@ -98,6 +95,28 @@
(undefined)
)))
+(def: (synthesize-apply synthesize outer-arity num-locals exprA)
+ (-> (-> la;Analysis ls;Synthesis) ls;Arity Nat la;Analysis ls;Synthesis)
+ (let [[funcA argsA] (&&function;unfold-apply exprA)
+ funcS (synthesize funcA)
+ argsS (list/map synthesize argsA)]
+ (case funcS
+ (^multi (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat _arity)] [_ (#;Tuple _env)] _bodyS))])
+ (and (n.= _arity (list;size argsS))
+ (not (&&loop;contains-self-reference? _bodyS)))
+ [(s;run _env (p;some s;int)) (#e;Success _env)])
+ (let [register-offset (if (&&function;top? outer-arity)
+ num-locals
+ (|> outer-arity n.inc (n.+ num-locals)))]
+ (` ("lux loop" (~ (code;nat register-offset)) [(~@ argsS)]
+ (~ (&&loop;adjust _env register-offset _bodyS)))))
+
+ (^ [_ (#;Form (list& [_ (#;Text "lux call")] funcS' argsS'))])
+ (call$ funcS' (list/compose argsS' argsS))
+
+ _
+ (call$ funcS argsS))))
+
(def: #export (synthesize analysis)
(-> la;Analysis ls;Synthesis)
(loop [outer-arity +0
@@ -105,53 +124,39 @@
num-locals +0
exprA analysis]
(case exprA
- #la;Unit
- (' [])
-
- (^template [<from> <to>]
- (<from> value)
- (<to> value))
- ([#la;Bool code;bool]
- [#la;Nat code;nat]
- [#la;Int code;int]
- [#la;Deg code;deg]
- [#la;Frac code;frac]
- [#la;Text code;text]
- [#la;Definition code;symbol])
-
- (#la;Product _)
- (` [(~@ (list/map (recur +0 resolver num-locals) (&&structure;unfold-tuple exprA)))])
-
- (#la;Sum choice)
- (let [[tag last? value] (&&structure;unfold-variant choice)]
+ (^code [(~ _left) (~ _right)])
+ (` [(~@ (list/map (recur +0 resolver num-locals) (la;unfold-tuple exprA)))])
+
+ (^or (^code ("lux sum left" (~ _)))
+ (^code ("lux sum right" (~ _))))
+ (let [[tag last? value] (maybe;assume (la;unfold-variant exprA))]
(variant$ tag last? (recur +0 resolver num-locals value)))
- (#la;Variable ref)
- (case ref
- (#;Local register)
- (if (&&function;nested? outer-arity)
- (if (n.= +0 register)
- (call$ (var$ 0) (|> (list;n.range +1 (n.dec outer-arity))
- (list/map (|>. &&function;to-local code;int (~) () (`)))))
- (var$ (&&function;adjust-var outer-arity (&&function;to-local register))))
- (var$ (&&function;to-local register)))
-
- (#;Captured register)
- (var$ (let [var (&&function;to-captured register)]
- (maybe;default var (dict;get var resolver)))))
-
- (#la;Case inputA branchesA)
+ (^code ((~ [_ (#;Int var)])))
+ (if (variableL;local? var)
+ (let [register (variableL;local-register var)]
+ (if (&&function;nested? outer-arity)
+ (if (n.= +0 register)
+ (call$ (var$ 0) (|> (list;n.range +1 (n.dec outer-arity))
+ (list/map (|>. variableL;local code;int (~) () (`)))))
+ (var$ (&&function;adjust-var outer-arity (variableL;local register))))
+ (var$ (variableL;local register))))
+ (let [register (variableL;captured-register var)]
+ (var$ (let [var (variableL;captured register)]
+ (maybe;default var (dict;get var resolver))))))
+
+ (^code ("lux case" (~ inputA) (~ [_ (#;Record branchesA)])))
(synthesize-case (recur +0 resolver num-locals) inputA branchesA)
-
- (#la;Function scope bodyA)
+
+ (^multi (^code ("lux function" [(~@ scope)] (~ bodyA)))
+ [(s;run scope (p;some s;int)) (#e;Success raw-env)])
(let [inner-arity (n.inc outer-arity)
- raw-env (&&function;environment scope)
env (list/map (function [var] (maybe;default var (dict;get var resolver))) raw-env)
env-vars (let [env-size (list;size raw-env)]
- (: (List ls;Variable)
+ (: (List Variable)
(case env-size
+0 (list)
- _ (list/map &&function;to-captured (list;n.range +0 (n.dec env-size))))))
+ _ (list/map variableL;captured (list;n.range +0 (n.dec env-size))))))
resolver' (if (&&function;nested? inner-arity)
(list/fold (function [[from to] resolver']
(dict;put from to resolver'))
@@ -169,27 +174,11 @@
bodyS
(function$ +1 env (prepare-body inner-arity +1 bodyS))))
- (#la;Apply _)
- (let [[funcA argsA] (&&function;unfold-apply exprA)
- funcS (recur +0 resolver num-locals funcA)
- argsS (list/map (recur +0 resolver num-locals) argsA)]
- (case funcS
- (^multi (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat _arity)] [_ (#;Tuple _env)] _bodyS))])
- (and (n.= _arity (list;size argsS))
- (not (&&loop;contains-self-reference? _bodyS)))
- [(parse-environment _env) (#e;Success _env)])
- (let [register-offset (if (&&function;top? outer-arity)
- num-locals
- (|> outer-arity n.inc (n.+ num-locals)))]
- (` ("lux loop" (~ (code;nat register-offset)) [(~@ argsS)]
- (~ (&&loop;adjust _env register-offset _bodyS)))))
-
- (^ [_ (#;Form (list& [_ (#;Text "lux call")] funcS' argsS'))])
- (call$ funcS' (list/compose argsS' argsS))
-
- _
- (call$ funcS argsS)))
-
- (#la;Procedure name args)
+ (^code ("lux apply" (~@ _)))
+ (synthesize-apply synthesize outer-arity num-locals exprA)
+
+ (^code ((~ [_ (#;Text name)]) (~@ args)))
(procedure$ name (list/map (recur +0 resolver num-locals) args))
- )))
+
+ _
+ exprA)))
diff --git a/new-luxc/source/luxc/synthesizer/case.lux b/new-luxc/source/luxc/synthesizer/case.lux
index 91f339bdf..15cb6eca3 100644
--- a/new-luxc/source/luxc/synthesizer/case.lux
+++ b/new-luxc/source/luxc/synthesizer/case.lux
@@ -6,26 +6,12 @@
(coll [list "list/" Fold<List>]))
(meta [code "code/" Eq<Code>]))
(luxc (lang ["la" analysis]
- ["ls" synthesis])
- (synthesizer ["&;" function])))
+ ["ls" synthesis])))
(def: #export (path pattern)
(-> la;Pattern ls;Path)
(case pattern
- (#la;BindP register)
- (` ("lux case bind" (~ (code;nat register))))
-
- (^template [<from> <to>]
- (<from> value)
- (<to> value))
- ([#la;BoolP code;bool]
- [#la;NatP code;nat]
- [#la;IntP code;int]
- [#la;DegP code;deg]
- [#la;FracP code;frac]
- [#la;TextP code;text])
-
- (#la;TupleP membersP)
+ (^code [(~@ membersP)])
(case (list;reverse membersP)
#;Nil
(' ("lux case pop"))
@@ -45,11 +31,14 @@
(` ("lux case tuple right" (~ (code;nat last-idx)) (~ (path lastP))))]
prevsP)]
tuple-path))
-
- (#la;VariantP tag num-tags memberP)
+
+ (^code ((~ [_ (#;Nat tag)]) (~ [_ (#;Nat num-tags)]) (~ memberP)))
(if (n.= (n.dec num-tags) tag)
(` ("lux case variant right" (~ (code;nat tag)) (~ (path memberP))))
- (` ("lux case variant left" (~ (code;nat tag)) (~ (path memberP)))))))
+ (` ("lux case variant left" (~ (code;nat tag)) (~ (path memberP)))))
+
+ _
+ pattern))
(def: #export (weave leftP rightP)
(-> ls;Path ls;Path ls;Path)
diff --git a/new-luxc/source/luxc/synthesizer/function.lux b/new-luxc/source/luxc/synthesizer/function.lux
index 4d9970a3f..52aee9a49 100644
--- a/new-luxc/source/luxc/synthesizer/function.lux
+++ b/new-luxc/source/luxc/synthesizer/function.lux
@@ -1,31 +1,8 @@
(;module:
lux
- (lux (data (coll [list "list/" Functor<List>])))
(luxc (lang ["la" analysis]
- ["ls" synthesis])))
-
-(def: #export (environment scope)
- (-> Scope (List ls;Variable))
- (|> scope
- (get@ [#;captured #;mappings])
- (list/map (function [[_ _ ref]]
- (case ref
- (#;Local idx)
- (nat-to-int idx)
-
- (#;Captured idx)
- (|> idx n.inc nat-to-int (i.* -1))
- )))))
-
-(do-template [<name> <comp>]
- [(def: #export (<name> var)
- (-> ls;Variable Bool)
- (<comp> 0 var))]
-
- [self? i.=]
- [local? i.>]
- [captured? i.<]
- )
+ ["ls" synthesis]
+ [";L" variable #+ Variable])))
(do-template [<name> <comp> <ref>]
[(def: #export (<name> arity)
@@ -37,27 +14,15 @@
)
(def: #export (adjust-var outer var)
- (-> ls;Arity ls;Variable ls;Variable)
+ (-> ls;Arity Variable Variable)
(|> outer n.dec nat-to-int (i.+ var)))
-(def: #export (to-captured idx)
- (-> Nat Int)
- (|> idx n.inc nat-to-int (i.* -1)))
-
-(def: #export (captured-idx idx)
- (-> Int Nat)
- (|> idx (i.* -1) int-to-nat n.dec))
-
-(def: #export (to-local idx)
- (-> Nat Int)
- (nat-to-int idx))
-
(def: #export (unfold-apply apply)
(-> la;Analysis [la;Analysis (List la;Analysis)])
(loop [apply apply
args (list)]
(case apply
- (#la;Apply arg func)
+ (^code ("lux apply" (~ arg) (~ func)))
(recur func (#;Cons arg args))
_
diff --git a/new-luxc/source/luxc/synthesizer/loop.lux b/new-luxc/source/luxc/synthesizer/loop.lux
index 8599db981..0070fcd5d 100644
--- a/new-luxc/source/luxc/synthesizer/loop.lux
+++ b/new-luxc/source/luxc/synthesizer/loop.lux
@@ -6,8 +6,8 @@
(coll [list "list/" Functor<List>]))
(meta [code]
[syntax]))
- (luxc (lang ["ls" synthesis])
- (synthesizer ["&&;" function])))
+ (luxc (lang ["ls" synthesis]
+ [";L" variable #+ Variable Register])))
(def: #export (contains-self-reference? exprS)
(-> ls;Synthesis Bool)
@@ -19,7 +19,7 @@
(list;any? contains-self-reference? membersS)
(^ [_ (#;Form (list [_ (#;Int var)]))])
- (&&function;self? var)
+ (variableL;self? var)
(^ [_ (#;Form (list [_ (#;Text "lux case")] inputS pathS))])
(or (contains-self-reference? inputS)
@@ -40,7 +40,7 @@
(list;any? (function [captured]
(case captured
(^ [_ (#;Form (list [_ (#;Int var)]))])
- (&&function;self? var)
+ (variableL;self? var)
_
false))
@@ -109,8 +109,8 @@
)))
(def: #export (adjust env outer-offset exprS)
- (-> (List ls;Variable) ls;Register ls;Synthesis ls;Synthesis)
- (let [resolve-captured (: (-> ls;Variable ls;Variable)
+ (-> (List Variable) Register ls;Synthesis ls;Synthesis)
+ (let [resolve-captured (: (-> Variable Variable)
(function [var]
(let [idx (|> var (i.* -1) int-to-nat n.dec)]
(|> env (list;nth idx) maybe;assume))))]
@@ -161,7 +161,7 @@
(` ((~ (code;text procedure)) (~@ (list/map recur argsS))))
(^ [_ (#;Form (list [_ (#;Int var)]))])
- (if (&&function;captured? var)
+ (if (variableL;captured? var)
(` ((~ (code;int (resolve-captured var)))))
(` ((~ (code;int (|> outer-offset nat-to-int (i.+ var)))))))
diff --git a/new-luxc/source/luxc/synthesizer/structure.lux b/new-luxc/source/luxc/synthesizer/structure.lux
deleted file mode 100644
index 403817c53..000000000
--- a/new-luxc/source/luxc/synthesizer/structure.lux
+++ /dev/null
@@ -1,28 +0,0 @@
-(;module:
- lux
- (luxc (lang ["la" analysis])))
-
-(def: #export (unfold-tuple tuple)
- (-> la;Analysis (List la;Analysis))
- (case tuple
- (#la;Product left right)
- (#;Cons left (unfold-tuple right))
-
- _
- (list tuple)))
-
-(def: #export (unfold-variant variant)
- (-> (Either la;Analysis la;Analysis) [Nat Bool la;Analysis])
- (loop [so-far +0
- variantA variant]
- (case variantA
- (#;Left valueA)
- (case valueA
- (#la;Sum choice)
- (recur (n.inc so-far) choice)
-
- _
- [so-far false valueA])
-
- (#;Right valueA)
- [(n.inc so-far) true valueA])))
diff --git a/new-luxc/source/luxc/synthesizer/variable.lux b/new-luxc/source/luxc/synthesizer/variable.lux
index 01ad101fa..3ce9f2678 100644
--- a/new-luxc/source/luxc/synthesizer/variable.lux
+++ b/new-luxc/source/luxc/synthesizer/variable.lux
@@ -1,22 +1,20 @@
(;module:
lux
- (lux (data [bool "B/" Eq<Bool>]
- [text "T/" Eq<Text>]
- [number]
- (coll [list "L/" Functor<List> Fold<List> Monoid<List>]
+ (lux (data [number]
+ (coll [list "list/" Fold<List> Monoid<List>]
["s" set])))
(luxc (lang ["la" analysis]
- ["ls" synthesis])
- (synthesizer ["&;" function])))
+ ["ls" synthesis]
+ [";L" variable #+ Variable])))
(def: (bound-vars path)
- (-> ls;Path (List ls;Variable))
+ (-> ls;Path (List Variable))
(case path
(#ls;BindP register)
(list (nat-to-int register))
(^or (#ls;SeqP pre post) (#ls;AltP pre post))
- (L/compose (bound-vars pre) (bound-vars post))
+ (list/compose (bound-vars pre) (bound-vars post))
_
(list)))
@@ -31,24 +29,24 @@
(path-bodies post)
(#ls;AltP pre post)
- (L/compose (path-bodies pre) (path-bodies post))
+ (list/compose (path-bodies pre) (path-bodies post))
_
(list)))
(def: (non-arg? arity var)
- (-> ls;Arity ls;Variable Bool)
- (and (&function;local? var)
+ (-> ls;Arity Variable Bool)
+ (and (variableL;local? var)
(n.> arity (int-to-nat var))))
-(type: Tracker (s;Set ls;Variable))
+(type: Tracker (s;Set Variable))
(def: init-tracker Tracker (s;new number;Hash<Int>))
(def: (unused-vars current-arity bound exprS)
- (-> ls;Arity (List ls;Variable) ls;Synthesis (List ls;Variable))
+ (-> ls;Arity (List Variable) ls;Synthesis (List Variable))
(let [tracker (loop [exprS exprS
- tracker (L/fold s;add init-tracker bound)]
+ tracker (list/fold s;add init-tracker bound)]
(case exprS
(#ls;Variable var)
(if (non-arg? current-arity var)
@@ -59,14 +57,14 @@
(recur memberS tracker)
(#ls;Tuple membersS)
- (L/fold recur tracker membersS)
+ (list/fold recur tracker membersS)
(#ls;Call funcS argsS)
- (L/fold recur (recur funcS tracker) argsS)
+ (list/fold recur (recur funcS tracker) argsS)
(^or (#ls;Recur argsS)
(#ls;Procedure name argsS))
- (L/fold recur tracker argsS)
+ (list/fold recur tracker argsS)
(#ls;Let offset inputS outputS)
(|> tracker (recur inputS) (recur outputS))
@@ -75,16 +73,16 @@
(|> tracker (recur testS) (recur thenS) (recur elseS))
(#ls;Loop offset initsS bodyS)
- (recur bodyS (L/fold recur tracker initsS))
+ (recur bodyS (list/fold recur tracker initsS))
(#ls;Case inputS outputPS)
- (let [tracker' (L/fold s;add
- (recur inputS tracker)
- (bound-vars outputPS))]
- (L/fold recur tracker' (path-bodies outputPS)))
+ (let [tracker' (list/fold s;add
+ (recur inputS tracker)
+ (bound-vars outputPS))]
+ (list/fold recur tracker' (path-bodies outputPS)))
(#ls;Function arity env bodyS)
- (L/fold s;remove tracker env)
+ (list/fold s;remove tracker env)
_
tracker
diff --git a/new-luxc/test/test/luxc/analyser/function.lux b/new-luxc/test/test/luxc/analyser/function.lux
index 6fbafd1eb..379c4acf4 100644
--- a/new-luxc/test/test/luxc/analyser/function.lux
+++ b/new-luxc/test/test/luxc/analyser/function.lux
@@ -44,7 +44,7 @@
(def: (flatten-apply analysis)
(-> la;Analysis [la;Analysis (List la;Analysis)])
(case analysis
- (#la;Apply head func)
+ (^code ("lux apply" (~ head) (~ func)))
(let [[func' tail] (flatten-apply func)]
[func' (#;Cons head tail)])
@@ -130,25 +130,25 @@
($_ seq
(test "Can analyse monomorphic type application."
(|> (@common;with-unknown-type
- (@;analyse-apply analyse funcT (#la;Unit) inputsC))
+ (@;analyse-apply analyse funcT (' []) inputsC))
(check-apply outputT full-args)))
(test "Can partially apply functions."
(|> (@common;with-unknown-type
- (@;analyse-apply analyse funcT (#la;Unit)
+ (@;analyse-apply analyse funcT (' [])
(list;take partial-args inputsC)))
(check-apply partialT partial-args)))
(test "Can apply polymorphic functions."
(|> (@common;with-unknown-type
- (@;analyse-apply analyse polyT (#la;Unit) inputsC))
+ (@;analyse-apply analyse polyT (' []) inputsC))
(check-apply poly-inputT full-args)))
(test "Polymorphic partial application propagates found type-vars."
(|> (@common;with-unknown-type
- (@;analyse-apply analyse polyT (#la;Unit)
+ (@;analyse-apply analyse polyT (' [])
(list;take (n.inc var-idx) inputsC)))
(check-apply partial-polyT1 (n.inc var-idx))))
(test "Polymorphic partial application preserves quantification for type-vars."
(|> (@common;with-unknown-type
- (@;analyse-apply analyse polyT (#la;Unit)
+ (@;analyse-apply analyse polyT (' [])
(list;take var-idx inputsC)))
(check-apply partial-polyT2 var-idx)))
))))
diff --git a/new-luxc/test/test/luxc/analyser/primitive.lux b/new-luxc/test/test/luxc/analyser/primitive.lux
index 3d2e4ada6..8c483428b 100644
--- a/new-luxc/test/test/luxc/analyser/primitive.lux
+++ b/new-luxc/test/test/luxc/analyser/primitive.lux
@@ -34,27 +34,34 @@
%deg% r;deg
%frac% r;frac
%text% (r;text +5)]
- (with-expansions
- [<tests> (do-template [<desc> <type> <tag> <value> <analyser>]
- [(test (format "Can analyse " <desc> ".")
- (|> (@common;with-unknown-type
- (<analyser> <value>))
- (meta;run (init-compiler []))
- (case> (#e;Success [_type (<tag> value)])
- (and (type/= <type> _type)
- (is <value> value))
+ (`` ($_ seq
+ (test "Can analyse unit."
+ (|> (@common;with-unknown-type
+ @;analyse-unit)
+ (meta;run (init-compiler []))
+ (case> (^ (#e;Success [_type (^code [])]))
+ (type/= Unit _type)
- _
- false))
- )]
+ _
+ false))
+ )
+ (~~ (do-template [<desc> <type> <tag> <value> <analyser>]
+ [(test (format "Can analyse " <desc> ".")
+ (|> (@common;with-unknown-type
+ (<analyser> <value>))
+ (meta;run (init-compiler []))
+ (case> (#e;Success [_type [_ (<tag> value)]])
+ (and (type/= <type> _type)
+ (is <value> value))
- ["unit" Unit #~;Unit [] (function [value] @;analyse-unit)]
- ["bool" Bool #~;Bool %bool% @;analyse-bool]
- ["nat" Nat #~;Nat %nat% @;analyse-nat]
- ["int" Int #~;Int %int% @;analyse-int]
- ["deg" Deg #~;Deg %deg% @;analyse-deg]
- ["frac" Frac #~;Frac %frac% @;analyse-frac]
- ["text" Text #~;Text %text% @;analyse-text]
- )]
- ($_ seq
- <tests>)))))
+ _
+ false))
+ )]
+
+ ["bool" Bool #;Bool %bool% @;analyse-bool]
+ ["nat" Nat #;Nat %nat% @;analyse-nat]
+ ["int" Int #;Int %int% @;analyse-int]
+ ["deg" Deg #;Deg %deg% @;analyse-deg]
+ ["frac" Frac #;Frac %frac% @;analyse-frac]
+ ["text" Text #;Text %text% @;analyse-text]
+ )))))))
diff --git a/new-luxc/test/test/luxc/analyser/reference.lux b/new-luxc/test/test/luxc/analyser/reference.lux
index 89d68484f..e9d66838a 100644
--- a/new-luxc/test/test/luxc/analyser/reference.lux
+++ b/new-luxc/test/test/luxc/analyser/reference.lux
@@ -31,7 +31,7 @@
(@common;with-unknown-type
(@;analyse-reference ["" var-name]))))
(meta;run (init-compiler []))
- (case> (#e;Success [_type (#~;Variable idx)])
+ (case> (^ (#e;Success [_type (^code ((~ [_ (#;Int var)])))]))
(type/= ref-type _type)
_
@@ -44,7 +44,7 @@
(@common;with-unknown-type
(@;analyse-reference [module-name var-name])))
(meta;run (init-compiler []))
- (case> (#e;Success [_type (#~;Definition idx)])
+ (case> (#e;Success [_type [_ (#;Symbol def-name)]])
(type/= ref-type _type)
_
diff --git a/new-luxc/test/test/luxc/analyser/structure.lux b/new-luxc/test/test/luxc/analyser/structure.lux
index 40896c334..5f88aea37 100644
--- a/new-luxc/test/test/luxc/analyser/structure.lux
+++ b/new-luxc/test/test/luxc/analyser/structure.lux
@@ -26,36 +26,6 @@
(.. common)
(test/luxc common))
-(def: (flatten-tuple analysis)
- (-> la;Analysis (List la;Analysis))
- (case analysis
- (#la;Product left right)
- (#;Cons left (flatten-tuple right))
-
- _
- (list analysis)))
-
-(def: (flatten-variant analysis)
- (-> la;Analysis (Maybe [Nat Bool la;Analysis]))
- (case analysis
- (#la;Sum variant)
- (loop [so-far +0
- variantA variant]
- (case variantA
- (#;Left valueA)
- (case valueA
- (#la;Sum choice)
- (recur (n.inc so-far) choice)
-
- _
- (#;Some [so-far false valueA]))
-
- (#;Right valueA)
- (#;Some [(n.inc so-far) true valueA])))
-
- _
- #;None))
-
(context: "Sums"
(<| (times +100)
(do @
@@ -79,7 +49,7 @@
(@;analyse-sum analyse choice valueC)))
(meta;run (init-compiler []))
(case> (^multi (#e;Success [_ sumA])
- [(flatten-variant sumA)
+ [(la;unfold-variant sumA)
(#;Some [tag last? valueA])])
(and (n.= tag choice)
(bool/= last? (n.= (n.dec size) choice)))
@@ -97,7 +67,7 @@
(@;analyse-sum analyse choice valueC))))))
(meta;run (init-compiler []))
(case> (^multi (#e;Success [_ sumA])
- [(flatten-variant sumA)
+ [(la;unfold-variant sumA)
(#;Some [tag last? valueA])])
(and (n.= tag choice)
(bool/= last? (n.= (n.dec size) choice)))
@@ -156,7 +126,7 @@
(@;analyse-product analyse (list/map product;right primitives)))
(meta;run (init-compiler []))
(case> (#e;Success tupleA)
- (n.= size (list;size (flatten-tuple tupleA)))
+ (n.= size (list;size (la;unfold-tuple tupleA)))
_
false)))
@@ -167,7 +137,7 @@
(case> (#e;Success [_type tupleA])
(and (type/= (type;tuple (list/map product;left primitives))
_type)
- (n.= size (list;size (flatten-tuple tupleA))))
+ (n.= size (list;size (la;unfold-tuple tupleA))))
_
false)))
@@ -191,7 +161,7 @@
(@;analyse-product analyse (list/map product;right primitives)))))))
(meta;run (init-compiler []))
(case> (#e;Success [_ tupleA])
- (n.= size (list;size (flatten-tuple tupleA)))
+ (n.= size (list;size (la;unfold-tuple tupleA)))
_
false)))
@@ -222,7 +192,7 @@
(|> analysis
(meta;run (init-compiler []))
(case> (^multi (#e;Success [_ _ sumT sumA])
- [(flatten-variant sumA)
+ [(la;unfold-variant sumA)
(#;Some [tag last? valueA])])
(and (type/= variantT sumT)
(n.= tag choice)
@@ -236,7 +206,7 @@
(|> analysis
(meta;run (init-compiler []))
(case> (^multi (#e;Success [_ _ productT productA])
- [(flatten-tuple productA)
+ [(la;unfold-tuple productA)
membersA])
(and (type/= tupleT productT)
(n.= size (list;size membersA)))
@@ -301,7 +271,7 @@
(@;analyse-tagged-sum analyse [module-name other-choice-tag] other-choiceC)))))
(meta;run (init-compiler []))
(case> (^multi (#e;Success [_ _ sumA])
- [(flatten-variant sumA)
+ [(la;unfold-variant sumA)
(#;Some [tag last? valueA])])
(and (n.= tag other-choice)
(bool/= last? (n.= (n.dec size) other-choice)))
@@ -357,7 +327,7 @@
(@;analyse-record analyse recordC)))))
(meta;run (init-compiler []))
(case> (^multi (#e;Success [_ _ productA])
- [(flatten-tuple productA)
+ [(la;unfold-tuple productA)
membersA])
(n.= size (list;size membersA))
diff --git a/new-luxc/test/test/luxc/analyser/type.lux b/new-luxc/test/test/luxc/analyser/type.lux
index eb414bf04..978e450b6 100644
--- a/new-luxc/test/test/luxc/analyser/type.lux
+++ b/new-luxc/test/test/luxc/analyser/type.lux
@@ -61,15 +61,15 @@
(case> (#e;Success [_ [analysisT analysisA]])
(and (type/= codeT analysisT)
(case [exprC analysisA]
- (^template [<expected> <actual> <test>]
- [[_ (<expected> expected)] (<actual> actual)]
+ (^template [<tag> <test>]
+ [[_ (<tag> expected)] [_ (<tag> actual)]]
(<test> expected actual))
- ([#;Bool #~;Bool bool/=]
- [#;Nat #~;Nat n.=]
- [#;Int #~;Int i.=]
- [#;Deg #~;Deg d.=]
- [#;Frac #~;Frac f.=]
- [#;Text #~;Text text/=])
+ ([#;Bool bool/=]
+ [#;Nat n.=]
+ [#;Int i.=]
+ [#;Deg d.=]
+ [#;Frac f.=]
+ [#;Text text/=])
_
false))
diff --git a/new-luxc/test/test/luxc/generator/reference.lux b/new-luxc/test/test/luxc/generator/reference.lux
index a8bed89e1..dd522839b 100644
--- a/new-luxc/test/test/luxc/generator/reference.lux
+++ b/new-luxc/test/test/luxc/generator/reference.lux
@@ -3,7 +3,8 @@
(lux [io]
(control [monad #+ do]
pipe)
- (data ["e" error])
+ (data ["e" error]
+ [text])
["r" math/random]
[meta]
(meta [code])
@@ -38,7 +39,7 @@
(context: "Definitions."
(<| (times +100)
(do @
- [module-name (r;text +5)
+ [module-name (|> (r;text +5) (r;filter (|>. (text;contains? "/") not)))
def-name (r;text +5)
def-value r;int
#let [valueI (|>. ($i;long def-value) ($i;wrap #$;Long))]]
diff --git a/new-luxc/test/test/luxc/synthesizer/case/special.lux b/new-luxc/test/test/luxc/synthesizer/case/special.lux
index 63a921b68..30e64fc77 100644
--- a/new-luxc/test/test/luxc/synthesizer/case/special.lux
+++ b/new-luxc/test/test/luxc/synthesizer/case/special.lux
@@ -3,16 +3,12 @@
(lux [io]
(control [monad #+ do]
pipe)
- (data [product]
- [number]
- text/format
- (coll [list "L/" Functor<List> Fold<List>]
- ["D" dict]
- ["s" set]))
+ (meta [code])
["r" math/random "r/" Monad<Random>]
test)
(luxc (lang ["la" analysis]
- ["ls" synthesis])
+ ["ls" synthesis]
+ [";L" variable #+ Variable])
[synthesizer])
(../.. common))
@@ -20,10 +16,10 @@
(<| (times +100)
(do @
[maskedA gen-primitive
- temp r;nat
- #let [maskA (#la;Case maskedA
- (list [(#la;BindP temp)
- (#la;Variable (#;Local temp))]))]]
+ temp (|> r;nat (:: @ map (n.% +100)))
+ #let [maskA (` ("lux case" (~ maskedA)
+ {("lux case bind" (~ (code;nat temp)))
+ (~ (la;var (variableL;local temp)))}))]]
(test "Dummy variables created to mask expressions get eliminated during synthesis."
(|> (synthesizer;synthesize maskA)
(corresponds? maskedA))))))
@@ -34,9 +30,9 @@
[registerA r;nat
inputA gen-primitive
outputA gen-primitive
- #let [letA (#la;Case inputA
- (list [(#la;BindP registerA)
- outputA]))]]
+ #let [letA (` ("lux case" (~ inputA)
+ {("lux case bind" (~ (code;nat registerA)))
+ (~ outputA)}))]]
(test "Can detect and reify simple 'let' expressions."
(|> (synthesizer;synthesize letA)
(case> (^ [_ (#;Form (list [_ (#;Text "lux let")] [_ (#;Nat registerS)] inputS outputS))])
@@ -55,12 +51,12 @@
thenA gen-primitive
elseA gen-primitive
#let [ifA (if then|else
- (#la;Case inputA
- (list [(#la;BoolP true) thenA]
- [(#la;BoolP false) elseA]))
- (#la;Case inputA
- (list [(#la;BoolP false) elseA]
- [(#la;BoolP true) thenA])))]]
+ (` ("lux case" (~ inputA)
+ {true (~ thenA)
+ false (~ elseA)}))
+ (` ("lux case" (~ inputA)
+ {false (~ elseA)
+ true (~ thenA)})))]]
(test "Can detect and reify simple 'if' expressions."
(|> (synthesizer;synthesize ifA)
(case> (^ [_ (#;Form (list [_ (#;Text "lux if")] inputS thenS elseS))])
diff --git a/new-luxc/test/test/luxc/synthesizer/common.lux b/new-luxc/test/test/luxc/synthesizer/common.lux
index 35e7a71ba..a74c64402 100644
--- a/new-luxc/test/test/luxc/synthesizer/common.lux
+++ b/new-luxc/test/test/luxc/synthesizer/common.lux
@@ -2,35 +2,36 @@
lux
(lux (data [bool "bool/" Eq<Bool>]
[text "text/" Eq<Text>])
+ (meta [code])
["r" math/random "r/" Monad<Random>])
(luxc (lang ["la" analysis]
["ls" synthesis])))
(def: #export gen-primitive
(r;Random la;Analysis)
- (r;either (r;either (r;either (r/wrap #la;Unit)
- (r/map (|>. #la;Bool) r;bool))
- (r;either (r/map (|>. #la;Nat) r;nat)
- (r/map (|>. #la;Int) r;int)))
- (r;either (r;either (r/map (|>. #la;Deg) r;deg)
- (r/map (|>. #la;Frac) r;frac))
- (r/map (|>. #la;Text) (r;text +5)))))
+ (r;either (r;either (r;either (r/wrap (' []))
+ (r/map code;bool r;bool))
+ (r;either (r/map code;nat r;nat)
+ (r/map code;int r;int)))
+ (r;either (r;either (r/map code;deg r;deg)
+ (r/map code;frac r;frac))
+ (r/map code;text (r;text +5)))))
(def: #export (corresponds? analysis synthesis)
(-> la;Analysis ls;Synthesis Bool)
(case [analysis synthesis]
- [#la;Unit [_ (#;Tuple #;Nil)]]
+ (^ [(^code []) (^code [])])
true
- (^template [<analysis> <synthesis> <test>]
- [(<analysis> valueA) [_ (<synthesis> valueS)]]
+ (^template [<tag> <test>]
+ [[_ (<tag> valueA)] [_ (<tag> valueS)]]
(<test> valueA valueS))
- ([#la;Bool #;Bool bool/=]
- [#la;Nat #;Nat n.=]
- [#la;Int #;Int i.=]
- [#la;Deg #;Deg d.=]
- [#la;Frac #;Frac f.=]
- [#la;Text #;Text text/=])
+ ([#;Bool bool/=]
+ [#;Nat n.=]
+ [#;Int i.=]
+ [#;Deg d.=]
+ [#;Frac f.=]
+ [#;Text text/=])
_
false))
diff --git a/new-luxc/test/test/luxc/synthesizer/function.lux b/new-luxc/test/test/luxc/synthesizer/function.lux
index f38a2fab5..cab0da847 100644
--- a/new-luxc/test/test/luxc/synthesizer/function.lux
+++ b/new-luxc/test/test/luxc/synthesizer/function.lux
@@ -10,29 +10,15 @@
(coll [list "list/" Functor<List> Fold<List>]
[dict #+ Dict]
[set]))
+ (meta [code])
["r" math/random "r/" Monad<Random>]
test)
(luxc (lang ["la" analysis]
- ["ls" synthesis])
- [synthesizer]
- (synthesizer ["&&;" function]))
+ ["ls" synthesis]
+ [";L" variable #+ Variable])
+ [synthesizer])
(.. common))
-(def: (reference var)
- (-> ls;Variable Ref)
- (if (&&function;captured? var)
- (#;Captured (|> var (i.* -1) int-to-nat n.dec))
- (#;Local (int-to-nat var))))
-
-(def: (make-scope env)
- (-> (List ls;Variable) Scope)
- {#;name (list)
- #;inner +0
- #;locals {#;counter +0 #;mappings (list)}
- #;captured {#;counter +0
- #;mappings (list/map (|>. reference [Void] [""])
- env)}})
-
(def: gen-function//constant
(r;Random [Nat la;Analysis la;Analysis])
(r;rec
@@ -44,7 +30,7 @@
[[num-args outputA subA] gen-function//constant]
(wrap [(n.inc num-args)
outputA
- (#la;Function (make-scope (list)) subA)]))
+ (` ("lux function" [] (~ subA)))]))
(do @
[outputA gen-primitive]
(wrap [+0 outputA outputA])))))))
@@ -58,8 +44,8 @@
(do r;Monad<Random>
[num-locals (|> r;nat (:: @ map (|>. (n.% +100) (n.max +10))))
#let [indices (list;n.range +0 (n.dec num-locals))
- absolute-env (list/map &&function;to-local indices)
- relative-env (list/map &&function;to-captured indices)]
+ absolute-env (list/map variableL;local indices)
+ relative-env (list/map variableL;captured indices)]
[total-args prediction bodyA] (: (r;Random [Nat Int la;Analysis])
(loop [num-args +1
global-env relative-env]
@@ -80,14 +66,16 @@
[total-args prediction bodyA] (recur (n.inc num-args)
(list/map (function [pick] (maybe;assume (list;nth pick global-env)))
picks))]
- (wrap [total-args prediction (#la;Function (make-scope (list/map &&function;to-captured picks))
- bodyA)]))
+ (wrap [total-args prediction (` ("lux function" [(~@ (list/map (|>. variableL;captured code;int) picks))]
+ (~ bodyA)))]))
(do @
[chosen (pick (list;size global-env))]
(wrap [num-args
(maybe;assume (dict;get chosen resolver))
- (#la;Variable (#;Captured chosen))])))))))]
- (wrap [total-args prediction (#la;Function (make-scope absolute-env) bodyA)])
+ (la;var (variableL;captured chosen))])))))))]
+ (wrap [total-args prediction (` ("lux function"
+ [(~@ (list/map code;int absolute-env))]
+ (~ bodyA)))])
))
(def: gen-function//local
@@ -98,12 +86,12 @@
(do r;Monad<Random>
[nest?' r;bool
[total-args prediction bodyA] (recur (n.inc num-args) nest?')]
- (wrap [total-args prediction (#la;Function (make-scope (list)) bodyA)]))
+ (wrap [total-args prediction (` ("lux function" [] (~ bodyA)))]))
(do r;Monad<Random>
[chosen (|> r;nat (:: @ map (|>. (n.% +100) (n.max +2))))]
(wrap [num-args
(|> chosen (n.+ (n.dec num-args)) nat-to-int)
- (#la;Variable (#;Local chosen))])))))
+ (la;var (variableL;local chosen))])))))
(context: "Function definition."
(<| (times +100)
diff --git a/new-luxc/test/test/luxc/synthesizer/loop.lux b/new-luxc/test/test/luxc/synthesizer/loop.lux
index 165408fb6..fd8c95ce1 100644
--- a/new-luxc/test/test/luxc/synthesizer/loop.lux
+++ b/new-luxc/test/test/luxc/synthesizer/loop.lux
@@ -7,6 +7,7 @@
(coll [list "list/" Functor<List> Fold<List>]
["s" set])
text/format)
+ (meta [code])
["r" math/random "r/" Monad<Random>]
test)
(luxc (lang ["la" analysis]
@@ -53,49 +54,39 @@
(-> Nat la;Analysis (r;Random la;Analysis))
(r;either (r;either (r/wrap output)
(do r;Monad<Random>
- [inputA (|> r;nat (:: @ map (|>. #la;Nat)))
+ [inputA (|> r;nat (:: @ map code;nat))
num-cases (|> r;nat (:: @ map (|>. (n.% +10) (n.max +1))))
tests (|> (r;set number;Hash<Nat> num-cases r;nat)
- (:: @ map (|>. s;to-list (list/map (|>. #la;NatP)))))
- #let [bad-bodies (list;repeat num-cases #la;Unit)]
+ (:: @ map (|>. s;to-list (list/map code;nat))))
+ #let [bad-bodies (list;repeat num-cases (' []))]
good-body (gen-body arity output)
where-to-set (|> r;nat (:: @ map (n.% num-cases)))
#let [bodies (list;concat (list (list;take where-to-set bad-bodies)
(list good-body)
(list;drop (n.inc where-to-set) bad-bodies)))]]
- (wrap (#la;Case inputA
- (list;zip2 tests bodies)))))
+ (wrap (` ("lux case" (~ inputA)
+ (~ (code;record (list;zip2 tests bodies))))))))
(r;either (do r;Monad<Random>
[valueS r;bool
output' (gen-body (n.inc arity) output)]
- (wrap (#la;Case (#la;Bool valueS) (list [(#la;BindP arity) output']))))
+ (wrap (` ("lux case" (~ (code;bool valueS))
+ {("lux case bind" (~ (code;nat arity))) (~ output')}))))
(do r;Monad<Random>
[valueS r;bool
then|else r;bool
output' (gen-body arity output)
- #let [thenA (if then|else output' #la;Unit)
- elseA (if (not then|else) output' #la;Unit)]]
- (wrap (#la;Case (#la;Bool valueS)
- (list [(#la;BoolP then|else) thenA]
- [(#la;BoolP (not then|else)) elseA])))))
+ #let [thenA (if then|else output' (' []))
+ elseA (if (not then|else) output' (' []))]]
+ (wrap (` ("lux case" (~ (code;bool valueS))
+ {(~ (code;bool then|else)) (~ thenA)
+ (~ (code;bool (not then|else))) (~ elseA)})))))
))
-(def: (make-apply func args)
- (-> la;Analysis (List la;Analysis) la;Analysis)
- (list/fold (function [arg' func']
- (#la;Apply arg' func'))
- func
- args))
-
(def: (make-function arity body)
(-> ls;Arity la;Analysis la;Analysis)
(case arity
+0 body
- _ (#la;Function {#;name (list)
- #;inner +0
- #;locals {#;counter +0 #;mappings (list)}
- #;captured {#;counter +0 #;mappings (list)}}
- (make-function (n.dec arity) body))))
+ _ (` ("lux function" [] (~ (make-function (n.dec arity) body))))))
(def: gen-recursion
(r;Random [Bool Nat la;Analysis])
@@ -103,14 +94,12 @@
[arity (|> r;nat (:: @ map (|>. (n.% +10) (n.max +1))))
recur? r;bool
outputS (if recur?
- (wrap (make-apply (#la;Variable (#;Local +0))
- (list;repeat arity #la;Unit)))
+ (wrap (la;apply (list;repeat arity (' [])) (la;var 0)))
(do @
[plus-or-minus? r;bool
how-much (|> r;nat (:: @ map (|>. (n.% arity) (n.max +1))))
#let [shift (if plus-or-minus? n.+ n.-)]]
- (wrap (make-apply (#la;Variable (#;Local +0))
- (list;repeat (shift how-much arity) #la;Unit)))))
+ (wrap (la;apply (list;repeat (shift how-much arity) (' [])) (la;var 0)))))
bodyS (gen-body arity outputS)]
(wrap [recur? arity (make-function arity bodyS)])))
@@ -120,15 +109,15 @@
[arity (|> r;nat (:: @ map (|>. (n.% +10) (n.max +1))))
recur? r;bool
self-ref? r;bool
- #let [selfA (#la;Variable (#;Local +0))
- argA (if self-ref? selfA #la;Unit)]
+ #let [selfA (la;var 0)
+ argA (if self-ref? selfA (' []))]
outputS (if recur?
- (wrap (make-apply selfA (list;repeat arity argA)))
+ (wrap (la;apply (list;repeat arity argA) selfA))
(do @
[plus-or-minus? r;bool
how-much (|> r;nat (:: @ map (|>. (n.% arity) (n.max +1))))
#let [shift (if plus-or-minus? n.+ n.-)]]
- (wrap (make-apply selfA (list;repeat (shift how-much arity) #la;Unit)))))
+ (wrap (la;apply (list;repeat (shift how-much arity) (' [])) selfA))))
bodyS (gen-body arity outputS)]
(wrap [(and recur? (not self-ref?))
arity
@@ -156,7 +145,7 @@
[[prediction arity analysis] gen-recursion]
($_ seq
(test "Can reify loops."
- (case (synthesizer;synthesize (make-apply analysis (list;repeat arity #la;Unit)))
+ (case (synthesizer;synthesize (la;apply (list;repeat arity (' [])) analysis))
(^ [_ (#;Form (list [_ (#;Text "lux loop")] [_ (#;Nat in_register)] [_ (#;Tuple _inits)] _body))])
(and (n.= arity (list;size _inits))
(not (&&loop;contains-self-reference? _body)))
diff --git a/new-luxc/test/test/luxc/synthesizer/primitive.lux b/new-luxc/test/test/luxc/synthesizer/primitive.lux
index e8484697d..fb37f6104 100644
--- a/new-luxc/test/test/luxc/synthesizer/primitive.lux
+++ b/new-luxc/test/test/luxc/synthesizer/primitive.lux
@@ -4,6 +4,7 @@
(control [monad #+ do]
pipe)
(data text/format)
+ (meta [code])
["r" math/random]
test)
(luxc (lang ["la" analysis]
@@ -22,8 +23,8 @@
%text% (r;text +5)]
(`` ($_ seq
(test (format "Can synthesize unit.")
- (|> (synthesizer;synthesize (#la;Unit []))
- (case> [_ (#;Tuple #;Nil)]
+ (|> (synthesizer;synthesize (' []))
+ (case> (^code [])
true
_
@@ -37,9 +38,9 @@
_
false)))]
- ["bool" #la;Bool #;Bool %bool%]
- ["nat" #la;Nat #;Nat %nat%]
- ["int" #la;Int #;Int %int%]
- ["deg" #la;Deg #;Deg %deg%]
- ["frac" #la;Frac #;Frac %frac%]
- ["text" #la;Text #;Text %text%])))))))
+ ["bool" code;bool #;Bool %bool%]
+ ["nat" code;nat #;Nat %nat%]
+ ["int" code;int #;Int %int%]
+ ["deg" code;deg #;Deg %deg%]
+ ["frac" code;frac #;Frac %frac%]
+ ["text" code;text #;Text %text%])))))))
diff --git a/new-luxc/test/test/luxc/synthesizer/procedure.lux b/new-luxc/test/test/luxc/synthesizer/procedure.lux
index 1753dcc47..68010adeb 100644
--- a/new-luxc/test/test/luxc/synthesizer/procedure.lux
+++ b/new-luxc/test/test/luxc/synthesizer/procedure.lux
@@ -3,8 +3,7 @@
(lux [io]
(control [monad #+ do]
pipe)
- (data [bool "B/" Eq<Bool>]
- [text "T/" Eq<Text>]
+ (data [text "text/" Eq<Text>]
[product]
(coll [list]))
["r" math/random "r/" Monad<Random>]
@@ -23,9 +22,9 @@
argsA (r;list num-args gen-primitive)]
($_ seq
(test "Can synthesize procedure calls."
- (|> (synthesizer;synthesize (#la;Procedure nameA argsA))
+ (|> (synthesizer;synthesize (la;procedure nameA argsA))
(case> (^ [_ (#;Form (list& [_ (#;Text procedure)] argsS))])
- (and (T/= nameA procedure)
+ (and (text/= nameA procedure)
(list;every? (product;uncurry corresponds?)
(list;zip2 argsA argsS)))