diff options
Diffstat (limited to '')
18 files changed, 1097 insertions, 69 deletions
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))) + )))) |