summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorErik Svedäng <erik.svedang@gmail.com>2021-09-04 14:30:31 +0200
committerGitHub <noreply@github.com>2021-09-04 14:30:31 +0200
commit784eabb12daf9cb1fe712706ff6cae1f9ad1b786 (patch)
tree32c6da462197ebebab83127b138c52ac6ab028a0
parentb11c2d36e50f445547f9edac755f24b60d70b32a (diff)
parent74d7d5767b42d55d91f16e8f113dcedb74eb3235 (diff)
Merge branch 'master' into fix-1261fix-1261
-rw-r--r--core/Array.carp6
-rw-r--r--core/Bench.carp3
-rw-r--r--core/Binary.carp1
-rw-r--r--core/BoolExtras.carp3
-rw-r--r--core/Byte.carp2
-rw-r--r--core/Char.carp1
-rw-r--r--core/Color.carp1
-rw-r--r--core/Control.carp2
-rw-r--r--core/ControlMacros.carp25
-rw-r--r--core/Core.carp1
-rw-r--r--core/Debug.carp2
-rw-r--r--core/Double.carp1
-rw-r--r--core/Dynamic.carp22
-rw-r--r--core/Filepath.carp1
-rw-r--r--core/Float.carp3
-rw-r--r--core/Function.carp1
-rw-r--r--core/GLFW.carp2
-rw-r--r--core/Generics.carp2
-rw-r--r--core/Gensym.carp2
-rw-r--r--core/Geometry.carp1
-rw-r--r--core/Heap.carp7
-rw-r--r--core/IO.carp4
-rw-r--r--core/Int.carp1
-rw-r--r--core/List.carp7
-rw-r--r--core/Long.carp2
-rw-r--r--core/Macros.carp4
-rw-r--r--core/Maybe.carp3
-rw-r--r--core/OpenGL.carp1
-rw-r--r--core/Pattern.carp3
-rw-r--r--core/Pointer.carp1
-rw-r--r--core/Random.carp1
-rw-r--r--core/Result.carp4
-rw-r--r--core/SDL.carp2
-rw-r--r--core/StaticArray.carp2
-rw-r--r--core/Statistics.carp2
-rw-r--r--core/StdInt.carp16
-rw-r--r--core/String.carp1
-rw-r--r--core/System.carp1
-rw-r--r--core/Test.carp14
-rw-r--r--core/Tuples.carp8
-rw-r--r--core/Unit.carp2
-rw-r--r--core/Unsafe.carp2
-rw-r--r--core/Vector.carp4
-rw-r--r--core/carp_float.h4
-rw-r--r--core/carp_string.h24
-rw-r--r--src/Commands.hs11
-rw-r--r--src/Concretize.hs920
-rw-r--r--src/Context.hs22
-rw-r--r--src/Deftype.hs8
-rw-r--r--src/Emit.hs17
-rw-r--r--src/Env.hs8
-rw-r--r--src/Eval.hs21
-rw-r--r--src/Forms.hs27
-rw-r--r--src/Obj.hs12
-rw-r--r--src/Parsing.hs10
-rw-r--r--src/Polymorphism.hs17
-rw-r--r--src/Primitives.hs48
-rw-r--r--src/Repl.hs12
-rw-r--r--src/Scoring.hs37
-rw-r--r--src/StartingEnv.hs1
-rw-r--r--src/SumtypeCase.hs14
-rw-r--r--src/Sumtypes.hs12
-rw-r--r--src/TypeError.hs3
-rw-r--r--src/Validate.hs38
-rw-r--r--test/control_macros.carp15
-rw-r--r--test/macros.carp9
-rw-r--r--test/regression.carp28
-rw-r--r--test/string.carp4
68 files changed, 955 insertions, 541 deletions
diff --git a/core/Array.carp b/core/Array.carp
index 8e444f1a..58d54357 100644
--- a/core/Array.carp
+++ b/core/Array.carp
@@ -18,6 +18,12 @@
body)
(set! %variable (+ %variable %step))))))))
+(doc Array "is the indexable collection data structure.
+
+Its literal uses brackets, so an array of integers would look like this:
+`[1 2 3]`. It provides both a functional and an imperative API, and is one of
+the core data structures of Carp. It is heap-allocated, for a stack-allocated
+variant you might want to check out [`StaticArray`](./StaticArray.html).")
(defmodule Array
(doc reduce "will reduce an array `xs` into a single value using a function `f` that takes the reduction thus far and the next value. The initial reduction value is `x`.
diff --git a/core/Bench.carp b/core/Bench.carp
index 079e88da..e6705cbd 100644
--- a/core/Bench.carp
+++ b/core/Bench.carp
@@ -2,6 +2,9 @@
(system-include "carp_bench.h")
+(doc Bench "is a module for benchmarking. The most important function of the
+module is [`Bench.bench`](#bench), which takes a function, benchmarks it, and
+prints the results.")
(defmodule Bench
(def- min-runs 50)
diff --git a/core/Binary.carp b/core/Binary.carp
index 8ef4ccf0..28909424 100644
--- a/core/Binary.carp
+++ b/core/Binary.carp
@@ -29,6 +29,7 @@
significant byte occurs first in a given byte sequence.")
(deftype ByteOrder LittleEndian BigEndian)
+(doc Binary "provides various helper functions to work with bits and bytes.")
(defmodule Binary
(register to-int16 (λ [Byte Byte] Uint16))
(register to-int32 (λ [Byte Byte Byte Byte] Uint32))
diff --git a/core/BoolExtras.carp b/core/BoolExtras.carp
new file mode 100644
index 00000000..603965b0
--- /dev/null
+++ b/core/BoolExtras.carp
@@ -0,0 +1,3 @@
+; this requires doc to work
+(doc Bool "is the basic boolean data type, inhabited by the values represented
+by the literals `true` and `false`.")
diff --git a/core/Byte.carp b/core/Byte.carp
index ade47163..8a53e8fd 100644
--- a/core/Byte.carp
+++ b/core/Byte.carp
@@ -1,5 +1,7 @@
(system-include "carp_byte.h")
+(doc Byte "is the data type for single bytes. Literals of type `Byte` are
+suffixed with `b`.")
(defmodule Byte
(register = (λ [Byte Byte] Bool))
(register copy (λ [&Byte] Byte))
diff --git a/core/Char.carp b/core/Char.carp
index 568679de..c5dd042a 100644
--- a/core/Char.carp
+++ b/core/Char.carp
@@ -1,5 +1,6 @@
(system-include "carp_char.h")
+(doc Char "is the single character data type.")
(defmodule Char
(register = (Fn [Char Char] Bool))
(register < (Fn [Char Char] Bool))
diff --git a/core/Color.carp b/core/Color.carp
index ccecd5e2..cd0ae661 100644
--- a/core/Color.carp
+++ b/core/Color.carp
@@ -1,3 +1,4 @@
+(doc Color "provides ANSI color operations.")
(defmodule Color
(hidden table)
(deftype Id
diff --git a/core/Control.carp b/core/Control.carp
index 29729fa8..d4f96e3b 100644
--- a/core/Control.carp
+++ b/core/Control.carp
@@ -1,5 +1,7 @@
;; This module contains functions that deal with functions, control flow, etc.
+(doc Control "contains functions that deal with functions, control flow, and
+other higher order concepts.")
(defmodule Control
(doc iterate "Apply function `f` `n` times, first to `start` and then to the result of `f`. TODO: Mention fix points.")
diff --git a/core/ControlMacros.carp b/core/ControlMacros.carp
index 327f56bf..47460d38 100644
--- a/core/ControlMacros.carp
+++ b/core/ControlMacros.carp
@@ -133,6 +133,13 @@ Example:
(defmacro forever-do [:rest forms]
(list 'while true (cons 'do forms)))
+ (doc ignore-do
+ ("Wraps side-effecting `forms` in a `do`, " false)
+ "ignoring all of their results."
+ "In other words, executes `forms` only for their side effects.")
+ (defmacro ignore-do [:rest forms]
+ (cons 'do (expand (apply ignore* forms))))
+
(doc when "is an `if` without an else branch.")
(defmacro when [condition form]
(list 'if condition form (list)))
@@ -141,6 +148,12 @@ Example:
(defmacro unless [condition form]
(list 'if condition (list) form))
+(hidden treat-case-handler)
+(defndynamic treat-case-handler [name handler]
+ (if (and (list? handler) (> (length handler) 1) (= ':or (car handler)))
+ (cons 'or (map (fn [val] (list '= name val)) (cdr handler)))
+ (list '= name handler)))
+
(hidden case-internal)
(defndynamic case-internal [name xs]
(if (= (length xs) 0)
@@ -150,24 +163,28 @@ Example:
(if (= (length xs) 1)
(car xs)
(list 'if
- (list '= name (car xs))
+ (treat-case-handler name (car xs))
(cadr xs)
(case-internal name (cddr xs)))))))
(doc case "takes a form and a list of branches which are value and operation
-pairs. If a value matches, the operation is executed. It takes a catch-all else
-branch that is executed if nothing matches.
+pairs. If a value matches (or any in a list of values preced by `:or`), the
+operation is executed. It takes a catch-all else branch that is executed if
+nothing matches.
Example:
```
(case (+ 10 1)
10 (println* \"nope\")
11 (println* \"yup\")
+ (:or 12 13) (println* \"multibranch, but nope\")
(println* \"else branch\")
)
```")
(defmacro case [form :rest branches]
- (case-internal form branches))
+ (let [name (gensym)]
+ (list 'let [name form]
+ (case-internal name branches))))
(defmodule Dynamic
(doc flip
diff --git a/core/Core.carp b/core/Core.carp
index 97eefad3..9d9d532d 100644
--- a/core/Core.carp
+++ b/core/Core.carp
@@ -19,6 +19,7 @@
(load-once "Blitable.carp")
(load-once "Bool.carp")
(load-once "Macros.carp")
+(load-once "BoolExtras.carp")
(load-once "List.carp")
(load-once "Derive.carp")
(load-once "Gensym.carp")
diff --git a/core/Debug.carp b/core/Debug.carp
index e2556d6d..228950bc 100644
--- a/core/Debug.carp
+++ b/core/Debug.carp
@@ -1,5 +1,7 @@
(system-include "carp_debug.h")
+(doc Debug "is a module that provides functions and commands to debug faulty
+programs and functions.")
(defmodule Debug
(doc sanitize-addresses "instructs the compiler to sanitize addresses.
diff --git a/core/Double.carp b/core/Double.carp
index 2f7b671e..833e51d5 100644
--- a/core/Double.carp
+++ b/core/Double.carp
@@ -1,5 +1,6 @@
(system-include "carp_double.h")
+(doc Double "is the default floating point number type.")
(defmodule Double
(def pi 3.141592653589793)
(implements pi Double.pi)
diff --git a/core/Dynamic.carp b/core/Dynamic.carp
index ccce54fe..e62b214a 100644
--- a/core/Dynamic.carp
+++ b/core/Dynamic.carp
@@ -2,6 +2,12 @@
(defmodule Dynamic
;; Functions for doing things at the REPL and during compile time.
+ (doc proc? "checks whether `x` is callable.")
+ (defndynamic proc? [x]
+ (or
+ (List.in? (dynamic-type x) '(fn closure))
+ (let [s (s-expr x)]
+ (and (not (empty? s)) (= 'dynamic (dynamic-type (car s)))))))
(doc nil "is the value `nil`, i.e. the empty list.")
(defdynamic nil '())
@@ -67,6 +73,22 @@ integers [`imod`](#imod).")
(defndynamic tail [s]
(String.suffix s 1))
)
+
+ (defmodule Debug
+ (doc trace "prints the value of an expression to `stdout`, then returns its value.")
+ (defmacro trace [x]
+ (let [sym (gensym)]
+ `(let-do [%sym %x]
+ ; we use eval here to ensure we resolve the symbol before putting it
+ ; into file, line, and column
+ (macro-log
+ %(eval `(file %x)) ":"
+ %(eval `(line %x)) ":"
+ %(eval `(column %x)) ": "
+ %sym)
+ %sym))
+ )
+ )
)
diff --git a/core/Filepath.carp b/core/Filepath.carp
index 3312fa21..9e39b380 100644
--- a/core/Filepath.carp
+++ b/core/Filepath.carp
@@ -1,3 +1,4 @@
+(doc Filepath "is a module that provides operations on paths to files.")
(defmodule Filepath
(use Array)
diff --git a/core/Float.carp b/core/Float.carp
index 56028ee8..73596daf 100644
--- a/core/Float.carp
+++ b/core/Float.carp
@@ -1,5 +1,7 @@
(system-include "carp_float.h")
+(doc Float "is a smaller numerical floating point type. Its literals are
+suffixed with `f`.")
(defmodule Float
(def pi 3.1415926536f)
(register MAX Float "CARP_FLT_MAX")
@@ -12,6 +14,7 @@
(register to-bytes (Fn [Float] Int))
(register from-int (Fn [Int] Float))
(register copy (Fn [(Ref Float)] Float))
+ (register round (Fn [Float] Int))
(register = (Fn [Float Float] Bool))
(register < (Fn [Float Float] Bool))
diff --git a/core/Function.carp b/core/Function.carp
index fd5046bd..75acae7d 100644
--- a/core/Function.carp
+++ b/core/Function.carp
@@ -1,3 +1,4 @@
+(doc Function "provides operations on functions.")
(defmodule Function
(doc unsafe-ptr "returns a void pointer to the function passed in.
diff --git a/core/GLFW.carp b/core/GLFW.carp
index 6f6fe2ce..831ee274 100644
--- a/core/GLFW.carp
+++ b/core/GLFW.carp
@@ -1,6 +1,8 @@
(system-include "GLFW/glfw3.h")
(add-pkg "glfw3")
+(doc GFLW "is a thin wrapper around the [GLFW](https://www.glfw.org/)
+library.")
(defmodule GLFW
;; Methods
(register init (λ [] Int) "glfwInit")
diff --git a/core/Generics.carp b/core/Generics.carp
index a42fa1c2..98ad01b2 100644
--- a/core/Generics.carp
+++ b/core/Generics.carp
@@ -1,5 +1,7 @@
;; The following generic functions make use of the interfaces
+(doc Generics "provides generic functions on top of the numerical interfaces
+`zero`, `inc`, `dec`, arithematic, and comparators.")
(defmodule Generics
(defn one [] (inc (zero)))
(defn minus-one [] (dec (zero)))
diff --git a/core/Gensym.carp b/core/Gensym.carp
index 78b91bd6..438c17ef 100644
--- a/core/Gensym.carp
+++ b/core/Gensym.carp
@@ -7,7 +7,7 @@
(doc gensym-with "Generates symbols dynamically, based on a symbol name.")
(defndynamic gensym-with [x]
(do
- (set! *gensym-counter* (inc *gensym-counter*))
+ (set! *gensym-counter* (+ *gensym-counter* 1))
(Symbol.concat [x (Symbol.from *gensym-counter*)])))
(doc gensym "Generates symbols dynamically as needed.")
diff --git a/core/Geometry.carp b/core/Geometry.carp
index 16b40a41..07f429cc 100644
--- a/core/Geometry.carp
+++ b/core/Geometry.carp
@@ -1,3 +1,4 @@
+(doc Geometry "provides numerical geometrical operations.")
(defmodule Geometry
(doc degree-to-radians "converts degrees expressed as a double `n` into radians.")
(defn degree-to-radians [n]
diff --git a/core/Heap.carp b/core/Heap.carp
index 238ae06f..94314549 100644
--- a/core/Heap.carp
+++ b/core/Heap.carp
@@ -4,6 +4,8 @@
;
; for any two items `a` and `b`,
; `a` will be higher in the Heap then `b` if `(ord a b)`
+(doc Heap "is a heap data structure that uses a user-supplied ordering function
+to order its values.")
(defmodule Heap
(hidden lchild)
(defn lchild [i]
@@ -17,7 +19,7 @@
(defn parent [i]
(/ (- i 1) 2))
- (hidden max-of-three-until)
+ (hidden max-of-three-until!)
(doc max-of-three-until! "Get the index for the largest (by ord) of an element and its two children.")
(defn max-of-three-until! [heap i len ord]
(let-do [lchild-i (lchild i)
@@ -80,6 +82,7 @@
(Array.pop-back! heap)))
)
+(doc MinHeap "is a heap that uses `<` to order its values.")
(defmodule MinHeap
(hidden ord)
(defn ord [a b]
@@ -111,6 +114,7 @@
(Heap.pop! heap &ord))
)
+(doc MaxHeap "is a heap that uses `>` to order its values.")
(defmodule MaxHeap
(hidden ord)
(defn ord [a b]
@@ -142,6 +146,7 @@
(Heap.pop! heap &ord))
)
+(doc HeapSort "is a module for sorting using the heap data structure.")
(defmodule HeapSort
(hidden ord)
(defn ord [a b]
diff --git a/core/IO.carp b/core/IO.carp
index 30d887f4..d99de8db 100644
--- a/core/IO.carp
+++ b/core/IO.carp
@@ -2,8 +2,10 @@
(register-type FILE)
+(doc IO "is a module for performing I/O operations. Most functions found in this
+module are wrappers around the C standard library.")
(defmodule IO
-
+
(doc Raw "wrappers for functions from the C standard library. Consider using a more carpesque function from IO when it exists. For detailed documentation please consult the documentation of your system (e.g. under Linux try man fprint).")
(defmodule Raw
(doc stdin "the standard input file (thin wrapper for the C standard library).")
diff --git a/core/Int.carp b/core/Int.carp
index 8fbd2931..f1846220 100644
--- a/core/Int.carp
+++ b/core/Int.carp
@@ -1,5 +1,6 @@
(system-include "carp_int.h")
+(doc Int "is the default integral data type.")
(defmodule Int
(register + (λ [Int Int] Int))
(register - (λ [Int Int] Int))
diff --git a/core/List.carp b/core/List.carp
index 9671251b..c6f8d2bb 100644
--- a/core/List.carp
+++ b/core/List.carp
@@ -329,6 +329,13 @@ elements is uneven, the trailing element will be discarded.")
(= n 0) (car l)
(List.nth (cdr l) (dec n))))
+ (doc remove-nth "removes the nth element from the list `l`.")
+ (defndynamic remove-nth [l n]
+ (cond
+ (empty? l) '()
+ (= n 0) (cdr l)
+ (cons (car l) (List.remove-nth (cdr l) (dec n)))))
+
(doc update-nth "updates the nth element of the list `l` using the function `f`.")
(defndynamic update-nth [l n f]
(cond
diff --git a/core/Long.carp b/core/Long.carp
index aaaac8ac..60bb6826 100644
--- a/core/Long.carp
+++ b/core/Long.carp
@@ -1,5 +1,7 @@
(system-include "carp_long.h")
+(doc Long "is a bigger integral data type (its size is 64 bits). Its suffix is
+`l`.")
(defmodule Long
(register MAX Long "LONG_MAX")
(register MIN Long "LONG_MIN")
diff --git a/core/Macros.carp b/core/Macros.carp
index fb9a0fd1..b96f83a9 100644
--- a/core/Macros.carp
+++ b/core/Macros.carp
@@ -258,6 +258,10 @@ the filename and module name are the same.")
(defmacro ignore [form]
(list 'let (array '_ form) (list)))
+(doc ignore* "Wraps all forms passed as an argument in a call to [`ignore`](#ignore).")
+(defmacro ignore* [:rest forms]
+ (map (fn [x] (cons-last x (list 'ignore))) forms))
+
(doc const-assert
"Asserts that the expression `expr` is true at compile time."
"Otherwise it will fail with the message `msg`."
diff --git a/core/Maybe.carp b/core/Maybe.carp
index cdda71ff..129022a4 100644
--- a/core/Maybe.carp
+++ b/core/Maybe.carp
@@ -2,6 +2,9 @@
(Just [a])
(Nothing []))
+(doc Maybe "is a data type to represent optional values. It has two
+constructors, `(Just <value>)` and `Nothing`, and provides many functions to
+wrap and unwrap values.")
(defmodule Maybe
(doc apply "applies a function to the value inside `a` if it is a `Just`, and wraps it up again. If it is `Nothing`, it is just returned.")
(defn apply [a f]
diff --git a/core/OpenGL.carp b/core/OpenGL.carp
index 188a8b8c..66bdf571 100644
--- a/core/OpenGL.carp
+++ b/core/OpenGL.carp
@@ -8,6 +8,7 @@
(system-include "gl.h")
(add-lib "-lopengl32"))
+(doc GL "is a thin wrapper around [OpenGL](https://www.opengl.org/).")
(defmodule GL
(register-type GLenum)
diff --git a/core/Pattern.carp b/core/Pattern.carp
index 92d9fab2..26bd9582 100644
--- a/core/Pattern.carp
+++ b/core/Pattern.carp
@@ -1,5 +1,8 @@
(system-include "carp_pattern.h")
+(doc Pattern "is a data type for pattern matching, similar to, but not the same
+as, Regular Expressions. [See the docs for more
+information](../LanguageGuide.html#patterns).")
(defmodule Pattern
(register-type MatchResult "PatternMatchResult" [start Int, end Int])
diff --git a/core/Pointer.carp b/core/Pointer.carp
index 543ffe2f..3e223ee1 100644
--- a/core/Pointer.carp
+++ b/core/Pointer.carp
@@ -1,3 +1,4 @@
+(doc Pointer "is a data type for representing C pointers.")
(defmodule Pointer
(doc eq "checks two pointers for equality.")
(deftemplate eq (Fn [(Ptr p) (Ptr p)] Bool) "bool $NAME($p *p1, $p *p2)" " $DECL { return p1 == p2; }")
diff --git a/core/Random.carp b/core/Random.carp
index 1d1e13e9..1388c384 100644
--- a/core/Random.carp
+++ b/core/Random.carp
@@ -1,3 +1,4 @@
+(doc Random "is a simple, non-cryptographic random number generator.")
(defmodule Random
(def- a 69069.0)
diff --git a/core/Result.carp b/core/Result.carp
index b995535a..e59bc0ff 100644
--- a/core/Result.carp
+++ b/core/Result.carp
@@ -2,6 +2,10 @@
(Success [a])
(Error [b]))
+(doc Result "is a data type for computations that might fail with an error. It
+has two constructors, `(Success <value>)` and `(Error <value>)`, and provides
+many functions for working with, combining, and wrapping and unwrapping
+values.")
(defmodule Result
(doc apply "takes a `Result` `a` and applies functions to them, one in the case that it is an `Error`, one in the case that it is a `Success`.")
(defn apply [a success-f error-f]
diff --git a/core/SDL.carp b/core/SDL.carp
index c25cf2af..c3e202ba 100644
--- a/core/SDL.carp
+++ b/core/SDL.carp
@@ -39,6 +39,8 @@
(register b (Fn [&SDL_Color] Int))
(register a (Fn [&SDL_Color] Int)))
+(doc SDL "is a thin wrapper around the [SDL
+framework](https://www.libsdl.org/).")
(defmodule SDL
;; Setup and teardown
(register INIT_EVERYTHING Int)
diff --git a/core/StaticArray.carp b/core/StaticArray.carp
index 5d0a653c..ea30659c 100644
--- a/core/StaticArray.carp
+++ b/core/StaticArray.carp
@@ -1,3 +1,5 @@
+(doc StaticArray "is a data type for static, immutable arrays. They are
+stack-allocated. For a more flexible, heap-allocated version, you might want to look at the [`Array`](./Array.html) module.")
(defmodule StaticArray
(doc map! "Maps a function over the static array `xs`, mutating it in place. The difference to Array.endo-map (which does the same thing internally) is that this function takes a ref (since you can never have static arrays as values) and that it returns ().")
diff --git a/core/Statistics.carp b/core/Statistics.carp
index 21c3f090..ac57a05c 100644
--- a/core/Statistics.carp
+++ b/core/Statistics.carp
@@ -2,6 +2,8 @@
(use Double)
(use Array)
+(doc Statistics "is a module for providing various statistical analyses on a
+collection of values.")
(defmodule Statistics
(deftype Summary [
sum Double,
diff --git a/core/StdInt.carp b/core/StdInt.carp
index 0fdd97c5..523b35b0 100644
--- a/core/StdInt.carp
+++ b/core/StdInt.carp
@@ -9,6 +9,8 @@
(register-type Int32)
(register-type Int64)
+(doc Int8 "is a thin wrapper around the `int8_t` C data type, a signed 8-bit
+integer.")
(defmodule Int8
(register = (λ [Int8 Int8] Bool))
(register > (λ [Int8 Int8] Bool))
@@ -53,6 +55,8 @@
(implements = Int8Extra.=)
)
+(doc Int16 "is a thin wrapper around the `int16_t` C data type, a signed 16-bit
+integer.")
(defmodule Int16
(register = (λ [Int16 Int16] Bool))
(register > (λ [Int16 Int16] Bool))
@@ -97,6 +101,8 @@
(implements = Int16Extra.=)
)
+(doc Int32 "is a thin wrapper around the `int32_t` C data type, a signed 32-bit
+integer.")
(defmodule Int32
(register = (λ [Int32 Int32] Bool))
(register > (λ [Int32 Int32] Bool))
@@ -141,6 +147,8 @@
(implements = Int32Extra.=)
)
+(doc Int64 "is a thin wrapper around the `int64_t` C data type, a signed 64-bit
+integer.")
(defmodule Int64
(register = (λ [Int64 Int64] Bool))
(register > (λ [Int64 Int64] Bool))
@@ -185,6 +193,8 @@
(implements = Int64Extra.=)
)
+(doc Uint8 "is a thin wrapper around the `uint8_t` C data type, an unsigned
+8-bit integer.")
(defmodule Uint8
(register = (λ [Uint8 Uint8] Bool))
(register > (λ [Uint8 Uint8] Bool))
@@ -229,6 +239,8 @@
(implements = Uint8Extra.=)
)
+(doc Uint16 "is a thin wrapper around the `uint16_t` C data type, an unsigned
+16-bit integer.")
(defmodule Uint16
(register = (λ [Uint16 Uint16] Bool))
(register > (λ [Uint16 Uint16] Bool))
@@ -273,6 +285,8 @@
(implements = Uint16Extra.=)
)
+(doc Uint32 "is a thin wrapper around the `uint32_t` C data type, an unsigned
+32-bit integer.")
(defmodule Uint32
(register = (λ [Uint32 Uint32] Bool))
(register > (λ [Uint32 Uint32] Bool))
@@ -317,6 +331,8 @@
(implements = Uint32Extra.=)
)
+(doc Uint64 "is a thin wrapper around the `uint64_t` C data type, an unsigned
+64-bit integer.")
(defmodule Uint64
(register = (λ [Uint64 Uint64] Bool))
(register > (λ [Uint64 Uint64] Bool))
diff --git a/core/String.carp b/core/String.carp
index 8ff972c3..e4e02eea 100644
--- a/core/String.carp
+++ b/core/String.carp
@@ -8,6 +8,7 @@
(register toupper- (Fn [Byte] Byte) "toupper")
)
+(doc String "is the string data type for representing text.")
(defmodule String
(register = (Fn [&String &String] Bool))
diff --git a/core/System.carp b/core/System.carp
index afa29680..6afc94fd 100644
--- a/core/System.carp
+++ b/core/System.carp
@@ -2,6 +2,7 @@
(system-include "errno.h") ; needed for (System.errno)
(system-include "string.h") ; needed for (System.strerror)
+(doc System "is a module for wrapping system calls and other OS utilities.")
(defmodule System
(doc carp-init-globals "Initializes all global variables (in correct order, based on interdependencies). Called automatically by `main` if the project is compiled as an executable. Client code needs to call this function manually when using a library written in Carp.")
(register carp-init-globals (Fn [Int (Ptr (Ptr CChar))] ()) "carp_init_globals")
diff --git a/core/Test.carp b/core/Test.carp
index 88582737..878b3e0a 100644
--- a/core/Test.carp
+++ b/core/Test.carp
@@ -1,5 +1,19 @@
(load "Color.carp")
+(doc Test "is the standard test framework.
+
+Example:
+```
+(load-and-use Test)
+
+(deftest test
+ (assert-equal test
+ 2
+ (+ 1 1)
+ \"addition works\"
+ )
+)
+```")
(defmodule Test
(deftype State [passed Int, failed Int])
(hidden State)
diff --git a/core/Tuples.carp b/core/Tuples.carp
index 1b2a367d..0bdb1b7d 100644
--- a/core/Tuples.carp
+++ b/core/Tuples.carp
@@ -21,8 +21,7 @@
(private deftuple-module-)
(hidden deftuple-module-)
(defndynamic deftuple-module- [name props]
- (let [sname (Symbol.str name)
- module-name (Symbol.concat [name 'Ref])]
+ (let [module-name (Symbol.concat [name 'Ref])]
`(do
(defmodule %module-name
(defn < [t1 t2] %(deftuple-lt- name props))
@@ -31,9 +30,10 @@
(defn > [t1 t2] (%(Symbol.prefix module-name '<) t2 t1))
(implements > %(Symbol.prefix module-name '>)))
+ (doc %name %(str "is a tuple of length " (length props) "."))
(defmodule %name
(doc init-from-refs
- %(String.concat ["initializes a `" sname "` from member references."]))
+ %(str "initializes a `" name "` from member references."))
%(let [prop-vars (map (fn [x] (Symbol.concat [x '-val])) props)]
`(defn init-from-refs %(collect-into prop-vars array)
(init %@(map (fn [x] `(copy %x)) prop-vars))))
@@ -47,7 +47,7 @@
(implements > %(Symbol.prefix name '>))
(doc reverse
- %(String.concat ["reverses a `" sname "` by reversing its member positions."]))
+ %(str "reverses a `" name "` by reversing its member positions."))
(defn reverse [t]
(init %@(map (fn [x] `(copy (%x t))) (reverse props))))))))
diff --git a/core/Unit.carp b/core/Unit.carp
index 6634c8d3..5320ffee 100644
--- a/core/Unit.carp
+++ b/core/Unit.carp
@@ -1,3 +1,5 @@
+(doc Unit "is the empty type, also represented as `()` and equivalent to `void`
+in C.")
(defmodule Unit
(implements prn prn)
(sig prn (Fn [Unit] String))
diff --git a/core/Unsafe.carp b/core/Unsafe.carp
index 6bd2b2d9..26724268 100644
--- a/core/Unsafe.carp
+++ b/core/Unsafe.carp
@@ -1,3 +1,5 @@
+(doc Unsafe "is a module containing unsafe operations. Lasciate ogne speranza,
+voi ch'intrate.")
(defmodule Unsafe
(doc coerce "coerces a value of type `b` to a value of type `a`.")
(deftemplate coerce (Fn [b] a) "$a $NAME($b b)" "$DECL { return ($a)b; }")
diff --git a/core/Vector.carp b/core/Vector.carp
index a0ef8dc1..32b59fd1 100644
--- a/core/Vector.carp
+++ b/core/Vector.carp
@@ -2,6 +2,7 @@
(derive Vector2 zero)
(derive Vector2 =)
+(doc Vector2 "is a two-dimensional vector data type.")
(defmodule Vector2
(defn map [f v]
(init (f @(x v))
@@ -99,6 +100,7 @@
(derive Vector3 zero)
(derive Vector3 =)
+(doc Vector3 "is a three-dimensional vector data type.")
(defmodule Vector3
(defn map [f v]
(init (f @(x v))
@@ -202,6 +204,8 @@
(deftype (VectorN f) [n Int, v (Array f)])
(derive VectorN =)
+(doc VectorN "is an n-dimensional vector data type. Its implementation is
+array-backed.")
(defmodule VectorN
(defn zero-sized [n]
(let [z (zero)]
diff --git a/core/carp_float.h b/core/carp_float.h
index af9d3dd9..196f6f4b 100644
--- a/core/carp_float.h
+++ b/core/carp_float.h
@@ -130,3 +130,7 @@ float Float_floor(float x) {
float Float_mod(float x, float y) {
return fmodf(x, y);
}
+
+int Float_round(float x) {
+ return roundf(x);
+}
diff --git a/core/carp_string.h b/core/carp_string.h
index 88380542..1d73c241 100644
--- a/core/carp_string.h
+++ b/core/carp_string.h
@@ -8,7 +8,7 @@ String String_allocate(int len, char byte) {
* String_alloc(10, "a") == "aaaaaaaaaa"
*/
String ptr = CARP_MALLOC(len + 1);
- if( ptr!=NULL) {
+ if (ptr != NULL) {
// calling memset(NULL,...) would exercise undefined behaviour...
memset(ptr, byte, len);
ptr[len] = '\0';
@@ -107,10 +107,28 @@ String String_str(const String *s) {
return String_copy(s);
}
+int count_occurrences(String s, char c) {
+ int res = 0;
+ while (*s != '\0') {
+ if (*s == c) res++;
+ s++;
+ }
+ return res;
+}
+
String String_prn(const String *s) {
- int n = strlen(*s) + 4;
+ int n = strlen(*s) + 4 + count_occurrences(*s, '"');
String buffer = CARP_MALLOC(n);
- sprintf(buffer, "@\"%s\"", *s);
+ buffer[0] = '@';
+ buffer[1] = '"';
+ String c = *s;
+ for (int i = 2; i < n - 2; i++) {
+ if (*c == '"') buffer[i++] = '\\';
+ buffer[i] = *c;
+ c++;
+ }
+ buffer[n - 2] = '"';
+ buffer[n - 1] = '\0';
return buffer;
}
diff --git a/src/Commands.hs b/src/Commands.hs
index 5489c81f..6f8238a4 100644
--- a/src/Commands.hs
+++ b/src/Commands.hs
@@ -64,7 +64,7 @@ addCmd path callback doc example =
XObj (Arr args) Nothing Nothing
]
)
- (Just dummyInfo)
+ (Just dummyInfo {infoFile = "Core Commands"})
(Just DynamicTy)
args = (\x -> XObj (Sym (SymPath [] x) Symbol) Nothing Nothing) <$> argnames
argnames = case callback of
@@ -614,6 +614,8 @@ commandSymConcat ctx a =
commandSymPrefix :: BinaryCommandCallback
commandSymPrefix ctx (XObj (Sym (SymPath [] prefix) _) _ _) (XObj (Sym (SymPath [] suffix) st) i t) =
pure (ctx, Right (XObj (Sym (SymPath [prefix] suffix) st) i t))
+commandSymPrefix ctx (XObj (Sym (SymPath ps prefix) _) _ _) (XObj (Sym (SymPath [] suffix) st) i t) =
+ pure (ctx, Right (XObj (Sym (SymPath (ps++[prefix]) suffix) st) i t))
commandSymPrefix ctx x (XObj (Sym (SymPath [] _) _) _ _) =
pure $ evalError ctx ("Can’t call `prefix` with " ++ pretty x) (xobjInfo x)
commandSymPrefix ctx _ x =
@@ -743,7 +745,6 @@ commandSaveDocsEx ctx modulePaths filePaths = do
Right ok -> saveDocs ctx ok
where
globalEnv = contextGlobalEnv ctx
-
modulesAndGlobals =
let (_, mods) = modules
(_, globs) = filesWithGlobals
@@ -751,7 +752,6 @@ commandSaveDocsEx ctx modulePaths filePaths = do
okMods <- mods
okGlobs <- globs
pure (okMods ++ okGlobs)
-
modules :: (Context, Either EvalError [(SymPath, Binder)])
modules = do
case modulePaths of
@@ -764,7 +764,6 @@ commandSaveDocsEx ctx modulePaths filePaths = do
Right okEnvBinders -> (ctx, Right (zip okPaths okEnvBinders))
x ->
evalError ctx ("Invalid first arg to save-docs-internal (expected array of symbols): " ++ pretty x) (xobjInfo modulePaths)
-
filesWithGlobals :: (Context, Either EvalError [(SymPath, Binder)])
filesWithGlobals = do
case filePaths of
@@ -777,7 +776,6 @@ commandSaveDocsEx ctx modulePaths filePaths = do
in (ctx, Right fauxModules)
x ->
evalError ctx ("Invalid second arg to save-docs-internal (expected array of strings containing filenames): " ++ pretty x) (xobjInfo filePaths)
-
createFauxModule :: String -> Map.Map String Binder -> (SymPath, Binder)
createFauxModule filename binders =
let moduleName = "Globals in " ++ filename
@@ -785,7 +783,6 @@ commandSaveDocsEx ctx modulePaths filePaths = do
fauxGlobalModuleWithBindings = fauxGlobalModule {envBindings = binders}
fauxTypeEnv = E.new Nothing Nothing
in (SymPath [] moduleName, Binder emptyMeta (XObj (Mod fauxGlobalModuleWithBindings fauxTypeEnv) Nothing Nothing))
-
getEnvironmentBinderForDocumentation :: Env -> SymPath -> Either String Binder
getEnvironmentBinderForDocumentation env path =
case E.searchValueBinder env path of
@@ -795,11 +792,9 @@ commandSaveDocsEx ctx modulePaths filePaths = do
Left ("I can’t generate documentation for `" ++ pretty x ++ "` because it isn’t a module")
Left _ ->
Left ("I can’t find the module `" ++ show path ++ "`")
-
getGlobalBindersForDocumentation :: Env -> String -> Map.Map String Binder
getGlobalBindersForDocumentation env filename =
Map.filter (\bind -> (binderFilename bind) == filename) (envBindings env)
-
binderFilename :: Binder -> String
binderFilename = takeFileName . fromMaybe "" . fmap infoFile . xobjInfo . binderXObj
diff --git a/src/Concretize.hs b/src/Concretize.hs
index 14620929..7b4a5462 100644
--- a/src/Concretize.hs
+++ b/src/Concretize.hs
@@ -1,14 +1,37 @@
{-# LANGUAGE LambdaCase #-}
-module Concretize where
+-- | Module Concretize determines the dependencies of polymorphic objects and
+-- resolves the object into a "concrete" version, where its types are no longer
+-- variables.
+module Concretize
+ ( concretizeXObj,
+ concretizeType,
+ depsForCopyFunc,
+ depsForPrnFunc,
+ depsForDeleteFunc,
+ depsForDeleteFuncs,
+ depsOfPolymorphicFunction,
+ typesStrFunctionType,
+ concreteDelete,
+ memberDeletion,
+ memberRefDeletion,
+ concreteCopy,
+ tokensForCopy,
+ memberCopy,
+ replaceGenericTypeSymbolsOnMembers,
+ )
+where
import AssignTypes
import Constraints
+import Control.Applicative
import Control.Monad.State
+import Data.Either (fromRight)
import Data.List (foldl')
import Data.Maybe (fromMaybe)
import Debug.Trace
-import Env (envIsExternal, getTypeBinder, insert, insertX, searchValue)
+import Env (EnvironmentError, empty, envIsExternal, findTypeBinder, getTypeBinder, insert, insertX, searchValue)
+import Forms
import Info
import InitialTypes
import Managed
@@ -36,339 +59,388 @@ data Level = Toplevel | Inside
-- | Both of these results are returned in a tuple: (<new xobj>, <dependencies>)
concretizeXObj :: Bool -> TypeEnv -> Env -> [SymPath] -> XObj -> Either TypeError (XObj, [XObj])
concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
- case runState (visit allowAmbiguityRoot Toplevel rootEnv root) [] of
+ case runState (visit (visitedDefinitions ++ [getPath root]) allowAmbiguityRoot Toplevel typeEnv rootEnv root) [] of
(Left err, _) -> Left err
(Right xobj, deps) -> Right (xobj, deps)
+
+--------------------------------------------------------------------------------
+-- Visit functions
+--
+-- These functions take a state and supporting information and gradually
+-- convert generically typed xobjs into concretely typed xobjs.
+--
+-- The functions prefixed "visit" primarily just recur into the component parts
+-- of different Carp forms while the "concretizeType..." functions perform the
+-- actual type conversion work.
+
+-- | The type of visit functions. These functions convert the types of the
+-- components of a form into concrete types and take the following arguments:
+-- - A List of paths that have already been visited.
+-- - A bool indicating whether or not type variables are allowed
+-- - A level indicating if we are in an inner component of a form or the top level
+-- - A type environment
+-- - A value environment
+-- - The xobj to concretize
+type Visitor = [SymPath] -> Bool -> Level -> TypeEnv -> Env -> XObj -> State [XObj] (Either TypeError [XObj])
+
+-- | Process the components of a form, yielding a concretely typed (no
+-- generics) version of the form.
+visit :: [SymPath] -> Bool -> Level -> TypeEnv -> Env -> XObj -> State [XObj] (Either TypeError XObj)
+visit visited ambig _ tenv env xobj@(SymPat _ _) = visitSymbol visited ambig tenv env xobj
+visit visited ambig _ tenv env xobj@(MultiSymPat _ _) = visitMultiSym visited ambig tenv env xobj
+visit visited ambig _ tenv env xobj@(InterfaceSymPat _) = visitInterfaceSym visited ambig tenv env xobj
+visit visited allowAmbig level tenv env xobj@(ListPat _) =
+ do
+ vLst <- visitList visited allowAmbig level tenv env xobj
+ pure (vLst >>= \ok -> pure (setObj xobj (Lst ok)))
+visit visited allowAmbig level tenv env xobj@(ArrPat arr) =
+ do
+ vArr <- fmap sequence (mapM (visit visited allowAmbig level tenv env) arr)
+ c <- concretizeTypeOfXObj tenv env xobj
+ pure (c >> vArr >>= \ok -> pure (setObj xobj (Arr ok)))
+visit visited allowAmbig level tenv env xobj@(StaticArrPat arr) =
+ do
+ vArr <- fmap sequence (mapM (visit visited allowAmbig level tenv env) arr)
+ c <- concretizeTypeOfXObj tenv env xobj
+ pure (c >> vArr >>= \ok -> pure (setObj xobj (StaticArr ok)))
+visit _ _ _ _ _ x = pure (Right x)
+
+-- | Entry point for concretely typing the components of a list form.
+visitList :: Visitor
+visitList _ _ _ _ _ (ListPat []) = pure (Right [])
+visitList p a l t e x@(ListPat (DefPat _ _ _)) = visitDef p a l t e x
+visitList p a l t e x@(ListPat (DefnPat _ _ _ _)) = visitDefn p a l t e x
+visitList p a l t e x@(ListPat (LetPat _ _ _)) = visitLet p a l t e x
+visitList p a l t e x@(ListPat (ThePat _ _ _)) = visitThe p a l t e x
+visitList p a l t e x@(ListPat (MatchPat _ _ _)) = visitMatch p a l t e x
+visitList p a l t e x@(ListPat (SetPat _ _ _)) = visitSetBang p a l t e x
+visitList p a l t e x@(ListPat (FnPat _ _ _)) = visitFn p a l t e x
+visitList p a l t e x@(ListPat (AppPat _ _)) = visitApp p a l t e x
+visitList _ _ _ _ _ x = pure (Left (CannotConcretize x))
+
+-- | Helper for producing a new environment with all a functions argument symbols.
+--
+-- Used to concretize defn and fn forms.
+envWithFunctionArgs :: Env -> [XObj] -> Either EnvironmentError Env
+envWithFunctionArgs env arr =
+ let functionEnv = Env Map.empty (Just env) Nothing Set.empty InternalEnv (envFunctionNestingLevel env)
+ in foldM
+ (\e arg@(XObj (Sym path _) _ _) -> insertX e path arg)
+ functionEnv
+ arr
+
+-- | Concretely type a function definition.
+--
+-- "main" is treated as a special case.
+visitDefn :: Visitor
+visitDefn p a l t e x@(ListPat (DefnPat _ (SymPat (SymPath [] "main") _) _ _)) = visitMain p a l t e x
+visitDefn visited _ Toplevel tenv env x@(ListPat (DefnPat defn name args@(ArrPat arr) body)) =
+ do
+ mapM_ (concretizeTypeOfXObj tenv env) arr
+ let envWithArgs = fromRight Env.empty (envWithFunctionArgs env arr)
+ allowAmbig = maybe True isTypeGeneric (xobjTy x)
+ c <- concretizeTypeOfXObj tenv env body
+ vBody <- visit (getPath x : visited) allowAmbig Inside tenv (incrementEnvNestLevel envWithArgs) body
+ pure (c >> vBody >>= go)
where
- rootDefinitionPath :: SymPath
- rootDefinitionPath = getPath root
- visit :: Bool -> Level -> Env -> XObj -> State [XObj] (Either TypeError XObj)
- visit allowAmbig _ env xobj@(XObj (Sym _ _) _ _) = visitSymbol allowAmbig env xobj
- visit allowAmbig _ env xobj@(XObj (MultiSym _ _) _ _) = visitMultiSym allowAmbig env xobj
- visit allowAmbig _ env xobj@(XObj (InterfaceSym _) _ _) = visitInterfaceSym allowAmbig env xobj
- visit allowAmbig level env xobj@(XObj (Lst _) i t) =
- do
- visited <- visitList allowAmbig level env xobj
- pure $ do
- okVisited <- visited
- Right (XObj (Lst okVisited) i t)
- visit allowAmbig level env xobj@(XObj (Arr arr) i (Just t)) =
- do
- visited <- fmap sequence (mapM (visit allowAmbig level env) arr)
- concretizeResult <- concretizeTypeOfXObj typeEnv xobj
- whenRight concretizeResult $
- pure $ do
- okVisited <- visited
- Right (XObj (Arr okVisited) i (Just t))
- visit allowAmbig level env xobj@(XObj (StaticArr arr) i (Just t)) =
- do
- visited <- fmap sequence (mapM (visit allowAmbig level env) arr)
- concretizeResult <- concretizeTypeOfXObj typeEnv xobj
- whenRight concretizeResult $
- pure $ do
- okVisited <- visited
- Right (XObj (StaticArr okVisited) i (Just t))
- visit _ _ _ x = pure (Right x)
- visitList :: Bool -> Level -> Env -> XObj -> State [XObj] (Either TypeError [XObj])
- visitList _ _ _ (XObj (Lst []) _ _) = pure (Right [])
- visitList _ Toplevel env (XObj (Lst [defn@(XObj (Defn _) _ _), nameSymbol@(XObj (Sym (SymPath [] "main") _) _ _), args@(XObj (Arr argsArr) _ _), body]) _ _) =
- if not (null argsArr)
- then pure $ Left (MainCannotHaveArguments nameSymbol (length argsArr))
- else do
- concretizeResult <- concretizeTypeOfXObj typeEnv body
- whenRight concretizeResult $ do
- visitedBody <- visit False Inside env body
- pure $ do
- okBody <- visitedBody
- let t = fromMaybe UnitTy (xobjTy okBody)
- if not (isTypeGeneric t) && t /= UnitTy && t /= IntTy
- 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) =
- do
- mapM_ (concretizeTypeOfXObj typeEnv) argsArr
- let functionEnv = Env Map.empty (Just env) Nothing Set.empty InternalEnv 0
- envWithArgs =
- foldl'
- ( \e arg@(XObj (Sym path _) _ _) ->
- -- n.b. this won't fail since we're inserting unqualified args into a fresh env
- -- TODO: Still, it'd be nicer and more flexible to catch failures here.
- let Right v = insertX e path arg in v
- )
- functionEnv
- argsArr
- Just funcTy = t
- allowAmbig = isTypeGeneric funcTy
- concretizeResult <- concretizeTypeOfXObj typeEnv body
- whenRight concretizeResult $ do
- visitedBody <- visit allowAmbig Inside (incrementEnvNestLevel envWithArgs) body
- pure $ do
- okBody <- visitedBody
- pure [defn, nameSymbol, args, okBody]
- visitList _ Inside _ xobj@(XObj (Lst [XObj (Defn _) _ _, _, XObj (Arr _) _ _, _]) _ _) =
- pure (Left (DefinitionsMustBeAtToplevel xobj))
- 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
- -- the C code.
- do
- mapM_ (concretizeTypeOfXObj typeEnv) argsArr
- let Just ii = i
- Just funcTy = t
- argObjs = map xobjObj argsArr
- -- TODO: This code is a copy of the one above in Defn, remove duplication:
- functionEnv = Env Map.empty (Just env) Nothing Set.empty InternalEnv (envFunctionNestingLevel env)
- envWithArgs =
- foldl'
- ( \e arg@(XObj (Sym path _) _ _) ->
- let Right v = insertX e path arg in v
- )
- functionEnv
- argsArr
- visitedBody <- visit allowAmbig Inside (incrementEnvNestLevel envWithArgs) body
- case visitedBody of
- Right okBody ->
- let -- Analyse the body of the lambda to find what variables it captures
- capturedVarsRaw = collectCapturedVars okBody
- -- and then remove the captures that are actually our arguments
- capturedVars = filter (\xobj -> xobjObj (toGeneralSymbol xobj) `notElem` argObjs) capturedVarsRaw
- -- Create a new (top-level) function that will be used when the lambda is called.
- -- Its name will contain the name of the (normal, non-lambda) function it's contained within,
- -- plus the identifier of the particular s-expression that defines the lambda.
- SymPath spath name = rootDefinitionPath
- lambdaPath = SymPath spath ("_Lambda_" ++ lambdaToCName name (envFunctionNestingLevel envWithArgs) ++ "_" ++ show (infoIdentifier ii) ++ "_env")
- lambdaNameSymbol = XObj (Sym lambdaPath Symbol) (Just dummyInfo) Nothing
- -- Anonymous functions bound to a let name might call themselves. These recursive instances will have already been qualified as LookupRecursive symbols.
- -- Rename the recursive calls according to the generated lambda name so that we can call these correctly from C.
- renameRecursives (XObj (Sym _ LookupRecursive) si st) = (XObj (Sym lambdaPath LookupRecursive) si st)
- renameRecursives x = x
- recBody = walk renameRecursives okBody
- environmentTypeName = pathToC lambdaPath ++ "_ty"
- tyPath = (SymPath [] environmentTypeName)
- extendedArgs =
- if null capturedVars
- then args
- else -- If the lambda captures anything it need an extra arg for its env:
-
- XObj
- ( Arr
- ( XObj
- (Sym (SymPath [] "_env") Symbol)
- (Just dummyInfo)
- (Just (PointerTy (StructTy (ConcreteNameTy tyPath) []))) :
- argsArr
- )
- )
- ai
- at
- lambdaCallback = XObj (Lst [XObj (Defn (Just (Set.fromList capturedVars))) (Just dummyInfo) Nothing, lambdaNameSymbol, extendedArgs, recBody]) 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)
- structMemberPairs =
- concatMap
- ( \(XObj (Sym path _) _ (Just symTy)) ->
- [XObj (Sym path Symbol) Nothing Nothing, reify symTy]
- )
- capturedVars
- environmentStructTy = StructTy (ConcreteNameTy tyPath) []
- environmentStruct =
- XObj
- ( Lst
- [ XObj (Deftype environmentStructTy) Nothing Nothing,
- XObj (Sym tyPath Symbol) Nothing Nothing,
- XObj (Arr structMemberPairs) Nothing Nothing
- ]
+ go b = pure [defn, name, args, b]
+visitDefn _ _ Inside _ _ x@(ListPat (DefnPat _ _ _ _)) =
+ pure (Left (DefinitionsMustBeAtToplevel x))
+visitDefn _ _ _ _ _ x = pure (Left (CannotConcretize x))
+
+-- | Concretely type a program entry point. Can only return Int or Unit.
+visitMain :: Visitor
+visitMain visited _ Toplevel tenv env (ListPat (DefnPat defn name@(SymPat (SymPath [] "main") _) args@(ArrPat []) body)) =
+ do
+ c <- concretizeTypeOfXObj tenv env body
+ vBody <- visit visited False Inside tenv env body
+ pure (c >> vBody >>= typeCheck)
+ where
+ typeCheck b =
+ let t = fromMaybe UnitTy (xobjTy b)
+ in if (t `elem` validMainTypes) || isTypeGeneric t
+ then pure [defn, name, args, b]
+ else Left (MainCanOnlyReturnUnitOrInt name t)
+ validMainTypes = [UnitTy, IntTy]
+visitMain _ _ _ _ _ (ListPat (DefnPat _ name@(SymPat (SymPath [] "main") _) (ArrPat arr) _)) =
+ pure (Left (MainCannotHaveArguments name (length arr)))
+visitMain _ _ _ _ _ x = pure (Left (CannotConcretize x))
+
+-- | Concretely type a Def form.
+visitDef :: Visitor
+visitDef visited _ Toplevel tenv env x@(ListPat (DefPat def name body)) =
+ do
+ vBody <- visit visited allowAmbig Inside tenv env body
+ pure (vBody >>= \ok -> pure [def, name, ok])
+ where
+ allowAmbig = isTypeGeneric (fromMaybe (VarTy "a") (xobjTy x))
+visitDef _ _ Inside _ _ x@(ListPat (DefPat _ _ _)) =
+ pure (Left (DefinitionsMustBeAtToplevel x))
+visitDef _ _ _ _ _ x = pure (Left (CannotConcretize x))
+
+-- | Concretely type a Let (let [bindings...] <body>) form.
+visitLet :: Visitor
+visitLet visited allowAmbig level tenv env (ListPat (LetPat letExpr arr@(ArrPat bindings) body)) =
+ do
+ bindings' <- fmap sequence (mapM (visit visited allowAmbig level tenv env) bindings)
+ body' <- visit visited allowAmbig level tenv env body
+ c <- mapM (concretizeTypeOfXObj tenv env . fst) (pairwise bindings)
+ pure (sequence c >> go bindings' body')
+ where
+ go x' y = do
+ okBindings <- x'
+ okBody <- y
+ pure [letExpr, (setObj arr (Arr okBindings)), okBody]
+visitLet _ _ _ _ _ x = pure (Left (CannotConcretize x))
+
+-- | Concretely type a The (the <type> <value>) form.
+visitThe :: Visitor
+visitThe visited allowAmbig level tenv env (ListPat (ThePat the ty value)) =
+ do
+ vVal <- visit visited allowAmbig level tenv env value
+ pure (vVal >>= \ok -> pure [the, ty, ok])
+visitThe _ _ _ _ _ x = pure (Left (CannotConcretize x))
+
+-- | Concretely type a Match (match <expr> <clauses...>) form.
+visitMatch :: Visitor
+visitMatch visited allowAmbig level tenv env (ListPat (MatchPat match expr rest)) =
+ do
+ c <- concretizeTypeOfXObj tenv env expr
+ vExpr <- visit visited allowAmbig level tenv env expr
+ mapM_ (concretizeTypeOfXObj tenv env . snd) (pairwise rest)
+ vCases <- fmap sequence (mapM (visitMatchCase visited allowAmbig level tenv env) (pairwise rest))
+ pure (c >> go vExpr vCases)
+ where
+ go x y = do
+ okExpr <- x
+ okRest <- fmap concat y
+ pure ([match, okExpr] ++ okRest)
+visitMatch _ _ _ _ _ x = pure (Left (CannotConcretize x))
+
+-- | Concretely type a Match form case.
+visitMatchCase :: [SymPath] -> Bool -> Level -> TypeEnv -> Env -> (XObj, XObj) -> State [XObj] (Either TypeError [XObj])
+visitMatchCase visited allowAmbig level tenv env (lhs, rhs) =
+ -- TODO! This changes the names of some tags (which is corrected in Emit) but perhaps there is a better way where they can be identified as tags and not changed?
+ do
+ vl <- visit visited allowAmbig level tenv env lhs
+ vr <- visit visited allowAmbig level tenv env rhs
+ pure (liftA2 (\x y -> [x, y]) vl vr)
+
+-- | Concretely type a Set (set! <var> <value>) form.
+visitSetBang :: Visitor
+visitSetBang visited allowAmbig _ tenv env (ListPat (SetPat set var value)) =
+ do
+ vVal <- visit visited allowAmbig Inside tenv env value
+ pure (vVal >>= \ok -> pure [set, var, ok])
+visitSetBang _ _ _ _ _ x = pure (Left (CannotConcretize x))
+
+-- | Concretely type a function application (<function> <args...>) form.
+visitApp :: Visitor
+visitApp visited allowAmbig level tenv env (ListPat (AppPat func args)) =
+ do
+ c <- concretizeTypeOfXObj tenv env func
+ cs <- fmap sequence $ mapM (concretizeTypeOfXObj tenv env) args
+ vFunc <- visit visited allowAmbig level tenv env func
+ vArgs <- fmap sequence (mapM (visit visited allowAmbig level tenv env) args)
+ pure (c >> cs >> liftA2 (:) vFunc vArgs)
+visitApp _ _ _ _ _ x = pure (Left (CannotConcretize x))
+
+-- | Concretely type an anonymous function and convert it into a
+-- resolvable/retrievable lambda.
+mkLambda :: Visitor
+mkLambda visited allowAmbig _ tenv env root@(ListPat (FnPat fn arr@(ArrPat args) body)) =
+ let capturedVars = filter (\xobj -> xobjObj (toGeneralSymbol xobj) `notElem` (map xobjObj args)) (collectCapturedVars body)
+ -- Create a new (top-level) function that will be used when the lambda is called.
+ -- Its name will contain the name of the (normal, non-lambda) function it's contained within,
+ -- plus the identifier of the particular s-expression that defines the lambda.
+ SymPath spath name = (last visited)
+ Just funcTy = xobjTy root
+ lambdaPath = SymPath spath ("_Lambda_" ++ lambdaToCName name (envFunctionNestingLevel env) ++ "_" ++ show (maybe 0 infoIdentifier (xobjInfo root)) ++ "_env")
+ lambdaNameSymbol = XObj (Sym lambdaPath Symbol) (Just dummyInfo) Nothing
+ -- Anonymous functions bound to a let name might call themselves. These recursive instances will have already been qualified as LookupRecursive symbols.
+ -- Rename the recursive calls according to the generated lambda name so that we can call these correctly from C.
+ renameRecursives (XObj (Sym _ LookupRecursive) si st) = (XObj (Sym lambdaPath LookupRecursive) si st)
+ renameRecursives x = x
+ recBody = walk renameRecursives body
+ environmentTypeName = pathToC lambdaPath ++ "_ty"
+ tyPath = (SymPath [] environmentTypeName)
+ extendedArgs =
+ if null capturedVars
+ then arr
+ else -- If the lambda captures anything it need an extra arg for its env:
+
+ ( setObj
+ arr
+ ( Arr
+ ( XObj
+ (Sym (SymPath [] "_env") Symbol)
+ (Just dummyInfo)
+ (Just (PointerTy (StructTy (ConcreteNameTy tyPath) []))) :
+ args
)
- i
- (Just TypeTy)
- pairs = memberXObjsToPairs structMemberPairs
- deleteFnTy = typesDeleterFunctionType (PointerTy environmentStructTy)
- deleteFnTemplate = concreteDeleteTakePtr typeEnv env pairs
- (deleteFn, deleterDeps) = instantiateTemplate (SymPath [] (environmentTypeName ++ "_delete")) deleteFnTy deleteFnTemplate
- copyFnTy = typesCopyFunctionType environmentStructTy
- copyFnTemplate = concreteCopyPtr typeEnv env pairs
- (copyFn, copyDeps) = instantiateTemplate (SymPath [] (environmentTypeName ++ "_copy")) copyFnTy copyFnTemplate
- -- The type env has to contain the lambdas environment struct for 'concretizeDefinition' to work:
- -- TODO: Fixup: Support modules in type envs.
- extendedTypeEnv = replaceLeft (FailedToAddLambdaStructToTyEnv tyPath environmentStruct) (insert typeEnv tyPath (toBinder environmentStruct))
- in case (extendedTypeEnv >>= \ext -> concretizeDefinition allowAmbig ext env visitedDefinitions lambdaCallback funcTy) of
- Left err -> pure (Left err)
- Right (concreteLiftedLambda, deps) ->
- do
- unless (any (isTypeGeneric . snd) pairs) $
- do
- modify (concreteLiftedLambda :)
- modify (deps ++)
- unless (null capturedVars) $
- do
- modify (environmentStruct :)
- modify (deleteFn :)
- modify (deleterDeps ++)
- modify (copyFn :)
- modify (copyDeps ++)
- pure (Right [XObj (Fn (Just lambdaPath) (Set.fromList capturedVars)) fni fnt, args, recBody])
- Left err ->
- pure (Left err)
- visitList _ Toplevel env (XObj (Lst [def@(XObj Def _ _), nameSymbol, body]) _ t) =
- do
- let Just defTy = t
- allowAmbig = isTypeGeneric defTy
- visitedBody <- visit allowAmbig Inside env body
- pure $ do
- okBody <- visitedBody
- pure [def, nameSymbol, okBody]
- visitList _ Inside _ xobj@(XObj (Lst [XObj Def _ _, _, _]) _ _) =
- pure (Left (DefinitionsMustBeAtToplevel xobj))
- visitList allowAmbig level env (XObj (Lst [letExpr@(XObj Let _ _), XObj (Arr bindings) bindi bindt, body]) _ _) =
- do
- visitedBindings <- fmap sequence (mapM (visit allowAmbig level env) bindings)
- visitedBody <- visit allowAmbig level env body
- concretizeResults <- mapM (concretizeTypeOfXObj typeEnv . fst) (pairwise bindings)
- whenRight (sequence concretizeResults) $
- pure $ do
- okVisitedBindings <- visitedBindings
- okVisitedBody <- visitedBody
- pure [letExpr, XObj (Arr okVisitedBindings) bindi bindt, okVisitedBody]
- visitList allowAmbig level env (XObj (Lst [theExpr@(XObj The _ _), typeXObj, value]) _ _) =
- do
- visitedValue <- visit allowAmbig level env value
- pure $ do
- okVisitedValue <- visitedValue
- pure [theExpr, typeXObj, okVisitedValue]
- visitList allowAmbig level env (XObj (Lst (matchExpr@(XObj (Match _) _ _) : expr : rest)) _ _) =
- do
- concretizeResult <- concretizeTypeOfXObj typeEnv expr
- whenRight concretizeResult $ do
- visitedExpr <- visit allowAmbig level env expr
- mapM_ (concretizeTypeOfXObj typeEnv . snd) (pairwise rest)
- visitedRest <- fmap sequence (mapM (visitMatchCase allowAmbig level env) (pairwise rest))
- pure $ do
- okVisitedExpr <- visitedExpr
- okVisitedRest <- fmap concat visitedRest
- pure ([matchExpr, okVisitedExpr] ++ okVisitedRest)
- visitList allowAmbig _ env (XObj (Lst [setbangExpr@(XObj SetBang _ _), variable, value]) _ _) =
- do
- visitedValue <- visit allowAmbig Inside env value
- pure $ do
- okVisitedValue <- visitedValue
- pure [setbangExpr, variable, okVisitedValue]
- visitList allowAmbig level env (XObj (Lst (func : args)) _ _) =
- do
- concretizeResult <- concretizeTypeOfXObj typeEnv func
- whenRight concretizeResult $ do
- concretizeResults <- mapM (concretizeTypeOfXObj typeEnv) args
- whenRight (sequence concretizeResults) $ do
- f <- visit allowAmbig level env func
- a <- fmap sequence (mapM (visit allowAmbig level env) args)
- pure $ do
- okF <- f
- okA <- a
- pure (okF : okA)
- visitList _ _ _ _ = error "visitlist"
- visitMatchCase :: Bool -> Level -> Env -> (XObj, XObj) -> State [XObj] (Either TypeError [XObj])
- visitMatchCase allowAmbig level env (lhs, rhs) =
- do
- visitedLhs <- visit allowAmbig level env lhs -- TODO! This changes the names of some tags (which is corrected in Emit) but perhaps there is a better way where they can be identified as tags and not changed?
- visitedRhs <- visit allowAmbig level env rhs
- pure $ do
- okVisitedLhs <- visitedLhs
- okVisitedRhs <- visitedRhs
- pure [okVisitedLhs, okVisitedRhs]
- visitSymbol :: Bool -> Env -> XObj -> State [XObj] (Either TypeError XObj)
- visitSymbol allowAmbig env xobj@(XObj (Sym path lookupMode) i t) =
- case searchValue env path of
- Right (foundEnv, binder)
- | envIsExternal foundEnv ->
- let theXObj = binderXObj binder
- Just theType = xobjTy theXObj
- typeOfVisited = fromMaybe (error ("Missing type on " ++ show xobj ++ " at " ++ prettyInfoFromXObj xobj ++ " when looking up path " ++ show path)) t
- in if --(trace $ "CHECKING " ++ getName xobj ++ " : " ++ show theType ++ " with visited type " ++ show typeOfVisited ++ " and visited definitions: " ++ show visitedDefinitions) $
- (isTypeGeneric theType && not (isTypeGeneric typeOfVisited))
- then case concretizeDefinition allowAmbig typeEnv env visitedDefinitions theXObj typeOfVisited of
- Left err -> pure (Left err)
- Right (concrete, deps) ->
- do
- modify (concrete :)
- modify (deps ++)
- pure (Right (XObj (Sym (getPath concrete) lookupMode) i t))
- else pure (Right xobj)
- | otherwise -> pure (Right xobj)
- _ -> pure (Right xobj)
- visitSymbol _ _ _ = error "Not a symbol."
- visitMultiSym :: Bool -> Env -> XObj -> State [XObj] (Either TypeError XObj)
- visitMultiSym allowAmbig env xobj@(XObj (MultiSym originalSymbolName paths) i t) =
- let Just actualType = t
- tys = map (typeFromPath env) paths
- modes = map (modeFromPath env) paths
+ )
+ )
+ lambdaCallback = XObj (Lst [XObj (Defn (Just (Set.fromList capturedVars))) (Just dummyInfo) Nothing, lambdaNameSymbol, extendedArgs, recBody]) (xobjInfo root) (xobjTy root)
+ -- The lambda will also carry with it a special made struct containing the variables it captures
+ -- (if it captures at least one variable)
+ structMemberPairs =
+ concatMap
+ ( \(XObj (Sym path _) _ (Just symTy)) ->
+ [XObj (Sym path Symbol) Nothing Nothing, reify symTy]
+ )
+ capturedVars
+ environmentStructTy = StructTy (ConcreteNameTy tyPath) []
+ environmentStruct =
+ XObj
+ ( Lst
+ [ XObj (Deftype environmentStructTy) Nothing Nothing,
+ XObj (Sym tyPath Symbol) Nothing Nothing,
+ XObj (Arr structMemberPairs) Nothing Nothing
+ ]
+ )
+ (xobjInfo root)
+ (Just TypeTy)
+ pairs = memberXObjsToPairs structMemberPairs
+ deleteFnTy = typesDeleterFunctionType (PointerTy environmentStructTy)
+ deleteFnTemplate = concreteDeleteTakePtr tenv env pairs
+ (deleteFn, deleterDeps) = instantiateTemplate (SymPath [] (environmentTypeName ++ "_delete")) deleteFnTy deleteFnTemplate
+ copyFnTy = typesCopyFunctionType environmentStructTy
+ copyFnTemplate = concreteCopyPtr tenv env pairs
+ (copyFn, copyDeps) = instantiateTemplate (SymPath [] (environmentTypeName ++ "_copy")) copyFnTy copyFnTemplate
+ -- The type env has to contain the lambdas environment struct for 'concretizeDefinition' to work:
+ -- TODO: Support modules in type envs.
+ extendedTypeEnv = replaceLeft (FailedToAddLambdaStructToTyEnv tyPath environmentStruct) (insert tenv tyPath (toBinder environmentStruct))
+ in --(fromMaybe UnitTy (xobjTy root))
+ case (extendedTypeEnv >>= \ext -> concretizeDefinition allowAmbig ext env visited lambdaCallback funcTy) of
+ Left e -> pure (Left e)
+ Right (concreteLiftedLambda, deps) ->
+ do
+ unless (any (isTypeGeneric . snd) pairs) $
+ do
+ modify (concreteLiftedLambda :)
+ modify (deps ++)
+ unless (null capturedVars) $
+ do
+ modify (environmentStruct :)
+ modify (deleteFn :)
+ modify (deleterDeps ++)
+ modify (copyFn :)
+ modify (copyDeps ++)
+ pure (Right [XObj (Fn (Just lambdaPath) (Set.fromList capturedVars)) (xobjInfo fn) (xobjTy fn), arr, recBody])
+mkLambda _ _ _ _ _ root = pure (Left (CannotConcretize root))
+
+-- | Concretize an anonymous function (fn [args...] <body>)
+--
+-- 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
+-- the C code.
+visitFn :: Visitor
+visitFn visited allowAmbig level tenv env x@(ListPat (FnPat fn args@(ArrPat arr) body)) =
+ do
+ mapM_ (concretizeTypeOfXObj tenv env) arr
+ let envWithArgs = fromRight Env.empty (envWithFunctionArgs env arr)
+ vBody <- visit visited allowAmbig Inside tenv (incrementEnvNestLevel envWithArgs) body
+ either (pure . Left) (\b -> mkLambda visited allowAmbig level tenv envWithArgs (setObj x (Lst [fn, args, b]))) vBody
+visitFn _ _ _ _ _ x = pure (Left (CannotConcretize x))
+
+--------------------------------------------------------------------------------
+-- Symbol concretization functions
+--
+-- Functions that concretely type arbitrary symbols, like `foo`
+-- This differ slightly from the functions that concretely type carp forms.
+--
+-- Symbols can designate:
+-- - A unique, and thus uniquely typed symbol.
+-- - An ambiguous "multi" symbol, the correct type of which is context-dependent
+-- - An interface symbol, which may be implemented by several concrete
+-- symbols of potentially different concrete types. Like the multi-symbol
+-- case, depends on context and type checking.
+
+-- | Concretely type a unique symbol.
+visitSymbol :: [SymPath] -> Bool -> TypeEnv -> Env -> XObj -> State [XObj] (Either TypeError XObj)
+visitSymbol visited allowAmbig tenv env xobj@(SymPat path mode) =
+ case searchValue env path of
+ Right (foundEnv, binder)
+ | envIsExternal foundEnv ->
+ let theXObj = binderXObj binder
+ Just theType = xobjTy theXObj
+ typeOfVisited = fromMaybe (error ("Missing type on " ++ show xobj ++ " at " ++ prettyInfoFromXObj xobj ++ " when looking up path " ++ show path)) (xobjTy xobj)
+ in if --(trace $ "CHECKING " ++ getName xobj ++ " : " ++ show theType ++ " with visited type " ++ show typeOfVisited ++ " and visited definitions: " ++ show visitedDefinitions) $
+ (isTypeGeneric theType && not (isTypeGeneric typeOfVisited))
+ then case concretizeDefinition allowAmbig tenv env visited theXObj typeOfVisited of
+ Left err -> pure (Left err)
+ Right (concrete, deps) ->
+ do
+ modify (concrete :)
+ modify (deps ++)
+ pure (Right (XObj (Sym (getPath concrete) mode) (xobjInfo xobj) (xobjTy xobj)))
+ else pure (Right xobj)
+ | otherwise -> pure (Right xobj)
+ _ -> pure (Right xobj)
+visitSymbol _ _ _ _ x = pure (Left (CannotConcretize x))
+
+-- | Concretely type a context-dependent multi-symbol.
+visitMultiSym :: [SymPath] -> Bool -> TypeEnv -> Env -> XObj -> State [XObj] (Either TypeError XObj)
+visitMultiSym visited allowAmbig tenv env xobj@(MultiSymPat name paths) =
+ case (filter (matchingSignature3 actualType) tysPathsModes) of
+ [] -> pure (Left (NoMatchingSignature xobj name actualType tysToPathsDict))
+ [x] -> go x
+ _ -> pure (Right xobj)
+ where
+ Just actualType = xobjTy xobj
+ tys = map (typeFromPath env) paths
+ modes = map (modeFromPath env) paths
+ tysToPathsDict = zip tys paths
+ tysPathsModes = zip3 tys paths modes
+ fake1 = XObj (Sym (SymPath [] "theType") Symbol) Nothing Nothing
+ fake2 = XObj (Sym (SymPath [] "xobjType") Symbol) Nothing Nothing
+ go :: (Ty, SymPath, SymbolMode) -> State [XObj] (Either TypeError XObj)
+ go (ty, path, mode) =
+ either
+ (pure . convertError)
+ (visitSymbol visited allowAmbig tenv env)
+ ( solve [Constraint ty actualType fake1 fake2 fake1 OrdMultiSym]
+ >>= pure . (flip replaceTyVars) actualType
+ >>= pure . suffixTyVars ("_x" ++ show (infoIdentifier (fromMaybe dummyInfo (xobjInfo xobj))))
+ >>= \t' -> pure (XObj (Sym path mode) (xobjInfo xobj) (Just t'))
+ )
+ convertError :: UnificationFailure -> Either TypeError XObj
+ convertError failure@(UnificationFailure _ _) =
+ Left (UnificationFailed (unificationFailure failure) (unificationMappings failure) [])
+ convertError (Holes holes) = Left (HolesFound holes)
+visitMultiSym _ _ _ _ x = pure (Left (CannotConcretize x))
+
+-- | Concretely type an interface symbol.
+visitInterfaceSym :: [SymPath] -> Bool -> TypeEnv -> Env -> XObj -> State [XObj] (Either TypeError XObj)
+visitInterfaceSym visited allowAmbig tenv env xobj@(InterfaceSymPat name) =
+ either (pure . const (Left (CannotConcretize xobj))) go (getTypeBinder tenv name)
+ where
+ Just actualType = (xobjTy xobj)
+ go :: Binder -> State [XObj] (Either TypeError XObj)
+ go (Binder _ (ListPat (InterfacePat _ paths))) =
+ let tys = map (typeFromPath env) paths
tysToPathsDict = zip tys paths
- tysPathsModes = zip3 tys paths modes
- in case filter (matchingSignature3 actualType) tysPathsModes of
- [] ->
- pure (Left (NoMatchingSignature xobj originalSymbolName actualType tysToPathsDict))
- [(theType, singlePath, mode)] ->
- let Just t' = t
- fake1 = XObj (Sym (SymPath [] "theType") Symbol) Nothing Nothing
- fake2 = XObj (Sym (SymPath [] "xobjType") Symbol) Nothing Nothing
- Just i' = i
- in case solve [Constraint theType t' fake1 fake2 fake1 OrdMultiSym] of
- Right mappings ->
- let replaced = (replaceTyVars mappings t')
- suffixed = suffixTyVars ("_x" ++ show (infoIdentifier i')) replaced -- Make sure it gets unique type variables. TODO: Is there a better way?
- normalSymbol = XObj (Sym singlePath mode) i (Just suffixed)
- in visitSymbol
- allowAmbig
- env
- --(trace ("Disambiguated " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj ++ " to " ++ show singlePath ++ " : " ++ show suffixed ++ ", used to be " ++ show t' ++ ", theType = " ++ show theType ++ ", mappings = " ++ show mappings) normalSymbol) normalSymbol
- normalSymbol
- Left failure@(UnificationFailure _ _) ->
- pure $
- Left
- ( UnificationFailed
- (unificationFailure failure)
- (unificationMappings failure)
- []
- )
- Left (Holes holes) ->
- pure $ Left (HolesFound holes)
- _ -> pure (Right xobj)
- visitMultiSym _ _ _ = error "Not a multi symbol."
- visitInterfaceSym :: Bool -> Env -> XObj -> State [XObj] (Either TypeError XObj)
- visitInterfaceSym allowAmbig env xobj@(XObj (InterfaceSym name) i t) =
- case getTypeBinder typeEnv name of
- Right (Binder _ (XObj (Lst [XObj (Interface _ interfacePaths) _ _, _]) _ _)) ->
- let Just actualType = t
- tys = map (typeFromPath env) interfacePaths
- tysToPathsDict = zip tys interfacePaths
- in case filter (matchingSignature actualType) tysToPathsDict of
- [] ->
- pure $ --(trace ("No matching signatures for interface lookup of " ++ name ++ " of type " ++ show actualType ++ " " ++ prettyInfoFromXObj xobj ++ ", options are:\n" ++ joinLines (map show tysToPathsDict))) $
- if allowAmbig
- then Right xobj -- No exact match of types
- else Left (NoMatchingSignature xobj name actualType tysToPathsDict)
- [(theType, singlePath)] ->
- --(trace ("One matching signature for interface lookup of '" ++ name ++ "' with single path " ++ show singlePath ++ " of type " ++ show theType ++ " at " ++ prettyInfoFromXObj xobj ++ ", original symbol: " ++ show xobj)) $
- let Just tt = t
- in if isTypeGeneric tt then pure (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" ++ joinLines (map show tysToPathsDict) ++ "\n Filtered paths are:\n" ++ (joinLines (map show severalPaths)))) $
- case filter (\(tt, _) -> typeEqIgnoreLifetimes actualType tt) severalPaths of
- [] ->
- --trace ("No exact matches for '" ++ show actualType ++ "'") $
- pure (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.
- _ -> pure (Left (SeveralExactMatches xobj name actualType severalPaths))
- where
- replace _ singlePath =
- let normalSymbol = XObj (Sym singlePath (LookupGlobal CarpLand AFunction)) i t -- TODO: Is it surely AFunction here? Could be AVariable as well...!?
- in visitSymbol
- allowAmbig
- env -- trace ("Replacing symbol " ++ pretty xobj ++ " with type " ++ show theType ++ " to single path " ++ show singlePath)
- normalSymbol
- Right _ -> error "visitinterfacesym1"
- Left _ ->
- error ("No interface named '" ++ name ++ "' found.")
- visitInterfaceSym _ _ _ = error "visitinterfacesym"
+ in case filter (matchingSignature actualType) tysToPathsDict of
+ [] -> pure $ if allowAmbig then Right xobj else Left (NoMatchingSignature xobj name actualType tysToPathsDict)
+ [x] -> updateSym x
+ xs -> case filter (typeEqIgnoreLifetimes actualType . fst) xs of
+ [] -> pure (Right xobj) -- No exact match of types
+ [y] -> updateSym y
+ ps -> pure (Left (SeveralExactMatches xobj name actualType ps))
+ go _ = pure (Left (CannotConcretize xobj))
+ -- TODO: Should we also check for allowAmbig here?
+ updateSym (_, path) = if isTypeGeneric actualType then pure (Right xobj) else replace path
+ replace path =
+ -- We pass the original xobj ty here, should we be passing the type found via matching signature?
+ let normalSymbol = XObj (Sym path (LookupGlobal CarpLand AFunction)) (xobjInfo xobj) (xobjTy xobj) -- TODO: Is it surely AFunction here? Could be AVariable as well...!?
+ in visitSymbol
+ visited
+ allowAmbig
+ tenv
+ env -- trace ("Replacing symbol " ++ pretty xobj ++ " with type " ++ show theType ++ " to single path " ++ show singlePath)
+ normalSymbol
+visitInterfaceSym _ _ _ _ x = pure (Left (CannotConcretize x))
toGeneralSymbol :: XObj -> XObj
toGeneralSymbol (XObj (Sym path _) _ t) = XObj (Sym path Symbol) (Just dummyInfo) t
@@ -376,7 +448,7 @@ toGeneralSymbol x = error ("Can't convert this to a general symbol: " ++ show x)
-- | Find all lookups in a lambda body that should be captured by its environment
collectCapturedVars :: XObj -> [XObj]
-collectCapturedVars root = removeDuplicates (map decreaseCaptureLevel (visit root))
+collectCapturedVars root = removeDuplicates (map decreaseCaptureLevel (visit' root))
where
removeDuplicates :: Ord a => [a] -> [a]
removeDuplicates = Set.toList . Set.fromList
@@ -398,7 +470,7 @@ collectCapturedVars root = removeDuplicates (map decreaseCaptureLevel (visit roo
(Just dummyInfo)
ty
decreaseCaptureLevel _ = error "decreasecapturelevel"
- visit xobj =
+ visit' xobj =
case xobjObj xobj of
-- don't peek inside lambdas, trust their capture lists:
(Lst [XObj (Fn _ captures) _ _, _, _]) -> Set.toList captures
@@ -408,26 +480,26 @@ collectCapturedVars root = removeDuplicates (map decreaseCaptureLevel (visit roo
let (bound, bindingsCaptured) =
foldl'
( \(bound', captured) (XObj sym _ ty, expr) ->
- let capt = filter (`Set.notMember` bound') (visit expr)
+ let capt = filter (`Set.notMember` bound') (visit' expr)
in (Set.insert (XObj sym (Just dummyInfo) ty) bound', capt ++ captured)
)
(Set.empty, [])
(pairwise bindings)
- in let bodyCaptured = filter (`Set.notMember` bound) (visit body)
+ in let bodyCaptured = filter (`Set.notMember` bound) (visit' body)
in bindingsCaptured ++ bodyCaptured
- (Lst _) -> visitList xobj
- (Arr _) -> visitArray xobj
+ (Lst _) -> visitList' xobj
+ (Arr _) -> visitArray' xobj
-- TODO: Static Arrays!
sym@(Sym _ (LookupLocal (Capture _))) -> [XObj sym (Just dummyInfo) (xobjTy xobj)]
_ -> []
- visitList :: XObj -> [XObj]
- visitList (XObj (Lst xobjs) _ _) =
- concatMap visit xobjs
- visitList _ = error "The function 'visitList' only accepts XObjs with lists in them."
- visitArray :: XObj -> [XObj]
- visitArray (XObj (Arr xobjs) _ _) =
- concatMap visit xobjs
- visitArray _ = error "The function 'visitArray' only accepts XObjs with arrays in them."
+ visitList' :: XObj -> [XObj]
+ visitList' (XObj (Lst xobjs) _ _) =
+ concatMap visit' xobjs
+ visitList' _ = error "The function 'visitList' only accepts XObjs with lists in them."
+ visitArray' :: XObj -> [XObj]
+ visitArray' (XObj (Arr xobjs) _ _) =
+ concatMap visit' xobjs
+ visitArray' _ = error "The function 'visitArray' only accepts XObjs with arrays in them."
-- | Do the signatures match?
matchingSignature :: Ty -> (Ty, SymPath) -> Bool
@@ -437,69 +509,70 @@ matchingSignature tA (tB, _) = areUnifiable tA tB
matchingSignature3 :: Ty -> (Ty, SymPath, SymbolMode) -> Bool
matchingSignature3 tA (tB, _, _) = areUnifiable tA tB
+--------------------------------------------------------------------------------
+-- Type concretization
+--
+-- These functions perform the actual work of converting generic types to concrete types.
+
-- | Does the type of an XObj require additional concretization of generic types or some typedefs for function types, etc?
-- | If so, perform the concretization and append the results to the list of dependencies.
-concretizeTypeOfXObj :: TypeEnv -> XObj -> State [XObj] (Either TypeError ())
-concretizeTypeOfXObj typeEnv (XObj _ _ (Just ty)) =
- case concretizeType typeEnv ty of
- Right t -> do
- modify (t ++)
- pure (Right ())
- Left err -> pure (Left err)
-concretizeTypeOfXObj _ _ = pure (Right ())
+concretizeTypeOfXObj :: TypeEnv -> Env -> XObj -> State [XObj] (Either TypeError ())
+concretizeTypeOfXObj typeEnv env (XObj _ _ (Just ty)) =
+ either (pure . Left) success (concretizeType typeEnv env ty)
+ where
+ success :: [XObj] -> State [XObj] (Either TypeError ())
+ success xs = modify (xs ++) >> pure (Right ())
+concretizeTypeOfXObj _ _ _ = pure (Right ())
-- | Find all the concrete deps of a type.
-concretizeType :: TypeEnv -> Ty -> Either TypeError [XObj]
-concretizeType _ ft@FuncTy {} =
+concretizeType :: TypeEnv -> Env -> Ty -> Either TypeError [XObj]
+concretizeType _ _ ft@FuncTy {} =
if isTypeGeneric ft
then Right []
else Right [defineFunctionTypeAlias ft]
-concretizeType typeEnv arrayTy@(StructTy (ConcreteNameTy (SymPath [] "Array")) varTys) =
+concretizeType typeEnv env arrayTy@(StructTy (ConcreteNameTy (SymPath [] "Array")) varTys) =
if isTypeGeneric arrayTy
then Right []
else do
- deps <- mapM (concretizeType typeEnv) varTys
+ deps <- mapM (concretizeType typeEnv env) varTys
Right (defineArrayTypeAlias arrayTy : concat deps)
-- TODO: Remove ugly duplication of code here:
-concretizeType typeEnv arrayTy@(StructTy (ConcreteNameTy (SymPath [] "StaticArray")) varTys) =
+concretizeType typeEnv env arrayTy@(StructTy (ConcreteNameTy (SymPath [] "StaticArray")) varTys) =
if isTypeGeneric arrayTy
then Right []
else do
- deps <- mapM (concretizeType typeEnv) varTys
+ deps <- mapM (concretizeType typeEnv env) varTys
Right (defineStaticArrayTypeAlias arrayTy : concat deps)
-concretizeType typeEnv genericStructTy@(StructTy (ConcreteNameTy (SymPath _ name)) _) =
- -- TODO: This function only looks up direct children of the type environment.
- -- However, spath can point to types that belong to a module. Pass the global env here.
- case (getTypeBinder typeEnv name) of
+concretizeType typeEnv env genericStructTy@(StructTy (ConcreteNameTy path@(SymPath _ name)) _) =
+ case (getTypeBinder typeEnv name) <> (findTypeBinder env path) of
Right (Binder _ x) -> go x
_ -> Right []
where
go :: XObj -> Either TypeError [XObj]
go (XObj (Lst (XObj (Deftype originalStructTy) _ _ : _ : rest)) _ _) =
if isTypeGeneric originalStructTy
- then instantiateGenericStructType typeEnv originalStructTy genericStructTy rest
+ then instantiateGenericStructType typeEnv env originalStructTy genericStructTy rest
else Right []
go (XObj (Lst (XObj (DefSumtype originalStructTy) _ _ : _ : rest)) _ _) =
if isTypeGeneric originalStructTy
- then instantiateGenericSumtype typeEnv originalStructTy genericStructTy rest
+ then instantiateGenericSumtype typeEnv env originalStructTy genericStructTy rest
else Right []
go (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _) = Right []
go x = error ("Non-deftype found in type env: " ++ pretty x)
-concretizeType t (RefTy rt _) =
- concretizeType t rt
-concretizeType t (PointerTy pt) =
- concretizeType t pt
-concretizeType _ _ =
+concretizeType t e (RefTy rt _) =
+ concretizeType t e rt
+concretizeType t e (PointerTy pt) =
+ concretizeType t e pt
+concretizeType _ _ _ =
Right [] -- ignore all other types
-- | Renames the type variable literals in a sum type for temporary validation.
renameGenericTypeSymbolsOnSum :: [(Ty, Ty)] -> XObj -> XObj
-renameGenericTypeSymbolsOnSum varpairs x@(XObj (Lst (caseNm : caseMembers)) i t) =
- case caseMembers of
- [XObj (Arr arr) ii tt] ->
- XObj (Lst (caseNm : [XObj (Arr (map replacer arr)) ii tt])) i t
- _ -> x
+renameGenericTypeSymbolsOnSum varpairs x@(XObj (Lst (caseNm : [a@(XObj (Arr arr) _ _)])) _ _) =
+ setObj x (Lst [caseNm, setObj a (Arr (map replacer arr))])
where
+ --XObj (Lst (caseNm : [XObj (Arr (map replacer arr)) ii tt])) i t
+
mapp = Map.fromList varpairs
replacer mem@(XObj (Sym (SymPath [] name) _) _ _) =
let Just perhapsTyVar = xobjToTy mem
@@ -523,53 +596,47 @@ renameGenericTypeSymbolsOnProduct vars members =
else mem
-- | Given an generic struct type and a concrete version of it, generate all dependencies needed to use the concrete one.
--- TODO: Handle polymorphic constructors (a b).
-instantiateGenericStructType :: TypeEnv -> Ty -> Ty -> [XObj] -> Either TypeError [XObj]
-instantiateGenericStructType typeEnv originalStructTy@(StructTy _ _) genericStructTy membersXObjs =
- -- Turn (deftype (A a) [x a, y a]) into (deftype (A Int) [x Int, y Int])
- let fake1 = XObj (Sym (SymPath [] "a") Symbol) Nothing Nothing
- fake2 = XObj (Sym (SymPath [] "b") Symbol) Nothing Nothing
- XObj (Arr memberXObjs) _ _ = head membersXObjs
- rename@(StructTy _ renamedOrig) = evalState (renameVarTys originalStructTy) 0
- in case solve [Constraint originalStructTy genericStructTy fake1 fake2 fake1 OrdMultiSym] of
- Left e -> error (show e)
- Right mappings ->
- let Right mapp = solve [Constraint rename genericStructTy fake1 fake2 fake1 OrdMultiSym]
- nameFixedMembers = renameGenericTypeSymbolsOnProduct renamedOrig memberXObjs
- validMembers = replaceGenericTypeSymbolsOnMembers mapp nameFixedMembers
- concretelyTypedMembers = replaceGenericTypeSymbolsOnMembers mappings memberXObjs
- in -- We only used the renamed types for validation--passing the
- -- renamed xobjs further down leads to syntactical issues.
- case validateMembers AllowAnyTypeVariableNames typeEnv renamedOrig validMembers of
- Left err -> Left err
- Right () ->
- let deps = mapM (depsForStructMemberPair typeEnv) (pairwise concretelyTypedMembers)
- in case deps of
- Left err -> Left err
- Right okDeps ->
- Right $
- XObj
- ( Lst
- ( XObj (Deftype genericStructTy) Nothing Nothing :
- XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing :
- [XObj (Arr concretelyTypedMembers) Nothing Nothing]
- )
- )
- (Just dummyInfo)
- (Just TypeTy) :
- concat okDeps
-instantiateGenericStructType _ _ _ _ = error "instantiategenericstructtype"
+--
+-- Turns (deftype (A a) [x a, y a]) into (deftype (A Int) [x Int, y Int])
+instantiateGenericStructType :: TypeEnv -> Env -> Ty -> Ty -> [XObj] -> Either TypeError [XObj]
+instantiateGenericStructType typeEnv env originalStructTy@(StructTy _ _) genericStructTy membersXObjs =
+ (replaceLeft (FailedToInstantiateGenericType originalStructTy) solution >>= go)
+ where
+ fake1 = XObj (Sym (SymPath [] "a") Symbol) Nothing Nothing
+ fake2 = XObj (Sym (SymPath [] "b") Symbol) Nothing Nothing
+ XObj (Arr memberXObjs) _ _ = head membersXObjs
+ rename@(StructTy _ renamedOrig) = evalState (renameVarTys originalStructTy) 0
+ solution = solve [Constraint originalStructTy genericStructTy fake1 fake2 fake1 OrdMultiSym]
+ go mappings = do
+ mappings' <- replaceLeft (FailedToInstantiateGenericType originalStructTy) (solve [Constraint rename genericStructTy fake1 fake2 fake1 OrdMultiSym])
+ let nameFixedMembers = renameGenericTypeSymbolsOnProduct renamedOrig memberXObjs
+ validMembers = replaceGenericTypeSymbolsOnMembers mappings' nameFixedMembers
+ concretelyTypedMembers = replaceGenericTypeSymbolsOnMembers mappings memberXObjs
+ validateMembers AllowAnyTypeVariableNames typeEnv env renamedOrig validMembers
+ deps <- mapM (depsForStructMemberPair typeEnv env) (pairwise concretelyTypedMembers)
+ let xobj =
+ XObj
+ ( Lst
+ ( XObj (Deftype genericStructTy) Nothing Nothing :
+ XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing :
+ [XObj (Arr concretelyTypedMembers) Nothing Nothing]
+ )
+ )
+ (Just dummyInfo)
+ (Just TypeTy) :
+ concat deps
+ pure xobj
+instantiateGenericStructType _ _ t _ _ = Left (FailedToInstantiateGenericType t)
-depsForStructMemberPair :: TypeEnv -> (XObj, XObj) -> Either TypeError [XObj]
-depsForStructMemberPair typeEnv (_, tyXObj) =
- case xobjToTy tyXObj of
- Just okTy -> concretizeType typeEnv okTy
- Nothing -> error ("Failed to convert " ++ pretty tyXObj ++ " to a type.")
+depsForStructMemberPair :: TypeEnv -> Env -> (XObj, XObj) -> Either TypeError [XObj]
+depsForStructMemberPair typeEnv env (_, tyXObj) =
+ maybe (Left (NotAType tyXObj)) (concretizeType typeEnv env) (xobjToTy tyXObj)
-- | Given an generic sumtype and a concrete version of it, generate all dependencies needed to use the concrete one.
-instantiateGenericSumtype :: TypeEnv -> Ty -> Ty -> [XObj] -> Either TypeError [XObj]
-instantiateGenericSumtype typeEnv originalStructTy@(StructTy _ originalTyVars) genericStructTy cases =
- -- Turn (deftype (Maybe a) (Just a) (Nothing)) into (deftype (Maybe Int) (Just Int) (Nothing))
+--
+-- Turn (deftype (Maybe a) (Just a) (Nothing)) into (deftype (Maybe Int) (Just Int) (Nothing))
+instantiateGenericSumtype :: TypeEnv -> Env -> Ty -> Ty -> [XObj] -> Either TypeError [XObj]
+instantiateGenericSumtype typeEnv env originalStructTy@(StructTy _ originalTyVars) genericStructTy cases =
let fake1 = XObj (Sym (SymPath [] "a") Symbol) Nothing Nothing
fake2 = XObj (Sym (SymPath [] "b") Symbol) Nothing Nothing
rename@(StructTy _ renamedOrig) = evalState (renameVarTys originalStructTy) 0
@@ -578,8 +645,8 @@ instantiateGenericSumtype typeEnv originalStructTy@(StructTy _ originalTyVars) g
Right mappings ->
let nameFixedCases = map (renameGenericTypeSymbolsOnSum (zip originalTyVars renamedOrig)) cases
concretelyTypedCases = map (replaceGenericTypeSymbolsOnCase mappings) nameFixedCases
- deps = mapM (depsForCase typeEnv) concretelyTypedCases
- in case toCases typeEnv AllowAnyTypeVariableNames renamedOrig concretelyTypedCases of -- Don't care about the cases, this is done just for validation.
+ deps = mapM (depsForCase typeEnv env) concretelyTypedCases
+ in case toCases typeEnv env AllowAnyTypeVariableNames renamedOrig concretelyTypedCases of -- Don't care about the cases, this is done just for validation.
Left err -> Left err
Right _ ->
case deps of
@@ -596,22 +663,19 @@ instantiateGenericSumtype typeEnv originalStructTy@(StructTy _ originalTyVars) g
(Just TypeTy) :
concat okDeps
Left err -> Left err
-instantiateGenericSumtype _ _ _ _ = error "instantiategenericsumtype"
+instantiateGenericSumtype _ _ _ _ _ = error "instantiategenericsumtype"
-- Resolves dependencies for sumtype cases.
-- NOTE: This function only accepts cases that are in "canonical form"
-- (Just [x]) aka XObj (Lst (Sym...) (Arr members))
-- On other cases it will return an error.
-depsForCase :: TypeEnv -> XObj -> Either TypeError [XObj]
-depsForCase typeEnv x@(XObj (Lst [_, XObj (Arr members) _ _]) _ _) =
+depsForCase :: TypeEnv -> Env -> XObj -> Either TypeError [XObj]
+depsForCase typeEnv env (XObj (Lst [_, XObj (Arr members) _ _]) _ _) =
concat
<$> mapM
- ( \m -> case xobjToTy m of
- Just okTy -> concretizeType typeEnv okTy
- Nothing -> error ("Failed to convert " ++ pretty m ++ " to a type: " ++ pretty x)
- )
+ (\t -> maybe (Left (NotAType t)) (concretizeType typeEnv env) (xobjToTy t))
members
-depsForCase _ x = Left (InvalidSumtypeCase x)
+depsForCase _ _ x = Left (InvalidSumtypeCase x)
replaceGenericTypeSymbolsOnMembers :: Map.Map String Ty -> [XObj] -> [XObj]
replaceGenericTypeSymbolsOnMembers mappings memberXObjs =
diff --git a/src/Context.hs b/src/Context.hs
index 2d6fa3d5..8094f1c7 100644
--- a/src/Context.hs
+++ b/src/Context.hs
@@ -2,6 +2,7 @@ module Context
( ContextError (..),
replaceGlobalEnv,
replaceInternalEnv,
+ replaceInternalEnvMaybe,
replaceTypeEnv,
replaceHistory,
replaceProject,
@@ -61,13 +62,13 @@ insertFailure path binder =
instance Show ContextError where
show (FailedToInsertInGlobalEnv path binder) =
insertFailure path binder
- ++ "in the context's global environment."
+ ++ " in the context's global environment."
show (FailedToInsertInTypeEnv path binder) =
insertFailure path binder
- ++ "in the context's type environment."
+ ++ " in the context's type environment."
show (FailedToInsertInInternalEnv path binder) =
insertFailure path binder
- ++ "in the context's internal environment."
+ ++ " in the context's internal environment."
show (AttemptedToInsertQualifiedInternalBinder path) =
"Attempted to insert a qualified binder: " ++ show path
++ " into a context's internal environment."
@@ -76,16 +77,16 @@ instance Show ContextError where
++ pathstring
show (NotFoundGlobal path) =
"Couldn't find the symbol: " ++ show path
- ++ "in the context's global environment."
+ ++ " in the context's global environment."
show (NotFoundType path) =
"Couldn't find the symbol: " ++ show path
- ++ "in the context's type environment."
+ ++ " in the context's type environment."
show (NotFoundContext path) =
"Couldn't find the symbol: " ++ show path
- ++ "in the context's context environment."
+ ++ " in the context's context environment."
show (NotFoundInternal path) =
"Couldn't find the symbol: " ++ show path
- ++ "in the context's internal environment."
+ ++ " in the context's internal environment."
--------------------------------------------------------------------------------
-- Contextual Class
@@ -118,6 +119,13 @@ replaceInternalEnv :: Context -> Env -> Context
replaceInternalEnv ctx env =
ctx {contextInternalEnv = Just env}
+-- | Replace a context's internal environment with a new environment or nothing.
+--
+-- The previous environment is completely replaced and will not be recoverable.
+replaceInternalEnvMaybe :: Context -> Maybe Env -> Context
+replaceInternalEnvMaybe ctx env =
+ ctx {contextInternalEnv = env}
+
-- | Replace a context's global environment with a new environment.
--
-- The previous environment is completely replaced and will not be recoverable.
diff --git a/src/Deftype.hs b/src/Deftype.hs
index f88a9e37..c4dbc87d 100644
--- a/src/Deftype.hs
+++ b/src/Deftype.hs
@@ -60,7 +60,7 @@ moduleForDeftype innerEnv typeEnv env pathStrings typeName typeVariables rest i
-- For example (module Vec2 [x Float]) creates bindings like Vec2.create, Vec2.x, etc.
insidePath = pathStrings ++ [typeName]
in do
- validateMemberCases typeEnv typeVariables rest
+ validateMemberCases typeEnv env typeVariables rest
let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables
(okMembers, membersDeps) <- templatesForMembers typeEnv env insidePath structTy rest
okInit <- binderForInit insidePath structTy rest
@@ -83,7 +83,7 @@ bindingsForRegisteredType typeEnv env pathStrings typeName rest i existingEnv =
moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv)
insidePath = pathStrings ++ [typeName]
in do
- validateMemberCases typeEnv [] rest
+ validateMemberCases typeEnv env [] rest
let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) []
(binders, deps) <- templatesForMembers typeEnv env insidePath structTy rest
okInit <- binderForInit insidePath structTy rest
@@ -382,7 +382,7 @@ genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameT
t = FuncTy (map snd (memberXObjsToPairs membersXObjs)) originalStructTy StaticLifetimeTy
docs = "creates a `" ++ show originalStructTy ++ "`."
templateCreator = TemplateCreator $
- \typeEnv _ ->
+ \typeEnv env ->
Template
(FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p") StaticLifetimeTy)
( \(FuncTy _ concreteStructTy _) ->
@@ -397,7 +397,7 @@ genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameT
in tokensForInit allocationMode (show originalStructTy) correctedMembers
)
( \(FuncTy _ concreteStructTy _) ->
- case concretizeType typeEnv concreteStructTy of
+ case concretizeType typeEnv env concreteStructTy of
Left _ -> []
Right ok -> ok
)
diff --git a/src/Emit.hs b/src/Emit.hs
index 54f4c65b..e003e15a 100644
--- a/src/Emit.hs
+++ b/src/Emit.hs
@@ -307,7 +307,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
appendToSrc (addIndent indent ++ "{\n")
let innerIndent = indent + indentAmount
ret <- visit innerIndent expr
- appendToSrc (addIndent innerIndent ++ pathToC path ++ " = " ++ ret ++ ";\n")
+ when (ret /= "") $ appendToSrc (addIndent innerIndent ++ pathToC path ++ " = " ++ ret ++ ";\n")
delete innerIndent info
appendToSrc (addIndent indent ++ "}\n")
pure ""
@@ -895,7 +895,9 @@ toDeclaration (Binder meta xobj@(XObj (Lst xobjs) _ ty)) =
in defnToDeclaration meta path argList retTy ++ ";\n"
[XObj Def _ _, XObj (Sym path _) _ _, _] ->
let Just t = ty
- in "" ++ tyToCLambdaFix t ++ " " ++ pathToC path ++ ";\n"
+ in if (isUnit t)
+ then ""
+ else tyToCLambdaFix t ++ " " ++ pathToC path ++ ";\n"
XObj (Deftype t) _ _ : XObj (Sym path _) _ _ : rest ->
defStructToDeclaration t path rest
XObj (DefSumtype t) _ _ : XObj (Sym _ _) _ _ : rest ->
@@ -926,6 +928,7 @@ toDeclaration (Binder meta xobj@(XObj (Lst xobjs) _ ty)) =
XObj (Primitive _) _ _ : _ ->
""
_ -> error ("Internal compiler error: Can't emit other kinds of definitions: " ++ show xobj)
+toDeclaration (Binder _ (XObj (Sym (SymPath [] "dummy") Symbol) Nothing (Just IntTy))) = ""
toDeclaration _ = error "Missing case."
paramListToC :: [XObj] -> String
@@ -1006,7 +1009,7 @@ globalsToC globalEnv =
typeEnvToDeclarations :: TypeEnv -> Env -> Either ToCError String
typeEnvToDeclarations typeEnv global =
let -- We need to carry the type environment to pass the correct environment on the binderToDeclaration call.
- addEnvToScore tyE = (sortDeclarationBinders tyE (map snd (Map.toList (binders tyE))))
+ addEnvToScore tyE = (sortDeclarationBinders tyE global (map snd (Map.toList (binders tyE))))
bindersWithScore = (addEnvToScore typeEnv)
mods = (findModules global)
folder =
@@ -1027,7 +1030,7 @@ typeEnvToDeclarations typeEnv global =
envToDeclarations :: TypeEnv -> Env -> Either ToCError String
envToDeclarations typeEnv env =
- let bindersWithScore = sortDeclarationBinders typeEnv (map snd (Map.toList (envBindings env)))
+ let bindersWithScore = sortDeclarationBinders typeEnv env (map snd (Map.toList (envBindings env)))
in do
okDecls <-
mapM
@@ -1042,10 +1045,10 @@ envToDeclarations typeEnv env =
-- debugScorePair :: (Int, Binder) -> (Int, Binder)
-- debugScorePair (s,b) = trace ("Scored binder: " ++ show b ++ ", score: " ++ show s) (s,b)
-sortDeclarationBinders :: TypeEnv -> [Binder] -> [(Int, Binder)]
-sortDeclarationBinders typeEnv binders' =
+sortDeclarationBinders :: TypeEnv -> Env -> [Binder] -> [(Int, Binder)]
+sortDeclarationBinders typeEnv env binders' =
--trace ("\nSORTED: " ++ (show (sortOn fst (map (scoreBinder typeEnv) binders))))
- sortOn fst (map (scoreTypeBinder typeEnv) binders')
+ sortOn fst (map (scoreTypeBinder typeEnv env) binders')
sortGlobalVariableBinders :: Env -> [Binder] -> [(Int, Binder)]
sortGlobalVariableBinders globalEnv binders' =
diff --git a/src/Env.hs b/src/Env.hs
index 36c250a7..0e08a3dd 100644
--- a/src/Env.hs
+++ b/src/Env.hs
@@ -292,7 +292,13 @@ getTypeBinder = getBinder
--
-- Restricts the final step of a search to binders in a module's *type* environment.
findType :: Environment e => e -> SymPath -> Either EnvironmentError (TypeEnv, Binder)
-findType e path = find' (inj (prj e)) path
+findType e path = go $ find' (inj (prj e)) path
+ -- Make sure the binder is actually a type.
+ where go :: Either EnvironmentError (TypeEnv, Binder) -> Either EnvironmentError (TypeEnv, Binder)
+ go (Right (t, b)) = if isType (binderXObj b)
+ then Right (t, b)
+ else Left (BindingNotFound (show path) (prj e))
+ go x = x
findTypeBinder :: Environment e => e -> SymPath -> Either EnvironmentError Binder
findTypeBinder e path = fmap snd (findType e path)
diff --git a/src/Eval.hs b/src/Eval.hs
index d4b02077..fe52a650 100644
--- a/src/Eval.hs
+++ b/src/Eval.hs
@@ -200,7 +200,7 @@ eval ctx xobj@(XObj o info ty) preference resolver =
(AppPat (MacroPat _ _ _) _) -> evaluateMacro form'
(AppPat (CommandPat _ _ _) _) -> evaluateCommand form'
(AppPat (PrimitivePat _ _ _) _) -> evaluatePrimitive form'
- (WithPat _ sym@(SymPat path) forms) -> specialCommandWith ctx sym path forms
+ (WithPat _ sym@(SymPat path _) forms) -> specialCommandWith ctx sym path forms
(DoPat _ forms) -> evaluateSideEffects forms
(WhilePat _ cond body) -> specialCommandWhile ctx cond body
(SetPat _ iden value) -> specialCommandSet ctx (iden : [value])
@@ -217,7 +217,7 @@ eval ctx xobj@(XObj o info ty) preference resolver =
-- Importantly, the loop *is only broken on literal nested lists*.
-- That is, passing a *symbol* that, e.g. resolves to a defn list, won't
-- break our normal loop.
- (AppPat self@(ListPat (x@(SymPat _) : _)) args) ->
+ (AppPat self@(ListPat (x@(SymPat _ _) : _)) args) ->
do
(_, evald) <- eval ctx x preference ResolveGlobal
case evald of
@@ -226,7 +226,7 @@ eval ctx xobj@(XObj o info ty) preference resolver =
Right _ -> evaluateApp (self : args)
Left er -> pure (evalError ctx (show er) (xobjInfo xobj))
(AppPat (ListPat _) _) -> evaluateApp form'
- (AppPat (SymPat _) _) -> evaluateApp form'
+ (AppPat (SymPat _ _) _) -> evaluateApp form'
[] -> pure (ctx, dynamicNil)
_ -> pure (throwErr (UnknownForm xobj) ctx (xobjInfo xobj))
checkStatic' (XObj Def _ _) = Left (HasStaticCall xobj info)
@@ -277,9 +277,9 @@ eval ctx xobj@(XObj o info ty) preference resolver =
Right newCtx -> do
(finalCtx, evaledBody) <- eval newCtx body (PreferLocal (map (\(name, _) -> (SymPath [] name)) binds)) ResolveLocal
let Just e = contextInternalEnv finalCtx
- parentEnv = fromMaybe e (envParent e)
+ parentEnv = envParent e
pure
- ( replaceInternalEnv finalCtx parentEnv,
+ ( replaceInternalEnvMaybe finalCtx parentEnv,
do
okBody <- evaledBody
Right okBody
@@ -298,7 +298,7 @@ eval ctx xobj@(XObj o info ty) preference resolver =
-- (let [f (fn [x] (if (= x 1) x (f (dec x))))] (f 10))
let origin = (contextInternalEnv ctx')
recFix = (E.recursive origin (Just "let-rec-env") 0)
- Right envWithSelf = E.insertX recFix (SymPath [] n) x
+ Right envWithSelf = if isFn x then E.insertX recFix (SymPath [] n) x else Right recFix
ctx'' = replaceInternalEnv ctx' envWithSelf
(newCtx, res) <- eval ctx'' x preference resolver
case res of
@@ -389,7 +389,7 @@ eval ctx xobj@(XObj o info ty) preference resolver =
evaluateApp (AppPat f' args) =
case f' of
l@(ListPat _) -> go l ResolveLocal
- sym@(SymPat _) -> go sym resolver
+ sym@(SymPat _ _) -> go sym resolver
_ -> pure (evalError ctx (format (GenericMalformed xobj)) (xobjInfo xobj))
where
go x resolve =
@@ -501,10 +501,13 @@ apply ctx@Context {contextInternalEnv = internal} body params args =
-- | Parses a string and then converts the resulting forms to commands, which are evaluated in order.
executeString :: Bool -> Bool -> Context -> String -> String -> IO Context
-executeString doCatch printResult ctx input fileName =
+executeString = executeStringAtLine 1
+
+executeStringAtLine :: Int -> Bool -> Bool -> Context -> String -> String -> IO Context
+executeStringAtLine line doCatch printResult ctx input fileName =
if doCatch then catch exec (catcher ctx) else exec
where
- exec = case parse input fileName of
+ exec = case parseAtLine line input fileName of
Left parseError ->
let sourcePos = Parsec.errorPos parseError
parseErrorXObj =
diff --git a/src/Forms.hs b/src/Forms.hs
index f03b0d7d..45c1e9c9 100644
--- a/src/Forms.hs
+++ b/src/Forms.hs
@@ -30,12 +30,17 @@ module Forms
pattern DoPat,
pattern WhilePat,
pattern SetPat,
+ pattern MultiSymPat,
+ pattern InterfaceSymPat,
+ pattern MatchPat,
+ pattern InterfacePat,
)
where
import Data.List (intercalate)
import Obj
import SymPath
+import Types
import Util
--------------------------------------------------------------------------------
@@ -244,7 +249,7 @@ validateWhile invalid = Left (GenericMalformed (XObj (Lst invalid) Nothing Nothi
-- | Validation of (def name value) expressions.
validateDef :: [XObj] -> Either Malformed [XObj]
validateDef x@(DefPat _ (UnqualifiedSymPat _) _) = Right x
-validateDef (DefPat _ invalid@(SymPat _) _) = Left (QualifiedIdentifier invalid None)
+validateDef (DefPat _ invalid@(SymPat _ _) _) = Left (QualifiedIdentifier invalid None)
validateDef (DefPat _ invalid _) = Left (InvalidIdentifier invalid None)
validateDef def = Left (GenericMalformed (XObj (Lst def) Nothing Nothing))
@@ -257,7 +262,7 @@ validateDefn x@(DefnPat _ (UnqualifiedSymPat _) arr@(ArrPat args) _)
| otherwise = pure x
validateDefn (DefnPat _ (UnqualifiedSymPat _) invalid _) =
Left (InvalidArguments invalid (DefnNonArrayArgs invalid))
-validateDefn (DefnPat _ invalid@(SymPat _) _ _) = Left (QualifiedIdentifier invalid None)
+validateDefn (DefnPat _ invalid@(SymPat _ _) _ _) = Left (QualifiedIdentifier invalid None)
validateDefn (DefnPat _ invalid _ _) = Left (InvalidIdentifier invalid None)
validateDefn defn = Left (GenericMalformed (XObj (Lst defn) Nothing Nothing))
@@ -348,7 +353,7 @@ validateApp app = Left (GenericMalformed (XObj (Lst app) Nothing Nothing))
-- | Validation of (with module body) expressions
validateWith :: [XObj] -> Either Malformed [XObj]
-validateWith x@(WithPat _ (SymPat _) _) = Right x
+validateWith x@(WithPat _ (SymPat _ _) _) = Right x
validateWith (WithPat _ invalid _) = Left (InvalidIdentifier invalid (InvalidWith invalid))
validateWith with = Left (GenericMalformed (XObj (Lst with) Nothing Nothing))
@@ -377,8 +382,8 @@ pattern StaticArrPat members <- XObj (StaticArr members) _ _
pattern ListPat :: [XObj] -> XObj
pattern ListPat members <- XObj (Lst members) _ _
-pattern SymPat :: SymPath -> XObj
-pattern SymPat path <- XObj (Sym path _) _ _
+pattern SymPat :: SymPath -> SymbolMode -> XObj
+pattern SymPat path mode <- XObj (Sym path mode) _ _
pattern UnqualifiedSymPat :: SymPath -> XObj
pattern UnqualifiedSymPat path <- XObj (Sym path@(SymPath [] _) _) _ _
@@ -433,3 +438,15 @@ pattern PrimitivePat arity sym params <- XObj (Lst [XObj (Primitive arity) _ _,
pattern AppPat :: XObj -> [XObj] -> [XObj]
pattern AppPat f args <- (f : args)
+
+pattern InterfaceSymPat :: String -> XObj
+pattern InterfaceSymPat name <- XObj (InterfaceSym name) _ _
+
+pattern MultiSymPat :: String -> [SymPath] -> XObj
+pattern MultiSymPat name candidates <- XObj (MultiSym name candidates) _ _
+
+pattern MatchPat :: XObj -> XObj -> [XObj] -> [XObj]
+pattern MatchPat match value stanzas <- (match@(XObj (Match _) _ _) : value : stanzas)
+
+pattern InterfacePat :: Ty -> [SymPath] -> [XObj]
+pattern InterfacePat ty paths <- [XObj (Interface ty paths) _ _, _]
diff --git a/src/Obj.hs b/src/Obj.hs
index 75d83f49..beb3d565 100644
--- a/src/Obj.hs
+++ b/src/Obj.hs
@@ -228,10 +228,19 @@ isTypeDef (XObj (Lst (XObj (Deftype _) _ _ : _)) _ _) = True
isTypeDef (XObj (Lst (XObj (DefSumtype _) _ _ : _)) _ _) = True
isTypeDef _ = False
+isType :: XObj -> Bool
+isType (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _) = True
+isType x = isTypeDef x
+
isMod :: XObj -> Bool
isMod (XObj (Mod _ _) _ _) = True
isMod _ = False
+isFn :: XObj -> Bool
+isFn (XObj (Lst (XObj (Fn _ _) _ _ : _)) _ _) = True
+isFn (XObj (Lst (XObj (Sym (SymPath [] "fn") _) _ _ : _)) _ _) = True
+isFn _ = False
+
-- | This instance is needed for the dynamic Dictionary
instance Ord Obj where
compare (Str a) (Str b) = compare a b
@@ -330,6 +339,9 @@ data XObj = XObj
}
deriving (Show, Eq, Ord)
+setObj :: XObj -> Obj -> XObj
+setObj x o = x {xobjObj = o}
+
instance Hashable XObj where
hashWithSalt s XObj {..} = s `hashWithSalt` xobjObj
diff --git a/src/Parsing.hs b/src/Parsing.hs
index 58081e85..b9781f76 100644
--- a/src/Parsing.hs
+++ b/src/Parsing.hs
@@ -2,6 +2,7 @@
module Parsing
( parse,
+ parseAtLine,
validCharacters,
balance,
)
@@ -599,11 +600,14 @@ lispSyntax = do
Parsec.eof
pure result
-parse :: String -> String -> Either Parsec.ParseError [XObj]
-parse text fileName =
- let initState = ParseState (Info 1 1 fileName (Set.fromList []) 0)
+parseAtLine :: Int -> String -> String -> Either Parsec.ParseError [XObj]
+parseAtLine line text fileName =
+ let initState = ParseState (Info line 1 fileName (Set.fromList []) 0)
in Parsec.runParser lispSyntax initState fileName text
+parse :: String -> String -> Either Parsec.ParseError [XObj]
+parse = parseAtLine 1
+
{-# ANN balance "HLint: ignore Use String" #-}
-- | For detecting the parenthesis balance in a string, i.e. "((( ))" = 1
diff --git a/src/Polymorphism.hs b/src/Polymorphism.hs
index 1973cde6..0e6e69a5 100644
--- a/src/Polymorphism.hs
+++ b/src/Polymorphism.hs
@@ -7,7 +7,8 @@ module Polymorphism
)
where
-import Data.Either (fromRight)
+import Data.Either (fromRight, rights)
+import Data.List (unionBy)
import Env
import Managed
import Obj
@@ -54,14 +55,16 @@ allImplementations typeEnv env functionName functionType =
foundBindings = case getTypeBinder typeEnv functionName of
-- this function is an interface; lookup implementations
Right (Binder _ (XObj (Lst (XObj (Interface _ paths) _ _ : _)) _ _)) ->
- case sequence $ map (\p -> searchValue env p) (paths ++ [(SymPath [] functionName)]) of
- Right found -> found
- Left _ ->
- case findPoly env functionName functionType of
- Right r -> [r]
- Left _ -> (lookupEverywhere env functionName)
+ case rights $ map (\p -> searchValue env p) (paths ++ [(SymPath [] functionName)]) of
+ [] -> getPoly
+ -- getPoly might return some functions we already found. Use set ops
+ -- to remove duplicates.
+ found -> (unionBy (\x y -> (snd x) == (snd y)) found getPoly)
-- just a regular function; look for it
_ -> fromRight [] ((fmap (: []) (Env.getValue env functionName)) <> pure (lookupEverywhere env functionName))
+ getPoly = case findPoly env functionName functionType of
+ Right r -> [r]
+ Left _ -> (lookupEverywhere env functionName)
-- | The various results when trying to find a function using 'findFunctionForMember'.
data FunctionFinderResult
diff --git a/src/Primitives.hs b/src/Primitives.hs
index fe5bd8de..675ed3af 100644
--- a/src/Primitives.hs
+++ b/src/Primitives.hs
@@ -16,10 +16,12 @@ import Data.Maybe (fromJust, fromMaybe)
import Deftype
import Emit
import Env (addUsePath, contextEnv, insert, lookupBinderEverywhere, lookupEverywhere, lookupMeta, searchValueBinder)
+import EvalError
import Infer
import Info
import Interfaces
import Managed
+import qualified Map
import qualified Meta
import Obj
import PrimitiveError
@@ -74,7 +76,7 @@ makePrim path callback doc example =
XObj (Arr args) Nothing Nothing
]
)
- (Just dummyInfo)
+ (Just dummyInfo {infoFile = "Core Primitives"})
(Just DynamicTy)
args = (\x -> XObj (Sym (SymPath [] x) Symbol) Nothing Nothing) <$> argnames
argnames = case callback of
@@ -347,6 +349,48 @@ primitiveInfo _ ctx target@(XObj (Sym path@(SymPath _ name) _) _ _) =
primitiveInfo _ ctx notName =
argumentErr ctx "info" "a name" "first" notName
+-- | Get information about a binding.
+primitiveStructuredInfo :: UnaryPrimitiveCallback
+primitiveStructuredInfo (XObj _ i _) ctx (XObj (Sym path _) _ _) =
+ case lookupBinderInTypeEnv ctx path of
+ Right bind -> return (ctx, Right $ workOnBinder bind)
+ Left _ ->
+ case lookupBinderInContextEnv ctx path of
+ Right bind -> return (ctx, Right $ workOnBinder bind)
+ Left e -> return $ throwErr e ctx i
+ where
+ workOnBinder :: Binder -> XObj
+ workOnBinder (Binder metaData (XObj _ (Just (Info l c f _ _)) t)) =
+ makeX
+ ( Lst
+ [ (maybe (makeX (Lst [])) reify t),
+ makeX
+ ( Lst
+ [ makeX (Str f),
+ makeX (Num IntTy (Integral l)),
+ makeX (Num IntTy (Integral c))
+ ]
+ ),
+ metaList metaData
+ ]
+ )
+ workOnBinder (Binder metaData (XObj _ _ t)) =
+ makeX
+ ( Lst
+ [ (maybe (makeX (Lst [])) reify t),
+ makeX (Lst []),
+ metaList metaData
+ ]
+ )
+ metaList :: MetaData -> XObj
+ metaList (MetaData m) =
+ makeX (Lst (map genPair (Map.toList m)))
+ where
+ genPair (s, x) = makeX (Lst [XObj (Str s) Nothing Nothing, x])
+ makeX o = XObj o Nothing Nothing
+primitiveStructuredInfo _ ctx notName =
+ argumentErr ctx "structured-info" "a name" "first" notName
+
dynamicOrMacroWith :: Context -> (SymPath -> [XObj]) -> Ty -> String -> XObj -> IO (Context, Either EvalError XObj)
dynamicOrMacroWith ctx producer ty name body = do
let qpath = qualifyPath ctx (SymPath [] name)
@@ -371,7 +415,6 @@ primitiveMembers _ ctx xobj@(XObj (Sym path _) _ _) =
go (XObj (Lst ((XObj (DefSumtype _) _ _) : _ : cases)) _ _) =
pure $ (ctx, (either Left (\a -> Right (XObj (Arr (concat a)) Nothing Nothing)) (mapM getMembersFromCase cases)))
go x = pure (toEvalError ctx x (NonTypeInTypeEnv path x))
-
getMembersFromCase :: XObj -> Either EvalError [XObj]
getMembersFromCase (XObj (Lst members) _ _) =
Right (map (\(a, b) -> XObj (Lst [a, b]) Nothing Nothing) (pairwise members))
@@ -666,7 +709,6 @@ primitiveUse xobj ctx (XObj (Sym path _) _ _) =
updateGlobalUsePaths :: Env -> SymPath -> (Context, Either EvalError XObj)
updateGlobalUsePaths e spath =
((replaceGlobalEnv ctx (addUsePath e spath)), dynamicNil)
-
updateModuleUsePaths :: Env -> SymPath -> Binder -> SymPath -> (Context, Either EvalError XObj)
updateModuleUsePaths e p (Binder meta (XObj (Mod ev et) i t)) spath =
either
diff --git a/src/Repl.hs b/src/Repl.hs
index a6f439cc..960935eb 100644
--- a/src/Repl.hs
+++ b/src/Repl.hs
@@ -112,8 +112,8 @@ treatSpecialInput (':' : rest) =
Nothing -> rewriteError ("Unknown special command: :" ++ [cmd])
treatSpecialInput arg = arg
-repl :: String -> String -> InputT (StateT Context IO) ()
-repl readSoFar prompt =
+repl :: Int -> String -> String -> InputT (StateT Context IO) ()
+repl line readSoFar prompt =
do
context <- lift get
input <- getInputLine (strWithColor Yellow prompt)
@@ -128,10 +128,10 @@ repl readSoFar prompt =
case balanced of
"" -> do
let input' = if concatenated == "\n" then contextLastInput context else concatenated -- Entering an empty string repeats last input
- context' <- liftIO $ executeString True True (resetAlreadyLoadedFiles context) (treatSpecialInput input') "REPL"
+ context' <- liftIO $ executeStringAtLine line True True (resetAlreadyLoadedFiles context) (treatSpecialInput input') "REPL"
lift $ put context'
- repl "" (projectPrompt proj)
- _ -> repl concatenated (if projectBalanceHints proj then balanced else "")
+ repl (line + (length (filter ('\n' ==) input'))) "" (projectPrompt proj)
+ _ -> repl line concatenated (if projectBalanceHints proj then balanced else "")
resetAlreadyLoadedFiles :: Context -> Context
resetAlreadyLoadedFiles context =
@@ -143,4 +143,4 @@ runRepl :: Context -> IO ((), Context)
runRepl context = do
historyPath <- configPath "history"
createDirectoryIfMissing True (takeDirectory historyPath)
- runStateT (runInputT (readlineSettings historyPath) (repl "" (projectPrompt (contextProj context)))) context
+ runStateT (runInputT (readlineSettings historyPath) (repl 1 "" (projectPrompt (contextProj context)))) context
diff --git a/src/Scoring.hs b/src/Scoring.hs
index 9efa256c..936c424b 100644
--- a/src/Scoring.hs
+++ b/src/Scoring.hs
@@ -10,8 +10,8 @@ import TypesToC
-- | Scoring of types.
-- | The score is used for sorting the bindings before emitting them.
-- | A lower score means appearing earlier in the emitted file.
-scoreTypeBinder :: TypeEnv -> Binder -> (Int, Binder)
-scoreTypeBinder typeEnv b@(Binder _ (XObj (Lst (XObj x _ _ : XObj (Sym _ _) _ _ : _)) _ _)) =
+scoreTypeBinder :: TypeEnv -> Env -> Binder -> (Int, Binder)
+scoreTypeBinder typeEnv env b@(Binder _ (XObj (Lst (XObj x _ _ : XObj (Sym _ _) _ _ : _)) _ _)) =
case x of
Defalias aliasedType ->
let selfName = ""
@@ -24,14 +24,16 @@ scoreTypeBinder typeEnv b@(Binder _ (XObj (Lst (XObj x _ _ : XObj (Sym _ _) _ _
ExternalType _ -> (0, b)
_ -> (500, b)
where
- depthOfStruct (StructTy (ConcreteNameTy (SymPath _ name)) varTys) =
- case E.getTypeBinder typeEnv name of
+ depthOfStruct (StructTy (ConcreteNameTy path@(SymPath _ name)) varTys) =
+ case E.getTypeBinder typeEnv name <> findTypeBinder env path of
Right (Binder _ typedef) -> (depthOfDeftype typeEnv Set.empty typedef varTys + 1, b)
+ -- TODO: This function should return (Either ScoringError (Int,
+ -- Binder)) instead of calling error.
Left e -> error (show e)
depthOfStruct _ = error "depthofstruct"
-scoreTypeBinder _ b@(Binder _ (XObj (Mod _ _) _ _)) =
+scoreTypeBinder _ _ b@(Binder _ (XObj (Mod _ _) _ _)) =
(1000, b)
-scoreTypeBinder _ x = error ("Can't score: " ++ show x)
+scoreTypeBinder _ _ x = error ("Can't score: " ++ show x)
depthOfDeftype :: TypeEnv -> Set.Set Ty -> XObj -> [Ty] -> Int
depthOfDeftype typeEnv visited (XObj (Lst (_ : XObj (Sym (SymPath path selfName) _) _ _ : rest)) _ _) varTys =
@@ -64,7 +66,28 @@ depthOfType typeEnv visited selfName theType =
visitType t@(StructTy _ varTys) = depthOfStructType t varTys
visitType (FuncTy argTys retTy ltTy) =
-- trace ("Depth of args of " ++ show argTys ++ ": " ++ show (map (visitType . Just) argTys))
- maximum (visitType ltTy : visitType retTy : fmap visitType argTys)
+ --
+ -- The `+ 1` in the function clause below is an important band-aid.
+ -- Here's the issue:
+ -- When we resolve declarations, some types may reference other types
+ -- that have not been scored yet. When that happens, we add 500 to the
+ -- binder to ensure it appears later than the types we'll resolve later
+ -- on.
+ --
+ -- However, this means that function types can be tied w/ such binders
+ -- when this case holds since they only took the maximum of their type
+ -- members. e.g. both a struct and its functions might be
+ -- scored "504" and we might incorrectly emit the functions before the
+ -- struct.
+ --
+ -- Since functions are *always* dependent on the types in their
+ -- signature, add 1 to ensure they appear after those types in all
+ -- possible scenarios.
+ --
+ -- TODO: Should we find a more robust solution that explicitly
+ -- accounts for unresolved types and scores based on these rather than
+ -- relying on our hardcoded adjustments being correct?
+ maximum (visitType ltTy : visitType retTy : fmap visitType argTys) + 1
visitType (PointerTy p) = visitType p
visitType (RefTy r lt) = max (visitType r) (visitType lt)
visitType _ = 1
diff --git a/src/StartingEnv.hs b/src/StartingEnv.hs
index ff8cbcbf..bb531c4e 100644
--- a/src/StartingEnv.hs
+++ b/src/StartingEnv.hs
@@ -297,6 +297,7 @@ dynamicModule =
let f = makeUnaryPrim . spath
in [ f "quote" (\_ ctx x -> pure (ctx, Right x)) "quotes any value." "(quote x) ; where x is an actual symbol",
f "info" primitiveInfo "prints all information associated with a symbol." "(info mysymbol)",
+ f "structured-info" primitiveStructuredInfo "gets all information associated with a symbol as a list of the form `(type|(), info|(), metadata)`." "(structured-info mysymbol)",
f "managed?" primitiveIsManaged "checks whether a type is managed by Carp by checking whether `delete` was implemented for it. For an explanation of memory management, you can reference [this document](https://carp-lang.github.io/carp-docs/Memory.html)." "(register-type Unmanaged \"void*\")\n(managed? Unmanaged) ; => false",
f "members" primitiveMembers "returns the members of a type as an array." "(members MyType)",
f "use" primitiveUse "uses a module, i.e. imports the symbols inside that module into the current module." "(use MyModule)",
diff --git a/src/SumtypeCase.hs b/src/SumtypeCase.hs
index 5e0bf26f..43cf45c8 100644
--- a/src/SumtypeCase.hs
+++ b/src/SumtypeCase.hs
@@ -11,17 +11,17 @@ data SumtypeCase = SumtypeCase
}
deriving (Show, Eq)
-toCases :: TypeEnv -> TypeVarRestriction -> [Ty] -> [XObj] -> Either TypeError [SumtypeCase]
-toCases typeEnv restriction typeVars = mapM (toCase typeEnv restriction typeVars)
+toCases :: TypeEnv -> Env -> TypeVarRestriction -> [Ty] -> [XObj] -> Either TypeError [SumtypeCase]
+toCases typeEnv globalEnv restriction typeVars = mapM (toCase typeEnv globalEnv restriction typeVars)
-toCase :: TypeEnv -> TypeVarRestriction -> [Ty] -> XObj -> Either TypeError SumtypeCase
-toCase typeEnv restriction typeVars x@(XObj (Lst [XObj (Sym (SymPath [] name) Symbol) _ _, XObj (Arr tyXObjs) _ _]) _ _) =
+toCase :: TypeEnv -> Env -> TypeVarRestriction -> [Ty] -> XObj -> Either TypeError SumtypeCase
+toCase typeEnv globalEnv restriction typeVars x@(XObj (Lst [XObj (Sym (SymPath [] name) Symbol) _ _, XObj (Arr tyXObjs) _ _]) _ _) =
let tys = map xobjToTy tyXObjs
in case sequence tys of
Nothing ->
Left (InvalidSumtypeCase x)
Just okTys ->
- let validated = map (\t -> canBeUsedAsMemberType restriction typeEnv typeVars t x) okTys
+ let validated = map (\t -> canBeUsedAsMemberType restriction typeEnv globalEnv typeVars t x) okTys
in case sequence validated of
Left e ->
Left e
@@ -31,11 +31,11 @@ toCase typeEnv restriction typeVars x@(XObj (Lst [XObj (Sym (SymPath [] name) Sy
{ caseName = name,
caseTys = okTys
}
-toCase _ _ _ (XObj (Sym (SymPath [] name) Symbol) _ _) =
+toCase _ _ _ _ (XObj (Sym (SymPath [] name) Symbol) _ _) =
Right $
SumtypeCase
{ caseName = name,
caseTys = []
}
-toCase _ _ _ x =
+toCase _ _ _ _ x =
Left (InvalidSumtypeCase x)
diff --git a/src/Sumtypes.hs b/src/Sumtypes.hs
index a0598bb7..113b0097 100644
--- a/src/Sumtypes.hs
+++ b/src/Sumtypes.hs
@@ -54,20 +54,20 @@ moduleForSumtype innerEnv typeEnv env pathStrings typeName typeVariables rest i
insidePath = pathStrings ++ [typeName]
in do
let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables
- cases <- toCases typeEnv AllowOnlyNamesInScope typeVariables rest
+ cases <- toCases typeEnv env AllowOnlyNamesInScope typeVariables rest
okIniters <- initers insidePath structTy cases
okTag <- binderForTag insidePath structTy
(okStr, okStrDeps) <- binderForStrOrPrn typeEnv env insidePath structTy cases "str"
(okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy cases "prn"
okDelete <- binderForDelete typeEnv env insidePath structTy cases
(okCopy, okCopyDeps) <- binderForCopy typeEnv env insidePath structTy cases
- okMemberDeps <- memberDeps typeEnv cases
+ okMemberDeps <- memberDeps typeEnv env cases
let moduleEnvWithBindings = addListOfBindings moduleValueEnv (okIniters ++ [okStr, okPrn, okDelete, okCopy, okTag])
typeModuleXObj = XObj (Mod moduleEnvWithBindings moduleTypeEnv) i (Just ModuleTy)
pure (typeName, typeModuleXObj, okMemberDeps ++ okCopyDeps ++ okStrDeps)
-memberDeps :: TypeEnv -> [SumtypeCase] -> Either TypeError [XObj]
-memberDeps typeEnv cases = fmap concat (mapM (concretizeType typeEnv) (concatMap caseTys cases))
+memberDeps :: TypeEnv -> Env -> [SumtypeCase] -> Either TypeError [XObj]
+memberDeps typeEnv env cases = fmap concat (mapM (concretizeType typeEnv env) (concatMap caseTys cases))
replaceGenericTypesOnCases :: TypeMappings -> [SumtypeCase] -> [SumtypeCase]
replaceGenericTypesOnCases mappings = map replaceOnCase
@@ -110,7 +110,7 @@ genericCaseInit allocationMode pathStrings originalStructTy sumtypeCase =
t = FuncTy (caseTys sumtypeCase) originalStructTy StaticLifetimeTy
docs = "creates a `" ++ caseName sumtypeCase ++ "`."
templateCreator = TemplateCreator $
- \typeEnv _ ->
+ \typeEnv env ->
Template
(FuncTy (caseTys sumtypeCase) (VarTy "p") StaticLifetimeTy)
( \(FuncTy _ concreteStructTy _) ->
@@ -124,7 +124,7 @@ genericCaseInit allocationMode pathStrings originalStructTy sumtypeCase =
in tokensForCaseInit allocationMode concreteStructTy (sumtypeCase {caseTys = correctedTys})
)
( \(FuncTy _ concreteStructTy _) ->
- case concretizeType typeEnv concreteStructTy of
+ case concretizeType typeEnv env concreteStructTy of
Left _ -> []
Right ok -> ok
)
diff --git a/src/TypeError.hs b/src/TypeError.hs
index f57f166f..186097be 100644
--- a/src/TypeError.hs
+++ b/src/TypeError.hs
@@ -61,6 +61,7 @@ data TypeError
| UninhabitedConstructor Ty XObj Int Int
| InconsistentKinds String [XObj]
| FailedToAddLambdaStructToTyEnv SymPath XObj
+ | FailedToInstantiateGenericType Ty
instance Show TypeError where
show (SymbolMissingType xobj env) =
@@ -310,6 +311,8 @@ instance Show TypeError where
"Failed to add the lambda: " ++ show path ++ " represented by struct: "
++ pretty xobj
++ " to the type environment."
+ show (FailedToInstantiateGenericType ty) =
+ "I couldn't instantiate the generic type " ++ show ty
machineReadableErrorStrings :: FilePathPrintLength -> TypeError -> [String]
machineReadableErrorStrings fppl err =
diff --git a/src/Validate.hs b/src/Validate.hs
index 43a3fd90..7b810a8a 100644
--- a/src/Validate.hs
+++ b/src/Validate.hs
@@ -21,16 +21,16 @@ data TypeVarRestriction
-- | Make sure that the member declarations in a type definition
-- | Follow the pattern [<name> <type>, <name> <type>, ...]
-- | TODO: This function is only called by the deftype parts of the codebase, which is more specific than the following check implies.
-validateMemberCases :: TypeEnv -> [Ty] -> [XObj] -> Either TypeError ()
-validateMemberCases typeEnv typeVariables rest = mapM_ visit rest
+validateMemberCases :: TypeEnv -> Env -> [Ty] -> [XObj] -> Either TypeError ()
+validateMemberCases typeEnv globalEnv typeVariables rest = mapM_ visit rest
where
visit (XObj (Arr membersXObjs) _ _) =
- validateMembers AllowOnlyNamesInScope typeEnv typeVariables membersXObjs
+ validateMembers AllowOnlyNamesInScope typeEnv globalEnv typeVariables membersXObjs
visit xobj =
Left (InvalidSumtypeCase xobj)
-validateMembers :: TypeVarRestriction -> TypeEnv -> [Ty] -> [XObj] -> Either TypeError ()
-validateMembers typeVarRestriction typeEnv typeVariables membersXObjs =
+validateMembers :: TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> [XObj] -> Either TypeError ()
+validateMembers typeVarRestriction typeEnv globalEnv typeVariables membersXObjs =
checkUnevenMembers >> checkDuplicateMembers >> checkMembers >> checkKindConsistency
where
pairs = pairwise membersXObjs
@@ -61,17 +61,17 @@ validateMembers typeVarRestriction typeEnv typeVariables membersXObjs =
-- todo? be safer anyway?
varsOnly = filter isTypeGeneric (map (fromJust . xobjToTy . snd) pairs)
checkMembers :: Either TypeError ()
- checkMembers = mapM_ (okXObjForType typeVarRestriction typeEnv typeVariables . snd) pairs
+ checkMembers = mapM_ (okXObjForType typeVarRestriction typeEnv globalEnv typeVariables . snd) pairs
-okXObjForType :: TypeVarRestriction -> TypeEnv -> [Ty] -> XObj -> Either TypeError ()
-okXObjForType typeVarRestriction typeEnv typeVariables xobj =
+okXObjForType :: TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> XObj -> Either TypeError ()
+okXObjForType typeVarRestriction typeEnv globalEnv typeVariables xobj =
case xobjToTy xobj of
- Just t -> canBeUsedAsMemberType typeVarRestriction typeEnv typeVariables t xobj
+ Just t -> canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables t xobj
Nothing -> Left (NotAType xobj)
-- | Can this type be used as a member for a deftype?
-canBeUsedAsMemberType :: TypeVarRestriction -> TypeEnv -> [Ty] -> Ty -> XObj -> Either TypeError ()
-canBeUsedAsMemberType typeVarRestriction typeEnv typeVariables ty xobj =
+canBeUsedAsMemberType :: TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> Ty -> XObj -> Either TypeError ()
+canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables ty xobj =
case ty of
UnitTy -> pure ()
IntTy -> pure ()
@@ -86,7 +86,7 @@ canBeUsedAsMemberType typeVarRestriction typeEnv typeVariables ty xobj =
FuncTy {} -> pure ()
PointerTy UnitTy -> pure ()
PointerTy inner ->
- canBeUsedAsMemberType typeVarRestriction typeEnv typeVariables inner xobj
+ canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables inner xobj
>> pure ()
-- Struct variables may appear as complete applications or individual
-- components in the head of a definition; that is the forms:
@@ -112,16 +112,16 @@ canBeUsedAsMemberType typeVarRestriction typeEnv typeVariables ty xobj =
where
checkStruct :: Ty -> [Ty] -> Either TypeError ()
checkStruct (ConcreteNameTy (SymPath [] "Array")) [innerType] =
- canBeUsedAsMemberType typeVarRestriction typeEnv typeVariables innerType xobj
+ canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables innerType xobj
>> pure ()
- checkStruct (ConcreteNameTy (SymPath _ name)) vars =
- case E.getTypeBinder typeEnv name of
+ checkStruct (ConcreteNameTy path@(SymPath _ name)) vars =
+ case E.getTypeBinder typeEnv name <> E.findTypeBinder globalEnv path of
Right (Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) ->
pure ()
Right (Binder _ (XObj (Lst (XObj (Deftype t) _ _ : _)) _ _)) ->
- checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType typeVarRestriction typeEnv typeVariables typ xobj) () vars
+ checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars
Right (Binder _ (XObj (Lst (XObj (DefSumtype t) _ _ : _)) _ _)) ->
- checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType typeVarRestriction typeEnv typeVariables typ xobj) () vars
+ checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars
_ -> Left (NotAmongRegisteredTypes ty xobj)
where
checkInhabitants :: Ty -> Either TypeError ()
@@ -131,8 +131,8 @@ canBeUsedAsMemberType typeVarRestriction typeEnv typeVariables ty xobj =
else Left (UninhabitedConstructor ty xobj (length vs) (length vars))
checkInhabitants _ = Left (InvalidMemberType ty xobj)
checkStruct v@(VarTy _) vars =
- canBeUsedAsMemberType typeVarRestriction typeEnv typeVariables v xobj
- >> foldM (\_ typ -> canBeUsedAsMemberType typeVarRestriction typeEnv typeVariables typ xobj) () vars
+ canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables v xobj
+ >> foldM (\_ typ -> canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars
checkStruct _ _ = error "checkstruct"
checkVar :: Ty -> Either TypeError ()
checkVar variable =
diff --git a/test/control_macros.carp b/test/control_macros.carp
new file mode 100644
index 00000000..0efbaf42
--- /dev/null
+++ b/test/control_macros.carp
@@ -0,0 +1,15 @@
+(load "Test.carp")
+(use Test)
+
+(def test-string @"")
+
+(defn test-ignore-do []
+ (ignore-do (+ 2 2) ;; ignored
+ (set! test-string @"new-string") ;; ignored, but side-effect performed
+ (- 4 4)))
+
+(deftest test
+ (assert-true test
+ (and (= () (test-ignore-do)) (= &test-string "new-string"))
+ "ignore-do performs side effects and ignores all results")
+)
diff --git a/test/macros.carp b/test/macros.carp
index 44734f2e..e4466ad6 100644
--- a/test/macros.carp
+++ b/test/macros.carp
@@ -34,6 +34,12 @@
1 true
false))
+(defn test-case-multi []
+ (case 1
+ 2 false
+ (:or 1 3) true
+ false))
+
(defmacro test-not [a] (not a))
(defmacro test-< [a b] (< a b))
(defmacro test-> [a b] (> a b))
@@ -85,6 +91,9 @@
(test-case-select)
"case correctly selects branch")
(assert-true test
+ (test-case-multi)
+ "case correctly selects multibranch")
+ (assert-true test
(test-comment)
"comment ignores input")
(assert-true test
diff --git a/test/regression.carp b/test/regression.carp
index 3d80e858..6d0ba14f 100644
--- a/test/regression.carp
+++ b/test/regression.carp
@@ -2,6 +2,9 @@
(load "Test.carp")
(load "Vector.carp")
+; void definitions should get elided (issue #1296)
+(def is-void ())
+
; this is a test-only module to test module resolution (see #288)
(defmodule Foo
(register init (Fn [] Int) "fooInit")
@@ -85,6 +88,17 @@
(defn weird [m]
(the (Map String AType) m))
+;; nested polymorphic types are resolved and emitted (#1293)
+(defmodule Bar
+ (deftype (Baz a) [it a])
+ (deftype (Qux a) [it (Bar.Baz a)])
+)
+
+(deftype (PolyNest a) [it (Bar.Baz a)])
+
+(defn poly-nest-one [x] (Bar.Baz x))
+(defn poly-nest-two [x] (Bar.Qux.init (Bar.Baz x)))
+(defn poly-nest-three [x] (PolyNest (Bar.Baz x)))
(deftest test
(assert-equal test
@@ -132,4 +146,18 @@
1
(dynamic-closure-referring-to-itself-test)
"test that dynamic closure can refer to itself")
+ (assert-equal test
+ 2
+ @(Bar.Baz.it &(poly-nest-one 2))
+ "test that polymorphic types in modules are emitted")
+ (assert-equal test
+ 2
+ @(Bar.Baz.it (Bar.Qux.it &(poly-nest-two 2)))
+ "test that polymorphic types in modules are emitted and can
+ refer to each other")
+ (assert-equal test
+ 2
+ @(Bar.Baz.it (PolyNest.it &(poly-nest-three 2)))
+ "test that polymorphic types in modules can be referred to using
+ other types outside the module")
)
diff --git a/test/string.carp b/test/string.carp
index 1598a29c..728c42af 100644
--- a/test/string.carp
+++ b/test/string.carp
@@ -331,4 +331,8 @@
"HäLLO WöRLD"
&(ascii-to-upper "HälLo WöRld")
"ascii-to-upper works for valid UTF-8" )
+ (assert-equal test
+ "@\"\\\"h\\\"i\\\"\""
+ &(prn "\"h\"i\"")
+ "prn works on quoted strings")
)