carp-lang/Carp
1
1
Fork 0
mirror of https://github.com/carp-lang/Carp.git synced 2024-11-04 01:25:04 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' of https://github.com/carp-lang/Carp

Browse Source
This commit is contained in:
Erik Svedäng 2020-02-10 09:51:25 +01:00
commit f63f4c54ad
66 changed files with 1413 additions and 807 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
core/Map.carp
View File

@ -144,8 +144,8 @@
(defn put [m k v]
(let [idx (Int.positive-mod (hash k) @(n-buckets &m))]
(update-buckets m &(fn [b]
(let [n (Array.unsafe-nth &b idx)]
(Array.aset b idx (Bucket.put @n k v)))))))
(let [n (Array.unsafe-nth &b idx)]
(Array.aset b idx (Bucket.put @n k v)))))))
(doc put! "Put a a value v into map m, using the key k, in place.")
(defn put! [m k v]
@ -209,8 +209,8 @@
(defn remove [m k]
(let [idx (Int.positive-mod (hash k) @(n-buckets &m))]
(update-buckets m &(fn [b]
(let [n (Array.unsafe-nth &b idx)]
(Array.aset b idx (Bucket.shrink @n k)))))))
(let [n (Array.unsafe-nth &b idx)]
(Array.aset b idx (Bucket.shrink @n k)))))))
(doc all? "Do all key-value pairs pass the given predicate (of two arguments)?")
(defn all? [pred m]
@ -358,12 +358,15 @@
(doc put "Put a a key k into the set s.")
(defn put [s k]
(let [idx (Int.positive-mod (hash k) @(n-buckets &s))]
(let [idx (Int.positive-mod (hash k) @(n-buckets &s))
;; The lifetime system really doesn't like this function, had to put in a bunch of copying to make it compile:
]
(update-buckets s &(fn [b]
(let [n (Array.unsafe-nth &b idx)]
(if (SetBucket.contains? n k)
b
(Array.aset b idx (SetBucket.grow n @k))))))))
(let [new-k @k] ;; HACK!
(Array.aset b idx (SetBucket.grow n new-k)))))))))
(doc put! "Put a a key k into the set s, in place.")
(defn put! [s k]
@ -393,8 +396,8 @@
(defn remove [s k]
(let [idx (Int.positive-mod (hash k) @(n-buckets &s))]
(update-buckets s &(fn [b]
(let [n (Array.unsafe-nth &b idx)]
(Array.aset b idx (SetBucket.shrink n k)))))))
(let [n (Array.unsafe-nth &b idx)]
(Array.aset b idx (SetBucket.shrink n k)))))))
(doc all? "Does the predicate hold for all values in this set?")
(defn all? [pred set]

26
core/Pattern.carp
View File

@ -39,6 +39,30 @@ If you want to replace all occurrences of the pattern, use `-1`.")
(doc from-chars "creates a pattern that matches a group of characters from a list of those characters.")
(defn from-chars [chars]
(Pattern.init &(str* @"[" (String.from-chars chars) @"]")))
(defn global-match-str [p s]
(Array.copy-map &Array.unsafe-first &(global-match p s)))
(doc split "splits a string by a pattern.")
(defn split [p s]
(let-do [idx (find-all p s)
strs (global-match-str p s)
lidx (Array.length &idx)
result (Array.allocate (Int.inc lidx))]
(Array.aset-uninitialized! &result 0
(substring s 0 (if (> lidx 0) @(Array.unsafe-nth &idx 0) (length s))))
(for [i 0 (Int.dec (Array.length &idx))]
(let [plen (length (Array.unsafe-nth &strs i))]
(Array.aset-uninitialized! &result (Int.inc i)
(substring s (+ @(Array.unsafe-nth &idx i) plen)
@(Array.unsafe-nth &idx (Int.inc i))))))
(when (> lidx 0)
(let [plen (length (Array.unsafe-nth &strs (Int.dec lidx)))]
(Array.aset-uninitialized! &result lidx
(suffix-string s (+ @(Array.unsafe-nth &idx (Int.dec lidx))
plen)))))
result))
)
(defmodule String
@ -84,7 +108,7 @@ If you want to replace all occurrences of the pattern, use `-1`.")
(doc chomp "trims a newline from the end of a string.")
(defn chomp [s]
(Pattern.substitute #"\n$" s "" 1))
(Pattern.substitute #"\r$" &(Pattern.substitute #"\n$" s "" 1) "" 1))
(doc collapse-whitespace "collapses groups of whitespace into single spaces.")
(defn collapse-whitespace [s]

22
core/carp_pattern.h
View File

@ -304,19 +304,17 @@ init: /* using goto's to optimize tail recursion */
s = NULL; /* match failed */
break;
}
case 'n': { /* newline? */
if (*s == '\r') {
if (*(++s) == '\n') s++;
} else if (*s == '\n')
s++;
else
s = NULL;
break;
}
case 'r': /* carriage return? */
case 'n': /* newline? */
case 't': { /* tab? */
if (*s == '\t')
char h = *(p + 1);
p += 2;
if ((*s == '\r' && h == 'r') ||
(*s == '\n' && h == 'n') ||
(*s == '\t' && h == 't')) {
s++;
else
goto init;
} else
s = NULL;
break;
}
@ -428,7 +426,7 @@ Array Pattern_internal_push_onecapture(PatternMatchState *ms, int i, String s,
if (i >= ms->level) {
if (!i)
return Array_push_String(captures, s, i,
ms->capture[i].len); /* add whole match */
e - s); /* add whole match */
else
carp_regerror("invalid capture index %cd", C_ESC, i + 1);
} else {

64
docs/DynamicSemantics.md
View File

@ -30,4 +30,66 @@ This document will help us rewrite Carp's dynamic evaluator (defined in Eval.hs)
## Index
[TODO]
## 1. [TODO]
## 0. Terms used in this document
* form : Any valid Carp data struture as represented in text.
* top level : Any form that isn't embedded in another form.
* Static Carp : The compiled version of the Carp langauge
* Dynamic Carp : The interpreted, functional, GC'ed version of the Carp langauge
## 1. Scoping Rules
Related issues:
* https://github.com/carp-lang/Carp/issues/659
Questions:
* How does Carp figure out what the value of the symbol X is?
* How do you set the value for symbol X?
* Are there any reserved names?
* What is a keyword?
* Are there different namespaces for dynamic and static Carp?
### 1.1 Global Variables
Questions:
* Are global variables mutable?
* If they are mutable, how are they mutated? When do these mutations come into affect?
* Do global variables have lexical or dynamic scope?
### 1.2 Local variables
Questions:
* Are local variables mutable?
* When do local variables come in and out of scope?
* What is a closure?
### 1.3. Namespace Rules
Questions:
* Given symbols `a` in the `foo` module and `a` in the `bar` module, how do I refer to each of them?
* Given the symbols`Foo.a` and `Bar.a`, exist, which symbol does `a` refer to?
* Do functions and variables live in the same namespace?
## 2. Evaluation Rules
Related issues:
* https://github.com/carp-lang/Carp/issues/555
Questions:
* When are macros evaluated?
* When are symbols evaluated?
* When are forms evaluated?
* Are forms evaluated left-to-right or right-to-left?
* How does error reporting work?
### 2.1 Macros
Questions:
* What is a macro?
* What functions are available at macro-expansion time?
* What is quasi-quoting and what is its syntax?
* What is splicing, and what is its syntax?
### 2.2 REPL
Questions:
* How does the REPL know when to evalutate something in the dynamic or static context?
* When does it decide to run the given code in the dynamic or static context?
## 3. Types
Issues:
* [#560 Add Reflection Module Proposal](https://github.com/carp-lang/Carp/issues/560)
Questions:
* What types are available?
* When is a form typechecked?
* How do you refer to a specific type? Are types [first class citizens](https://en.wikipedia.org/wiki/First-class_citizen)?

112
docs/core/Array.html
View File

@ -161,7 +161,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array a)), (Ref (Array a))] Bool)
(λ [(Ref (Array a) b), (Ref (Array a) b)] Bool)
</p>
<pre class="args">
(= a b)
@ -181,7 +181,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (λ [&amp;a] Bool)), (Ref (Array a))] Bool)
(λ [(Ref (λ [(Ref a b)] Bool c) d), (Ref (Array a) b)] Bool)
</p>
<pre class="args">
(all? f a)
@ -201,7 +201,7 @@
template
</div>
<p class="sig">
(λ [Int] (Array t))
(λ [Int] (Array a))
</p>
<span>
@ -221,7 +221,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (λ [&amp;a] Bool)), (Ref (Array a))] Bool)
(λ [(Ref (λ [(Ref a b)] Bool c) d), (Ref (Array a) b)] Bool)
</p>
<pre class="args">
(any? f a)
@ -241,7 +241,7 @@
template
</div>
<p class="sig">
(λ [(Array t), Int, t] (Array t))
(λ [(Array a), Int, a] (Array a))
</p>
<span>
@ -261,7 +261,7 @@
template
</div>
<p class="sig">
(λ [(Ref (Array t)), Int, t] ())
(λ [(Ref (Array a) b), Int, a] ())
</p>
<span>
@ -281,7 +281,7 @@
template
</div>
<p class="sig">
(λ [(Ref (Array t)), Int, t] ())
(λ [(Ref (Array a) b), Int, a] ())
</p>
<span>
@ -301,7 +301,7 @@
defn
</div>
<p class="sig">
(λ [(Array a), Int, (Ref (λ [&amp;a] a))] (Array a))
(λ [(Array a), Int, (Ref (λ [(Ref a b)] a c) d)] (Array a))
</p>
<pre class="args">
(aupdate a i f)
@ -321,7 +321,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array a)), Int, (Ref (λ [&amp;a] a))] ())
(λ [(Ref (Array a) b), Int, (Ref (λ [(Ref a b)] a c) d)] ())
</p>
<pre class="args">
(aupdate! a i f)
@ -341,7 +341,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array (Array a)))] (Array a))
(λ [(Ref (Array (Array a)) b)] (Array a))
</p>
<pre class="args">
(concat xs)
@ -361,7 +361,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array a)), &amp;a] Bool)
(λ [(Ref (Array a) b), (Ref a b)] Bool)
</p>
<pre class="args">
(contains? arr el)
@ -381,7 +381,7 @@
template
</div>
<p class="sig">
(λ [(Ref (Array a))] (Array a))
(λ [(Ref (Array a) b)] (Array a))
</p>
<span>
@ -401,7 +401,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (λ [&amp;a] Bool)), (Ref (Array a))] (Array a))
(λ [(Ref (λ [(Ref a b)] Bool c) d), (Ref (Array a) e)] (Array a))
</p>
<pre class="args">
(copy-filter f a)
@ -422,7 +422,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (λ [&amp;a] b)), (Ref (Array a))] (Array b))
(λ [(Ref (λ [(Ref a b)] c d) e), (Ref (Array a) b)] (Array c))
</p>
<pre class="args">
(copy-map f a)
@ -463,7 +463,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array a)), &amp;a] Int)
(λ [(Ref (Array a) b), (Ref a b)] Int)
</p>
<pre class="args">
(element-count a e)
@ -483,7 +483,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array a))] Bool)
(λ [(Ref (Array a) b)] Bool)
</p>
<pre class="args">
(empty? a)
@ -503,7 +503,7 @@
template
</div>
<p class="sig">
(λ [(Ref (λ [&amp;a] Bool)), (Array a)] (Array a))
(λ [(Ref (λ [(Ref a b)] Bool c) d), (Array a)] (Array a))
</p>
<span>
@ -523,7 +523,7 @@
template
</div>
<p class="sig">
(λ [(Ref (λ [a] a)), (Array a)] (Array a))
(λ [(Ref (λ [a] a b) c), (Array a)] (Array a))
</p>
<span>
@ -543,7 +543,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array a))] (Array (Pair Int a)))
(λ [(Ref (Array a) b)] (Array (Pair Int a)))
</p>
<pre class="args">
(enumerated xs)
@ -563,7 +563,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (λ [&amp;a] Bool)), (Ref (Array a))] (Maybe a))
(λ [(Ref (λ [(Ref a b)] Bool c) d), (Ref (Array a) b)] (Maybe a))
</p>
<pre class="args">
(find f a)
@ -584,7 +584,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (λ [&amp;a] Bool)), (Ref (Array a))] (Maybe Int))
(λ [(Ref (λ [(Ref a b)] Bool c) d), (Ref (Array a) b)] (Maybe Int))
</p>
<pre class="args">
(find-index f a)
@ -605,7 +605,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array a))] (Maybe a))
(λ [(Ref (Array a) b)] (Maybe a))
</p>
<pre class="args">
(first a)
@ -626,7 +626,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array a)), &amp;a] (Maybe Int))
(λ [(Ref (Array a) b), (Ref a b)] (Maybe Int))
</p>
<pre class="args">
(index-of a e)
@ -647,7 +647,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array a))] (Maybe a))
(λ [(Ref (Array a) b)] (Maybe a))
</p>
<pre class="args">
(last a)
@ -668,7 +668,7 @@
template
</div>
<p class="sig">
(λ [(Ref (Array t))] Int)
(λ [(Ref (Array a) b)] Int)
</p>
<span>
@ -688,7 +688,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array a))] (Maybe a))
(λ [(Ref (Array a) b)] (Maybe a))
</p>
<pre class="args">
(maximum xs)
@ -709,7 +709,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array a))] (Maybe a))
(λ [(Ref (Array a) b)] (Maybe a))
</p>
<pre class="args">
(minimum xs)
@ -730,7 +730,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array a)), Int] (Maybe a))
(λ [(Ref (Array a) b), Int] (Maybe a))
</p>
<pre class="args">
(nth xs index)
@ -771,7 +771,7 @@
template
</div>
<p class="sig">
(λ [(Ref (Array a))] a)
(λ [(Ref (Array a) b)] a)
</p>
<span>
@ -791,7 +791,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array a)), (Ref (λ [&amp;a] Bool))] Int)
(λ [(Ref (Array a) b), (Ref (λ [(Ref a b)] Bool c) d)] Int)
</p>
<pre class="args">
(predicate-count a pred)
@ -811,7 +811,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array a)), Int] (Array a))
(λ [(Ref (Array a) b), Int] (Array a))
</p>
<pre class="args">
(prefix-array xs end-index)
@ -831,7 +831,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array a))] String)
(λ [(Ref (Array a) b)] String)
</p>
<pre class="args">
(prn x)
@ -870,7 +870,7 @@
template
</div>
<p class="sig">
(λ [(Ref (Array a)), a] ())
(λ [(Ref (Array a) b), a] ())
</p>
<span>
@ -910,7 +910,7 @@
template
</div>
<p class="sig">
(λ [(Array t)] (Ptr t))
(λ [(Array a)] (Ptr a))
</p>
<span>
@ -930,7 +930,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (λ [a, &amp;b] a)), a, (Ref (Array b))] a)
(λ [(Ref (λ [a, (Ref b c)] a d) e), a, (Ref (Array b) c)] a)
</p>
<pre class="args">
(reduce f x xs)
@ -955,7 +955,7 @@
defn
</div>
<p class="sig">
(λ [&amp;a, (Array a)] (Array a))
(λ [(Ref a b), (Array a)] (Array a))
</p>
<pre class="args">
(remove el arr)
@ -995,7 +995,7 @@
defn
</div>
<p class="sig">
(λ [Int, (Ref (λ [] a))] (Array a))
(λ [Int, (Ref (λ [] a b) c)] (Array a))
</p>
<pre class="args">
(repeat n f)
@ -1015,7 +1015,7 @@
defn
</div>
<p class="sig">
(λ [Int, (λ [Int] a)] (Array a))
(λ [Int, (λ [Int] a b)] (Array a))
</p>
<pre class="args">
(repeat-indexed n f)
@ -1036,7 +1036,7 @@
defn
</div>
<p class="sig">
(λ [Int, &amp;a] (Array a))
(λ [Int, (Ref a b)] (Array a))
</p>
<pre class="args">
(replicate n e)
@ -1096,7 +1096,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array a))] ())
(λ [(Ref (Array a) b)] ())
</p>
<pre class="args">
(sort! arr)
@ -1116,7 +1116,7 @@
defn
</div>
<p class="sig">
(λ [(Array a), (Ref (λ [&amp;a, &amp;a] Bool))] (Array a))
(λ [(Array a), (Ref (λ [(Ref a b), (Ref a b)] Bool c) d)] (Array a))
</p>
<pre class="args">
(sort-by arr f)
@ -1136,7 +1136,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array a)), (Ref (λ [&amp;a, &amp;a] Bool))] ())
(λ [(Ref (Array a) b), (Ref (λ [(Ref a b), (Ref a b)] Bool c) d)] ())
</p>
<pre class="args">
(sort-by! arr f)
@ -1156,7 +1156,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array a))] (Array a))
(λ [(Ref (Array a) b)] (Array a))
</p>
<pre class="args">
(sorted arr)
@ -1176,7 +1176,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array a)), (Ref (λ [&amp;a, &amp;a] Bool))] (Array a))
(λ [(Ref (Array a) b), (Ref (λ [(Ref a c), (Ref a c)] Bool d) e)] (Array a))
</p>
<pre class="args">
(sorted-by arr f)
@ -1196,7 +1196,7 @@
template
</div>
<p class="sig">
(λ [(Ref (Array a))] String)
(λ [(Ref (Array a) b)] String)
</p>
<span>
@ -1216,7 +1216,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array a)), Int, Int] (Array a))
(λ [(Ref (Array a) b), Int, Int] (Array a))
</p>
<pre class="args">
(subarray xs start-index end-index)
@ -1236,7 +1236,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array a)), Int] (Array a))
(λ [(Ref (Array a) b), Int] (Array a))
</p>
<pre class="args">
(suffix-array xs start-index)
@ -1256,7 +1256,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array a))] a)
(λ [(Ref (Array a) b)] a)
</p>
<pre class="args">
(sum xs)
@ -1276,7 +1276,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array (Array a)))] Int)
(λ [(Ref (Array (Array a)) b)] Int)
</p>
<pre class="args">
(sum-length xs)
@ -1316,7 +1316,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array a)), Int, Int] ())
(λ [(Ref (Array a) b), Int, Int] ())
</p>
<pre class="args">
(swap! a i j)
@ -1336,7 +1336,7 @@
defn
</div>
<p class="sig">
(λ [a, (Ref (λ [a] Bool)), (Ref (λ [a] a))] (Array a))
(λ [a, (Ref (λ [a] Bool b) c), (Ref (λ [a] a b) d)] (Array a))
</p>
<pre class="args">
(unreduce start test step)
@ -1363,7 +1363,7 @@ no longer satisfy <code>test</code>. The initial value is <code>start</code>.</p
defn
</div>
<p class="sig">
(λ [(Ref (Array a))] a)
(λ [(Ref (Array a) b)] a)
</p>
<pre class="args">
(unsafe-first a)
@ -1384,7 +1384,7 @@ no longer satisfy <code>test</code>. The initial value is <code>start</code>.</p
defn
</div>
<p class="sig">
(λ [(Ref (Array a))] a)
(λ [(Ref (Array a) b)] a)
</p>
<pre class="args">
(unsafe-last a)
@ -1405,7 +1405,7 @@ no longer satisfy <code>test</code>. The initial value is <code>start</code>.</p
template
</div>
<p class="sig">
(λ [(Ref (Array t)), Int] &amp;t)
(λ [(Ref (Array a) b), Int] (Ref a b))
</p>
<span>
@ -1425,7 +1425,7 @@ no longer satisfy <code>test</code>. The initial value is <code>start</code>.</p
template
</div>
<p class="sig">
(λ [(Ref (Array t))] (Ptr t))
(λ [(Ref a (Array b))] (Ptr b))
</p>
<span>
@ -1465,7 +1465,7 @@ no longer satisfy <code>test</code>. The initial value is <code>start</code>.</p
defn
</div>
<p class="sig">
(λ [(Ref (λ [&amp;a, &amp;b] c)), (Ref (Array a)), (Ref (Array b))] (Array c))
(λ [(Ref (λ [(Ref a b), (Ref c d)] e f) g), (Ref (Array a) b), (Ref (Array c) d)] (Array e))
</p>
<pre class="args">
(zip f a b)

2
docs/core/Bench.html
View File

@ -161,7 +161,7 @@
defn
</div>
<p class="sig">
(λ [(λ [] a)] ())
(λ [(λ [] a b)] ())
</p>
<pre class="args">
(bench f)

6
docs/core/Bool.html
View File

@ -199,7 +199,7 @@
external
</div>
<p class="sig">
(λ [&amp;Bool] Bool)
(λ [(Ref Bool a)] Bool)
</p>
<span>
@ -218,7 +218,7 @@
external
</div>
<p class="sig">
(λ [&amp;String, Bool] String)
(λ [(Ref String a), Bool] String)
</p>
<span>
@ -237,7 +237,7 @@
defn
</div>
<p class="sig">
(λ [&amp;Bool] Int)
(λ [(Ref Bool a)] Int)
</p>
<pre class="args">
(hash k)

10
docs/core/Byte.html
View File

@ -294,7 +294,7 @@
defn
</div>
<p class="sig">
(λ [&amp;Byte, &amp;Byte] Byte)
(λ [(Ref Byte a), (Ref Byte b)] Byte)
</p>
<pre class="args">
(add-ref x y)
@ -446,7 +446,7 @@
external
</div>
<p class="sig">
(λ [&amp;Byte] Byte)
(λ [(Ref Byte a)] Byte)
</p>
<span>
@ -503,7 +503,7 @@
external
</div>
<p class="sig">
(λ [&amp;String, Byte] String)
(λ [(Ref String a), Byte] String)
</p>
<span>
@ -541,7 +541,7 @@
external
</div>
<p class="sig">
(λ [&amp;String] Byte)
(λ [(Ref String a)] Byte)
</p>
<span>
@ -560,7 +560,7 @@
defn
</div>
<p class="sig">
(λ [&amp;Byte] Int)
(λ [(Ref Byte a)] Int)
</p>
<pre class="args">
(hash k)

8
docs/core/Char.html
View File

@ -258,7 +258,7 @@
external
</div>
<p class="sig">
(λ [&amp;Char] Char)
(λ [(Ref Char a)] Char)
</p>
<span>
@ -277,7 +277,7 @@
external
</div>
<p class="sig">
(λ [&amp;String, Char] String)
(λ [(Ref String a), Char] String)
</p>
<span>
@ -315,7 +315,7 @@
defn
</div>
<p class="sig">
(λ [&amp;Char] Int)
(λ [(Ref Char a)] Int)
</p>
<pre class="args">
(hash k)
@ -354,7 +354,7 @@
defn
</div>
<p class="sig">
(λ [&amp;Char] Int)
(λ [(Ref Char a)] Int)
</p>
<pre class="args">
(meaning char-ref)

14
docs/core/Double.html
View File

@ -351,7 +351,7 @@
defn
</div>
<p class="sig">
(λ [&amp;Double, &amp;Double] Double)
(λ [(Ref Double a), (Ref Double b)] Double)
</p>
<pre class="args">
(add-ref x y)
@ -467,7 +467,7 @@
external
</div>
<p class="sig">
(λ [&amp;Double] Double)
(λ [(Ref Double a)] Double)
</p>
<span>
@ -600,7 +600,7 @@
external
</div>
<p class="sig">
(λ [&amp;String, Double] String)
(λ [(Ref String a), Double] String)
</p>
<span>
@ -619,7 +619,7 @@
external
</div>
<p class="sig">
(λ [Double, &amp;Int] Double)
(λ [Double, (Ref Int a)] Double)
</p>
<span>
@ -695,7 +695,7 @@
external
</div>
<p class="sig">
(λ [&amp;String] Double)
(λ [(Ref String a)] Double)
</p>
<span>
@ -714,7 +714,7 @@
defn
</div>
<p class="sig">
(λ [&amp;Double] Int)
(λ [(Ref Double a)] Int)
</p>
<pre class="args">
(hash k)
@ -828,7 +828,7 @@
external
</div>
<p class="sig">
(λ [Double, &amp;Double] Double)
(λ [Double, (Ref Double a)] Double)
</p>
<span>

14
docs/core/Float.html
View File

@ -351,7 +351,7 @@
defn
</div>
<p class="sig">
(λ [&amp;Float, &amp;Float] Float)
(λ [(Ref Float a), (Ref Float b)] Float)
</p>
<pre class="args">
(add-ref x y)
@ -486,7 +486,7 @@
external
</div>
<p class="sig">
(λ [&amp;Float] Float)
(λ [(Ref Float a)] Float)
</p>
<span>
@ -600,7 +600,7 @@
external
</div>
<p class="sig">
(λ [&amp;String, Float] String)
(λ [(Ref String a), Float] String)
</p>
<span>
@ -619,7 +619,7 @@
external
</div>
<p class="sig">
(λ [Float, &amp;Int] Float)
(λ [Float, (Ref Int a)] Float)
</p>
<span>
@ -657,7 +657,7 @@
external
</div>
<p class="sig">
(λ [&amp;String] Float)
(λ [(Ref String a)] Float)
</p>
<span>
@ -676,7 +676,7 @@
defn
</div>
<p class="sig">
(λ [&amp;Float] Int)
(λ [(Ref Float a)] Int)
</p>
<pre class="args">
(hash k)
@ -790,7 +790,7 @@
external
</div>
<p class="sig">
(λ [Float, &amp;Float] Float)
(λ [Float, (Ref Float a)] Float)
</p>
<span>

18
docs/core/IO.html
View File

@ -258,7 +258,7 @@
defn
</div>
<p class="sig">
(λ [Id, &amp;String] ())
(λ [Id, (Ref String a)] ())
</p>
<pre class="args">
(colorize cid s)
@ -278,7 +278,7 @@
external
</div>
<p class="sig">
(λ [&amp;String] ())
(λ [(Ref String a)] ())
</p>
<span>
@ -298,7 +298,7 @@
external
</div>
<p class="sig">
(λ [&amp;String] ())
(λ [(Ref String a)] ())
</p>
<span>
@ -398,7 +398,7 @@
external
</div>
<p class="sig">
(λ [&amp;String, &amp;String] (Ptr FILE))
(λ [(Ref String a), (Ref String b)] (Ptr FILE))
</p>
<span>
@ -557,7 +557,7 @@
defn
</div>
<p class="sig">
(λ [&amp;String, &amp;String] (Result (Ptr FILE) Int))
(λ [(Ref String a), (Ref String b)] (Result (Ptr FILE) Int))
</p>
<pre class="args">
(open-file filename mode)
@ -577,7 +577,7 @@
external
</div>
<p class="sig">
(λ [&amp;String] ())
(λ [(Ref String a)] ())
</p>
<span>
@ -597,7 +597,7 @@
external
</div>
<p class="sig">
(λ [&amp;String] ())
(λ [(Ref String a)] ())
</p>
<span>
@ -617,7 +617,7 @@
defn
</div>
<p class="sig">
(λ [&amp;String] (Result String Int))
(λ [(Ref String a)] (Result String Int))
</p>
<pre class="args">
(read-&gt;EOF filename)
@ -637,7 +637,7 @@
external
</div>
<p class="sig">
(λ [&amp;String] String)
(λ [(Ref String a)] String)
</p>
<span>

16
docs/core/Int.html
View File

@ -352,7 +352,7 @@
defn
</div>
<p class="sig">
(λ [&amp;Int, &amp;Int] Int)
(λ [(Ref Int a), (Ref Int b)] Int)
</p>
<pre class="args">
(add-ref x y)
@ -504,7 +504,7 @@
external
</div>
<p class="sig">
(λ [&amp;Int] Int)
(λ [(Ref Int a)] Int)
</p>
<span>
@ -561,7 +561,7 @@
external
</div>
<p class="sig">
(λ [&amp;String, Int] String)
(λ [(Ref String a), Int] String)
</p>
<span>
@ -600,7 +600,7 @@
external
</div>
<p class="sig">
(λ [&amp;String] Int)
(λ [(Ref String a)] Int)
</p>
<span>
@ -619,7 +619,7 @@
defn
</div>
<p class="sig">
(λ [&amp;Int] Int)
(λ [(Ref Int a)] Int)
</p>
<pre class="args">
(hash k)
@ -792,7 +792,7 @@
external
</div>
<p class="sig">
(λ [Int, Int, &amp;Int] Bool)
(λ [Int, Int, (Ref Int a)] Bool)
</p>
<span>
@ -812,7 +812,7 @@
external
</div>
<p class="sig">
(λ [Int, Int, &amp;Int] Bool)
(λ [Int, Int, (Ref Int a)] Bool)
</p>
<span>
@ -832,7 +832,7 @@
external
</div>
<p class="sig">
(λ [Int, Int, &amp;Int] Bool)
(λ [Int, Int, (Ref Int a)] Bool)
</p>
<span>

14
docs/core/Long.html
View File

@ -427,7 +427,7 @@
external
</div>
<p class="sig">
(λ [&amp;Long] Long)
(λ [(Ref Long a)] Long)
</p>
<span>
@ -484,7 +484,7 @@
external
</div>
<p class="sig">
(λ [&amp;String, Long] String)
(λ [(Ref String a), Long] String)
</p>
<span>
@ -522,7 +522,7 @@
external
</div>
<p class="sig">
(λ [&amp;String] Long)
(λ [(Ref String a)] Long)
</p>
<span>
@ -541,7 +541,7 @@
defn
</div>
<p class="sig">
(λ [&amp;Long] Int)
(λ [(Ref Long a)] Int)
</p>
<pre class="args">
(hash k)
@ -693,7 +693,7 @@
external
</div>
<p class="sig">
(λ [Long, Long, &amp;Long] Bool)
(λ [Long, Long, (Ref Long a)] Bool)
</p>
<span>
@ -712,7 +712,7 @@
external
</div>
<p class="sig">
(λ [Long, Long, &amp;Long] Bool)
(λ [Long, Long, (Ref Long a)] Bool)
</p>
<span>
@ -731,7 +731,7 @@
external
</div>
<p class="sig">
(λ [Long, Long, &amp;Long] Bool)
(λ [Long, Long, (Ref Long a)] Bool)
</p>
<span>

58
docs/core/Map.html
View File

