diff options
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/function.lux | 111 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/variable.lux | 47 | ||||
| -rw-r--r-- | new-luxc/test/test/luxc/lang/analysis/function.lux | 141 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/analysis.lux | 16 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/analysis/expression.lux | 4 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/analysis/function.lux | 104 | ||||
| -rw-r--r-- | stdlib/source/lux/lang/scope.lux | 19 | ||||
| -rw-r--r-- | stdlib/test/test/lux/lang/analysis/function.lux | 111 | ||||
| -rw-r--r-- | stdlib/test/test/lux/lang/analysis/structure.lux | 2 |
9 files changed, 248 insertions, 307 deletions
diff --git a/new-luxc/source/luxc/lang/analysis/function.lux b/new-luxc/source/luxc/lang/analysis/function.lux deleted file mode 100644 index eaddfa5bb..000000000 --- a/new-luxc/source/luxc/lang/analysis/function.lux +++ /dev/null @@ -1,111 +0,0 @@ -(.module: - lux - (lux (control monad - ["ex" exception #+ exception:]) - (data [maybe] - [text] - text/format - (coll [list "list/" Fold<List> Monoid<List> Monad<List>])) - [macro] - (macro [code]) - (lang [type] - (type ["tc" check]))) - (luxc ["&" lang] - (lang ["&." scope] - ["la" analysis #+ Analysis] - (analysis ["&." common] - ["&." inference]) - [".L" variable #+ Variable]))) - -(do-template [<name>] - [(exception: #export (<name> {message Text}) - message)] - - [Cannot-Analyse-Function] - [Invalid-Function-Type] - [Cannot-Apply-Function] - ) - -## [Analysers] -(def: #export (analyse-function analyse func-name arg-name body) - (-> &.Analyser Text Text Code (Meta Analysis)) - (do macro.Monad<Meta> - [functionT macro.expected-type] - (loop [expectedT functionT] - (&.with-stacked-errors - (function (_ _) - (ex.construct Cannot-Analyse-Function - (format " Type: " (%type expectedT) "\n" - "Function: " func-name "\n" - "Argument: " arg-name "\n" - " Body: " (%code body)))) - (case expectedT - (#.Named name unnamedT) - (recur unnamedT) - - (#.Apply argT funT) - (case (type.apply (list argT) funT) - (#.Some value) - (recur value) - - #.None - (&.throw Invalid-Function-Type (%type expectedT))) - - (^template [<tag> <instancer>] - (<tag> _) - (do @ - [[_ instanceT] (&.with-type-env <instancer>)] - (recur (maybe.assume (type.apply (list instanceT) expectedT))))) - ([#.UnivQ tc.existential] - [#.ExQ tc.var]) - - (#.Var id) - (do @ - [?expectedT' (&.with-type-env - (tc.read id))] - (case ?expectedT' - (#.Some expectedT') - (recur expectedT') - - _ - ## Inference - (do @ - [[input-id inputT] (&.with-type-env tc.var) - [output-id outputT] (&.with-type-env tc.var) - #let [funT (#.Function inputT outputT)] - funA (recur funT) - _ (&.with-type-env - (tc.check expectedT funT))] - (wrap funA)) - )) - - (#.Function inputT outputT) - (<| (:: @ 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. - (&scope.with-local [func-name expectedT]) - (&scope.with-local [arg-name inputT]) - (&.with-type outputT) - (analyse body)) - - _ - (&.fail "") - ))))) - -(def: #export (analyse-apply analyse funcT funcA args) - (-> &.Analyser Type Analysis (List Code) (Meta Analysis)) - (&.with-stacked-errors - (function (_ _) - (ex.construct Cannot-Apply-Function - (format " Function: " (%type funcT) "\n" - "Arguments:" (|> args - list.enumerate - (list/map (function (_ [idx argC]) - (format "\n " (%n idx) " " (%code argC)))) - (text.join-with ""))))) - (do macro.Monad<Meta> - [[applyT argsA] (&inference.general analyse funcT args)] - (wrap (la.apply argsA funcA))))) diff --git a/new-luxc/source/luxc/lang/variable.lux b/new-luxc/source/luxc/lang/variable.lux deleted file mode 100644 index b33574d19..000000000 --- a/new-luxc/source/luxc/lang/variable.lux +++ /dev/null @@ -1,47 +0,0 @@ -(.module: - lux - (lux (data (coll [list "list/" Functor<List>])))) - -(def: #export Variable Int) -(def: #export Register Nat) - -(def: #export (captured register) - (-> Register Variable) - (|> register n/inc nat-to-int (i/* -1))) - -(def: #export (local register) - (-> Register 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/test/test/luxc/lang/analysis/function.lux b/new-luxc/test/test/luxc/lang/analysis/function.lux deleted file mode 100644 index 968de53ef..000000000 --- a/new-luxc/test/test/luxc/lang/analysis/function.lux +++ /dev/null @@ -1,141 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data ["e" error] - [maybe] - [product] - [text "text/" Eq<Text>] - text/format - (coll [list "list/" Functor<List>])) - ["r" math/random "r/" Monad<Random>] - [macro] - (macro [code]) - (lang [type "type/" Eq<Type>]) - test) - (luxc ["&" lang] - (lang ["@." module] - ["la" analysis] - (analysis [".A" expression] - ["@" function] - ["@." common]))) - (// common) - (test/luxc common)) - -(def: (check-type expectedT error) - (-> Type (e.Error [Type la.Analysis]) Bool) - (case error - (#e.Success [exprT exprA]) - (type/= expectedT exprT) - - _ - false)) - -(def: (succeeds? error) - (All [a] (-> (e.Error a) Bool)) - (case error - (#e.Success _) - true - - (#e.Error _) - false)) - -(def: (flatten-apply analysis) - (-> la.Analysis [la.Analysis (List la.Analysis)]) - (case analysis - (^code ("lux apply" (~ head) (~ func))) - (let [[func' tail] (flatten-apply func)] - [func' (#.Cons head tail)]) - - _ - [analysis (list)])) - -(def: (check-apply expectedT num-args analysis) - (-> Type Nat (Meta la.Analysis) Bool) - (|> analysis - (&.with-type expectedT) - (macro.run (io.run init-jvm)) - (case> (#e.Success applyA) - (let [[funcA argsA] (flatten-apply applyA)] - (n/= num-args (list.size argsA))) - - (#e.Error error) - false))) - -(context: "Function definition." - (<| (times +100) - (do @ - [func-name (r.text +5) - arg-name (|> (r.text +5) (r.filter (|>> (text/= func-name) not))) - [outputT outputC] gen-primitive - [inputT _] gen-primitive - #let [g!arg (code.local-symbol arg-name)]] - ($_ seq - (test "Can analyse function." - (and (|> (&.with-type (All [a] (-> a outputT)) - (@.analyse-function analyse func-name arg-name outputC)) - (macro.run (io.run init-jvm)) - succeeds?) - (|> (&.with-type (All [a] (-> a a)) - (@.analyse-function analyse func-name arg-name g!arg)) - (macro.run (io.run init-jvm)) - succeeds?))) - (test "Generic functions can always be specialized." - (and (|> (&.with-type (-> inputT outputT) - (@.analyse-function analyse func-name arg-name outputC)) - (macro.run (io.run init-jvm)) - succeeds?) - (|> (&.with-type (-> inputT inputT) - (@.analyse-function analyse func-name arg-name g!arg)) - (macro.run (io.run init-jvm)) - succeeds?))) - (test "The function's name is bound to the function's type." - (|> (&.with-type (Rec self (-> inputT self)) - (@.analyse-function analyse func-name arg-name (code.local-symbol func-name))) - (macro.run (io.run init-jvm)) - succeeds?)) - )))) - -(context: "Function application." - (<| (times +100) - (do @ - [full-args (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) - partial-args (|> r.nat (:: @ map (n/% full-args))) - var-idx (|> r.nat (:: @ map (|>> (n/% full-args) (n/max +1)))) - inputsTC (r.list full-args gen-primitive) - #let [inputsT (list/map product.left inputsTC) - inputsC (list/map product.right inputsTC)] - [outputT outputC] gen-primitive - #let [funcT (type.function inputsT outputT) - partialT (type.function (list.drop partial-args inputsT) outputT) - varT (#.Bound +1) - polyT (<| (type.univ-q +1) - (type.function (list.concat (list (list.take var-idx inputsT) - (list varT) - (list.drop (n/inc var-idx) inputsT)))) - varT) - poly-inputT (maybe.assume (list.nth var-idx inputsT)) - partial-poly-inputsT (list.drop (n/inc var-idx) inputsT) - partial-polyT1 (<| (type.function partial-poly-inputsT) - poly-inputT) - partial-polyT2 (<| (type.univ-q +1) - (type.function (#.Cons varT partial-poly-inputsT)) - varT)]] - ($_ seq - (test "Can analyse monomorphic type application." - (|> (@.analyse-apply analyse funcT (' []) inputsC) - (check-apply outputT full-args))) - (test "Can partially apply functions." - (|> (@.analyse-apply analyse funcT (' []) (list.take partial-args inputsC)) - (check-apply partialT partial-args))) - (test "Can apply polymorphic functions." - (|> (@.analyse-apply analyse polyT (' []) inputsC) - (check-apply poly-inputT full-args))) - (test "Polymorphic partial application propagates found type-vars." - (|> (@.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." - (|> (@.analyse-apply analyse polyT (' []) (list.take var-idx inputsC)) - (check-apply partial-polyT2 var-idx))) - )))) diff --git a/stdlib/source/lux/lang/analysis.lux b/stdlib/source/lux/lang/analysis.lux index 6b2ba097d..223f2fb29 100644 --- a/stdlib/source/lux/lang/analysis.lux +++ b/stdlib/source/lux/lang/analysis.lux @@ -55,6 +55,8 @@ (type: #export Tuple (List Analysis)) +(type: #export Application [Analysis (List Analysis)]) + (do-template [<name> <tag>] [(def: <name> (-> Analysis Analysis) @@ -103,8 +105,8 @@ (list/fold (function (_ left right) (#Structure (#Product left right))) last prevs))) -(def: #export (apply args func) - (-> (List Analysis) Analysis Analysis) +(def: #export (apply [func args]) + (-> Application Analysis) (list/fold (function (_ arg func) (#Apply arg func)) func args)) (type: #export Analyser @@ -141,3 +143,13 @@ _ #.None))) + +(def: #export (application analysis) + (-> Analysis Application) + (case analysis + (#Apply head func) + (let [[func' tail] (application func)] + [func' (#.Cons head tail)]) + + _ + [analysis (list)])) diff --git a/stdlib/source/lux/lang/analysis/expression.lux b/stdlib/source/lux/lang/analysis/expression.lux index 5013246aa..da1b27a10 100644 --- a/stdlib/source/lux/lang/analysis/expression.lux +++ b/stdlib/source/lux/lang/analysis/expression.lux @@ -13,9 +13,7 @@ (analysis [".A" type] [".A" primitive] [".A" structure] - [".A" reference] - ## [".A" function] - ) + [".A" reference]) ## [".L" macro] ## [".L" extension] ))) diff --git a/stdlib/source/lux/lang/analysis/function.lux b/stdlib/source/lux/lang/analysis/function.lux new file mode 100644 index 000000000..f6fea9bb0 --- /dev/null +++ b/stdlib/source/lux/lang/analysis/function.lux @@ -0,0 +1,104 @@ +(.module: + [lux #- function] + (lux (control monad + ["ex" exception #+ exception:]) + (data [maybe] + [text] + text/format + (coll [list "list/" Fold<List> Monoid<List> Monad<List>])) + [macro] + (macro [code]) + [lang] + (lang [type] + (type ["tc" check]) + [".L" scope] + [".L" analysis #+ Analysis Analyser] + (analysis [".A" type] + [".A" inference])))) + +(exception: #export (cannot-analyse {expected Type} {function Text} {argument Text} {body Code}) + (ex.report ["Type" (%type expected)] + ["Function" function] + ["Argument" argument] + ["Body" (%code body)])) + +(exception: #export (cannot-apply {function Type} {arguments (List Code)}) + (ex.report [" Function" (%type function)] + ["Arguments" (|> arguments + list.enumerate + (list/map (.function (_ [idx argC]) + (format "\n " (%n idx) " " (%code argC)))) + (text.join-with ""))])) + +## [Analysers] +(def: #export (function analyse function-name arg-name body) + (-> Analyser Text Text Code (Meta Analysis)) + (do macro.Monad<Meta> + [functionT macro.expected-type] + (loop [expectedT functionT] + (lang.with-stacked-errors + (.function (_ _) + (ex.construct cannot-analyse [expectedT function-name arg-name body])) + (case expectedT + (#.Named name unnamedT) + (recur unnamedT) + + (#.Apply argT funT) + (case (type.apply (list argT) funT) + (#.Some value) + (recur value) + + #.None + (lang.fail (ex.construct cannot-analyse [expectedT function-name arg-name body]))) + + (^template [<tag> <instancer>] + (<tag> _) + (do @ + [[_ instanceT] (typeA.with-env <instancer>)] + (recur (maybe.assume (type.apply (list instanceT) expectedT))))) + ([#.UnivQ tc.existential] + [#.ExQ tc.var]) + + (#.Var id) + (do @ + [?expectedT' (typeA.with-env + (tc.read id))] + (case ?expectedT' + (#.Some expectedT') + (recur expectedT') + + _ + ## Inference + (do @ + [[input-id inputT] (typeA.with-env tc.var) + [output-id outputT] (typeA.with-env tc.var) + #let [functionT (#.Function inputT outputT)] + functionA (recur functionT) + _ (typeA.with-env + (tc.check expectedT functionT))] + (wrap functionA)) + )) + + (#.Function inputT outputT) + (<| (:: @ map (.function (_ [scope bodyA]) + (#analysisL.Function (scopeL.environment scope) bodyA))) + lang.with-scope + ## Functions have access not only to their argument, but + ## also to themselves, through a local variable. + (scopeL.with-local [function-name expectedT]) + (scopeL.with-local [arg-name inputT]) + (typeA.with-type outputT) + (analyse body)) + + _ + (lang.fail "") + ))))) + +(def: #export (apply analyse functionT functionA args) + (-> Analyser Type Analysis (List Code) (Meta Analysis)) + (lang.with-stacked-errors + (.function (_ _) + (ex.construct cannot-apply [functionT args])) + (do macro.Monad<Meta> + [[applyT argsA] (inferenceA.general analyse functionT args)] + (wrap (analysisL.apply [functionA argsA]))))) diff --git a/stdlib/source/lux/lang/scope.lux b/stdlib/source/lux/lang/scope.lux index 45008ae24..1995338f4 100644 --- a/stdlib/source/lux/lang/scope.lux +++ b/stdlib/source/lux/lang/scope.lux @@ -9,7 +9,7 @@ (coll [list "list/" Functor<List> Fold<List> Monoid<List>] (dictionary [plist]))) [macro]) - (// [analysis #+ Variable])) + (// [analysis #+ Variable Register])) (type: Locals (Bindings Text [Type Nat])) (type: Foreign (Bindings Text [Type Variable])) @@ -163,7 +163,7 @@ )) (def: #export next-local - (Meta Nat) + (Meta Register) (function (_ compiler) (case (get@ #.scopes compiler) #.Nil @@ -171,3 +171,18 @@ (#.Cons top _) (#e.Success [compiler (get@ [#.locals #.counter] top)])))) + +(def: (ref-to-variable ref) + (-> Ref Variable) + (case ref + (#.Local register) + (#analysis.Local register) + + (#.Captured register) + (#analysis.Foreign register))) + +(def: #export (environment scope) + (-> Scope (List Variable)) + (|> scope + (get@ [#.captured #.mappings]) + (list/map (function (_ [_ [_ ref]]) (ref-to-variable ref))))) diff --git a/stdlib/test/test/lux/lang/analysis/function.lux b/stdlib/test/test/lux/lang/analysis/function.lux new file mode 100644 index 000000000..97ab808a0 --- /dev/null +++ b/stdlib/test/test/lux/lang/analysis/function.lux @@ -0,0 +1,111 @@ +(.module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data ["e" error] + [maybe] + [product] + [text "text/" Eq<Text>] + text/format + (coll [list "list/" Functor<List>])) + ["r" math/random "r/" Monad<Random>] + [macro] + (macro [code]) + [lang] + (lang [type "type/" Eq<Type>] + [".L" init] + [".L" analysis #+ Analysis] + (analysis [".A" type] + [".A" expression] + ["/" function])) + test) + (// ["_." primitive] + ["_." structure])) + +(def: analyse (expressionA.analyser (:! lang.Eval []))) + +(def: (check-apply expectedT num-args analysis) + (-> Type Nat (Meta Analysis) Bool) + (|> analysis + (typeA.with-type expectedT) + (macro.run (initL.compiler [])) + (case> (#e.Success applyA) + (let [[funcA argsA] (analysisL.application applyA)] + (n/= num-args (list.size argsA))) + + (#e.Error error) + false))) + +(context: "Function definition." + (<| (times +100) + (do @ + [func-name (r.unicode +5) + arg-name (|> (r.unicode +5) (r.filter (|>> (text/= func-name) not))) + [outputT outputC] _primitive.primitive + [inputT _] _primitive.primitive + #let [g!arg (code.local-symbol arg-name)]] + ($_ seq + (test "Can analyse function." + (and (|> (typeA.with-type (All [a] (-> a outputT)) + (/.function ..analyse func-name arg-name outputC)) + _structure.check-succeeds) + (|> (typeA.with-type (All [a] (-> a a)) + (/.function ..analyse func-name arg-name g!arg)) + _structure.check-succeeds))) + (test "Generic functions can always be specialized." + (and (|> (typeA.with-type (-> inputT outputT) + (/.function ..analyse func-name arg-name outputC)) + _structure.check-succeeds) + (|> (typeA.with-type (-> inputT inputT) + (/.function ..analyse func-name arg-name g!arg)) + _structure.check-succeeds))) + (test "The function's name is bound to the function's type." + (|> (typeA.with-type (Rec self (-> inputT self)) + (/.function ..analyse func-name arg-name (code.local-symbol func-name))) + _structure.check-succeeds)) + )))) + +(context: "Function application." + (<| (times +100) + (do @ + [full-args (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) + partial-args (|> r.nat (:: @ map (n/% full-args))) + var-idx (|> r.nat (:: @ map (|>> (n/% full-args) (n/max +1)))) + inputsTC (r.list full-args _primitive.primitive) + #let [inputsT (list/map product.left inputsTC) + inputsC (list/map product.right inputsTC)] + [outputT outputC] _primitive.primitive + #let [funcT (type.function inputsT outputT) + partialT (type.function (list.drop partial-args inputsT) outputT) + varT (#.Bound +1) + polyT (<| (type.univ-q +1) + (type.function (list.concat (list (list.take var-idx inputsT) + (list varT) + (list.drop (inc var-idx) inputsT)))) + varT) + poly-inputT (maybe.assume (list.nth var-idx inputsT)) + partial-poly-inputsT (list.drop (inc var-idx) inputsT) + partial-polyT1 (<| (type.function partial-poly-inputsT) + poly-inputT) + partial-polyT2 (<| (type.univ-q +1) + (type.function (#.Cons varT partial-poly-inputsT)) + varT) + dummy-function (#analysisL.Function (list) (#analysisL.Variable (#analysisL.Local +1)))]] + ($_ seq + (test "Can analyse monomorphic type application." + (|> (/.apply ..analyse funcT dummy-function inputsC) + (check-apply outputT full-args))) + (test "Can partially apply functions." + (|> (/.apply ..analyse funcT dummy-function (list.take partial-args inputsC)) + (check-apply partialT partial-args))) + (test "Can apply polymorphic functions." + (|> (/.apply ..analyse polyT dummy-function inputsC) + (check-apply poly-inputT full-args))) + (test "Polymorphic partial application propagates found type-vars." + (|> (/.apply ..analyse polyT dummy-function (list.take (inc var-idx) inputsC)) + (check-apply partial-polyT1 (inc var-idx)))) + (test "Polymorphic partial application preserves quantification for type-vars." + (|> (/.apply ..analyse polyT dummy-function (list.take var-idx inputsC)) + (check-apply partial-polyT2 var-idx))) + )))) diff --git a/stdlib/test/test/lux/lang/analysis/structure.lux b/stdlib/test/test/lux/lang/analysis/structure.lux index 5bebe5325..ad6691287 100644 --- a/stdlib/test/test/lux/lang/analysis/structure.lux +++ b/stdlib/test/test/lux/lang/analysis/structure.lux @@ -29,7 +29,7 @@ (def: analyse (expressionA.analyser (:! lang.Eval []))) (do-template [<name> <on-success> <on-error>] - [(def: <name> + [(def: #export <name> (All [a] (-> (Meta a) Bool)) (|>> (macro.run (initL.compiler [])) (case> (#e.Success _) |