blob: 5a6df4d3ef3fc2b726a0be4f9ee7be7524bf43f4 (
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
105
106
107
108
109
110
111
112
113
114
115
|
(;module:
lux
(lux (control monad
["ex" exception #+ exception:])
(data [maybe]
[text]
text/format
(coll [list "list/" Fold<List> Monoid<List> Monad<List>]))
[meta]
(meta [code]
[type]
(type ["tc" check])))
(luxc ["&" base]
(lang ["la" analysis #+ Analysis]
(analysis ["&;" common]
["&;" inference])
[";L" variable #+ Variable])
["&;" scope]))
(exception: #export Invalid-Function-Type)
(exception: #export Cannot-Apply-Function)
## [Analysers]
(def: #export (analyse-function analyse func-name arg-name body)
(-> &;Analyser Text Text Code (Meta Analysis))
(do meta;Monad<Meta>
[functionT meta;expected-type]
(loop [expectedT functionT]
(&;with-stacked-errors
(function [_] (Invalid-Function-Type (%type expectedT)))
(case expectedT
(#;Named name unnamedT)
(recur unnamedT)
(#;Apply argT funT)
(case (type;apply (list argT) funT)
(#;Some value)
(recur value)
#;None
(&;fail (format "Cannot apply type " (%type funT) " to type " (%type argT))))
(#;UnivQ _)
(do @
[[var-id var] (&;with-type-env
tc;existential)]
(recur (maybe;assume (type;apply (list var) expectedT))))
(#;ExQ _)
(&common;with-var
(function [[var-id var]]
(recur (maybe;assume (type;apply (list var) expectedT)))))
(#;Var id)
(do @
[? (&;with-type-env
(tc;concrete? id))]
(if ?
(do @
[expectedT' (&;with-type-env
(tc;read id))]
(recur expectedT'))
## Inference
(&common;with-var
(function [[input-id inputT]]
(&common;with-var
(function [[output-id outputT]]
(do @
[#let [funT (#;Function inputT outputT)]
funA (recur funT)
funT' (&;with-type-env
(tc;clean output-id funT))
concrete-input? (&;with-type-env
(tc;concrete? input-id))
funT'' (if concrete-input?
(&;with-type-env
(tc;clean input-id funT'))
(wrap (type;univ-q +1 (&inference;replace-var input-id +1 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-expected-type outputT)
(analyse body))
_
(&;fail "")
)))))
(def: #export (analyse-apply analyse funcT funcA args)
(-> &;Analyser Type Analysis (List Code) (Meta Analysis))
(&;with-stacked-errors
(function [_]
(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 meta;Monad<Meta>
[expectedT meta;expected-type
[applyT argsA] (&inference;apply-function analyse funcT args)
_ (&;with-type-env
(tc;check expectedT applyT))]
(wrap (la;apply argsA funcA)))))
|