@ -161,7 +161,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Map a b)), (Ref (Map a b))] Bool)
(λ [(Ref (Map a b) c), (Ref (Map a b) c)] Bool)
</p>
<pre class="args">
(= m1 m2)
@ -180,7 +180,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (λ [&amp;a, &amp;b] Bool)), (Ref (Map a b))] Bool)
(λ [(Ref (λ [(Ref a b), (Ref c b)] Bool d) e), (Ref (Map a c) b)] Bool)
</p>
<pre class="args">
(all? pred m)
@ -200,7 +200,7 @@
instantiate
</div>
<p class="sig">
(λ [(Ref (Map a b))] (Ref (Array (Bucket a b))))
(λ [(Ref (Map a b) c)] (Ref (Array (Bucket a b)) c))
</p>
<span>
@ -220,7 +220,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Map a b)), &amp;a] Bool)
(λ [(Ref (Map a b) c), (Ref a c)] Bool)
</p>
<pre class="args">
(contains? m k)
@ -240,7 +240,7 @@
template
</div>
<p class="sig">
(λ [(Ref (Map a b))] (Map a b))
(λ [(Ref (Map a b) c)] (Map a b))
</p>
<span>
@ -340,7 +340,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (λ [&amp;a, &amp;b] b)), (Map a b)] (Map a b))
(λ [(Ref (λ [(Ref a b), (Ref c b)] c d) e), (Map a c)] (Map a c))
</p>
<pre class="args">
(endo-map f m)
@ -360,7 +360,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Map a b)), (Ref (λ [&amp;a, &amp;b] ()))] ())
(λ [(Ref (Map a b) c), (Ref (λ [(Ref a c), (Ref b c)] () d) e)] ())
</p>
<pre class="args">
(for-each m f)
@ -380,7 +380,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array (Pair a b)))] (Map a b))
(λ [(Ref (Array (Pair a b)) c)] (Map a b))
</p>
<pre class="args">
(from-array a)
@ -400,7 +400,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Map a b)), &amp;a] b)
(λ [(Ref (Map a b) c), (Ref a c)] b)
</p>
<pre class="args">
(get m k)
@ -420,7 +420,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Map a b)), &amp;a] (Maybe b))
(λ [(Ref (Map a b) c), (Ref a c)] (Maybe b))
</p>
<pre class="args">
(get-maybe m k)
@ -440,7 +440,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Map a b)), &amp;a, &amp;b] b)
(λ [(Ref (Map a b) c), (Ref a c), (Ref b d)] b)
</p>
<pre class="args">
(get-with-default m k default-value)
@ -480,7 +480,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Map a b))] (Array a))
(λ [(Ref (Map a b) c)] (Array a))
</p>
<pre class="args">
(keys m)
@ -500,7 +500,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (λ [a, &amp;b, &amp;c] a)), a, (Ref (Map b c))] a)
(λ [(Ref (λ [a, (Ref b c), (Ref d c)] a e) f), a, (Ref (Map b d) c)] a)
</p>
<pre class="args">
(kv-reduce f init m)
@ -520,7 +520,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Map a b))] Int)
(λ [(Ref (Map a b) c)] Int)
</p>
<pre class="args">
(length m)
@ -540,7 +540,7 @@
instantiate
</div>
<p class="sig">
(λ [(Ref (Map a b))] &amp;Int)
(λ [(Ref (Map a b) c)] (Ref Int c))
</p>
<span>
@ -560,7 +560,7 @@
template
</div>
<p class="sig">
(λ [(Ref (Map a b))] String)
(λ [(Ref (Map a b) c)] String)
</p>
<span>
@ -580,7 +580,7 @@
defn
</div>
<p class="sig">
(λ [(Map a b), &amp;a, &amp;b] (Map a b))
(λ [(Map a b), (Ref a c), (Ref b c)] (Map a b))
</p>
<pre class="args">
(put m k v)
@ -600,7 +600,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Map a b)), &amp;a, &amp;b] ())
(λ [(Ref (Map a b) c), (Ref a c), (Ref b d)] ())
</p>
<pre class="args">
(put! m k v)
@ -620,7 +620,7 @@
defn
</div>
<p class="sig">
(λ [(Map a b), &amp;a] (Map a b))
(λ [(Map a b), (Ref a c)] (Map a b))
</p>
<pre class="args">
(remove m k)
@ -640,7 +640,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Map a b))] (Map b a))
(λ [(Ref (Map a b) c)] (Map b a))
</p>
<pre class="args">
(reverse m)
@ -680,7 +680,7 @@
instantiate
</div>
<p class="sig">
(λ [(Ref (Map a b)), (Array (Bucket a b))] ())
(λ [(Ref (Map a b) c), (Array (Bucket a b))] ())
</p>
<span>
@ -720,7 +720,7 @@
instantiate
</div>
<p class="sig">
(λ [(Ref (Map a b)), Int] ())
(λ [(Ref (Map a b) c), Int] ())
</p>
<span>
@ -740,7 +740,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Map a b))] String)
(λ [(Ref (Map a b) c)] String)
</p>
<pre class="args">
(str m)
@ -760,7 +760,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Map a b))] (Array (Pair a b)))
(λ [(Ref (Map a b) c)] (Array (Pair a b)))
</p>
<pre class="args">
(to-array m)
@ -780,7 +780,7 @@
defn
</div>
<p class="sig">
(λ [(Map a b), &amp;a, (Ref (λ [b] b))] (Map a b))
(λ [(Map a b), (Ref a c), (Ref (λ [b] b d) c)] (Map a b))
</p>
<pre class="args">
(update m k f)
@ -800,7 +800,7 @@
instantiate
</div>
<p class="sig">
(λ [(Map a b), (Ref (λ [(Array (Bucket a b))] (Array (Bucket a b))))] (Map a b))
(λ [(Map a b), (Ref (λ [(Array (Bucket a b))] (Array (Bucket a b)) c) d)] (Map a b))
</p>
<span>
@ -820,7 +820,7 @@
instantiate
</div>
<p class="sig">
(λ [(Map a b), (Ref (λ [Int] Int))] (Map a b))
(λ [(Map a b), (Ref (λ [Int] Int c) d)] (Map a b))
</p>
<span>
@ -840,7 +840,7 @@
defn
</div>
<p class="sig">
(λ [(Map a b), &amp;a, (Ref (λ [b] b)), b] (Map a b))
(λ [(Map a b), (Ref a c), (Ref (λ [b] b d) c), b] (Map a b))
</p>
<pre class="args">
(update-with-default m k f v)
@ -860,7 +860,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Map a b))] (Array b))
(λ [(Ref (Map a b) c)] (Array b))
</p>
<pre class="args">
(vals m)

18
docs/core/Maybe.html
View File

@ -161,7 +161,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Maybe a)), (Ref (Maybe a))] Bool)
(λ [(Ref (Maybe a) b), (Ref (Maybe a) c)] Bool)
</p>
<pre class="args">
(= a b)
@ -221,7 +221,7 @@
defn
</div>
<p class="sig">
(λ [(Maybe a), (Ref (λ [a] b))] (Maybe b))
(λ [(Maybe a), (Ref (λ [a] b c) d)] (Maybe b))
</p>
<pre class="args">
(apply a f)
@ -241,7 +241,7 @@
template
</div>
<p class="sig">
(λ [(Ref (Maybe a))] (Maybe a))
(λ [(Ref (Maybe a) b)] (Maybe a))
</p>
<span>
@ -322,7 +322,7 @@
instantiate
</div>
<p class="sig">
(λ [(Ref (Maybe a))] Int)
(λ [(Ref (Maybe a) b)] Int)
</p>
<span>
@ -342,7 +342,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Maybe a))] Bool)
(λ [(Ref (Maybe a) b)] Bool)
</p>
<pre class="args">
(just? a)
@ -363,7 +363,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Maybe a))] Bool)
(λ [(Ref (Maybe a) b)] Bool)
</p>
<pre class="args">
(nothing? a)
@ -405,7 +405,7 @@ a value using <code>zero</code> if a <code>Nothing</code> is passed.</p>
template
</div>
<p class="sig">
(λ [(Ref (Maybe a))] String)
(λ [(Ref (Maybe a) b)] String)
</p>
<span>
@ -425,7 +425,7 @@ a value using <code>zero</code> if a <code>Nothing</code> is passed.</p>
template
</div>
<p class="sig">
(λ [(Ref (Maybe a))] String)
(λ [(Ref (Maybe a) b)] String)
</p>
<span>
@ -486,7 +486,7 @@ a value using <code>zero</code> if a <code>Nothing</code> is passed.</p>
defn
</div>
<p class="sig">
(λ [(Ref (Maybe a))] (Ptr a))
(λ [(Ref (Maybe a) b)] (Ptr a))
</p>
<pre class="args">
(unsafe-ptr a)

26
docs/core/Pattern.html
View File

@ -161,7 +161,7 @@
external
</div>
<p class="sig">
(λ [&amp;Pattern, &amp;Pattern] Bool)
(λ [(Ref Pattern a), (Ref Pattern b)] Bool)
</p>
<span>
@ -180,7 +180,7 @@
external
</div>
<p class="sig">
(λ [&amp;Pattern] Pattern)
(λ [(Ref Pattern a)] Pattern)
</p>
<span>
@ -199,7 +199,7 @@
external
</div>
<p class="sig">
(λ [&amp;Pattern, &amp;String] Int)
(λ [(Ref Pattern a), (Ref String b)] Int)
</p>
<span>
@ -220,7 +220,7 @@
external
</div>
<p class="sig">
(λ [&amp;Pattern, &amp;String] (Array Int))
(λ [(Ref Pattern a), (Ref String b)] (Array Int))
</p>
<span>
@ -241,7 +241,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array Char))] Pattern)
(λ [(Ref (Array Char) a)] Pattern)
</p>
<pre class="args">
(from-chars chars)
@ -261,7 +261,7 @@
external
</div>
<p class="sig">
(λ [&amp;Pattern, &amp;String] (Array (Array String)))
(λ [(Ref Pattern a), (Ref String b)] (Array (Array String)))
</p>
<span>
@ -301,7 +301,7 @@
external
</div>
<p class="sig">
(λ [&amp;String] Pattern)
(λ [(Ref String a)] Pattern)
</p>
<span>
@ -320,7 +320,7 @@
external
</div>
<p class="sig">
(λ [&amp;Pattern, &amp;String] (Array String))
(λ [(Ref Pattern a), (Ref String b)] (Array String))
</p>
<span>
@ -341,7 +341,7 @@
external
</div>
<p class="sig">
(λ [&amp;Pattern, &amp;String] String)
(λ [(Ref Pattern a), (Ref String b)] String)
</p>
<span>
@ -362,7 +362,7 @@
defn
</div>
<p class="sig">
(λ [&amp;Pattern, &amp;String] Bool)
(λ [(Ref Pattern a), (Ref String b)] Bool)
</p>
<pre class="args">
(matches? pat s)
@ -382,7 +382,7 @@
external
</div>
<p class="sig">
(λ [&amp;Pattern] String)
(λ [(Ref Pattern a)] String)
</p>
<span>
@ -421,7 +421,7 @@
external
</div>
<p class="sig">
(λ [&amp;Pattern] String)
(λ [(Ref Pattern a)] String)
</p>
<span>
@ -440,7 +440,7 @@
external
</div>
<p class="sig">
(λ [&amp;Pattern, &amp;String, &amp;String, Int] String)
(λ [(Ref Pattern a), (Ref String b), (Ref String c), Int] String)
</p>
<span>

16
docs/core/Pointer.html
View File

@ -161,7 +161,7 @@
template
</div>
<p class="sig">
(λ [(Ptr p), Long] (Ptr p))
(λ [(Ptr a), Long] (Ptr a))
</p>
<span>
@ -181,7 +181,7 @@
template
</div>
<p class="sig">
(λ [(Ref (Ptr p))] (Ptr p))
(λ [(Ref (Ptr a) b)] (Ptr a))
</p>
<span>
@ -220,7 +220,7 @@
template
</div>
<p class="sig">
(λ [(Ptr p), (Ptr p)] Bool)
(λ [(Ptr a), (Ptr a)] Bool)
</p>
<span>
@ -240,7 +240,7 @@
template
</div>
<p class="sig">
(λ [Long] (Ptr p))
(λ [Long] (Ptr a))
</p>
<span>
@ -279,7 +279,7 @@
template
</div>
<p class="sig">
(λ [(Ptr p), Long] (Ptr p))
(λ [(Ptr a), Long] (Ptr a))
</p>
<span>
@ -299,7 +299,7 @@
template
</div>
<p class="sig">
(λ [(Ptr p)] Long)
(λ [(Ptr a)] Long)
</p>
<span>
@ -319,7 +319,7 @@
template
</div>
<p class="sig">
(λ [(Ptr p)] &amp;p)
(λ [(Ptr a)] (Ref a StaticLifetime))
</p>
<span>
@ -339,7 +339,7 @@
template
</div>
<p class="sig">
(λ [(Ptr p)] Long)
(λ [(Ptr a)] Long)
</p>
<span>

28
docs/core/Result.html
View File

@ -161,7 +161,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Result a b)), (Ref (Result a b))] Bool)
(λ [(Ref (Result a b) c), (Ref (Result a b) d)] Bool)
</p>
<pre class="args">
(= a b)
@ -181,7 +181,7 @@
template
</div>
<p class="sig">
(λ [b] (Result a b))
(λ [a] (Result b a))
</p>
<span>
@ -221,7 +221,7 @@
defn
</div>
<p class="sig">
(λ [(Result a b), (Ref (λ [a] (Result c b)))] (Result c b))
(λ [(Result a b), (Ref (λ [a] (Result c b) d) e)] (Result c b))
</p>
<pre class="args">
(and-then a f)
@ -242,7 +242,7 @@
defn
</div>
<p class="sig">
(λ [(Result a b), (Ref (λ [a] c)), (Ref (λ [b] d))] (Result c d))
(λ [(Result a b), (Ref (λ [a] c d) e), (Ref (λ [b] f d) g)] (Result c f))
</p>
<pre class="args">
(apply a success-f error-f)
@ -262,7 +262,7 @@
template
</div>
<p class="sig">
(λ [(Ref (Result a b))] (Result a b))
(λ [(Ref (Result a b) c)] (Result a b))
</p>
<span>
@ -302,7 +302,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Result a b))] Bool)
(λ [(Ref (Result a b) c)] Bool)
</p>
<pre class="args">
(error? a)
@ -361,7 +361,7 @@
instantiate
</div>
<p class="sig">
(λ [(Ref (Result a b))] Int)
(λ [(Ref (Result a b) c)] Int)
</p>
<span>
@ -381,7 +381,7 @@
defn
</div>
<p class="sig">
(λ [(Result a b), (Ref (λ [a] c))] (Result c b))
(λ [(Result a b), (Ref (λ [a] c d) e)] (Result c b))
</p>
<pre class="args">
(map a f)
@ -401,7 +401,7 @@
defn
</div>
<p class="sig">
(λ [(Result a b), (Ref (λ [b] c))] (Result a c))
(λ [(Result a b), (Ref (λ [b] c d) e)] (Result a c))
</p>
<pre class="args">
(map-error a f)
@ -421,7 +421,7 @@
defn
</div>
<p class="sig">
(λ [(Result a b), (Ref (λ [b] (Result a c)))] (Result a c))
(λ [(Result a b), (Ref (λ [b] (Result a c) d) e)] (Result a c))
</p>
<pre class="args">
(or-else a f)
@ -442,7 +442,7 @@
template
</div>
<p class="sig">
(λ [(Ref (Result a b))] String)
(λ [(Ref (Result a b) c)] String)
</p>
<span>
@ -462,7 +462,7 @@
template
</div>
<p class="sig">
(λ [(Ref (Result a b))] String)
(λ [(Ref (Result a b) c)] String)
</p>
<span>
@ -482,7 +482,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Result a b))] Bool)
(λ [(Ref (Result a b) c)] Bool)
</p>
<pre class="args">
(success? a)
@ -564,7 +564,7 @@
defn
</div>
<p class="sig">
(λ [(Result a b), (Ref (λ [b] a))] a)
(λ [(Result a b), (Ref (λ [b] a c) d)] a)
</p>
<pre class="args">
(unwrap-or-else a f)

26
docs/core/Statistics.html
View File

@ -180,7 +180,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array Double)), Int] Double)
(λ [(Ref (Array Double) a), Int] Double)
</p>
<pre class="args">
(grouped-median data interval)
@ -200,7 +200,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array Double))] Double)
(λ [(Ref (Array Double) a)] Double)
</p>
<pre class="args">
(high-median data)
@ -220,7 +220,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array Double))] Double)
(λ [(Ref (Array Double) a)] Double)
</p>
<pre class="args">
(iqr data)
@ -240,7 +240,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array Double))] Double)
(λ [(Ref (Array Double) a)] Double)
</p>
<pre class="args">
(low-median data)
@ -260,7 +260,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array a))] a)
(λ [(Ref (Array a) b)] a)
</p>
<pre class="args">
(mean data)
@ -280,7 +280,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array Double))] Double)
(λ [(Ref (Array Double) a)] Double)
</p>
<pre class="args">
(median data)
@ -300,7 +300,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array Double))] Double)
(λ [(Ref (Array Double) a)] Double)
</p>
<pre class="args">
(pstdev data)
@ -340,7 +340,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array Double))] Double)
(λ [(Ref (Array Double) a)] Double)
</p>
<pre class="args">
(pvariance data)
@ -360,7 +360,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array Double))] (Array Double))
(λ [(Ref (Array Double) a)] (Array Double))
</p>
<pre class="args">
(quartiles data)
@ -380,7 +380,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array Double))] Double)
(λ [(Ref (Array Double) a)] Double)
</p>
<pre class="args">
(stdev data)
@ -400,7 +400,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array Double))] Double)
(λ [(Ref (Array Double) a)] Double)
</p>
<pre class="args">
(stdev-pct data)
@ -419,7 +419,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array Double))] Summary)
(λ [(Ref (Array Double) a)] Summary)
</p>
<pre class="args">
(summary samples)
@ -439,7 +439,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array Double))] Double)
(λ [(Ref (Array Double) a)] Double)
</p>
<pre class="args">
(variance data)

100
docs/core/String.html
View File

@ -161,7 +161,7 @@
external
</div>
<p class="sig">
(λ [&amp;String, &amp;String] Bool)
(λ [(Ref String a), (Ref String b)] Bool)
</p>
<span>
@ -180,7 +180,7 @@
external
</div>
<p class="sig">
(λ [&amp;String, &amp;String] Bool)
(λ [(Ref String a), (Ref String b)] Bool)
</p>
<span>
@ -199,7 +199,7 @@
external
</div>
<p class="sig">
(λ [&amp;String, &amp;String] Bool)
(λ [(Ref String a), (Ref String b)] Bool)
</p>
<span>
@ -237,7 +237,7 @@
defn
</div>
<p class="sig">
(λ [&amp;String] Bool)
(λ [(Ref String a)] Bool)
</p>
<pre class="args">
(alpha? s)
@ -257,7 +257,7 @@
defn
</div>
<p class="sig">
(λ [&amp;String] Bool)
(λ [(Ref String a)] Bool)
</p>
<pre class="args">
(alphanum? s)
@ -277,7 +277,7 @@
external
</div>
<p class="sig">
(λ [&amp;String, &amp;String] String)
(λ [(Ref String a), (Ref String b)] String)
</p>
<span>
@ -296,7 +296,7 @@
external
</div>
<p class="sig">
(λ [&amp;String, Int] Char)
(λ [(Ref String a), Int] Char)
</p>
<span>
@ -315,7 +315,7 @@
external
</div>
<p class="sig">
(λ [&amp;String] (Array Char))
(λ [(Ref String a)] (Array Char))
</p>
<span>
@ -334,7 +334,7 @@
defn
</div>
<p class="sig">
(λ [&amp;String] String)
(λ [(Ref String a)] String)
</p>
<pre class="args">
(chomp s)
@ -354,7 +354,7 @@
defn
</div>
<p class="sig">
(λ [&amp;String] String)
(λ [(Ref String a)] String)
</p>
<pre class="args">
(collapse-whitespace s)
@ -374,7 +374,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array String))] String)
(λ [(Ref (Array String) a)] String)
</p>
<pre class="args">
(concat strings)
@ -394,7 +394,7 @@
defn
</div>
<p class="sig">
(λ [&amp;String, Char] Bool)
(λ [(Ref String a), Char] Bool)
</p>
<pre class="args">
(contains? s c)
@ -414,7 +414,7 @@
defn
</div>
<p class="sig">
(λ [&amp;String, Char] Int)
(λ [(Ref String a), Char] Int)
</p>
<pre class="args">
(count-char s c)
@ -434,7 +434,7 @@
external
</div>
<p class="sig">
(λ [&amp;String] (Ptr Char))
(λ [(Ref String a)] (Ptr Char))
</p>
<span>
@ -453,7 +453,7 @@
defn
</div>
<p class="sig">
(λ [&amp;String] Bool)
(λ [(Ref String a)] Bool)
</p>
<pre class="args">
(empty? s)
@ -473,7 +473,7 @@
defn
</div>
<p class="sig">
(λ [&amp;String, &amp;String] Bool)
(λ [(Ref String a), (Ref String b)] Bool)
</p>
<pre class="args">
(ends-with? s sub)
@ -493,7 +493,7 @@
external
</div>
<p class="sig">
(λ [&amp;String, &amp;String] String)
(λ [(Ref String a), (Ref String b)] String)
</p>
<span>
@ -512,7 +512,7 @@
external
</div>
<p class="sig">
(λ [(Ref (Array Char))] String)
(λ [(Ref (Array Char) a)] String)
</p>
<span>
@ -550,7 +550,7 @@
defn
</div>
<p class="sig">
(λ [&amp;String] Int)
(λ [(Ref String a)] Int)
</p>
<pre class="args">
(hash k)
@ -569,7 +569,7 @@
defn
</div>
<p class="sig">
(λ [&amp;String] Char)
(λ [(Ref String a)] Char)
</p>
<pre class="args">
(head s)
@ -589,7 +589,7 @@
defn
</div>
<p class="sig">
(λ [&amp;String] Bool)
(λ [(Ref String a)] Bool)
</p>
<pre class="args">
(hex? s)
@ -609,7 +609,7 @@
defn
</div>
<p class="sig">
(λ [&amp;String, &amp;String] Bool)
(λ [(Ref String a), (Ref String b)] Bool)
</p>
<pre class="args">
(in? s sub)
@ -629,7 +629,7 @@
external
</div>
<p class="sig">
(λ [&amp;String, Char] Int)
(λ [(Ref String a), Char] Int)
</p>
<span>
@ -648,7 +648,7 @@
external
</div>
<p class="sig">
(λ [&amp;String, Char, Int] Int)
(λ [(Ref String a), Char, Int] Int)
</p>
<span>
@ -667,7 +667,7 @@
defn
</div>
<p class="sig">
(λ [&amp;String, (Ref (Array String))] String)
(λ [(Ref String a), (Ref (Array String) b)] String)
</p>
<pre class="args">
(join sep strings)
@ -687,7 +687,7 @@
defn
</div>
<p class="sig">
(λ [Char, (Ref (Array String))] String)
(λ [Char, (Ref (Array String) a)] String)
</p>
<pre class="args">
(join-with-char sep strings)
@ -707,7 +707,7 @@
external
</div>
<p class="sig">
(λ [&amp;String] Int)
(λ [(Ref String a)] Int)
</p>
<span>
@ -726,7 +726,7 @@
defn
</div>
<p class="sig">
(λ [&amp;String] (Array String))
(λ [(Ref String a)] (Array String))
</p>
<pre class="args">
(lines s)
@ -746,7 +746,7 @@
defn
</div>
<p class="sig">
(λ [&amp;String] Bool)
(λ [(Ref String a)] Bool)
</p>
<pre class="args">
(lower? s)
@ -766,7 +766,7 @@
defn
</div>
<p class="sig">
(λ [&amp;String] Bool)
(λ [(Ref String a)] Bool)
</p>
<pre class="args">
(num? s)
@ -786,7 +786,7 @@
defn
</div>
<p class="sig">
(λ [Int, Char, &amp;String] String)
(λ [Int, Char, (Ref String a)] String)
</p>
<pre class="args">
(pad-left len pad s)
@ -806,7 +806,7 @@
defn
</div>
<p class="sig">
(λ [Int, Char, &amp;String] String)
(λ [Int, Char, (Ref String a)] String)
</p>
<pre class="args">
(pad-right len pad s)
@ -826,7 +826,7 @@
defn
</div>
<p class="sig">
(λ [&amp;String, Int] String)
(λ [(Ref String a), Int] String)
</p>
<pre class="args">
(prefix-string s a)
@ -846,7 +846,7 @@
external
</div>
<p class="sig">
(λ [&amp;String] String)
(λ [(Ref String a)] String)
</p>
<span>
@ -884,7 +884,7 @@
defn
</div>
<p class="sig">
(λ [Int, &amp;String] String)
(λ [Int, (Ref String a)] String)
</p>
<pre class="args">
(repeat n inpt)
@ -904,7 +904,7 @@
defn
</div>
<p class="sig">
(λ [&amp;String] String)
(λ [(Ref String a)] String)
</p>
<pre class="args">
(reverse s)
@ -924,7 +924,7 @@
defn
</div>
<p class="sig">
(λ [&amp;String, (Ref (Array Char))] (Array String))
(λ [(Ref String a), (Ref (Array Char) b)] (Array String))
</p>
<pre class="args">
(split-by s separators)
@ -944,7 +944,7 @@
defn
</div>
<p class="sig">
(λ [&amp;String, &amp;String] Bool)
(λ [(Ref String a), (Ref String b)] Bool)
</p>
<pre class="args">
(starts-with? s sub)
@ -964,7 +964,7 @@
external
</div>
<p class="sig">
(λ [&amp;String] String)
(λ [(Ref String a)] String)
</p>
<span>
@ -983,7 +983,7 @@
external
</div>
<p class="sig">
(λ [&amp;String, Int, Char] ())
(λ [(Ref String a), Int, Char] ())
</p>
<span>
@ -1002,7 +1002,7 @@
external
</div>
<p class="sig">
(λ [&amp;String, Int, &amp;String] ())
(λ [(Ref String a), Int, (Ref String b)] ())
</p>
<span>
@ -1021,7 +1021,7 @@
defn
</div>
<p class="sig">
(λ [&amp;String, Int, Int] String)
(λ [(Ref String a), Int, Int] String)
</p>
<pre class="args">
(substring s a b)
@ -1040,7 +1040,7 @@
defn
</div>
<p class="sig">
(λ [&amp;String, Int] String)
(λ [(Ref String a), Int] String)
</p>
<pre class="args">
(suffix-string s b)
@ -1060,7 +1060,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Array String))] Int)
(λ [(Ref (Array String) a)] Int)
</p>
<pre class="args">
(sum-length strings)
@ -1080,7 +1080,7 @@
external
</div>
<p class="sig">
(λ [&amp;String] String)
(λ [(Ref String a)] String)
</p>
<span>
@ -1099,7 +1099,7 @@
defn
</div>
<p class="sig">
(λ [&amp;String] String)
(λ [(Ref String a)] String)
</p>
<pre class="args">
(trim s)
@ -1119,7 +1119,7 @@
defn
</div>
<p class="sig">
(λ [&amp;String] String)
(λ [(Ref String a)] String)
</p>
<pre class="args">
(trim-left s)
@ -1139,7 +1139,7 @@
defn
</div>
<p class="sig">
(λ [&amp;String] String)
(λ [(Ref String a)] String)
</p>
<pre class="args">
(trim-right s)
@ -1159,7 +1159,7 @@
defn
</div>
<p class="sig">
(λ [&amp;String] Bool)
(λ [(Ref String a)] Bool)
</p>
<pre class="args">
(upper? s)
@ -1179,7 +1179,7 @@
defn
</div>
<p class="sig">
(λ [&amp;String] (Array String))
(λ [(Ref String a)] (Array String))
</p>
<pre class="args">
(words s)

6
docs/core/System.html
View File

@ -561,7 +561,7 @@
external
</div>
<p class="sig">
(λ [t] ())
(λ [a] ())
</p>
<span>
@ -581,7 +581,7 @@
external
</div>
<p class="sig">
(λ [Int] &amp;String)
(λ [Int] (Ref String a))
</p>
<span>
@ -832,7 +832,7 @@
external
</div>
<p class="sig">
(λ [&amp;String] ())
(λ [(Ref String a)] ())
</p>
<span>

16
docs/core/Test.html
View File

@ -180,7 +180,7 @@
defn
</div>
<p class="sig">
(λ [(Ref State), a, a, &amp;b] State)
(λ [(Ref State a), b, b, (Ref c d)] State)
</p>
<pre class="args">
(assert-equal state x y descr)
@ -200,7 +200,7 @@
defn
</div>
<p class="sig">
(λ [(Ref State), Int, (λ [] ()), &amp;a] State)
(λ [(Ref State a), Int, (λ [] () b), (Ref c d)] State)
</p>
<pre class="args">
(assert-exit state exit-code f descr)
@ -220,7 +220,7 @@
defn
</div>
<p class="sig">
(λ [(Ref State), Bool, &amp;a] State)
(λ [(Ref State a), Bool, (Ref b c)] State)
</p>
<pre class="args">
(assert-false state x descr)
@ -240,7 +240,7 @@
defn
</div>
<p class="sig">
(λ [(Ref State), a, a, &amp;b] State)
(λ [(Ref State a), b, b, (Ref c d)] State)
</p>
<pre class="args">
(assert-not-equal state x y descr)
@ -260,7 +260,7 @@
defn
</div>
<p class="sig">
(λ [(Ref State), a, b, &amp;c, (λ [a, b] Bool)] State)
(λ [(Ref State a), b, c, (Ref d e), (λ [b, c] Bool f)] State)
</p>
<pre class="args">
(assert-op state x y descr op)
@ -280,7 +280,7 @@
defn
</div>
<p class="sig">
(λ [(Ref State), Int, (λ [] ()), &amp;a] State)
(λ [(Ref State a), Int, (λ [] () b), (Ref c d)] State)
</p>
<pre class="args">
(assert-signal state signal x descr)
@ -299,7 +299,7 @@
defn
</div>
<p class="sig">
(λ [(Ref State), Bool, &amp;a] State)
(λ [(Ref State a), Bool, (Ref b c)] State)
</p>
<pre class="args">
(assert-true state x descr)
@ -319,7 +319,7 @@
defn
</div>
<p class="sig">
(λ [(Ref State)] ())
(λ [(Ref State a)] ())
</p>
<pre class="args">
(print-test-results state)

70
docs/core/Vector2.html
View File

@ -161,7 +161,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector2 a)), (Ref (Vector2 a))] Bool)
(λ [(Ref (Vector2 a) b), (Ref (Vector2 a) c)] Bool)
</p>
<pre class="args">
(= a b)
@ -180,7 +180,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector2 a)), (Ref (Vector2 a))] (Vector2 a))
(λ [(Ref (Vector2 a) b), (Ref (Vector2 a) c)] (Vector2 a))
</p>
<pre class="args">
(add a b)
@ -199,7 +199,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector2 a)), (Ref (Vector2 a))] a)
(λ [(Ref (Vector2 a) b), (Ref (Vector2 a) c)] a)
</p>
<pre class="args">
(angle-between a b)
@ -219,7 +219,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector2 a)), (Ref (Vector2 a))] Bool)
(λ [(Ref (Vector2 a) b), (Ref (Vector2 a) c)] Bool)
</p>
<pre class="args">
(anti-parallel? a b)
@ -239,7 +239,7 @@
template
</div>
<p class="sig">
(λ [(Ref (Vector2 f))] (Vector2 f))
(λ [(Ref (Vector2 a) b)] (Vector2 a))
</p>
<span>
@ -259,7 +259,7 @@
template
</div>
<p class="sig">
(λ [(Vector2 f)] ())
(λ [(Vector2 a)] ())
</p>
<span>
@ -279,7 +279,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector2 a)), (Ref (Vector2 a))] a)
(λ [(Ref (Vector2 a) b), (Ref (Vector2 a) c)] a)
</p>
<pre class="args">
(dist a b)
@ -299,7 +299,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector2 a)), a] (Vector2 a))
(λ [(Ref (Vector2 a) b), a] (Vector2 a))
</p>
<pre class="args">
(div a n)
@ -318,7 +318,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector2 a)), (Ref (Vector2 a))] a)
(λ [(Ref (Vector2 a) b), (Ref (Vector2 a) c)] a)
</p>
<pre class="args">
(dot a b)
@ -338,7 +338,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector2 a))] a)
(λ [(Ref (Vector2 a) b)] a)
</p>
<pre class="args">
(heading a)
@ -358,7 +358,7 @@
template
</div>
<p class="sig">
(λ [f, f] (Vector2 f))
(λ [a, a] (Vector2 a))
</p>
<span>
@ -378,7 +378,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector2 a))] a)
(λ [(Ref (Vector2 a) b)] a)
</p>
<pre class="args">
(mag o)
@ -398,7 +398,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector2 a))] a)
(λ [(Ref (Vector2 a) b)] a)
</p>
<pre class="args">
(mag-sq o)
@ -418,7 +418,7 @@
defn
</div>
<p class="sig">
(λ [(λ [a] b), (Ref (Vector2 a))] (Vector2 b))
(λ [(λ [a] b c), (Ref (Vector2 a) d)] (Vector2 b))
</p>
<pre class="args">
(map f v)
@ -437,7 +437,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector2 a)), a] (Vector2 a))
(λ [(Ref (Vector2 a) b), a] (Vector2 a))
</p>
<pre class="args">
(mul a n)
@ -456,7 +456,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector2 a))] (Vector2 a))
(λ [(Ref (Vector2 a) b)] (Vector2 a))
</p>
<pre class="args">
(normalize o)
@ -476,7 +476,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector2 a)), (Ref (Vector2 a))] Bool)
(λ [(Ref (Vector2 a) b), (Ref (Vector2 a) c)] Bool)
</p>
<pre class="args">
(parallel? a b)
@ -496,7 +496,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector2 a)), (Ref (Vector2 a))] Bool)
(λ [(Ref (Vector2 a) b), (Ref (Vector2 a) c)] Bool)
</p>
<pre class="args">
(perpendicular? a b)
@ -516,7 +516,7 @@
template
</div>
<p class="sig">
(λ [(Ref (Vector2 f))] String)
(λ [(Ref (Vector2 a) b)] String)
</p>
<span>
@ -555,7 +555,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector2 a)), a] (Vector2 a))
(λ [(Ref (Vector2 a) b), a] (Vector2 a))
</p>
<pre class="args">
(rotate a n)
@ -575,7 +575,7 @@
template
</div>
<p class="sig">
(λ [(Vector2 f), f] (Vector2 f))
(λ [(Vector2 a), a] (Vector2 a))
</p>
<span>
@ -595,7 +595,7 @@
instantiate
</div>
<p class="sig">
(λ [(Ref (Vector2 f)), f] ())
(λ [(Ref (Vector2 a) b), a] ())
</p>
<span>
@ -615,7 +615,7 @@
template
</div>
<p class="sig">
(λ [(Vector2 f), f] (Vector2 f))
(λ [(Vector2 a), a] (Vector2 a))
</p>
<span>
@ -635,7 +635,7 @@
instantiate
</div>
<p class="sig">
(λ [(Ref (Vector2 f)), f] ())
(λ [(Ref (Vector2 a) b), a] ())
</p>
<span>
@ -655,7 +655,7 @@
template
</div>
<p class="sig">
(λ [(Ref (Vector2 f))] String)
(λ [(Ref (Vector2 a) b)] String)
</p>
<span>
@ -675,7 +675,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector2 a)), (Ref (Vector2 a))] (Vector2 a))
(λ [(Ref (Vector2 a) b), (Ref (Vector2 a) c)] (Vector2 a))
</p>
<pre class="args">
(sub a b)
@ -694,7 +694,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector2 a))] a)
(λ [(Ref (Vector2 a) b)] a)
</p>
<pre class="args">
(sum o)
@ -713,7 +713,7 @@
instantiate
</div>
<p class="sig">
(λ [(Vector2 f), (Ref (λ [f] f))] (Vector2 f))
(λ [(Vector2 a), (Ref (λ [a] a b) c)] (Vector2 a))
</p>
<span>
@ -733,7 +733,7 @@
instantiate
</div>
<p class="sig">
(λ [(Vector2 f), (Ref (λ [f] f))] (Vector2 f))
(λ [(Vector2 a), (Ref (λ [a] a b) c)] (Vector2 a))
</p>
<span>
@ -753,7 +753,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector2 a)), (Ref (Vector2 a))] Bool)
(λ [(Ref (Vector2 a) b), (Ref (Vector2 a) c)] Bool)
</p>
<pre class="args">
(vapprox a b)
@ -773,7 +773,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector2 a)), (Ref (Vector2 a)), a] (Vector2 a))
(λ [(Ref (Vector2 a) b), (Ref (Vector2 a) c), a] (Vector2 a))
</p>
<pre class="args">
(vlerp a b amnt)
@ -793,7 +793,7 @@
defn
</div>
<p class="sig">
(λ [(λ [a, b] a), a, (Ref (Vector2 b))] a)
(λ [(λ [a, b] a c), a, (Ref (Vector2 b) d)] a)
</p>
<pre class="args">
(vreduce f i v)
@ -812,7 +812,7 @@
instantiate
</div>
<p class="sig">
(λ [(Ref (Vector2 f))] &amp;f)
(λ [(Ref (Vector2 a) b)] (Ref a b))
</p>
<span>
@ -832,7 +832,7 @@
instantiate
</div>
<p class="sig">
(λ [(Ref (Vector2 f))] &amp;f)
(λ [(Ref (Vector2 a) b)] (Ref a b))
</p>
<span>
@ -871,7 +871,7 @@
defn
</div>
<p class="sig">
(λ [(λ [a, b] c), (Ref (Vector2 a)), (Ref (Vector2 b))] (Vector2 c))
(λ [(λ [a, b] c d), (Ref (Vector2 a) e), (Ref (Vector2 b) f)] (Vector2 c))
</p>
<pre class="args">
(zip f a b)

