From b6c3a84b536235a53bdfaf0f96d76413bc222ba7 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Mon, 30 Oct 2017 21:49:35 -0400
Subject: - Migrated the format of synthesis nodes from a custom data-type, to
just Code nodes.
---
new-luxc/source/luxc/generator/case.jvm.lux | 162 ++++----
new-luxc/source/luxc/generator/expr.jvm.lux | 57 +--
.../source/luxc/generator/procedure/common.jvm.lux | 5 +
.../source/luxc/generator/procedure/host.jvm.lux | 33 +-
new-luxc/source/luxc/lang/synthesis.lux | 38 +-
new-luxc/source/luxc/synthesizer.lux | 167 +++++---
new-luxc/source/luxc/synthesizer/case.lux | 96 ++---
new-luxc/source/luxc/synthesizer/loop.lux | 224 +++++-----
new-luxc/test/test/luxc/generator/case.lux | 58 +--
new-luxc/test/test/luxc/generator/function.lux | 19 +-
new-luxc/test/test/luxc/generator/primitive.lux | 15 +-
.../test/luxc/generator/procedure/common.jvm.lux | 161 ++++----
.../test/luxc/generator/procedure/host.jvm.lux | 452 ++++++++++-----------
new-luxc/test/test/luxc/generator/reference.lux | 7 +-
new-luxc/test/test/luxc/generator/structure.lux | 39 +-
.../test/test/luxc/synthesizer/case/special.lux | 4 +-
new-luxc/test/test/luxc/synthesizer/common.lux | 22 +-
new-luxc/test/test/luxc/synthesizer/function.lux | 10 +-
new-luxc/test/test/luxc/synthesizer/loop.lux | 46 ++-
new-luxc/test/test/luxc/synthesizer/primitive.lux | 38 +-
new-luxc/test/test/luxc/synthesizer/procedure.lux | 4 +-
new-luxc/test/test/luxc/synthesizer/structure.lux | 4 +-
22 files changed, 841 insertions(+), 820 deletions(-)
(limited to 'new-luxc')
diff --git a/new-luxc/source/luxc/generator/case.jvm.lux b/new-luxc/source/luxc/generator/case.jvm.lux
index f20c83f6e..a619768bb 100644
--- a/new-luxc/source/luxc/generator/case.jvm.lux
+++ b/new-luxc/source/luxc/generator/case.jvm.lux
@@ -1,8 +1,11 @@
(;module:
lux
- (lux (control [monad #+ do])
+ (lux (control [monad #+ do]
+ ["ex" exception #+ exception:])
+ (data text/format)
[meta "meta/" Monad])
- (luxc [";L" host]
+ (luxc ["_" base]
+ [";L" host]
(lang ["ls" synthesis])
(generator (host ["$" jvm]
(jvm ["$t" type]
@@ -49,50 +52,52 @@
(list))
false)))
-(def: (generate-pattern' generate stack-depth @else @end path)
+(exception: #export Unrecognized-Path)
+
+(def: (generate-path' generate stack-depth @else @end path)
(-> (-> ls;Synthesis (Meta $;Inst))
Nat $;Label $;Label ls;Path (Meta $;Inst))
(case path
- (#ls;ExecP bodyS)
+ (^ [_ (#;Form (list [_ (#;Text "lux case exec")] bodyS))])
(do meta;Monad
[bodyI (generate bodyS)]
(wrap (|>. (pop-altI stack-depth)
bodyI
($i;GOTO @end))))
- #ls;UnitP
+ (^ [_ (#;Form (list [_ (#;Text "lux case pop")]))])
(meta/wrap popI)
- (#ls;BindP register)
+ (^ [_ (#;Form (list [_ (#;Text "lux case bind")] [_ (#;Nat register)]))])
(meta/wrap (|>. peekI
($i;ASTORE register)
popI))
- (#ls;BoolP value)
+ [_ (#;Bool value)]
(meta/wrap (let [jumpI (if value $i;IFEQ $i;IFNE)]
(|>. peekI
($i;unwrap #$;Boolean)
(jumpI @else))))
(^template [ ]
- ( value)
+ [_ ( value)]
(meta/wrap (|>. peekI
($i;unwrap #$;Long)
($i;long (|> value ))
$i;LCMP
($i;IFNE @else))))
- ([#ls;NatP (:! Int)]
- [#ls;IntP (: Int)]
- [#ls;DegP (:! Int)])
+ ([#;Nat (:! Int)]
+ [#;Int (: Int)]
+ [#;Deg (:! Int)])
- (#ls;FracP value)
+ [_ (#;Frac value)]
(meta/wrap (|>. peekI
($i;unwrap #$;Double)
($i;double value)
$i;DCMPL
($i;IFNE @else)))
- (#ls;TextP value)
+ [_ (#;Text value)]
(meta/wrap (|>. peekI
($i;string value)
($i;INVOKEVIRTUAL "java.lang.Object"
@@ -103,95 +108,88 @@
false)
($i;IFEQ @else)))
- (#ls;TupleP idx subP)
- (do meta;Monad
- [subI (generate-pattern' generate stack-depth @else @end subP)
- #let [[idx tail?] (case idx
- (#;Left idx)
- [idx false]
-
- (#;Right idx)
- [idx true])]]
- (wrap (case idx
- +0
- (|>. peekI
- ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple))
- ($i;int 0)
- $i;AALOAD
- pushI
- subI)
-
- _
- (|>. peekI
- ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple))
- ($i;int (nat-to-int idx))
- ($i;INVOKESTATIC hostL;runtime-class
- (if tail? "pm_right" "pm_left")
- ($t;method (list ../runtime;$Tuple $t;int)
- (#;Some $Object)
- (list))
- false)
- pushI
- subI))))
-
- (#ls;VariantP idx subP)
- (do meta;Monad
- [subI (generate-pattern' generate stack-depth @else @end subP)
- #let [[idx last?] (case idx
- (#;Left idx)
- [idx false]
-
- (#;Right idx)
- [idx true])
- flagI (if last?
- ($i;string "")
- $i;NULL)]]
- (wrap (<| $i;with-label (function [@success])
- $i;with-label (function [@fail])
+ (^template [ ]
+ (^ [_ (#;Form (list [_ (#;Text )] [_ (#;Nat idx)] subP))])
+ (do meta;Monad
+ [subI (generate-path' generate stack-depth @else @end subP)]
+ (wrap (case idx
+ +0
+ (|>. peekI
+ ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple))
+ ($i;int 0)
+ $i;AALOAD
+ pushI
+ subI)
+
+ _
(|>. peekI
- ($i;CHECKCAST ($t;descriptor ../runtime;$Variant))
+ ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple))
($i;int (nat-to-int idx))
- flagI
- ($i;INVOKESTATIC hostL;runtime-class "pm_variant"
- ($t;method (list ../runtime;$Variant ../runtime;$Tag ../runtime;$Flag)
- (#;Some ../runtime;$Datum)
+ ($i;INVOKESTATIC hostL;runtime-class
+
+ ($t;method (list ../runtime;$Tuple $t;int)
+ (#;Some $Object)
(list))
false)
- $i;DUP
- ($i;IFNULL @fail)
- ($i;GOTO @success)
- ($i;label @fail)
- $i;POP
- ($i;GOTO @else)
- ($i;label @success)
pushI
- subI))))
-
- (#ls;SeqP leftP rightP)
+ subI)))))
+ (["lux case tuple left" "pm_left"]
+ ["lux case tuple right" "pm_right"])
+
+ (^template [ ]
+ (^ [_ (#;Form (list [_ (#;Text )] [_ (#;Nat idx)] subP))])
+ (do meta;Monad
+ [subI (generate-path' generate stack-depth @else @end subP)]
+ (wrap (<| $i;with-label (function [@success])
+ $i;with-label (function [@fail])
+ (|>. peekI
+ ($i;CHECKCAST ($t;descriptor ../runtime;$Variant))
+ ($i;int (nat-to-int idx))
+
+ ($i;INVOKESTATIC hostL;runtime-class "pm_variant"
+ ($t;method (list ../runtime;$Variant ../runtime;$Tag ../runtime;$Flag)
+ (#;Some ../runtime;$Datum)
+ (list))
+ false)
+ $i;DUP
+ ($i;IFNULL @fail)
+ ($i;GOTO @success)
+ ($i;label @fail)
+ $i;POP
+ ($i;GOTO @else)
+ ($i;label @success)
+ pushI
+ subI)))))
+ (["lux case variant left" $i;NULL]
+ ["lux case variant right" ($i;string "")])
+
+ (^ [_ (#;Form (list [_ (#;Text "lux case seq")] leftP rightP))])
(do meta;Monad
- [leftI (generate-pattern' generate stack-depth @else @end leftP)
- rightI (generate-pattern' generate stack-depth @else @end rightP)]
+ [leftI (generate-path' generate stack-depth @else @end leftP)
+ rightI (generate-path' generate stack-depth @else @end rightP)]
(wrap (|>. leftI
rightI)))
- (#ls;AltP leftP rightP)
+ (^ [_ (#;Form (list [_ (#;Text "lux case alt")] leftP rightP))])
(do meta;Monad
[@alt-else $i;make-label
- leftI (generate-pattern' generate (n.inc stack-depth) @alt-else @end leftP)
- rightI (generate-pattern' generate stack-depth @else @end rightP)]
+ leftI (generate-path' generate (n.inc stack-depth) @alt-else @end leftP)
+ rightI (generate-path' generate stack-depth @else @end rightP)]
(wrap (|>. $i;DUP
leftI
($i;label @alt-else)
$i;POP
rightI)))
- ))
-(def: (generate-pattern generate path @end)
+ _
+ (_;throw Unrecognized-Path (%code path))))
+
+(def: (generate-path generate path @end)
(-> (-> ls;Synthesis (Meta $;Inst))
ls;Path $;Label (Meta $;Inst))
(do meta;Monad
[@else $i;make-label
- pathI (generate-pattern' generate +1 @else @end path)]
+ pathI (generate-path' generate +1 @else @end path)]
(wrap (|>. pathI
($i;label @else)
$i;POP
@@ -208,7 +206,7 @@
(do meta;Monad
[@end $i;make-label
valueI (generate valueS)
- pathI (generate-pattern generate path @end)]
+ pathI (generate-path generate path @end)]
(wrap (|>. valueI
$i;NULL
$i;SWAP
diff --git a/new-luxc/source/luxc/generator/expr.jvm.lux b/new-luxc/source/luxc/generator/expr.jvm.lux
index 685bf2335..b439ff17a 100644
--- a/new-luxc/source/luxc/generator/expr.jvm.lux
+++ b/new-luxc/source/luxc/generator/expr.jvm.lux
@@ -1,9 +1,12 @@
(;module:
lux
(lux (control monad
- ["ex" exception #+ exception:])
- (data text/format)
- [meta #+ Monad "Meta/" Monad])
+ ["ex" exception #+ exception:]
+ ["p" parser])
+ (data ["e" error]
+ text/format)
+ [meta]
+ (meta ["s" syntax]))
(luxc ["&" base]
(lang ["ls" synthesis])
["&;" analyser]
@@ -24,48 +27,52 @@
(def: #export (generate synthesis)
(-> ls;Synthesis (Meta $;Inst))
(case synthesis
- #ls;Unit
+ [_ (#;Tuple #;Nil)]
&primitive;generate-unit
+ (^ [_ (#;Tuple (list singleton))])
+ (generate singleton)
+
(^template [ ]
- ( value)
+ [_ ( value)]
( value))
- ([#ls;Bool &primitive;generate-bool]
- [#ls;Nat &primitive;generate-nat]
- [#ls;Int &primitive;generate-int]
- [#ls;Deg &primitive;generate-deg]
- [#ls;Frac &primitive;generate-frac]
- [#ls;Text &primitive;generate-text])
+ ([#;Bool &primitive;generate-bool]
+ [#;Nat &primitive;generate-nat]
+ [#;Int &primitive;generate-int]
+ [#;Deg &primitive;generate-deg]
+ [#;Frac &primitive;generate-frac]
+ [#;Text &primitive;generate-text])
- (#ls;Variant tag tail? member)
- (&structure;generate-variant generate tag tail? member)
+ (^ [_ (#;Form (list [_ (#;Nat tag)] [_ (#;Bool last?)] valueS))])
+ (&structure;generate-variant generate tag last? valueS)
- (#ls;Tuple members)
+ [_ (#;Tuple members)]
(&structure;generate-tuple generate members)
- (#ls;Variable var)
+ (^ [_ (#;Form (list [_ (#;Int var)]))])
(if (functionS;captured? var)
(&reference;generate-captured var)
(&reference;generate-variable var))
- (#ls;Definition definition)
+ [_ (#;Symbol definition)]
(&reference;generate-definition definition)
- (#ls;Let register inputS exprS)
+ (^ [_ (#;Form (list [_ (#;Text "lux let")] [_ (#;Nat register)] inputS exprS))])
(caseG;generate-let generate register inputS exprS)
- (#ls;Case inputS pathPS)
+ (^ [_ (#;Form (list [_ (#;Text "lux case")] inputS pathPS))])
(caseG;generate-case generate inputS pathPS)
- (#ls;Function arity env body)
- (&function;generate-function generate env arity body)
+ (^multi (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat arity)] [_ (#;Tuple environment)] bodyS))])
+ [(s;run environment (p;some s;int)) (#e;Success environment)])
+ (&function;generate-function generate environment arity bodyS)
- (#ls;Call args function)
- (&function;generate-call generate function args)
+ (^ [_ (#;Form (list& [_ (#;Text "lux call")] functionS argsS))])
+ (&function;generate-call generate functionS argsS)
- (#ls;Procedure name args)
- (&procedure;generate-procedure generate name args)
+ (^ [_ (#;Form (list& [_ (#;Text procedure)] argsS))])
+ (&procedure;generate-procedure generate procedure argsS)
_
- (&;throw Unrecognized-Synthesis "")
+ (&;throw Unrecognized-Synthesis (%code synthesis))
))
diff --git a/new-luxc/source/luxc/generator/procedure/common.jvm.lux b/new-luxc/source/luxc/generator/procedure/common.jvm.lux
index fd76082a6..7ae471c64 100644
--- a/new-luxc/source/luxc/generator/procedure/common.jvm.lux
+++ b/new-luxc/source/luxc/generator/procedure/common.jvm.lux
@@ -146,6 +146,10 @@
($i;CHECKCAST hostL;function-class)
($i;INVOKESTATIC hostL;runtime-class "try" try-method false)))
+(def: (lux//noop valueI)
+ Unary
+ valueI)
+
## [[Bits]]
(do-template [ ]
[(def: ( [inputI maskI])
@@ -536,6 +540,7 @@
(def: lux-procs
Bundle
(|> (dict;new text;Hash)
+ (install "lux noop" (unary lux//noop))
(install "lux is" (binary lux//is))
(install "lux try" (unary lux//try))))
diff --git a/new-luxc/source/luxc/generator/procedure/host.jvm.lux b/new-luxc/source/luxc/generator/procedure/host.jvm.lux
index fc6bdd01b..44da5744d 100644
--- a/new-luxc/source/luxc/generator/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/generator/procedure/host.jvm.lux
@@ -37,6 +37,7 @@
[L2S (|>. $i;L2I $i;I2S)]
[L2B (|>. $i;L2I $i;I2B)]
+ [L2C (|>. $i;L2I $i;I2C)]
)
(do-template [ ]
@@ -68,6 +69,7 @@
[convert//long-to-int #$;Long $i;L2I #$;Int]
[convert//long-to-short #$;Long L2S #$;Short]
[convert//long-to-byte #$;Long L2B #$;Byte]
+ [convert//long-to-char #$;Long L2C #$;Char]
[convert//char-to-byte #$;Char $i;I2B #$;Byte]
[convert//char-to-short #$;Char $i;I2S #$;Short]
[convert//char-to-int #$;Char $i;NOP #$;Int]
@@ -97,6 +99,7 @@
(@;install "long-to-int" (@;unary convert//long-to-int))
(@;install "long-to-short" (@;unary convert//long-to-short))
(@;install "long-to-byte" (@;unary convert//long-to-byte))
+ (@;install "long-to-char" (@;unary convert//long-to-char))
(@;install "char-to-byte" (@;unary convert//char-to-byte))
(@;install "char-to-short" (@;unary convert//char-to-short))
(@;install "char-to-int" (@;unary convert//char-to-int))
@@ -278,7 +281,7 @@
(def: (array//new proc generate inputs)
(-> Text @;Proc)
(case inputs
- (^ (list (#ls;Nat level) (#ls;Text class) lengthS))
+ (^ (list [_ (#;Nat level)] [_ (#;Text class)] lengthS))
(do meta;Monad
[lengthI (generate lengthS)
#let [arrayJT ($t;array level (case class
@@ -302,7 +305,7 @@
(def: (array//read proc generate inputs)
(-> Text @;Proc)
(case inputs
- (^ (list (#ls;Text class) idxS arrayS))
+ (^ (list [_ (#;Text class)] idxS arrayS))
(do meta;Monad
[arrayI (generate arrayS)
idxI (generate idxS)
@@ -328,7 +331,7 @@
(def: (array//write proc generate inputs)
(-> Text @;Proc)
(case inputs
- (^ (list (#ls;Text class) idxS valueS arrayS))
+ (^ (list [_ (#;Text class)] idxS valueS arrayS))
(do meta;Monad
[arrayI (generate arrayS)
idxI (generate idxS)
@@ -397,7 +400,7 @@
(def: (object//class proc generate inputs)
(-> Text @;Proc)
(case inputs
- (^ (list (#ls;Text class)))
+ (^ (list [_ (#;Text class)]))
(do meta;Monad
[]
(wrap (|>. ($i;string class)
@@ -413,7 +416,7 @@
(def: (object//instance? proc generate inputs)
(-> Text @;Proc)
(case inputs
- (^ (list (#ls;Text class) objectS))
+ (^ (list [_ (#;Text class)] objectS))
(do meta;Monad
[objectI (generate objectS)]
(wrap (|>. objectI
@@ -450,7 +453,7 @@
(def: (static//get proc generate inputs)
(-> Text @;Proc)
(case inputs
- (^ (list (#ls;Text class) (#ls;Text field) (#ls;Text unboxed)))
+ (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)]))
(do meta;Monad
[]
(case (dict;get unboxed primitives)
@@ -477,7 +480,7 @@
(def: (static//put proc generate inputs)
(-> Text @;Proc)
(case inputs
- (^ (list (#ls;Text class) (#ls;Text field) (#ls;Text unboxed) valueS))
+ (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] valueS))
(do meta;Monad
[valueI (generate valueS)]
(case (dict;get unboxed primitives)
@@ -509,7 +512,7 @@
(def: (virtual//get proc generate inputs)
(-> Text @;Proc)
(case inputs
- (^ (list (#ls;Text class) (#ls;Text field) (#ls;Text unboxed) objectS))
+ (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] objectS))
(do meta;Monad
[objectI (generate objectS)]
(case (dict;get unboxed primitives)
@@ -540,7 +543,7 @@
(def: (virtual//put proc generate inputs)
(-> Text @;Proc)
(case inputs
- (^ (list (#ls;Text class) (#ls;Text field) (#ls;Text unboxed) valueS objectS))
+ (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] valueS objectS))
(do meta;Monad
[valueI (generate valueS)
objectI (generate objectS)]
@@ -632,7 +635,7 @@
#;Nil
(meta/wrap #;Nil)
- (^ (list& [(#ls;Tuple (list (#ls;Text argD) argS))] tail))
+ (^ (list& [_ (#;Tuple (list [_ (#;Text argD)] argS))] tail))
(do meta;Monad
[argT (generate-type argD)
argI (:: @ map (prepare-input argT) (generate argS))
@@ -669,8 +672,8 @@
(def: (invoke//static proc generate inputs)
(-> Text @;Proc)
(case inputs
- (^ (list& (#ls;Text class) (#ls;Text method)
- (#ls;Text unboxed) argsS))
+ (^ (list& [_ (#;Text class)] [_ (#;Text method)]
+ [_ (#;Text unboxed)] argsS))
(do meta;Monad
[argsTI (generate-args generate argsS)
returnT (method-return-type unboxed)
@@ -687,8 +690,8 @@
[(def: ( proc generate inputs)
(-> Text @;Proc)
(case inputs
- (^ (list& (#ls;Text class) (#ls;Text method)
- (#ls;Text unboxed) objectS argsS))
+ (^ (list& [_ (#;Text class)] [_ (#;Text method)]
+ [_ (#;Text unboxed)] objectS argsS))
(do meta;Monad
[objectI (generate objectS)
argsTI (generate-args generate argsS)
@@ -712,7 +715,7 @@
(def: (invoke//constructor proc generate inputs)
(-> Text @;Proc)
(case inputs
- (^ (list& (#ls;Text class) argsS))
+ (^ (list& [_ (#;Text class)] argsS))
(do meta;Monad
[argsTI (generate-args generate argsS)]
(wrap (|>. ($i;NEW class)
diff --git a/new-luxc/source/luxc/lang/synthesis.lux b/new-luxc/source/luxc/lang/synthesis.lux
index dab2d84e6..96053edc0 100644
--- a/new-luxc/source/luxc/lang/synthesis.lux
+++ b/new-luxc/source/luxc/lang/synthesis.lux
@@ -5,40 +5,6 @@
(def: #export Register Nat)
(def: #export Variable Int)
-(type: #export (Path' s)
- #UnitP
- (#BoolP Bool)
- (#NatP Nat)
- (#IntP Int)
- (#DegP Deg)
- (#FracP Frac)
- (#TextP Text)
- (#VariantP (Either Nat Nat) (Path' s))
- (#TupleP (Either Nat Nat) (Path' s))
- (#BindP Nat)
- (#AltP (Path' s) (Path' s))
- (#SeqP (Path' s) (Path' s))
- (#ExecP s))
+(type: #export Synthesis Code)
-(type: #export #rec Synthesis
- #Unit
- (#Bool Bool)
- (#Nat Nat)
- (#Int Int)
- (#Deg Deg)
- (#Frac Frac)
- (#Text Text)
- (#Variant Nat Bool Synthesis)
- (#Tuple (List Synthesis))
- (#Case Synthesis (Path' Synthesis))
- (#Function Arity (List Variable) Synthesis)
- (#Call (List Synthesis) Synthesis)
- (#Recur (List Synthesis))
- (#Procedure Text (List Synthesis))
- (#Variable Variable)
- (#Definition Ident)
- (#Let Register Synthesis Synthesis)
- (#If Synthesis Synthesis Synthesis)
- (#Loop Register (List Synthesis) Synthesis))
-
-(type: #export Path (Path' Synthesis))
+(type: #export Path Code)
diff --git a/new-luxc/source/luxc/synthesizer.lux b/new-luxc/source/luxc/synthesizer.lux
index 011dfd8ae..e1eb67bd7 100644
--- a/new-luxc/source/luxc/synthesizer.lux
+++ b/new-luxc/source/luxc/synthesizer.lux
@@ -1,11 +1,15 @@
(;module:
lux
- (lux (data [maybe]
+ (lux (control ["p" parser])
+ (data [maybe]
+ ["e" error]
[number]
[product]
text/format
(coll [list "list/" Functor Fold Monoid]
- [dict #+ Dict])))
+ [dict #+ Dict]))
+ (meta [code]
+ ["s" syntax]))
(luxc ["&" base]
(lang ["la" analysis]
["ls" synthesis])
@@ -24,6 +28,76 @@
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))))
+
+(def: (if$ testS thenS elseS)
+ (-> ls;Synthesis ls;Synthesis ls;Synthesis ls;Synthesis)
+ (` ("lux if" (~ testS)
+ (~ thenS)
+ (~ elseS))))
+
+(def: (function$ arity environment body)
+ (-> ls;Arity (List ls;Variable) ls;Synthesis ls;Synthesis)
+ (` ("lux function" (~ (code;nat arity))
+ [(~@ (list/map code;int environment))]
+ (~ body))))
+
+(def: (variant$ tag last? valueS)
+ (-> Nat Bool ls;Synthesis ls;Synthesis)
+ (` ((~ (code;nat tag)) (~ (code;bool last?)) (~ valueS))))
+
+(def: (var$ var)
+ (-> ls;Variable ls;Synthesis)
+ (` ((~ (code;int var)))))
+
+(def: (procedure$ name argsS)
+ (-> Text (List ls;Synthesis) ls;Synthesis)
+ (` ((~ (code;text name)) (~@ argsS))))
+
+(def: (call$ funcS argsS)
+ (-> ls;Synthesis (List ls;Synthesis) ls;Synthesis)
+ (` ("lux call" (~ funcS) (~@ argsS))))
+
+(def: (synthesize-case synthesize inputA branchesA)
+ (-> (-> la;Analysis ls;Synthesis)
+ la;Analysis (List [la;Pattern la;Analysis])
+ 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))
+ inputS
+
+ (^ (list [(#la;BindP 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])))
+ (if$ inputS (synthesize thenA) (synthesize elseA))
+
+ (#;Cons [lastP lastA] prevsPA)
+ (let [transform-branch (: (-> la;Pattern la;Analysis ls;Path)
+ (function [pattern expr]
+ (|> (synthesize expr)
+ (~) ("lux case exec")
+ ("lux case seq" (~ (&&case;path pattern)))
+ (`))))]
+ (` ("lux case" (~ inputS)
+ (~ (list/fold &&case;weave
+ (transform-branch lastP lastA)
+ (list/map (product;uncurry transform-branch) prevsPA))))))
+
+ _
+ (undefined)
+ )))
+
(def: #export (synthesize analysis)
(-> la;Analysis ls;Synthesis)
(loop [outer-arity +0
@@ -31,71 +105,43 @@
num-locals +0
exprA analysis]
(case exprA
+ #la;Unit
+ (' [])
+
(^template [ ]
( value)
( value))
- ([#la;Unit #ls;Unit]
- [#la;Bool #ls;Bool]
- [#la;Nat #ls;Nat]
- [#la;Int #ls;Int]
- [#la;Deg #ls;Deg]
- [#la;Frac #ls;Frac]
- [#la;Text #ls;Text]
- [#la;Definition #ls;Definition])
+ ([#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 _)
- (#ls;Tuple (list/map (recur +0 resolver num-locals) (&&structure;unfold-tuple exprA)))
+ (` [(~@ (list/map (recur +0 resolver num-locals) (&&structure;unfold-tuple exprA)))])
(#la;Sum choice)
(let [[tag last? value] (&&structure;unfold-variant choice)]
- (#ls;Variant tag last? (recur +0 resolver num-locals value)))
+ (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)
- (#ls;Call (|> (list;n.range +1 (n.dec outer-arity))
- (list/map (|>. &&function;to-local #ls;Variable)))
- (#ls;Variable 0))
- (#ls;Variable (&&function;adjust-var outer-arity (&&function;to-local register))))
- (#ls;Variable (&&function;to-local 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)
- (#ls;Variable (let [var (&&function;to-captured register)]
- (maybe;default var (dict;get var resolver)))))
+ (var$ (let [var (&&function;to-captured register)]
+ (maybe;default var (dict;get var resolver)))))
(#la;Case inputA branchesA)
- (let [inputS (recur +0 resolver num-locals inputA)]
- (case (list;reverse branchesA)
- (^multi (^ (list [(#la;BindP input-register)
- (#la;Variable (#;Local output-register))]))
- (n.= input-register output-register))
- inputS
-
- (^ (list [(#la;BindP register) bodyA]))
- (#ls;Let register inputS (recur +0 resolver num-locals bodyA))
-
- (^or (^ (list [(#la;BoolP true) thenA] [(#la;BoolP false) elseA]))
- (^ (list [(#la;BoolP false) elseA] [(#la;BoolP true) thenA])))
- (#ls;If inputS
- (recur +0 resolver num-locals thenA)
- (recur +0 resolver num-locals elseA))
-
- (#;Cons [lastP lastA] prevsPA)
- (let [transform-branch (: (-> la;Pattern la;Analysis ls;Path)
- (function [pattern expr]
- (|> (recur +0 resolver num-locals expr)
- #ls;ExecP
- (#ls;SeqP (&&case;path pattern)))))]
- (#ls;Case inputS
- (list/fold &&case;weave
- (transform-branch lastP lastA)
- (list/map (product;uncurry transform-branch) prevsPA))))
-
- _
- (undefined)
- ))
+ (synthesize-case (recur +0 resolver num-locals) inputA branchesA)
(#la;Function scope bodyA)
(let [inner-arity (n.inc outer-arity)
@@ -116,33 +162,34 @@
init-resolver
env-vars))]
(case (recur inner-arity resolver' +0 bodyA)
- (#ls;Function arity' env' bodyS')
+ (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat arity')] env' bodyS'))])
(let [arity (n.inc arity')]
- (#ls;Function arity env (prepare-body inner-arity arity bodyS')))
+ (function$ arity env (prepare-body inner-arity arity bodyS')))
bodyS
- (#ls;Function +1 env (prepare-body inner-arity +1 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 (#ls;Function _arity _env _bodyS)
+ (^multi (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat _arity)] [_ (#;Tuple _env)] _bodyS))])
(and (n.= _arity (list;size argsS))
- (not (&&loop;contains-self-reference? _bodyS))))
+ (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)))]
- (#ls;Loop register-offset argsS
- (&&loop;adjust _env register-offset _bodyS)))
+ (` ("lux loop" (~ (code;nat register-offset)) [(~@ argsS)]
+ (~ (&&loop;adjust _env register-offset _bodyS)))))
- (#ls;Call argsS' funcS')
- (#ls;Call (list/compose argsS' argsS) funcS')
+ (^ [_ (#;Form (list& [_ (#;Text "lux call")] funcS' argsS'))])
+ (call$ funcS' (list/compose argsS' argsS))
_
- (#ls;Call argsS funcS)))
+ (call$ funcS argsS)))
(#la;Procedure name args)
- (#ls;Procedure name (list/map (recur +0 resolver num-locals) args))
+ (procedure$ name (list/map (recur +0 resolver num-locals) args))
)))
diff --git a/new-luxc/source/luxc/synthesizer/case.lux b/new-luxc/source/luxc/synthesizer/case.lux
index 02b1bfba5..91f339bdf 100644
--- a/new-luxc/source/luxc/synthesizer/case.lux
+++ b/new-luxc/source/luxc/synthesizer/case.lux
@@ -1,10 +1,10 @@
(;module:
lux
- (lux (data [bool "B/" Eq]
- [text "T/" Eq]
+ (lux (data [bool "bool/" Eq]
+ [text "text/" Eq]
[number]
- (coll [list "L/" Functor Fold Monoid]
- ["s" set])))
+ (coll [list "list/" Fold]))
+ (meta [code "code/" Eq]))
(luxc (lang ["la" analysis]
["ls" synthesis])
(synthesizer ["&;" function])))
@@ -12,21 +12,23 @@
(def: #export (path pattern)
(-> la;Pattern ls;Path)
(case pattern
+ (#la;BindP register)
+ (` ("lux case bind" (~ (code;nat register))))
+
(^template [ ]
- ( register)
- ( register))
- ([#la;BindP #ls;BindP]
- [#la;BoolP #ls;BoolP]
- [#la;NatP #ls;NatP]
- [#la;IntP #ls;IntP]
- [#la;DegP #ls;DegP]
- [#la;FracP #ls;FracP]
- [#la;TextP #ls;TextP])
+ ( value)
+ ( 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)
(case (list;reverse membersP)
#;Nil
- #ls;UnitP
+ (' ("lux case pop"))
(#;Cons singletonP #;Nil)
(path singletonP)
@@ -34,58 +36,46 @@
(#;Cons lastP prevsP)
(let [length (list;size membersP)
last-idx (n.dec length)
- last-path (#ls;TupleP (#;Right last-idx) (path lastP))
- [_ tuple-path] (L/fold (function [current-pattern [current-idx next-path]]
- [(n.dec current-idx)
- (#ls;SeqP (#ls;TupleP (#;Left current-idx)
- (path current-pattern))
- next-path)])
- [(n.dec last-idx) last-path]
- prevsP)]
+ [_ tuple-path] (list/fold (function [current-pattern [current-idx next-path]]
+ [(n.dec current-idx)
+ (` ("lux case seq"
+ ("lux case tuple left" (~ (code;nat current-idx)) (~ (path current-pattern)))
+ (~ next-path)))])
+ [(n.dec last-idx)
+ (` ("lux case tuple right" (~ (code;nat last-idx)) (~ (path lastP))))]
+ prevsP)]
tuple-path))
(#la;VariantP tag num-tags memberP)
- (let [last? (n.= (n.dec num-tags) tag)]
- (#ls;VariantP (if last? (#;Right tag) (#;Left tag))
- (path 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)))))))
(def: #export (weave leftP rightP)
(-> ls;Path ls;Path ls;Path)
- (with-expansions [ (as-is (#ls;AltP leftP rightP))]
+ (with-expansions [ (as-is (` ("lux case alt" (~ leftP) (~ rightP))))]
(case [leftP rightP]
- [#ls;UnitP #ls;UnitP]
- #ls;UnitP
-
- (^template [ ]
- [( left) ( right)]
- (if ( left right)
- leftP
- ))
- ([#ls;BindP n.=]
- [#ls;BoolP B/=]
- [#ls;NatP n.=]
- [#ls;IntP i.=]
- [#ls;DegP d.=]
- [#ls;FracP f.=]
- [#ls;TextP T/=])
-
- (^template [ ]
- [( ( left-idx) left-then) ( ( right-idx) right-then)]
+ (^template []
+ (^ [[_ (#;Form (list [_ (#;Text )] [_ (#;Nat left-idx)] left-then))]
+ [_ (#;Form (list [_ (#;Text )] [_ (#;Nat right-idx)] right-then))]])
(if (n.= left-idx right-idx)
- (weave left-then right-then)
+ (` ( (~ (code;nat left-idx)) (~ (weave left-then right-then))))
))
- ([#ls;TupleP #;Left]
- [#ls;TupleP #;Right]
- [#ls;VariantP #;Left]
- [#ls;VariantP #;Right])
+ (["lux case tuple left"]
+ ["lux case tuple right"]
+ ["lux case variant left"]
+ ["lux case variant right"])
- [(#ls;SeqP left-pre left-post) (#ls;SeqP right-pre right-post)]
+ (^ [[_ (#;Form (list [_ (#;Text "lux case seq")] left-pre left-post))]
+ [_ (#;Form (list [_ (#;Text "lux case seq")] right-pre right-post))]])
(case (weave left-pre right-pre)
- (#ls;AltP _ _)
+ (^ [_ (#;Form (list [_ (#;Text "lux case alt")] _ _))])
weavedP
- (#ls;SeqP weavedP (weave left-post right-post)))
+ (` ("lux case seq" (~ weavedP) (~ (weave left-post right-post)))))
_
- )))
+ (if (code/= leftP rightP)
+ leftP
+ ))))
diff --git a/new-luxc/source/luxc/synthesizer/loop.lux b/new-luxc/source/luxc/synthesizer/loop.lux
index ad4504f41..8599db981 100644
--- a/new-luxc/source/luxc/synthesizer/loop.lux
+++ b/new-luxc/source/luxc/synthesizer/loop.lux
@@ -1,61 +1,71 @@
(;module:
lux
- (lux (data [maybe]
- text/format
- (coll [list "L/" Functor])))
+ (lux (control [monad #+ do]
+ ["p" parser])
+ (data [maybe]
+ (coll [list "list/" Functor]))
+ (meta [code]
+ [syntax]))
(luxc (lang ["ls" synthesis])
(synthesizer ["&&;" function])))
(def: #export (contains-self-reference? exprS)
(-> ls;Synthesis Bool)
(case exprS
- (#ls;Variant tag last? memberS)
+ (^ [_ (#;Form (list [_ (#;Nat tag)] [_ (#;Bool last?)] memberS))])
(contains-self-reference? memberS)
- (#ls;Tuple membersS)
+ [_ (#;Tuple membersS)]
(list;any? contains-self-reference? membersS)
- (#ls;Case inputS pathS)
+ (^ [_ (#;Form (list [_ (#;Int var)]))])
+ (&&function;self? var)
+
+ (^ [_ (#;Form (list [_ (#;Text "lux case")] inputS pathS))])
(or (contains-self-reference? inputS)
(loop [pathS pathS]
(case pathS
- (^or (#ls;AltP leftS rightS)
- (#ls;SeqP leftS rightS))
+ (^or (^ [_ (#;Form (list [_ (#;Text "lux case alt")] leftS rightS))])
+ (^ [_ (#;Form (list [_ (#;Text "lux case seq")] leftS rightS))]))
(or (recur leftS)
(recur rightS))
-
- (#ls;ExecP bodyS)
+
+ (^ [_ (#;Form (list [_ (#;Text "lux case exec")] bodyS))])
(contains-self-reference? bodyS)
_
false)))
- (#ls;Function arity environment bodyS)
- (list;any? &&function;self? environment)
-
- (#ls;Call argsS funcS)
+ (^ [_ (#;Form (list [_ (#;Text "lux function")] arity [_ (#;Tuple environment)] bodyS))])
+ (list;any? (function [captured]
+ (case captured
+ (^ [_ (#;Form (list [_ (#;Int var)]))])
+ (&&function;self? var)
+
+ _
+ false))
+ environment)
+
+ (^ [_ (#;Form (list& [_ (#;Text "lux call")] funcS argsS))])
(or (contains-self-reference? funcS)
(list;any? contains-self-reference? argsS))
-
- (^or (#ls;Recur argsS)
- (#ls;Procedure name argsS))
- (list;any? contains-self-reference? argsS)
-
- (#ls;Variable idx)
- (&&function;self? idx)
- (#ls;Let register inputS bodyS)
+ (^ [_ (#;Form (list [_ (#;Text "lux let")] register inputS bodyS))])
(or (contains-self-reference? inputS)
(contains-self-reference? bodyS))
- (#ls;If inputS thenS elseS)
+ (^ [_ (#;Form (list [_ (#;Text "lux if")] inputS thenS elseS))])
(or (contains-self-reference? inputS)
(contains-self-reference? thenS)
(contains-self-reference? elseS))
- (#ls;Loop offset argsS bodyS)
- (or (list;any? contains-self-reference? argsS)
+ (^ [_ (#;Form (list [_ (#;Text "lux loop")] offset [_ (#;Tuple initsS)] bodyS))])
+ (or (list;any? contains-self-reference? initsS)
(contains-self-reference? bodyS))
+
+ (^or (^ [_ (#;Form (list& [_ (#;Text "lux recur")] argsS))])
+ (^ [_ (#;Form (list& [_ (#;Text procedure)] argsS))]))
+ (list;any? contains-self-reference? argsS)
_
false
@@ -65,37 +75,34 @@
(-> Nat ls;Synthesis ls;Synthesis)
(loop [exprS exprS]
(case exprS
- (#ls;Case inputS pathS)
- (#ls;Case inputS
- (let [reify-recursion' recur]
- (loop [pathS pathS]
- (case pathS
- (#ls;AltP leftS rightS)
- (#ls;AltP (recur leftS) (recur rightS))
-
- (#ls;SeqP leftS rightS)
- (#ls;SeqP leftS (recur rightS))
-
- (#ls;ExecP bodyS)
- (#ls;ExecP (reify-recursion' bodyS))
-
- _
- pathS))))
-
- (^multi (#ls;Call argsS (#ls;Variable 0))
+ (^ [_ (#;Form (list [_ (#;Text "lux case")] inputS pathS))])
+ (` ("lux case" (~ inputS)
+ (~ (let [reify-recursion' recur]
+ (loop [pathS pathS]
+ (case pathS
+ (^ [_ (#;Form (list [_ (#;Text "lux case alt")] leftS rightS))])
+ (` ("lux case alt" (~ (recur leftS)) (~ (recur rightS))))
+
+ (^ [_ (#;Form (list [_ (#;Text "lux case seq")] leftS rightS))])
+ (` ("lux case seq" (~ leftS) (~ (recur rightS))))
+
+ (^ [_ (#;Form (list [_ (#;Text "lux case exec")] bodyS))])
+ (` ("lux case exec" (~ (reify-recursion' bodyS))))
+
+ _
+ pathS))))))
+
+ (^multi (^ [_ (#;Form (list& [_ (#;Text "lux call")]
+ [_ (#;Form (list [_ (#;Int 0)]))]
+ argsS))])
(n.= arity (list;size argsS)))
- (#ls;Recur argsS)
+ (` ("lux recur" (~@ argsS)))
- (#ls;Call argsS (#ls;Variable var))
- exprS
+ (^ [_ (#;Form (list [_ (#;Text "lux let")] register inputS bodyS))])
+ (` ("lux let" (~ register) (~ inputS) (~ (recur bodyS))))
- (#ls;Let register inputS bodyS)
- (#ls;Let register inputS (recur bodyS))
-
- (#ls;If inputS thenS elseS)
- (#ls;If inputS
- (recur thenS)
- (recur elseS))
+ (^ [_ (#;Form (list [_ (#;Text "lux if")] inputS thenS elseS))])
+ (` ("lux if" (~ inputS) (~ (recur thenS)) (~ (recur elseS))))
_
exprS
@@ -109,58 +116,69 @@
(|> env (list;nth idx) maybe;assume))))]
(loop [exprS exprS]
(case exprS
- (#ls;Variant tag last? valueS)
- (#ls;Variant tag last? (recur valueS))
+ (^ [_ (#;Form (list [_ (#;Nat tag)] last? valueS))])
+ (` ((~ (code;nat tag)) (~ last?) (~ (recur valueS))))
- (#ls;Tuple members)
- (#ls;Tuple (L/map recur members))
-
- (#ls;Case inputS pathS)
- (#ls;Case (recur inputS)
- (let [adjust' recur]
- (loop [pathS pathS]
- (case pathS
- (^template []
- ( leftS rightS)
- ( (recur leftS) (recur rightS)))
- ([#ls;AltP]
- [#ls;SeqP])
-
- (#ls;ExecP bodyS)
- (#ls;ExecP (adjust' bodyS))
-
- _
- pathS))))
-
- (#ls;Function arity scope bodyS)
- (#ls;Function arity
- (L/map resolve-captured scope)
- (recur bodyS))
-
- (#ls;Call argsS funcS)
- (#ls;Call (L/map recur argsS) (recur funcS))
-
- (#ls;Recur argsS)
- (#ls;Recur (L/map recur argsS))
-
- (#ls;Procedure name argsS)
- (#ls;Procedure name (L/map recur argsS))
-
- (#ls;Variable var)
- (if (&&function;captured? var)
- (#ls;Variable (resolve-captured var))
- (#ls;Variable (|> outer-offset nat-to-int (i.+ var))))
-
- (#ls;Let register inputS bodyS)
- (#ls;Let (n.+ outer-offset register) (recur inputS) (recur bodyS))
-
- (#ls;If inputS thenS elseS)
- (#ls;If (recur inputS) (recur thenS) (recur elseS))
+ [_ (#;Tuple members)]
+ [_ (#;Tuple (list/map recur members))]
+
+ (^ [_ (#;Form (list [_ (#;Text "lux case")] inputS pathS))])
+ (` ("lux case" (~ (recur inputS))
+ (~ (let [adjust' recur]
+ (loop [pathS pathS]
+ (case pathS
+ (^template []
+ (^ [_ (#;Form (list [_ (#;Text )] leftS rightS))])
+ (` ( (~ (recur leftS)) (~ (recur rightS)))))
+ (["lux case alt"]
+ ["lux case seq"])
+
+ (^ [_ (#;Form (list [_ (#;Text "lux case exec")] bodyS))])
+ (` ("lux case exec" (~ (adjust' bodyS))))
+
+ _
+ pathS))))))
+
+ (^ [_ (#;Form (list [_ (#;Text "lux function")] arity [_ (#;Tuple environment)] bodyS))])
+ (` ("lux function" (~ arity)
+ (~ [_ (#;Tuple (list/map (function [_var]
+ (case _var
+ (^ [_ (#;Form (list [_ (#;Int var)]))])
+ (` ((~ (code;int (resolve-captured var)))))
+
+ _
+ _var))
+ environment))])
+ (~ (recur bodyS))))
+
+ (^ [_ (#;Form (list& [_ (#;Text "lux call")] funcS argsS))])
+ (` ("lux call" (~ (recur funcS)) (~@ (list/map recur argsS))))
+
+ (^ [_ (#;Form (list& [_ (#;Text "lux recur")] argsS))])
+ (` ("lux recur" (~@ (list/map recur argsS))))
+
+ (^ [_ (#;Form (list& [_ (#;Text procedure)] argsS))])
+ (` ((~ (code;text procedure)) (~@ (list/map recur argsS))))
- (#ls;Loop inner-offset argsS bodyS)
- (#ls;Loop (n.+ outer-offset inner-offset)
- (L/map recur argsS)
- (recur bodyS))
+ (^ [_ (#;Form (list [_ (#;Int var)]))])
+ (if (&&function;captured? var)
+ (` ((~ (code;int (resolve-captured var)))))
+ (` ((~ (code;int (|> outer-offset nat-to-int (i.+ var)))))))
+
+ (^ [_ (#;Form (list [_ (#;Text "lux let")] [_ (#;Nat register)] inputS bodyS))])
+ (` ("lux let" (~ (code;nat (n.+ outer-offset register)))
+ (~ (recur inputS))
+ (~ (recur bodyS))))
+
+ (^ [_ (#;Form (list [_ (#;Text "lux if")] inputS thenS elseS))])
+ (` ("lux if" (~ (recur inputS))
+ (~ (recur thenS))
+ (~ (recur elseS))))
+
+ (^ [_ (#;Form (list [_ (#;Text "lux loop")] [_ (#;Nat inner-offset)] [_ (#;Tuple initsS)] bodyS))])
+ (` ("lux loop" (~ (code;nat (n.+ outer-offset inner-offset)))
+ [(~@ (list/map recur initsS))]
+ (~ (recur bodyS))))
_
exprS
diff --git a/new-luxc/test/test/luxc/generator/case.lux b/new-luxc/test/test/luxc/generator/case.lux
index f9e165c03..ff0e017aa 100644
--- a/new-luxc/test/test/luxc/generator/case.lux
+++ b/new-luxc/test/test/luxc/generator/case.lux
@@ -4,9 +4,11 @@
(control [monad #+ do]
pipe)
(data ["e" error]
+ text/format
(coll [list]))
["r" math/random "r/" Monad]
[meta]
+ (meta [code])
test)
(luxc (lang ["ls" synthesis])
[analyser]
@@ -28,46 +30,44 @@
(r;Random [ls;Synthesis ls;Path])
(<| r;rec (function [gen-case])
(`` ($_ r;either
- (r/wrap [#ls;Unit #ls;UnitP])
- (~~ (do-template [ ]
+ (r/wrap [(' []) (' ("lux case pop"))])
+ (~~ (do-template [ ]
[(do r;Monad
[value ]
- (wrap [( value) ( value)]))]
+ (wrap [( value) ( value)]))]
- [r;bool #ls;Bool #ls;BoolP]
- [r;nat #ls;Nat #ls;NatP]
- [r;int #ls;Int #ls;IntP]
- [r;deg #ls;Deg #ls;DegP]
- [r;frac #ls;Frac #ls;FracP]
- [(r;text +5) #ls;Text #ls;TextP]))
+ [r;bool code;bool]
+ [r;nat code;nat]
+ [r;int code;int]
+ [r;deg code;deg]
+ [r;frac code;frac]
+ [(r;text +5) code;text]))
(do r;Monad
[size (|> r;nat (:: @ map (|>. (n.% struct-limit) (n.max +2))))
idx (|> r;nat (:: @ map (n.% size)))
[subS subP] gen-case
- #let [caseS (#ls;Tuple (list;concat (list (list;repeat idx #ls;Unit)
- (list subS)
- (list;repeat (|> size n.dec (n.- idx)) #ls;Unit))))
- caseP (#ls;TupleP (if (tail? size idx)
- (#;Right idx)
- (#;Left idx))
- subP)]]
+ #let [caseS (` [(~@ (list;concat (list (list;repeat idx (' []))
+ (list subS)
+ (list;repeat (|> size n.dec (n.- idx)) (' [])))))])
+ caseP (if (tail? size idx)
+ (` ("lux case tuple right" (~ (code;nat idx)) (~ subP)))
+ (` ("lux case tuple left" (~ (code;nat idx)) (~ subP))))]]
(wrap [caseS caseP]))
(do r;Monad
[size (|> r;nat (:: @ map (|>. (n.% struct-limit) (n.max +2))))
idx (|> r;nat (:: @ map (n.% size)))
[subS subP] gen-case
- #let [caseS (#ls;Variant idx (tail? idx idx) subS)
- caseP (#ls;VariantP (if (tail? idx idx)
- (#;Right idx)
- (#;Left idx))
- subP)]]
+ #let [caseS (` ((~ (code;nat idx)) (~ (code;bool (tail? size idx))) (~ subS)))
+ caseP (if (tail? size idx)
+ (` ("lux case variant right" (~ (code;nat idx)) (~ subP)))
+ (` ("lux case variant left" (~ (code;nat idx)) (~ subP))))]]
(wrap [caseS caseP]))
))))
(context: "Pattern-matching."
(<| (times +100)
(do @
- [[valueS path] gen-case
+ [[valueS pathS] gen-case
to-bind r;nat]
($_ seq
(test "Can generate pattern-matching."
@@ -75,21 +75,25 @@
[runtime-bytecode @runtime;generate
sampleI (@;generate-case exprG;generate
valueS
- (#ls;AltP (#ls;SeqP path (#ls;ExecP (#ls;Bool true)))
- (#ls;SeqP (#ls;BindP +0) (#ls;ExecP (#ls;Bool false)))))]
+ (` ("lux case alt"
+ ("lux case seq" (~ pathS)
+ ("lux case exec" true))
+ ("lux case seq" ("lux case bind" +0)
+ ("lux case exec" false)))))]
(@eval;eval sampleI))
(meta;run (init-compiler []))
(case> (#e;Success valueG)
(:! Bool valueG)
- _
+ (#e;Error error)
false)))
(test "Can bind values."
(|> (do meta;Monad
[runtime-bytecode @runtime;generate
sampleI (@;generate-case exprG;generate
- (#ls;Nat to-bind)
- (#ls;SeqP (#ls;BindP +1) (#ls;ExecP (#ls;Variable 1))))]
+ (code;nat to-bind)
+ (` ("lux case seq" ("lux case bind" +0)
+ ("lux case exec" (0)))))]
(@eval;eval sampleI))
(meta;run (init-compiler []))
(case> (#e;Success valueG)
diff --git a/new-luxc/test/test/luxc/generator/function.lux b/new-luxc/test/test/luxc/generator/function.lux
index dfc1230be..1f922706c 100644
--- a/new-luxc/test/test/luxc/generator/function.lux
+++ b/new-luxc/test/test/luxc/generator/function.lux
@@ -33,7 +33,8 @@
(do r;Monad
[arity arity
arg (|> r;nat (:: @ map (n.% arity)))
- #let [functionS (#ls;Function arity (list) (#ls;Variable (nat-to-int (n.inc arg))))]]
+ #let [functionS (` ("lux function" (~ (code;nat arity)) []
+ ((~ (code;int (nat-to-int (n.inc arg)))))))]]
(wrap [arity arg functionS])))
(context: "Function."
@@ -43,14 +44,14 @@
cut-off (|> r;nat (:: @ map (n.% arity)))
args (r;list arity r;nat)
#let [arg-value (maybe;assume (list;nth arg args))
- argsS (list/map (|>. #ls;Nat) args)
+ argsS (list/map code;nat args)
last-arg (n.dec arity)
cut-off (|> cut-off (n.min (n.dec last-arg)))]]
($_ seq
(test "Can read arguments."
(|> (do meta;Monad
[runtime-bytecode @runtime;generate
- sampleI (@expr;generate (#ls;Call argsS functionS))]
+ sampleI (@expr;generate (` ("lux call" (~ functionS) (~@ argsS))))]
(@eval;eval sampleI))
(meta;run (init-compiler []))
(case> (#e;Success valueG)
@@ -65,7 +66,9 @@
preS (list;take partial-arity argsS)
postS (list;drop partial-arity argsS)]
runtime-bytecode @runtime;generate
- sampleI (@expr;generate (|> functionS (#ls;Call preS) (#ls;Call postS)))]
+ sampleI (@expr;generate (` ("lux call"
+ ("lux call" (~ functionS) (~@ preS))
+ (~@ postS))))]
(@eval;eval sampleI))
(meta;run (init-compiler []))
(case> (#e;Success valueG)
@@ -83,11 +86,11 @@
(|> arg n.inc nat-to-int (i.* -1))
(|> arg n.inc (n.- super-arity) nat-to-int))
sub-arity (|> arity (n.- super-arity))
- functionS (<| (#ls;Function super-arity (list))
- (#ls;Function sub-arity env)
- (#ls;Variable arg-var))]
+ functionS (` ("lux function" (~ (code;nat super-arity)) []
+ ("lux function" (~ (code;nat sub-arity)) [(~@ (list/map code;int env))]
+ ((~ (code;int arg-var))))))]
runtime-bytecode @runtime;generate
- sampleI (@expr;generate (#ls;Call argsS functionS))]
+ sampleI (@expr;generate (` ("lux call" (~ functionS) (~@ argsS))))]
(@eval;eval sampleI))
(meta;run (init-compiler []))
(case> (#e;Success valueG)
diff --git a/new-luxc/test/test/luxc/generator/primitive.lux b/new-luxc/test/test/luxc/generator/primitive.lux
index 66eacca27..37f87829b 100644
--- a/new-luxc/test/test/luxc/generator/primitive.lux
+++ b/new-luxc/test/test/luxc/generator/primitive.lux
@@ -9,6 +9,7 @@
[text "T/" Eq])
["r" math/random]
[meta]
+ (meta [code])
test)
(luxc [";L" host]
(lang ["ls" synthesis])
@@ -42,16 +43,16 @@
_
false)))]
- ["bool" Bool #ls;Bool %bool% B/=]
- ["nat" Nat #ls;Nat %nat% n.=]
- ["int" Int #ls;Int %int% i.=]
- ["deg" Deg #ls;Deg %deg% d.=]
- ["frac" Frac #ls;Frac %frac% f.=]
- ["text" Text #ls;Text %text% T/=])]
+ ["bool" Bool code;bool %bool% B/=]
+ ["nat" Nat code;nat %nat% n.=]
+ ["int" Int code;int %int% i.=]
+ ["deg" Deg code;deg %deg% d.=]
+ ["frac" Frac code;frac %frac% f.=]
+ ["text" Text code;text %text% T/=])]
($_ seq
(test "Can generate unit."
(|> (do meta;Monad
- [sampleI (@;generate #ls;Unit)]
+ [sampleI (@;generate (' []))]
(@eval;eval sampleI))
(meta;run (init-compiler []))
(case> (#e;Success valueG)
diff --git a/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux b/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux
index dde15b19b..7e36575d8 100644
--- a/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux
+++ b/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux
@@ -12,7 +12,8 @@
(coll ["a" array]
[list]))
["r" math/random]
- [meta #+ Monad]
+ [meta]
+ (meta [code])
[host]
test)
(luxc (lang ["ls" synthesis])
@@ -32,9 +33,8 @@
(with-expansions [ (do-template [ ]
[(test
(|> (do meta;Monad
- [sampleI (@;generate (#ls;Procedure
- (list (#ls;Nat subject)
- (#ls;Nat param))))]
+ [sampleI (@;generate (` ( (~ (code;nat subject))
+ (~ (code;nat param)))))]
(@eval;eval sampleI))
(meta;run (init-compiler []))
(case> (#e;Success valueG)
@@ -52,7 +52,7 @@
($_ seq
(test "bit count"
(|> (do meta;Monad
- [sampleI (@;generate (#ls;Procedure "bit count" (list (#ls;Nat subject))))]
+ [sampleI (@;generate (` ("bit count" (~ (code;nat subject)))))]
(@eval;eval sampleI))
(meta;run (init-compiler []))
(case> (#e;Success valueG)
@@ -64,9 +64,9 @@
(test "bit shift-right"
(|> (do meta;Monad
- [sampleI (@;generate (#ls;Procedure "bit shift-right"
- (list (#ls;Int (nat-to-int subject))
- (#ls;Nat param))))]
+ [sampleI (@;generate (` ("bit shift-right"
+ (~ (code;int (nat-to-int subject)))
+ (~ (code;nat param)))))]
(@eval;eval sampleI))
(meta;run (init-compiler []))
(case> (#e;Success valueG)
@@ -82,64 +82,59 @@
(do @
[param (|> r;nat (r;filter (|>. (n.= +0) not)))
subject r;nat]
- (with-expansions [ (do-template [ ]
- [(test
- (|> (do meta;Monad
- [sampleI (@;generate (#ls;Procedure (list)))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- (n.= (:! Nat valueG))
+ (`` ($_ seq
+ (~~ (do-template [ ]
+ [(test
+ (|> (do meta;Monad
+ [sampleI (@;generate (` ()))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ (n.= (:! Nat valueG))
- _
- false)))]
+ _
+ false)))]
- ["nat min" nat/bottom]
- ["nat max" nat/top]
- )
- (do-template [ ]
- [(test
- (|> (do meta;Monad
- [sampleI (@;generate (#ls;Procedure (list (#ls;Nat subject))))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- ( ( subject) (:! valueG))
+ ["nat min" nat/bottom]
+ ["nat max" nat/top]
+ ))
+ (~~ (do-template [ ]
+ [(test
+ (|> (do meta;Monad
+ [sampleI (@;generate (` ( (~ (code;nat subject)))))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ ( ( subject) (:! valueG))
- _
- false)))]
+ _
+ false)))]
- ["nat to-int" Int nat-to-int i.=]
- ["nat to-char" Text text;from-code text/=]
- )
- (do-template [ ]
- [(test
- (|> (do Monad
- [runtime-bytecode @runtime;generate
- sampleI (@;generate (#ls;Procedure
- (list (#ls;Nat subject)
- (#ls;Nat param))))]
- (@eval;eval sampleI))
- (meta;run (init-compiler []))
- (case> (#e;Success valueG)
- ( ( param subject) (:! valueG))
+ ["nat to-int" Int nat-to-int i.=]
+ ["nat to-char" Text text;from-code text/=]
+ ))
+ (~~ (do-template [ ]
+ [(test
+ (|> (do meta;Monad
+ [runtime-bytecode @runtime;generate
+ sampleI (@;generate (` ( (~ (code;nat subject)) (~ (code;nat param)))))]
+ (@eval;eval sampleI))
+ (meta;run (init-compiler []))
+ (case> (#e;Success valueG)
+ ( ( param subject) (:! valueG))
- _
- false)))]
+ _
+ false)))]
- ["nat +" n.+ Nat n.=]
- ["nat -" n.- Nat n.=]
- ["nat *" n.* Nat n.=]
- ["nat /" n./ Nat n.=]
- ["nat %" n.% Nat n.=]
- ["nat =" n.= Bool bool/=]
- ["nat <" n.< Bool bool/=]
- )]
- ($_ seq
-
-
-
- )))))
+ ["nat +" n.+ Nat n.=]
+ ["nat -" n.- Nat n.=]
+ ["nat *" n.* Nat n.=]
+ ["nat /" n./ Nat n.=]
+ ["nat %" n.% Nat n.=]
+ ["nat =" n.= Bool bool/=]
+ ["nat <" n.< Bool bool/=]
+ ))
+ )))))
(context: "Int procedures"
(<| (times +100)
@@ -149,7 +144,7 @@
(with-expansions [ (do-template [ ]
[(test
(|> (do meta;Monad
- [sampleI (@;generate (#ls;Procedure (list)))]
+ [sampleI (@;generate (` ()))]
(@eval;eval sampleI))
(meta;run (init-compiler []))
(case> (#e;Success valueG)
@@ -164,7 +159,7 @@
(do-template [ ]
[(test
(|> (do meta;Monad
- [sampleI (@;generate (#ls;Procedure (list (#ls;Int subject))))]
+ [sampleI (@;generate (` ( (~ (code;int subject)))))]
(@eval;eval sampleI))
(meta;run (init-compiler []))
(case> (#e;Success valueG)
@@ -178,11 +173,9 @@
)
(do-template [ ]
[(test
- (|> (do Monad
+ (|> (do meta;Monad
[runtime-bytecode @runtime;generate
- sampleI (@;generate (#ls;Procedure
- (list (#ls;Int subject)
- (#ls;Int param))))]
+ sampleI (@;generate (` ( (~ (code;int subject)) (~ (code;int param)))))]
(@eval;eval sampleI))
(meta;run (init-compiler []))
(case> (#e;Success valueG)
@@ -212,11 +205,9 @@
subject r;frac]
(with-expansions [ (do-template [ ]
[(test
- (|> (do Monad
+ (|> (do meta;Monad
[runtime-bytecode @runtime;generate
- sampleI (@;generate (#ls;Procedure
- (list (#ls;Frac subject)
- (#ls;Frac param))))]
+ sampleI (@;generate (` ( (~ (code;frac subject)) (~ (code;frac param)))))]
(@eval;eval sampleI))
(meta;run (init-compiler []))
(case> (#e;Success valueG)
@@ -245,7 +236,7 @@
(with-expansions [ (do-template [ ]
[(test
(|> (do meta;Monad
- [sampleI (@;generate (#ls;Procedure (list)))]
+ [sampleI (@;generate (` ()))]
(@eval;eval sampleI))
(meta;run (init-compiler []))
(case> (#e;Success valueG)
@@ -263,9 +254,9 @@
)
(do-template [ ]
[(test
- (|> (do Monad
+ (|> (do meta;Monad
[runtime-bytecode @runtime;generate
- sampleI (@;generate (#ls;Procedure (list (#ls;Frac subject))))]
+ sampleI (@;generate (` ( (~ (code;frac subject)))))]
(@eval;eval sampleI))
(meta;run (init-compiler []))
(case> (#e;Success valueG)
@@ -281,11 +272,9 @@
(test "frac encode|decode"
- (|> (do Monad
+ (|> (do meta;Monad
[runtime-bytecode @runtime;generate
- sampleI (@;generate (|> (#ls;Frac subject)
- (list) (#ls;Procedure "frac encode")
- (list) (#ls;Procedure "frac decode")))]
+ sampleI (@;generate (` ("frac decode" ("frac encode" (~ (code;frac subject))))))]
(@eval;eval sampleI))
(meta;run (init-compiler []))
(case> (^multi (#e;Success valueG)
@@ -313,7 +302,7 @@
(~~ (do-template [ ]
[(test
(|> (do meta;Monad
- [sampleI (@;generate (#ls;Procedure (list)))]
+ [sampleI (@;generate (` ()))]
(@eval;eval sampleI))
(meta;run (init-compiler []))
(case> (#e;Success valueG)
@@ -327,9 +316,9 @@
))
(~~ (do-template [ ]
[(test
- (|> (do Monad
+ (|> (do meta;Monad
[runtime-bytecode @runtime;generate
- sampleI (@;generate (#ls;Procedure (list (#ls;Deg subject))))]
+ sampleI (@;generate (` ( (~ (code;deg subject)))))]
(@eval;eval sampleI))
(meta;run (init-compiler []))
(case> (#e;Success valueG)
@@ -342,11 +331,9 @@
))
(~~ (do-template [ ]
[(test
- (|> (do Monad
+ (|> (do meta;Monad
[runtime-bytecode @runtime;generate
- sampleI (@;generate (#ls;Procedure
- (list (#ls;Deg subject)
- (#ls;Deg param))))]
+ sampleI (@;generate (` ( (~ (code;deg subject)) (~ (code;deg param)))))]
(@eval;eval sampleI))
(meta;run (init-compiler []))
(case> (#e;Success valueG)
@@ -365,11 +352,9 @@
))
(~~ (do-template [ ]
[(test
- (|> (do Monad
+ (|> (do meta;Monad
[runtime-bytecode @runtime;generate
- sampleI (@;generate (#ls;Procedure
- (list (#ls;Deg subject)
- (#ls;Nat special))))]
+ sampleI (@;generate (` ( (~ (code;deg subject)) (~ (code;nat special)))))]
(@eval;eval sampleI))
(meta;run (init-compiler []))
(case> (#e;Success valueG)
diff --git a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux
index 7a047dff9..153f276cc 100644
--- a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux
+++ b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux
@@ -12,7 +12,8 @@
text/format
(coll [list]))
["r" math/random "r/" Monad]
- [meta #+ Monad]
+ [meta]
+ (meta [code])
[host]
test)
(luxc [";L" host]
@@ -33,9 +34,7 @@
(with-expansions [<2step> (do-template [ ]
[(test (format " / " )
(|> (do meta;Monad
- [sampleI (@;generate (|> ( )
- (list) (#ls;Procedure )
- (list) (#ls;Procedure )))]
+ [sampleI (@;generate (|> (~ ( )) (`)))]
(@eval;eval sampleI))
(meta;run (init-compiler []))
(case> (#e;Success valueG)
@@ -44,14 +43,14 @@
(#e;Error error)
false)))]
- ["jvm convert double-to-float" "jvm convert float-to-double" #ls;Frac frac-sample Frac f.=]
- ["jvm convert double-to-int" "jvm convert int-to-double" #ls;Frac frac-sample Frac f.=]
- ["jvm convert double-to-long" "jvm convert long-to-double" #ls;Frac frac-sample Frac f.=]
+ ["jvm convert double-to-float" "jvm convert float-to-double" code;frac frac-sample Frac f.=]
+ ["jvm convert double-to-int" "jvm convert int-to-double" code;frac frac-sample Frac f.=]
+ ["jvm convert double-to-long" "jvm convert long-to-double" code;frac frac-sample Frac f.=]
- ["jvm convert long-to-float" "jvm convert float-to-long" #ls;Int int-sample Int i.=]
- ["jvm convert long-to-int" "jvm convert int-to-long" #ls;Int int-sample Int i.=]
- ["jvm convert long-to-short" "jvm convert short-to-long" #ls;Int int-sample Int i.=]
- ["jvm convert long-to-byte" "jvm convert byte-to-long" #ls;Int int-sample Int i.=]
+ ["jvm convert long-to-float" "jvm convert float-to-long" code;int int-sample Int i.=]
+ ["jvm convert long-to-int" "jvm convert int-to-long" code;int int-sample Int i.=]
+ ["jvm convert long-to-short" "jvm convert short-to-long" code;int int-sample Int i.=]
+ ["jvm convert long-to-byte" "jvm convert byte-to-long" code;int int-sample Int i.=]
)]
($_ seq
<2step>
@@ -62,52 +61,50 @@
(do @
[int-sample (|> r;int (:: @ map (|>. (i.% 128) int/abs)))
#let [frac-sample (int-to-frac int-sample)]]
- (with-expansions [<3step> (do-template [ ]
- [(test (format " / " " / " )
- (|> (do meta;Monad