aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lux-mode/lux-mode.el2
-rw-r--r--new-luxc/source/luxc/lang/synthesis/expression.lux202
-rw-r--r--new-luxc/source/luxc/lang/synthesis/function.lux29
-rw-r--r--new-luxc/source/luxc/lang/synthesis/loop.lux188
-rw-r--r--new-luxc/test/test/luxc/lang/synthesis/common.lux37
-rw-r--r--new-luxc/test/test/luxc/lang/synthesis/function.lux151
-rw-r--r--new-luxc/test/test/luxc/lang/synthesis/primitive.lux46
-rw-r--r--new-luxc/test/test/luxc/lang/synthesis/structure.lux50
-rw-r--r--stdlib/source/lux.lux69
-rw-r--r--stdlib/source/lux/control/state.lux10
-rw-r--r--stdlib/source/lux/data/coll/list.lux6
-rw-r--r--stdlib/source/lux/data/text.lux2
-rw-r--r--stdlib/source/lux/lang/analysis.lux30
-rw-r--r--stdlib/source/lux/lang/analysis/case/coverage.lux2
-rw-r--r--stdlib/source/lux/lang/extension.lux22
-rw-r--r--stdlib/source/lux/lang/synthesis.lux152
-rw-r--r--stdlib/source/lux/lang/synthesis/expression.lux210
-rw-r--r--stdlib/source/lux/lang/synthesis/function.lux49
-rw-r--r--stdlib/source/lux/lang/synthesis/loop.lux277
-rw-r--r--stdlib/source/lux/lang/type/check.lux14
-rw-r--r--stdlib/source/lux/world/console.lux2
-rw-r--r--stdlib/test/test/lux/control/state.lux2
-rw-r--r--stdlib/test/test/lux/lang/synthesis/case.lux (renamed from new-luxc/test/test/luxc/lang/synthesis/case/special.lux)14
-rw-r--r--stdlib/test/test/lux/lang/synthesis/function.lux161
-rw-r--r--stdlib/test/test/lux/lang/synthesis/primitive.lux90
-rw-r--r--stdlib/test/test/lux/lang/synthesis/structure.lux54
26 files changed, 1098 insertions, 773 deletions
diff --git a/lux-mode/lux-mode.el b/lux-mode/lux-mode.el
index c8a3b89e0..91232201c 100644
--- a/lux-mode/lux-mode.el
+++ b/lux-mode/lux-mode.el
@@ -227,7 +227,7 @@ Called by `imenu--generic-function'."
"function" "case" ":" ":!" ":!!" "undefined" "ident-for" "static"
"and" "or"
"char"
- "exec" "let" "if" "cond" "do" "be" "open" "loop" "recur" "comment" "for"
+ "exec" "let" "if" "cond" "do" "be" "open:" "loop" "recur" "comment" "for"
"list" "list&" "io" "sequence" "tree"
"get@" "set@" "update@" "|>" "|>>" "<|" "<<|" "_$" "$_" "~" "~+" "~!" "~'" "::" ":::"
"|" "&" "->" "All" "Ex" "Rec" "primitive" "$" "type"
diff --git a/new-luxc/source/luxc/lang/synthesis/expression.lux b/new-luxc/source/luxc/lang/synthesis/expression.lux
deleted file mode 100644
index 3fa594086..000000000
--- a/new-luxc/source/luxc/lang/synthesis/expression.lux
+++ /dev/null
@@ -1,202 +0,0 @@
-(.module:
- lux
- (lux (control ["p" parser])
- (data [maybe]
- ["e" error]
- [number]
- [product]
- text/format
- (coll [list "list/" Functor<List> Fold<List> Monoid<List>]
- (dictionary ["dict" unordered #+ Dict])))
- (macro [code]
- ["s" syntax]))
- (luxc (lang ["la" analysis]
- ["ls" synthesis]
- [".L" extension #+ Syntheses]
- (synthesis [".S" case]
- [".S" function]
- [".S" loop])
- [".L" variable #+ Variable])
- ))
-
-(def: init-env (List Variable) (list))
-(def: init-resolver (Dict Int Int) (dict.new number.Hash<Int>))
-
-(def: (prepare-body inner-arity arity body)
- (-> ls.Arity ls.Arity ls.Synthesis ls.Synthesis)
- (if (functionS.nested? inner-arity)
- body
- (loopS.reify-recursion arity body)))
-
-(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 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)
- (-> 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 arity num-locals synthesize inputA branchesA)
- (-> ls.Arity Nat (-> Nat la.Analysis ls.Synthesis)
- la.Analysis (List [la.Pattern la.Analysis])
- ls.Synthesis)
- (let [inputS (synthesize num-locals inputA)]
- (case (list.reverse branchesA)
- (^multi (^ (list [(^code ("lux case bind" (~ [_ (#.Nat input-register)])))
- (^code ((~ [_ (#.Int var)])))]))
- (not (variableL.captured? var))
- (n/= input-register (variableL.local-register var)))
- inputS
-
- (^ (list [(^code ("lux case bind" (~ [_ (#.Nat register)]))) bodyA]))
- (let$ (if (functionS.nested? arity)
- (n/+ (n/dec arity) register)
- register)
- inputS
- (synthesize (n/inc num-locals) bodyA))
-
- (^or (^ (list [(^code true) thenA] [(^code false) elseA]))
- (^ (list [(^code false) elseA] [(^code true) thenA])))
- (if$ inputS (synthesize num-locals thenA) (synthesize num-locals elseA))
-
- (#.Cons [lastP lastA] prevsPA)
- (let [transform-branch (: (-> la.Pattern la.Analysis ls.Path)
- (caseS.path arity num-locals synthesize))
- pathS (list/fold caseS.weave
- (transform-branch lastP lastA)
- (list/map (product.uncurry transform-branch) prevsPA))]
- (` ("lux case" (~ inputS) (~ pathS))))
-
- _
- (undefined)
- )))
-
-(def: (synthesize-apply synthesize num-locals exprA)
- (-> (-> la.Analysis ls.Synthesis) Nat la.Analysis ls.Synthesis)
- (let [[funcA argsA] (functionS.unfold-apply exprA)
- funcS (synthesize funcA)
- argsS (list/map synthesize argsA)]
- (case funcS
- (^multi (^code ("lux function" (~ [_ (#.Nat _arity)]) [(~+ _env)] (~ _bodyS)))
- (and (n/= _arity (list.size argsS))
- (not (loopS.contains-self-reference? _bodyS)))
- [(s.run _env (p.some s.int)) (#e.Success _env)])
- (` ("lux loop" (~ (code.nat (n/inc num-locals))) [(~+ argsS)]
- (~ (loopS.adjust _env num-locals _bodyS))))
-
- (^code ("lux call" (~ funcS') (~+ argsS')))
- (call$ funcS' (list/compose argsS' argsS))
-
- _
- (call$ funcS argsS))))
-
-(def: #export (synthesize extensions expressionA)
- (-> Syntheses la.Analysis ls.Synthesis)
- (loop [arity +0
- resolver init-resolver
- direct? false
- num-locals +0
- expressionA expressionA]
- (case expressionA
- (^code [(~ _left) (~ _right)])
- (` [(~+ (list/map (recur arity resolver false num-locals)
- (la.unfold-tuple expressionA)))])
-
- (^or (^code ("lux sum left" (~ _)))
- (^code ("lux sum right" (~ _))))
- (let [[tag last? value] (maybe.assume (la.unfold-variant expressionA))]
- (variant$ tag last? (recur arity resolver false num-locals value)))
-
- (^code ((~ [_ (#.Int var)])))
- (if (variableL.local? var)
- (if (functionS.nested? arity)
- (if (variableL.self? var)
- (call$ (var$ 0) (|> (list.n/range +1 (n/dec arity))
- (list/map (|>> variableL.local code.int (~) () (`)))))
- (var$ (functionS.adjust-var arity var)))
- (var$ var))
- (var$ (maybe.default var (dict.get var resolver))))
-
- (^code ("lux case" (~ inputA) (~ [_ (#.Record branchesA)])))
- (synthesize-case arity num-locals (recur arity resolver false) inputA branchesA)
-
- (^multi (^code ("lux function" [(~+ scope)] (~ bodyA)))
- [(s.run scope (p.some s.int)) (#e.Success raw-env)])
- (let [function-arity (if direct?
- (n/inc arity)
- +1)
- env (list/map (function (_ closure)
- (case (dict.get closure resolver)
- (#.Some resolved)
- (if (and (variableL.local? resolved)
- (functionS.nested? arity)
- (|> resolved variableL.local-register (n/>= arity)))
- (functionS.adjust-var arity resolved)
- resolved)
-
- #.None
- (if (and (variableL.local? closure)
- (functionS.nested? arity))
- (functionS.adjust-var arity closure)
- closure)))
- raw-env)
- env-vars (: (List Variable)
- (case raw-env
- #.Nil (list)
- _ (|> (list.size raw-env) n/dec (list.n/range +0) (list/map variableL.captured))))
- resolver' (if (and (functionS.nested? function-arity)
- direct?)
- (list/fold (function (_ [from to] resolver')
- (dict.put from to resolver'))
- init-resolver
- (list.zip2 env-vars env))
- (list/fold (function (_ var resolver')
- (dict.put var var resolver'))
- init-resolver
- env-vars))]
- (case (recur function-arity resolver' true function-arity bodyA)
- (^ [_ (#.Form (list [_ (#.Text "lux function")] [_ (#.Nat unmerged-arity)] env' bodyS'))])
- (let [merged-arity (n/inc unmerged-arity)]
- (function$ merged-arity env
- (prepare-body function-arity merged-arity bodyS')))
-
- bodyS
- (function$ +1 env (prepare-body function-arity +1 bodyS))))
-
- (^code ("lux apply" (~+ _)))
- (synthesize-apply (recur arity resolver false num-locals) num-locals expressionA)
-
- (^code ((~ [_ (#.Text name)]) (~+ args)))
- (case (dict.get name extensions)
- #.None
- (procedure$ name (list/map (recur arity resolver false num-locals) args))
-
- (#.Some extension)
- (extension (recur arity resolver false num-locals) args))
-
- _
- expressionA)))
diff --git a/new-luxc/source/luxc/lang/synthesis/function.lux b/new-luxc/source/luxc/lang/synthesis/function.lux
deleted file mode 100644
index 25dd75aff..000000000
--- a/new-luxc/source/luxc/lang/synthesis/function.lux
+++ /dev/null
@@ -1,29 +0,0 @@
-(.module:
- lux
- (luxc (lang ["la" analysis]
- ["ls" synthesis]
- [".L" variable #+ Variable])))
-
-(do-template [<name> <comp> <ref>]
- [(def: #export (<name> arity)
- (-> ls.Arity Bool)
- (<comp> <ref> arity))]
-
- [nested? n/> +1]
- [top? n/= +0]
- )
-
-(def: #export (adjust-var outer var)
- (-> ls.Arity Variable Variable)
- (|> outer n/dec nat-to-int (i/+ var)))
-
-(def: #export (unfold-apply apply)
- (-> la.Analysis [la.Analysis (List la.Analysis)])
- (loop [apply apply
- args (list)]
- (case apply
- (^code ("lux apply" (~ arg) (~ func)))
- (recur func (#.Cons arg args))
-
- _
- [apply args])))
diff --git a/new-luxc/source/luxc/lang/synthesis/loop.lux b/new-luxc/source/luxc/lang/synthesis/loop.lux
deleted file mode 100644
index c00d5626b..000000000
--- a/new-luxc/source/luxc/lang/synthesis/loop.lux
+++ /dev/null
@@ -1,188 +0,0 @@
-(.module:
- lux
- (lux (control [monad #+ do]
- ["p" parser])
- (data [maybe]
- (coll [list "list/" Functor<List>]))
- (macro [code]
- [syntax]))
- (luxc (lang ["ls" synthesis]
- [".L" variable #+ Variable Register])))
-
-(def: #export (contains-self-reference? exprS)
- (-> ls.Synthesis Bool)
- (case exprS
- (^ [_ (#.Form (list [_ (#.Nat tag)] [_ (#.Bool last?)] memberS))])
- (contains-self-reference? memberS)
-
- [_ (#.Tuple membersS)]
- (list.any? contains-self-reference? membersS)
-
- (^ [_ (#.Form (list [_ (#.Int var)]))])
- (variableL.self? var)
-
- (^ [_ (#.Form (list [_ (#.Text "lux case")] inputS pathS))])
- (or (contains-self-reference? inputS)
- (loop [pathS pathS]
- (case pathS
- (^or (^ [_ (#.Form (list [_ (#.Text "lux case alt")] leftS rightS))])
- (^ [_ (#.Form (list [_ (#.Text "lux case seq")] leftS rightS))]))
- (or (recur leftS)
- (recur rightS))
-
- (^ [_ (#.Form (list [_ (#.Text "lux case exec")] bodyS))])
- (contains-self-reference? bodyS)
-
- _
- false)))
-
- (^ [_ (#.Form (list [_ (#.Text "lux function")] arity [_ (#.Tuple environment)] bodyS))])
- (list.any? (function (_ captured)
- (case captured
- (^ [_ (#.Form (list [_ (#.Int var)]))])
- (variableL.self? var)
-
- _
- false))
- environment)
-
- (^ [_ (#.Form (list& [_ (#.Text "lux call")] funcS argsS))])
- (or (contains-self-reference? funcS)
- (list.any? contains-self-reference? argsS))
-
- (^ [_ (#.Form (list [_ (#.Text "lux let")] register inputS bodyS))])
- (or (contains-self-reference? inputS)
- (contains-self-reference? bodyS))
-
- (^ [_ (#.Form (list [_ (#.Text "lux if")] inputS thenS elseS))])
- (or (contains-self-reference? inputS)
- (contains-self-reference? thenS)
- (contains-self-reference? elseS))
-
- (^ [_ (#.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
- ))
-
-(def: #export (reify-recursion arity exprS)
- (-> Nat ls.Synthesis ls.Synthesis)
- (loop [exprS exprS]
- (case exprS
- (^ [_ (#.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)))
- (` ("lux recur" (~+ argsS)))
-
- (^ [_ (#.Form (list [_ (#.Text "lux let")] register inputS bodyS))])
- (` ("lux let" (~ register) (~ inputS) (~ (recur bodyS))))
-
- (^ [_ (#.Form (list [_ (#.Text "lux if")] inputS thenS elseS))])
- (` ("lux if" (~ inputS) (~ (recur thenS)) (~ (recur elseS))))
-
- _
- exprS
- )))
-
-(def: #export (adjust env offset exprS)
- (-> (List Variable) Register ls.Synthesis ls.Synthesis)
- (let [resolve-captured (: (-> Variable Variable)
- (function (_ var)
- (let [idx (|> var (i/* -1) int-to-nat n/dec)]
- (|> env (list.nth idx) maybe.assume))))]
- (loop [exprS exprS]
- (case exprS
- (^code ((~ [_ (#.Nat tag)]) (~ last?) (~ valueS)))
- (` ((~ (code.nat tag)) (~ last?) (~ (recur valueS))))
-
- (^code [(~+ members)])
- (` [(~+ (list/map recur members))])
-
- (^code ("lux case" (~ inputS) (~ pathS)))
- (` ("lux case" (~ (recur inputS))
- (~ (let [adjust' recur]
- (loop [pathS pathS]
- (case pathS
- (^template [<pattern>]
- (^ [_ (#.Form (list [_ (#.Text <pattern>)] leftS rightS))])
- (` (<pattern> (~ (recur leftS)) (~ (recur rightS)))))
- (["lux case alt"]
- ["lux case seq"])
-
- (^code ("lux case bind" (~ [_ (#.Nat register)])))
- (` ("lux case bind" (~ (code.nat (n/+ offset register)))))
-
- (^ [_ (#.Form (list [_ (#.Text "lux case exec")] bodyS))])
- (` ("lux case exec" (~ (adjust' bodyS))))
-
- _
- pathS))))))
-
- (^code ("lux function" (~ arity) [(~+ environment)] (~ bodyS)))
- (` ("lux function" (~ arity)
- [(~+ (list/map (function (_ _var)
- (case _var
- (^ [_ (#.Form (list [_ (#.Int var)]))])
- (` ((~ (code.int (resolve-captured var)))))
-
- _
- _var))
- environment))]
- (~ 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))))
-
- (^code ("lux let" (~ [_ (#.Nat register)]) (~ inputS) (~ bodyS)))
- (` ("lux let" (~ (code.nat (n/+ 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 loop-offset)] [_ (#.Tuple initsS)] bodyS))])
- (` ("lux loop" (~ (code.nat (n/+ offset loop-offset)))
- [(~+ (list/map recur initsS))]
- (~ (recur bodyS))))
-
- (^ [_ (#.Form (list [_ (#.Int var)]))])
- (if (variableL.captured? var)
- (` ((~ (code.int (resolve-captured var)))))
- (` ((~ (code.int (|> offset nat-to-int (i/+ var)))))))
-
- (^ [_ (#.Form (list& [_ (#.Text procedure)] argsS))])
- (` ((~ (code.text procedure)) (~+ (list/map recur argsS))))
-
- _
- exprS
- ))))
diff --git a/new-luxc/test/test/luxc/lang/synthesis/common.lux b/new-luxc/test/test/luxc/lang/synthesis/common.lux
deleted file mode 100644
index 3379fe7fd..000000000
--- a/new-luxc/test/test/luxc/lang/synthesis/common.lux
+++ /dev/null
@@ -1,37 +0,0 @@
-(.module:
- lux
- (lux (data [bool "bool/" Eq<Bool>]
- [text "text/" Eq<Text>])
- (macro [code])
- ["r" math/random "r/" Monad<Random>])
- (luxc (lang ["la" analysis]
- ["ls" synthesis])))
-
-(def: #export gen-primitive
- (r.Random la.Analysis)
- (r.either (r.either (r.either (r/wrap (' []))
- (r/map code.bool r.bool))
- (r.either (r/map code.nat r.nat)
- (r/map code.int r.int)))
- (r.either (r.either (r/map code.deg r.deg)
- (r/map code.frac r.frac))
- (r/map code.text (r.text +5)))))
-
-(def: #export (corresponds? analysis synthesis)
- (-> la.Analysis ls.Synthesis Bool)
- (case [analysis synthesis]
- (^ [(^code []) (^code [])])
- true
-
- (^template [<tag> <test>]
- [[_ (<tag> valueA)] [_ (<tag> valueS)]]
- (<test> valueA valueS))
- ([#.Bool bool/=]
- [#.Nat n/=]
- [#.Int i/=]
- [#.Deg d/=]
- [#.Frac f/=]
- [#.Text text/=])
-
- _
- false))
diff --git a/new-luxc/test/test/luxc/lang/synthesis/function.lux b/new-luxc/test/test/luxc/lang/synthesis/function.lux
deleted file mode 100644
index fa29b4284..000000000
--- a/new-luxc/test/test/luxc/lang/synthesis/function.lux
+++ /dev/null
@@ -1,151 +0,0 @@
-(.module:
- lux
- (lux [io]
- (control [monad #+ do]
- pipe)
- (data [product]
- [maybe]
- [number]
- text/format
- (coll [list "list/" Functor<List> Fold<List>]
- (dictionary ["dict" unordered #+ Dict])
- (set ["set" unordered])))
- (macro [code])
- ["r" math/random "r/" Monad<Random>]
- test)
- (luxc (lang ["la" analysis]
- ["ls" synthesis]
- (synthesis [".S" expression])
- [".L" extension]
- [".L" variable #+ Variable]))
- (// common))
-
-(def: gen-function//constant
- (r.Random [Nat la.Analysis la.Analysis])
- (r.rec
- (function (_ gen-function//constant)
- (do r.Monad<Random>
- [function? r.bool]
- (if function?
- (do @
- [[num-args outputA subA] gen-function//constant]
- (wrap [(n/inc num-args)
- outputA
- (` ("lux function" [] (~ subA)))]))
- (do @
- [outputA gen-primitive]
- (wrap [+0 outputA outputA])))))))
-
-(def: (pick scope-size)
- (-> Nat (r.Random Nat))
- (|> r.nat (:: r.Monad<Random> map (n/% scope-size))))
-
-(def: gen-function//captured
- (r.Random [Nat Int la.Analysis])
- (do r.Monad<Random>
- [num-locals (|> r.nat (:: @ map (|>> (n/% +100) (n/max +10))))
- #let [indices (list.n/range +0 (n/dec num-locals))
- absolute-env (list/map variableL.local indices)
- relative-env (list/map variableL.captured indices)]
- [total-args prediction bodyA] (: (r.Random [Nat Int la.Analysis])
- (loop [num-args +1
- global-env relative-env]
- (let [env-size (list.size global-env)
- resolver (list/fold (function (_ [idx var] resolver)
- (dict.put idx var resolver))
- (: (Dict Nat Int)
- (dict.new number.Hash<Nat>))
- (list.zip2 (list.n/range +0 (n/dec env-size))
- global-env))]
- (do @
- [nest? r.bool]
- (if nest?
- (do @
- [num-picks (:: @ map (n/max +1) (pick (n/inc env-size)))
- picks (|> (r.set number.Hash<Nat> num-picks (pick env-size))
- (:: @ map set.to-list))
- [total-args prediction bodyA] (recur (n/inc num-args)
- (list/map (function (_ pick) (maybe.assume (list.nth pick global-env)))
- picks))]
- (wrap [total-args prediction (` ("lux function" [(~+ (list/map (|>> variableL.captured code.int) picks))]
- (~ bodyA)))]))
- (do @
- [chosen (pick (list.size global-env))]
- (wrap [num-args
- (maybe.assume (dict.get chosen resolver))
- (la.var (variableL.captured chosen))])))))))]
- (wrap [total-args prediction (` ("lux function"
- [(~+ (list/map code.int absolute-env))]
- (~ bodyA)))])
- ))
-
-(def: gen-function//local
- (r.Random [Nat Int la.Analysis])
- (loop [num-args +0
- nest? true]
- (if nest?
- (do r.Monad<Random>
- [nest?' r.bool
- [total-args prediction bodyA] (recur (n/inc num-args) nest?')]
- (wrap [total-args prediction (` ("lux function" [] (~ bodyA)))]))
- (do r.Monad<Random>
- [chosen (|> r.nat (:: @ map (|>> (n/% +100) (n/max +2))))]
- (wrap [num-args
- (|> chosen (n/+ (n/dec num-args)) nat-to-int)
- (la.var (variableL.local chosen))])))))
-
-(context: "Function definition."
- (<| (times +100)
- (do @
- [[args1 prediction1 function1] gen-function//constant
- [args2 prediction2 function2] gen-function//captured
- [args3 prediction3 function3] gen-function//local]
- ($_ seq
- (test "Nested functions will get folded together."
- (|> (expressionS.synthesize extensionL.no-syntheses function1)
- (case> (^ [_ (#.Form (list [_ (#.Text "lux function")] [_ (#.Nat args)] [_ (#.Tuple captured)] output))])
- (and (n/= args1 args)
- (corresponds? prediction1 output))
-
- _
- (n/= +0 args1))))
- (test "Folded functions provide direct access to captured variables."
- (|> (expressionS.synthesize extensionL.no-syntheses function2)
- (case> (^ [_ (#.Form (list [_ (#.Text "lux function")] [_ (#.Nat args)] [_ (#.Tuple captured)]
- [_ (#.Form (list [_ (#.Int output)]))]))])
- (and (n/= args2 args)
- (i/= prediction2 output))
-
- _
- false)))
- (test "Folded functions properly offset local variables."
- (|> (expressionS.synthesize extensionL.no-syntheses function3)
- (case> (^ [_ (#.Form (list [_ (#.Text "lux function")] [_ (#.Nat args)] [_ (#.Tuple captured)]
- [_ (#.Form (list [_ (#.Int output)]))]))])
- (and (n/= args3 args)
- (i/= prediction3 output))
-
- _
- false)))
- ))))
-
-(context: "Function application."
- (<| (times +100)
- (do @
- [num-args (|> r.nat (:: @ map (|>> (n/% +10) (n/max +1))))
- funcA gen-primitive
- argsA (r.list num-args gen-primitive)]
- ($_ seq
- (test "Can synthesize function application."
- (|> (expressionS.synthesize extensionL.no-syntheses (la.apply argsA funcA))
- (case> (^ [_ (#.Form (list& [_ (#.Text "lux call")] funcS argsS))])
- (and (corresponds? funcA funcS)
- (list.every? (product.uncurry corresponds?)
- (list.zip2 argsA argsS)))
-
- _
- false)))
- (test "Function application on no arguments just synthesizes to the function itself."
- (|> (expressionS.synthesize extensionL.no-syntheses (la.apply (list) funcA))
- (corresponds? funcA)))
- ))))
diff --git a/new-luxc/test/test/luxc/lang/synthesis/primitive.lux b/new-luxc/test/test/luxc/lang/synthesis/primitive.lux
deleted file mode 100644
index d2298193f..000000000
--- a/new-luxc/test/test/luxc/lang/synthesis/primitive.lux
+++ /dev/null
@@ -1,46 +0,0 @@
-(.module:
- lux
- (lux [io]
- (control [monad #+ do]
- pipe)
- (data text/format)
- (macro [code])
- ["r" math/random]
- test)
- (luxc (lang ["la" analysis]
- ["ls" synthesis]
- [".L" extension]
- (synthesis [".S" expression]))))
-
-(context: "Primitives"
- (<| (times +100)
- (do @
- [%bool% r.bool
- %nat% r.nat
- %int% r.int
- %deg% r.deg
- %frac% r.frac
- %text% (r.text +5)]
- (`` ($_ seq
- (test (format "Can synthesize unit.")
- (|> (expressionS.synthesize extensionL.no-syntheses (' []))
- (case> (^code [])
- true
-
- _
- false)))
- (~~ (do-template [<desc> <analysis> <synthesis> <sample>]
- [(test (format "Can synthesize " <desc> ".")
- (|> (expressionS.synthesize extensionL.no-syntheses (<analysis> <sample>))
- (case> [_ (<synthesis> value)]
- (is? <sample> value)
-
- _
- false)))]
-
- ["bool" code.bool #.Bool %bool%]
- ["nat" code.nat #.Nat %nat%]
- ["int" code.int #.Int %int%]
- ["deg" code.deg #.Deg %deg%]
- ["frac" code.frac #.Frac %frac%]
- ["text" code.text #.Text %text%])))))))
diff --git a/new-luxc/test/test/luxc/lang/synthesis/structure.lux b/new-luxc/test/test/luxc/lang/synthesis/structure.lux
deleted file mode 100644
index 46c9bf2a1..000000000
--- a/new-luxc/test/test/luxc/lang/synthesis/structure.lux
+++ /dev/null
@@ -1,50 +0,0 @@
-(.module:
- lux
- (lux [io]
- (control [monad #+ do]
- pipe)
- (data [bool "B/" Eq<Bool>]
- [product]
- (coll [list]))
- ["r" math/random "r/" Monad<Random>]
- test)
- (luxc (lang ["la" analysis]
- ["ls" synthesis]
- (synthesis [".S" expression])
- [".L" extension]))
- (// common))
-
-(context: "Variants"
- (<| (times +100)
- (do @
- [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2))))
- tagA (|> r.nat (:: @ map (n/% size)))
- memberA gen-primitive]
- ($_ seq
- (test "Can synthesize variants."
- (|> (expressionS.synthesize extensionL.no-syntheses (la.sum tagA size +0 memberA))
- (case> (^ [_ (#.Form (list [_ (#.Nat tagS)] [_ (#.Bool last?S)] memberS))])
- (and (n/= tagA tagS)
- (B/= (n/= (n/dec size) tagA)
- last?S)
- (corresponds? memberA memberS))
-
- _
- false)))
- ))))
-
-(context: "Tuples"
- (<| (times +100)
- (do @
- [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2))))
- membersA (r.list size gen-primitive)]
- ($_ seq
- (test "Can synthesize tuple."
- (|> (expressionS.synthesize extensionL.no-syntheses (la.product membersA))
- (case> [_ (#.Tuple membersS)]
- (and (n/= size (list.size membersS))
- (list.every? (product.uncurry corresponds?) (list.zip2 membersA membersS)))
-
- _
- false)))
- ))))
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux
index b84b0d096..157208071 100644
--- a/stdlib/source/lux.lux
+++ b/stdlib/source/lux.lux
@@ -4757,41 +4757,59 @@
(return (list (` ("lux def" (~ (symbol$ ["" (text/compose prefix name)])) (~ source+)
[(~ cursor-code) (#.Record #Nil)])))))))
-(macro: #export (open tokens)
+(macro: #export (open: tokens)
{#.doc "## Opens a structure and generates a definition for each of its members (including nested members).
## For example:
- (open Number<Int> \"i:\")
+ (open: \"i:\" Number<Int>)
## Will generate:
(def: i:+ (:: Number<Int> +))
(def: i:- (:: Number<Int> -))
(def: i:* (:: Number<Int> *))
+ ...
+
+ ## However, the prefix is optional.
+ ## For example:
+ (open: Number<Int>)
+ ## Will generate:
+ (def: + (:: Number<Int> +))
+ (def: - (:: Number<Int> -))
+ (def: * (:: Number<Int> *))
..."}
- (case tokens
- (^ (list& [_ (#Symbol struct-name)] tokens'))
- (do Monad<Meta>
- [@module current-module-name
- #let [prefix (case tokens'
- (^ (list [_ (#Text prefix)]))
- prefix
-
- _
- "")]
- struct-type (find-type struct-name)
- output (resolve-type-tags struct-type)
- #let [source (symbol$ struct-name)]]
- (case output
- (#Some [tags members])
+ (let [[prefix tokens'] (case tokens
+ (^ (list& [_ (#Text prefix)] tokens'))
+ [prefix tokens']
+
+ tokens'
+ ["" tokens'])]
+ (case tokens'
+ (^ (list struct))
+ (case struct
+ [_ (#Symbol struct-name)]
(do Monad<Meta>
- [decls' (monad/map Monad<Meta> (: (-> [Ident Type] (Meta (List Code)))
- (function (_ [sname stype]) (open-field prefix sname source stype)))
- (zip2 tags members))]
- (return (list/join decls')))
+ [struct-type (find-type struct-name)
+ output (resolve-type-tags struct-type)
+ #let [source (symbol$ struct-name)]]
+ (case output
+ (#Some [tags members])
+ (do Monad<Meta>
+ [decls' (monad/map Monad<Meta> (: (-> [Ident Type] (Meta (List Code)))
+ (function (_ [sname stype])
+ (open-field prefix sname source stype)))
+ (zip2 tags members))]
+ (return (list/join decls')))
+
+ _
+ (fail (text/compose "Can only \"open:\" structs: " (type/show struct-type)))))
_
- (fail (text/compose "Can only \"open\" structs: " (type/show struct-type)))))
+ (do Monad<Meta>
+ [g!struct (gensym "struct")]
+ (return (list (` ("lux def" (~ g!struct) (~ struct)
+ [(~ cursor-code) (#.Record #Nil)]))
+ (` (..open: (~ (text$ prefix)) (~ g!struct)))))))
- _
- (fail "Wrong syntax for open")))
+ _
+ (fail "Wrong syntax for open:"))))
(macro: #export (|>> tokens)
{#.doc "## Similar to the piping macro, but rather than taking an initial object to work on, creates a function for taking it.
@@ -4897,7 +4915,8 @@
defs')
openings (join-map (: (-> Openings (List Code))
(function (_ [prefix structs])
- (list/map (function (_ [_ name]) (` (open (~ (symbol$ [module-name name])) (~ (text$ prefix)))))
+ (list/map (function (_ [_ name])
+ (` (open: (~ (text$ prefix)) (~ (symbol$ [module-name name])))))
structs)))
r-opens)]]
(wrap (list/compose defs openings))
diff --git a/stdlib/source/lux/control/state.lux b/stdlib/source/lux/control/state.lux
index 296147e6b..be8844a0c 100644
--- a/stdlib/source/lux/control/state.lux
+++ b/stdlib/source/lux/control/state.lux
@@ -80,7 +80,7 @@
(All [s a] (-> s (State s a) [s a]))
(action state))
-(struct: (Functor<StateT> Functor<M>)
+(struct: (Functor<State'> Functor<M>)
(All [M s] (-> (F.Functor M) (F.Functor (All [a] (-> s (M [s a]))))))
(def: (map f sfa)
@@ -88,10 +88,10 @@
(:: Functor<M> map (function (_ [s a]) [s (f a)])
(sfa state)))))
-(struct: (Apply<StateT> Monad<M>)
+(struct: (Apply<State'> Monad<M>)
(All [M s] (-> (Monad M) (A.Apply (All [a] (-> s (M [s a]))))))
- (def: functor (Functor<StateT> (:: Monad<M> functor)))
+ (def: functor (Functor<State'> (:: Monad<M> functor)))
(def: (apply sFf sFa)
(function (_ state)
@@ -109,11 +109,11 @@
(All [M s a] (-> s (State' M s a) (M [s a])))
(action state))
-(struct: #export (StateT Monad<M>)
+(struct: #export (Monad<State'> Monad<M>)
{#.doc "A monad transformer to create composite stateful computations."}
(All [M s] (-> (Monad M) (Monad (State' M s))))
- (def: functor (Functor<StateT> (:: Monad<M> functor)))
+ (def: functor (Functor<State'> (:: Monad<M> functor)))
(def: (wrap a)
(function (_ state)
diff --git a/stdlib/source/lux/data/coll/list.lux b/stdlib/source/lux/data/coll/list.lux
index 063e9648c..5f41b4381 100644
--- a/stdlib/source/lux/data/coll/list.lux
+++ b/stdlib/source/lux/data/coll/list.lux
@@ -25,7 +25,7 @@
(#.Cons [x xs'])
(fold f (f x init) xs'))))
-(open Fold<List>)
+(open: Fold<List>)
(def: #export (reverse xs)
(All [a]
@@ -258,7 +258,7 @@
#.Nil ys
(#.Cons x xs') (#.Cons x (compose xs' ys)))))
-(open Monoid<List>)
+(open: Monoid<List>)
(struct: #export _ (Functor List)
(def: (map f ma)
@@ -266,7 +266,7 @@
#.Nil #.Nil
(#.Cons a ma') (#.Cons (f a) (map f ma')))))
-(open Functor<List>)
+(open: Functor<List>)
(struct: #export _ (Apply List)
(def: functor Functor<List>)
diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux
index 6b259b49f..6d11bb9b0 100644
--- a/stdlib/source/lux/data/text.lux
+++ b/stdlib/source/lux/data/text.lux
@@ -150,7 +150,7 @@
(def: (compose left right)
("lux text concat" left right)))
-(open Monoid<Text> "text/")
+(open: "text/" Monoid<Text>)
(def: #export (encode original)
(-> Text Text)
diff --git a/stdlib/source/lux/lang/analysis.lux b/stdlib/source/lux/lang/analysis.lux
index 324f12b3e..3cac8d7b2 100644
--- a/stdlib/source/lux/lang/analysis.lux
+++ b/stdlib/source/lux/lang/analysis.lux
@@ -1,6 +1,7 @@
(.module:
[lux #- nat int deg]
- (lux [function]
+ (lux (control [equality #+ Eq])
+ [function]
(data (coll [list "list/" Fold<List>]))))
(type: #export #rec Primitive
@@ -29,6 +30,17 @@
(#Local Register)
(#Foreign Register))
+(struct: #export _ (Eq Variable)
+ (def: (= reference sample)
+ (case [reference sample]
+ (^template [<tag>]
+ [(<tag> reference') (<tag> sample')]
+ (n/= reference' sample'))
+ ([#Local] [#Foreign])
+
+ _
+ false)))
+
(type: #export (Match p e)
[[p e] (List [p e])])
@@ -36,16 +48,17 @@
(List Variable))
(type: #export (Special e)
- [Text (List e)])
+ {#extension Text
+ #parameters (List e)})
(type: #export #rec Analysis
(#Primitive Primitive)
(#Structure (Composite Analysis))
+ (#Variable Variable)
+ (#Constant Ident)
(#Case Analysis (Match Pattern Analysis))
(#Function Environment Analysis)
(#Apply Analysis Analysis)
- (#Variable Variable)
- (#Constant Ident)
(#Special (Special Analysis)))
(do-template [<name> <type> <tag>]
@@ -169,3 +182,12 @@
_
[analysis (list)]))
+
+(def: #export (self? var)
+ (-> Variable Bool)
+ (case var
+ (#Local +0)
+ true
+
+ _
+ false))
diff --git a/stdlib/source/lux/lang/analysis/case/coverage.lux b/stdlib/source/lux/lang/analysis/case/coverage.lux
index da256206f..a5958001f 100644
--- a/stdlib/source/lux/lang/analysis/case/coverage.lux
+++ b/stdlib/source/lux/lang/analysis/case/coverage.lux
@@ -172,7 +172,7 @@
_
false)))
-(open Eq<Coverage> "C/")
+(open: "C/" Eq<Coverage>)
## After determining the coverage of each individual pattern, it is
## necessary to merge them all to figure out if the entire
diff --git a/stdlib/source/lux/lang/extension.lux b/stdlib/source/lux/lang/extension.lux
index 03fd81d71..6da453148 100644
--- a/stdlib/source/lux/lang/extension.lux
+++ b/stdlib/source/lux/lang/extension.lux
@@ -8,7 +8,7 @@
[macro])
[// #+ Eval]
(// [".L" analysis #+ Analyser]
- [".L" synthesis]))
+ [".L" synthesis #+ Synthesizer]))
(do-template [<name>]
[(exception: #export (<name> {message Text})
@@ -29,7 +29,8 @@
(-> Analyser Eval (List Code) (Meta analysisL.Analysis)))
(type: #export Synthesis
- (-> (-> analysisL.Analysis synthesisL.Synthesis) (List Code) Code))
+ (-> Synthesizer (List analysisL.Analysis)
+ (synthesisL.Operation synthesisL.Synthesis)))
(type: #export Translation
(-> (List Code) (Meta Code)))
@@ -83,17 +84,20 @@
[find-statement Statement #statement unknown-statement]
)
-(do-template [<no> <all> <type> <category> <empty>]
- [(def: #export <no>
- <type>
- <empty>)
+(def: #export empty
+ (All [e] (Extension e))
+ (dict.new text.Hash<Text>))
- (def: #export <all>
- (Meta <type>)
+(do-template [<all> <type> <category>]
+ [(def: #export <all>
+ (Meta (Extension <type>))
(|> ..get
(:: macro.Monad<Meta> map (get@ <category>))))]
- [no-syntheses all-syntheses (Extension Synthesis) #synthesis (dict.new text.Hash<Text>)]
+ [all-analyses Analysis #analysis]
+ [all-syntheses Synthesis #synthesis]
+ [all-translations Translation #translation]
+ [all-statements Statement #statement]
)
(do-template [<name> <type> <category> <exception>]
diff --git a/stdlib/source/lux/lang/synthesis.lux b/stdlib/source/lux/lang/synthesis.lux
index 33c8aa063..4bb83ac5e 100644
--- a/stdlib/source/lux/lang/synthesis.lux
+++ b/stdlib/source/lux/lang/synthesis.lux
@@ -1,8 +1,152 @@
(.module:
- lux)
+ [lux #- Scope]
+ (lux (control [state]
+ ["ex" exception #+ Exception exception:])
+ (data [product]
+ [error #+ Error]
+ [number]
+ (coll (dictionary ["dict" unordered #+ Dict]))))
+ [//analysis #+ Register Variable Environment Special Analysis])
-(def: #export Arity Nat)
+(type: #export Arity Nat)
-(type: #export Synthesis Code)
+(type: #export Resolver (Dict Register Variable))
-(type: #export Path Code)
+(type: #export State
+ {#scope-arity Arity
+ #resolver Resolver
+ #direct? Bool
+ #locals Nat})
+
+(def: #export init
+ State
+ {#scope-arity +0
+ #resolver (dict.new number.Hash<Nat>)
+ #direct? false
+ #locals +0})
+
+(type: (Operation' s o)
+ (state.State' Error s o))
+
+(type: #export (Compiler s i o)
+ (-> i (Operation' ..State o)))
+
+(type: #export Primitive
+ (#Bool Bool)
+ (#I64 I64)
+ (#F64 Frac)
+ (#Text Text))
+
+(type: #export (Structure a)
+ (#Variant (//analysis.Variant a))
+ (#Tuple (//analysis.Tuple a)))
+
+(type: #export (Path' s)
+ (#Bind Register)
+ (#Alt (Path' s) (Path' s))
+ (#Seq (Path' s) (Path' s))
+ (#Exec s))
+
+(type: #export (Abstraction' s)
+ {#environment Environment
+ #arity Arity
+ #body s})
+
+(type: #export (Branch s)
+ (#Case s (Path' s))
+ (#Let s Register s)
+ (#If s s s))
+
+(type: #export (Scope s)
+ {#start Register
+ #inits (List s)
+ #iteration s})
+
+(type: #export (Loop s)
+ (#Scope (Scope s))
+ (#Recur (List s)))
+
+(type: #export (Function s)
+ (#Abstraction (Abstraction' s))
+ (#Apply s (List s)))
+
+(type: #export (Control s)
+ (#Branch (Branch s))
+ (#Loop (Loop s))
+ (#Function (Function s)))
+
+(type: #export #rec Synthesis
+ (#Primitive Primitive)
+ (#Structure (Structure Synthesis))
+ (#Variable Variable)
+ (#Control (Control Synthesis))
+ (#Special (Special Synthesis)))
+
+(type: #export Path
+ (Path' Synthesis))
+
+(type: #export Abstraction
+ (Abstraction' Synthesis))
+
+(type: #export (Operation a)
+ (Operation' ..State a))
+
+(def: #export unit Text "")
+
+(type: #export Synthesizer
+ (Compiler ..State Analysis Synthesis))
+
+(def: #export (throw exception parameters)
+ (All [e] (-> (Exception e) e Operation'))
+ (state.lift error.Monad<Error>
+ (ex.throw exception parameters)))
+
+(def: #export (run synthesizer analysis)
+ (-> Synthesizer Analysis (Error Synthesis))
+ (:: error.Monad<Error> map product.right
+ (synthesizer analysis ..init)))
+
+(def: (localized transform)
+ (-> (-> State State)
+ (-> Synthesizer Synthesizer))
+ (function (scope synthesizer)
+ (function (synthesize analysis state)
+ (case (synthesize analysis (transform state))
+ (#error.Error error)
+ (#error.Error error)
+
+ (#error.Success [state' output])
+ (#error.Success [state output])))))
+
+(def: #export indirectly
+ (-> Synthesizer Synthesizer)
+ (localized (set@ #direct? false)))
+
+(do-template [<name> <tag> <type>]
+ [(def: #export <name>
+ (Operation <type>)
+ (function (_ state)
+ (#error.Success [state (get@ <tag> state)])))]
+
+ [scope-arity #scope-arity Arity]
+ [direct? #direct? Bool]
+ [locals #locals Nat]
+ )
+
+(do-template [<name> <family> <tag>]
+ [(template: #export (<name> content)
+ (<| #..Control
+ <family>
+ <tag>
+ content))]
+
+ [branch/case #..Branch #..Case]
+ [branch/let #..Branch #..Let]
+ [branch/if #..Branch #..If]
+
+ [loop/scope #..Loop #..Scope]
+ [loop/recur #..Loop #..Recur]
+
+ [function/abstraction #..Function #..Abstraction]
+ [function/apply #..Function #..Apply]
+ )
diff --git a/stdlib/source/lux/lang/synthesis/expression.lux b/stdlib/source/lux/lang/synthesis/expression.lux
new file mode 100644
index 000000000..1167e975a
--- /dev/null
+++ b/stdlib/source/lux/lang/synthesis/expression.lux
@@ -0,0 +1,210 @@
+(.module:
+ [lux #- primitive]
+ (lux (control [monad #+ do]
+ ["ex" exception #+ exception:]
+ [state])
+ (data [maybe]
+ [error]
+ [number]
+ [product]
+ text/format
+ (coll [list "list/" Functor<List> Fold<List> Monoid<List>]
+ (dictionary ["dict" unordered #+ Dict])))
+ (macro [code]
+ ["s" syntax])
+ [lang]
+ (lang [".L" analysis #+ Analysis]
+ [".L" extension #+ Extension]))
+ [// #+ Synthesis]
+ [//function]
+ ## (luxc (lang (synthesis [".S" case]
+ ## [".S" loop])
+ ## [".L" variable #+ Variable])
+ ## )
+ )
+
+(exception: #export (unknown-synthesis-extension {name Text})
+ name)
+
+## (def: init-env (List Variable) (list))
+## (def: init-resolver (Dict Int Int) (dict.new number.Hash<Int>))
+
+## (def: (prepare-body inner-arity arity body)
+## (-> ls.Arity ls.Arity Synthesis Synthesis)
+## (if (//function.nested? inner-arity)
+## body
+## (loopS.reify-recursion arity body)))
+
+## (def: (let$ register inputS bodyS)
+## (-> Nat Synthesis Synthesis Synthesis)
+## (` ("lux let" (~ (code.nat register)) (~ inputS) (~ bodyS))))
+
+## (def: (if$ testS thenS elseS)
+## (-> Synthesis Synthesis Synthesis Synthesis)
+## (` ("lux if" (~ testS)
+## (~ thenS)
+## (~ elseS))))
+
+## (def: (variant$ tag last? valueS)
+## (-> Nat Bool Synthesis Synthesis)
+## (` ((~ (code.nat tag)) (~ (code.bool last?)) (~ valueS))))
+
+## (def: (var$ var)
+## (-> Variable Synthesis)
+## (` ((~ (code.int var)))))
+
+## (def: (procedure$ name argsS)
+## (-> Text (List Synthesis) Synthesis)
+## (` ((~ (code.text name)) (~+ argsS))))
+
+## (def: (call$ funcS argsS)
+## (-> Synthesis (List Synthesis) Synthesis)
+## (` ("lux call" (~ funcS) (~+ argsS))))
+
+## (def: (synthesize-case arity num-locals synthesize inputA branchesA)
+## (-> ls.Arity Nat (-> Nat Analysis Synthesis)
+## Analysis (List [la.Pattern Analysis])
+## Synthesis)
+## (let [inputS (synthesize num-locals inputA)]
+## (case (list.reverse branchesA)
+## (^multi (^ (list [(^code ("lux case bind" (~ [_ (#.Nat input-register)])))
+## (^code ((~ [_ (#.Int var)])))]))
+## (not (variableL.captured? var))
+## (n/= input-register (variableL.local-register var)))
+## inputS
+
+## (^ (list [(^code ("lux case bind" (~ [_ (#.Nat register)]))) bodyA]))
+## (let$ (if (//function.nested? arity)
+## (n/+ (dec arity) register)
+## register)
+## inputS
+## (synthesize (inc num-locals) bodyA))
+
+## (^or (^ (list [(^code true) thenA] [(^code false) elseA]))
+## (^ (list [(^code false) elseA] [(^code true) thenA])))
+## (if$ inputS (synthesize num-locals thenA) (synthesize num-locals elseA))
+
+## (#.Cons [lastP lastA] prevsPA)
+## (let [transform-branch (: (-> la.Pattern Analysis ls.Path)
+## (caseS.path arity num-locals synthesize))
+## pathS (list/fold caseS.weave
+## (transform-branch lastP lastA)
+## (list/map (product.uncurry transform-branch) prevsPA))]
+## (` ("lux case" (~ inputS) (~ pathS))))
+
+## _
+## (undefined)
+## )))
+
+(def: (primitive analysis)
+ (-> analysisL.Primitive //.Primitive)
+ (case analysis
+ #analysisL.Unit
+ (#//.Text //.unit)
+
+ (^template [<analysis> <synthesis>]
+ (<analysis> value)
+ (<synthesis> value))
+ ([#analysisL.Bool #//.Bool]
+ [#analysisL.Frac #//.F64]
+ [#analysisL.Text #//.Text])
+
+ (^template [<analysis> <synthesis>]
+ (<analysis> value)
+ (<synthesis> (.i64 value)))
+ ([#analysisL.Nat #//.I64]
+ [#analysisL.Int #//.I64]
+ [#analysisL.Deg #//.I64])))
+
+(def: Compiler@Monad (state.Monad<State'> error.Monad<Error>))
+(open: "compiler/" Compiler@Monad)
+
+(def: #export (synthesizer extensions)
+ (-> (Extension extensionL.Synthesis) //.Synthesizer)
+ (function (synthesize analysis)
+ (case analysis
+ (#analysisL.Primitive analysis')
+ (compiler/wrap (#//.Primitive (..primitive analysis')))
+
+ (#analysisL.Structure composite)
+ (case (analysisL.variant analysis)
+ (#.Some variant)
+ (do Compiler@Monad
+ [valueS (synthesize (get@ #analysisL.value variant))]
+ (wrap (#//.Structure (#//.Variant (set@ #analysisL.value valueS variant)))))
+
+ _
+ (do Compiler@Monad
+ [tupleS (monad.map @ synthesize (analysisL.tuple analysis))]
+ (wrap (#//.Structure (#//.Tuple tupleS)))))
+
+ (#analysisL.Apply _)
+ (//function.apply (//.indirectly synthesize) analysis)
+
+ (#analysisL.Special name args)
+ (case (dict.get name extensions)
+ #.None
+ (//.throw unknown-synthesis-extension name)
+
+ (#.Some extension)
+ (extension (//.indirectly synthesize) args))
+
+ _
+ (undefined)
+
+ ## (^code ((~ [_ (#.Int var)])))
+ ## (if (variableL.local? var)
+ ## (if (//function.nested? arity)
+ ## (if (variableL.self? var)
+ ## (call$ (var$ 0) (|> (list.n/range +1 (dec arity))
+ ## (list/map (|>> variableL.local code.int (~) () (`)))))
+ ## (var$ (//function.adjust-var arity var)))
+ ## (var$ var))
+ ## (var$ (maybe.default var (dict.get var resolver))))
+
+ ## (^code ("lux case" (~ inputA) (~ [_ (#.Record branchesA)])))
+ ## (synthesize-case arity num-locals (//.indirectly synthesize) inputA branchesA)
+
+ ## (^multi (^code ("lux function" [(~+ scope)] (~ bodyA)))
+ ## [(s.run scope (p.some s.int)) (#error.Success raw-env)])
+ ## (let [function-arity (if direct?
+ ## (inc arity)
+ ## +1)
+ ## env (list/map (function (_ closure)
+ ## (case (dict.get closure resolver)
+ ## (#.Some resolved)
+ ## (if (and (variableL.local? resolved)
+ ## (//function.nested? arity)
+ ## (|> resolved variableL.local-register (n/>= arity)))
+ ## (//function.adjust-var arity resolved)
+ ## resolved)
+
+ ## #.None
+ ## (if (and (variableL.local? closure)
+ ## (//function.nested? arity))
+ ## (//function.adjust-var arity closure)
+ ## closure)))
+ ## raw-env)
+ ## env-vars (: (List Variable)
+ ## (case raw-env
+ ## #.Nil (list)
+ ## _ (|> (list.size raw-env) dec (list.n/range +0) (list/map variableL.captured))))
+ ## resolver' (if (and (//function.nested? function-arity)
+ ## direct?)
+ ## (list/fold (function (_ [from to] resolver')
+ ## (dict.put from to resolver'))
+ ## init-resolver
+ ## (list.zip2 env-vars env))
+ ## (list/fold (function (_ var resolver')
+ ## (dict.put var var resolver'))
+ ## init-resolver
+ ## env-vars))]
+ ## (case (recur function-arity resolver' true function-arity bodyA)
+ ## (^ [_ (#.Form (list [_ (#.Text "lux function")] [_ (#.Nat unmerged-arity)] env' bodyS'))])
+ ## (let [merged-arity (inc unmerged-arity)]
+ ## (function$ merged-arity env
+ ## (prepare-body function-arity merged-arity bodyS')))
+
+ ## bodyS
+ ## (function$ +1 env (prepare-body function-arity +1 bodyS))))
+ )))
diff --git a/stdlib/source/lux/lang/synthesis/function.lux b/stdlib/source/lux/lang/synthesis/function.lux
new file mode 100644
index 000000000..7b989d975
--- /dev/null
+++ b/stdlib/source/lux/lang/synthesis/function.lux
@@ -0,0 +1,49 @@
+(.module:
+ lux
+ (lux (control [monad #+ do]
+ [state])
+ (data [maybe]
+ [error]
+ (coll [list "list/" Monoid<List>]))
+ (lang [".L" analysis #+ Variable Analysis]))
+ [// #+ Arity Synthesizer]
+ [//loop])
+
+(def: nested?
+ (-> Arity Bool)
+ (n/> +1))
+
+## (def: (adjust-var outer var)
+## (-> Arity Variable Variable)
+## (|> outer dec .int (i/+ var)))
+
+(def: (unfold apply)
+ (-> Analysis [Analysis (List Analysis)])
+ (loop [apply apply
+ args (list)]
+ (case apply
+ (#analysisL.Apply arg func)
+ (recur func (#.Cons arg args))
+
+ _
+ [apply args])))
+
+(def: #export (apply synthesize)
+ (-> Synthesizer Synthesizer)
+ (function (_ exprA)
+ (let [[funcA argsA] (unfold exprA)]
+ (do (state.Monad<State'> error.Monad<Error>)
+ [funcS (synthesize funcA)
+ argsS (monad.map @ synthesize argsA)
+ locals //.locals]
+ (case funcS
+ (^ (//.function/abstraction functionS))
+ (wrap (|> functionS
+ (//loop.loop (get@ #//.environment functionS) locals argsS)
+ (maybe.default (//.function/apply [funcS argsS]))))
+
+ (^ (//.function/apply [funcS' argsS']))
+ (wrap (//.function/apply [funcS' (list/compose argsS' argsS)]))
+
+ _
+ (wrap (//.function/apply [funcS argsS])))))))
diff --git a/stdlib/source/lux/lang/synthesis/loop.lux b/stdlib/source/lux/lang/synthesis/loop.lux
new file mode 100644
index 000000000..476cf27b4
--- /dev/null
+++ b/stdlib/source/lux/lang/synthesis/loop.lux
@@ -0,0 +1,277 @@
+(.module:
+ [lux #- loop]
+ (lux (control [monad #+ do]
+ ["p" parser])
+ (data [maybe "maybe/" Monad<Maybe>]
+ (coll [list "list/" Functor<List>]))
+ (macro [code]
+ [syntax]))
+ [///analysis #+ Register Variable Environment]
+ [// #+ Path Abstraction Synthesis])
+
+(type: (Transform a)
+ (-> a (Maybe a)))
+
+(def: (some? maybe)
+ (All [a] (-> (Maybe a) Bool))
+ (case maybe
+ (#.Some _) true
+ #.None false))
+
+(def: proper Bool true)
+
+(def: (proper? exprS)
+ (-> Synthesis Bool)
+ (case exprS
+ (#//.Structure structure)
+ (case structure
+ (#//.Variant variantS)
+ (proper? (get@ #///analysis.value variantS))
+
+ (#//.Tuple membersS+)
+ (list.every? proper? membersS+))
+
+ (#//.Variable var)
+ (not (///analysis.self? var))
+
+ (#//.Control controlS)
+ (case controlS
+ (#//.Branch branchS)
+ (case branchS
+ (#//.Case inputS pathS)
+ (and (proper? inputS)
+ (.loop [pathS pathS]
+ (case pathS
+ (^or (#//.Alt leftS rightS) (#//.Seq leftS rightS))
+ (and (recur leftS) (recur rightS))
+
+ (#//.Exec bodyS)
+ (proper? bodyS)
+
+ _
+ proper)))
+
+ (#//.Let inputS register bodyS)
+ (and (proper? inputS)
+ (proper? bodyS))
+
+ (#//.If inputS thenS elseS)
+ (and (proper? inputS)
+ (proper? thenS)
+ (proper? elseS)))
+
+ (#//.Loop loopS)
+ (case loopS
+ (#//.Scope scopeS)
+ (and (list.every? proper? (get@ #//.inits scopeS))
+ (proper? (get@ #//.iteration scopeS)))
+
+ (#//.Recur argsS)
+ (list.every? proper? argsS))
+
+ (#//.Function functionS)
+ (case functionS
+ (#//.Abstraction environment arity bodyS)
+ (list.every? ///analysis.self? environment)
+
+ (#//.Apply funcS argsS)
+ (and (proper? funcS)
+ (list.every? proper? argsS))))
+
+ (#//.Special [special argsS])
+ (list.every? proper? argsS)
+
+ _
+ proper))
+
+(def: (path-recursion synthesis-recursion)
+ (-> (Transform Synthesis) (Transform Path))
+ (function (recur pathS)
+ (case pathS
+ (#//.Alt leftS rightS)
+ (let [leftS' (recur leftS)
+ rightS' (recur rightS)]
+ (if (or (some? leftS')
+ (some? rightS'))
+ (#.Some (#//.Alt (maybe.default leftS leftS')
+ (maybe.default rightS rightS')))
+ #.None))
+
+ (#//.Seq leftS rightS)
+ (maybe/map (|>> (#//.Seq leftS)) (recur rightS))
+
+ (#//.Exec bodyS)
+ (maybe/map (|>> #//.Exec) (synthesis-recursion bodyS))
+
+ _
+ #.None)))
+
+(template: (recursive-apply args)
+ (#//.Apply (#//.Variable (#///analysis.Local +0))
+ args))
+
+(def: #export (recursion arity)
+ (-> Nat (Transform Synthesis))
+ (function (recur exprS)
+ (case exprS
+ (#//.Control controlS)
+ (case controlS
+ (#//.Branch branchS)
+ (case branchS
+ (#//.Case inputS pathS)
+ (|> pathS
+ (path-recursion recur)
+ (maybe/map (|>> (#//.Case inputS) #//.Branch #//.Control)))
+
+ (#//.Let inputS register bodyS)
+ (maybe/map (|>> (#//.Let inputS register) #//.Branch #//.Control)
+ (recur bodyS))
+
+ (#//.If inputS thenS elseS)
+ (let [thenS' (recur thenS)
+ elseS' (recur elseS)]
+ (if (or (some? thenS')
+ (some? elseS'))
+ (#.Some (|> (#//.If inputS
+ (maybe.default thenS thenS')
+ (maybe.default elseS elseS'))
+ #//.Branch #//.Control))
+ #.None)))
+
+ (^ (#//.Function (recursive-apply argsS)))
+ (if (n/= arity (list.size argsS))
+ (#.Some (|> argsS #//.Recur #//.Loop #//.Control))
+ #.None)
+
+ _
+ #.None)
+
+ _
+ #.None)))
+
+(def: (resolve environment)
+ (-> Environment (Transform Variable))
+ (function (_ variable)
+ (case variable
+ (#///analysis.Foreign register)
+ (list.nth register environment)
+
+ _
+ (#.Some variable))))
+
+(def: (adjust-path adjust-synthesis offset)
+ (-> (Transform Synthesis) Register (Transform Path))
+ (function (recur pathS)
+ (case pathS
+ (#//.Bind register)
+ (#.Some (#//.Bind (n/+ offset register)))
+
+ (^template [<tag>]
+ (<tag> leftS rightS)
+ (do maybe.Monad<Maybe>
+ [leftS' (recur leftS)
+ rightS' (recur rightS)]
+ (wrap (<tag> leftS' rightS'))))
+ ([#//.Alt] [#//.Seq])
+
+ (#//.Exec bodyS)
+ (|> bodyS adjust-synthesis (maybe/map (|>> #//.Exec)))
+
+ _
+ (#.Some pathS))))
+
+(def: (adjust scope-environment offset)
+ (-> Environment Register (Transform Synthesis))
+ (function (recur exprS)
+ (case exprS
+ (#//.Structure structureS)
+ (case structureS
+ (#//.Variant variantS)
+ (do maybe.Monad<Maybe>
+ [valueS' (|> variantS (get@ #///analysis.value) recur)]
+ (wrap (|> variantS
+ (set@ #///analysis.value valueS')
+ #//.Variant
+ #//.Structure)))
+
+ (#//.Tuple membersS+)
+ (|> membersS+
+ (monad.map maybe.Monad<Maybe> recur)
+ (maybe/map (|>> #//.Tuple #//.Structure))))
+
+ (#//.Variable variable)
+ (case variable
+ (#///analysis.Local register)
+ (#.Some (#//.Variable (#///analysis.Local (n/+ offset register))))
+
+ (#///analysis.Foreign register)
+ (|> scope-environment
+ (list.nth register)
+ (maybe/map (|>> #//.Variable))))
+
+ (^ (//.branch/case [inputS pathS]))
+ (do maybe.Monad<Maybe>
+ [inputS' (recur inputS)
+ pathS' (adjust-path recur offset pathS)]
+ (wrap (|> pathS' [inputS'] //.branch/case)))
+
+ (^ (//.branch/let [inputS register bodyS]))
+ (do maybe.Monad<Maybe>
+ [inputS' (recur inputS)
+ bodyS' (recur bodyS)]
+ (wrap (//.branch/let [inputS' register bodyS'])))
+
+ (^ (//.branch/if [inputS thenS elseS]))
+ (do maybe.Monad<Maybe>
+ [inputS' (recur inputS)
+ thenS' (recur thenS)
+ elseS' (recur elseS)]
+ (wrap (//.branch/if [inputS' thenS' elseS'])))
+
+ (^ (//.loop/scope scopeS))
+ (do maybe.Monad<Maybe>
+ [inits' (|> scopeS
+ (get@ #//.inits)
+ (monad.map maybe.Monad<Maybe> recur))
+ iteration' (recur (get@ #//.iteration scopeS))]
+ (wrap (//.loop/scope {#//.start (|> scopeS (get@ #//.start) (n/+ offset))
+ #//.inits inits'
+ #//.iteration iteration'})))
+
+ (^ (//.loop/recur argsS))
+ (|> argsS
+ (monad.map maybe.Monad<Maybe> recur)
+ (maybe/map (|>> //.loop/recur)))
+
+
+ (^ (//.function/abstraction [environment arity bodyS]))
+ (do maybe.Monad<Maybe>
+ [environment' (monad.map maybe.Monad<Maybe>
+ (resolve scope-environment)
+ environment)]
+ (wrap (//.function/abstraction [environment' arity bodyS])))
+
+ (^ (//.function/apply [function arguments]))
+ (do maybe.Monad<Maybe>
+ [function' (recur function)
+ arguments' (monad.map maybe.Monad<Maybe> recur arguments)]
+ (wrap (//.function/apply [function' arguments'])))
+
+ (#//.Special [procedure argsS])
+ (|> argsS
+ (monad.map maybe.Monad<Maybe> recur)
+ (maybe/map (|>> [procedure] #//.Special)))
+
+ _
+ (#.Some exprS))))
+
+(def: #export (loop environment num-locals inits functionS)
+ (-> Environment Nat (List Synthesis) Abstraction (Maybe Synthesis))
+ (let [bodyS (get@ #//.body functionS)]
+ (if (and (n/= (list.size inits)
+ (get@ #//.arity functionS))
+ (proper? bodyS))
+ (|> bodyS
+ (adjust environment num-locals)
+ (maybe/map (|>> [(inc num-locals) inits] //.loop/scope)))
+ #.None)))
diff --git a/stdlib/source/lux/lang/type/check.lux b/stdlib/source/lux/lang/type/check.lux
index 61001d8be..2e255d47c 100644
--- a/stdlib/source/lux/lang/type/check.lux
+++ b/stdlib/source/lux/lang/type/check.lux
@@ -24,15 +24,13 @@
(type.to-text (#.Apply argT funcT)))
(exception: #export (cannot-rebind-var {id Nat} {type Type} {bound Type})
- ($_ text/compose
- " Var: " (nat/encode id) "\n"
- " Wanted Type: " (type.to-text type) "\n"
- "Current Type: " (type.to-text bound)))
+ (ex.report ["Var" (nat/encode id)]
+ ["Wanted Type" (type.to-text type)]
+ ["Current Type" (type.to-text bound)]))
(exception: #export (type-check-failed {expected Type} {actual Type})
- ($_ text/compose
- "Expected: " (type.to-text expected) "\n\n"
- " Actual: " (type.to-text actual)))
+ (ex.report ["Expected" (type.to-text expected)]
+ ["Actual" (type.to-text actual)]))
(type: #export Var Nat)
@@ -99,7 +97,7 @@
)))
)
-(open Monad<Check> "check/")
+(open: "check/" Monad<Check>)
(def: (var::get id plist)
(-> Var Type-Vars (Maybe (Maybe Type)))
diff --git a/stdlib/source/lux/world/console.lux b/stdlib/source/lux/world/console.lux
index 7bd7cfaca..b66dce4da 100644
--- a/stdlib/source/lux/world/console.lux
+++ b/stdlib/source/lux/world/console.lux
@@ -1,5 +1,5 @@
(.module:
- [lux #- open]
+ lux
(lux (control [monad #+ do])
(data ["e" error]
[text])
diff --git a/stdlib/test/test/lux/control/state.lux b/stdlib/test/test/lux/control/state.lux
index 381a40b79..1194351e5 100644
--- a/stdlib/test/test/lux/control/state.lux
+++ b/stdlib/test/test/lux/control/state.lux
@@ -83,7 +83,7 @@
(let [(^open "io/") io.Monad<IO>]
(test "Can add state functionality to any monad."
(|> (: (&.State' io.IO Nat Nat)
- (do (&.StateT io.Monad<IO>)
+ (do (&.Monad<State'> io.Monad<IO>)
[a (&.lift io.Monad<IO> (io/wrap left))
b (wrap right)]
(wrap (n/+ a b))))
diff --git a/new-luxc/test/test/luxc/lang/synthesis/case/special.lux b/stdlib/test/test/lux/lang/synthesis/case.lux
index 398f98a57..3ae62badc 100644
--- a/new-luxc/test/test/luxc/lang/synthesis/case/special.lux
+++ b/stdlib/test/test/lux/lang/synthesis/case.lux
@@ -7,7 +7,7 @@
["r" math/random "r/" Monad<Random>]
test)
(luxc (lang ["la" analysis]
- ["ls" synthesis]
+ ["//" synthesis #+ Synthesis]
(synthesis [".S" expression])
[".L" extension]
[".L" variable #+ Variable]))
@@ -22,8 +22,8 @@
{("lux case bind" (~ (code.nat temp)))
(~ (la.var (variableL.local temp)))}))]]
(test "Dummy variables created to mask expressions get eliminated during synthesis."
- (|> (expressionS.synthesize extensionL.no-syntheses
- maskA)
+ (|> (//.run (expressionS.synthesizer extensionL.no-syntheses
+ maskA))
(corresponds? maskedA))))))
(context: "Let expressions."
@@ -36,8 +36,8 @@
{("lux case bind" (~ (code.nat registerA)))
(~ outputA)}))]]
(test "Can detect and reify simple 'let' expressions."
- (|> (expressionS.synthesize extensionL.no-syntheses
- letA)
+ (|> (//.run (expressionS.synthesizer extensionL.no-syntheses
+ letA))
(case> (^ [_ (#.Form (list [_ (#.Text "lux let")] [_ (#.Nat registerS)] inputS outputS))])
(and (n/= registerA registerS)
(corresponds? inputA inputS)
@@ -61,8 +61,8 @@
{false (~ elseA)
true (~ thenA)})))]]
(test "Can detect and reify simple 'if' expressions."
- (|> (expressionS.synthesize extensionL.no-syntheses
- ifA)
+ (|> (//.run (expressionS.synthesizer extensionL.no-syntheses
+ ifA))
(case> (^ [_ (#.Form (list [_ (#.Text "lux if")] inputS thenS elseS))])
(and (corresponds? inputA inputS)
(corresponds? thenA thenS)
diff --git a/stdlib/test/test/lux/lang/synthesis/function.lux b/stdlib/test/test/lux/lang/synthesis/function.lux
new file mode 100644
index 000000000..c469d8665
--- /dev/null
+++ b/stdlib/test/test/lux/lang/synthesis/function.lux
@@ -0,0 +1,161 @@
+(.module:
+ lux
+ (lux [io]
+ (control [monad #+ do]
+ pipe)
+ (data [product]
+ [maybe]
+ [error]
+ [number]
+ text/format
+ (coll [list "list/" Functor<List> Fold<List>]
+ (dictionary ["dict" unordered #+ Dict])
+ (set ["set" unordered])))
+ (lang [".L" analysis #+ Variable Analysis "variable/" Eq<Variable>]
+ ["//" synthesis #+ Arity Synthesis]
+ (synthesis [".S" expression])
+ [".L" extension])
+ ["r" math/random]
+ test)
+ [//primitive])
+
+(def: constant-function
+ (r.Random [Arity Analysis Analysis])
+ (r.rec
+ (function (_ constant-function)
+ (do r.Monad<Random>
+ [function? r.bool]
+ (if function?
+ (do @
+ [[arity bodyA predictionA] constant-function]
+ (wrap [(inc arity)
+ (#analysisL.Function (list) bodyA)
+ predictionA]))
+ (do @
+ [predictionA //primitive.primitive]
+ (wrap [+0 predictionA predictionA])))))))
+
+(def: (pick scope-size)
+ (-> Nat (r.Random Nat))
+ (|> r.nat (:: r.Monad<Random> map (n/% scope-size))))
+
+(def: function-with-environment
+ (r.Random [Arity Analysis Variable])
+ (do r.Monad<Random>
+ [num-locals (|> r.nat (:: @ map (|>> (n/% +100) (n/max +10))))
+ #let [indices (list.n/range +0 (dec num-locals))
+ absolute-env (list/map (|>> #analysisL.Local) indices)
+ relative-env (list/map (|>> #analysisL.Foreign) indices)]
+ [arity bodyA predictionA] (: (r.Random [Arity Analysis Variable])
+ (loop [arity +1
+ global-env relative-env]
+ (let [env-size (list.size global-env)
+ resolver (list/fold (function (_ [idx var] resolver)
+ (dict.put idx var resolver))
+ (: (Dict Nat Variable)
+ (dict.new number.Hash<Nat>))
+ (list.zip2 (list.n/range +0 (dec env-size))
+ global-env))]
+ (do @
+ [nest? r.bool]
+ (if nest?
+ (do @
+ [num-picks (:: @ map (n/max +1) (pick (inc env-size)))
+ picks (|> (r.set number.Hash<Nat> num-picks (pick env-size))
+ (:: @ map set.to-list))
+ [arity bodyA predictionA] (recur (inc arity)
+ (list/map (function (_ pick)
+ (maybe.assume (list.nth pick global-env)))
+ picks))]
+ (wrap [arity
+ (#analysisL.Function (list/map (|>> #analysisL.Foreign) picks)
+ bodyA)
+ predictionA]))
+ (do @
+ [chosen (pick (list.size global-env))]
+ (wrap [arity
+ (#analysisL.Variable (#analysisL.Foreign chosen))
+ (maybe.assume (dict.get chosen resolver))])))))))]
+ (wrap [arity
+ (#analysisL.Function absolute-env bodyA)
+ predictionA])))
+
+(def: local-function
+ (r.Random [Arity Analysis Variable])
+ (loop [arity +0
+ nest? true]
+ (if nest?
+ (do r.Monad<Random>
+ [nest?' r.bool
+ [arity' bodyA predictionA] (recur (inc arity) nest?')]
+ (wrap [arity'
+ (#analysisL.Function (list) bodyA)
+ predictionA]))
+ (do r.Monad<Random>
+ [chosen (|> r.nat (:: @ map (|>> (n/% +100) (n/max +2))))]
+ (wrap [arity
+ (#analysisL.Variable (#analysisL.Local chosen))
+ (|> chosen (n/+ (dec arity)) #analysisL.Local)])))))
+
+(context: "Function definition."
+ (<| (times +100)
+ (do @
+ [[arity//constant function//constant prediction//constant] constant-function
+ [arity//environment function//environment prediction//environment] function-with-environment
+ [arity//local function//local prediction//local] local-function]
+ ($_ seq
+ (test "Nested functions will get folded together."
+ (|> function//constant
+ (//.run (expressionS.synthesizer extensionL.empty))
+ (case> (^ (#error.Success (//.function/abstraction [environment arity output])))
+ (and (n/= arity//constant arity)
+ (//primitive.corresponds? prediction//constant output))
+
+ _
+ (n/= +0 arity//constant))))
+ (test "Folded functions provide direct access to environment variables."
+ (|> function//environment
+ (//.run (expressionS.synthesizer extensionL.empty))
+ (case> (^ (#error.Success (//.function/abstraction [environment arity (#//.Variable output)])))
+ (and (n/= arity//environment arity)
+ (variable/= prediction//environment output))
+
+ _
+ false)))
+ (test "Folded functions properly offset local variables."
+ (|> function//local
+ (//.run (expressionS.synthesizer extensionL.empty))
+ (case> (^ (#error.Success (//.function/abstraction [environment arity (#//.Variable output)])))
+ (and (n/= arity//local arity)
+ (variable/= prediction//local output))
+
+ _
+ false)))
+ ))))
+
+(context: "Function application."
+ (<| (times +100)
+ (do @
+ [arity (|> r.nat (:: @ map (|>> (n/% +10) (n/max +1))))
+ funcA //primitive.primitive
+ argsA (r.list arity //primitive.primitive)]
+ ($_ seq
+ (test "Can synthesize function application."
+ (|> (analysisL.apply [funcA argsA])
+ (//.run (expressionS.synthesizer extensionL.empty))
+ (case> (^ (#error.Success (//.function/apply [funcS argsS])))
+ (and (//primitive.corresponds? funcA funcS)
+ (list.every? (product.uncurry //primitive.corresponds?)
+ (list.zip2 argsA argsS)))
+
+ _
+ false)))
+ (test "Function application on no arguments just synthesizes to the function itself."
+ (|> (analysisL.apply [funcA (list)])
+ (//.run (expressionS.synthesizer extensionL.empty))
+ (case> (#error.Success funcS)
+ (//primitive.corresponds? funcA funcS)
+
+ _
+ false)))
+ ))))
diff --git a/stdlib/test/test/lux/lang/synthesis/primitive.lux b/stdlib/test/test/lux/lang/synthesis/primitive.lux
new file mode 100644
index 000000000..ffe0eb795
--- /dev/null
+++ b/stdlib/test/test/lux/lang/synthesis/primitive.lux
@@ -0,0 +1,90 @@
+(.module:
+ [lux #- primitive]
+ (lux [io]
+ (control [monad #+ do]
+ pipe)
+ (data [error]
+ text/format)
+ [lang]
+ (lang [".L" extension]
+ [".L" analysis #+ Analysis]
+ ["//" synthesis #+ Synthesis]
+ (synthesis [".S" expression]))
+ ["r" math/random]
+ test))
+
+(def: #export primitive
+ (r.Random Analysis)
+ (do r.Monad<Random>
+ [primitive (: (r.Random analysisL.Primitive)
+ ($_ r.alt
+ (wrap [])
+ r.bool
+ r.nat
+ r.int
+ r.deg
+ r.frac
+ (r.unicode +5)))]
+ (wrap (#analysisL.Primitive primitive))))
+
+(def: #export (corresponds? analysis synthesis)
+ (-> Analysis Synthesis Bool)
+ (case [synthesis analysis]
+ [(#//.Primitive (#//.Text valueS))
+ (#analysisL.Primitive (#analysisL.Unit valueA))]
+ (is? valueS (:! Text valueA))
+
+ [(#//.Primitive (#//.Bool valueS))
+ (#analysisL.Primitive (#analysisL.Bool valueA))]
+ (is? valueS valueA)
+
+ [(#//.Primitive (#//.I64 valueS))
+ (#analysisL.Primitive (#analysisL.Nat valueA))]
+ (is? valueS (.i64 valueA))
+
+ [(#//.Primitive (#//.I64 valueS))
+ (#analysisL.Primitive (#analysisL.Int valueA))]
+ (is? valueS (.i64 valueA))
+
+ [(#//.Primitive (#//.I64 valueS))
+ (#analysisL.Primitive (#analysisL.Deg valueA))]
+ (is? valueS (.i64 valueA))
+
+ [(#//.Primitive (#//.F64 valueS))
+ (#analysisL.Primitive (#analysisL.Frac valueA))]
+ (is? valueS valueA)
+
+ [(#//.Primitive (#//.Text valueS))
+ (#analysisL.Primitive (#analysisL.Text valueA))]
+ (is? valueS valueA)
+
+ _
+ false))
+
+(context: "Primitives."
+ (<| (times +100)
+ (do @
+ [%bool% r.bool
+ %nat% r.nat
+ %int% r.int
+ %deg% r.deg
+ %frac% r.frac
+ %text% (r.unicode +5)]
+ (`` ($_ seq
+ (~~ (do-template [<desc> <analysis> <synthesis> <sample>]
+ [(test (format "Can synthesize " <desc> ".")
+ (|> (#analysisL.Primitive (<analysis> <sample>))
+ (//.run (expressionS.synthesizer extensionL.empty))
+ (case> (#error.Success (#//.Primitive (<synthesis> value)))
+ (is? <sample> value)
+
+ _
+ false)))]
+
+ ["unit" #analysisL.Unit #//.Text //.unit]
+ ["bool" #analysisL.Bool #//.Bool %bool%]
+ ["nat" #analysisL.Nat #//.I64 (.i64 %nat%)]
+ ["int" #analysisL.Int #//.I64 (.i64 %int%)]
+ ["deg" #analysisL.Deg #//.I64 (.i64 %deg%)]
+ ["frac" #analysisL.Frac #//.F64 %frac%]
+ ["text" #analysisL.Text #//.Text %text%])))))))
diff --git a/stdlib/test/test/lux/lang/synthesis/structure.lux b/stdlib/test/test/lux/lang/synthesis/structure.lux
new file mode 100644
index 000000000..a8e298bf5
--- /dev/null
+++ b/stdlib/test/test/lux/lang/synthesis/structure.lux
@@ -0,0 +1,54 @@
+(.module:
+ lux
+ (lux [io]
+ (control [monad #+ do]
+ pipe)
+ (data [bool "bool/" Eq<Bool>]
+ [product]
+ [error]
+ (coll [list]))
+ (lang [".L" analysis]
+ ["//" synthesis #+ Synthesis]
+ (synthesis [".S" expression])
+ [".L" extension])
+ ["r" math/random "r/" Monad<Random>]
+ test)
+ [//primitive])
+
+(context: "Variants"
+ (<| (times +100)
+ (do @
+ [size (|> r.nat (:: @ map (|>> (n/% +10) (n/+ +2))))
+ tagA (|> r.nat (:: @ map (n/% size)))
+ memberA //primitive.primitive]
+ ($_ seq
+ (test "Can synthesize variants."
+ (|> (analysisL.sum-analysis size tagA memberA)
+ (//.run (expressionS.synthesizer extensionL.empty))
+ (case> (#error.Success (#//.Structure (#//.Variant [leftsS right?S valueS])))
+ (let [tagS (if right?S (inc leftsS) leftsS)]
+ (and (n/= tagA tagS)
+ (|> tagS (n/= (dec size)) (bool/= right?S))
+ (//primitive.corresponds? memberA valueS)))
+
+ _
+ false)))
+ ))))
+
+(context: "Tuples"
+ (<| (times +100)
+ (do @
+ [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2))))
+ membersA (r.list size //primitive.primitive)]
+ ($_ seq
+ (test "Can synthesize tuple."
+ (|> (analysisL.product-analysis membersA)
+ (//.run (expressionS.synthesizer extensionL.empty))
+ (case> (#error.Success (#//.Structure (#//.Tuple membersS)))
+ (and (n/= size (list.size membersS))
+ (list.every? (product.uncurry //primitive.corresponds?)
+ (list.zip2 membersA membersS)))
+
+ _
+ false)))
+ ))))