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