80
docs/core/Vector3.html
View File

@ -161,7 +161,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector3 a)), (Ref (Vector3 a))] Bool)
(λ [(Ref (Vector3 a) b), (Ref (Vector3 a) c)] Bool)
</p>
<pre class="args">
(= a b)
@ -180,7 +180,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector3 a)), (Ref (Vector3 a))] (Vector3 a))
(λ [(Ref (Vector3 a) b), (Ref (Vector3 a) c)] (Vector3 a))
</p>
<pre class="args">
(add a b)
@ -199,7 +199,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector3 a)), (Ref (Vector3 a))] a)
(λ [(Ref (Vector3 a) b), (Ref (Vector3 a) c)] a)
</p>
<pre class="args">
(angle-between a b)
@ -219,7 +219,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector3 a)), (Ref (Vector3 a))] Bool)
(λ [(Ref (Vector3 a) b), (Ref (Vector3 a) c)] Bool)
</p>
<pre class="args">
(anti-parallel? a b)
@ -239,7 +239,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector3 a)), (Ref (Vector3 a))] (Vector3 a))
(λ [(Ref (Vector3 a) b), (Ref (Vector3 a) c)] (Vector3 a))
</p>
<pre class="args">
(cmul a b)
@ -258,7 +258,7 @@
template
</div>
<p class="sig">
(λ [(Ref (Vector3 f))] (Vector3 f))
(λ [(Ref (Vector3 a) b)] (Vector3 a))
</p>
<span>
@ -278,7 +278,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector3 a)), (Ref (Vector3 a))] (Vector3 a))
(λ [(Ref (Vector3 a) b), (Ref (Vector3 a) c)] (Vector3 a))
</p>
<pre class="args">
(cross a b)
@ -298,7 +298,7 @@
template
</div>
<p class="sig">
(λ [(Vector3 f)] ())
(λ [(Vector3 a)] ())
</p>
<span>
@ -318,7 +318,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector3 a)), (Ref (Vector3 a))] a)
(λ [(Ref (Vector3 a) b), (Ref (Vector3 a) c)] a)
</p>
<pre class="args">
(dist a b)
@ -338,7 +338,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector3 a)), a] (Vector3 a))
(λ [(Ref (Vector3 a) b), a] (Vector3 a))
</p>
<pre class="args">
(div v n)
@ -357,7 +357,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector3 a)), (Ref (Vector3 a))] a)
(λ [(Ref (Vector3 a) b), (Ref (Vector3 a) c)] a)
</p>
<pre class="args">
(dot a b)
@ -377,7 +377,7 @@
template
</div>
<p class="sig">
(λ [f, f, f] (Vector3 f))
(λ [a, a, a] (Vector3 a))
</p>
<span>
@ -397,7 +397,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector3 a))] a)
(λ [(Ref (Vector3 a) b)] a)
</p>
<pre class="args">
(mag o)
@ -417,7 +417,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector3 a))] a)
(λ [(Ref (Vector3 a) b)] a)
</p>
<pre class="args">
(mag-sq o)
@ -437,7 +437,7 @@
defn
</div>
<p class="sig">
(λ [(λ [a] b), (Ref (Vector3 a))] (Vector3 b))
(λ [(λ [a] b c), (Ref (Vector3 a) d)] (Vector3 b))
</p>
<pre class="args">
(map f v)
@ -456,7 +456,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector3 a)), a] (Vector3 a))
(λ [(Ref (Vector3 a) b), a] (Vector3 a))
</p>
<pre class="args">
(mul v n)
@ -475,7 +475,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector3 a))] (Vector3 a))
(λ [(Ref (Vector3 a) b)] (Vector3 a))
</p>
<pre class="args">
(neg a)
@ -494,7 +494,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector3 a))] (Vector3 a))
(λ [(Ref (Vector3 a) b)] (Vector3 a))
</p>
<pre class="args">
(normalize o)
@ -514,7 +514,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector3 a)), (Ref (Vector3 a))] Bool)
(λ [(Ref (Vector3 a) b), (Ref (Vector3 a) c)] Bool)
</p>
<pre class="args">
(parallel? a b)
@ -534,7 +534,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector3 a)), (Ref (Vector3 a))] Bool)
(λ [(Ref (Vector3 a) b), (Ref (Vector3 a) c)] Bool)
</p>
<pre class="args">
(perpendicular? a b)
@ -554,7 +554,7 @@
template
</div>
<p class="sig">
(λ [(Ref (Vector3 f))] String)
(λ [(Ref (Vector3 a) b)] String)
</p>
<span>
@ -593,7 +593,7 @@
template
</div>
<p class="sig">
(λ [(Vector3 f), f] (Vector3 f))
(λ [(Vector3 a), a] (Vector3 a))
</p>
<span>
@ -613,7 +613,7 @@
instantiate
</div>
<p class="sig">
(λ [(Ref (Vector3 f)), f] ())
(λ [(Ref (Vector3 a) b), a] ())
</p>
<span>
@ -633,7 +633,7 @@
template
</div>
<p class="sig">
(λ [(Vector3 f), f] (Vector3 f))
(λ [(Vector3 a), a] (Vector3 a))
</p>
<span>
@ -653,7 +653,7 @@
instantiate
</div>
<p class="sig">
(λ [(Ref (Vector3 f)), f] ())
(λ [(Ref (Vector3 a) b), a] ())
</p>
<span>
@ -673,7 +673,7 @@
template
</div>
<p class="sig">
(λ [(Vector3 f), f] (Vector3 f))
(λ [(Vector3 a), a] (Vector3 a))
</p>
<span>
@ -693,7 +693,7 @@
instantiate
</div>
<p class="sig">
(λ [(Ref (Vector3 f)), f] ())
(λ [(Ref (Vector3 a) b), a] ())
</p>
<span>
@ -713,7 +713,7 @@
template
</div>
<p class="sig">
(λ [(Ref (Vector3 f))] String)
(λ [(Ref (Vector3 a) b)] String)
</p>
<span>
@ -733,7 +733,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector3 a)), (Ref (Vector3 a))] (Vector3 a))
(λ [(Ref (Vector3 a) b), (Ref (Vector3 a) c)] (Vector3 a))
</p>
<pre class="args">
(sub a b)
@ -752,7 +752,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector3 a))] a)
(λ [(Ref (Vector3 a) b)] a)
</p>
<pre class="args">
(sum o)
@ -771,7 +771,7 @@
instantiate
</div>
<p class="sig">
(λ [(Vector3 f), (Ref (λ [f] f))] (Vector3 f))
(λ [(Vector3 a), (Ref (λ [a] a b) c)] (Vector3 a))
</p>
<span>
@ -791,7 +791,7 @@
instantiate
</div>
<p class="sig">
(λ [(Vector3 f), (Ref (λ [f] f))] (Vector3 f))
(λ [(Vector3 a), (Ref (λ [a] a b) c)] (Vector3 a))
</p>
<span>
@ -811,7 +811,7 @@
instantiate
</div>
<p class="sig">
(λ [(Vector3 f), (Ref (λ [f] f))] (Vector3 f))
(λ [(Vector3 a), (Ref (λ [a] a b) c)] (Vector3 a))
</p>
<span>
@ -831,7 +831,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector3 a)), (Ref (Vector3 a))] Bool)
(λ [(Ref (Vector3 a) b), (Ref (Vector3 a) c)] Bool)
</p>
<pre class="args">
(vapprox a b)
@ -851,7 +851,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (Vector3 a)), (Ref (Vector3 a)), a] (Vector3 a))
(λ [(Ref (Vector3 a) b), (Ref (Vector3 a) c), a] (Vector3 a))
</p>
<pre class="args">
(vlerp a b amnt)
@ -871,7 +871,7 @@
defn
</div>
<p class="sig">
(λ [(λ [a, b] a), a, (Ref (Vector3 b))] a)
(λ [(λ [a, b] a c), a, (Ref (Vector3 b) d)] a)
</p>
<pre class="args">
(vreduce f i v)
@ -890,7 +890,7 @@
instantiate
</div>
<p class="sig">
(λ [(Ref (Vector3 f))] &amp;f)
(λ [(Ref (Vector3 a) b)] (Ref a b))
</p>
<span>
@ -910,7 +910,7 @@
instantiate
</div>
<p class="sig">
(λ [(Ref (Vector3 f))] &amp;f)
(λ [(Ref (Vector3 a) b)] (Ref a b))
</p>
<span>
@ -930,7 +930,7 @@
instantiate
</div>
<p class="sig">
(λ [(Ref (Vector3 f))] &amp;f)
(λ [(Ref (Vector3 a) b)] (Ref a b))
</p>
<span>
@ -969,7 +969,7 @@
defn
</div>
<p class="sig">
(λ [(λ [a, b] c), (Ref (Vector3 a)), (Ref (Vector3 b))] (Vector3 c))
(λ [(λ [a, b] c d), (Ref (Vector3 a) e), (Ref (Vector3 b) f)] (Vector3 c))
</p>
<pre class="args">
(zip f a b)

60
docs/core/VectorN.html
View File

@ -161,7 +161,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (VectorN a)), (Ref (VectorN a))] Bool)
(λ [(Ref (VectorN a) b), (Ref (VectorN a) b)] Bool)
</p>
<pre class="args">
(= a b)
@ -180,7 +180,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (VectorN a)), (Ref (VectorN a))] (Maybe (VectorN a)))
(λ [(Ref (VectorN a) b), (Ref (VectorN a) c)] (Maybe (VectorN a)))
</p>
<pre class="args">
(add a b)
@ -199,7 +199,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (VectorN a)), (Ref (VectorN a))] (Maybe a))
(λ [(Ref (VectorN a) b), (Ref (VectorN a) b)] (Maybe a))
</p>
<pre class="args">
(angle-between a b)
@ -219,7 +219,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (VectorN a)), (Ref (VectorN a))] (Maybe Bool))
(λ [(Ref (VectorN a) b), (Ref (VectorN a) b)] (Maybe Bool))
</p>
<pre class="args">
(anti-parallel? a b)
@ -239,7 +239,7 @@
template
</div>
<p class="sig">
(λ [(Ref (VectorN f))] (VectorN f))
(λ [(Ref (VectorN a) b)] (VectorN a))
</p>
<span>
@ -259,7 +259,7 @@
template
</div>
<p class="sig">
(λ [(VectorN f)] ())
(λ [(VectorN a)] ())
</p>
<span>
@ -279,7 +279,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (VectorN a)), (Ref (VectorN a))] (Maybe a))
(λ [(Ref (VectorN a) b), (Ref (VectorN a) c)] (Maybe a))
</p>
<pre class="args">
(dist a b)
@ -299,7 +299,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (VectorN a)), a] (VectorN a))
(λ [(Ref (VectorN a) b), a] (VectorN a))
</p>
<pre class="args">
(div a n)
@ -318,7 +318,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (VectorN a)), (Ref (VectorN a))] (Maybe a))
(λ [(Ref (VectorN a) b), (Ref (VectorN a) c)] (Maybe a))
</p>
<pre class="args">
(dot x y)
@ -338,7 +338,7 @@
template
</div>
<p class="sig">
(λ [Int, (Array f)] (VectorN f))
(λ [Int, (Array a)] (VectorN a))
</p>
<span>
@ -358,7 +358,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (VectorN a))] a)
(λ [(Ref (VectorN a) b)] a)
</p>
<pre class="args">
(mag o)
@ -378,7 +378,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (VectorN a))] a)
(λ [(Ref (VectorN a) b)] a)
</p>
<pre class="args">
(mag-sq o)
@ -398,7 +398,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (VectorN a)), a] (VectorN a))
(λ [(Ref (VectorN a) b), a] (VectorN a))
</p>
<pre class="args">
(mul a n)
@ -417,7 +417,7 @@
instantiate
</div>
<p class="sig">
(λ [(Ref (VectorN f))] &amp;Int)
(λ [(Ref (VectorN a) b)] (Ref Int b))
</p>
<span>
@ -437,7 +437,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (VectorN a))] (VectorN a))
(λ [(Ref (VectorN a) b)] (VectorN a))
</p>
<pre class="args">
(normalize o)
@ -457,7 +457,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (VectorN a)), (Ref (VectorN a))] (Maybe Bool))
(λ [(Ref (VectorN a) b), (Ref (VectorN a) b)] (Maybe Bool))
</p>
<pre class="args">
(parallel? a b)
@ -477,7 +477,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (VectorN a)), (Ref (VectorN a))] (Maybe Bool))
(λ [(Ref (VectorN a) b), (Ref (VectorN a) b)] (Maybe Bool))
</p>
<pre class="args">
(perpendicular? a b)
@ -497,7 +497,7 @@
template
</div>
<p class="sig">
(λ [(Ref (VectorN f))] String)
(λ [(Ref (VectorN a) b)] String)
</p>
<span>
@ -536,7 +536,7 @@
instantiate
</div>
<p class="sig">
(λ [(VectorN f), Int] (VectorN f))
(λ [(VectorN a), Int] (VectorN a))
</p>
<span>
@ -556,7 +556,7 @@
instantiate
</div>
<p class="sig">
(λ [(Ref (VectorN f)), Int] ())
(λ [(Ref (VectorN a) b), Int] ())
</p>
<span>
@ -576,7 +576,7 @@
template
</div>
<p class="sig">
(λ [(VectorN f), (Array f)] (VectorN f))
(λ [(VectorN a), (Array a)] (VectorN a))
</p>
<span>
@ -596,7 +596,7 @@
instantiate
</div>
<p class="sig">
(λ [(Ref (VectorN f)), (Array f)] ())
(λ [(Ref (VectorN a) b), (Array a)] ())
</p>
<span>
@ -616,7 +616,7 @@
template
</div>
<p class="sig">
(λ [(Ref (VectorN f))] String)
(λ [(Ref (VectorN a) b)] String)
</p>
<span>
@ -636,7 +636,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (VectorN a)), (Ref (VectorN a))] (Maybe (VectorN a)))
(λ [(Ref (VectorN a) b), (Ref (VectorN a) c)] (Maybe (VectorN a)))
</p>
<pre class="args">
(sub a b)
@ -655,7 +655,7 @@
instantiate
</div>
<p class="sig">
(λ [(VectorN f), (Ref (λ [Int] Int))] (VectorN f))
(λ [(VectorN a), (Ref (λ [Int] Int b) c)] (VectorN a))
</p>
<span>
@ -675,7 +675,7 @@
instantiate
</div>
<p class="sig">
(λ [(VectorN f), (Ref (λ [(Array f)] (Array f)))] (VectorN f))
(λ [(VectorN a), (Ref (λ [(Array a)] (Array a) b) c)] (VectorN a))
</p>
<span>
@ -695,7 +695,7 @@
instantiate
</div>
<p class="sig">
(λ [(Ref (VectorN f))] (Ref (Array f)))
(λ [(Ref (VectorN a) b)] (Ref (Array a) b))
</p>
<span>
@ -715,7 +715,7 @@
defn
</div>
<p class="sig">
(λ [(Ref (VectorN a)), (Ref (VectorN a)), a] (Maybe (VectorN a)))
(λ [(Ref (VectorN a) b), (Ref (VectorN a) c), a] (Maybe (VectorN a)))
</p>
<pre class="args">
(vlerp a b amnt)
@ -754,7 +754,7 @@
defn
</div>
<p class="sig">
(λ [(λ [a, b] c), (Ref (VectorN a)), (Ref (VectorN b))] (Maybe (VectorN c)))
(λ [(λ [a, b] c d), (Ref (VectorN a) e), (Ref (VectorN b) f)] (Maybe (VectorN c)))
</p>
<pre class="args">
(zip f a b)
@ -773,7 +773,7 @@
defn
</div>
<p class="sig">
(λ [(λ [a, b] c), (Ref (Array a)), (Ref (Array b))] (VectorN c))
(λ [(λ [a, b] c d), (Ref (Array a) e), (Ref (Array b) f)] (VectorN c))
</p>
<pre class="args">
(zip- f a b)

6
docs/sdl/SDL.html
View File

@ -180,7 +180,7 @@
defn
</div>
<p class="sig">
(λ [(Ptr SDL_Renderer), (Ref SDL_Color)] ())
(λ [(Ptr SDL_Renderer), (Ref SDL_Color a)] ())
</p>
<pre class="args">
(bg rend color)
@ -427,7 +427,7 @@
defn
</div>
<p class="sig">
(λ [(Ptr SDL_Renderer), (Ptr SDL_Texture), (Ref SDL_Point)] ())
(λ [(Ptr SDL_Renderer), (Ptr SDL_Texture), (Ref SDL_Point a)] ())
</p>
<pre class="args">
(draw-texture rend texture point)
@ -446,7 +446,7 @@
defn
</div>
<p class="sig">
(λ [(Ptr SDL_Renderer), (Ptr SDL_Texture), (Ref SDL_Point)] ())
(λ [(Ptr SDL_Renderer), (Ptr SDL_Texture), (Ref SDL_Point a)] ())
</p>
<pre class="args">
(draw-texture-centered rend texture point)

32
docs/sdl/SDLApp.html
View File

@ -66,7 +66,7 @@
instantiate
</div>
<p class="sig">
(λ [(Ref SDLApp)] SDLApp)
(λ [(Ref SDLApp a)] SDLApp)
</p>
<span>
@ -86,7 +86,7 @@
defn
</div>
<p class="sig">
(λ [&amp;String, Int, Int] SDLApp)
(λ [(Ref String a), Int, Int] SDLApp)
</p>
<pre class="args">
(create title width height)
@ -126,7 +126,7 @@
instantiate
</div>
<p class="sig">
(λ [(Ref SDLApp)] &amp;Int)
(λ [(Ref SDLApp a)] (Ref Int a))
</p>
<span>
@ -166,7 +166,7 @@
instantiate
</div>
<p class="sig">
(λ [(Ref SDLApp)] String)
(λ [(Ref SDLApp a)] String)
</p>
<span>
@ -186,7 +186,7 @@
defn
</div>
<p class="sig">
(λ [(Ref SDLApp), a, (Ref SDL_Event)] a)
(λ [(Ref SDLApp a), b, (Ref SDL_Event c)] b)
</p>
<pre class="args">
(quit-on-esc app state event)
@ -206,7 +206,7 @@
instantiate
</div>
<p class="sig">
(λ [(Ref SDLApp)] (Ref (Ptr SDL_Renderer)))
(λ [(Ref SDLApp a)] (Ref (Ptr SDL_Renderer) a))
</p>
<span>
@ -226,7 +226,7 @@
defn
</div>
<p class="sig">
(λ [(Ref SDLApp), (λ [(Ref SDLApp), a, (Ref SDL_Event)] a), (λ [a] a), (λ [(Ref SDLApp), (Ptr SDL_Renderer), &amp;a] ()), a] ())
(λ [(Ref SDLApp a), (λ [(Ref SDLApp a), b, (Ref SDL_Event c)] b d), (λ [b] b e), (λ [(Ref SDLApp a), (Ptr SDL_Renderer), (Ref b f)] () e), b] ())
</p>
<pre class="args">
(run-with-callbacks app event-fn update-fn draw-fn initial-state)
@ -266,7 +266,7 @@
instantiate
</div>
<p class="sig">
(λ [(Ref SDLApp), Int] ())
(λ [(Ref SDLApp a), Int] ())
</p>
<span>
@ -306,7 +306,7 @@
instantiate
</div>
<p class="sig">
(λ [(Ref SDLApp), (Ptr SDL_Renderer)] ())
(λ [(Ref SDLApp a), (Ptr SDL_Renderer)] ())
</p>
<span>
@ -346,7 +346,7 @@
instantiate
</div>
<p class="sig">
(λ [(Ref SDLApp), (Ptr SDL_Window)] ())
(λ [(Ref SDLApp a), (Ptr SDL_Window)] ())
</p>
<span>
@ -366,7 +366,7 @@
defn
</div>
<p class="sig">
(λ [(Ref SDLApp)] a)
(λ [(Ref SDLApp a)] b)
</p>
<pre class="args">
(stop app)
@ -386,7 +386,7 @@
instantiate
</div>
<p class="sig">
(λ [(Ref SDLApp)] String)
(λ [(Ref SDLApp a)] String)
</p>
<span>
@ -406,7 +406,7 @@
instantiate
</div>
<p class="sig">
(λ [SDLApp, (Ref (λ [Int] Int))] SDLApp)
(λ [SDLApp, (Ref (λ [Int] Int a) b)] SDLApp)
</p>
<span>
@ -426,7 +426,7 @@
instantiate
</div>
<p class="sig">
(λ [SDLApp, (Ref (λ [(Ptr SDL_Renderer)] (Ptr SDL_Renderer)))] SDLApp)
(λ [SDLApp, (Ref (λ [(Ptr SDL_Renderer)] (Ptr SDL_Renderer) a) b)] SDLApp)
</p>
<span>
@ -446,7 +446,7 @@
instantiate
</div>
<p class="sig">
(λ [SDLApp, (Ref (λ [(Ptr SDL_Window)] (Ptr SDL_Window)))] SDLApp)
(λ [SDLApp, (Ref (λ [(Ptr SDL_Window)] (Ptr SDL_Window) a) b)] SDLApp)
</p>
<span>
@ -466,7 +466,7 @@
instantiate
</div>
<p class="sig">
(λ [(Ref SDLApp)] (Ref (Ptr SDL_Window)))
(λ [(Ref SDLApp a)] (Ref (Ptr SDL_Window) a))
</p>
<span>

2
docs/sdl/TTF.html
View File

@ -256,7 +256,7 @@
defn
</div>
<p class="sig">
(λ [(Ptr SDL_Renderer), (Ptr TTF_Font), &amp;String, SDL_Color] (Ptr SDL_Texture))
(λ [(Ptr SDL_Renderer), (Ptr TTF_Font), (Ref String a), SDL_Color] (Ptr SDL_Texture))
</p>
<pre class="args">
(render-text-to-texture rend font str color)

178
examples/lifetimes.carp Normal file
View File

@ -0,0 +1,178 @@
(Debug.sanitize-addresses)
(Project.config "print-ast" true)
;; Preventing the usage of a reference to a deleted object
;; (defn f []
;; (let-do [x @"DATA"
;; r &x]
;; (delete x)
;; (IO.println r)))
;; Same as above, but deleting the argument
;; (defn g [x]
;; (let-do [r &x]
;; (delete (the String x))
;; (IO.println r)))
;; A function accepting two refs and returning one of them
;; (defn two-refs [x a b]
;; (if x
;; (the (Ref t q) a)
;; (the (Ref t w) b)))
;; Lambdas
;; (defn l []
;; (let [x @"DATA"
;; r &x
;; f (fn [] (IO.println r))]
;; (do
;; (String.delete x)
;; (f))))
;; (defn from-ptr [a]
;; (if (null? a)
;; (Maybe.Nothing)
;; (Maybe.Just @(Pointer.to-ref a))))
;; (defn pair-eq [p1 p2]
;; (and (= (Pair.a p1) (Pair.a p2))
;; (= (Pair.b p1) (Pair.b p2)))
;; )
;; (defn map-put []
;; (fn [b]
;; (let [n &b]
;; ())))
;; (defn f [x y]
;; (let [s @"hej"
;; z 123]
;; (Int.+ x y)))
;; (defn f []
;; &100) ;; TODO: Number literals should create prim var deleter too!
;; use-ref-in-lambda-after-free
;; (defn boo []
;; (let-do [data @"DATA"
;; r &data
;; f (fn []
;; (IO.println (id r)))]
;; ;;(String.delete data)
;; (f)))
;; (defn foo []
;; (let-do [data [10 20 30]
;; r &data
;; f (fn [] (Array.nth r 1))]
;; ;;(Array.delete data)
;; (println* (f))))
;; (defn lam []
;; (let [stuff [100 200 300]
;; ;;r &stuff
;; f (fn []
;; (println* (id &stuff)))]
;; (f)))
;; Problematic order of arguments, the variable 'b' will depend on 'snake', which is consumed first in the call to Snake.set-body
;; (use Array)
;; (deftype Snake [body (Array Int)])
;; (defn grow [snake]
;; (let [b (Snake.body &snake)]
;; (Snake.set-body snake (push-back @b 0))))
;;(unsafe-last b)
;; (defn dangling-1 []
;; (let [b [1 2 3]]
;; &b))
;; (defn dangling-2 []
;; (let [b [1 2 3]
;; r &b]
;; r))
;; (defn unique []
;; (let [r1 (the &String "DATA")
;; r2 (the &String "DATA") ;; should get another lifetime variable than r1
;; r3 "DATA"]
;; ()))
;; (defn fool [s1 s2]
;; (let [r1 (the (Ref String Static) s1)
;; r2 (the (Ref String b) s2)]
;; (do
;; (if (= r1 r2) () ())
;; ;;(delete s1)
;; ;;(= r1 r2)
;; ;;()
;; r2)))
;; This should be detected as an error too:
;; (defn f [s]
;; (let [r &s]
;; r))
;;(f @"hej")
;; (defn magic []
;; (let [s @"DATA"]
;; &s)) ;; shouldn't work either
;; (defn simple-fool []
;; (let [r (magic) ;; 'magic' returns (Ref String a)
;; static (the (Ref String Static) "")]
;; (do
;; (if (= r static) () ()) ;; shouldn't just be possible to trick 'r' that its lifetime is Static
;; ())))
;; (defn first [xs]
;; (Array.nth xs 0))
;;(defn f [x] (fn [] (IO.println x)))
;; (defn g []
;; (let-do [s @"DATA"
;; r &s
;; f (fn [] (IO.println r))]
;; ;;(delete s)
;; ;;(f)
;; f))
;; (defn ok [r]
;; (let-do [f (fn [] (IO.println r))]
;; f))
(deftype Blah [x Int])
(defn trick []
(let[s1 (Blah.init 100)
r1 &s1
g (let [s2 (Blah.init 200)
r2 &s2
f (fn [] (println* r1 r2))]
f)]
(g) ;; shouldn't work because 's2' has been deleted and 'r2' is thus a dead reference
))

3
examples/reptile.carp
View File

