aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/lang/analysis/function.lux111
-rw-r--r--new-luxc/source/luxc/lang/variable.lux47
-rw-r--r--new-luxc/test/test/luxc/lang/analysis/function.lux141
-rw-r--r--stdlib/source/lux/lang/analysis.lux16
-rw-r--r--stdlib/source/lux/lang/analysis/expression.lux4
-rw-r--r--stdlib/source/lux/lang/analysis/function.lux104
-rw-r--r--stdlib/source/lux/lang/scope.lux19
-rw-r--r--stdlib/test/test/lux/lang/analysis/function.lux111
-rw-r--r--stdlib/test/test/lux/lang/analysis/structure.lux2
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 _)