blob: 394e65c4dafed347ee4b94dde95f037475ca6b47 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
|
(;module:
lux
(lux (control monad)
(data [text]
text/format
(coll [list "L/" Fold<List> Monoid<List> Monad<List>]))
[macro #+ Monad<Lux>]
[type]
(type ["TC" check]))
(luxc ["&" base]
(lang ["la" analysis #+ Analysis])
["&;" env]
(analyser ["&;" common]
["&;" inference])))
## [Analysers]
(def: #export (analyse-function analyse func-name arg-name body)
(-> &;Analyser Text Text Code (Lux Analysis))
(do Monad<Lux>
[functionT macro;expected-type]
(loop [expected functionT]
(&;with-stacked-errors
(function [_] (format "Functions require function types: " (type;to-text expected)))
(case expected
(#;Named name unnamedT)
(recur unnamedT)
(#;App funT argT)
(do @
[fully-applied (case (type;apply-type funT argT)
(#;Some value)
(wrap value)
#;None
(&;fail (format "Cannot apply type " (%type funT) " to type " (%type argT))))]
(recur fully-applied))
(#;UnivQ _)
(do @
[[var-id var] (&;within-type-env
TC;existential)]
(recur (assume (type;apply-type expected var))))
(#;ExQ _)
(&common;with-var
(function [[var-id var]]
(recur (assume (type;apply-type expected var)))))
(#;Var id)
(do @
[? (&;within-type-env
(TC;bound? id))]
(if ?
(do @
[expected' (&;within-type-env
(TC;read-var id))]
(recur expected'))
## Inference
(&common;with-var
(function [[input-id inputT]]
(&common;with-var
(function [[output-id outputT]]
(do @
[#let [funT (#;Function inputT outputT)]
=function (recur funT)
funT' (&;within-type-env
(TC;clean output-id funT))
concrete-input? (&;within-type-env
(TC;bound? input-id))
funT'' (if concrete-input?
(&;within-type-env
(TC;clean input-id funT'))
(wrap (#;UnivQ (list) (&inference;bind-var input-id +1 funT'))))
_ (&;within-type-env
(TC;check expected funT''))]
(wrap =function))
))))))
(#;Function inputT outputT)
(<| (:: @ map (|>. #la;Function))
&;with-scope
(&env;with-local [func-name functionT])
(&env;with-local [arg-name inputT])
(&;with-expected-type outputT)
(analyse body))
_
(&;fail "")
)))))
(def: #export (analyse-apply analyse funcT funcA args)
(-> &;Analyser Type Analysis (List Code) (Lux Analysis))
(&;with-stacked-errors
(function [_] (format "Cannot apply function " (%type funcT)
" to args: " (|> args (L/map %code) (text;join-with " "))))
(do Monad<Lux>
[expected macro;expected-type
[applyT argsA] (&inference;apply-function analyse funcT args)
_ (&;within-type-env
(TC;check expected applyT))]
(wrap (L/fold (function [arg func]
(#la;Apply arg func))
funcA
argsA)))))
|
