aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
authorEduardo Julian2020-06-01 20:16:32 -0400
committerEduardo Julian2020-06-01 20:16:32 -0400
commita6987ad82f107df49853e1601b73076d030d6fc8 (patch)
treeb5562ec12fcee4a87b0c6ca4d485e7ac82ffbfec /stdlib/source
parent1546feb83e8e821ee8bbf3dea736a49a072bcd52 (diff)
Implemented an optimization for getting fields/slots from records in the new compiler.
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/control/parser/analysis.lux20
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/analysis.lux118
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/analysis/scope.lux20
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux12
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux16
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm.lux3
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux63
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux5
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable.lux3
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux3
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux5
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/apply.lux3
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/init.lux5
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/loop.lux5
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux7
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux3
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux178
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux23
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux47
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/synthesis.lux33
-rw-r--r--stdlib/source/lux/tool/compiler/reference.lux79
-rw-r--r--stdlib/source/lux/tool/compiler/reference/variable.lux59
-rw-r--r--stdlib/source/test/lux/control.lux2
-rw-r--r--stdlib/source/test/lux/control/parser/analysis.lux146
-rw-r--r--stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/case.lux159
-rw-r--r--stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/function.lux19
-rw-r--r--stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/primitive.lux22
27 files changed, 774 insertions, 284 deletions
diff --git a/stdlib/source/lux/control/parser/analysis.lux b/stdlib/source/lux/control/parser/analysis.lux
index fe8b4c4f0..824e2a83c 100644
--- a/stdlib/source/lux/control/parser/analysis.lux
+++ b/stdlib/source/lux/control/parser/analysis.lux
@@ -35,29 +35,19 @@
(list.interpose " ")
(text.join-with ""))))
-## TODO: Use "type:" ASAP.
-(def: Input Type (type (List Analysis)))
-
-(exception: #export (cannot-parse {input ..Input})
+(exception: #export (cannot-parse {input (List Analysis)})
(exception.report
["Input" (exception.enumerate /.%analysis input)]))
-(exception: #export (unconsumed-input {input ..Input})
+(exception: #export (unconsumed-input {input (List Analysis)})
(exception.report
["Input" (exception.enumerate /.%analysis input)]))
-(exception: #export (wrong-arity {expected Arity} {actual Arity})
- (exception.report
- ["Expected" (%.nat expected)]
- ["Actual" (%.nat actual)]))
-
-(exception: #export empty-input)
-
(type: #export Parser
- (//.Parser ..Input))
+ (//.Parser (List Analysis)))
(def: #export (run parser input)
- (All [a] (-> (Parser a) ..Input (Try a)))
+ (All [a] (-> (Parser a) (List Analysis) (Try a)))
(case (parser input)
(#try.Failure error)
(#try.Failure error)
@@ -73,7 +63,7 @@
(function (_ input)
(case input
#.Nil
- (exception.throw ..empty-input [])
+ (exception.throw ..cannot-parse input)
(#.Cons [head tail])
(#try.Success [tail head]))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/analysis.lux b/stdlib/source/lux/tool/compiler/language/lux/analysis.lux
index 27bc09652..c9bc95612 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/analysis.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/analysis.lux
@@ -1,6 +1,7 @@
(.module:
[lux (#- nat int rev)
[abstract
+ [equivalence (#+ Equivalence)]
[monad (#+ do)]]
[control
["." function]
@@ -9,8 +10,12 @@
[data
["." product]
["." maybe]
+ ["." bit ("#@." equivalence)]
[number
- ["n" nat]]
+ ["n" nat]
+ ["i" int]
+ ["r" rev]
+ ["f" frac]]
["." text ("#@." equivalence)
["%" format (#+ Format format)]]
[collection
@@ -21,7 +26,8 @@
[///
[arity (#+ Arity)]
[version (#+ Version)]
- ["." reference (#+ Register Variable Reference)]
+ ["." reference (#+ Reference)
+ ["." variable (#+ Register Variable)]]
["." phase]]])
(type: #export #rec Primitive
@@ -76,6 +82,103 @@
(type: #export Match
(Match' Analysis))
+(structure: primitive-equivalence
+ (Equivalence Primitive)
+
+ (def: (= reference sample)
+ (case [reference sample]
+ [#Unit #Unit]
+ true
+
+ (^template [<tag> <=>]
+ [(<tag> reference) (<tag> sample)]
+ (<=> reference sample))
+ ([#Bit bit@=]
+ [#Nat n.=]
+ [#Int i.=]
+ [#Rev r.=]
+ [#Frac f.=]
+ [#Text text@=])
+
+ _
+ false)))
+
+(structure: (composite-equivalence (^open "/@."))
+ (All [a] (-> (Equivalence a) (Equivalence (Composite a))))
+
+ (def: (= reference sample)
+ (case [reference sample]
+ [(#Variant [reference-lefts reference-right? reference-value])
+ (#Variant [sample-lefts sample-right? sample-value])]
+ (and (n.= reference-lefts sample-lefts)
+ (bit@= reference-right? sample-right?)
+ (/@= reference-value sample-value))
+
+ [(#Tuple reference) (#Tuple sample)]
+ (:: (list.equivalence /@=) = reference sample)
+
+ _
+ false)))
+
+(structure: pattern-equivalence
+ (Equivalence Pattern)
+
+ (def: (= reference sample)
+ (case [reference sample]
+ [(#Simple reference) (#Simple sample)]
+ (:: primitive-equivalence = reference sample)
+
+ [(#Complex reference) (#Complex sample)]
+ (:: (composite-equivalence =) = reference sample)
+
+ [(#Bind reference) (#Bind sample)]
+ (n.= reference sample)
+
+ _
+ false)))
+
+(structure: (branch-equivalence equivalence)
+ (-> (Equivalence Analysis) (Equivalence Branch))
+
+ (def: (= [reference-pattern reference-body] [sample-pattern sample-body])
+ (and (:: pattern-equivalence = reference-pattern sample-pattern)
+ (:: equivalence = reference-body sample-body))))
+
+(structure: #export equivalence
+ (Equivalence Analysis)
+
+ (def: (= reference sample)
+ (case [reference sample]
+ [(#Primitive reference) (#Primitive sample)]
+ (:: primitive-equivalence = reference sample)
+
+ [(#Structure reference) (#Structure sample)]
+ (:: (composite-equivalence =) = reference sample)
+
+ [(#Reference reference) (#Reference sample)]
+ (:: reference.equivalence = reference sample)
+
+ [(#Case [reference-analysis reference-match])
+ (#Case [sample-analysis sample-match])]
+ (and (= reference-analysis sample-analysis)
+ (:: (list.equivalence (branch-equivalence =)) = (#.Cons reference-match) (#.Cons sample-match)))
+
+ [(#Function [reference-environment reference-analysis])
+ (#Function [sample-environment sample-analysis])]
+ (and (= reference-analysis sample-analysis)
+ (:: (list.equivalence variable.equivalence) = reference-environment sample-environment))
+
+ [(#Apply [reference-input reference-abstraction])
+ (#Apply [sample-input sample-abstraction])]
+ (and (= reference-input sample-input)
+ (= reference-abstraction sample-abstraction))
+
+ [(#Extension reference) (#Extension sample)]
+ (:: (extension.equivalence =) = reference sample)
+
+ _
+ false)))
+
(template [<name> <tag>]
[(template: #export (<name> content)
(<tag> content))]
@@ -104,7 +207,7 @@
(n.= (dec size) tag))
(template: #export (no-op value)
- (|> 1 #reference.Local #reference.Variable #..Reference
+ (|> 1 #variable.Local #reference.Variable #..Reference
(#..Function (list))
(#..Apply value)))
@@ -207,12 +310,7 @@
(text.enclose ["[" "]"])))
(#Reference reference)
- (case reference
- (#reference.Variable variable)
- (reference.%variable variable)
-
- (#reference.Constant constant)
- (%.name constant))
+ (reference.format reference)
(#Case analysis match)
"{?}"
@@ -221,7 +319,7 @@
(|> (%analysis body)
(format " ")
(format (|> environment
- (list@map reference.%variable)
+ (list@map variable.format)
(text.join-with " ")
(text.enclose ["[" "]"])))
(text.enclose ["(" ")"]))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/scope.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/scope.lux
index d68d3fed7..ffa635109 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/scope.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/scope.lux
@@ -18,7 +18,8 @@
[//
["/" analysis (#+ Operation Phase)]
[///
- ["." reference (#+ Register Variable)]
+ [reference
+ ["." variable (#+ Register Variable)]]
["#" phase]]]])
(type: Local (Bindings Text [Type Register]))
@@ -36,7 +37,7 @@
(get@ [#.locals #.mappings])
(plist.get name)
(maybe@map (function (_ [type value])
- [type (#reference.Local value)]))))
+ [type (#variable.Local value)]))))
(def: (captured? name scope)
(-> Text Scope Bit)
@@ -51,7 +52,7 @@
(case mappings
(#.Cons [_name [_source-type _source-ref]] mappings')
(if (text@= name _name)
- (#.Some [_source-type (#reference.Foreign idx)])
+ (#.Some [_source-type (#variable.Foreign idx)])
(recur (inc idx) mappings'))
#.Nil
@@ -87,7 +88,7 @@
(..reference name top-outer))
[ref inner'] (list@fold (: (-> Scope [Variable (List Scope)] [Variable (List Scope)])
(function (_ scope ref+inner)
- [(#reference.Foreign (get@ [#.captured #.counter] scope))
+ [(#variable.Foreign (get@ [#.captured #.counter] scope))
(#.Cons (update@ #.captured
(: (-> Foreign Foreign)
(|>> (update@ #.counter inc)
@@ -101,11 +102,8 @@
(#.Some [ref-type ref])]))
)))))
-(exception: #export (cannot-create-local-binding-without-a-scope)
- "")
-
-(exception: #export (invalid-scope-alteration)
- "")
+(exception: #export cannot-create-local-binding-without-a-scope)
+(exception: #export invalid-scope-alteration)
(def: #export (with-local [name type] action)
(All [a] (-> [Text Type] (Operation a) (Operation a)))
@@ -195,10 +193,10 @@
(-> Ref Variable)
(case ref
(#.Local register)
- (#reference.Local register)
+ (#variable.Local register)
(#.Captured register)
- (#reference.Foreign register)))
+ (#variable.Foreign register)))
(def: #export (environment scope)
(-> Scope (List Variable))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux
index 8498c0321..2cc5c42b8 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux
@@ -1,6 +1,7 @@
(.module:
[lux (#- Name)
[abstract
+ [equivalence (#+ Equivalence)]
["." monad (#+ do)]]
[control
["." function]
@@ -19,8 +20,15 @@
(type: #export Name Text)
-(type: #export (Extension i)
- [Name (List i)])
+(type: #export (Extension a)
+ [Name (List a)])
+
+(structure: #export (equivalence input-equivalence)
+ (All [a] (-> (Equivalence a) (Equivalence (Extension a))))
+
+ (def: (= [reference-name reference-inputs] [sample-name sample-inputs])
+ (and (text@= reference-name sample-name)
+ (:: (list.equivalence input-equivalence) = reference-inputs sample-inputs))))
(with-expansions [<Bundle> (as-is (Dictionary Name (Handler s i o)))]
(type: #export (Handler s i o)
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux
index 026b31c70..005563f1a 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux
@@ -63,7 +63,8 @@
["#." generation]
[///
["#" phase]
- ["#." reference (#+ Variable)]
+ [reference (#+)
+ ["#." variable (#+ Variable)]]
[meta
["." archive (#+ Archive)]]]]]])
@@ -897,6 +898,9 @@
(^ (//////synthesis.branch/if [testS thenS elseS]))
(//////synthesis.branch/if [(recur testS) (recur thenS) (recur elseS)])
+ (^ (//////synthesis.branch/get [path recordS]))
+ (//////synthesis.branch/get [path (recur recordS)])
+
(^ (//////synthesis.loop/scope [offset initsS+ bodyS]))
(//////synthesis.loop/scope [offset (list@map recur initsS+) (recur bodyS)])
@@ -1006,14 +1010,14 @@
## Combine them.
list@join
## Remove duplicates.
- (set.from-list //////reference.hash)
+ (set.from-list //////variable.hash)
set.to-list)
global-mapping (|> total-environment
## Give them names as "foreign" variables.
list.enumerate
(list@map (function (_ [id capture])
- [capture (#//////reference.Foreign id)]))
- (dictionary.from-list //////reference.hash))
+ [capture (#//////variable.Foreign id)]))
+ (dictionary.from-list //////variable.hash))
normalized-methods (list@map (function (_ [environment
[ownerT name
strict-fp? annotations vars
@@ -1022,11 +1026,11 @@
(let [local-mapping (|> environment
list.enumerate
(list@map (function (_ [foreign-id capture])
- [(#//////reference.Foreign foreign-id)
+ [(#//////variable.Foreign foreign-id)
(|> global-mapping
(dictionary.get capture)
maybe.assume)]))
- (dictionary.from-list //////reference.hash))]
+ (dictionary.from-list //////variable.hash))]
[ownerT name
strict-fp? annotations vars
self-name arguments returnT exceptionsT
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm.lux
index b552f16d5..5ede5f926 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm.lux
@@ -53,6 +53,9 @@
(^ (synthesis.branch/if [conditionS thenS elseS]))
(/case.if generate archive [conditionS thenS elseS])
+ (^ (synthesis.branch/get [path recordS]))
+ (/case.get generate archive [path recordS])
+
(^ (synthesis.loop/scope scope))
(/loop.scope generate archive scope)
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux
index 9abfe1f55..0d94ac026 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux
@@ -7,7 +7,9 @@
[data
[number
["." i32]
- ["n" nat]]]
+ ["n" nat]]
+ [collection
+ ["." list ("#@." fold)]]]
[target
[jvm
["_" bytecode (#+ Label Bytecode) ("#@." monad)]
@@ -21,8 +23,9 @@
["." synthesis (#+ Path Synthesis)]
["." generation]
[///
- [reference (#+ Register)]
- ["." phase ("operation@." monad)]]]])
+ ["." phase ("operation@." monad)]
+ [reference
+ [variable (#+ Register)]]]]])
(def: equals-name
"equals")
@@ -65,6 +68,25 @@
(//runtime.get //runtime.stack-tail)
(_.checkcast //type.stack)))
+(def: (left-projection lefts)
+ (-> Nat (Bytecode Any))
+ ($_ _.compose
+ (_.checkcast //type.tuple)
+ (..int lefts)
+ (.case lefts
+ 0
+ _.aaload
+
+ lefts
+ //runtime.left-projection)))
+
+(def: (right-projection lefts)
+ (-> Nat (Bytecode Any))
+ ($_ _.compose
+ (_.checkcast //type.tuple)
+ (..int lefts)
+ //runtime.right-projection))
+
(def: (path' stack-depth @else @end phase archive path)
(-> Nat Label Label (Generator Path))
(.case path
@@ -138,25 +160,15 @@
[synthesis.side/right //runtime.right-flag .inc])
(^ (synthesis.member/left lefts))
- (operation@wrap (.let [optimized-projection (.case lefts
- 0
- _.aaload
-
- lefts
- //runtime.left-projection)]
- ($_ _.compose
- ..peek
- (_.checkcast //type.tuple)
- (..int lefts)
- optimized-projection
- //runtime.push)))
+ (operation@wrap ($_ _.compose
+ ..peek
+ (..left-projection lefts)
+ //runtime.push))
(^ (synthesis.member/right lefts))
(operation@wrap ($_ _.compose
..peek
- (_.checkcast //type.tuple)
- (..int lefts)
- //runtime.right-projection
+ (..right-projection lefts)
//runtime.push))
## Extra optimization
@@ -253,6 +265,21 @@
(_.astore register)
bodyG))))
+(def: #export (get phase archive [path recordS])
+ (Generator [(List synthesis.Member) Synthesis])
+ (do phase.monad
+ [recordG (phase archive recordS)]
+ (wrap (list@fold (function (_ step so-far)
+ (.let [next (.case step
+ (#.Left lefts)
+ (..left-projection lefts)
+
+ (#.Right lefts)
+ (..right-projection lefts))]
+ (_.compose so-far next)))
+ recordG
+ path))))
+
(def: #export (case phase archive [valueS path])
(Generator [Synthesis Path])
(do phase.monad
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux
index 788919379..4359d7815 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux
@@ -52,9 +52,10 @@
[synthesis (#+ Synthesis Abstraction Apply)]
["." generation]
[///
- [reference (#+ Register)]
["." arity (#+ Arity)]
- ["." phase]]]]])
+ ["." phase]
+ [reference
+ [variable (#+ Register)]]]]]])
(def: #export (with archive @begin class environment arity body)
(-> Archive Label External Environment Arity (Bytecode Any)
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable.lux
index c491039b9..13865b17e 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable.lux
@@ -17,7 +17,8 @@
["#." type]
["#." reference]
[//////
- [reference (#+ Register)]]])
+ [reference
+ [variable (#+ Register)]]]])
(def: #export type ////type.value)
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux
index b9e97ddfd..14b4f6cab 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux
@@ -18,7 +18,8 @@
[////
[analysis (#+ Environment)]
[///
- [reference (#+ Register)]]]]])
+ [reference
+ [variable (#+ Register)]]]]]])
(def: #export (closure environment)
(-> Environment (List (Type Value)))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux
index b44cb4102..57271de30 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux
@@ -25,8 +25,9 @@
["//#" /// #_
["#." reference]
[//////
- [reference (#+ Register)]
- ["." arity (#+ Arity)]]]]]])
+ ["." arity (#+ Arity)]
+ [reference
+ [variable (#+ Register)]]]]]]])
(def: #export (initial amount)
(-> Nat (Bytecode Any))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/apply.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/apply.lux
index 592c798ec..cafb6ceeb 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/apply.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/apply.lux
@@ -42,7 +42,8 @@
[analysis (#+ Environment)]
[///
[arity (#+ Arity)]
- ["." reference (#+ Register)]]]]]])
+ [reference
+ [variable (#+ Register)]]]]]]])
(def: (increment by)
(-> Nat (Bytecode Any))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/init.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/init.lux
index 5c39bd145..cf1ad20df 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/init.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/init.lux
@@ -35,8 +35,9 @@
[////
[analysis (#+ Environment)]
[///
- [reference (#+ Register)]
- ["." arity (#+ Arity)]]]]]])
+ ["." arity (#+ Arity)]
+ [reference
+ [variable (#+ Register)]]]]]]])
(def: #export name "<init>")
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/loop.lux
index 5e07ea35a..0f79b6e86 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/loop.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/loop.lux
@@ -20,8 +20,9 @@
["." synthesis (#+ Path Synthesis)]
["." generation]
[///
- [reference (#+ Register)]
- ["." phase]]]])
+ ["." phase]
+ [reference
+ [variable (#+ Register)]]]]])
(def: (invariant? register changeS)
(-> Register Synthesis Bit)
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux
index 7bd43b8aa..b21c899e0 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux
@@ -20,7 +20,8 @@
["." generation]
[///
["#" phase ("operation@." monad)]
- ["." reference (#+ Register Variable)]
+ [reference
+ ["." variable (#+ Register Variable)]]
[meta
[archive (#+ Archive)]]]]]])
@@ -51,10 +52,10 @@
(def: #export (variable archive variable)
(-> Archive Variable (Operation (Bytecode Any)))
(case variable
- (#reference.Local variable)
+ (#variable.Local variable)
(operation@wrap (_.aload variable))
- (#reference.Foreign variable)
+ (#variable.Foreign variable)
(..foreign archive variable)))
(def: #export (constant archive name)
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux
index 304629c6f..41153f29c 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux
@@ -50,7 +50,8 @@
[///
["#" phase]
[arity (#+ Arity)]
- [reference (#+ Register)]
+ [reference
+ [variable (#+ Register)]]
["." meta
[io (#+ lux-context)]
[archive (#+ Archive)]]]]]])
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux
index 149d3e69a..8d3b7b2d5 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux
@@ -20,8 +20,9 @@
["#." analysis (#+ Pattern Match Analysis)]
["/" synthesis (#+ Path Synthesis Operation Phase)]
[///
- ["#." reference (#+ Variable)]
["#" phase ("#@." monad)]
+ ["#." reference
+ ["#/." variable (#+ Register Variable)]]
[meta
[archive (#+ Archive)]]]]])
@@ -76,11 +77,11 @@
(list.reverse (list.enumerate tuple))))
))
-(def: #export (path archive synthesize pattern bodyA)
+(def: (path archive synthesize pattern bodyA)
(-> Archive Phase Pattern Analysis (Operation Path))
(path' pattern true (///@map (|>> #/.Then) (synthesize archive bodyA))))
-(def: #export (weave leftP rightP)
+(def: (weave leftP rightP)
(-> Path Path Path)
(with-expansions [<default> (as-is (#/.Alt leftP rightP))]
(case [leftP rightP]
@@ -126,54 +127,127 @@
_
<default>)))
+(def: (get patterns @selection)
+ (-> (///analysis.Tuple ///analysis.Pattern) Register (List /.Member))
+ (loop [lefts 0
+ patterns patterns]
+ (with-expansions [<failure> (as-is (list))
+ <continue> (as-is (recur (inc lefts)
+ tail))
+ <member> (as-is (if (list.empty? tail)
+ (#.Right (dec lefts))
+ (#.Left lefts)))]
+ (case patterns
+ #.Nil
+ <failure>
+
+ (#.Cons head tail)
+ (case head
+ (#///analysis.Simple #///analysis.Unit)
+ <continue>
+
+ (#///analysis.Bind register)
+ (if (n.= @selection register)
+ (list <member>)
+ <continue>)
+
+ (#///analysis.Complex (#///analysis.Tuple sub-patterns))
+ (case (get sub-patterns @selection)
+ #.Nil
+ <continue>
+
+ sub-members
+ (list& <member> sub-members))
+
+ _
+ <failure>)))))
+
+(def: #export (synthesize-case synthesize archive input [headB tailB+])
+ (-> Phase Archive Synthesis Match (Operation Synthesis))
+ (let [[[lastP lastA] prevsPA] (|> (#.Cons headB tailB+)
+ list.reverse
+ (case> (#.Cons [lastP lastA] prevsPA)
+ [[lastP lastA] prevsPA]
+
+ _
+ (undefined)))]
+ (do {@ ///.monad}
+ [lastSP (path archive synthesize lastP lastA)
+ prevsSP+ (monad.map @ (product.uncurry (path archive synthesize)) prevsPA)]
+ (wrap (/.branch/case [input (list@fold weave lastSP prevsSP+)])))))
+
+(template: (!masking <variable> <output>)
+ [[(#///analysis.Bind <variable>)
+ (#///analysis.Reference (///reference.local <output>))]
+ (list)])
+
+(def: #export (synthesize-masking synthesize archive input @variable @output)
+ (-> Phase Archive Synthesis Register Register (Operation Synthesis))
+ (if (n.= @variable @output)
+ (///@wrap input)
+ (..synthesize-case synthesize archive input (!masking @variable @output))))
+
+(def: #export (synthesize-let synthesize archive input @variable body)
+ (-> Phase Archive Synthesis Register Analysis (Operation Synthesis))
+ (do ///.monad
+ [body (/.with-new-local
+ (synthesize archive body))]
+ (wrap (/.branch/let [input @variable body]))))
+
+(def: #export (synthesize-if synthesize archive test then else)
+ (-> Phase Archive Synthesis Analysis Analysis (Operation Synthesis))
+ (do ///.monad
+ [then (synthesize archive then)
+ else (synthesize archive else)]
+ (wrap (/.branch/if [test then else]))))
+
+(template: (!get <patterns> <output>)
+ [[(///analysis.pattern/tuple <patterns>)
+ (#///analysis.Reference (///reference.local <output>))]
+ (.list)])
+
+(def: #export (synthesize-get synthesize archive input patterns @member)
+ (-> Phase Archive Synthesis (///analysis.Tuple ///analysis.Pattern) Register (Operation Synthesis))
+ (case (..get patterns @member)
+ #.Nil
+ (..synthesize-case synthesize archive input (!get patterns @member))
+
+ path
+ (case input
+ (^ (/.branch/get [sub-path sub-input]))
+ (///@wrap (/.branch/get [(list@compose path sub-path) sub-input]))
+
+ _
+ (///@wrap (/.branch/get [path input])))))
+
(def: #export (synthesize synthesize^ [headB tailB+] archive inputA)
(-> Phase Match Phase)
(do {@ ///.monad}
[inputS (synthesize^ archive inputA)]
- (with-expansions [<unnecesary-let>
- (as-is (^multi (^ (#///analysis.Reference (///reference.local outputR)))
- (n.= inputR outputR))
- (wrap inputS))
-
- <let>
- (as-is [[(#///analysis.Bind inputR) headB/bodyA]
- #.Nil]
- (case headB/bodyA
- <unnecesary-let>
-
- _
- (do @
- [headB/bodyS (/.with-new-local
- (synthesize^ archive headB/bodyA))]
- (wrap (/.branch/let [inputS inputR headB/bodyS])))))
-
- <if>
- (as-is (^or (^ [[(///analysis.pattern/bit #1) thenA]
- (list [(///analysis.pattern/bit #0) elseA])])
- (^ [[(///analysis.pattern/bit #0) elseA]
- (list [(///analysis.pattern/bit #1) thenA])]))
- (do @
- [thenS (synthesize^ archive thenA)
- elseS (synthesize^ archive elseA)]
- (wrap (/.branch/if [inputS thenS elseS]))))
-
- <case>
- (as-is _
- (let [[[lastP lastA] prevsPA] (|> (#.Cons headB tailB+)
- list.reverse
- (case> (#.Cons [lastP lastA] prevsPA)
- [[lastP lastA] prevsPA]
-
- _
- (undefined)))]
- (do @
- [lastSP (path archive synthesize^ lastP lastA)
- prevsSP+ (monad.map @ (product.uncurry (path archive synthesize^)) prevsPA)]
- (wrap (/.branch/case [inputS (list@fold weave lastSP prevsSP+)])))))]
- (case [headB tailB+]
- <let>
- <if>
- <case>))))
+ (case [headB tailB+]
+ (^ (!masking @variable @output))
+ (..synthesize-masking synthesize^ archive inputS @variable @output)
+
+ [[(#///analysis.Bind @variable) body]
+ #.Nil]
+ (..synthesize-let synthesize^ archive inputS @variable body)
+
+ (^or (^ [[(///analysis.pattern/bit #1) then]
+ (list [(///analysis.pattern/bit #0) else])])
+ (^ [[(///analysis.pattern/bit #1) then]
+ (list [(///analysis.pattern/unit) else])])
+
+ (^ [[(///analysis.pattern/bit #0) else]
+ (list [(///analysis.pattern/bit #1) then])])
+ (^ [[(///analysis.pattern/bit #0) else]
+ (list [(///analysis.pattern/unit) then])]))
+ (..synthesize-if synthesize^ archive inputS then else)
+
+ (^ (!get patterns @member))
+ (..synthesize-get synthesize^ archive inputS patterns @member)
+
+ match
+ (..synthesize-case synthesize^ archive inputS match))))
(def: #export (count-pops path)
(-> Path [Nat Path])
@@ -194,13 +268,13 @@
(def: empty
Storage
- {#bindings (set.new ///reference.hash)
- #dependencies (set.new ///reference.hash)})
+ {#bindings (set.new ///reference/variable.hash)
+ #dependencies (set.new ///reference/variable.hash)})
## TODO: Use this to declare all local variables at the beginning of
## script functions.
## That way, it should be possible to do cheap "let" expressions,
-## since the variable will exist before hand so no closure will need
+## since the variable will exist beforehand, so no closure will need
## to be created for it.
## Apply this trick to JS, Python et al.
(def: #export (storage path)
@@ -210,7 +284,7 @@
path-storage ..empty]
(case path
(^ (/.path/bind register))
- (update@ #bindings (set.add (#///reference.Local register))
+ (update@ #bindings (set.add (#///reference/variable.Local register))
path-storage)
(^or (^ (/.path/seq left right))
@@ -245,7 +319,7 @@
(^ (/.branch/let [inputS register exprS]))
(list@fold for-synthesis
- (update@ #bindings (set.add (#///reference.Local register))
+ (update@ #bindings (set.add (#///reference/variable.Local register))
synthesis-storage)
(list inputS exprS))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux
index 02258a7b1..e34c78f71 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux
@@ -9,8 +9,7 @@
["." text
["%" format (#+ format)]]
[collection
- ["." list ("#@." functor monoid fold)]
- ["dict" dictionary (#+ Dictionary)]]]]
+ ["." list ("#@." functor monoid fold)]]]]
["." // #_
["#." loop (#+ Transform)]
["//#" /// #_
@@ -18,13 +17,14 @@
["/" synthesis (#+ Path Synthesis Operation Phase)]
[///
[arity (#+ Arity)]
- ["#." reference (#+ Register Variable)]
+ ["#." reference
+ ["#/." variable (#+ Register Variable)]]
["." phase ("#@." monad)]]]])
(exception: #export (cannot-find-foreign-variable-in-environment {foreign Register} {environment Environment})
(ex.report ["Foreign" (%.nat foreign)]
["Environment" (|> environment
- (list@map ////reference.%variable)
+ (list@map ////reference/variable.format)
(text.join-with " "))]))
(def: arity-arguments
@@ -98,10 +98,10 @@
(monad.map phase.monad
(function (_ variable)
(case variable
- (#////reference.Local register)
- (phase@wrap (#////reference.Local (inc register)))
+ (#////reference/variable.Local register)
+ (phase@wrap (#////reference/variable.Local (inc register)))
- (#////reference.Foreign register)
+ (#////reference/variable.Foreign register)
(find-foreign super register)))
sub))
@@ -127,10 +127,10 @@
(case reference
(#////reference.Variable variable)
(case variable
- (#////reference.Local register)
+ (#////reference/variable.Local register)
(phase@wrap (/.variable/local (inc register)))
- (#////reference.Foreign register)
+ (#////reference/variable.Foreign register)
(|> register
(find-foreign environment)
(phase@map (|>> /.variable))))
@@ -154,6 +154,11 @@
thenS' (grow environment thenS)
elseS' (grow environment elseS)]
(wrap (/.branch/if [testS' thenS' elseS'])))
+
+ (#/.Get members inputS)
+ (do phase.monad
+ [inputS' (grow environment inputS)]
+ (wrap (/.branch/get [members inputS'])))
(#/.Case [inputS pathS])
(do phase.monad
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux
index f4cc28012..5aa644e18 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux
@@ -5,11 +5,11 @@
[control
["p" parser]]
[data
- ["." maybe ("#;." monad)]
+ ["." maybe ("#@." monad)]
[number
["n" nat]]
[collection
- ["." list ("#;." functor)]]]
+ ["." list ("#@." functor)]]]
[macro
["." code]
["." syntax]]]
@@ -20,7 +20,8 @@
["#." analysis (#+ Environment)]
["/" synthesis (#+ Path Abstraction Synthesis)]
[///
- ["#." reference (#+ Register Variable)]]]])
+ ["#." reference
+ ["#/." variable (#+ Register Variable)]]]]])
(type: #export (Transform a)
(-> a (Maybe a)))
@@ -44,7 +45,7 @@
(-> Synthesis Bit)
(case exprS
(^ (self))
- improper
+ ..improper
(#/.Structure structure)
(case structure
@@ -69,7 +70,7 @@
(proper? bodyS)
_
- proper)))
+ ..proper)))
(#/.Let inputS register bodyS)
(and (proper? inputS)
@@ -78,7 +79,10 @@
(#/.If inputS thenS elseS)
(and (proper? inputS)
(proper? thenS)
- (proper? elseS)))
+ (proper? elseS))
+
+ (#/.Get members inputS)
+ (proper? inputS))
(#/.Loop loopS)
(case loopS
@@ -92,7 +96,7 @@
(#/.Function functionS)
(case functionS
(#/.Abstraction environment arity bodyS)
- (list.every? ///reference.self? environment)
+ (list.every? ///reference/variable.self? environment)
(#/.Apply funcS argsS)
(and (proper? funcS)
@@ -102,7 +106,7 @@
(list.every? proper? argsS)
_
- proper))
+ ..proper))
(def: (path-recursion synthesis-recursion)
(-> (Transform Synthesis) (Transform Path))
@@ -118,10 +122,10 @@
#.None))
(#/.Seq leftS rightS)
- (maybe;map (|>> (#/.Seq leftS)) (recur rightS))
+ (maybe@map (|>> (#/.Seq leftS)) (recur rightS))
(#/.Then bodyS)
- (maybe;map (|>> #/.Then) (synthesis-recursion bodyS))
+ (maybe@map (|>> #/.Then) (synthesis-recursion bodyS))
_
#.None)))
@@ -137,10 +141,10 @@
(#/.Case inputS pathS)
(|> pathS
(path-recursion recur)
- (maybe;map (|>> (#/.Case inputS) #/.Branch #/.Control)))
+ (maybe@map (|>> (#/.Case inputS) #/.Branch #/.Control)))
(#/.Let inputS register bodyS)
- (maybe;map (|>> (#/.Let inputS register) #/.Branch #/.Control)
+ (maybe@map (|>> (#/.Let inputS register) #/.Branch #/.Control)
(recur bodyS))
(#/.If inputS thenS elseS)
@@ -152,7 +156,10 @@
(maybe.default thenS thenS')
(maybe.default elseS elseS'))
#/.Branch #/.Control))
- #.None)))
+ #.None))
+
+ (#/.Get members inputS)
+ #.None)
(^ (#/.Function (recursive-apply argsS)))
(if (n.= arity (list.size argsS))
@@ -169,7 +176,7 @@
(-> Environment (Transform Variable))
(function (_ variable)
(case variable
- (#///reference.Foreign register)
+ (#///reference/variable.Foreign register)
(list.nth register environment)
_
@@ -191,7 +198,7 @@
([#/.Alt] [#/.Seq])
(#/.Then bodyS)
- (|> bodyS adjust-synthesis (maybe;map (|>> #/.Then)))
+ (|> bodyS adjust-synthesis (maybe@map (|>> #/.Then)))
_
(#.Some pathS))))
@@ -213,7 +220,7 @@
(#///analysis.Tuple membersS+)
(|> membersS+
(monad.map maybe.monad recur)
- (maybe;map (|>> #///analysis.Tuple #/.Structure))))
+ (maybe@map (|>> #///analysis.Tuple #/.Structure))))
(#/.Reference reference)
(case reference
@@ -226,7 +233,7 @@
(^ (///reference.foreign register))
(|> scope-environment
(list.nth register)
- (maybe;map (|>> #///reference.Variable #/.Reference))))
+ (maybe@map (|>> #///reference.Variable #/.Reference))))
(^ (/.branch/case [inputS pathS]))
(do maybe.monad
@@ -260,7 +267,7 @@
(^ (/.loop/recur argsS))
(|> argsS
(monad.map maybe.monad recur)
- (maybe;map (|>> /.loop/recur)))
+ (maybe@map (|>> /.loop/recur)))
(^ (/.function/abstraction [environment arity bodyS]))
@@ -279,7 +286,7 @@
(#/.Extension [name argsS])
(|> argsS
(monad.map maybe.monad recur)
- (maybe;map (|>> [name] #/.Extension)))
+ (maybe@map (|>> [name] #/.Extension)))
_
(#.Some exprS))))
@@ -292,5 +299,5 @@
(proper? bodyS))
(|> bodyS
(adjust environment num-locals)
- (maybe;map (|>> [(inc num-locals) inits] /.loop/scope)))
+ (maybe@map (|>> [(inc num-locals) inits] /.loop/scope)))
#.None)))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux b/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux
index 7519df0a2..a88d986fc 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux
@@ -6,15 +6,15 @@
[control
["ex" exception (#+ exception:)]]
[data
- ["." bit ("#;." equivalence)]
- ["." text ("#;." equivalence)
+ ["." bit ("#@." equivalence)]
+ ["." text ("#@." equivalence)
["%" format (#+ Format format)]]
[number
["n" nat]
["i" int]
["f" frac]]
[collection
- ["." list ("#;." functor)]
+ ["." list ("#@." functor)]
["." dictionary (#+ Dictionary)]]]]
["." // #_
["#." analysis (#+ Environment Composite Analysis)]
@@ -22,7 +22,8 @@
["." extension (#+ Extension)]]
[///
[arity (#+ Arity)]
- ["#." reference (#+ Register Variable Reference)]
+ ["#." reference (#+ Reference)
+ ["#/." variable (#+ Register Variable)]]
["#." phase]]])
(type: #export Resolver (Dictionary Variable Variable))
@@ -32,7 +33,7 @@
(def: #export fresh-resolver
Resolver
- (dictionary.new //reference.hash))
+ (dictionary.new //reference/variable.hash))
(def: #export init
State
@@ -75,6 +76,7 @@
(type: #export (Branch s)
(#Let s Register s)
(#If s s s)
+ (#Get (List Member) s)
(#Case s (Path' s)))
(type: #export (Scope s)
@@ -246,6 +248,7 @@
[branch/case #..Branch #..Case]
[branch/let #..Branch #..Let]
[branch/if #..Branch #..If]
+ [branch/get #..Branch #..Get]
[loop/recur #..Loop #..Recur]
[loop/scope #..Loop #..Scope]
@@ -331,12 +334,12 @@
(#//analysis.Tuple members)
(|> members
- (list;map %synthesis)
+ (list@map %synthesis)
(text.join-with " ")
(text.enclose ["[" "]"])))
(#Reference reference)
- (//reference.%reference reference)
+ (//reference.format reference)
(#Control control)
(case control
@@ -346,14 +349,14 @@
(|> (%synthesis body)
(format (%.nat arity) " ")
(format (|> environment
- (list;map //reference.%variable)
+ (list@map //reference/variable.format)
(text.join-with " ")
(text.enclose ["[" "]"]))
" ")
(text.enclose ["(" ")"]))
(#Apply func args)
- (|> (list;map %synthesis args)
+ (|> (list@map %synthesis args)
(text.join-with " ")
(format (%synthesis func) " ")
(text.enclose ["(" ")"])))
@@ -367,6 +370,12 @@
(#If test then else)
(|> (format (%synthesis test) " " (%synthesis then) " " (%synthesis else))
(text.enclose ["(#if " ")"]))
+
+ (#Get members record)
+ (|> (format (%.list (%path' %synthesis)
+ (list@map (|>> #Member #Access) members))
+ " " (%synthesis record))
+ (text.enclose ["(#get " ")"]))
(#Case input path)
(|> (format (%synthesis input) " " (%path' %synthesis path))
@@ -377,7 +386,7 @@
"???")
(#Extension [name args])
- (|> (list;map %synthesis args)
+ (|> (list@map %synthesis args)
(text.join-with " ")
(format (%.text name))
(text.enclose ["(" ")"]))))
@@ -392,9 +401,9 @@
(^template [<tag> <eq> <format>]
[(<tag> reference') (<tag> sample')]
(<eq> reference' sample'))
- ([#Bit bit;= %.bit]
+ ([#Bit bit@= %.bit]
[#F64 f.= %.frac]
- [#Text text;= %.text])
+ [#Text text@= %.text])
[(#I64 reference') (#I64 sample')]
(i.= (.int reference') (.int sample'))
diff --git a/stdlib/source/lux/tool/compiler/reference.lux b/stdlib/source/lux/tool/compiler/reference.lux
index 79f6c921e..abcbe1162 100644
--- a/stdlib/source/lux/tool/compiler/reference.lux
+++ b/stdlib/source/lux/tool/compiler/reference.lux
@@ -1,46 +1,38 @@
(.module:
[lux #*
[abstract
- [equivalence (#+ Equivalence)]
- [hash (#+ Hash)]]
+ [equivalence (#+ Equivalence)]]
[control
- pipe]
+ [pipe (#+ case>)]]
[data
+ ["." name]
[number
["n" nat]]
[text
- ["%" format (#+ Format format)]]]])
+ ["%" format (#+ Format)]]]]
+ ["." / #_
+ ["#." variable (#+ Variable)]])
-(type: #export Register Nat)
-
-(type: #export Variable
- (#Local Register)
- (#Foreign Register))
+(type: #export Constant
+ Name)
(type: #export Reference
(#Variable Variable)
- (#Constant Name))
+ (#Constant Constant))
+
+(structure: #export equivalence
+ (Equivalence Reference)
-(structure: #export equivalence (Equivalence Variable)
(def: (= reference sample)
(case [reference sample]
- (^template [<tag>]
- [(<tag> reference') (<tag> sample')]
- (n.= reference' sample'))
- ([#Local] [#Foreign])
+ (^template [<tag> <equivalence>]
+ [(<tag> reference) (<tag> sample)]
+ (:: <equivalence> = reference sample))
+ ([#Variable /variable.equivalence]
+ [#Constant name.equivalence])
_
- #0)))
-
-(structure: #export hash (Hash Variable)
- (def: &equivalence ..equivalence)
- (def: (hash var)
- (case var
- (#Local register)
- (n.* 1 register)
-
- (#Foreign register)
- (n.* 2 register))))
+ false)))
(template [<name> <family> <tag>]
[(template: #export (<name> content)
@@ -48,8 +40,8 @@
<tag>
content))]
- [local #..Variable #..Local]
- [foreign #..Variable #..Foreign]
+ [local #..Variable #/variable.Local]
+ [foreign #..Variable #/variable.Foreign]
)
(template [<name> <tag>]
@@ -63,29 +55,10 @@
(def: #export self Reference (..local 0))
-(def: #export self?
- (-> Variable Bit)
- (|>> ..variable
- (case> (^ (..local 0))
- #1
-
- _
- #0)))
-
-(def: #export (%variable variable)
- (Format Variable)
- (case variable
- (#Local local)
- (format "+" (%.nat local))
-
- (#Foreign foreign)
- (format "-" (%.nat foreign))))
-
-(def: #export (%reference reference)
+(def: #export format
(Format Reference)
- (case reference
- (#Variable variable)
- (%variable variable)
-
- (#Constant constant)
- (%.name constant)))
+ (|>> (case> (#Variable variable)
+ (/variable.format variable)
+
+ (#Constant constant)
+ (%.name constant))))
diff --git a/stdlib/source/lux/tool/compiler/reference/variable.lux b/stdlib/source/lux/tool/compiler/reference/variable.lux
new file mode 100644
index 000000000..10c080c6e
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/reference/variable.lux
@@ -0,0 +1,59 @@
+(.module:
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [hash (#+ Hash)]]
+ [control
+ [pipe (#+ case>)]]
+ [data
+ [number
+ ["n" nat]
+ ["i" int]]
+ [text
+ ["%" format (#+ Format)]]]])
+
+(type: #export Register Nat)
+
+(type: #export Variable
+ (#Local Register)
+ (#Foreign Register))
+
+(structure: #export equivalence
+ (Equivalence Variable)
+
+ (def: (= reference sample)
+ (case [reference sample]
+ (^template [<tag>]
+ [(<tag> reference') (<tag> sample')]
+ (n.= reference' sample'))
+ ([#Local] [#Foreign])
+
+ _
+ #0)))
+
+(structure: #export hash
+ (Hash Variable)
+
+ (def: &equivalence ..equivalence)
+ (def: hash
+ (|>> (case> (#Local register)
+ register
+
+ (#Foreign register)
+ (|> register .int (i.* -1) .nat)))))
+
+(def: #export self?
+ (-> Variable Bit)
+ (|>> (case> (^ (#Local 0))
+ true
+
+ _
+ false)))
+
+(def: #export format
+ (Format Variable)
+ (|>> (case> (#Local local)
+ (%.format "+" (%.nat local))
+
+ (#Foreign foreign)
+ (%.format "-" (%.nat foreign)))))
diff --git a/stdlib/source/test/lux/control.lux b/stdlib/source/test/lux/control.lux
index 56be46610..7fc1c428d 100644
--- a/stdlib/source/test/lux/control.lux
+++ b/stdlib/source/test/lux/control.lux
@@ -20,6 +20,7 @@
["#." try]
["#." io]
["#." parser
+ ["#/." analysis]
["#/." text]
["#/." cli]]
["#." pipe]
@@ -57,6 +58,7 @@
Test
($_ _.and
/parser.test
+ /parser/analysis.test
/parser/text.test
/parser/cli.test
))
diff --git a/stdlib/source/test/lux/control/parser/analysis.lux b/stdlib/source/test/lux/control/parser/analysis.lux
new file mode 100644
index 000000000..397b2c779
--- /dev/null
+++ b/stdlib/source/test/lux/control/parser/analysis.lux
@@ -0,0 +1,146 @@
+(.module:
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ [pipe (#+ case>)]
+ ["." try]
+ ["." exception]
+ ["<>" parser]]
+ [data
+ ["." name ("#@." equivalence)]
+ ["." bit ("#@." equivalence)]
+ ["." text ("#@." equivalence)]
+ [number
+ ["n" nat]
+ ["i" int]
+ ["f" frac]
+ ["r" rev]]
+ [collection
+ ["." list]]]
+ [math
+ ["." random (#+ Random)]]
+ [tool
+ [compiler
+ [reference (#+ Constant)]
+ [language
+ [lux
+ ["." analysis]]]]]]
+ {1
+ ["." /]})
+
+(template: (!expect <expectation> <computation>)
+ (case <computation>
+ <expectation>
+ true
+
+ _
+ false))
+
+(def: constant
+ (Random Constant)
+ (random.and (random.unicode 10)
+ (random.unicode 10)))
+
+(def: #export test
+ Test
+ (<| (_.covering /._)
+ (_.with-cover [/.Parser])
+ (do {@ random.monad}
+ []
+ (`` ($_ _.and
+ (do {@ random.monad}
+ [expected (:: @ map (|>> analysis.bit) random.bit)]
+ (_.cover [/.run /.any]
+ (|> (list expected)
+ (/.run /.any)
+ (case> (#try.Success actual)
+ (:: analysis.equivalence = expected actual)
+
+ (#try.Failure _)
+ false))))
+ (~~ (template [<query> <check> <random> <analysis> <=>]
+ [(do {@ random.monad}
+ [expected <random>]
+ (_.cover [<query>]
+ (|> (list (<analysis> expected))
+ (/.run <query>)
+ (case> (#try.Success actual)
+ (<=> expected actual)
+
+ (#try.Failure _)
+ false))))
+ (do {@ random.monad}
+ [expected <random>]
+ (_.cover [<check>]
+ (|> (list (<analysis> expected))
+ (/.run (<check> expected))
+ (!expect (#try.Success _)))))]
+
+ [/.bit /.bit! random.bit analysis.bit bit@=]
+ [/.nat /.nat! random.nat analysis.nat n.=]
+ [/.int /.int! random.int analysis.int i.=]
+ [/.frac /.frac! random.frac analysis.frac f.=]
+ [/.rev /.rev! random.rev analysis.rev r.=]
+ [/.text /.text! (random.unicode 10) analysis.text text@=]
+ [/.local /.local! random.nat analysis.variable/local n.=]
+ [/.foreign /.foreign! random.nat analysis.variable/foreign n.=]
+ [/.constant /.constant! ..constant analysis.constant name@=]
+ ))
+ (do {@ random.monad}
+ [expected random.bit]
+ (_.cover [/.tuple]
+ (|> (list (analysis.tuple (list (analysis.bit expected))))
+ (/.run (/.tuple /.bit))
+ (case> (#try.Success actual)
+ (bit@= expected actual)
+
+ (#try.Failure _)
+ false))))
+ (do {@ random.monad}
+ [dummy random.bit]
+ (_.cover [/.end?]
+ (and (|> (/.run /.end? (list))
+ (!expect (#try.Success #1)))
+ (|> (/.run (do <>.monad
+ [verdict /.end?
+ _ /.bit]
+ (wrap verdict))
+ (list (analysis.bit dummy)))
+ (!expect (#try.Success #0))))))
+ (do {@ random.monad}
+ [dummy random.bit]
+ (_.cover [/.end!]
+ (and (|> (/.run /.end! (list))
+ (!expect (#try.Success _)))
+ (|> (/.run /.end! (list (analysis.bit dummy)))
+ (!expect (#try.Failure _))))))
+ (do {@ random.monad}
+ [expected random.bit]
+ (_.cover [/.cannot-parse]
+ (and (|> (list (analysis.bit expected))
+ (/.run /.nat)
+ (case> (#try.Success _)
+ false
+
+ (#try.Failure error)
+ (exception.match? /.cannot-parse error)))
+ (|> (list)
+ (/.run /.bit)
+ (case> (#try.Success _)
+ false
+
+ (#try.Failure error)
+ (exception.match? /.cannot-parse error))))))
+ (do {@ random.monad}
+ [expected random.bit]
+ (_.cover [/.unconsumed-input]
+ (|> (list (analysis.bit expected) (analysis.bit expected))
+ (/.run /.bit)
+ (case> (#try.Success _)
+ false
+
+ (#try.Failure error)
+ (exception.match? /.unconsumed-input error)))))
+ )))))
diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/case.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/case.lux
index 5f9f14321..d084e0210 100644
--- a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/case.lux
+++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/case.lux
@@ -1,15 +1,19 @@
(.module:
[lux #*
- [abstract ["." monad (#+ do)]]
- [data
- ["." name]
- [number
- ["n" nat]]]
- ["r" math/random (#+ Random) ("#@." monad)]
["_" test (#+ Test)]
+ [abstract
+ ["." monad (#+ do)]]
[control
pipe
- ["." try ("#@." functor)]]]
+ ["." try ("#@." functor)]]
+ [data
+ ["." sum]
+ [number
+ ["n" nat]]
+ [collection
+ ["." list ("#@." fold monoid)]]]
+ [math
+ ["." random (#+ Random) ("#@." monad)]]]
["." // #_
["#." primitive]]
{1
@@ -22,32 +26,33 @@
["#." analysis (#+ Branch Analysis)]
["#." synthesis (#+ Synthesis)]
[///
- ["#." reference]
+ ["#." reference
+ [variable (#+ Register)]]
["." phase]
[meta
["." archive]]]]]]]})
-(def: dummy-vars
+(def: masking-test
Test
- (do {@ r.monad}
+ (do {@ random.monad}
[maskedA //primitive.primitive
- temp (|> r.nat (:: @ map (n.% 100)))
+ temp (|> random.nat (:: @ map (n.% 100)))
#let [maskA (////analysis.control/case
[maskedA
[[(#////analysis.Bind temp)
(#////analysis.Reference (////reference.local temp))]
(list)]])]]
- (_.test "Dummy variables created to mask expressions get eliminated during synthesis."
- (|> maskA
- (//.phase archive.empty)
- (phase.run [///bundle.empty ////synthesis.init])
- (try@map (//primitive.corresponds? maskedA))
- (try.default false)))))
+ (_.cover [/.synthesize-masking]
+ (|> maskA
+ (//.phase archive.empty)
+ (phase.run [///bundle.empty ////synthesis.init])
+ (try@map (//primitive.corresponds? maskedA))
+ (try.default false)))))
-(def: let-expr
+(def: let-test
Test
- (do r.monad
- [registerA r.nat
+ (do random.monad
+ [registerA random.nat
inputA //primitive.primitive
outputA //primitive.primitive
#let [letA (////analysis.control/case
@@ -55,22 +60,22 @@
[[(#////analysis.Bind registerA)
outputA]
(list)]])]]
- (_.test "Can detect and reify simple 'let' expressions."
- (|> letA
- (//.phase archive.empty)
- (phase.run [///bundle.empty ////synthesis.init])
- (case> (^ (#try.Success (////synthesis.branch/let [inputS registerS outputS])))
- (and (n.= registerA registerS)
- (//primitive.corresponds? inputA inputS)
- (//primitive.corresponds? outputA outputS))
+ (_.cover [/.synthesize-let]
+ (|> letA
+ (//.phase archive.empty)
+ (phase.run [///bundle.empty ////synthesis.init])
+ (case> (^ (#try.Success (////synthesis.branch/let [inputS registerS outputS])))
+ (and (n.= registerA registerS)
+ (//primitive.corresponds? inputA inputS)
+ (//primitive.corresponds? outputA outputS))
- _
- false)))))
+ _
+ false)))))
-(def: if-expr
+(def: if-test
Test
- (do r.monad
- [then|else r.bit
+ (do random.monad
+ [then|else random.bit
inputA //primitive.primitive
thenA //primitive.primitive
elseA //primitive.primitive
@@ -83,23 +88,83 @@
ifA (if then|else
(////analysis.control/case [inputA [thenB (list elseB)]])
(////analysis.control/case [inputA [elseB (list thenB)]]))]]
- (_.test "Can detect and reify simple 'if' expressions."
- (|> ifA
- (//.phase archive.empty)
- (phase.run [///bundle.empty ////synthesis.init])
- (case> (^ (#try.Success (////synthesis.branch/if [inputS thenS elseS])))
- (and (//primitive.corresponds? inputA inputS)
- (//primitive.corresponds? thenA thenS)
- (//primitive.corresponds? elseA elseS))
+ (_.cover [/.synthesize-if]
+ (|> ifA
+ (//.phase archive.empty)
+ (phase.run [///bundle.empty ////synthesis.init])
+ (case> (^ (#try.Success (////synthesis.branch/if [inputS thenS elseS])))
+ (and (//primitive.corresponds? inputA inputS)
+ (//primitive.corresponds? thenA thenS)
+ (//primitive.corresponds? elseA elseS))
+
+ _
+ false)))))
+
+(def: random-member
+ (Random ////synthesis.Member)
+ (do {@ random.monad}
+ [lefts (|> random.nat (:: @ map (n.% 10)))
+ right? random.bit]
+ (wrap (if right?
+ (#.Right lefts)
+ (#.Left lefts)))))
+
+(def: random-path
+ (Random (////analysis.Tuple ////synthesis.Member))
+ (do {@ random.monad}
+ [size-1 (|> random.nat (:: @ map (|>> (n.% 10) inc)))]
+ (random.list size-1 ..random-member)))
+
+(def: (get-pattern path)
+ (-> (////analysis.Tuple ////synthesis.Member)
+ (Random [////analysis.Pattern Register]))
+ (do random.monad
+ [@member random.nat]
+ (wrap [(list@fold (function (_ member inner)
+ (case member
+ (#.Left lefts)
+ (////analysis.pattern/tuple
+ (list@compose (list.repeat lefts (////analysis.pattern/unit))
+ (list inner (////analysis.pattern/unit))))
+
+ (#.Right lefts)
+ (////analysis.pattern/tuple
+ (list@compose (list.repeat (inc lefts) (////analysis.pattern/unit))
+ (list inner)))))
+ (#////analysis.Bind @member)
+ (list.reverse path))
+ @member])))
+
+(def: get-test
+ Test
+ (do {@ random.monad}
+ [recordA (|> random.nat
+ (:: @ map (|>> ////analysis.nat))
+ (random.list 10)
+ (:: @ map (|>> ////analysis.tuple)))
+ pathA ..random-path
+ [pattern @member] (get-pattern pathA)
+ #let [getA (////analysis.control/case [recordA [[pattern
+ (#////analysis.Reference (////reference.local @member))]
+ (list)]])]]
+ (_.cover [/.synthesize-get]
+ (|> getA
+ (//.phase archive.empty)
+ (phase.run [///bundle.empty ////synthesis.init])
+ (case> (^ (#try.Success (////synthesis.branch/get [pathS recordS])))
+ (and (:: (list.equivalence (sum.equivalence n.= n.=)) = pathA pathS)
+ (//primitive.corresponds? recordA recordS))
- _
- false)))))
+ _
+ false)))))
(def: #export test
Test
- (<| (_.context (name.module (name-of /._)))
+ (<| (_.covering /._)
+ (_.with-cover [/.synthesize])
($_ _.and
- ..dummy-vars
- ..let-expr
- ..if-expr
+ ..masking-test
+ ..let-test
+ ..if-test
+ ..get-test
)))
diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/function.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/function.lux
index 799a8a526..7350881b1 100644
--- a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/function.lux
+++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/function.lux
@@ -16,7 +16,7 @@
["n" nat]]
[collection
["." list ("#@." functor fold)]
- ["dict" dictionary (#+ Dictionary)]
+ ["." dictionary (#+ Dictionary)]
["." set]]]]
["." // #_
["#." primitive]]
@@ -31,7 +31,8 @@
["#." synthesis (#+ Synthesis)]
[///
[arity (#+ Arity)]
- ["#." reference (#+ Variable) ("variable@." equivalence)]
+ ["#." reference
+ ["." variable (#+ Variable) ("#@." equivalence)]]
["." phase]
[meta
["." archive]]]]]]]})
@@ -61,16 +62,16 @@
(do {@ r.monad}
[num-locals (|> r.nat (:: @ map (|>> (n.% 100) (n.max 10))))
#let [indices (list.n/range 0 (dec num-locals))
- local-env (list@map (|>> #////reference.Local) indices)
- foreign-env (list@map (|>> #////reference.Foreign) indices)]
+ local-env (list@map (|>> #variable.Local) indices)
+ foreign-env (list@map (|>> #variable.Foreign) indices)]
[arity bodyA predictionA] (: (Random [Arity Analysis Variable])
(loop [arity 1
current-env foreign-env]
(let [current-env/size (list.size current-env)
resolver (list@fold (function (_ [idx var] resolver)
- (dict.put idx var resolver))
+ (dictionary.put idx var resolver))
(: (Dictionary Nat Variable)
- (dict.new n.hash))
+ (dictionary.new n.hash))
(list.enumerate current-env))]
(do @
[nest? r.bit]
@@ -83,7 +84,7 @@
(list@map (function (_ pick)
(maybe.assume (list.nth pick current-env)))
picks))
- #let [picked-env (list@map (|>> #////reference.Foreign) picks)]]
+ #let [picked-env (list@map (|>> #variable.Foreign) picks)]]
(wrap [arity
(#////analysis.Function picked-env bodyA)
predictionA]))
@@ -91,7 +92,7 @@
[chosen (pick (list.size current-env))]
(wrap [arity
(#////analysis.Reference (////reference.foreign chosen))
- (maybe.assume (dict.get chosen resolver))])))))))]
+ (maybe.assume (dictionary.get chosen resolver))])))))))]
(wrap [arity
(#////analysis.Function local-env bodyA)
predictionA])))
@@ -111,7 +112,7 @@
[chosen (|> r.nat (:: @ map (|>> (n.% 100) (n.max 2))))]
(wrap [arity
(#////analysis.Reference (////reference.local chosen))
- (|> chosen (n.+ (dec arity)) #////reference.Local)])))))
+ (|> chosen (n.+ (dec arity)) #variable.Local)])))))
(def: abstraction
Test
diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/primitive.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/primitive.lux
index cd7fe54eb..40f9efad4 100644
--- a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/primitive.lux
+++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/primitive.lux
@@ -1,14 +1,18 @@
(.module:
[lux (#- primitive)
[abstract ["." monad (#+ do)]]
+ [control
+ [pipe (#+ case>)]
+ ["." try]]
[data
["%" text/format (#+ format)]
- ["." name]]
+ ["." name]
+ [number
+ ["n" nat]]
+ [collection
+ ["." list]]]
["r" math/random (#+ Random) ("#@." monad)]
- ["_" test (#+ Test)]
- [control
- pipe
- ["." try]]]
+ ["_" test (#+ Test)]]
{1
["." / #_
["/#" //
@@ -54,6 +58,14 @@
[#////analysis.Frac (|>) #////synthesis.F64 (|>)]
[#////analysis.Text (|>) #////synthesis.Text (|>)]
))
+
+ (^ [(////analysis.tuple expected)
+ (////synthesis.tuple actual)])
+ (and (n.= (list.size expected)
+ (list.size actual))
+ (list.every? (function (_ [expected actual])
+ (corresponds? expected actual))
+ (list.zip2 expected actual)))
_
false)))