@ -114,8 +114,9 @@
(defn update-after-kill [world]
(let [s (World.snake &world)
new-s (grow @s)
new-world (kill-human world)]
(World.set-snake new-world (grow @s))))
(World.set-snake new-world new-s)))
(defn check-for-kill [world]
(let [s (World.snake world)

114
src/ArrayTemplates.hs
View File

@ -17,13 +17,13 @@ import Lookup
-- | "Endofunctor Map"
templateEMap :: (String, Binder)
templateEMap =
let fTy = FuncTy [VarTy "a"] (VarTy "a")
let fTy = FuncTy [VarTy "a"] (VarTy "a") (VarTy "fq")
aTy = StructTy "Array" [VarTy "a"]
bTy = StructTy "Array" [VarTy "a"]
elem = "((($a*)a.data)[i])"
in defineTemplate
(SymPath ["Array"] "endo-map")
(FuncTy [RefTy fTy, aTy] bTy)
(FuncTy [RefTy fTy (VarTy "q"), aTy] bTy StaticLifetimeTy)
"applies a function `f` to an array `a`. The type of the elements cannot change."
(toTemplate "Array $NAME(Lambda *f, Array a)") -- Lambda used to be $(Fn [a] a)
(toTemplate $ unlines
@ -34,8 +34,8 @@ templateEMap =
," return a;"
,"}"
])
(\(FuncTy [RefTy t@(FuncTy fArgTys fRetTy), arrayType] _) ->
[defineFunctionTypeAlias t, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) fRetTy)])
(\(FuncTy [RefTy t@(FuncTy fArgTys fRetTy _) _, arrayType] _ _) ->
[defineFunctionTypeAlias t, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) fRetTy StaticLifetimeTy)])
templateShrinkCheck :: String -> String
templateShrinkCheck var =
@ -49,10 +49,10 @@ templateShrinkCheck var =
templateEFilter :: (String, Binder)
templateEFilter = defineTypeParameterizedTemplate templateCreator path t docs
where
fTy = FuncTy [RefTy (VarTy "a")] BoolTy
fTy = FuncTy [RefTy (VarTy "a") (VarTy "q")] BoolTy (VarTy "fq")
aTy = StructTy "Array" [VarTy "a"]
path = SymPath ["Array"] "endo-filter"
t = FuncTy [RefTy fTy, aTy] aTy
t = FuncTy [RefTy fTy (VarTy "w"), aTy] aTy StaticLifetimeTy
docs = "filters array members using a function. This function takes ownership."
elem = "&((($a*)a.data)[i])"
templateCreator = TemplateCreator $
@ -60,7 +60,7 @@ templateEFilter = defineTypeParameterizedTemplate templateCreator path t docs
Template
t
(const (toTemplate "Array $NAME(Lambda *predicate, Array a)")) -- Lambda used to be $(Fn [(Ref a)] Bool)
(\(FuncTy [RefTy (FuncTy [RefTy insideTy] BoolTy), _] _) ->
(\(FuncTy [RefTy (FuncTy [RefTy insideTy _] BoolTy _) _, _] _ _) ->
toTemplate $ unlines $
let deleter = insideArrayDeletion typeEnv env insideTy
in ["$DECL { "
@ -77,8 +77,8 @@ templateEFilter = defineTypeParameterizedTemplate templateCreator path t docs
, " return a;"
, "}"
])
(\(FuncTy [RefTy ft@(FuncTy fArgTys@[RefTy insideType] BoolTy), arrayType] _) ->
[defineFunctionTypeAlias ft, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) BoolTy)] ++
(\(FuncTy [RefTy ft@(FuncTy fArgTys@[RefTy insideType _] BoolTy _) _, arrayType] _ _) ->
[defineFunctionTypeAlias ft, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) BoolTy StaticLifetimeTy)] ++
depsForDeleteFunc typeEnv env insideType)
templatePushBack :: (String, Binder)
@ -87,7 +87,7 @@ templatePushBack =
valTy = VarTy "a"
in defineTemplate
(SymPath ["Array"] "push-back")
(FuncTy [aTy, valTy] aTy)
(FuncTy [aTy, valTy] aTy StaticLifetimeTy)
"adds an element `value` to the end of an array `a`."
(toTemplate "Array $NAME(Array a, $a value)")
(toTemplate $ unlines
@ -101,15 +101,15 @@ templatePushBack =
," return a;"
,"}"
])
(\(FuncTy [arrayType, _] _) -> [])
(\(FuncTy [arrayType, _] _ _) -> [])
templatePushBackBang :: (String, Binder)
templatePushBackBang =
let aTy = RefTy (StructTy "Array" [VarTy "a"])
let aTy = RefTy (StructTy "Array" [VarTy "a"]) (VarTy "q")
valTy = VarTy "a"
in defineTemplate
(SymPath ["Array"] "push-back!")
(FuncTy [aTy, valTy] UnitTy)
(FuncTy [aTy, valTy] UnitTy StaticLifetimeTy)
"adds an element `value` to the end of an array `a` in-place."
(toTemplate "void $NAME(Array *aRef, $a value)")
(toTemplate $ unlines
@ -122,20 +122,20 @@ templatePushBackBang =
," (($a*)aRef->data)[aRef->len - 1] = value;"
,"}"
])
(\(FuncTy [arrayType, _] _) -> [])
(\(FuncTy [arrayType, _] _ _) -> [])
templatePopBack :: (String, Binder)
templatePopBack = defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath ["Array"] "pop-back"
aTy = StructTy "Array" [VarTy "a"]
t = FuncTy [aTy] aTy
t = FuncTy [aTy] aTy StaticLifetimeTy
docs = "removes the last element of an array and returns the new array."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "Array $NAME(Array a)"))
(\(FuncTy [arrayType@(StructTy _ [insideTy])] _) ->
(\(FuncTy [arrayType@(StructTy _ [insideTy])] _ _) ->
let deleteElement = insideArrayDeletion typeEnv env insideTy
in toTemplate (unlines
["$DECL { "
@ -146,18 +146,18 @@ templatePopBack = defineTypeParameterizedTemplate templateCreator path t docs
," return a;"
,"}"
]))
(\(FuncTy [arrayType@(StructTy _ [insideTy])] _) ->
(\(FuncTy [arrayType@(StructTy _ [insideTy])] _ _) ->
depsForDeleteFunc typeEnv env arrayType ++
depsForCopyFunc typeEnv env insideTy
)
templatePopBackBang :: (String, Binder)
templatePopBackBang =
let aTy = RefTy (StructTy "Array" [VarTy "a"])
let aTy = RefTy (StructTy "Array" [VarTy "a"]) (VarTy "q")
valTy = VarTy "a"
in defineTemplate
(SymPath ["Array"] "pop-back!")
(FuncTy [aTy] (VarTy "a"))
(FuncTy [aTy] (VarTy "a") StaticLifetimeTy)
"removes an element `value` from the end of an array `a` in-place and returns it."
(toTemplate "$a $NAME(Array *aRef)")
(toTemplate $ unlines
@ -169,7 +169,7 @@ templatePopBackBang =
," return ret;"
,"}"
])
(\(FuncTy [arrayType] _) -> [])
(\(FuncTy [arrayType] _ _) -> [])
templateNth :: (String, Binder)
@ -177,7 +177,7 @@ templateNth =
let t = VarTy "t"
in defineTemplate
(SymPath ["Array"] "unsafe-nth")
(FuncTy [RefTy (StructTy "Array" [t]), IntTy] (RefTy t))
(FuncTy [RefTy (StructTy "Array" [t]) (VarTy "q"), IntTy] (RefTy t (VarTy "q")) StaticLifetimeTy)
"gets a reference to the `n`th element from an array `a`."
(toTemplate "$t* $NAME (Array *aRef, int n)")
(toTemplate $ unlines ["$DECL {"
@ -186,38 +186,38 @@ templateNth =
," assert(n < a.len);"
," return &((($t*)a.data)[n]);"
,"}"])
(\(FuncTy [RefTy arrayType, _] _) ->
(\(FuncTy [RefTy arrayType _, _] _ _) ->
[])
templateRaw :: (String, Binder)
templateRaw = defineTemplate
(SymPath ["Array"] "raw")
(FuncTy [StructTy "Array" [VarTy "t"]] (PointerTy (VarTy "t")))
(FuncTy [StructTy "Array" [VarTy "t"]] (PointerTy (VarTy "t")) StaticLifetimeTy)
"returns an array `a` as a raw pointer—useful for interacting with C."
(toTemplate "$t* $NAME (Array a)")
(toTemplate "$DECL { return a.data; }")
(\(FuncTy [arrayType] _) -> [])
(\(FuncTy [arrayType] _ _) -> [])
templateUnsafeRaw :: (String, Binder)
templateUnsafeRaw = defineTemplate
(SymPath ["Array"] "unsafe-raw")
(FuncTy [RefTy (StructTy "Array" [VarTy "t"])] (PointerTy (VarTy "t")))
(FuncTy [RefTy (VarTy "q") (StructTy "Array" [VarTy "t"])] (PointerTy (VarTy "t")) StaticLifetimeTy)
"returns an array `a` as a raw pointer—useful for interacting with C."
(toTemplate "$t* $NAME (Array* a)")
(toTemplate "$DECL { return a->data; }")
(\(FuncTy [RefTy arrayType] _) -> [])
(\(FuncTy [RefTy arrayType _] _ _) -> [])
templateAset :: (String, Binder)
templateAset = defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath ["Array"] "aset"
t = FuncTy [StructTy "Array" [VarTy "t"], IntTy, VarTy "t"] (StructTy "Array" [VarTy "t"])
t = FuncTy [StructTy "Array" [VarTy "t"], IntTy, VarTy "t"] (StructTy "Array" [VarTy "t"]) StaticLifetimeTy
docs = "sets an array element at the index `n` to a new value."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(\_ -> toTemplate "Array $NAME (Array a, int n, $t newValue)")
(\(FuncTy [_, _, insideTy] _) ->
(\(FuncTy [_, _, insideTy] _ _) ->
let deleter = insideArrayDeletion typeEnv env insideTy
in toTemplate $ unlines ["$DECL {"
," assert(n >= 0);"
@ -226,20 +226,20 @@ templateAset = defineTypeParameterizedTemplate templateCreator path t docs
," (($t*)a.data)[n] = newValue;"
," return a;"
,"}"])
(\(FuncTy [_, _, insideTy] _) ->
(\(FuncTy [_, _, insideTy] _ _) ->
depsForDeleteFunc typeEnv env insideTy)
templateAsetBang :: (String, Binder)
templateAsetBang = defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath ["Array"] "aset!"
t = FuncTy [RefTy (StructTy "Array" [VarTy "t"]), IntTy, VarTy "t"] UnitTy
t = FuncTy [RefTy (StructTy "Array" [VarTy "t"]) (VarTy "q"), IntTy, VarTy "t"] UnitTy StaticLifetimeTy
docs = "sets an array element at the index `n` to a new value in place."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "void $NAME (Array *aRef, int n, $t newValue)"))
(\(FuncTy [_, _, insideTy] _) ->
(\(FuncTy [_, _, insideTy] _ _) ->
let deleter = insideArrayDeletion typeEnv env insideTy
in (toTemplate $ unlines ["$DECL {"
," Array a = *aRef;"
@ -248,7 +248,7 @@ templateAsetBang = defineTypeParameterizedTemplate templateCreator path t docs
, deleter "n"
," (($t*)a.data)[n] = newValue;"
,"}"]))
(\(FuncTy [RefTy arrayType, _, _] _) ->
(\(FuncTy [RefTy arrayType _, _, _] _ _) ->
depsForDeleteFunc typeEnv env arrayType)
-- | This function can set uninitialized memory in an array (used together with 'allocate').
@ -256,7 +256,7 @@ templateAsetBang = defineTypeParameterizedTemplate templateCreator path t docs
templateAsetUninitializedBang :: (String, Binder)
templateAsetUninitializedBang = defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath ["Array"] "aset-uninitialized!"
t = FuncTy [RefTy (StructTy "Array" [VarTy "t"]), IntTy, VarTy "t"] UnitTy
t = FuncTy [RefTy (StructTy "Array" [VarTy "t"]) (VarTy "q"), IntTy, VarTy "t"] UnitTy StaticLifetimeTy
docs = "sets an uninitialized array member. The old member will not be deleted."
templateCreator = TemplateCreator $
\typeEnv env ->
@ -274,7 +274,7 @@ templateAsetUninitializedBang = defineTypeParameterizedTemplate templateCreator
templateLength :: (String, Binder)
templateLength = defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath ["Array"] "length"
t = FuncTy [RefTy (StructTy "Array" [VarTy "t"])] IntTy
t = FuncTy [RefTy (StructTy "Array" [VarTy "t"]) (VarTy "q")] IntTy StaticLifetimeTy
docs = "gets the length of the array."
templateCreator = TemplateCreator $
\typeEnv env ->
@ -282,20 +282,20 @@ templateLength = defineTypeParameterizedTemplate templateCreator path t docs
t
(const (toTemplate "int $NAME (Array *a)"))
(const (toTemplate "$DECL { return (*a).len; }"))
(\(FuncTy [RefTy arrayType] _) ->
(\(FuncTy [RefTy arrayType _] _ _) ->
depsForDeleteFunc typeEnv env arrayType)
templateAllocate :: (String, Binder)
templateAllocate = defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath ["Array"] "allocate"
t = FuncTy [IntTy] (StructTy "Array" [VarTy "t"])
t = FuncTy [IntTy] (StructTy "Array" [VarTy "t"]) StaticLifetimeTy
docs = "allocates an uninitialized array. You can initialize members using [`aset-uninitialized`](#aset-uninitialized)."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "Array $NAME (int n)"))
(\(FuncTy [_] arrayType) ->
(\(FuncTy [_] arrayType _) ->
toTemplate $ unlines (["$DECL {"
," Array a;"
," a.len = n;"
@ -304,24 +304,24 @@ templateAllocate = defineTypeParameterizedTemplate templateCreator path t docs
++ initTy arrayType ++
[" return a;"
,"}"]))
(\(FuncTy [_] arrayType) ->
(\(FuncTy [_] arrayType _) ->
depsForDeleteFunc typeEnv env arrayType)
templateDeleteArray :: (String, Binder)
templateDeleteArray = defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath ["Array"] "delete"
t = FuncTy [StructTy "Array" [VarTy "a"]] UnitTy
t = FuncTy [StructTy "Array" [VarTy "a"]] UnitTy StaticLifetimeTy
docs = "deletes an array. This function should usually not be called manually."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "void $NAME (Array a)"))
(\(FuncTy [arrayType] UnitTy) ->
(\(FuncTy [arrayType] UnitTy _) ->
[TokDecl, TokC "{\n"] ++
deleteTy typeEnv env arrayType ++
[TokC "}\n"])
(\(FuncTy [arrayType@(StructTy "Array" [insideType])] UnitTy) ->
(\(FuncTy [arrayType@(StructTy "Array" [insideType])] UnitTy _) ->
depsForDeleteFunc typeEnv env insideType)
deleteTy :: TypeEnv -> Env -> Ty -> [Token]
@ -334,7 +334,7 @@ deleteTy typeEnv env (StructTy "Array" [innerType]) =
deleteTy _ _ _ = []
initTy :: Ty -> [String]
initTy (StructTy "Array" [innerType@(FuncTy _ _)]) =
initTy (StructTy "Array" [innerType@(FuncTy _ _ _)]) =
[ " // initialize each Lambda struct "
, " for(int i = 0; i < a.len; i++) {"
, " " ++ insideArrayInitLambda innerType "i"
@ -361,14 +361,14 @@ insideArrayDeletion typeEnv env t indexer =
templateCopyArray :: (String, Binder)
templateCopyArray = defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath ["Array"] "copy"
t = FuncTy [RefTy (StructTy "Array" [VarTy "a"])] (StructTy "Array" [VarTy "a"])
t = FuncTy [RefTy (StructTy "Array" [VarTy "a"]) (VarTy "q")] (StructTy "Array" [VarTy "a"]) StaticLifetimeTy
docs = "copies an array."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "Array $NAME (Array* a)"))
(\(FuncTy [RefTy arrayType] _) ->
(\(FuncTy [RefTy arrayType _] _ _) ->
[TokDecl, TokC "{\n"] ++
[TokC " Array copy;\n"] ++
[TokC " copy.len = a->len;\n"] ++
@ -378,7 +378,7 @@ templateCopyArray = defineTypeParameterizedTemplate templateCreator path t docs
[TokC " return copy;\n"] ++
[TokC "}\n"])
(\case
(FuncTy [RefTy arrayType@(StructTy "Array" [insideType])] _) ->
(FuncTy [RefTy arrayType@(StructTy "Array" [insideType]) _] _ _) ->
depsForCopyFunc typeEnv env insideType ++
depsForDeleteFunc typeEnv env arrayType
err ->
@ -386,10 +386,20 @@ templateCopyArray = defineTypeParameterizedTemplate templateCreator path t docs
copyTy :: TypeEnv -> Env -> Ty -> [Token]
copyTy typeEnv env (StructTy "Array" [innerType]) =
[ TokC " for(int i = 0; i < a->len; i++) {\n"
, TokC $ " " ++ insideArrayCopying typeEnv env innerType
, TokC " }\n"
]
if isManaged
then
[ TokC " for(int i = 0; i < a->len; i++) {\n"
, TokC $ " " ++ insideArrayCopying typeEnv env innerType
, TokC " }\n"
]
else
[TokC " memcpy(copy.data, a->data, sizeof(", TokTy (VarTy "a") Normal, TokC ") * a->len);\n"]
where isManaged =
case findFunctionForMember typeEnv env "delete"
(typesDeleterFunctionType innerType) ("Inside array.", innerType) of
FunctionFound _ -> True
FunctionNotFound msg -> False
FunctionIgnored -> False
copyTy _ _ _ = []
-- | The "memberCopy" and "memberDeletion" functions in Deftype are very similar!
@ -409,14 +419,14 @@ templateStrArray = defineTypeParameterizedTemplate templateCreator path t docs
Template
t
(const (toTemplate "String $NAME (Array* a)"))
(\(FuncTy [RefTy arrayType] StringTy) ->
(\(FuncTy [RefTy arrayType _] StringTy _) ->
[TokDecl, TokC " {\n"] ++
strTy typeEnv env arrayType ++
[TokC "}\n"])
(\(FuncTy [RefTy arrayType@(StructTy "Array" [insideType])] StringTy) ->
(\(FuncTy [RefTy arrayType@(StructTy "Array" [insideType]) _] StringTy _) ->
depsForPrnFunc typeEnv env insideType)
path = SymPath ["Array"] "str"
t = FuncTy [RefTy (StructTy "Array" [VarTy "a"])] StringTy
t = FuncTy [RefTy (StructTy "Array" [VarTy "a"]) (VarTy "q")] StringTy StaticLifetimeTy
docs = "converts an array to a string."
-- | TODO: move this into the templateStrArray function?

10
src/AssignTypes.hs
View File

@ -45,7 +45,7 @@ assignTypes mappings root = visit root
isArrayTypeOK :: Ty -> Bool
isArrayTypeOK (StructTy "Array" [RefTy _]) = False -- An array containing refs!
isArrayTypeOK (StructTy "Array" [RefTy _ _]) = False -- An array containing refs!
isArrayTypeOK _ = True
@ -60,12 +60,12 @@ beautifyTypeVariables root =
in assignTypes mappings root
typeVariablesInOrderOfAppearance :: Ty -> [Ty]
typeVariablesInOrderOfAppearance (FuncTy argTys retTy) =
concatMap typeVariablesInOrderOfAppearance argTys ++ typeVariablesInOrderOfAppearance retTy
typeVariablesInOrderOfAppearance (FuncTy argTys retTy ltTy) =
concatMap typeVariablesInOrderOfAppearance argTys ++ typeVariablesInOrderOfAppearance retTy ++ typeVariablesInOrderOfAppearance ltTy
typeVariablesInOrderOfAppearance (StructTy _ typeArgs) =
concatMap typeVariablesInOrderOfAppearance typeArgs
typeVariablesInOrderOfAppearance (RefTy innerTy) =
typeVariablesInOrderOfAppearance innerTy
typeVariablesInOrderOfAppearance (RefTy innerTy lifetimeTy) =
typeVariablesInOrderOfAppearance innerTy ++ typeVariablesInOrderOfAppearance lifetimeTy
typeVariablesInOrderOfAppearance (PointerTy innerTy) =
typeVariablesInOrderOfAppearance innerTy
typeVariablesInOrderOfAppearance t@(VarTy _) =

324
src/Concretize.hs
View File

@ -55,7 +55,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
visitList :: Bool -> Level -> Env -> XObj -> State [XObj] (Either TypeError [XObj])
visitList _ _ _ (XObj (Lst []) _ _) = return (Right [])
visitList _ Toplevel env (XObj (Lst [defn@(XObj Defn _ _), nameSymbol@(XObj (Sym (SymPath [] "main") _) _ _), args@(XObj (Arr argsArr) _ _), body]) _ _) =
visitList _ Toplevel env (XObj (Lst [defn@(XObj (Defn _) _ _), nameSymbol@(XObj (Sym (SymPath [] "main") _) _ _), args@(XObj (Arr argsArr) _ _), body]) _ _) =
if not (null argsArr)
then return $ Left (MainCannotHaveArguments nameSymbol (length argsArr))
else do concretizeTypeOfXObj typeEnv body
@ -66,7 +66,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
then Left (MainCanOnlyReturnUnitOrInt nameSymbol t)
else return [defn, nameSymbol, args, okBody]
visitList _ Toplevel env (XObj (Lst [defn@(XObj Defn _ _), nameSymbol, args@(XObj (Arr argsArr) _ _), body]) _ t) =
visitList _ Toplevel env (XObj (Lst [defn@(XObj (Defn _) _ _), nameSymbol, args@(XObj (Arr argsArr) _ _), body]) _ t) =
do mapM_ (concretizeTypeOfXObj typeEnv) argsArr
let functionEnv = Env Map.empty (Just env) Nothing [] InternalEnv 0
envWithArgs = foldl' (\e arg@(XObj (Sym (SymPath _ argSymName) _) _ _) ->
@ -79,11 +79,11 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
return $ do okBody <- visitedBody
return [defn, nameSymbol, args, okBody]
visitList _ Inside env xobj@(XObj (Lst [defn@(XObj Defn _ _), nameSymbol, args@(XObj (Arr argsArr) _ _), body]) _ t) =
visitList _ Inside env xobj@(XObj (Lst [defn@(XObj (Defn _) _ _), nameSymbol, args@(XObj (Arr argsArr) _ _), body]) _ t) =
return (Left (DefinitionsMustBeAtToplevel xobj))
-- | Fn / λ
visitList allowAmbig _ env (XObj (Lst [XObj (Fn _ _) fni fnt, args@(XObj (Arr argsArr) ai at), body]) i t) =
visitList allowAmbig _ env (XObj (Lst [XObj (Fn _ _ _) fni fnt, args@(XObj (Arr argsArr) ai at), body]) i t) =
-- The basic idea of this function is to first visit the body of the lambda ("in place"),
-- then take the resulting body and put into a separate function 'defn' with a new name
-- in the global scope. That function definition will be set as the lambdas '.callback' in
@ -119,7 +119,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
(Just dummyInfo)
(Just (PointerTy (StructTy environmentTypeName []))) :
argsArr)) ai at
lambdaCallback = XObj (Lst [XObj Defn (Just dummyInfo) Nothing, lambdaNameSymbol, extendedArgs, okBody]) i t
lambdaCallback = XObj (Lst [XObj (Defn (Just (Set.fromList capturedVars))) (Just dummyInfo) Nothing, lambdaNameSymbol, extendedArgs, okBody]) i t
-- The lambda will also carry with it a special made struct containing the variables it captures
-- (if it captures at least one variable)
@ -158,7 +158,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
modify (deleterDeps ++)
modify (copyFn :)
modify (copyDeps ++)
return (Right [XObj (Fn (Just lambdaPath) (Set.fromList capturedVars)) fni fnt, args, okBody])
return (Right [XObj (Fn (Just lambdaPath) (Set.fromList capturedVars) (FEnv env)) fni fnt, args, okBody])
Left err ->
return (Left err)
@ -277,7 +277,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
tys = map (typeFromPath env) interfacePaths
tysToPathsDict = zip tys interfacePaths
in case filter (matchingSignature actualType) tysToPathsDict of
[] -> return $ -- (trace ("No matching signatures for interface lookup of " ++ name ++ " of type " ++ show actualType ++ " " ++ prettyInfoFromXObj xobj ++ ", options are:\n" ++ joinWith "\n" (map show tysToPathsDict))) $
[] -> return $ --(trace ("No matching signatures for interface lookup of " ++ name ++ " of type " ++ show actualType ++ " " ++ prettyInfoFromXObj xobj ++ ", options are:\n" ++ joinWith "\n" (map show tysToPathsDict))) $
if allowAmbig
then Right xobj -- No exact match of types
else Left (NoMatchingSignature xobj name actualType tysToPathsDict)
@ -287,8 +287,9 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
in if isTypeGeneric tt then return (Right xobj) else replace theType singlePath
severalPaths ->
--(trace ("Several matching signatures for interface lookup of '" ++ name ++ "' of type " ++ show actualType ++ " " ++ prettyInfoFromXObj xobj ++ ", options are:\n" ++ joinWith "\n" (map show tysToPathsDict) ++ "\n Filtered paths are:\n" ++ (joinWith "\n" (map show severalPaths)))) $
case filter (\(tt, _) -> actualType == tt) severalPaths of
[] -> return (Right xobj) -- No exact match of types
case filter (\(tt, _) -> typeEqIgnoreLifetimes actualType tt) severalPaths of
[] -> --trace ("No exact matches for '" ++ show actualType ++ "'") $
return (Right xobj) -- No exact match of types
[(theType, singlePath)] -> replace theType singlePath -- Found an exact match, will ignore any "half matched" functions that might have slipped in.
_ -> return (Left (SeveralExactMatches xobj name actualType severalPaths))
where replace theType singlePath =
@ -313,7 +314,7 @@ collectCapturedVars root = removeDuplicates (map toGeneralSymbol (visit root))
visit xobj =
case obj xobj of
-- don't peek inside lambdas, trust their capture lists:
(Lst [XObj (Fn _ captures) _ _, _, _]) -> Set.toList captures
(Lst [XObj (Fn _ captures _ ) _ _, _, _]) -> Set.toList captures
(Lst _) -> visitList xobj
(Arr _) -> visitArray xobj
(Sym path (LookupLocal Capture)) -> [xobj]
@ -349,7 +350,7 @@ concretizeTypeOfXObj _ xobj = return (Right ())
-- | Find all the concrete deps of a type.
concretizeType :: TypeEnv -> Ty -> Either TypeError [XObj]
concretizeType _ ft@(FuncTy _ _) =
concretizeType _ ft@(FuncTy _ _ _) =
if isTypeGeneric ft
then Right []
else Right [defineFunctionTypeAlias ft]
@ -374,7 +375,7 @@ concretizeType typeEnv genericStructTy@(StructTy name _) =
error ("Non-deftype found in type env: " ++ show x)
Nothing ->
Right []
concretizeType env (RefTy rt) =
concretizeType env (RefTy rt _) =
concretizeType env rt
concretizeType env (PointerTy pt) =
concretizeType env pt
@ -491,7 +492,7 @@ concretizeDefinition allowAmbiguity typeEnv globalEnv visitedDefinitions definit
newPath = SymPath pathStrings (name ++ suffix)
in
case definition of
XObj (Lst (XObj Defn _ _ : _)) _ _ ->
XObj (Lst (XObj (Defn _) _ _ : _)) _ _ ->
let withNewPath = setPath definition newPath
mappings = unifySignatures polyType concreteType
in case assignTypes mappings withNewPath of
@ -545,29 +546,29 @@ depsOfPolymorphicFunction typeEnv env visitedDefinitions functionName functionTy
depsForDeleteFunc :: TypeEnv -> Env -> Ty -> [XObj]
depsForDeleteFunc typeEnv env t =
if isManaged typeEnv t
then depsOfPolymorphicFunction typeEnv env [] "delete" (FuncTy [t] UnitTy)
then depsOfPolymorphicFunction typeEnv env [] "delete" (FuncTy [t] UnitTy StaticLifetimeTy)
else []
-- | Helper for finding the 'copy' function for a type.
depsForCopyFunc :: TypeEnv -> Env -> Ty -> [XObj]
depsForCopyFunc typeEnv env t =
if isManaged typeEnv t
then depsOfPolymorphicFunction typeEnv env [] "copy" (FuncTy [RefTy t] t)
then depsOfPolymorphicFunction typeEnv env [] "copy" (FuncTy [RefTy t (VarTy "q")] t StaticLifetimeTy)
else []
-- | Helper for finding the 'str' function for a type.
depsForPrnFunc :: TypeEnv -> Env -> Ty -> [XObj]
depsForPrnFunc typeEnv env t =
if isManaged typeEnv t
then depsOfPolymorphicFunction typeEnv env [] "prn" (FuncTy [RefTy t] StringTy)
else depsOfPolymorphicFunction typeEnv env [] "prn" (FuncTy [t] StringTy)
then depsOfPolymorphicFunction typeEnv env [] "prn" (FuncTy [RefTy t (VarTy "q")] StringTy StaticLifetimeTy)
else depsOfPolymorphicFunction typeEnv env [] "prn" (FuncTy [t] StringTy StaticLifetimeTy)
-- | The type of a type's str function.
typesStrFunctionType :: TypeEnv -> Ty -> Ty
typesStrFunctionType typeEnv memberType =
if isManaged typeEnv memberType
then FuncTy [RefTy memberType] StringTy
else FuncTy [memberType] StringTy
then FuncTy [RefTy memberType (VarTy "q")] StringTy StaticLifetimeTy
else FuncTy [memberType] StringTy StaticLifetimeTy
-- | The various results when trying to find a function using 'findFunctionForMember'.
data FunctionFinderResult = FunctionFound String
@ -621,18 +622,29 @@ setDeletersOnInfo i deleters = fmap (\i' -> i' { infoDelete = deleters }) i
del :: XObj -> Set.Set Deleter -> XObj
del xobj deleters = xobj { info = setDeletersOnInfo (info xobj) deleters }
-- | Differentiate between lifetimes depending on variables in a lexical scope and depending on something outside the function
data LifetimeMode = LifetimeInsideFunction String
| LifetimeOutsideFunction
deriving Show
-- | To keep track of the deleters when recursively walking the form.
data MemState = MemState
{ memStateDeleters :: Set.Set Deleter
, memStateDeps :: [XObj]
, memStateLifetimes :: Map.Map String LifetimeMode
} deriving Show
prettyLifetimeMappings :: Map.Map String LifetimeMode -> String
prettyLifetimeMappings mappings =
joinWith "\n" (map prettyMapping (Map.toList mappings))
where prettyMapping (key, value) = " " ++ key ++ " => " ++ show value
-- | Find out what deleters are needed and where in an XObj.
-- | Deleters will be added to the info field on XObj so that
-- | the code emitter can access them and insert calls to destructors.
manageMemory :: TypeEnv -> Env -> XObj -> Either TypeError (XObj, [XObj])
manageMemory typeEnv globalEnv root =
let (finalObj, finalState) = runState (visit root) (MemState (Set.fromList []) [])
let (finalObj, finalState) = runState (visit root) (MemState (Set.fromList []) [] (Map.empty))
deleteThese = memStateDeleters finalState
deps = memStateDeps finalState
in -- (trace ("Delete these: " ++ joinWithComma (map show (Set.toList deleteThese)))) $
@ -643,12 +655,27 @@ manageMemory typeEnv globalEnv root =
where visit :: XObj -> State MemState (Either TypeError XObj)
visit xobj =
case obj xobj of
Lst _ -> visitList xobj
Arr _ -> visitArray xobj
Str _ -> do manage xobj
return (Right xobj)
_ -> return (Right xobj)
do r <- case obj xobj of
Lst _ -> do visitList xobj
-- res <- visitList xobj
-- case res of
-- Right ok -> do addToLifetimesMappingsIfRef True ok
-- return res
-- Left err -> return (Left err)
Arr _ -> visitArray xobj
Str _ -> do manage xobj
addToLifetimesMappingsIfRef False xobj -- TODO: Should "internal = True" here?
return (Right xobj)
Pattern _ -> do manage xobj
addToLifetimesMappingsIfRef False xobj
return (Right xobj)
_ ->
return (Right xobj)
case r of
Right ok -> do MemState _ _ m <- get
checkThatRefTargetIsAlive $ --trace ("CHECKING " ++ pretty ok ++ " : " ++ showMaybeTy (ty xobj) ++ ", mappings: " ++ prettyLifetimeMappings m) $
ok
Left err -> return (Left err)
visitArray :: XObj -> State MemState (Either TypeError XObj)
visitArray xobj@(XObj (Arr arr) _ _) =
@ -665,13 +692,23 @@ manageMemory typeEnv globalEnv root =
visitList :: XObj -> State MemState (Either TypeError XObj)
visitList xobj@(XObj (Lst lst) i t) =
case lst of
[defn@(XObj Defn _ _), nameSymbol@(XObj (Sym _ _) _ _), args@(XObj (Arr argList) _ _), body] ->
let Just funcTy@(FuncTy _ defnReturnType) = t
[defn@(XObj (Defn maybeCaptures) _ _), nameSymbol@(XObj (Sym _ _) _ _), args@(XObj (Arr argList) _ _), body] ->
let Just funcTy@(FuncTy _ defnReturnType _) = t
captures = fromMaybe [] (fmap Set.toList maybeCaptures)
in case defnReturnType of
RefTy _ ->
return (Left (FunctionsCantReturnRefTy xobj funcTy))
-- RefTy _ _ ->
-- return (Left (FunctionsCantReturnRefTy xobj funcTy))
_ ->
do mapM_ manage argList
-- Add the captured variables (if any, only happens in lifted lambdas) as fake deleters
-- TODO: Use another kind of Deleter for this case since it's pretty special?
mapM_
(\cap ->
modify (\memState ->
memState { memStateDeleters = Set.insert (FakeDeleter cap) (memStateDeleters memState) }))
(map getName captures)
mapM_ (addToLifetimesMappingsIfRef False) argList
mapM_ (addToLifetimesMappingsIfRef False) captures -- For captured variables inside of lifted lambdas
visitedBody <- visit body
result <- unmanage body
return $
@ -681,13 +718,14 @@ manageMemory typeEnv globalEnv root =
do okBody <- visitedBody
return (XObj (Lst [defn, nameSymbol, args, okBody]) i t)
-- Fn / λ
[fn@(XObj (Fn _ captures) _ _), args@(XObj (Arr argList) _ _), body] ->
let Just funcTy@(FuncTy _ fnReturnType) = t
-- Fn / λ (Lambda)
[fn@(XObj (Fn _ captures _) _ _), args@(XObj (Arr argList) _ _), body] ->
let Just funcTy@(FuncTy _ fnReturnType _) = t
in do manage xobj -- manage inner lambdas but leave their bodies unvisited, they will be visited in the lifted version...
mapM_ unmanage captures
return (Right (XObj (Lst [fn, args, body]) i t))
-- Def
[def@(XObj Def _ _), nameSymbol@(XObj (Sym _ _) _ _), expr] ->
do visitedExpr <- visit expr
result <- unmanage expr
@ -698,24 +736,25 @@ manageMemory typeEnv globalEnv root =
do okExpr <- visitedExpr
return (XObj (Lst [def, nameSymbol, okExpr]) i t)
-- Let
[letExpr@(XObj Let _ _), XObj (Arr bindings) bindi bindt, body] ->
let Just letReturnType = t
in case letReturnType of
RefTy _ ->
return (Left (LetCantReturnRefTy xobj letReturnType))
-- RefTy _ _ ->
-- return (Left (LetCantReturnRefTy xobj letReturnType))
_ ->
do MemState preDeleters _ <- get
do MemState preDeleters _ _ <- get
visitedBindings <- mapM visitLetBinding (pairwise bindings)
visitedBody <- visit body
result <- unmanage body
case result of
Left e -> return (Left e)
Right _ ->
do MemState postDeleters deps <- get
do MemState postDeleters deps postLifetimes <- get
let diff = postDeleters Set.\\ preDeleters
newInfo = setDeletersOnInfo i diff
survivors = postDeleters Set.\\ diff -- Same as just pre deleters, right?!
put (MemState survivors deps)
put (MemState survivors deps postLifetimes)
--trace ("LET Pre: " ++ show preDeleters ++ "\nPost: " ++ show postDeleters ++ "\nDiff: " ++ show diff ++ "\nSurvivors: " ++ show survivors)
manage xobj
return $ do okBody <- visitedBody
@ -735,7 +774,7 @@ manageMemory typeEnv globalEnv root =
Left err ->
return (Left err)
Right (okCorrectVariable, okMode) ->
do MemState preDeleters _ <- get
do MemState preDeleters _ _ <- get
ownsTheVarBefore <- case createDeleter okCorrectVariable of
Nothing -> return (Right ())
Just d -> if Set.member d preDeleters || isLookupGlobal okMode
@ -744,7 +783,7 @@ manageMemory typeEnv globalEnv root =
visitedValue <- visit value
unmanage value -- The assigned value can't be used anymore
MemState managed deps <- get
MemState managed deps postLifetimes <- get
-- Delete the value previously stored in the variable, if it's still alive
let deleters = case createDeleter okCorrectVariable of
Just d -> Set.fromList [d]
@ -812,17 +851,17 @@ manageMemory typeEnv globalEnv root =
return (XObj (Lst (doExpr : okExpressions)) i t)
[whileExpr@(XObj While _ _), expr, body] ->
do MemState preDeleters _ <- get
do MemState preDeleters _ _ <- get
visitedExpr <- visit expr
MemState afterExprDeleters _ <- get
MemState afterExprDeleters _ _ <- get
visitedBody <- visit body
manage body
MemState postDeleters deps <- get
MemState postDeleters deps postLifetimes <- get
-- Visit an extra time to simulate repeated use
visitedExpr2 <- visit expr
visitedBody2 <- visit body
let diff = postDeleters \\ preDeleters
put (MemState (postDeleters \\ diff) deps) -- Same as just pre deleters, right?!
put (MemState (postDeleters \\ diff) deps postLifetimes) -- Same as just pre deleters, right?!
return $ do okExpr <- visitedExpr
okBody <- visitedBody
okExpr2 <- visitedExpr2 -- This evaluates the second visit so that it actually produces the error
@ -836,7 +875,7 @@ manageMemory typeEnv globalEnv root =
[ifExpr@(XObj If _ _), expr, ifTrue, ifFalse] ->
do visitedExpr <- visit expr
MemState preDeleters deps <- get
MemState preDeleters deps lifetimes <- get
let (visitedTrue, stillAliveTrue) = runState (do { v <- visit ifTrue;
result <- transferOwnership ifTrue xobj;
@ -844,7 +883,7 @@ manageMemory typeEnv globalEnv root =
Left e -> error (show e)
Right () -> v
})
(MemState preDeleters deps)
(MemState preDeleters deps lifetimes)
(visitedFalse, stillAliveFalse) = runState (do { v <- visit ifFalse;
result <- transferOwnership ifFalse xobj;
@ -852,7 +891,7 @@ manageMemory typeEnv globalEnv root =
Left e -> error (show e)
Right () -> v
})
(MemState preDeleters deps)
(MemState preDeleters deps lifetimes)
let deletedInTrue = preDeleters \\ memStateDeleters stillAliveTrue
deletedInFalse = preDeleters \\ memStateDeleters stillAliveFalse
@ -887,7 +926,7 @@ manageMemory typeEnv globalEnv root =
"depsAfter: " ++ show depsAfter ++ "\n"
)
put (MemState stillAliveAfter depsAfter)
put (MemState stillAliveAfter depsAfter lifetimes)
manage xobj
return $ do okExpr <- visitedExpr
@ -906,7 +945,7 @@ manageMemory typeEnv globalEnv root =
Left e -> return (Left e)
Right okVisitedExpr ->
do unmanage okVisitedExpr
MemState preDeleters deps <- get
MemState preDeleters deps lifetimes <- get
vistedCasesAndDeps <- mapM visitMatchCase (pairwise cases)
case sequence vistedCasesAndDeps of
Left e -> return (Left e)
@ -914,7 +953,7 @@ manageMemory typeEnv globalEnv root =
let visitedCases = map fst okCasesAndDeps
depsFromCases = concatMap snd okCasesAndDeps
(finalXObj, postDeleters) = figureOutStuff okVisitedExpr visitedCases preDeleters
in do put (MemState postDeleters (deps ++ depsFromCases))
in do put (MemState postDeleters (deps ++ depsFromCases) lifetimes)
manage xobj
return (Right finalXObj)
@ -954,30 +993,37 @@ manageMemory typeEnv globalEnv root =
XObj (Lst [deref@(XObj Deref _ _), f]) xi xt : args ->
do -- Do not visit f in this case, we don't want to manage it's memory since it is a ref!
visitedArgs <- sequence <$> mapM visitArg args
manage xobj
return $ do okArgs <- visitedArgs
Right (XObj (Lst (XObj (Lst [deref, f]) xi xt : okArgs)) i t)
case visitedArgs of
Left err -> return (Left err)
Right args ->
do unmanagedArgs <- sequence <$> mapM unmanageArg args
manage xobj
return $ do okArgs <- unmanagedArgs
Right (XObj (Lst (XObj (Lst [deref, f]) xi xt : okArgs)) i t)
f : args ->
do visitedF <- visit f
visitedArgs <- sequence <$> mapM visitArg args
manage xobj
return $ do okF <- visitedF
okArgs <- visitedArgs
Right (XObj (Lst (okF : okArgs)) i t)
case visitedArgs of
Left err -> return (Left err)
Right args -> do unmanagedArgs <- sequence <$> mapM unmanageArg args
manage xobj
return $ do okF <- visitedF
okArgs <- unmanagedArgs
Right (XObj (Lst (okF : okArgs)) i t)
[] -> return (Right xobj)
visitList _ = error "Must visit list."
visitMatchCase :: (XObj, XObj) -> State MemState (Either TypeError ((Set.Set Deleter, (XObj, XObj)), [XObj]))
visitMatchCase (lhs@(XObj _ lhsInfo _), rhs@XObj{}) =
do MemState preDeleters preDeps <- get
do MemState preDeleters preDeps preLifetimes <- get
_ <- visitCaseLhs lhs
visitedRhs <- visit rhs
unmanage rhs
MemState postDeleters postDeps <- get
MemState postDeleters postDeps postLifetimes <- get
let diff = postDeleters \\ preDeleters
put (MemState preDeleters postDeps) -- Restore managed variables, TODO: Use a "local" state monad instead?
put (MemState preDeleters postDeps postLifetimes) -- Restore managed variables, TODO: Use a "local" state monad instead?
return $ do okVisitedRhs <- visitedRhs
-- trace ("\npre: " ++ show preDeleters ++
-- "\npost: " ++ show postDeleters ++
@ -1009,9 +1055,81 @@ manageMemory typeEnv globalEnv root =
visitCaseLhs _ =
return (Right []) -- TODO: Handle nesting!!!
addToLifetimesMappingsIfRef :: Bool -> XObj -> State MemState ()
addToLifetimesMappingsIfRef internal xobj =
case ty xobj of
Just (RefTy _ (VarTy lt)) ->
do m@(MemState _ _ lifetimes) <- get
case Map.lookup lt lifetimes of
Just existing ->
--trace ("\nThere is already a mapping for '" ++ pretty xobj ++ "' from the lifetime '" ++ lt ++ "' to " ++ show existing ++ ", won't add " ++ show (makeLifetimeMode xobj)) $
return ()
Nothing ->
do let lifetimes' = Map.insert lt (makeLifetimeMode xobj) lifetimes
put $ --(trace $ "\nExtended lifetimes mappings for '" ++ pretty xobj ++ "' with " ++ show lt ++ " => " ++ show (makeLifetimeMode xobj) ++ " at " ++ prettyInfoFromXObj xobj ++ ":\n" ++ prettyLifetimeMappings lifetimes') $
m { memStateLifetimes = lifetimes' }
return ()
Just notThisType ->
--trace ("Won't add to mappings! " ++ pretty xobj ++ " : " ++ show notThisType ++ " at " ++ prettyInfoFromXObj xobj) $
return ()
_ ->
--trace ("No type on " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj) $
return ()
where makeLifetimeMode xobj =
if internal then
LifetimeInsideFunction $
case xobj of
XObj (Lst [(XObj Ref _ _), target]) _ _ -> varOfXObj target
_ -> varOfXObj xobj
else
LifetimeOutsideFunction
checkThatRefTargetIsAlive :: XObj -> State MemState (Either TypeError XObj)
checkThatRefTargetIsAlive xobj =
case ty xobj of
Just (RefTy _ (VarTy lt)) ->
performCheck lt
Just (FuncTy _ _ (VarTy lt)) ->
performCheck lt
_ ->
return (Right xobj)
where performCheck :: String -> State MemState (Either TypeError XObj)
performCheck lt =
do MemState deleters _ lifetimeMappings <- get
case Map.lookup lt lifetimeMappings of
Just (LifetimeInsideFunction deleterName) ->
let matchingDeleters = Set.toList $ Set.filter (\case
ProperDeleter { deleterVariable = dv } -> dv == deleterName
FakeDeleter { deleterVariable = dv } -> dv == deleterName
PrimDeleter { aliveVariable = dv } -> dv == deleterName
RefDeleter { refVariable = dv } -> dv == deleterName
)
deleters
in case matchingDeleters of
[] ->
--trace ("Can't use reference " ++ pretty xobj ++ " (with lifetime '" ++ lt ++ "', depending on " ++ show deleterName ++ ") at " ++ prettyInfoFromXObj xobj ++ ", it's not alive here:\n" ++ show xobj ++ "\nMappings: " ++ prettyLifetimeMappings lifetimeMappings ++ "\nAlive: " ++ show deleters ++ "\n") $
--return (Right xobj)
return (Left (UsingDeadReference xobj deleterName))
_ ->
-- trace ("CAN use reference " ++ pretty xobj ++ " (with lifetime '" ++ lt ++ "', depending on " ++ show deleterName ++ ") at " ++ prettyInfoFromXObj xobj ++ ", it's not alive here:\n" ++ show xobj ++ "\nMappings: " ++ prettyLifetimeMappings lifetimeMappings ++ "\nAlive: " ++ show deleters ++ "\n") $
return (Right xobj)
Just LifetimeOutsideFunction ->
--trace ("Lifetime OUTSIDE function: " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj) $
return (Right xobj)
Nothing ->
case xobj of
-- XObj (Sym _ (LookupLocal Capture)) _ _ ->
-- -- Ignore these for the moment! TODO: FIX!!!
-- return (Right xobj)
_ ->
--trace ("Failed to find lifetime key (when checking) '" ++ lt ++ "' for " ++ pretty xobj ++ " in mappings at " ++ prettyInfoFromXObj xobj) $
return (Right xobj)
visitLetBinding :: (XObj, XObj) -> State MemState (Either TypeError (XObj, XObj))
visitLetBinding (name, expr) =
do visitedExpr <- visit expr
do visitedExpr <- visit expr
addToLifetimesMappingsIfRef True expr
result <- transferOwnership expr name
return $ case result of
Left e -> Left e
@ -1019,27 +1137,44 @@ manageMemory typeEnv globalEnv root =
return (name, okExpr)
visitArg :: XObj -> State MemState (Either TypeError XObj)
visitArg xobj@(XObj _ _ (Just t)) =
if isManaged typeEnv t
then do visitedXObj <- visit xobj
result <- unmanage xobj
case result of
Left e -> return (Left e)
Right _ -> return visitedXObj
else visit xobj
visitArg xobj@XObj{} =
visitArg xobj@(XObj _ _ (Just t)) =
do afterVisit <- if isManaged typeEnv t
then do visitedXObj <- visit xobj
--result <- unmanage xobj
return visitedXObj
else visit xobj
case afterVisit of
Right okAfterVisit -> do addToLifetimesMappingsIfRef True okAfterVisit
return (Right okAfterVisit)
Left err -> return (Left err)
visitArg xobj@XObj{} =
visit xobj
unmanageArg :: XObj -> State MemState (Either TypeError XObj)
unmanageArg xobj@(XObj _ _ (Just t)) =
do if isManaged typeEnv t
then do r <- unmanage xobj
case r of
Left err -> return (Left err)
Right () -> return (Right xobj)
else return (Right xobj)
unmanageArg xobj@XObj{} =
return (Right xobj)
createDeleter :: XObj -> Maybe Deleter
createDeleter xobj =
case ty xobj of
Just (RefTy _ _) -> Just (RefDeleter (varOfXObj xobj))
Just t -> let var = varOfXObj xobj
in if isManaged typeEnv t && not (isExternalType typeEnv t)
then case nameOfPolymorphicFunction typeEnv globalEnv (FuncTy [t] UnitTy) "delete" of
Just pathOfDeleteFunc -> Just (ProperDeleter pathOfDeleteFunc var)
Nothing -> --trace ("Found no delete function for " ++ var ++ " : " ++ (showMaybeTy (ty xobj)))
Just (FakeDeleter var)
else Nothing
in if isExternalType typeEnv t
then Just (FakeDeleter var)
else if isManaged typeEnv t
then case nameOfPolymorphicFunction typeEnv globalEnv (FuncTy [t] UnitTy StaticLifetimeTy) "delete" of
Just pathOfDeleteFunc ->
Just (ProperDeleter pathOfDeleteFunc var)
Nothing -> --trace ("Found no delete function for " ++ var ++ " : " ++ (showMaybeTy (ty xobj)))
Just (FakeDeleter var)
else Just (PrimDeleter var)
Nothing -> error ("No type, can't manage " ++ show xobj)
manage :: XObj -> State MemState ()
@ -1047,11 +1182,11 @@ manageMemory typeEnv globalEnv root =
if isSymbolThatCaptures xobj -- When visiting lifted lambdas, don't manage symbols that capture (they are owned by the environment).
then return ()
else case createDeleter xobj of
Just deleter -> do MemState deleters deps <- get
Just deleter -> do MemState deleters deps lifetimes <- get
let newDeleters = Set.insert deleter deleters
Just t = ty xobj
newDeps = deps ++ depsForDeleteFunc typeEnv globalEnv t
put (MemState newDeleters newDeps)
put (MemState newDeleters newDeps lifetimes)
Nothing -> return ()
deletersMatchingXObj :: XObj -> Set.Set Deleter -> [Deleter]
@ -1059,7 +1194,10 @@ manageMemory typeEnv globalEnv root =
let var = varOfXObj xobj
in Set.toList $ Set.filter (\case
ProperDeleter { deleterVariable = dv } -> dv == var
FakeDeleter { deleterVariable = dv } -> dv == var)
FakeDeleter { deleterVariable = dv } -> dv == var
PrimDeleter { aliveVariable = dv } -> dv == var
RefDeleter { refVariable = dv } -> dv == var
)
deleters
isSymbolThatCaptures :: XObj -> Bool
@ -1073,13 +1211,13 @@ manageMemory typeEnv globalEnv root =
let Just t = ty xobj
Just i = info xobj
in if isManaged typeEnv t && not (isGlobalFunc xobj) && not (isExternalType typeEnv t)
then do MemState deleters deps <- get
then do MemState deleters deps lifetimes <- get
case deletersMatchingXObj xobj deleters of
[] -> if isSymbolThatCaptures xobj
then return (Left (UsingCapturedValue xobj))
else return (Left (UsingUnownedValue xobj))
[one] -> let newDeleters = Set.delete one deleters
in do put (MemState newDeleters deps)
in do put (MemState newDeleters deps lifetimes)
return (Right ())
_ -> error "Too many variables with the same name in set."
else return (Right ())
@ -1092,8 +1230,8 @@ manageMemory typeEnv globalEnv root =
isGlobalVariable = case xobj of
XObj (Sym _ (LookupGlobal _ _)) _ _ -> True
_ -> False
in if not isGlobalVariable && not (isGlobalFunc xobj) && isManaged typeEnv t && not (isExternalType typeEnv t) && not (isSymbolThatCaptures xobj)
then do MemState deleters deps <- get
in if not isGlobalVariable && not (isGlobalFunc xobj) && isManaged typeEnv t && not (isExternalType typeEnv t) && not (isSymbolThatCaptures xobj) -- TODO: The 'isManaged typeEnv t' boolean check should be removed!
then do MemState deleters deps lifetimes <- get
case deletersMatchingXObj xobj deleters of
[] -> return (Left (GettingReferenceToUnownedValue xobj))
[_] -> return (return ())
@ -1120,19 +1258,19 @@ suffixTyVars :: String -> Ty -> Ty
suffixTyVars suffix t =
case t of
VarTy key -> VarTy (key ++ suffix)
FuncTy argTys retTy -> FuncTy (map (suffixTyVars suffix) argTys) (suffixTyVars suffix retTy)
FuncTy argTys retTy ltTy -> FuncTy (map (suffixTyVars suffix) argTys) (suffixTyVars suffix retTy) (suffixTyVars suffix ltTy)
StructTy name tyArgs -> StructTy name (fmap (suffixTyVars suffix) tyArgs)
PointerTy x -> PointerTy (suffixTyVars suffix x)
RefTy x -> RefTy (suffixTyVars suffix x)
RefTy x lt -> RefTy (suffixTyVars suffix x) (suffixTyVars suffix lt)
_ -> t
isGlobalFunc :: XObj -> Bool
isGlobalFunc xobj =
case xobj of
XObj (InterfaceSym _) _ (Just (FuncTy _ _)) -> True
XObj (MultiSym _ _) _ (Just (FuncTy _ _)) -> True
XObj (Sym _ (LookupGlobal _ _)) _ (Just (FuncTy _ _)) -> True
XObj (Sym _ (LookupGlobalOverride _)) _ (Just (FuncTy _ _)) -> True
XObj (InterfaceSym _) _ (Just (FuncTy _ _ _)) -> True
XObj (MultiSym _ _) _ (Just (FuncTy _ _ _)) -> True
XObj (Sym _ (LookupGlobal _ _)) _ (Just (FuncTy _ _ _)) -> True
XObj (Sym _ (LookupGlobalOverride _)) _ (Just (FuncTy _ _ _)) -> True
_ -> False
-- | The following functions will generate deleters and copy:ing methods for structs, they are shared with the Deftype module
@ -1143,7 +1281,7 @@ data AllocationMode = StackAlloc | HeapAlloc
concreteDelete :: TypeEnv -> Env -> [(String, Ty)] -> Template
concreteDelete typeEnv env members =
Template
(FuncTy [VarTy "p"] UnitTy)
(FuncTy [VarTy "p"] UnitTy StaticLifetimeTy)
(const (toTemplate "void $NAME($p p)"))
(const (toTemplate $ unlines [ "$DECL {"
, joinWith "\n" (map (memberDeletion typeEnv env) members)
@ -1155,7 +1293,7 @@ concreteDelete typeEnv env members =
concreteDeleteTakePtr :: TypeEnv -> Env -> [(String, Ty)] -> Template
concreteDeleteTakePtr typeEnv env members =
Template
(FuncTy [PointerTy (VarTy "p")] UnitTy)
(FuncTy [PointerTy (VarTy "p")] UnitTy StaticLifetimeTy)
(const (toTemplate "void $NAME($p* p)"))
(const (toTemplate $ unlines [ "$DECL {"
, joinWith "\n" (map (memberDeletionGeneral "->" typeEnv env) members)
@ -1179,7 +1317,7 @@ memberRefDeletion = memberDeletionGeneral "Ref->"
concreteCopy :: TypeEnv -> Env -> [(String, Ty)] -> Template
concreteCopy typeEnv env memberPairs =
Template
(FuncTy [RefTy (VarTy "p")] (VarTy "p"))
(FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy)
(const (toTemplate "$p $NAME($p* pRef)"))
(const (tokensForCopy typeEnv env memberPairs))
(\_ -> concatMap (depsOfPolymorphicFunction typeEnv env [] "copy" . typesCopyFunctionType)
@ -1207,7 +1345,7 @@ memberCopy typeEnv env (memberName, memberType) =
concreteCopyPtr :: TypeEnv -> Env -> [(String, Ty)] -> Template
concreteCopyPtr typeEnv env memberPairs =
Template
(FuncTy [RefTy (VarTy "p")] (VarTy "p"))
(FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy)
(const (toTemplate "$p* $NAME($p* pRef)"))
(const (tokensForCopyPtr typeEnv env memberPairs))
(\_ -> concatMap (depsOfPolymorphicFunction typeEnv env [] "copy" . typesCopyFunctionType)

40
src/Constraints.hs
View File

@ -24,6 +24,7 @@ data ConstraintOrder = OrdNo
| OrdFuncAppRet
| OrdArrHead
| OrdArg
| OrdCapture
| OrdDefnBody
| OrdDefExpr
| OrdLetBind
@ -58,7 +59,7 @@ data UnificationFailure = UnificationFailure { unificationFailure ::Constraint
deriving (Eq, Show)
instance Show Constraint where
show (Constraint a b xa xb ctx ord) = "{" ++ show a ++ " == " ++ show b ++ " (ord " ++ show ord ++ ")} " ++ show (fmap infoLine (info xa)) ++ ", " ++ show (fmap infoLine (info xb)) ++ " in " ++ show ctx
show (Constraint a b xa xb ctx ord) = "{" ++ show a ++ " == " ++ show b ++ " (ord " ++ show ord ++ ")} " -- ++ show (fmap infoLine (info xa)) ++ ", " ++ show (fmap infoLine (info xb)) ++ " in " ++ show ctx
-- Finds the symbol with the "lowest name" (first in alphabetical order)
recursiveLookup :: TypeMappings -> String -> Maybe Ty
@ -123,11 +124,14 @@ solveOneInternal mappings constraint =
else Left (UnificationFailure constraint mappings)
-- Func types
Constraint (FuncTy argsA retA) (FuncTy argsB retB) _ _ _ _ ->
Constraint (FuncTy argsA retA ltA) (FuncTy argsB retB ltB) _ _ _ _ ->
if length argsA == length argsB
then let (Constraint _ _ i1 i2 ctx ord) = constraint
in foldM (\m (aa, bb) -> solveOneInternal m (Constraint aa bb i1 i2 ctx ord)) mappings (zip (retA : argsA)
(retB : argsB))
res = foldM (\m (aa, bb) -> solveOneInternal m (Constraint aa bb i1 i2 ctx ord)) mappings (zip (retA : argsA)
(retB : argsB))
in case res of
Right ok -> solveOneInternal ok (Constraint ltA ltB i1 i2 ctx ord)
Left err -> Left err
else Left (UnificationFailure constraint mappings)
-- Pointer types
@ -137,9 +141,11 @@ solveOneInternal mappings constraint =
-- Ref types
-- TODO: This messes up the error message since the constraint is between non-reffed types so the refs don't show in the error message!!!
Constraint (RefTy a) (RefTy b) _ _ _ _ ->
Constraint (RefTy a ltA) (RefTy b ltB) _ _ _ _ ->
let (Constraint _ _ i1 i2 ctx ord) = constraint
in solveOneInternal mappings (Constraint a b i1 i2 ctx ord)
in case solveOneInternal mappings (Constraint a b i1 i2 ctx ord) of
Left err -> Left err
Right ok -> solveOneInternal ok (Constraint ltA ltB i1 i2 ctx ord)
-- Else
Constraint aTy bTy _ _ _ _ ->
@ -166,10 +172,13 @@ checkForConflict mappings constraint name otherTy =
foldM solveOneInternal mappings (zipWith (mkConstraint OrdStruct xobj1 xobj2 ctx) structTyVars otherTyVars)
VarTy _ -> Right mappings
_ -> Left (UnificationFailure constraint mappings)
Just (FuncTy argTys retTy) ->
Just (FuncTy argTys retTy lifetimeTy) ->
case otherTy of
FuncTy otherArgTys otherRetTy -> do m <- foldM solveOneInternal mappings (zipWith (mkConstraint OrdFunc xobj1 xobj2 ctx) argTys otherArgTys)
solveOneInternal m (mkConstraint OrdFunc xobj1 xobj2 ctx retTy otherRetTy)
FuncTy otherArgTys otherRetTy otherLifetimeTy ->
do m <- foldM solveOneInternal mappings (zipWith (mkConstraint OrdFunc xobj1 xobj2 ctx) argTys otherArgTys)
case solveOneInternal m (mkConstraint OrdFunc xobj1 xobj2 ctx retTy otherRetTy) of
Right ok -> solveOneInternal m (mkConstraint OrdFunc xobj1 xobj2 ctx lifetimeTy otherLifetimeTy)
Left err -> Left err
VarTy _ -> Right mappings
_ -> Left (UnificationFailure constraint mappings)
Just (PointerTy innerTy) ->
@ -177,9 +186,12 @@ checkForConflict mappings constraint name otherTy =
PointerTy otherInnerTy -> solveOneInternal mappings (mkConstraint OrdPtr xobj1 xobj2 ctx innerTy otherInnerTy)
VarTy _ -> Right mappings
_ -> Left (UnificationFailure constraint mappings)
Just (RefTy innerTy) ->
Just (RefTy innerTy lifetimeTy) ->
case otherTy of
RefTy otherInnerTy -> solveOneInternal mappings (mkConstraint OrdRef xobj1 xobj2 ctx innerTy otherInnerTy)
RefTy otherInnerTy otherLifetimeTy ->
case solveOneInternal mappings (mkConstraint OrdRef xobj1 xobj2 ctx innerTy otherInnerTy) of
Left err -> Left err
Right ok -> solveOneInternal ok (mkConstraint OrdRef xobj1 xobj2 ctx lifetimeTy otherLifetimeTy)
VarTy _ -> Right mappings
_ -> Left (UnificationFailure constraint mappings)
Just foundNonVar -> case otherTy of
@ -207,7 +219,7 @@ resolveFully mappings varName = Right (Map.insert varName (fullResolve (VarTy va
fullResolve x@(VarTy var) =
case recursiveLookup mappings var of
Just (StructTy name varTys) -> StructTy name (map (fullLookup Set.empty) varTys)
Just (FuncTy argTys retTy) -> FuncTy (map (fullLookup Set.empty) argTys) (fullLookup Set.empty retTy)
Just (FuncTy argTys retTy ltTy) -> FuncTy (map (fullLookup Set.empty) argTys) (fullLookup Set.empty retTy) (fullLookup Set.empty ltTy)
Just found -> found
Nothing -> x -- still not found, must be a generic variable
fullResolve x = x
@ -222,7 +234,7 @@ resolveFully mappings varName = Right (Map.insert varName (fullResolve (VarTy va
fullLookup visited structTy@(StructTy name vs) =
let newVisited = Set.insert structTy visited
in StructTy name (map (fullLookup newVisited) vs)
fullLookup visited funcTy@(FuncTy argTys retTy) =
fullLookup visited funcTy@(FuncTy argTys retTy ltTy) =
let newVisited = Set.insert funcTy visited
in FuncTy (map (fullLookup newVisited) argTys) (fullLookup newVisited retTy)
in FuncTy (map (fullLookup newVisited) argTys) (fullLookup newVisited retTy) (fullLookup newVisited ltTy)
fullLookup visited x = x

90
src/Deftype.hs
View File

@ -77,13 +77,13 @@ templatesForSingleMember :: TypeEnv -> Env -> [String] -> Ty -> (XObj, XObj) ->
templatesForSingleMember typeEnv env insidePath p@(StructTy typeName _) (nameXObj, typeXObj) =
let Just t = xobjToTy typeXObj
memberName = getName nameXObj
in [instanceBinderWithDeps (SymPath insidePath memberName) (FuncTy [RefTy p] (RefTy t)) (templateGetter (mangle memberName) t) ("gets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "`.")
in [instanceBinderWithDeps (SymPath insidePath memberName) (FuncTy [RefTy p (VarTy "q")] (RefTy t (VarTy "q")) StaticLifetimeTy) (templateGetter (mangle memberName) t) ("gets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "`.")
, if isTypeGeneric t
then (templateGenericSetter insidePath p t memberName, [])
else instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName)) (FuncTy [p, t] p) (templateSetter typeEnv env (mangle memberName) t) ("sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "`.")
,instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName ++ "!")) (FuncTy [RefTy p, t] UnitTy) (templateMutatingSetter typeEnv env (mangle memberName) t) ("sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "` in place.")
else instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName)) (FuncTy [p, t] p StaticLifetimeTy) (templateSetter typeEnv env (mangle memberName) t) ("sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "`.")
,instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName ++ "!")) (FuncTy [RefTy p (VarTy "q"), t] UnitTy StaticLifetimeTy) (templateMutatingSetter typeEnv env (mangle memberName) t) ("sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "` in place.")
,instanceBinderWithDeps (SymPath insidePath ("update-" ++ memberName))
(FuncTy [p, RefTy (FuncTy [t] t)] p)
(FuncTy [p, RefTy (FuncTy [t] t (VarTy "fq")) (VarTy "q")] p StaticLifetimeTy)
(templateUpdater (mangle memberName))
("updates the `" ++ memberName ++ "` property of a `" ++ typeName ++ "` using a function `f`.")
]
@ -92,12 +92,12 @@ templatesForSingleMember typeEnv env insidePath p@(StructTy typeName _) (nameXOb
templateGetter :: String -> Ty -> Template
templateGetter member memberTy =
Template
(FuncTy [RefTy (VarTy "p")] (VarTy "t"))
(FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "t") StaticLifetimeTy)
(const (toTemplate "$t $NAME($(Ref p) p)"))
(const $
let fixForVoidStarMembers =
if isFunctionType memberTy && not (isTypeGeneric memberTy)
then "(" ++ tyToCLambdaFix (RefTy memberTy) ++ ")"
then "(" ++ tyToCLambdaFix (RefTy memberTy (VarTy "q")) ++ ")"
else ""
in toTemplate ("$DECL { return " ++ fixForVoidStarMembers ++ "(&(p->" ++ member ++ ")); }\n"))
(const [])
@ -108,7 +108,7 @@ templateSetter typeEnv env memberName memberTy =
let callToDelete = memberDeletion typeEnv env (memberName, memberTy)
in
Template
(FuncTy [VarTy "p", VarTy "t"] (VarTy "p"))
(FuncTy [VarTy "p", VarTy "t"] (VarTy "p") StaticLifetimeTy)
(const (toTemplate "$p $NAME($p p, $t newValue)"))
(const (toTemplate (unlines ["$DECL {"
,callToDelete
@ -122,23 +122,23 @@ templateSetter typeEnv env memberName memberTy =
-- | The template for setters of a generic deftype.
templateGenericSetter :: [String] -> Ty -> Ty -> String -> (String, Binder)
templateGenericSetter pathStrings originalStructTy@(StructTy typeName _) memberTy memberName =
defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy, memberTy] originalStructTy) docs
defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy, memberTy] originalStructTy StaticLifetimeTy) docs
where path = SymPath pathStrings ("set-" ++ memberName)
t = FuncTy [VarTy "p", VarTy "t"] (VarTy "p")
t = FuncTy [VarTy "p", VarTy "t"] (VarTy "p") StaticLifetimeTy
docs = "sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "`."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "$p $NAME($p p, $t newValue)"))
(\(FuncTy [_, memberTy] _) ->
(\(FuncTy [_, memberTy] _ _) ->
let callToDelete = memberDeletion typeEnv env (memberName, memberTy)
in toTemplate (unlines ["$DECL {"
,callToDelete
," p." ++ memberName ++ " = newValue;"
," return p;"
,"}\n"]))
(\(FuncTy [_, memberTy] _) ->
(\(FuncTy [_, memberTy] _ _) ->
if isManaged typeEnv memberTy
then depsOfPolymorphicFunction typeEnv env [] "delete" (typesDeleterFunctionType memberTy)
else [])
@ -148,7 +148,7 @@ templateMutatingSetter :: TypeEnv -> Env -> String -> Ty -> Template
templateMutatingSetter typeEnv env memberName memberTy =
let callToDelete = memberRefDeletion typeEnv env (memberName, memberTy)
in Template
(FuncTy [RefTy (VarTy "p"), VarTy "t"] UnitTy)
(FuncTy [RefTy (VarTy "p") (VarTy "q"), VarTy "t"] UnitTy StaticLifetimeTy)
(const (toTemplate "void $NAME($p* pRef, $t newValue)"))
(const (toTemplate (unlines ["$DECL {"
,callToDelete
@ -161,16 +161,16 @@ templateMutatingSetter typeEnv env memberName memberTy =
templateUpdater :: String -> Template
templateUpdater member =
Template
(FuncTy [VarTy "p", RefTy (FuncTy [VarTy "t"] (VarTy "t"))] (VarTy "p"))
(FuncTy [VarTy "p", RefTy (FuncTy [VarTy "t"] (VarTy "t") (VarTy "fq")) (VarTy "q")] (VarTy "p") StaticLifetimeTy)
(const (toTemplate "$p $NAME($p p, Lambda *updater)")) -- "Lambda" used to be: $(Fn [t] t)
(const (toTemplate (unlines ["$DECL {"
," p." ++ member ++ " = " ++ templateCodeForCallingLambda "(*updater)" (FuncTy [VarTy "t"] (VarTy "t")) ["p." ++ member] ++ ";"
," p." ++ member ++ " = " ++ templateCodeForCallingLambda "(*updater)" (FuncTy [VarTy "t"] (VarTy "t") (VarTy "fq")) ["p." ++ member] ++ ";"
," return p;"
,"}\n"])))
(\(FuncTy [_, RefTy t@(FuncTy fArgTys fRetTy)] _) ->
(\(FuncTy [_, RefTy t@(FuncTy fArgTys fRetTy _) _] _ _) ->
if isTypeGeneric fRetTy
then []
else [defineFunctionTypeAlias t, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) fRetTy)])
else [defineFunctionTypeAlias t, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) fRetTy StaticLifetimeTy)])
-- | Helper function to create the binder for the 'init' template.
binderForInit :: [String] -> Ty -> [XObj] -> Either TypeError (String, Binder)
@ -178,7 +178,7 @@ binderForInit insidePath structTy@(StructTy typeName _) [XObj (Arr membersXObjs)
if isTypeGeneric structTy
then Right (genericInit StackAlloc insidePath structTy membersXObjs)
else Right $ instanceBinder (SymPath insidePath "init")
(FuncTy (initArgListTypes membersXObjs) structTy)
(FuncTy (initArgListTypes membersXObjs) structTy StaticLifetimeTy)
(concreteInit StackAlloc structTy membersXObjs)
("creates a `" ++ typeName ++ "`.")
@ -190,33 +190,33 @@ initArgListTypes xobjs = map (\(_, x) -> fromJust (xobjToTy x)) (pairwise xobjs)
concreteInit :: AllocationMode -> Ty -> [XObj] -> Template
concreteInit allocationMode originalStructTy@(StructTy typeName typeVariables) membersXObjs =
Template
(FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p"))
(\(FuncTy _ concreteStructTy) ->
(FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p") StaticLifetimeTy)
(\(FuncTy _ concreteStructTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
memberPairs = memberXObjsToPairs correctedMembers
in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg memberPairs) ++ ")"))
(const (tokensForInit allocationMode typeName membersXObjs))
(\(FuncTy _ _) -> [])
(\(FuncTy _ _ _) -> [])
-- | The template for the 'init' and 'new' functions for a generic deftype.
genericInit :: AllocationMode -> [String] -> Ty -> [XObj] -> (String, Binder)
genericInit allocationMode pathStrings originalStructTy@(StructTy typeName _) membersXObjs =
defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath pathStrings "init"
t = FuncTy (map snd (memberXObjsToPairs membersXObjs)) originalStructTy
t = FuncTy (map snd (memberXObjsToPairs membersXObjs)) originalStructTy StaticLifetimeTy
docs = "creates a `" ++ typeName ++ "`."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
(FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p"))
(\(FuncTy _ concreteStructTy) ->
(FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p") StaticLifetimeTy)
(\(FuncTy _ concreteStructTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
memberPairs = memberXObjsToPairs correctedMembers
in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg memberPairs) ++ ")"))
(const (tokensForInit allocationMode typeName membersXObjs))
(\(FuncTy _ concreteStructTy) ->
(\(FuncTy _ concreteStructTy _) ->
case concretizeType typeEnv concreteStructTy of
Left err -> error (show err ++ ". This error should not crash the compiler - change return type to Either here.")
Right ok -> ok
@ -242,9 +242,9 @@ memberArg (memberName, memberTy) =
-- | If the type is just a type variable; create a template type variable by appending $ in front of it's name
templatizeTy :: Ty -> Ty
templatizeTy (VarTy vt) = VarTy ("$" ++ vt)
templatizeTy (FuncTy argTys retTy) = FuncTy (map templatizeTy argTys) (templatizeTy retTy)
templatizeTy (FuncTy argTys retTy ltTy) = FuncTy (map templatizeTy argTys) (templatizeTy retTy) (templatizeTy ltTy)
templatizeTy (StructTy name tys) = StructTy name (map templatizeTy tys)
templatizeTy (RefTy t) = RefTy (templatizeTy t)
templatizeTy (RefTy t lt) = RefTy (templatizeTy t) (templatizeTy lt)
templatizeTy (PointerTy t) = PointerTy (templatizeTy t)
templatizeTy t = t
@ -254,7 +254,7 @@ binderForStrOrPrn typeEnv env insidePath structTy@(StructTy typeName _) [XObj (A
if isTypeGeneric structTy
then Right (genericStr insidePath structTy membersXObjs strOrPrn, [])
else Right (instanceBinderWithDeps (SymPath insidePath strOrPrn)
(FuncTy [RefTy structTy] StringTy)
(FuncTy [RefTy structTy (VarTy "q")] StringTy StaticLifetimeTy)
(concreteStr typeEnv env structTy (memberXObjsToPairs membersXObjs) strOrPrn)
("converts a `" ++ typeName ++ "` to a string."))
@ -262,11 +262,11 @@ binderForStrOrPrn typeEnv env insidePath structTy@(StructTy typeName _) [XObj (A
concreteStr :: TypeEnv -> Env -> Ty -> [(String, Ty)] -> String -> Template
concreteStr typeEnv env concreteStructTy@(StructTy typeName _) memberPairs strOrPrn =
Template
(FuncTy [RefTy concreteStructTy] StringTy)
(\(FuncTy [RefTy structTy] StringTy) -> toTemplate $ "String $NAME(" ++ tyToCLambdaFix structTy ++ " *p)")
(\(FuncTy [RefTy structTy@(StructTy _ concreteMemberTys)] StringTy) ->
(FuncTy [RefTy concreteStructTy (VarTy "q")] StringTy StaticLifetimeTy)
(\(FuncTy [RefTy structTy _] StringTy _) -> toTemplate $ "String $NAME(" ++ tyToCLambdaFix structTy ++ " *p)")
(\(FuncTy [RefTy structTy@(StructTy _ concreteMemberTys) _] StringTy _) ->
tokensForStr typeEnv env typeName memberPairs concreteStructTy)
(\ft@(FuncTy [RefTy structTy@(StructTy _ concreteMemberTys)] StringTy) ->
(\ft@(FuncTy [RefTy structTy@(StructTy _ concreteMemberTys) (VarTy "q")] StringTy _) ->
concatMap (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv)
(filter (\t -> (not . isExternalType typeEnv) t && (not . isFullyGenericType) t)
(map snd memberPairs)))
@ -276,21 +276,21 @@ genericStr :: [String] -> Ty -> [XObj] -> String -> (String, Binder)
genericStr pathStrings originalStructTy@(StructTy typeName varTys) membersXObjs strOrPrn =
defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath pathStrings strOrPrn
t = FuncTy [RefTy originalStructTy] StringTy
t = FuncTy [RefTy originalStructTy (VarTy "q")] StringTy StaticLifetimeTy
members = memberXObjsToPairs membersXObjs
docs = "converts a `" ++ typeName ++ "` to a string."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(\(FuncTy [RefTy concreteStructTy] StringTy) ->
(\(FuncTy [RefTy concreteStructTy _] StringTy _) ->
toTemplate $ "String $NAME(" ++ tyToCLambdaFix concreteStructTy ++ " *p)")
(\(FuncTy [RefTy concreteStructTy@(StructTy _ concreteMemberTys)] StringTy) ->
(\(FuncTy [RefTy concreteStructTy@(StructTy _ concreteMemberTys) _] StringTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
memberPairs = memberXObjsToPairs correctedMembers
in tokensForStr typeEnv env typeName memberPairs concreteStructTy)
(\ft@(FuncTy [RefTy concreteStructTy@(StructTy _ concreteMemberTys)] StringTy) ->
(\ft@(FuncTy [RefTy concreteStructTy@(StructTy _ concreteMemberTys) _] StringTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
memberPairs = memberXObjsToPairs correctedMembers
@ -339,30 +339,30 @@ binderForDelete typeEnv env insidePath structTy@(StructTy typeName _) [XObj (Arr
if isTypeGeneric structTy
then Right (genericDelete insidePath structTy membersXObjs, [])
else Right (instanceBinderWithDeps (SymPath insidePath "delete")
(FuncTy [structTy] UnitTy)
(FuncTy [structTy] UnitTy StaticLifetimeTy)
(concreteDelete typeEnv env (memberXObjsToPairs membersXObjs))
("deletes a `" ++ typeName ++"`."))
-- | The template for the 'delete' function of a generic deftype.
genericDelete :: [String] -> Ty -> [XObj] -> (String, Binder)
genericDelete pathStrings originalStructTy@(StructTy typeName _) membersXObjs =
defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy] UnitTy) docs
defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy] UnitTy StaticLifetimeTy) docs
where path = SymPath pathStrings "delete"
t = FuncTy [VarTy "p"] UnitTy
t = FuncTy [VarTy "p"] UnitTy StaticLifetimeTy
docs = "deletes a `" ++ typeName ++ "`. Should usually not be called manually."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "void $NAME($p p)"))
(\(FuncTy [concreteStructTy] UnitTy) ->
(\(FuncTy [concreteStructTy] UnitTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
memberPairs = memberXObjsToPairs correctedMembers
in (toTemplate $ unlines [ "$DECL {"
, joinWith "\n" (map (memberDeletion typeEnv env) memberPairs)
, "}"]))
(\(FuncTy [concreteStructTy] UnitTy) ->
(\(FuncTy [concreteStructTy] UnitTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
memberPairs = memberXObjsToPairs correctedMembers
@ -377,28 +377,28 @@ binderForCopy typeEnv env insidePath structTy@(StructTy typeName _) [XObj (Arr m
if isTypeGeneric structTy
then Right (genericCopy insidePath structTy membersXObjs, [])
else Right (instanceBinderWithDeps (SymPath insidePath "copy")
(FuncTy [RefTy structTy] structTy)
(FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy)
(concreteCopy typeEnv env (memberXObjsToPairs membersXObjs))
("copies a `" ++ typeName ++ "`."))
-- | The template for the 'copy' function of a generic deftype.
genericCopy :: [String] -> Ty -> [XObj] -> (String, Binder)
genericCopy pathStrings originalStructTy@(StructTy typeName _) membersXObjs =
defineTypeParameterizedTemplate templateCreator path (FuncTy [RefTy originalStructTy] originalStructTy) docs
defineTypeParameterizedTemplate templateCreator path (FuncTy [RefTy originalStructTy (VarTy "q")] originalStructTy StaticLifetimeTy) docs
where path = SymPath pathStrings "copy"
t = FuncTy [RefTy (VarTy "p")] (VarTy "p")
t = FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy
docs = "copies the `" ++ typeName ++ "`."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "$p $NAME($p* pRef)"))
(\(FuncTy [RefTy concreteStructTy] _) ->
(\(FuncTy [RefTy concreteStructTy _] _ _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
memberPairs = memberXObjsToPairs correctedMembers
in tokensForCopy typeEnv env memberPairs)
(\(FuncTy [RefTy concreteStructTy] _) ->
(\(FuncTy [RefTy concreteStructTy _] _ _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
memberPairs = memberXObjsToPairs correctedMembers

26
src/Emit.hs
View File

@ -111,7 +111,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
'\\' -> "'\\\\'"
x -> ['\'', x, '\'']
Sym _ _ -> visitSymbol indent xobj
Defn -> error (show (DontVisitObj xobj))
(Defn _) -> error (show (DontVisitObj xobj))
Def -> error (show (DontVisitObj xobj))
Let -> error (show (DontVisitObj xobj))
If -> error (show (DontVisitObj xobj))
@ -181,13 +181,13 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
visitList indent (XObj (Lst xobjs) (Just i) t) =
case xobjs of
-- Defn
[XObj Defn _ _, XObj (Sym path@(SymPath _ name) _) _ _, XObj (Arr argList) _ _, body] ->
[XObj (Defn _) _ _, XObj (Sym path@(SymPath _ name) _) _ _, XObj (Arr argList) _ _, body] ->
case toCMode of
Globals ->
return ""
_ ->
do let innerIndent = indent + indentAmount
Just (FuncTy _ retTy) = t
Just (FuncTy _ retTy _) = t
defnDecl = defnToDeclaration meta path argList retTy
appendToSrc (defnDecl ++ " {\n")
when (name == "main") $
@ -200,7 +200,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
return ""
-- Fn / λ
[XObj (Fn name set) _ _, XObj (Arr argList) _ _, body] ->
[XObj (Fn name set _) _ _, XObj (Arr argList) _ _, body] ->
do let retVar = freshVar i
capturedVars = Set.toList set
Just callback = name
@ -499,7 +499,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
let funcTy = case ty func of
Just actualType -> actualType
_ -> error ("No type on func " ++ show func)
FuncTy argTys retTy = funcTy
FuncTy argTys retTy _ = funcTy
callFunction = overriddenName ++ "(" ++ argListAsC ++ ");\n"
if retTy == UnitTy
then do appendToSrc (addIndent indent ++ callFunction)
@ -511,7 +511,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
-- Function application (global symbols that are functions -- lambdas stored in def:s need to be called like locals, see below)
func@(XObj (Sym path (LookupGlobal mode AFunction)) _ _) : args ->
do argListAsC <- createArgList indent (mode == ExternalCode) args
let Just (FuncTy _ retTy) = ty func
let Just (FuncTy _ retTy _) = ty func
funcToCall = pathToC path
if retTy == UnitTy
then do appendToSrc (addIndent indent ++ funcToCall ++ "(" ++ argListAsC ++ ");\n")
@ -530,7 +530,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
let funcTy = case ty func of
Just actualType -> actualType
_ -> error ("No type on func " ++ show func)
FuncTy argTys retTy = funcTy
FuncTy argTys retTy _ = funcTy
castToFn =
if unwrapLambdas
then tyToCLambdaFix retTy ++ "(*)(" ++ joinWithComma (map tyToCRawFunctionPtrFix argTys) ++ ")"
@ -595,6 +595,10 @@ delete indent i = mapM_ deleterToC (infoDelete i)
where deleterToC :: Deleter -> State EmitterState ()
deleterToC FakeDeleter {} =
return ()
deleterToC PrimDeleter {} =
return ()
deleterToC RefDeleter {} =
return ()
deleterToC deleter@ProperDeleter{} =
appendToSrc $ addIndent indent ++ "" ++ pathToC (deleterPath deleter) ++ "(" ++ mangle (deleterVariable deleter) ++ ");\n"
@ -689,15 +693,15 @@ defSumtypeToDeclaration sumTy@(StructTy typeName typeVariables) path rest =
defaliasToDeclaration :: Ty -> SymPath -> String
defaliasToDeclaration t path =
case t of
(FuncTy argTys retTy) -> "typedef " ++ tyToCLambdaFix retTy ++ "(*" ++ pathToC path ++ ")(" ++
intercalate ", " (map tyToCLambdaFix argTys) ++ ");\n"
(FuncTy argTys retTy _) -> "typedef " ++ tyToCLambdaFix retTy ++ "(*" ++ pathToC path ++ ")(" ++
intercalate ", " (map tyToCLambdaFix argTys) ++ ");\n"
_ -> "typedef " ++ tyToC t ++ " " ++ pathToC path ++ ";\n"
toDeclaration :: Binder -> String
toDeclaration (Binder meta xobj@(XObj (Lst xobjs) _ t)) =
case xobjs of
[XObj Defn _ _, XObj (Sym path _) _ _, XObj (Arr argList) _ _, _] ->
let (Just (FuncTy _ retTy)) = t
[XObj (Defn _) _ _, XObj (Sym path _) _ _, XObj (Arr argList) _ _, _] ->
let (Just (FuncTy _ retTy _)) = t
in defnToDeclaration meta path argList retTy ++ ";\n"
[XObj Def _ _, XObj (Sym path _) _ _, _] ->
let Just t' = t

31
src/Eval.hs
View File

@ -147,12 +147,12 @@ eval env xobj =
_ -> return (makeEvalError ctx Nothing ("`if` condition contains non-boolean value: " ++ pretty okCondition) (info okCondition))
Left err -> return (Left err)
[XObj (Fn _ _) _ _, args@(XObj (Arr a) _ _), _] ->
[XObj (Fn b c _) d e, args@(XObj (Arr a) _ _), f] ->
if all isUnqualifiedSym a
then return (Right listXObj)
then return (Right (XObj (Lst [XObj (Fn b c (FEnv env)) d e, args, f]) i t))
else return (makeEvalError ctx Nothing ("`fn` requires all arguments to be unqualified symbols, but it got `" ++ pretty args ++ "`") (info xobj))
[defnExpr@(XObj Defn _ _), name, args@(XObj (Arr a) _ _), body] ->
[defnExpr@(XObj (Defn _) _ _), name, args@(XObj (Arr a) _ _), body] ->
case obj name of
(Sym (SymPath [] _) _) ->
if all isUnqualifiedSym a
@ -160,10 +160,10 @@ eval env xobj =
else return (makeEvalError ctx Nothing ("`defn` requires all arguments to be unqualified symbols, but it got `" ++ pretty args ++ "`") (info xobj))
_ -> return (makeEvalError ctx Nothing ("`defn` identifiers must be unqualified symbols, but it got `" ++ pretty name ++ "`") (info xobj))
[defnExpr@(XObj Defn _ _), name, invalidArgs, _] ->
[defnExpr@(XObj (Defn _) _ _), name, invalidArgs, _] ->
return (makeEvalError ctx Nothing ("`defn` requires an array of symbols as argument list, but it got `" ++ pretty invalidArgs ++ "`") (info xobj))
(defnExpr@(XObj Defn _ _) : _) ->
(defnExpr@(XObj (Defn _) _ _) : _) ->
return (makeEvalError ctx Nothing ("I didn’t understand the `defn` at " ++ prettyInfoFromXObj xobj ++ ":\n\n" ++ pretty xobj ++ "\n\nIs it valid? Every `defn` needs to follow the form `(defn name [arg] body)`.") Nothing)
[defExpr@(XObj Def _ _), name, expr] ->
@ -303,6 +303,15 @@ eval env xobj =
f:args -> do evaledF <- eval env f
case evaledF of
Right (XObj (Lst [XObj (Fn _ _ (FEnv e)) _ _, XObj (Arr params) _ _, body]) _ _) -> do
case checkMatchingNrOfArgs ctx fppl f params args of
Left err -> return (Left err)
Right () ->
do evaledArgs <- fmap sequence (mapM (eval env) args)
case evaledArgs of
Right okArgs -> apply e body params okArgs
Left err -> return (Left err)
Right (XObj (Lst [XObj Dynamic _ _, _, XObj (Arr params) _ _, body]) _ _) ->
case checkMatchingNrOfArgs ctx fppl f params args of
Left err -> return (Left err)
@ -606,7 +615,7 @@ define hidden ctx@(Context globalEnv typeEnv _ proj _ _) annXObj =
registerDefnOrDefInInterfaceIfNeeded :: Context -> XObj -> Either String Context
registerDefnOrDefInInterfaceIfNeeded ctx xobj =
case xobj of
XObj (Lst [XObj Defn _ _, XObj (Sym path _) _ _, _, _]) _ (Just t) ->
XObj (Lst [XObj (Defn _) _ _, XObj (Sym path _) _ _, _, _]) _ (Just t) ->
-- This is a function, does it belong to an interface?
registerInInterfaceIfNeeded ctx path t
XObj (Lst [XObj Def _ _, XObj (Sym path _) _ _, _]) _ (Just t) ->
@ -745,8 +754,8 @@ deftypeInternal nameXObj typeName typeVariableXObjs rest =
in do ctxWithDeps <- liftIO (foldM (define True) ctx' deps)
let ctxWithInterfaceRegistrations =
foldM (\context (path, sig) -> registerInInterfaceIfNeeded context path sig) ctxWithDeps
[(SymPath (pathStrings ++ [typeModuleName]) "str", FuncTy [RefTy structTy] StringTy)
,(SymPath (pathStrings ++ [typeModuleName]) "copy", FuncTy [RefTy structTy] structTy)]
[(SymPath (pathStrings ++ [typeModuleName]) "str", FuncTy [RefTy structTy (VarTy "q")] StringTy StaticLifetimeTy)
,(SymPath (pathStrings ++ [typeModuleName]) "copy", FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy)]
case ctxWithInterfaceRegistrations of
Left err -> liftIO (putStrLnWithColor Red err)
Right ok -> put ok
@ -1283,18 +1292,18 @@ printC xobj =
executeFunctionAsMain :: Context -> XObj -> StateT Context IO (Either EvalError XObj)
executeFunctionAsMain ctx expression =
let fppl = projectFilePathPrintLength (contextProj ctx)
tempMainFunction x = XObj (Lst [XObj Defn (Just dummyInfo) Nothing
tempMainFunction x = XObj (Lst [XObj (Defn Nothing) (Just dummyInfo) Nothing
,XObj (Sym (SymPath [] "main") Symbol) (Just dummyInfo) Nothing
,XObj (Arr []) (Just dummyInfo) Nothing
,case ty x of
Just UnitTy -> x
Just (RefTy _) -> XObj (Lst [XObj (Sym (SymPath [] "println*") Symbol) (Just dummyInfo) Nothing, x])
Just (RefTy _ _) -> XObj (Lst [XObj (Sym (SymPath [] "println*") Symbol) (Just dummyInfo) Nothing, x])
(Just dummyInfo) (Just UnitTy)
Just _ -> XObj (Lst [XObj (Sym (SymPath [] "println*") Symbol) (Just dummyInfo) Nothing,
XObj (Lst [XObj Ref (Just dummyInfo) Nothing, x])
(Just dummyInfo) (Just UnitTy)])
(Just dummyInfo) (Just UnitTy)
]) (Just dummyInfo) (Just (FuncTy [] UnitTy))
]) (Just dummyInfo) (Just (FuncTy [] UnitTy StaticLifetimeTy))
in do r <- annotateWithinContext False expression
case r of
Right (annXObj, annDeps) ->

4
src/Expand.hs
View File

@ -48,7 +48,7 @@ expand eval env xobj =
XObj (Instantiate _) _ _ : _ -> return (Right xobj)
XObj (Deftemplate _) _ _ : _ -> return (Right xobj)
XObj (Defalias _) _ _ : _ -> return (Right xobj)
[defnExpr@(XObj Defn _ _), name, args, body] ->
[defnExpr@(XObj (Defn _) _ _), name, args, body] ->
do expandedBody <- expand eval env body
return $ do okBody <- expandedBody
Right (XObj (Lst [defnExpr, name, args, okBody]) i t)
@ -169,7 +169,7 @@ expand eval env xobj =
Just (_, Binder _ (XObj (Lst (XObj (External _) _ _ : _)) _ _)) -> return (Right xobj)
Just (_, Binder _ (XObj (Lst (XObj (Instantiate _) _ _ : _)) _ _)) -> return (Right xobj)
Just (_, Binder _ (XObj (Lst (XObj (Deftemplate _) _ _ : _)) _ _)) -> return (Right xobj)
Just (_, Binder _ (XObj (Lst (XObj Defn _ _ : _)) _ _)) -> return (Right xobj)
Just (_, Binder _ (XObj (Lst (XObj (Defn _) _ _ : _)) _ _)) -> return (Right xobj)
Just (_, Binder _ (XObj (Lst (XObj Def _ _ : _)) _ _)) -> return (Right xobj)
Just (_, Binder _ (XObj (Lst (XObj (Defalias _) _ _ : _)) _ _)) -> return (Right xobj)
Just (_, Binder _ found) -> return (Right found) -- use the found value

44
src/GenerateConstraints.hs
View File

@ -3,7 +3,9 @@ module GenerateConstraints (genConstraints) where
import Data.List (foldl', sort, zipWith4)
import Control.Arrow
import Control.Monad.State
import Data.Maybe (mapMaybe)
import Data.Maybe (mapMaybe, fromMaybe)
import Data.Set as Set
import Data.List as List
import Debug.Trace (trace)
import Types
@ -16,24 +18,37 @@ import Lookup
-- | Will create a list of type constraints for a form.
genConstraints :: TypeEnv -> XObj -> Either TypeError [Constraint]
genConstraints typeEnv root = fmap sort (gen root)
where genF xobj args body =
where genF xobj args body captures =
do insideBodyConstraints <- gen body
xobjType <- toEither (ty xobj) (DefnMissingType xobj)
bodyType <- toEither (ty body) (ExpressionMissingType xobj)
let (FuncTy argTys retTy) = xobjType
let (FuncTy argTys retTy lifetimeTy) = xobjType
bodyConstr = Constraint retTy bodyType xobj body xobj OrdDefnBody
argConstrs = zipWith3 (\a b aObj -> Constraint a b aObj xobj xobj OrdArg) (map forceTy args) argTys args
return (bodyConstr : argConstrs ++ insideBodyConstraints)
argConstrs = zipWith3 (\a b aObj -> Constraint a b aObj xobj xobj OrdArg) (List.map forceTy args) argTys args
captureList :: [XObj]
captureList = Set.toList captures
capturesConstrs = mapMaybe id
(zipWith (\captureTy captureObj ->
case captureTy of
RefTy _ refLt ->
--trace ("Generated constraint between " ++ show lifetimeTy ++ " and " ++ show refLt) $
Just (Constraint lifetimeTy refLt captureObj xobj xobj OrdCapture)
_ ->
--trace ("Did not generate constraint for captured variable " ++ show captureObj) $
Nothing)
(List.map forceTy captureList)
captureList)
return (bodyConstr : argConstrs ++ insideBodyConstraints ++ capturesConstrs)
gen xobj =
case obj xobj of
Lst lst -> case lst of
-- Defn
[XObj Defn _ _, _, XObj (Arr args) _ _, body] ->
genF xobj args body
[XObj (Defn captures) _ _, _, XObj (Arr args) _ _, body] ->
genF xobj args body (fromMaybe Set.empty captures)
-- Fn
[XObj (Fn _ _) _ _, XObj (Arr args) _ _, body] ->
genF xobj args body
[XObj (Fn _ captures _) _ _, XObj (Arr args) _ _, body] ->
genF xobj args body captures
-- Def
[XObj Def _ _, _, expr] ->
@ -52,7 +67,7 @@ genConstraints typeEnv root = fmap sort (gen root)
wholeStatementConstraint = Constraint bodyType xobjTy body xobj xobj OrdLetBody
bindingsConstraints = zipWith (\(symTy, exprTy) (symObj, exprObj) ->
Constraint symTy exprTy symObj exprObj xobj OrdLetBind)
(map (forceTy *** forceTy) (pairwise bindings))
(List.map (forceTy *** forceTy) (pairwise bindings))
(pairwise bindings)
return (wholeStatementConstraint : insideBodyConstraints ++
bindingsConstraints ++ insideBindingsConstraints)
@ -172,7 +187,8 @@ genConstraints typeEnv root = fmap sort (gen root)
do insideValueConstraints <- gen value
xobjType <- toEither (ty xobj) (ExpressionMissingType xobj)
valueType <- toEither (ty value) (ExpressionMissingType value)
let theTheConstraint = Constraint (RefTy xobjType) valueType xobj value xobj OrdDeref
let lt = (VarTy (makeTypeVariableNameFromInfo (info xobj)))
let theTheConstraint = Constraint (RefTy xobjType lt) valueType xobj value xobj OrdDeref
return (theTheConstraint : insideValueConstraints)
-- Break
@ -185,7 +201,7 @@ genConstraints typeEnv root = fmap sort (gen root)
insideArgsConstraints <- fmap join (mapM gen args)
funcTy <- toEither (ty func) (ExpressionMissingType func)
case funcTy of
(FuncTy argTys retTy) ->
(FuncTy argTys retTy _) ->
if length args /= length argTys then
Left (WrongArgCount func (length argTys) (length args))
else
@ -193,7 +209,7 @@ genConstraints typeEnv root = fmap sort (gen root)
XObj (Sym (SymPath [] ("Expected " ++ enumerate n ++ " argument to '" ++ getName func ++ "'")) Symbol)
(info func) (Just t)
argConstraints = zipWith4 (\a t aObj n -> Constraint a t aObj (expected t n) xobj OrdFuncAppArg)
(map forceTy args)
(List.map forceTy args)
argTys
args
[0..]
@ -201,7 +217,7 @@ genConstraints typeEnv root = fmap sort (gen root)
retConstraint = Constraint xobjTy retTy xobj func xobj OrdFuncAppRet
in return (retConstraint : funcConstraints ++ argConstraints ++ insideArgsConstraints)
funcVarTy@(VarTy _) ->
let fabricatedFunctionType = FuncTy (map forceTy args) (forceTy xobj)
let fabricatedFunctionType = FuncTy (List.map forceTy args) (forceTy xobj) (VarTy "what?!")
expected = XObj (Sym (SymPath [] ("Calling '" ++ getName func ++ "'")) Symbol) (info func) Nothing
wholeTypeConstraint = Constraint funcVarTy fabricatedFunctionType func expected xobj OrdFuncAppVarTy
in return (wholeTypeConstraint : funcConstraints ++ insideArgsConstraints)

47
src/InitialTypes.hs
View File

@ -36,9 +36,10 @@ renameVarTys rootType = do n <- get
return result
where
rename :: Ty -> State (Integer, Map.Map String Ty) Ty
rename (FuncTy argTys retTy) = do argTys' <- mapM rename argTys
retTy' <- rename retTy
return (FuncTy argTys' retTy')
rename (FuncTy argTys retTy ltTy) = do ltTy' <- rename ltTy
argTys' <- mapM rename argTys
retTy' <- rename retTy
return (FuncTy argTys' retTy' ltTy')
rename (VarTy v) = do (n, mappings) <- get
case Map.lookup v mappings of
Just found -> return found
@ -52,8 +53,9 @@ renameVarTys rootType = do n <- get
rename (PointerTy x) = do x' <- rename x
return (PointerTy x')
rename (RefTy x) = do x' <- rename x
return (RefTy x')
rename (RefTy x lt) = do x' <- rename x
lt' <- rename lt
return (RefTy x' lt')
rename x = return x
@ -66,10 +68,12 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
visit env xobj = case obj xobj of
(Num t _) -> return (Right (xobj { ty = Just t }))
(Bol _) -> return (Right (xobj { ty = Just BoolTy }))
(Str _) -> return (Right (xobj { ty = Just (RefTy StringTy) }))
(Pattern _) -> return (Right (xobj { ty = Just (RefTy PatternTy) }))
(Str _) -> do lt <- genVarTy
return (Right (xobj { ty = Just (RefTy StringTy lt) }))
(Pattern _) -> do lt <- genVarTy
return (Right (xobj { ty = Just (RefTy PatternTy lt) }))
(Chr _) -> return (Right (xobj { ty = Just CharTy }))
Break -> return (Right (xobj { ty = Just (FuncTy [] UnitTy)}))
Break -> return (Right (xobj { ty = Just (FuncTy [] UnitTy StaticLifetimeTy)}))
(Command _) -> return (Right (xobj { ty = Just DynamicTy }))
(Lst _) -> visitList env xobj
(Arr _) -> visitArray env xobj
@ -77,9 +81,9 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
(Sym symPath _) -> visitSymbol env xobj symPath
(MultiSym _ paths) -> visitMultiSym env xobj paths
(InterfaceSym _) -> visitInterfaceSym env xobj
Defn -> return (Left (InvalidObj Defn xobj))
e@(Defn _) -> return (Left (InvalidObj e xobj))
Def -> return (Left (InvalidObj Def xobj))
e@(Fn _ _) -> return (Left (InvalidObj e xobj))
e@(Fn _ _ _) -> return (Left (InvalidObj e xobj))
Let -> return (Left (InvalidObj Let xobj))
If -> return (Left (InvalidObj If xobj))
While -> return (Left (InvalidObj While xobj))
@ -162,9 +166,9 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
visitList env xobj@(XObj (Lst xobjs) i _) =
case xobjs of
-- Defn
[defn@(XObj Defn _ _), nameSymbol@(XObj (Sym (SymPath _ name) _) _ _), XObj (Arr argList) argsi argst, body] ->
[defn@(XObj (Defn _) _ _), nameSymbol@(XObj (Sym (SymPath _ name) _) _ _), XObj (Arr argList) argsi argst, body] ->
do (argTypes, returnType, funcScopeEnv) <- getTys env argList
let funcTy = Just (FuncTy argTypes returnType)
let funcTy = Just (FuncTy argTypes returnType StaticLifetimeTy)
typedNameSymbol = nameSymbol { ty = funcTy }
-- TODO! After the introduction of 'LookupRecursive' this env shouldn't be needed anymore? (but it is for some reason...)
envWithSelf = extendEnv funcScopeEnv name typedNameSymbol
@ -174,13 +178,14 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
okArgs <- sequence visitedArgs
return (XObj (Lst [defn, nameSymbol, XObj (Arr okArgs) argsi argst, okBody]) i funcTy)
[XObj Defn _ _, XObj (Sym _ _) _ _, XObj (Arr _) _ _] -> return (Left (NoFormsInBody xobj))
XObj Defn _ _ : _ -> return (Left (InvalidObj Defn xobj))
[defn@(XObj (Defn _) _ _), XObj (Sym _ _) _ _, XObj (Arr _) _ _] -> return (Left (NoFormsInBody xobj))
(XObj defn@(Defn _) _ _) : _ -> return (Left (InvalidObj defn xobj))
-- Fn
[fn@(XObj (Fn _ _) _ _), XObj (Arr argList) argsi argst, body] ->
[fn@(XObj (Fn _ _ _) _ _), XObj (Arr argList) argsi argst, body] ->
do (argTypes, returnType, funcScopeEnv) <- getTys env argList
let funcTy = Just (FuncTy argTypes returnType)
lt <- genVarTy
let funcTy = Just (FuncTy argTypes returnType lt)
visitedBody <- visit funcScopeEnv body
visitedArgs <- mapM (visit funcScopeEnv) argList
return $ do okBody <- visitedBody
@ -188,8 +193,8 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
let final = XObj (Lst [fn, XObj (Arr okArgs) argsi argst, okBody]) i funcTy
return final --(trace ("FINAL: " ++ show final) final)
[XObj (Fn _ _) _ _, XObj (Arr _) _ _] -> return (Left (NoFormsInBody xobj)) -- TODO: Special error message for lambdas needed?
XObj fn@(Fn _ _) _ _ : _ -> return (Left (InvalidObj fn xobj))
[XObj (Fn _ _ _ ) _ _, XObj (Arr _) _ _] -> return (Left (NoFormsInBody xobj)) -- TODO: Special error message for lambdas needed?
XObj fn@(Fn _ _ _) _ _ : _ -> return (Left (InvalidObj fn xobj))
-- Def
[def@(XObj Def _ _), nameSymbol, expression]->
@ -313,9 +318,13 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
-- Ref
[refExpr@(XObj Ref _ _), value] ->
do visitedValue <- visit env value
lt <- case value of -- This is to not get lifetime errors when using globals. TODO: Is there a better way?!
XObj (Sym _ (LookupGlobal _ _)) _ _ -> return StaticLifetimeTy
_ | isLiteral value -> return StaticLifetimeTy
| otherwise -> genVarTy
return $ do okValue <- visitedValue
let Just valueTy = ty okValue
return (XObj (Lst [refExpr, okValue]) i (Just (RefTy valueTy)))
return (XObj (Lst [refExpr, okValue]) i (Just (RefTy valueTy lt)))
-- Deref (error!)
[XObj Deref _ _, value] ->

4
src/Lookup.hs
View File

@ -198,12 +198,12 @@ isManaged typeEnv (StructTy name _) =
)
isManaged _ StringTy = True
isManaged _ PatternTy = True
isManaged _ (FuncTy _ _) = True
isManaged _ (FuncTy _ _ _) = True
isManaged _ _ = False
-- | Is this type a function type?
isFunctionType :: Ty -> Bool
isFunctionType (FuncTy _ _) = True
isFunctionType (FuncTy _ _ _) = True
isFunctionType _ = False
-- | Is this type a struct type?

90
src/Obj.hs
View File

@ -55,9 +55,9 @@ data Obj = Sym SymPath SymbolMode
| Lst [XObj]
| Arr [XObj]
| Dict (Map.Map XObj XObj)
| Defn
| Defn (Maybe (Set.Set XObj)) -- if this is a lifted lambda it needs the set of captured variables
| Def
| Fn (Maybe SymPath) (Set.Set XObj) -- the name of the lifted function, and the set of variables this lambda captures
| Fn (Maybe SymPath) (Set.Set XObj) FnEnv -- the name of the lifted function, the set of variables this lambda captures, and a dynamic environment
| Do
| Let
| While
@ -123,16 +123,23 @@ data Info = Info { infoLine :: Int
dummyInfo :: Info
dummyInfo = Info 0 0 "dummy-file" Set.empty (-1)
-- TODO: The name 'deleter' for these things are really confusing!
data Deleter = ProperDeleter { deleterPath :: SymPath
, deleterVariable :: String
}
| FakeDeleter { deleterVariable :: String -- used for external types with no delete function
}
| PrimDeleter { aliveVariable :: String -- used by primitive types (i.e. Int) to signify that the variable is alive
}
| RefDeleter { refVariable :: String
}
deriving (Eq, Ord)
instance Show Deleter where
show (ProperDeleter path var) = "(ProperDel " ++ show path ++ " " ++ show var ++ ")"
show (FakeDeleter var) = "(FakeDel " ++ show var ++ ")"
show (PrimDeleter var) = "(PrimDel " ++ show var ++ ")"
show (RefDeleter var) = "(RefDel " ++ show var ++ ")"
getInfo i = (infoLine i, infoColumn i, infoFile i)
@ -180,7 +187,7 @@ data XObj = XObj { obj :: Obj
} deriving (Show, Eq, Ord)
getBinderDescription :: XObj -> String
getBinderDescription (XObj (Lst (XObj Defn _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "defn"
getBinderDescription (XObj (Lst (XObj (Defn _) _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "defn"
getBinderDescription (XObj (Lst (XObj Def _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "def"
getBinderDescription (XObj (Lst (XObj Macro _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "macro"
getBinderDescription (XObj (Lst (XObj Dynamic _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "dynamic"
@ -204,7 +211,7 @@ getSimpleName :: XObj -> String
getSimpleName xobj = let SymPath _ name = getPath xobj in name
getSimpleNameWithArgs :: XObj -> Maybe String
getSimpleNameWithArgs xobj@(XObj (Lst (XObj Defn _ _ : _ : XObj (Arr args) _ _ : _)) _ _) =
getSimpleNameWithArgs xobj@(XObj (Lst (XObj (Defn _) _ _ : _ : XObj (Arr args) _ _ : _)) _ _) =
Just $
"(" ++ getSimpleName xobj ++ (if not (null args) then " " else "") ++
unwords (map getSimpleName args) ++ ")"
@ -220,7 +227,7 @@ getSimpleNameWithArgs xobj = Nothing
-- | Extracts the second form (where the name of definitions are stored) from a list of XObj:s.
getPath :: XObj -> SymPath
getPath (XObj (Lst (XObj Defn _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
getPath (XObj (Lst (XObj (Defn _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
getPath (XObj (Lst (XObj Def _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
getPath (XObj (Lst (XObj Macro _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
getPath (XObj (Lst (XObj Dynamic _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
@ -239,7 +246,7 @@ getPath x = SymPath [] (pretty x)
-- | Changes the second form (where the name of definitions are stored) in a list of XObj:s.
setPath :: XObj -> SymPath -> XObj
setPath (XObj (Lst (defn@(XObj Defn _ _) : XObj (Sym _ _) si st : rest)) i t) newPath =
setPath (XObj (Lst (defn@(XObj (Defn _) _ _) : XObj (Sym _ _) si st : rest)) i t) newPath =
XObj (Lst (defn : XObj (Sym newPath Symbol) si st : rest)) i t
setPath (XObj (Lst [extr@(XObj (External _) _ _), XObj (Sym _ _) si st]) i t) newPath =
XObj (Lst [extr, XObj (Sym newPath Symbol) si st]) i t
@ -268,9 +275,11 @@ pretty = visit 0
MultiSym originalName paths -> originalName ++ "{" ++ joinWithComma (map show paths) ++ "}"
InterfaceSym name -> name -- ++ "§"
Bol b -> if b then "true" else "false"
Defn -> "defn"
Defn maybeCaptures -> "defn" ++ case maybeCaptures of
Just captures -> " <" ++ prettyCaptures captures ++ ">"
Nothing -> ""
Def -> "def"
Fn _ captures -> "fn" ++ " <" ++ joinWithComma (map getName (Set.toList captures)) ++ ">"
Fn _ captures _ -> "fn" ++ " <" ++ prettyCaptures captures ++ ">"
If -> "if"
Match -> "match"
While -> "while"
@ -299,6 +308,10 @@ pretty = visit 0
Interface _ _ -> "interface"
With -> "with"
prettyCaptures :: Set.Set XObj -> String
prettyCaptures captures =
joinWithComma (map (\x -> getName x ++ " : " ++ fromMaybe "" (fmap show (ty x))) (Set.toList captures))
data EvalError = EvalError String (Maybe Info) FilePathPrintLength deriving (Eq)
instance Show EvalError where
@ -381,7 +394,7 @@ showBinderIndented indent (name, Binder _ (XObj (Lst [XObj (Interface t paths) _
joinWith "\n " (map show paths) ++
"\n" ++ replicate indent ' ' ++ "}"
showBinderIndented indent (name, Binder meta xobj) =
if metaIsTrue meta "hidden"
if False -- metaIsTrue meta "hidden"
then ""
else replicate indent ' ' ++ name ++
-- " (" ++ show (getPath xobj) ++ ")" ++
@ -390,7 +403,11 @@ showBinderIndented indent (name, Binder meta xobj) =
-- | Get a list of pairs from a deftype declaration.
memberXObjsToPairs :: [XObj] -> [(String, Ty)]
memberXObjsToPairs xobjs = map (\(n, t) -> (mangle (getName n), fromJust (xobjToTy t))) (pairwise xobjs)
memberXObjsToPairs xobjs = map (\(n, t) -> (mangle (getName n), fromJustWithErrorMessage (xobjToTy t) ("Failed to convert " ++ show t ++ "\nPRETTY: " ++ pretty t ++ " from xobj to type."))) (pairwise xobjs)
fromJustWithErrorMessage :: Maybe Ty -> String -> Ty
fromJustWithErrorMessage (Just x) _ = x
fromJustWithErrorMessage Nothing msg = error msg
replaceGenericTypeSymbolsOnMembers :: Map.Map String Ty -> [XObj] -> [XObj]
replaceGenericTypeSymbolsOnMembers mappings memberXObjs =
@ -415,9 +432,10 @@ replaceGenericTypeSymbols _ xobj = xobj
tyToXObj :: Ty -> XObj
tyToXObj (StructTy n []) = XObj (Sym (SymPath [] n) Symbol) Nothing Nothing
tyToXObj (StructTy n vs) = XObj (Lst (XObj (Sym (SymPath [] n) Symbol) Nothing Nothing : map tyToXObj vs)) Nothing Nothing
tyToXObj (RefTy t) = XObj (Lst [XObj (Sym (SymPath [] "Ref") Symbol) Nothing Nothing, tyToXObj t]) Nothing Nothing
tyToXObj (RefTy t lt) = XObj (Lst [XObj (Sym (SymPath [] "Ref") Symbol) Nothing Nothing, tyToXObj t, tyToXObj lt]) Nothing Nothing
tyToXObj (PointerTy t) = XObj (Lst [XObj (Sym (SymPath [] "Ptr") Symbol) Nothing Nothing, tyToXObj t]) Nothing Nothing
tyToXObj (FuncTy argTys returnTy) = XObj (Lst [XObj (Sym (SymPath [] "Fn") Symbol) Nothing Nothing, XObj (Arr (map tyToXObj argTys)) Nothing Nothing, tyToXObj returnTy]) Nothing Nothing
tyToXObj (FuncTy argTys returnTy StaticLifetimeTy) = XObj (Lst [XObj (Sym (SymPath [] "Fn") Symbol) Nothing Nothing, XObj (Arr (map tyToXObj argTys)) Nothing Nothing, tyToXObj returnTy]) Nothing Nothing
tyToXObj (FuncTy argTys returnTy lt) = XObj (Lst [(XObj (Sym (SymPath [] "Fn") Symbol) Nothing Nothing), XObj (Arr (map tyToXObj argTys)) Nothing Nothing, tyToXObj returnTy, tyToXObj lt]) Nothing Nothing
tyToXObj x = XObj (Sym (SymPath [] (show x)) Symbol) Nothing Nothing
-- | Helper function to create binding pairs for registering external functions.
@ -438,6 +456,14 @@ data Env = Env { envBindings :: Map.Map String Binder
, envFunctionNestingLevel :: Int -- Normal defn:s have 0, lambdas get +1 for each level of nesting
} deriving (Show, Eq)
-- Could be (Maybe Env), but we have to get rid of equality
data FnEnv = None
| FEnv Env
deriving (Show)
instance Eq FnEnv where
_ == _ = True
newtype TypeEnv = TypeEnv { getTypeEnv :: Env }
instance Show TypeEnv where
@ -606,6 +632,7 @@ xobjToTy (XObj (Sym (SymPath _ "String") _) _ _) = Just StringTy
xobjToTy (XObj (Sym (SymPath _ "Pattern") _) _ _) = Just PatternTy
xobjToTy (XObj (Sym (SymPath _ "Char") _) _ _) = Just CharTy
xobjToTy (XObj (Sym (SymPath _ "Bool") _) _ _) = Just BoolTy
xobjToTy (XObj (Sym (SymPath _ "Static") _) _ _) = Just StaticLifetimeTy
xobjToTy (XObj (Sym (SymPath _ s@(firstLetter:_)) _) _ _) | isLower firstLetter = Just (VarTy s)
| otherwise = Just (StructTy s [])
xobjToTy (XObj (Lst [XObj (Sym (SymPath _ "Ptr") _) _ _, innerTy]) _ _) =
@ -613,12 +640,16 @@ xobjToTy (XObj (Lst [XObj (Sym (SymPath _ "Ptr") _) _ _, innerTy]) _ _) =
return (PointerTy okInnerTy)
xobjToTy (XObj (Lst (XObj (Sym (SymPath _ "Ptr") _) _ _ : _)) _ _) =
Nothing
xobjToTy (XObj (Lst [XObj (Sym (SymPath _ "Ref") _) _ _, innerTy]) _ _) =
xobjToTy (XObj (Lst [XObj (Sym (SymPath _ "Ref") _) _ _, innerTy]) i _) =
do okInnerTy <- xobjToTy innerTy
return (RefTy okInnerTy)
xobjToTy (XObj (Lst [XObj Ref i t, innerTy]) _ _) = -- This enables parsing of '&'
return (RefTy okInnerTy (VarTy (makeTypeVariableNameFromInfo i)))
xobjToTy (XObj (Lst [XObj (Sym (SymPath _ "Ref") _) _ _, innerTy, lifetimeTy]) _ _) =
do okInnerTy <- xobjToTy innerTy
return (RefTy okInnerTy)
okLifetimeTy <- xobjToTy lifetimeTy
return (RefTy okInnerTy okLifetimeTy)
xobjToTy (XObj (Lst [XObj Ref _ _, innerTy]) i _) = -- This enables parsing of '&'
do okInnerTy <- xobjToTy innerTy
return (RefTy okInnerTy (VarTy (makeTypeVariableNameFromInfo i)))
xobjToTy (XObj (Lst (XObj (Sym (SymPath _ "Ref") _) _ _ : _)) _ _) =
Nothing
xobjToTy (XObj (Lst [XObj (Sym (SymPath path "╬╗") _) fi ft, XObj (Arr argTys) ai at, retTy]) i t) =
@ -628,7 +659,12 @@ xobjToTy (XObj (Lst [XObj (Sym (SymPath path "λ") _) fi ft, XObj (Arr argTys) a
xobjToTy (XObj (Lst [XObj (Sym (SymPath _ "Fn") _) _ _, XObj (Arr argTys) _ _, retTy]) _ _) =
do okArgTys <- mapM xobjToTy argTys
okRetTy <- xobjToTy retTy
return (FuncTy okArgTys okRetTy)
return (FuncTy okArgTys okRetTy StaticLifetimeTy)
xobjToTy (XObj (Lst [XObj (Sym (SymPath _ "Fn") _) _ _, XObj (Arr argTys) _ _, retTy, lifetime]) _ _) =
do okArgTys <- mapM xobjToTy argTys
okRetTy <- xobjToTy retTy
okLifetime <- xobjToTy lifetime
return (FuncTy okArgTys okRetTy StaticLifetimeTy)
xobjToTy (XObj (Lst []) _ _) = Just UnitTy
xobjToTy (XObj (Lst (x:xs)) _ _) =
do okX <- xobjToTy x
@ -639,6 +675,12 @@ xobjToTy (XObj (Lst (x:xs)) _ _) =
_ -> Nothing
xobjToTy _ = Nothing
makeTypeVariableNameFromInfo :: Maybe Info -> String
makeTypeVariableNameFromInfo (Just i) =
"tyvar-from-info-" ++ show (infoIdentifier i) ++ "_" ++ show (infoLine i) ++ "_" ++ show (infoColumn i)
makeTypeVariableNameFromInfo Nothing =
error "unnamed-typevariable"
-- | Generates the suffix added to polymorphic functions when they are instantiated.
-- For example (defn id [x] x) : t -> t
-- might be invoked like this (id 5)
@ -661,12 +703,12 @@ polymorphicSuffix signature actualType =
then return []
else do put (a : visitedTypeVariables) -- now it's visited
return [tyToC b]
(FuncTy argTysA retTyA, FuncTy argTysB retTyB) -> do visitedArgs <- fmap concat (zipWithM visit argTysA argTysB)
visitedRets <- visit retTyA retTyB
return (visitedArgs ++ visitedRets)
(FuncTy argTysA retTyA _, FuncTy argTysB retTyB _) -> do visitedArgs <- fmap concat (zipWithM visit argTysA argTysB)
visitedRets <- visit retTyA retTyB
return (visitedArgs ++ visitedRets)
(StructTy _ a, StructTy _ b) -> fmap concat (zipWithM visit a b)
(PointerTy a, PointerTy b) -> visit a b
(RefTy a, RefTy b) -> visit a b
(RefTy a _, RefTy b _) -> visit a b
(_, _) -> return []
type VisitedTypes = [Ty]
@ -809,6 +851,12 @@ isArray :: XObj -> Bool
isArray (XObj (Arr _) _ _) = True
isArray _ = False
isLiteral :: XObj -> Bool
isLiteral (XObj (Num _ _) _ _) = True
isLiteral (XObj (Chr _) _ _) = True
isLiteral (XObj (Bol _) _ _) = True
isLiteral _ = False
-- construct an empty list xobj
emptyList :: XObj
emptyList = XObj (Lst []) Nothing Nothing

8
src/Parsing.hs
View File

@ -110,8 +110,8 @@ parseInternalPattern = do maybeAnchor <- Parsec.optionMaybe (Parsec.char '^')
_ <- Parsec.char '\\'
c <- Parsec.oneOf ['1', '2', '3', '4', '5', '6', '7', '8', '9',
'a', 'c', 'd', 'g', 'l', 'p', 's', 'u', 'w',
'x', 'n', 't', 'b', 'f', '[', ']', '\\', '$',
'(', ')', '^', '"', '*', '.', '-']
'x', 'n', 'r', 't', 'b', 'f', '[', ']', '\\',
'$', '(', ')', '^', '"', '*', '.', '-']
case c of
'b' -> do c1 <- Parsec.noneOf ['"']
c2 <- Parsec.noneOf ['"']
@ -223,12 +223,12 @@ symbol = do i <- createInfo
i Nothing)
else
case last segments of
"defn" -> return (XObj Defn i Nothing)
"defn" -> return (XObj (Defn Nothing) i Nothing)
"def" -> return (XObj Def i Nothing)
-- TODO: What about the other def- forms?
"do" -> return (XObj Do i Nothing)
"while" -> return (XObj While i Nothing)
"fn" -> return (XObj (Fn Nothing Set.empty) i Nothing)
"fn" -> return (XObj (Fn Nothing Set.empty None) i Nothing)
"let" -> return (XObj Let i Nothing)
"break" -> return (XObj Break i Nothing)
"if" -> return (XObj If i Nothing)

4
src/Qualify.hs
View File

@ -23,7 +23,7 @@ setFullyQualifiedDefn xobj _ = error ("Can't set new path on " ++ show xobj)
-- | This must run after the 'setFullyQualifiedDefn' function has fixed the paths of all bindings in the environment.
-- | This function does NOT go into function-body scope environments and the like.
setFullyQualifiedSymbols :: TypeEnv -> Env -> Env -> XObj -> XObj
setFullyQualifiedSymbols typeEnv globalEnv env (XObj (Lst [defn@(XObj Defn _ _),
setFullyQualifiedSymbols typeEnv globalEnv env (XObj (Lst [defn@(XObj (Defn _) _ _),
sym@(XObj (Sym (SymPath _ functionName) _) _ _),
args@(XObj (Arr argsArr) _ _),
body])
@ -37,7 +37,7 @@ setFullyQualifiedSymbols typeEnv globalEnv env (XObj (Lst [defn@(XObj Defn _ _),
functionEnv = Env Map.empty (Just envWithSelf) Nothing [] InternalEnv 0
envWithArgs = foldl' (\e arg@(XObj (Sym (SymPath _ argSymName) _) _ _) -> extendEnv e argSymName arg) functionEnv argsArr
in XObj (Lst [defn, sym, args, setFullyQualifiedSymbols typeEnv globalEnv envWithArgs body]) i t
setFullyQualifiedSymbols typeEnv globalEnv env (XObj (Lst [fn@(XObj (Fn _ _) _ _),
setFullyQualifiedSymbols typeEnv globalEnv env (XObj (Lst [fn@(XObj (Fn _ _ _) _ _),
args@(XObj (Arr argsArr) _ _),
body])
i t) =

13
src/RenderDocs.hs
View File

@ -12,12 +12,23 @@ import Data.Maybe (fromMaybe)
import Data.Text.Lazy as T
import Data.Text as Text
import qualified Data.Map as Map
import qualified Data.List as List
import Debug.Trace
import Obj
import Types
import Util
import Path
import AssignTypes (typeVariablesInOrderOfAppearance)
-- TODO: Move the beautification to a much earlier place, preferably when the function is defined/concretized-
-- This might be a duplicate with the work in a PR by @jacereda
beautifyType :: Ty -> Ty
beautifyType t =
let tys = List.nub (typeVariablesInOrderOfAppearance t)
mappings = Map.fromList (List.zip (List.map (\(VarTy name) -> name) tys)
(List.map (VarTy . (:[])) ['a'..]))
in replaceTyVars mappings t
saveDocsForEnvs :: Project -> [(SymPath, Binder)] -> IO ()
saveDocsForEnvs ctx pathsAndEnvBinders =
@ -119,7 +130,7 @@ binderToHtml (Binder meta xobj) =
maybeNameAndArgs = getSimpleNameWithArgs xobj
description = getBinderDescription xobj
typeSignature = case ty xobj of
Just t -> show t
Just t -> show (beautifyType t) -- NOTE: This destroys user-defined names of type variables!
Nothing -> ""
metaMap = getMeta meta
docString = case Map.lookup "doc" metaMap of

8
src/Scoring.hs
View File

@ -64,11 +64,11 @@ depthOfType typeEnv visited selfName theType =
where
visitType :: Ty -> Int
visitType t@(StructTy name varTys) = depthOfStructType (tyToC t) varTys
visitType (FuncTy argTys retTy) =
visitType (FuncTy argTys retTy ltTy) =
-- trace ("Depth of args of " ++ show argTys ++ ": " ++ show (map (visitType . Just) argTys))
maximum (visitType retTy : fmap visitType argTys)
maximum (visitType ltTy : visitType retTy : fmap visitType argTys)
visitType (PointerTy p) = visitType p
visitType (RefTy r) = visitType r
visitType (RefTy r lt) = max (visitType r) (visitType lt)
visitType _ = 1
depthOfStructType :: String -> [Ty] -> Int
@ -98,7 +98,7 @@ scoreValueBinder globalEnv _ binder@(Binder _ (XObj (Lst (XObj (External _) _ _
(0, binder)
scoreValueBinder globalEnv visited binder@(Binder _ (XObj (Lst [XObj Def _ _, XObj (Sym path Symbol) _ _, body]) _ _)) =
(scoreBody globalEnv visited body, binder)
scoreValueBinder globalEnv visited binder@(Binder _ (XObj (Lst [XObj Defn _ _, XObj (Sym path Symbol) _ _, _, body]) _ _)) =
scoreValueBinder globalEnv visited binder@(Binder _ (XObj (Lst [XObj (Defn _) _ _, XObj (Sym path Symbol) _ _, _, body]) _ _)) =
(scoreBody globalEnv visited body, binder)
scoreValueBinder _ _ binder =
(0, binder)

36
src/StartingEnv.hs
View File

@ -67,7 +67,7 @@ pointerModule = Env { envBindings = bindings
templatePointerCopy :: (String, Binder)
templatePointerCopy = defineTemplate
(SymPath ["Pointer"] "copy")
(FuncTy [RefTy (PointerTy (VarTy "p"))] (PointerTy (VarTy "p")))
(FuncTy [RefTy (PointerTy (VarTy "p")) (VarTy "q")] (PointerTy (VarTy "p")) StaticLifetimeTy)
"copies a pointer `p`."
(toTemplate "$p* $NAME ($p** ptrRef)")
(toTemplate $ unlines ["$DECL {"
@ -77,7 +77,7 @@ templatePointerCopy = defineTemplate
templatePointerEqual = defineTemplate
(SymPath ["Pointer"] "eq")
(FuncTy [PointerTy (VarTy "p"), PointerTy (VarTy "p")] BoolTy)
(FuncTy [PointerTy (VarTy "p"), PointerTy (VarTy "p")] BoolTy StaticLifetimeTy)
"checks two pointers for equality."
(toTemplate "bool $NAME ($p *p1, $p *p2)")
(toTemplate $ unlines ["$DECL {"
@ -88,7 +88,7 @@ templatePointerEqual = defineTemplate
-- | A template function for converting pointers to ref (it's up to the user of this function to make sure that is a safe operation).
templatePointerToRef = defineTemplate
(SymPath ["Pointer"] "to-ref")
(FuncTy [PointerTy (VarTy "p")] (RefTy (VarTy "p")))
(FuncTy [PointerTy (VarTy "p")] (RefTy (VarTy "p") StaticLifetimeTy) StaticLifetimeTy)
"converts a pointer to a reference type. The user will have to ensure themselves that this is a safe operation."
(toTemplate "$p* $NAME ($p *p)")
(toTemplate $ unlines ["$DECL {"
@ -98,7 +98,7 @@ templatePointerToRef = defineTemplate
templatePointerAdd = defineTemplate
(SymPath ["Pointer"] "add")
(FuncTy [PointerTy (VarTy "p"), LongTy] (PointerTy (VarTy "p")))
(FuncTy [PointerTy (VarTy "p"), LongTy] (PointerTy (VarTy "p")) StaticLifetimeTy)
"adds a long integer value to a pointer."
(toTemplate "$p* $NAME ($p *p, long x)")
(toTemplate $ unlines ["$DECL {"
@ -108,7 +108,7 @@ templatePointerAdd = defineTemplate
templatePointerSub = defineTemplate
(SymPath ["Pointer"] "sub")
(FuncTy [PointerTy (VarTy "p"), LongTy] (PointerTy (VarTy "p")))
(FuncTy [PointerTy (VarTy "p"), LongTy] (PointerTy (VarTy "p")) StaticLifetimeTy)
"subtracts a long integer value from a pointer."
(toTemplate "$p* $NAME ($p *p, long x)")
(toTemplate $ unlines ["$DECL {"
@ -118,7 +118,7 @@ templatePointerSub = defineTemplate
templatePointerWidth = defineTemplate
(SymPath ["Pointer"] "width")
(FuncTy [PointerTy (VarTy "p")] LongTy)
(FuncTy [PointerTy (VarTy "p")] LongTy StaticLifetimeTy)
"gets the byte size of a pointer."
(toTemplate "long $NAME ($p *p)")
(toTemplate $ unlines ["$DECL {"
@ -128,7 +128,7 @@ templatePointerWidth = defineTemplate
templatePointerToLong = defineTemplate
(SymPath ["Pointer"] "to-long")
(FuncTy [PointerTy (VarTy "p")] LongTy)
(FuncTy [PointerTy (VarTy "p")] LongTy StaticLifetimeTy)
"converts a pointer to a long integer."
(toTemplate "long $NAME ($p *p)")
(toTemplate $ unlines ["$DECL {"
@ -138,7 +138,7 @@ templatePointerToLong = defineTemplate
templatePointerFromLong = defineTemplate
(SymPath ["Pointer"] "from-long")
(FuncTy [LongTy] (PointerTy (VarTy "p")))
(FuncTy [LongTy] (PointerTy (VarTy "p")) StaticLifetimeTy)
"converts a long integer to a pointer."
(toTemplate "$p* $NAME (long p)")
(toTemplate $ unlines ["$DECL {"
@ -161,7 +161,7 @@ systemModule = Env { envBindings = bindings
templateExit :: (String, Binder)
templateExit = defineTemplate
(SymPath ["System"] "exit")
(FuncTy [IntTy] (VarTy "a"))
(FuncTy [IntTy] (VarTy "a") StaticLifetimeTy)
"exits the program."
(toTemplate "$a $NAME (int code)")
(toTemplate $ unlines ["$DECL {"
@ -198,7 +198,7 @@ generateInnerFunctionModule arity =
where
alphabet = ['d'..'y']
charToTyName c = [c]
funcTy = FuncTy (take arity (map (VarTy . charToTyName) alphabet)) (VarTy "z")
funcTy = FuncTy (take arity (map (VarTy . charToTyName) alphabet)) (VarTy "z") StaticLifetimeTy
bindings = Map.fromList [ generateTemplateFuncCopy funcTy
, generateTemplateFuncDelete funcTy
, generateTemplateFuncStrOrPrn "str" "converts a function to a string." funcTy
@ -210,7 +210,7 @@ generateInnerFunctionModule arity =
generateTemplateFuncCopy :: Ty -> (String, Binder)
generateTemplateFuncCopy funcTy = defineTemplate
(SymPath ["Function"] "copy")
(FuncTy [RefTy funcTy] (VarTy "a"))
(FuncTy [RefTy funcTy (VarTy "q")] (VarTy "a") StaticLifetimeTy)
"copies a function."
(toTemplate "$a $NAME ($a* ref)")
(toTemplate $ unlines ["$DECL {"
@ -231,7 +231,7 @@ generateTemplateFuncCopy funcTy = defineTemplate
generateTemplateFuncDelete :: Ty -> (String, Binder)
generateTemplateFuncDelete funcTy = defineTemplate
(SymPath ["Function"] "delete")
(FuncTy [funcTy] UnitTy)
(FuncTy [funcTy] UnitTy StaticLifetimeTy)
"deletes a function."
(toTemplate "void $NAME (Lambda f)")
(toTemplate $ unlines ["$DECL {"
@ -246,7 +246,7 @@ generateTemplateFuncDelete funcTy = defineTemplate
generateTemplateFuncStrOrPrn :: String -> String -> Ty -> (String, Binder)
generateTemplateFuncStrOrPrn name docs funcTy = defineTemplate
(SymPath ["Function"] name)
(FuncTy [RefTy funcTy] StringTy)
(FuncTy [RefTy funcTy (VarTy "q")] StringTy StaticLifetimeTy)
docs
(toTemplate "String $NAME (Lambda *f)")
(toTemplate $ unlines ["$DECL {"
@ -357,7 +357,7 @@ dynamicProjectModule = Env { envBindings = bindings
templateEnumToInt :: (String, Binder)
templateEnumToInt = defineTemplate
(SymPath [] "enum-to-int")
(FuncTy [VarTy "a"] IntTy)
(FuncTy [VarTy "a"] IntTy StaticLifetimeTy)
"converts an enum `e` to an integer."
(toTemplate "int $NAME ($a e)")
(toTemplate $ unlines ["$DECL {"
@ -379,7 +379,7 @@ unsafeModule = Env { envBindings = bindings
templateCoerce :: (String, Binder)
templateCoerce = defineTemplate
(SymPath ["Unsafe"] "coerce")
(FuncTy [VarTy "b"] (VarTy "a"))
(FuncTy [VarTy "b"] (VarTy "a") StaticLifetimeTy)
"coerces a value of type b to a value of type a."
(toTemplate "$a $NAME ($b b)")
(toTemplate $ unlines ["$DECL {"
@ -417,15 +417,15 @@ startingTypeEnv = Env { envBindings = bindings
, envFunctionNestingLevel = 0
}
where bindings = Map.fromList
[ interfaceBinder "copy" (FuncTy [RefTy (VarTy "a")] (VarTy "a"))
[ interfaceBinder "copy" (FuncTy [RefTy (VarTy "a") (VarTy "q")] (VarTy "a") StaticLifetimeTy)
([SymPath ["Array"] "copy", SymPath ["Pointer"] "copy"] ++ registerFunctionFunctionsWithInterface "copy")
builtInSymbolInfo
, interfaceBinder "str" (FuncTy [VarTy "a"] StringTy)
, interfaceBinder "str" (FuncTy [VarTy "a"] StringTy StaticLifetimeTy)
(SymPath ["Array"] "str" : registerFunctionFunctionsWithInterface "str")
builtInSymbolInfo
, interfaceBinder "prn" (FuncTy [VarTy "a"] StringTy)
, interfaceBinder "prn" (FuncTy [VarTy "a"] StringTy StaticLifetimeTy)
(registerFunctionFunctionsWithInterface "prn")
builtInSymbolInfo
]

4
src/StructUtils.hs
View File

@ -7,8 +7,8 @@ import Lookup
import Polymorphism
memberInfo typeEnv memberTy =
let refOrNotRefType = if isManaged typeEnv memberTy then RefTy memberTy else memberTy
in (refOrNotRefType, if isManaged typeEnv memberTy then "&" else "", FuncTy [refOrNotRefType] StringTy)
let refOrNotRefType = if isManaged typeEnv memberTy then RefTy memberTy (VarTy "w") else memberTy -- OBS! The VarTy "w" here is dubious
in (refOrNotRefType, if isManaged typeEnv memberTy then "&" else "", FuncTy [refOrNotRefType] StringTy StaticLifetimeTy)
-- | Generate C code for converting a member variable to a string and appending it to a buffer.
memberPrn :: TypeEnv -> Env -> (String, Ty) -> String

68
src/Sumtypes.hs
View File

@ -63,33 +63,33 @@ binderForCaseInit insidePath structTy@(StructTy typeName _) sumtypeCase =
concreteCaseInit :: AllocationMode -> [String] -> Ty -> SumtypeCase -> (String, Binder)
concreteCaseInit allocationMode insidePath structTy sumtypeCase =
instanceBinder (SymPath insidePath (caseName sumtypeCase)) (FuncTy (caseTys sumtypeCase) structTy) template doc
instanceBinder (SymPath insidePath (caseName sumtypeCase)) (FuncTy (caseTys sumtypeCase) structTy StaticLifetimeTy) template doc
where doc = "creates a `" ++ caseName sumtypeCase ++ "`."
template =
Template
(FuncTy (caseTys sumtypeCase) (VarTy "p"))
(\(FuncTy _ concreteStructTy) ->
(FuncTy (caseTys sumtypeCase) (VarTy "p") StaticLifetimeTy)
(\(FuncTy _ concreteStructTy _) ->
let mappings = unifySignatures structTy concreteStructTy
correctedTys = map (replaceTyVars mappings) (caseTys sumtypeCase)
in (toTemplate $ "$p $NAME(" ++ joinWithComma (zipWith (curry memberArg) anonMemberNames correctedTys) ++ ")"))
(const (tokensForCaseInit allocationMode structTy sumtypeCase))
(\(FuncTy _ _) -> [])
(\(FuncTy _ _ _) -> [])
genericCaseInit :: AllocationMode -> [String] -> Ty -> SumtypeCase -> (String, Binder)
genericCaseInit allocationMode pathStrings originalStructTy sumtypeCase =
defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath pathStrings (caseName sumtypeCase)
t = FuncTy (caseTys sumtypeCase) originalStructTy
t = FuncTy (caseTys sumtypeCase) originalStructTy StaticLifetimeTy
docs = "creates a `" ++ caseName sumtypeCase ++ "`."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
(FuncTy (caseTys sumtypeCase) (VarTy "p"))
(\(FuncTy _ concreteStructTy) ->
(FuncTy (caseTys sumtypeCase) (VarTy "p") StaticLifetimeTy)
(\(FuncTy _ concreteStructTy _) ->
toTemplate $ "$p $NAME(" ++ joinWithComma (zipWith (curry memberArg) anonMemberNames (caseTys sumtypeCase)) ++ ")")
(\(FuncTy _ concreteStructTy) ->
(\(FuncTy _ concreteStructTy _) ->
tokensForCaseInit allocationMode concreteStructTy sumtypeCase)
(\(FuncTy _ concreteStructTy) ->
(\(FuncTy _ concreteStructTy _) ->
case concretizeType typeEnv concreteStructTy of
Left err -> error (show err ++ ". This error should not crash the compiler - change return type to Either here.")
Right ok -> ok)
@ -117,12 +117,12 @@ caseMemberAssignment allocationMode caseName (memberName, _) =
binderForTag :: [String] -> Ty -> Either TypeError (String, Binder)
binderForTag insidePath originalStructTy@(StructTy typeName _) =
Right $ instanceBinder path (FuncTy [RefTy originalStructTy] IntTy) template doc
Right $ instanceBinder path (FuncTy [RefTy originalStructTy (VarTy "q")] IntTy StaticLifetimeTy) template doc
where path = SymPath insidePath "get-tag"
template = Template
(FuncTy [RefTy originalStructTy] IntTy)
(\(FuncTy [RefTy structTy] IntTy) -> toTemplate $ proto structTy)
(\(FuncTy [RefTy structTy] IntTy) -> toTemplate $ proto structTy ++ " { return p->_tag; }")
(FuncTy [RefTy originalStructTy (VarTy "q")] IntTy StaticLifetimeTy)
(\(FuncTy [RefTy structTy _] IntTy _) -> toTemplate $ proto structTy)
(\(FuncTy [RefTy structTy _] IntTy _) -> toTemplate $ proto structTy ++ " { return p->_tag; }")
(\_ -> [])
proto structTy = "int $NAME(" ++ tyToCLambdaFix structTy ++ " *p)"
doc = "Gets the tag from a `" ++ typeName ++ "`."
@ -138,15 +138,15 @@ binderForStrOrPrn typeEnv env insidePath structTy@(StructTy typeName _) cases st
-- | The template for the 'str' function for a concrete deftype.
concreteStr :: TypeEnv -> Env -> [String] -> Ty -> [SumtypeCase] -> String -> (String, Binder)
concreteStr typeEnv env insidePath concreteStructTy@(StructTy typeName _) cases strOrPrn =
instanceBinder (SymPath insidePath strOrPrn) (FuncTy [RefTy concreteStructTy] StringTy) template doc
instanceBinder (SymPath insidePath strOrPrn) (FuncTy [RefTy concreteStructTy (VarTy "q")] StringTy StaticLifetimeTy) template doc
where doc = "converts a `" ++ typeName ++ "` to a string."
template =
Template
(FuncTy [RefTy concreteStructTy] StringTy)
(\(FuncTy [RefTy structTy] StringTy) -> toTemplate $ "String $NAME(" ++ tyToCLambdaFix structTy ++ " *p)")
(\(FuncTy [RefTy structTy@(StructTy _ concreteMemberTys)] StringTy) ->
(FuncTy [RefTy concreteStructTy (VarTy "q")] StringTy StaticLifetimeTy)
(\(FuncTy [RefTy structTy _] StringTy _) -> toTemplate $ "String $NAME(" ++ tyToCLambdaFix structTy ++ " *p)")
(\(FuncTy [RefTy structTy@(StructTy _ concreteMemberTys) _] StringTy _) ->
tokensForStr typeEnv env typeName cases concreteStructTy)
(\ft@(FuncTy [RefTy structTy@(StructTy _ concreteMemberTys)] StringTy) ->
(\ft@(FuncTy [RefTy structTy@(StructTy _ concreteMemberTys) _] StringTy _) ->
concatMap (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv)
(filter (\t -> (not . isExternalType typeEnv) t && (not . isFullyGenericType) t) (concatMap caseTys cases))
)
@ -156,19 +156,19 @@ genericStr :: [String] -> Ty -> [SumtypeCase] -> String -> (String, Binder)
genericStr insidePath originalStructTy@(StructTy typeName varTys) cases strOrPrn =
defineTypeParameterizedTemplate templateCreator path t docs
where path = SymPath insidePath strOrPrn
t = FuncTy [RefTy originalStructTy] StringTy
t = FuncTy [RefTy originalStructTy (VarTy "q")] StringTy StaticLifetimeTy
docs = "stringifies a `" ++ show typeName ++ "`."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(\(FuncTy [RefTy concreteStructTy] StringTy) ->
(\(FuncTy [RefTy concreteStructTy _] StringTy _) ->
toTemplate $ "String $NAME(" ++ tyToCLambdaFix concreteStructTy ++ " *p)")
(\(FuncTy [RefTy concreteStructTy@(StructTy _ concreteMemberTys)] StringTy) ->
(\(FuncTy [RefTy concreteStructTy@(StructTy _ concreteMemberTys) _] StringTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedCases = replaceGenericTypesOnCases mappings cases
in tokensForStr typeEnv env typeName correctedCases concreteStructTy)
(\ft@(FuncTy [RefTy concreteStructTy@(StructTy _ concreteMemberTys)] StringTy) ->
(\ft@(FuncTy [RefTy concreteStructTy@(StructTy _ concreteMemberTys) _] StringTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedCases = replaceGenericTypesOnCases mappings cases
tys = filter (\t -> (not . isExternalType typeEnv) t && (not . isFullyGenericType) t) (concatMap caseTys correctedCases)
@ -238,22 +238,22 @@ binderForDelete typeEnv env insidePath structTy@(StructTy typeName _) cases =
-- | The template for the 'delete' function of a generic sumtype.
genericSumtypeDelete :: [String] -> Ty -> [SumtypeCase] -> (String, Binder)
genericSumtypeDelete pathStrings originalStructTy cases =
defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy] UnitTy) docs
defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy] UnitTy StaticLifetimeTy) docs
where path = SymPath pathStrings "delete"
t = FuncTy [VarTy "p"] UnitTy
t = FuncTy [VarTy "p"] UnitTy StaticLifetimeTy
docs = "deletes a `" ++ show originalStructTy ++ "`. Should usually not be called manually."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "void $NAME($p p)"))
(\(FuncTy [concreteStructTy] UnitTy) ->
(\(FuncTy [concreteStructTy] UnitTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedCases = replaceGenericTypesOnCases mappings cases
in (toTemplate $ unlines [ "$DECL {"
, concatMap (deleteCase typeEnv env concreteStructTy) (zip correctedCases (True : repeat False))
, "}"]))
(\(FuncTy [concreteStructTy] UnitTy) ->
(\(FuncTy [concreteStructTy] UnitTy _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedCases = replaceGenericTypesOnCases mappings cases
in if isTypeGeneric concreteStructTy
@ -264,10 +264,10 @@ genericSumtypeDelete pathStrings originalStructTy cases =
-- | The template for the 'delete' function of a concrete sumtype
concreteSumtypeDelete :: [String] -> TypeEnv -> Env -> Ty -> [SumtypeCase] -> (String, Binder)
concreteSumtypeDelete insidePath typeEnv env structTy@(StructTy typeName _) cases =
instanceBinder (SymPath insidePath "delete") (FuncTy [structTy] UnitTy) template doc
instanceBinder (SymPath insidePath "delete") (FuncTy [structTy] UnitTy StaticLifetimeTy) template doc
where doc = "deletes a `" ++ typeName ++ "`. This should usually not be called manually."
template = Template
(FuncTy [VarTy "p"] UnitTy)
(FuncTy [VarTy "p"] UnitTy StaticLifetimeTy)
(const (toTemplate "void $NAME($p p)"))
(const (toTemplate $ unlines [ "$DECL {"
, concatMap (deleteCase typeEnv env structTy) (zip cases (True : repeat False))
@ -295,20 +295,20 @@ binderForCopy typeEnv env insidePath structTy@(StructTy typeName _) cases =
-- | The template for the 'copy' function of a generic sumtype.
genericSumtypeCopy :: [String] -> Ty -> [SumtypeCase] -> (String, Binder)
genericSumtypeCopy pathStrings originalStructTy cases =
defineTypeParameterizedTemplate templateCreator path (FuncTy [RefTy originalStructTy] originalStructTy) docs
defineTypeParameterizedTemplate templateCreator path (FuncTy [RefTy originalStructTy (VarTy "q")] originalStructTy StaticLifetimeTy) docs
where path = SymPath pathStrings "copy"
t = FuncTy [RefTy (VarTy "p")] (VarTy "p")
t = FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy
docs = "copies a `" ++ show originalStructTy ++ "`."
templateCreator = TemplateCreator $
\typeEnv env ->
Template
t
(const (toTemplate "$p $NAME($p* pRef)"))
(\(FuncTy [RefTy concreteStructTy] _) ->
(\(FuncTy [RefTy concreteStructTy _] _ _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedCases = replaceGenericTypesOnCases mappings cases
in tokensForSumtypeCopy typeEnv env concreteStructTy correctedCases)
(\(FuncTy [RefTy concreteStructTy] _) ->
(\(FuncTy [RefTy concreteStructTy _] _ _) ->
let mappings = unifySignatures originalStructTy concreteStructTy
correctedCases = replaceGenericTypesOnCases mappings cases
in if isTypeGeneric concreteStructTy
@ -319,10 +319,10 @@ genericSumtypeCopy pathStrings originalStructTy cases =
-- | The template for the 'copy' function of a concrete sumtype
concreteSumtypeCopy :: [String] -> TypeEnv -> Env -> Ty -> [SumtypeCase] -> (String, Binder)
concreteSumtypeCopy insidePath typeEnv env structTy@(StructTy typeName _) cases =
instanceBinder (SymPath insidePath "copy") (FuncTy [RefTy structTy] structTy) template doc
instanceBinder (SymPath insidePath "copy") (FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy) template doc
where doc = "copies a `" ++ typeName ++ "`."
template = Template
(FuncTy [RefTy (VarTy "p")] (VarTy "p"))
(FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy)
(const (toTemplate "$p $NAME($p* pRef)"))
(const (tokensForSumtypeCopy typeEnv env structTy cases))
(\_ -> concatMap (depsOfPolymorphicFunction typeEnv env [] "copy" . typesCopyFunctionType)

8
src/Template.hs
View File

@ -72,8 +72,8 @@ concretizeTypesInToken mappings cName decl token =
-- | The code needed to correctly call a lambda from C.
templateCodeForCallingLambda :: String -> Ty -> [String] -> String
templateCodeForCallingLambda functionName t args =
let FuncTy argTys retTy = t
castToFnWithEnv = tyToCast (FuncTy (lambdaEnvTy : argTys) retTy)
let FuncTy argTys retTy lt = t
castToFnWithEnv = tyToCast (FuncTy (lambdaEnvTy : argTys) retTy lt)
castToFn = tyToCast t
in
functionName ++ ".env ? " ++
@ -84,7 +84,7 @@ templateCodeForCallingLambda functionName t args =
-- | Must cast a lambda:s .callback member to the correct type to be able to call it.
tyToCast :: Ty -> String
tyToCast t =
let FuncTy argTys retTy = t
let FuncTy argTys retTy _ = t
in "§(Fn [" ++ joinWithSpace (map show argTys) ++ "] " ++ show retTy ++ ")" -- Note! The '§' means that the emitted type will be "raw" and not converted to 'Lambda'.
----------------------------------------------------------------------------------------------------------
@ -94,7 +94,7 @@ tyToCast t =
templateNoop :: (String, Binder)
templateNoop = defineTemplate
(SymPath [] "noop")
(FuncTy [PointerTy (VarTy "a")] UnitTy)
(FuncTy [PointerTy (VarTy "a")] UnitTy StaticLifetimeTy)
"accepts a pointer and will do nothing with it."
(toTemplate "void $NAME ($a* a)")
(toTemplate "$DECL { }")

17
src/TypeError.hs
View File

@ -52,6 +52,7 @@ data TypeError = SymbolMissingType XObj Env
| InvalidLetBinding [XObj] (XObj, XObj)
| DuplicateBinding XObj
| DefinitionsMustBeAtToplevel XObj
| UsingDeadReference XObj String
instance Show TypeError where
show (SymbolMissingType xobj env) =
@ -77,7 +78,7 @@ instance Show TypeError where
matches (keysInEnvEditDistance symPath env 3)
where matches [] = "Maybe you forgot to define it?"
matches x = "Maybe you wanted one of the following?\n " ++ joinWith "\n " (map (show . SymPath p) x)
show (InvalidObj Defn xobj) =
show (InvalidObj (Defn _) xobj) =
"I didn’t understand the function definition at " ++
prettyInfoFromXObj xobj ++
".\n\nIs it valid? Every `defn` needs to follow the form `(defn name [arg] body)`."
@ -235,6 +236,9 @@ instance Show TypeError where
show (DefinitionsMustBeAtToplevel xobj) =
"I encountered a definition that was not at top level: `" ++ pretty xobj ++ "`"
show (UsingDeadReference xobj dependsOn) =
"The reference '" ++ pretty xobj ++ "' (depending on the variable '" ++ dependsOn ++ "') isn't alive at " ++ prettyInfoFromXObj xobj ++ "."
machineReadableErrorStrings :: FilePathPrintLength -> TypeError -> [String]
machineReadableErrorStrings fppl err =
case err of
@ -253,7 +257,7 @@ machineReadableErrorStrings fppl err =
[machineReadableInfoFromXObj fppl xobj ++ " Trying to refer to an undefined symbol '" ++ show symPath ++ "'."]
(SymbolMissingType xobj env) ->
[machineReadableInfoFromXObj fppl xobj ++ " Symbol '" ++ getName xobj ++ "' missing type."]
(InvalidObj Defn xobj) ->
(InvalidObj (Defn _) xobj) ->
[machineReadableInfoFromXObj fppl xobj ++ " Invalid function definition."]
(InvalidObj If xobj) ->
[machineReadableInfoFromXObj fppl xobj ++ " Invalid if-statement."]
@ -353,6 +357,8 @@ machineReadableErrorStrings fppl err =
[machineReadableInfoFromXObj fppl xobj ++ " Duplicate binding `" ++ pretty xobj ++ "` inside `let`."]
(DefinitionsMustBeAtToplevel xobj) ->
[machineReadableInfoFromXObj fppl xobj ++ " Definition not at top level: `" ++ pretty xobj ++ "`"]
(UsingDeadReference xobj dependsOn) ->
[machineReadableInfoFromXObj fppl xobj ++ " The reference '" ++ pretty xobj ++ "' isn't alive."]
_ ->
[show err]
@ -363,11 +369,12 @@ joinedMachineReadableErrorStrings fppl err = joinWith "\n\n" (machineReadableErr
recursiveLookupTy :: TypeMappings -> Ty -> Ty
recursiveLookupTy mappings t = case t of
(VarTy v) -> fromMaybe t (recursiveLookup mappings v)
(RefTy r) -> RefTy (recursiveLookupTy mappings r)
(RefTy r lt) -> RefTy (recursiveLookupTy mappings r) (recursiveLookupTy mappings lt)
(PointerTy p) -> PointerTy (recursiveLookupTy mappings p)
(StructTy n innerTys) -> StructTy n (map (recursiveLookupTy mappings) innerTys)
(FuncTy argTys retTy) -> FuncTy (map (recursiveLookupTy mappings) argTys)
(recursiveLookupTy mappings retTy)
(FuncTy argTys retTy ltTy) -> FuncTy (map (recursiveLookupTy mappings) argTys)
(recursiveLookupTy mappings retTy)
(recursiveLookupTy mappings ltTy)
_ -> t
showTypeFromXObj :: TypeMappings -> XObj -> String

95
src/Types.hs
View File

@ -17,6 +17,7 @@ module Types ( TypeMappings
, consPath
, doesTypeContainTyVarWithName
, lambdaEnvTy
, typeEqIgnoreLifetimes
) where
import qualified Data.Map as Map
@ -34,12 +35,13 @@ data Ty = IntTy
| StringTy
| PatternTy
| CharTy
| FuncTy [Ty] Ty
| FuncTy [Ty] Ty Ty -- In order of appearance: (1) Argument types, (2) Return type, (3) Lifetime
| VarTy String
| UnitTy
| ModuleTy
| PointerTy Ty
| RefTy Ty
| RefTy Ty Ty -- second Ty is the lifetime
| StaticLifetimeTy
| StructTy String [Ty] -- the name of the struct, and it's type parameters
| TypeTy -- the type of types
| MacroTy
@ -47,6 +49,17 @@ data Ty = IntTy
| InterfaceTy
deriving (Eq, Ord)
-- Exactly like '==' for Ty, but ignore lifetime parameter
typeEqIgnoreLifetimes :: Ty -> Ty -> Bool
typeEqIgnoreLifetimes (RefTy a _) (RefTy b _) = a == b
typeEqIgnoreLifetimes (FuncTy argsA retA _) (FuncTy argsB retB _) =
all (== True) (zipWith typeEqIgnoreLifetimes argsA argsB) &&
typeEqIgnoreLifetimes retA retB
typeEqIgnoreLifetimes (StructTy a tyVarsA) (StructTy b tyVarsB) =
a == b &&
all (== True) (zipWith typeEqIgnoreLifetimes tyVarsA tyVarsB)
typeEqIgnoreLifetimes a b = a == b
data SumTyCase = SumTyCase { caseName :: String
, caseMembers :: [(String, Ty)]
} deriving (Show, Ord, Eq)
@ -66,7 +79,8 @@ instance Show Ty where
show StringTy = "String"
show PatternTy = "Pattern"
show CharTy = "Char"
show (FuncTy argTys retTy) = "(" ++ fnOrLambda ++ " [" ++ joinWithComma (map show argTys) ++ "] " ++ show retTy ++ ")"
show (FuncTy argTys retTy StaticLifetimeTy) = "(" ++ fnOrLambda ++ " [" ++ joinWithComma (map show argTys) ++ "] " ++ show retTy ++ ")"
show (FuncTy argTys retTy lt) = "(" ++ fnOrLambda ++ " [" ++ joinWithComma (map show argTys) ++ "] " ++ show retTy ++ " " ++ show lt ++ ")"
show (VarTy t) = t
show UnitTy = "()"
show ModuleTy = "Module"
@ -75,13 +89,15 @@ instance Show Ty where
show (StructTy s []) = s
show (StructTy s typeArgs) = "(" ++ s ++ " " ++ joinWithSpace (map show typeArgs) ++ ")"
show (PointerTy p) = "(Ptr " ++ show p ++ ")"
show (RefTy r) =
case r of
PointerTy _ -> listView
StructTy _ _ -> listView
FuncTy _ _ -> listView
_ -> "&" ++ show r
where listView = "(Ref " ++ show r ++ ")"
show (RefTy r lt) =
-- case r of
-- PointerTy _ -> listView
-- StructTy _ _ -> listView
-- FuncTy _ _ -> listView
-- _ -> "&" ++ show r
-- where listView = "(Ref " ++ show r ++ ")"
"(Ref " ++ show r ++ " " ++ show lt ++ ")"
show StaticLifetimeTy = "StaticLifetime"
show MacroTy = "Macro"
show DynamicTy = "Dynamic"
@ -93,14 +109,14 @@ tyToC :: Ty -> String
tyToC = tyToCManglePtr False
tyToCLambdaFix :: Ty -> String
tyToCLambdaFix t@(FuncTy _ _) = "Lambda"
tyToCLambdaFix (RefTy (FuncTy _ _)) = "Lambda*"
tyToCLambdaFix (RefTy (RefTy (FuncTy _ _))) = "Lambda**"
tyToCLambdaFix (RefTy (RefTy (RefTy (FuncTy _ _)))) = "Lambda***" -- | TODO: More cases needed?! What's a better way to do it..?
tyToCLambdaFix t@(FuncTy _ _ _) = "Lambda"
tyToCLambdaFix (RefTy (FuncTy _ _ _) _) = "Lambda*"
tyToCLambdaFix (RefTy (RefTy (FuncTy _ _ _) _) _) = "Lambda**"
tyToCLambdaFix (RefTy (RefTy (RefTy (FuncTy _ _ _) _) _) _) = "Lambda***" -- | TODO: More cases needed?! What's a better way to do it..?
tyToCLambdaFix t = tyToCManglePtr False t
tyToCRawFunctionPtrFix :: Ty -> String
tyToCRawFunctionPtrFix t@(FuncTy _ _) = "void*"
tyToCRawFunctionPtrFix t@(FuncTy _ _ _) = "void*"
tyToCRawFunctionPtrFix t = tyToCManglePtr False t
tyToCManglePtr :: Bool -> Ty -> String
@ -115,10 +131,10 @@ tyToCManglePtr _ PatternTy = "Pattern"
tyToCManglePtr _ CharTy = "char"
tyToCManglePtr _ UnitTy = "void"
tyToCManglePtr _ (VarTy x) = x
tyToCManglePtr _ (FuncTy argTys retTy) = "Fn__" ++ joinWithUnderscore (map (tyToCManglePtr True) argTys) ++ "_" ++ tyToCManglePtr True retTy
tyToCManglePtr _ (FuncTy argTys retTy _) = "Fn__" ++ joinWithUnderscore (map (tyToCManglePtr True) argTys) ++ "_" ++ tyToCManglePtr True retTy
tyToCManglePtr _ ModuleTy = error "Can't emit module type."
tyToCManglePtr b (PointerTy p) = tyToCManglePtr b p ++ (if b then mangle "*" else "*")
tyToCManglePtr b (RefTy r) = tyToCManglePtr b r ++ (if b then mangle "*" else "*")
tyToCManglePtr b (RefTy r _) = tyToCManglePtr b r ++ (if b then mangle "*" else "*")
tyToCManglePtr _ (StructTy s []) = mangle s
tyToCManglePtr _ (StructTy s typeArgs) = mangle s ++ "__" ++ joinWithUnderscore (map (tyToCManglePtr True) typeArgs)
tyToCManglePtr _ TypeTy = error "Can't emit the type of types."
@ -127,18 +143,22 @@ tyToCManglePtr _ DynamicTy = error "Can't emit the type of dynamic
isTypeGeneric :: Ty -> Bool
isTypeGeneric (VarTy _) = True
isTypeGeneric (FuncTy argTys retTy) = any isTypeGeneric argTys || isTypeGeneric retTy
isTypeGeneric (FuncTy argTys retTy _) = any isTypeGeneric argTys || isTypeGeneric retTy
isTypeGeneric (StructTy _ tyArgs) = any isTypeGeneric tyArgs
isTypeGeneric (PointerTy p) = isTypeGeneric p
isTypeGeneric (RefTy r) = isTypeGeneric r
isTypeGeneric (RefTy r _) = isTypeGeneric r
isTypeGeneric _ = False
doesTypeContainTyVarWithName :: String -> Ty -> Bool
doesTypeContainTyVarWithName name (VarTy n) = name == n
doesTypeContainTyVarWithName name (FuncTy argTys retTy) = any (doesTypeContainTyVarWithName name) argTys || doesTypeContainTyVarWithName name retTy
doesTypeContainTyVarWithName name (FuncTy argTys retTy lt) =
doesTypeContainTyVarWithName name lt ||
any (doesTypeContainTyVarWithName name) argTys ||
doesTypeContainTyVarWithName name retTy
doesTypeContainTyVarWithName name (StructTy _ tyArgs) = any (doesTypeContainTyVarWithName name) tyArgs
doesTypeContainTyVarWithName name (PointerTy p) = doesTypeContainTyVarWithName name p
doesTypeContainTyVarWithName name (RefTy r) = doesTypeContainTyVarWithName name r
doesTypeContainTyVarWithName name (RefTy r lt) = doesTypeContainTyVarWithName name r ||
doesTypeContainTyVarWithName name lt
doesTypeContainTyVarWithName _ _ = False
-- | Map type variable names to actual types, eg. t0 => Int, t1 => Float
@ -223,13 +243,15 @@ unifySignatures v t = Map.fromList (unify v t)
unify (PointerTy a) (PointerTy b) = unify a b
unify a@(PointerTy _) b = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b)
unify (RefTy a) (RefTy b) = unify a b
unify a@(RefTy _) b = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b)
unify (RefTy a ltA) (RefTy b ltB) = unify a b ++ unify ltA ltB
unify a@(RefTy _ _) b = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b)
unify (FuncTy argTysA retTyA) (FuncTy argTysB retTyB) = let argToks = concat (zipWith unify argTysA argTysB)
retToks = unify retTyA retTyB
in argToks ++ retToks
unify a@(FuncTy _ _) b = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b)
unify (FuncTy argTysA retTyA ltA) (FuncTy argTysB retTyB ltB) =
let argToks = concat (zipWith unify argTysA argTysB)
retToks = unify retTyA retTyB
ltToks = unify ltA ltB
in ltToks ++ argToks ++ retToks
unify a@(FuncTy _ _ _) b = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b)
unify a b | a == b = []
| otherwise = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b)
@ -246,14 +268,15 @@ areUnifiable (StructTy a aArgs) (StructTy b bArgs)
areUnifiable (StructTy _ _) _ = False
areUnifiable (PointerTy a) (PointerTy b) = areUnifiable a b
areUnifiable (PointerTy _) _ = False
areUnifiable (RefTy a) (RefTy b) = areUnifiable a b
areUnifiable (RefTy _) _ = False
areUnifiable (FuncTy argTysA retTyA) (FuncTy argTysB retTyB)
areUnifiable (RefTy a ltA) (RefTy b ltB) = areUnifiable a b && areUnifiable ltA ltB
areUnifiable (RefTy _ _) _ = False
areUnifiable (FuncTy argTysA retTyA ltA) (FuncTy argTysB retTyB ltB)
| length argTysA /= length argTysB = False
| otherwise = let argBools = zipWith areUnifiable argTysA argTysB
retBool = areUnifiable retTyA retTyB
in all (== True) (retBool : argBools)
areUnifiable (FuncTy _ _) _ = False
ltBool = areUnifiable ltA ltB
in all (== True) (ltBool : retBool : argBools)
areUnifiable (FuncTy _ _ _) _ = False
areUnifiable a b | a == b = True
| otherwise = False
@ -264,19 +287,19 @@ replaceTyVars :: TypeMappings -> Ty -> Ty
replaceTyVars mappings t =
case t of
(VarTy key) -> fromMaybe t (Map.lookup key mappings)
(FuncTy argTys retTy) -> FuncTy (map (replaceTyVars mappings) argTys) (replaceTyVars mappings retTy)
(FuncTy argTys retTy lt) -> FuncTy (map (replaceTyVars mappings) argTys) (replaceTyVars mappings retTy) (replaceTyVars mappings lt)
(StructTy name tyArgs) -> StructTy name (fmap (replaceTyVars mappings) tyArgs)
(PointerTy x) -> PointerTy (replaceTyVars mappings x)
(RefTy x) -> RefTy (replaceTyVars mappings x)
(RefTy x lt) -> RefTy (replaceTyVars mappings x) (replaceTyVars mappings lt)
_ -> t
-- | The type of a type's copying function.
typesCopyFunctionType :: Ty -> Ty
typesCopyFunctionType memberType = FuncTy [RefTy memberType] memberType
typesCopyFunctionType memberType = FuncTy [RefTy memberType (VarTy "q")] memberType StaticLifetimeTy
-- | The type of a type's deleter function.
typesDeleterFunctionType :: Ty -> Ty
typesDeleterFunctionType memberType = FuncTy [memberType] UnitTy
typesDeleterFunctionType memberType = FuncTy [memberType] UnitTy StaticLifetimeTy
isFullyGenericType (VarTy _) = True
isFullyGenericType _ = False

2
src/Validate.hs
View File

@ -44,7 +44,7 @@ canBeUsedAsMemberType typeEnv typeVariables t xobj =
StringTy -> return ()
PatternTy -> return ()
CharTy -> return ()
FuncTy _ _ -> return ()
FuncTy _ _ _ -> return ()
PointerTy inner -> do _ <- canBeUsedAsMemberType typeEnv typeVariables inner xobj
return ()
StructTy "Array" [inner] -> do _ <- canBeUsedAsMemberType typeEnv typeVariables inner xobj

8
test-for-errors/lambda_capturing_ref_that_dies.carp Normal file
View File

@ -0,0 +1,8 @@
(Project.config "file-path-print-length" "short")
(defn this-wont-work []
(let-do [s @"DATA"
r &s
f (fn [] (IO.println r))]
(delete s)
(f)))

7
test-for-errors/use_ref_after_free.carp Normal file
View File

@ -0,0 +1,7 @@
(Project.config "file-path-print-length" "short")
(defn f []
(let-do [data @"DATA"
r &data]
(delete data)
(IO.println r)))

6
test-for-errors/use_ref_arg_after_free.carp Normal file
View File

@ -0,0 +1,6 @@
(Project.config "file-path-print-length" "short")
(defn f [x]
(let-do [r &x]
(delete x)
(IO.println r)))

9
test-for-errors/use_ref_via_nth_after_free.carp Normal file
View File

@ -0,0 +1,9 @@
(Project.config "file-path-print-length" "short")
(defn f []
(let [xs [@"A" @"B" @"C"]
r (Array.unsafe-nth &xs 0) ;; The lifetime has to be propagated via the call to 'nth' for this to work
q r] ;; An extra copy of the ref just to make things more tricky
(do
(Array.delete xs)
(IO.println q))))

19
test/Spec.hs
View File

@ -175,11 +175,26 @@ testConstr34 = assertSolution
-- Same as testConstr34, except everything is wrapped in refs
testConstr35 = assertSolution
[Constraint (RefTy (VarTy "a")) (RefTy (StructTy "Pair" [(VarTy "x0"), (VarTy "y0")])) x x x OrdNo
,Constraint (RefTy (StructTy "Array" [(VarTy "a")])) (RefTy (StructTy "Array" [(StructTy "Pair" [(VarTy "x1"), (VarTy "y1")])])) x x x OrdNo]
[Constraint (RefTy (VarTy "a") (VarTy "lt0")) (RefTy (StructTy "Pair" [(VarTy "x0"), (VarTy "y0")]) (VarTy "lt1")) x x x OrdNo
,Constraint (RefTy (StructTy "Array" [(VarTy "a")]) (VarTy "lt2")) (RefTy (StructTy "Array" [(StructTy "Pair" [(VarTy "x1"), (VarTy "y1")])]) (VarTy "lt3")) x x x OrdNo]
[("a", (StructTy "Pair" [(VarTy "x0"), (VarTy "y0")]))
,("x0", (VarTy "x0"))
,("y0", (VarTy "y0"))
,("x1", (VarTy "x0"))
,("y1", (VarTy "y0"))
,("lt0", (VarTy "lt0"))
,("lt1", (VarTy "lt0"))
,("lt2", (VarTy "lt2"))
,("lt3", (VarTy "lt2"))
]
-- Ref types with lifetimes
-- testConstr36 = assertSolution
-- [Constraint (RefTy (VarTy "a")) (RefTy (StructTy "Pair" [(VarTy "x0"), (VarTy "y0")])) x x x OrdNo
-- ,Constraint (RefTy (StructTy "Array" [(VarTy "a")])) (RefTy (StructTy "Array" [(StructTy "Pair" [(VarTy "x1"), (VarTy "y1")])])) x x x OrdNo]
-- [("a", (StructTy "Pair" [(VarTy "x0"), (VarTy "y0")]))
-- ,("x0", (VarTy "x0"))
-- ,("y0", (VarTy "y0"))
-- ,("x1", (VarTy "x0"))
-- ,("y1", (VarTy "y0"))
-- ]

1
test/execute.sh
View File

@ -2,6 +2,7 @@
# Runs the executable and compares its output to the .expected file
echo $1
./carp.sh $1 --log-memory -x > test/output/$1.output.actual 2>&1
if ! diff test/output/$1.output.actual test/output/$1.output.expected; then

1
test/output/test-for-errors/lambda_capturing_ref_that_dies.carp.output.expected Normal file
View File

@ -0,0 +1 @@
lambda_capturing_ref_that_dies.carp:8:6 The reference 'f' isn't alive.

2
test/output/test-for-errors/trick_resolution.carp.output.expected
View File

@ -1,4 +1,4 @@
trick_resolution.carp:7:14 Can't find matching lookup for symbol 'blurgh' of type (λ [&String] Bool)
trick_resolution.carp:7:14 Can't find matching lookup for symbol 'blurgh' of type (λ [(Ref String t3)] Bool)
None of the possibilities have the correct signature:
A.blurgh : (λ [Int] Bool)
B.blurgh : (λ [Float] Bool)

1
test/output/test-for-errors/use_ref_after_free.carp.output.expected Normal file
View File

@ -0,0 +1 @@
use_ref_after_free.carp:7:17 The reference 'r' isn't alive.

1
test/output/test-for-errors/use_ref_arg_after_free.carp.output.expected Normal file
View File

@ -0,0 +1 @@
use_ref_arg_after_free.carp:6:17 The reference 'r' isn't alive.

1
test/output/test-for-errors/use_ref_via_nth_after_free.carp.output.expected Normal file
View File

@ -0,0 +1 @@
use_ref_via_nth_after_free.carp:9:19 The reference 'q' isn't alive.

7
test/pattern.carp
View File

@ -61,8 +61,7 @@
"matches? works as exptected II")
(assert-equal test
true
(and* (matches? #"\n" "\n") (matches? #"\n" "\r")
(matches? #"\n" "\r\n"))
(and (matches? #"\n" "\n") (matches? #"\r" "\r"))
"matches? works as exptected on newlines special case")
(assert-equal test
true
@ -84,6 +83,10 @@
"sub 2-3 3-4"
&(substitute #"(\d)-(\d)" "1-2 2-3 3-4" "sub" 1)
"substitute works as expected")
(assert-equal test
&[@"" @"1" @"2" @"3" @""]
&(split #"\-\-" "--1--2--3--")
"split works as expected")
(assert-equal test
"sub sub sub"
&(substitute #"(\d)-(\d)" "1-2 2-3 3-4" "sub" -1)