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

Merge pull request #769 from scolsen/implement-prim

Browse Source 
Add an `implements` primitive, update core
This commit is contained in:
Erik Svedäng 2020-05-12 21:45:29 +02:00 committed by GitHub
commit aae743fb35
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
35 changed files with 655 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
core/Array.carp
View File

@ -105,6 +105,7 @@ Returns `Nothing` if the array is empty.")
(set! eq false)
(break))))
eq)))
(implements = Array.=)
(doc maximum "gets the maximum in an array (elements must support `<`) and wraps it in a `Just`.
@ -144,6 +145,7 @@ If the array is empty, returns `Nothing`")
(for [i start-index end-index]
(set! result (push-back result @(unsafe-nth xs i))))
result))
(implements slice Array.slice)
(doc prefix "gets a prefix array to `end-index`.")
(defn prefix [xs end-index]
@ -295,6 +297,7 @@ The trailing elements of the longer array will be discarded.")
(doc zero "returns the empty array.")
(defn zero [] [])
(implements zero Array.zero)
(doc concat "returns a new array which is the concatenation of the provided nested array `xs`.")
(defn concat [xs]

6
core/Bool.carp
View File

@ -2,7 +2,9 @@
(defmodule Bool
(register = (Fn [Bool Bool] Bool))
(implements = Bool.=)
(register copy (Fn [&Bool] Bool))
(implements copy Bool.copy)
(register format (Fn [&String Bool] String))
(register not (Fn [Bool] Bool))
(register and (Fn [Bool Bool] Bool))
@ -11,6 +13,8 @@
(defmodule RefBool
(defn = [a b]
(Bool.= @a @b)))
(Bool.= @a @b))
(implements = RefBool.=)
)
(defn not [a] (Bool.not a))

40
core/Byte.carp
View File

@ -1,30 +1,49 @@
(system-include "carp_byte.h")
(defmodule Byte
(register = (λ [Byte Byte] Bool))
(register copy (λ [&Byte] Byte))
(register + (λ [Byte Byte] Byte))
(register - (λ [Byte Byte] Byte))
(register * (λ [Byte Byte] Byte))
(register / (λ [Byte Byte] Byte))
(register < (λ [Byte Byte] Bool))
(register > (λ [Byte Byte] Bool))
(register = (λ [Byte Byte] Bool))
(register mod (λ [Byte Byte] Byte))
(register inc (λ [Byte] Byte))
(register dec (λ [Byte] Byte))
(register to-int (λ [Byte] Int))
(register from-int (λ [Int] Byte))
(defn zero [] 0b)
(implements = Byte.=)
(implements copy Byte.copy)
(implements + Byte.+)
(implements - Byte.-)
(implements * Byte.*)
(implements / Byte./)
(implements < Byte.<)
(implements > Byte.>)
(implements mod Byte.mod)
(implements inc Byte.inc)
(implements dec Byte.dec)
(implements zero Byte.zero)
(implements to-int Byte.to-int)
(implements from-int Byte.from-int)
)
(defmodule Byte
(register bit-shift-left (λ [Byte Byte] Byte))
(register bit-shift-right (λ [Byte Byte] Byte))
(register bit-and (λ [Byte Byte] Byte))
(register bit-or (λ [Byte Byte] Byte))
(register bit-xor (λ [Byte Byte] Byte))
(register bit-not (λ [Byte] Byte))
(register inc (λ [Byte] Byte))
(register dec (λ [Byte] Byte))
(register copy (λ [&Byte] Byte))
(register to-int (λ [Byte] Int))
(register from-int (λ [Int] Byte))
(defn even? [a] (= (mod a 2b) 0b))
(defn odd? [a] (not (even? a)))
(defn zero [] 0b)
(defn add-ref [x y]
(Byte.+ @x @y))
@ -47,6 +66,9 @@
(set! y (/ y 2b))
(set! x (* x x))))
r))
(implements pow Byte.pow)
(implements add-ref Byte.add-ref)
)
(defmodule ByteRef
@ -58,4 +80,8 @@
(defn > [a b]
(Byte.> @a @b))
(implements = ByteRef.=)
(implements < ByteRef.<)
(implements > ByteRef.>)
)

14
core/Char.carp
View File

@ -8,6 +8,13 @@
(register from-int (Fn [Int] Char))
(register copy (Fn [&Char] Char))
(implements < Char.<)
(implements > Char.>)
(implements = Char.=)
(implements copy Char.copy)
(implements to-int Char.to-int)
(implements from-int Char.from-int)
(doc meaning "converts a numerical char into the appropriate number (e.g. from `\1` to `1`).")
(defn meaning [char-ref]
(let [c @char-ref]
@ -45,16 +52,21 @@
(or (alpha? c) (num? c)))
(defn zero [] (the Char (from-int 0)))
(implements zero Char.zero)
)
(defmodule CharRef
(defn = [a b]
(Char.= @a @b))
(implements = CharRef.=)
(defn < [a b]
(Char.< @a @b))
(implements < CharRef.<)
(defn > [a b]
(Char.> @a @b))
(implements > CharRef.>)
)
(defmodule PtrChar
(register str (Fn [(Ptr Char)] String)))
(register str (Fn [(Ptr Char)] String))
(implements str PtrChar.str))

15
core/Collection.carp Normal file
View File

@ -0,0 +1,15 @@
(definterface unsafe-nth (Fn [(Ref (a b) c) Int] &b))
(implements unsafe-nth Array.unsafe-nth)
(implements unsafe-nth StaticArray.unsafe-nth)
(definterface length (Fn [(Ref (a b))] Int))
(implements unsafe-nth Array.length)
(implements unsafe-nth StaticArray.length)
(defmodule Collections
(defn empty? [a]
(= 0 (length a)))
(defn first [a]
(if (empty? a)
(Maybe.Nothing)
(Maybe.Just @(unsafe-nth a 0))))
)

2
core/Color.carp
View File

@ -27,8 +27,10 @@
(use Id)
(defn hash [k]
(get-tag k))
(implements hash Color.hash)
(defn = [a b]
(= (hash (the (Ref Id) a)) (hash b)))
(implements = Color.=)
(def table
{(Black) @"30"

43
core/Double.carp
View File

@ -2,6 +2,7 @@
(defmodule Double
(def pi 3.141592653589793)
(implements pi Double.pi)
(def e 2.718281828459045)
(register MAX Double "CARP_DBL_MAX")
(register = (Fn [Double Double] Bool))
@ -21,6 +22,18 @@
(register to-bytes (Fn [Double] Long))
(register copy (Fn [(Ref Double)] Double))
(implements + Double.+)
(implements - Double.-)
(implements * Double.*)
(implements / Double./)
(implements < Double.<)
(implements > Double.>)
(implements = Double.=)
(implements copy Double.copy)
(implements neg Double.neg)
(implements to-int Double.to-int)
(implements from-int Double.from-int)
(register abs (Fn [Double] Double))
(register acos (Fn [Double] Double))
(register asin (Fn [Double] Double))
@ -44,6 +57,29 @@
(register tan (Fn [Double] Double))
(register tanh (Fn [Double] Double))
(implements abs Double.abs)
(implements acos Double.acos)
(implements asin Double.asin)
(implements atan Double.atan)
(implements atan2 Double.atan2)
(implements ceil Double.ceil)
(implements cos Double.cos)
(implements cosh Double.cosh)
(implements exp Double.exp)
(implements floor Double.floor)
(implements frexp Double.frexp)
(implements ldexp Double.ldexp)
(implements log Double.log)
(implements log10 Double.log10)
(implements mod Double.mod)
(implements modf Double.modf)
(implements pow Double.pow)
(implements sin Double.sin)
(implements sinh Double.sinh)
(implements sqrt Double.sqrt)
(implements tan Double.tan)
(implements tanh Double.tanh)
(doc approx "checks whether `x` and `y` are approximately equal.
The margin of error is `0.00001`.")
@ -53,24 +89,31 @@ The margin of error is `0.00001`.")
(doc zero "returns the value `0.0`.")
(defn zero []
0.0)
(implements zero Double.zero)
(defn inc [x]
(+ 1.0 x))
(implements inc Double.inc)
(defn dec [x]
(- x 1.0))
(implements dec Double.dec)
(defn add-ref [x y]
(Double.+ @x @y))
(implements add-ref Double.add-ref)
)
(defmodule DoubleRef
(defn = [a b]
(Double.= @a @b))
(implements = DoubleRef.=)
(defn < [a b]
(Double.< @a @b))
(implements < DoubleRef.<)
(defn > [a b]
(Double.> @a @b))
(implements > DoubleRef.>)
)

39
core/Float.carp
View File

@ -17,6 +17,18 @@
(register < (Fn [Float Float] Bool))
(register > (Fn [Float Float] Bool))
(implements + Float.+)
(implements - Float.-)
(implements * Float.*)
(implements / Float./)
(implements < Float.<)
(implements > Float.>)
(implements = Float.=)
(implements copy Float.copy)
(implements neg Float.neg)
(implements to-int Float.to-int)
(implements from-int Float.from-int)
(defn clamp [min, max, val]
(if (> val max)
max
@ -55,18 +67,45 @@ The margin of error is 0.00001.")
(register tan (Fn [Float] Float))
(register tanh (Fn [Float] Float))
(implements abs Float.abs)
(implements acos Float.acos)
(implements asin Float.asin)
(implements atan Float.atan)
(implements atan2 Float.atan2)
(implements ceil Float.ceil)
(implements cos Float.cos)
(implements cosh Float.cosh)
(implements exp Float.exp)
(implements floor Float.floor)
(implements frexp Float.frexp)
(implements ldexp Float.ldexp)
(implements log Float.log)
(implements log10 Float.log10)
(implements mod Float.mod)
(implements modf Float.modf)
(implements pow Float.pow)
(implements sin Float.sin)
(implements sinh Float.sinh)
(implements sqrt Float.sqrt)
(implements tan Float.tan)
(implements tanh Float.tanh)
(doc zero "returns `0.0f`.")
(defn zero []
0.0f)
(implements zero Float.zero)
(defn inc [x]
(+ 1.0f x))
(implements inc Float.inc)
(defn dec [x]
(- x 1.0f))
(implements dec Float.dec)
(defn add-ref [x y]
(Float.+ @x @y))
(implements add-ref Float.add-ref)
)
(defmodule FloatRef

50
core/Int.carp
View File

@ -1,8 +1,6 @@
(system-include "carp_int.h")
(defmodule Int
(register MAX Int "CARP_INT_MAX")
(register MIN Int "CARP_INT_MIN")
(register + (λ [Int Int] Int))
(register - (λ [Int Int] Int))
(register * (λ [Int Int] Int))
@ -10,26 +8,56 @@
(register < (λ [Int Int] Bool))
(register > (λ [Int Int] Bool))
(register = (λ [Int Int] Bool))
(register copy (λ [&Int] Int))
(register inc (λ [Int] Int))
(register dec (λ [Int] Int))
(register neg (λ [Int] Int))
(register mod (λ [Int Int] Int))
(doc to-int "acts as the identity function to implement the interface.")
(sig to-int (Fn [Int] Int))
(defn to-int [a] a)
(doc from-int "acts as the identity function to implement the interface.")
(sig from-int (Fn [Int] Int))
(defn from-int [a] a)
(implements + Int.+)
(implements - Int.-)
(implements * Int.*)
(implements / Int./)
(implements < Int.<)
(implements > Int.>)
(implements = Int.=)
(implements copy Int.copy)
(implements inc Int.inc)
(implements dec Int.dec)
(implements neg Int.neg)
(implements mod Int.mod)
(implements to-int Int.to-int)
(implements from-int Int.from-int)
)
(defmodule Int
(register MAX Int "CARP_INT_MAX")
(register MIN Int "CARP_INT_MIN")
(register bit-shift-left (λ [Int Int] Int))
(register bit-shift-right (λ [Int Int] Int))
(register bit-and (λ [Int Int] Int))
(register bit-or (λ [Int Int] Int))
(register bit-xor (λ [Int Int] Int))
(register bit-not (λ [Int] Int))
(register inc (λ [Int] Int))
(register dec (λ [Int] Int))
(register copy (λ [&Int] Int))
(doc abs "The absolute value (removes the negative sign) of an Int.")
(register abs (λ [Int] Int))
(implements abs Int.abs)
(defn even? [a] (= (mod a 2) 0))
(defn odd? [a] (not (even? a)))
(defn zero []
0)
(implements zero Int.zero)
(defn add-ref [x y]
(Int.+ @x @y))
@ -60,22 +88,20 @@
(+ r n)
r)))
(doc to-int "acts as the identity function to implement the interface.")
(sig to-int (Fn [Int] Int))
(defn to-int [a] a)
(doc from-int "acts as the identity function to implement the interface.")
(sig from-int (Fn [Int] Int))
(defn from-int [a] a)
(implements add-ref Int.add-ref)
(implements pow Int.pow)
)
(defmodule IntRef
(defn = [a b]
(Int.= @a @b))
(implements = IntRef.=)
(defn < [a b]
(Int.< @a @b))
(implements < IntRef.<)
(defn > [a b]
(Int.> @a @b))
(implements > IntRef.>)
)

18
core/Long.carp
View File

@ -27,6 +27,21 @@
to non-refs.")
(register copy (λ [&Long] Long))
(implements + Long.+)
(implements - Long.-)
(implements * Long.*)
(implements / Long./)
(implements < Long.<)
(implements > Long.>)
(implements = Long.=)
(implements copy Long.copy)
(implements inc Long.inc)
(implements dec Long.dec)
(implements neg Long.neg)
(implements mod Long.mod)
(implements to-int Long.to-int)
(implements from-int Long.from-int)
(not-on-windows ; this seems to generate invalid code on some windows machines
(register safe-add (λ [Long Long (Ref Long)] Bool))
(register safe-sub (λ [Long Long (Ref Long)] Bool))
@ -39,6 +54,9 @@ to non-refs.")
(defn odd? [a] (not (even? a)))
(defn zero [] 0l)
(implements abs Long.abs)
(implements zero Long.zero)
)
(defmodule LongRef

20
core/Map.carp
View File

@ -11,66 +11,82 @@
(set! a (* a b))
(set! x (Int.inc x))))
(Int.abs vh)))
(implements hash String.hash)
)
(defmodule Int
(defn hash [k] (the Int @k))
(implements hash Int.hash)
)
(defmodule Long
(defn hash [k] (to-int (the Long @k)))
(implements hash Long.hash)
)
(defmodule Bool
(defn hash [k] (if (the Bool @k) 1 0))
(implements hash Bool.hash)
)
(defmodule Char
(defn hash [k] (to-int (the Char @k)))
(implements hash Char.hash)
)
(defmodule Byte
(defn hash [k] (to-int (the Byte @k)))
(implements hash Byte.hash)
)
(defmodule Float
(defn hash [k] (Float.to-bytes @k))
(implements hash Float.hash)
)
(defmodule Double
(defn hash [k] (Long.to-int (Double.to-bytes @k)))
(implements hash Double.hash)
)
(defmodule Int8
(defn hash [k] (Long.to-int (Int8.to-long @k)))
(implements hash Int8.hash)
)
(defmodule Int16
(defn hash [k] (Long.to-int (Int16.to-long @k)))
(implements hash Int16.hash)
)
(defmodule Int32
(defn hash [k] (Long.to-int (Int32.to-long @k)))
(implements hash Int32.hash)
)
(defmodule Int64
(defn hash [k] (Long.to-int (Int64.to-long @k)))
(implements hash Int64.hash)
)
(defmodule Uint8
(defn hash [k] (Long.to-int (Uint8.to-long @k)))
(implements hash Uint8.hash)
)
(defmodule Uint16
(defn hash [k] (Long.to-int (Uint16.to-long @k)))
(implements hash Uint16.hash)
)
(defmodule Uint32
(defn hash [k] (Long.to-int (Uint32.to-long @k)))
(implements hash Uint32.hash)
)
(defmodule Uint64
(defn hash [k] (Long.to-int (Uint64.to-long @k)))
(implements hash Uint64.hash)
)
(defmodule Pair
@ -79,6 +95,7 @@
(set! code (+ (* 31 code) (hash (Pair.a pair))))
(set! code (+ (* 31 code) (hash (Pair.b pair))))
code))
(implements hash Pair.hash)
)
(deftype (Bucket a b) [entries (Array (Pair a b))])
@ -261,6 +278,7 @@
(and (= (length m1) (length m2))
;; we could use contains? and get-with-default here to avoid requiring a (zero) for the value type
(all? &(fn [k v] (= v &(get m2 k))) m1)))
(implements = Map.=)
(doc for-each "Execute the binary function f for all keys and values in the map m.")
(defn for-each [m f]
@ -449,6 +467,7 @@
(defn = [set-a set-b]
(and (= (Set.length set-a) (Set.length set-b))
(subset? set-a set-b)))
(implements = Set.=)
(doc for-each "Execute the unary function f for each element in the set s.")
(defn for-each [s f]
@ -507,4 +526,5 @@
@"{"
set)]
(String.append &res " }")))
(implements str Set.str)
)

2
core/Maybe.carp
View File

@ -51,6 +51,7 @@ It is the inverse of [`just?`](#just?).")
(match-ref b
(Nothing) false
(Just y) (= x y))))
(implements = Maybe.=)
(doc unsafe-ptr "Creates a `(Ptr a)` from a `(Maybe a)`. If the `Maybe` was
`Nothing`, this function will return a `NULL` value.")
@ -69,4 +70,5 @@ It is the inverse of [`just?`](#just?).")
(doc zero "returns `Nothing`.")
(defn zero [] (Nothing))
(implements zero Maybe.zero)
)

4
core/Pattern.carp
View File

@ -35,12 +35,16 @@ If you want to replace all occurrences of the pattern, use `-1`.")
(defn matches? [pat s] (/= (find pat s) -1))
(register str (Fn [&Pattern] String))
(implements str Pattern.str)
(register prn (Fn [&Pattern] String))
(implements prn Pattern.prn)
(register init (Fn [&String] Pattern))
(register = (Fn [&Pattern &Pattern] Bool))
(implements = Pattern.=)
(register delete (Fn [Pattern] ()))
(register copy (Fn [&Pattern] Pattern))
(implements copy Pattern.copy)
(doc from-chars "creates a pattern that matches a group of characters from a
list of those characters.")

2
core/Pointer.carp
View File

@ -1,4 +1,6 @@
(defmodule Pointer
(defn inc [a] (Pointer.add a 1l))
(implements inc Pointer.inc)
(defn dec [a] (Pointer.sub a 1l))
(implements dec Pointer.dec)
)

14
core/Random.carp
View File

@ -32,9 +32,12 @@
(defn random-between [lower upper]
(let [diff (- upper lower)]
(+ (Double.to-int (* (Double.from-int diff) (Random.random))) lower)))
(implements random-between Int.random-between)
(defn random []
(random-between 0 MAX))
(implements random Int.random)
)
(defmodule Float
@ -42,34 +45,43 @@
(let [diff (- upper lower)]
(+ (Double.to-float (* (Double.from-float diff) (Random.random))) lower)))
(implements random-between Float.random-between)
(defn random []
(random-between 0.0f (from-int Int.MAX)))
(implements random Float.random)
)
(defmodule Long
(defn random-between [lower upper]
(let [diff (- upper lower)]
(+ (Double.to-long (* (Double.from-long diff) (Random.random))) lower)))
(implements random-between Long.random-between)
(defn random []
(random-between 0l (from-int Int.MAX)))
(implements random Long.random)
)
(defmodule Double
(defn random-between [lower upper]
(let [diff (- upper lower)]
(+ (* diff (Random.random)) lower)))
(implements random-between Double.random-between)
(defn random []
(random-between 0.0 (from-int Int.MAX)))
(implements random Double.random)
)
(defmodule Char
(defn random []
(Char.from-int (Int.random)))
(implements random Char.random)
(defn random-between [a b]
(Char.from-int (Int.random-between (Char.to-int a) (Char.to-int b))))
(implements random-between Char.random-between)
)
(defmodule String
@ -80,8 +92,10 @@
(defmodule Byte
(defn random-between [lower upper]
(Byte.from-int (Int.random-between (Byte.to-int lower) (Byte.to-int upper))))
(implements random-between Byte.random-between)
(defn random []
(Byte.from-int (Int.random)))
(implements random Byte.random)
)

1
core/Result.carp
View File

@ -106,6 +106,7 @@ It is the inverse of [`success?`](#success?).")
(match-ref b
(Success _) false
(Error y) (= x y))))
(implements = Result.=)
)
(defmodule Maybe

6
core/SDL.carp
View File

@ -76,6 +76,8 @@
(set! events (Array.push-back events e)))
events))
(implements = SDL.Event.=)
(implements copy SDL.Event.copy)
)
;; Rendering
@ -117,10 +119,14 @@
(defn = [a b]
(Int.= (enum-to-int (the SDL_Keycode a))
(enum-to-int (the SDL_Keycode b))))
(implements = SDL.Keycode.=)
(register copy (Fn [(Ref SDL_Keycode)] SDL_Keycode))
(implements copy SDL.Keycode.copy)
(register str (Fn [SDL_Keycode] String))
(implements str SDL.Keycode.str)
(defn prn [x]
(SDL.Keycode.str x))
(implements prn SDL.Keycode.prn)
(register return SDL_Keycode "SDLK_RETURN")
(register space SDL_Keycode "SDLK_SPACE")

1
core/StaticArray.carp
View File

@ -47,6 +47,7 @@
(set! eq false)
(break))))
eq)))
(implements = StaticArray.=)
(doc empty? "checks whether the array `a` is empty.")
(defn empty? [a]

120
core/StdInt.carp
View File

@ -32,12 +32,27 @@
(defn zero [] (from-long 0l))
(register from-bytes (Fn [&(Array Byte)] (Array Int8)))
(implements + Int8.+)
(implements - Int8.-)
(implements * Int8.*)
(implements / Int8./)
(implements < Int8.<)
(implements > Int8.>)
(implements = Int8.=)
(implements copy Int8.copy)
(implements str Int8.str)
(implements prn Int8.prn)
(implements zero Int8.zero)
)
(defmodule Int8Extra
(defn prn [a] (Int8.prn @a))
(defn str [a] (Int8.str @a))
(defn = [a b] (Int8.= @a @b))
(implements prn Int8Extra.prn)
(implements str Int8Extra.str)
(implements = Int8Extra.=)
)
(defmodule Int16
@ -63,12 +78,27 @@
(defn zero [] (from-long 0l))
(register from-bytes (Fn [&(Array Byte)] (Array Int16)))
(implements + Int16.+)
(implements - Int16.-)
(implements * Int16.*)
(implements / Int16./)
(implements < Int16.<)
(implements > Int16.>)
(implements = Int16.=)
(implements copy Int16.copy)
(implements str Int16.str)
(implements prn Int16.prn)
(implements zero Int16.zero)
)
(defmodule Int16Extra
(defn prn [a] (Int16.prn @a))
(defn str [a] (Int16.str @a))
(defn = [a b] (Int16.= @a @b))
(implements prn Int16Extra.prn)
(implements str Int16Extra.str)
(implements = Int16Extra.=)
)
(defmodule Int32
@ -94,12 +124,27 @@
(defn zero [] (from-long 0l))
(register from-bytes (Fn [&(Array Byte)] (Array Int32)))
(implements + Int32.+)
(implements - Int32.-)
(implements * Int32.*)
(implements / Int32./)
(implements < Int32.<)
(implements > Int32.>)
(implements = Int32.=)
(implements copy Int32.copy)
(implements str Int32.str)
(implements prn Int32.prn)
(implements zero Int32.zero)
)
(defmodule Int32Extra
(defn prn [a] (Int32.prn @a))
(defn str [a] (Int32.str @a))
(defn = [a b] (Int32.= @a @b))
(implements prn Int32Extra.prn)
(implements str Int32Extra.str)
(implements = Int32Extra.=)
)
(defmodule Int64
@ -125,12 +170,27 @@
(defn zero [] (from-long 0l))
(register from-bytes (Fn [&(Array Byte)] (Array Int64)))
(implements + Int64.+)
(implements - Int64.-)
(implements * Int64.*)
(implements / Int64./)
(implements < Int64.<)
(implements > Int64.>)
(implements = Int64.=)
(implements copy Int64.copy)
(implements str Int64.str)
(implements prn Int64.prn)
(implements zero Int64.zero)
)
(defmodule Int64Extra
(defn prn [a] (Int64.prn @a))
(defn str [a] (Int64.str @a))
(defn = [a b] (Int64.= @a @b))
(implements prn Int64Extra.prn)
(implements str Int64Extra.str)
(implements = Int64Extra.=)
)
(defmodule Uint8
@ -156,12 +216,27 @@
(defn zero [] (from-long 0l))
(register from-bytes (Fn [&(Array Byte)] (Array Uint8)))
(implements + Uint8.+)
(implements - Uint8.-)
(implements * Uint8.*)
(implements / Uint8./)
(implements < Uint8.<)
(implements > Uint8.>)
(implements = Uint8.=)
(implements copy Uint8.copy)
(implements str Uint8.str)
(implements prn Uint8.prn)
(implements zero Uint8.zero)
)
(defmodule Uint8Extra
(defn prn [a] (Uint8.prn @a))
(defn str [a] (Uint8.str @a))
(defn = [a b] (Uint8.= @a @b))
(implements prn Uint8Extra.prn)
(implements str Uint8Extra.str)
(implements = Uint8Extra.=)
)
(defmodule Uint16
@ -187,12 +262,27 @@
(defn zero [] (from-long 0l))
(register from-bytes (Fn [&(Array Byte)] (Array Uint16)))
(implements + Uint16.+)
(implements - Uint16.-)
(implements * Uint16.*)
(implements / Uint16./)
(implements < Uint16.<)
(implements > Uint16.>)
(implements = Uint16.=)
(implements copy Uint16.copy)
(implements str Uint16.str)
(implements prn Uint16.prn)
(implements zero Uint16.zero)
)
(defmodule Uint16Extra
(defn prn [a] (Uint16.prn @a))
(defn str [a] (Uint16.str @a))
(defn = [a b] (Uint16.= @a @b))
(implements prn Uint16Extra.prn)
(implements str Uint16Extra.str)
(implements = Uint16Extra.=)
)
(defmodule Uint32
@ -218,12 +308,27 @@
(defn zero [] (from-long 0l))
(register from-bytes (Fn [&(Array Byte)] (Array Uint32)))
(implements + Uint32.+)
(implements - Uint32.-)
(implements * Uint32.*)
(implements / Uint32./)
(implements < Uint32.<)
(implements > Uint32.>)
(implements = Uint32.=)
(implements copy Uint32.copy)
(implements str Uint32.str)
(implements prn Uint32.prn)
(implements zero Uint32.zero)
)
(defmodule Uint32Extra
(defn prn [a] (Uint32.prn @a))
(defn str [a] (Uint32.str @a))
(defn = [a b] (Uint32.= @a @b))
(implements prn Uint32Extra.prn)
(implements str Uint32Extra.str)
(implements = Uint32Extra.=)
)
(defmodule Uint64
@ -249,10 +354,25 @@
(defn zero [] (from-long 0l))
(register from-bytes (Fn [&(Array Byte)] (Array Uint64)))
(implements + Uint64.+)
(implements - Uint64.-)
(implements * Uint64.*)
(implements / Uint64./)
(implements < Uint64.<)
(implements > Uint64.>)
(implements = Uint64.=)
(implements copy Uint64.copy)
(implements str Uint64.str)
(implements prn Uint64.prn)
(implements zero Uint64.zero)
)
(defmodule Uint64Extra
(defn prn [a] (Uint64.prn @a))
(defn str [a] (Uint64.str @a))
(defn = [a b] (Uint64.= @a @b))
(implements prn Uint64Extra.prn)
(implements str Uint64Extra.str)
(implements = Uint64Extra.=)
)

58
core/String.carp
View File

@ -20,10 +20,18 @@
(register from-chars (Fn [&(Array Char)] String))
(register tail (λ [(Ref String)] String))
(register format (Fn [&String &String] String))
(implements format String.format)
(register string-set! (Fn [&String Int Char] ()))
(register string-set-at! (Fn [&String Int &String] ()))
(register allocate (Fn [Int Char] String))
(implements < String.<)
(implements > String.>)
(implements = String.=)
(implements copy String.copy)
(implements prn String.prn)
(implements str String.str)
(doc head "Returns the character at start of string.")
(defn head [s]
(char-at s 0))
@ -65,6 +73,7 @@
(defn slice [s a b]
(from-chars &(Array.slice &(chars s) a b)))
(implements slice String.slice)
(doc prefix "Return the first `a` characters of the string `s`.")
(defn prefix [s a]
@ -87,6 +96,7 @@
(doc zero "The empty string.")
(defn zero [] @"")
(implements zero String.zero)
(doc sum-length "Returns the sum of lengths from an array of Strings.")
(defn sum-length [strings]
@ -158,79 +168,111 @@
(defn = [a b]
(String.= &a &b))
(implements = StringCopy.=)
(defn < [a b]
(String.< &a &b))
(implements < StringCopy.<)
(defn > [a b]
(String.> &a &b))
(implements > StringCopy.>)
(defn prn [s]
(prn &(the String s)))
(implements prn StringCopy.prn)
(defn str [s]
(str &(the String s)))
(implements str StringCopy.str)
)
(defmodule Bool
(register str (Fn [Bool] String))
(implements str Bool.str)
(register format (Fn [&String Bool] String))
(implements format Bool.format)
)
(defmodule Int
(register str (Fn [Int] String))
(implements str Int.str)
(register format (Fn [&String Int] String))
(implements format Int.format)
(register from-string (λ [&String] Int))
(implements from-string Int.from-string)
)
(defmodule Byte
(register str (Fn [Byte] String))
(implements str Byte.str)
(register format (Fn [&String Byte] String))
(implements format Byte.format)
(register from-string (λ [&String] Byte))
(implements from-string Byte.from-string)
)
(defmodule Float
(register str (Fn [Float] String))
(implements str Float.str)
(register format (Fn [&String Float] String))
(implements format Float.format)
(register from-string (λ [&String] Float))
(implements from-string Float.from-string)
)
(defmodule Long
(register str (Fn [Long] String))
(implements str Long.str)
(register format (Fn [&String Long] String))
(implements format Long.format)
(register from-string (λ [&String] Long))
(implements from-string Long.from-string)
)
(defmodule Double
(register str (Fn [Double] String))
(implements str Double.str)
(register format (Fn [&String Double] String))
(implements format Double.format)
(register from-string (λ [&String] Double))
(implements from-string Double.from-string)
)
(defmodule Char
(register str (Fn [Char] String))
(implements str Char.str)
(register prn (Fn [Char] String))
(implements prn Char.prn)
(register format (Fn [&String Char] String))
(implements format Char.format)
)
(defmodule Int (defn prn [x] (Int.str x)))
(defmodule Byte (defn prn [x] (Byte.str x)))
(defmodule Int (defn prn [x] (Int.str x)) (implements prn Int.prn))
(defmodule Byte (defn prn [x] (Byte.str x)) (implements prn Byte.prn))
(defmodule IntRef
(defn prn [x] (Int.str @x))
(implements prn IntRef.prn)
(defn str [x] (Int.str @x))
(implements str IntRef.str)
)
(defmodule BoolRef
(defn prn [x] (Bool.str @x))
(defn str [x] (Bool.str @x)))
(implements prn BoolRef.prn)
(defn str [x] (Bool.str @x))
(implements str BoolRef.str)
)
(defmodule ByteRef
(defn prn [x] (Byte.str @x))
(implements prn ByteRef.prn)
(defn str [x] (Byte.str @x))
(implements str ByteRef.str)
)
(defmodule Long (defn prn [x] (Long.str x)))
(defmodule Float (defn prn [x] (Float.str x)))
(defmodule Double (defn prn [x] (Double.str x)))
(defmodule Bool (defn prn [x] (Bool.str x)))
(defmodule Array (defn prn [x] (Array.str x)))
(defmodule Long (defn prn [x] (Long.str x)) (implements prn Long.prn))
(defmodule Float (defn prn [x] (Float.str x)) (implements prn Float.prn))
(defmodule Double (defn prn [x] (Double.str x)) (implements prn Double.prn))
(defmodule Bool (defn prn [x] (Bool.str x)) (implements prn Bool.prn))
(defmodule Array (defn prn [x] (Array.str x)) (implements prn Array.prn))

6
core/Tuples.carp
View File

@ -4,14 +4,17 @@
(defn = [p1 p2]
(and (= (Pair.a p1) (Pair.a p2))
(= (Pair.b p1) (Pair.b p2))))
(implements = PairRef.=)
(defn < [p1 p2]
(if (= (Pair.a p1) (Pair.a p2))
(< (Pair.b p1) (Pair.b p2))
(< (Pair.a p1) (Pair.a p2))))
(implements < PairRef.<)
(defn > [p1 p2]
(PairRef.< p2 p1)))
(implements > PairRef.=)
(defmodule Pair
(defn init-from-refs [r1 r2]
@ -20,12 +23,15 @@
(defn = [p1 p2]
(and (= (Pair.a &p1) (Pair.a &p2))
(= (Pair.b &p1) (Pair.b &p2))))
(implements = Pair.=)
(defn < [p1 p2]
(PairRef.< &p1 &p2))
(implements < Pair.<)
(defn > [p1 p2]
(PairRef.> &p1 &p2))
(implements > Pair.>)
(doc reverse "reverses a `Pair` `p` such that its first member is its second member and vice versa.")
(defn reverse [p]

7
core/Vector.carp
View File

@ -14,9 +14,11 @@
(defn zero []
(init (zero) (zero)))
(implements zero Vector2.zero)
(defn random []
(init (random-0-1) (random-0-1)))
(implements random Vector2.random)
(defn add [a b]
(zip + a b))
@ -34,6 +36,7 @@
(defn = [a b]
(vreduce (fn [i v] (and i v)) true &(zip = a b)))
(implements = Vector2.=)
(doc vapprox "Check whether the vectors a and b are approximately equal.")
(defn vapprox [a b]
@ -116,12 +119,15 @@
(defn zero []
(init (zero) (zero) (zero)))
(implements zero Vector3.zero)
(defn random []
(init (random-0-1) (random-0-1) (random-0-1)))
(implements random Vector3.random)
(defn = [a b]
(vreduce (fn [i v] (and i v)) true &(zip = a b)))
(implements = Vector3.=)
(doc vapprox "Check whether the vectors a and b are approximately equal.")
(defn vapprox [a b]
@ -231,6 +237,7 @@
(defn = [a b]
(and (Int.= @(n a) @(n b))
(Array.= (v a) (v b))))
(implements = VectorN.=)
(defn add [a b]
(zip + a b))

4
examples/functor.carp
View File

@ -7,13 +7,15 @@
(defmodule ArrayExtension
(defn fmap [f a] (Array.endo-map f a))
(implements fmap ArrayExtension.fmap)
)
(deftype Box [x Int])
(defmodule Box
(defn fmap [f box] (let [new-x (~f @(Box.x &box))]
(Box.set-x box new-x))))
(Box.set-x box new-x)))
(implements fmap Box.fmap))
(use Box)
(use ArrayExtension)

7
examples/sorting.carp
View File

@ -9,7 +9,12 @@
(defn > [a b]
(> (Age.x a) (Age.x b)))
(defn < [a b]
(< (Age.x a) (Age.x b))))
(< (Age.x a) (Age.x b)))
(implements = Age.=)
(implements > Age.>)
(implements < Age.<)
)
(defn main []
(let-do [ints (Array.sort [10 3 75 40])

52
src/Lookup.hs
View File

@ -10,6 +10,9 @@ import Obj
import Util
import Debug.Trace
-- | The type of generic lookup functions.
type LookupFunc a = a -> Env -> [Binder]
-- | Find the Binder at a specified path.
lookupInEnv :: SymPath -> Env -> Maybe (Env, Binder)
lookupInEnv (SymPath [] name) env =
@ -48,6 +51,9 @@ multiLookup = multiLookupInternal False
multiLookupALL :: String -> Env -> [(Env, Binder)]
multiLookupALL = multiLookupInternal True
-- TODO: Many of the local functions defined in the body of multiLookupInternal have been extracted.
-- Remove the duplication and define this in terms of the more generic/extracted functions.
{-# ANN multiLookupInternal "HLint: ignore Eta reduce" #-}
-- | The advanced version of multiLookup that allows for looking into modules that are NOT imported.
-- | Perhaps this function will become unnecessary when all functions can be found through Interfaces? (even 'delete', etc.)
@ -90,6 +96,52 @@ multiLookupInternal allowLookupInAllModules name rootEnv = recursiveLookup rootE
in --(trace $ "multiLookupInternal '" ++ name ++ "' " ++ show (envModuleName env) ++ ", spine: " ++ show (fmap snd spine) ++ ", leaves: " ++ show (fmap snd leaves) ++ ", above: " ++ show (fmap snd above))
spine ++ leaves ++ above
binderToEnv :: Binder -> Maybe Env
binderToEnv (Binder _ (XObj (Mod e) _ _)) = Just e
binderToEnv _ = Nothing
-- | Given an environment, returns the list of all environments of binders from
-- imported modules `(load "module-file.carp")`
importedEnvs :: Env -> [Env]
importedEnvs env =
let envs = mapMaybe (binderToEnv . snd) (Map.toList (envBindings env))
in envs ++ concatMap importedEnvs envs
-- | Given an environment, use a lookup function to recursively find all binders
-- in the environment that satisfy the lookup.
recursiveLookupAll :: a -> LookupFunc a -> Env -> [Binder]
recursiveLookupAll input lookf env =
let spine = lookf input env
leaves = concatMap (lookf input) (importedEnvs env)
above = case envParent env of
Just parent -> recursiveLookupAll input lookf parent
Nothing -> []
in spine ++ leaves ++ above
-- | Lookup binders by name.
lookupByName :: String -> Env -> [Binder]
lookupByName name env =
let filtered = Map.filterWithKey (\k v -> k == name) (envBindings env)
in map snd $ Map.toList filtered
-- | Lookup binders that have specified metadata.
lookupByMeta :: String -> Env -> [Binder]
lookupByMeta key env =
let filtered = Map.filter hasMeta (envBindings env)
in map snd $ Map.toList filtered
where hasMeta (Binder meta _)= Map.member key (getMeta meta)
-- | Given an interface, lookup all binders that implement the interface.
lookupImplementations :: SymPath -> Env -> [Binder]
lookupImplementations interface env =
let binders = lookupByMeta "implements" env
in filter isImpl binders
where isImpl (Binder meta _) =
case Map.lookup "implements" (getMeta meta) of
Just (XObj (Sym i@(SymPath _ _) _) _ _) -> i == interface
_ -> False
getEnvFromBinder :: (a, Binder) -> Env
getEnvFromBinder (_, Binder _ (XObj (Mod foundEnv) _ _)) = foundEnv
getEnvFromBinder (_, Binder _ err) = error ("Can't handle imports of non modules yet: " ++ show err)

1
src/Obj.hs
View File

@ -98,6 +98,7 @@ instance Ord Obj where
compare a b = compare (show a) (show b)
-- TODO: handle comparison of lists, arrays and dictionaries
-- | The type of primitive functions. See Primitives.hs
type Primitive = XObj -> Context -> [XObj] -> IO (Context, Either EvalError XObj)
newtype PrimitiveFunctionType = PrimitiveFunction { getPrimitive :: Primitive }

123
src/Primitives.hs
View File

@ -114,10 +114,56 @@ primitiveColumn x@(XObj _ i t) ctx args =
("`column` expected 0 or 1 arguments, but got " ++ show (length args))
(info x))
registerInInterfaceIfNeeded :: Context -> SymPath -> Ty -> Either String Context
registerInInterfaceIfNeeded ctx path@(SymPath _ name) definitionSignature =
primitiveImplements :: Primitive
primitiveImplements xobj ctx [x@(XObj (Sym interface@(SymPath _ _) _) _ _), i@(XObj (Sym impl@(SymPath _ _) _) _ _)] =
let tyEnv = getTypeEnv . contextTypeEnv $ ctx
global = contextGlobalEnv ctx
def = lookupInEnv impl global
inter = lookupInEnv interface tyEnv
in case def of
Just (_, Binder meta defobj) ->
do
case inter of
Just _ -> return ()
Nothing ->
do putStrWithColor Blue ("[WARNING] The interface " ++ show interface ++ " implemented by " ++ show impl ++
" at " ++ prettyInfoFromXObj xobj ++ " is not defined." ++
" Did you define it using `definterface`?")
putStrLnWithColor White "" -- To restore color for sure.
case registerDefnOrDefInInterfaceIfNeeded ctx defobj interface of
Left err ->
do case contextExecMode ctx of
Check -> let fppl = projectFilePathPrintLength (contextProj ctx)
in putStrLn (machineReadableInfoFromXObj fppl defobj ++ " " ++ err)
_ -> putStrLnWithColor Red err
return $ evalError ctx err (info x)
Right ctx' ->
let adjustedMeta = meta {getMeta = Map.insert "implements" x (getMeta meta)}
in return (ctx' {contextGlobalEnv = envInsertAt global (getPath defobj) (Binder adjustedMeta defobj)},
dynamicNil)
-- If the implementation binding doesn't exist yet, set the implements
-- meta. This enables specifying a function as an implementation before
-- defining it.
Nothing ->
do
case inter of
Just _ -> return ()
Nothing ->
do putStrWithColor Blue ("[WARNING] The interface " ++ show interface ++ " implemented by " ++ show impl ++
" at " ++ prettyInfoFromXObj xobj ++ " is not defined." ++
" Did you define it using `definterface`?")
putStrLnWithColor White "" -- To restore color for sure.
primitiveMetaSet xobj ctx [i, XObj (Str "implements") (Just dummyInfo) (Just StringTy), x]
primitiveImplements xobj ctx [x, y] =
return $ evalError ctx ("`implements` expects symbol arguments.") (info x)
primitiveImplements x@(XObj _ i t) ctx args =
return $ evalError
ctx ("`implements` expected 2 arguments, but got " ++ show (length args)) (info x)
registerInInterfaceIfNeeded :: Context -> SymPath -> SymPath -> Ty -> Either String Context
registerInInterfaceIfNeeded ctx path@(SymPath _ _) interface@(SymPath [] name) definitionSignature =
let typeEnv = getTypeEnv (contextTypeEnv ctx)
in case lookupInEnv (SymPath [] name) typeEnv of
in case lookupInEnv interface typeEnv of
Just (_, Binder _ (XObj (Lst [XObj (Interface interfaceSignature paths) ii it, isym]) i t)) ->
if checkKinds interfaceSignature definitionSignature
then if areUnifiable interfaceSignature definitionSignature
@ -127,22 +173,26 @@ registerInInterfaceIfNeeded ctx path@(SymPath _ name) definitionSignature =
" doesn't match the interface signature " ++ show interfaceSignature)
else Left ("[INTERFACE ERROR] " ++ show path ++ ":" ++ " One or more types in the interface implementation " ++ show definitionSignature ++ " have kinds that do not match the kinds of the types in the interface signature " ++ show interfaceSignature ++ "\n" ++ "Types of the form (f a) must be matched by constructor types such as (Maybe a)")
Just (_, Binder _ x) ->
error ("A non-interface named '" ++ name ++ "' was found in the type environment: " ++ show x)
error ("Can't implement the non-interface '" ++ name ++ "' in the type environment: " ++ show x)
Nothing -> return ctx
-- | Ensure that a 'def' / 'defn' has registered with an interface (if they share the same name).
registerDefnOrDefInInterfaceIfNeeded :: Context -> XObj -> Either String Context
registerDefnOrDefInInterfaceIfNeeded ctx xobj =
-- | Given an XObj and an interface path, ensure that a 'def' / 'defn' is
-- registered with the interface.
registerDefnOrDefInInterfaceIfNeeded :: Context -> XObj -> SymPath -> Either String Context
registerDefnOrDefInInterfaceIfNeeded ctx xobj interface =
case xobj of
XObj (Lst [XObj (Defn _) _ _, XObj (Sym path _) _ _, _, _]) _ (Just t) ->
-- This is a function, does it belong to an interface?
registerInInterfaceIfNeeded ctx path t
registerInInterfaceIfNeeded ctx path interface t
XObj (Lst [XObj (Deftemplate _) _ _, XObj (Sym path _) _ _]) _ (Just t) ->
-- Templates should also be registered.
registerInInterfaceIfNeeded ctx path t
registerInInterfaceIfNeeded ctx path interface t
XObj (Lst [XObj Def _ _, XObj (Sym path _) _ _, _]) _ (Just t) ->
-- Global variables can also be part of an interface
registerInInterfaceIfNeeded ctx path t
registerInInterfaceIfNeeded ctx path interface t
-- So can externals!
XObj (Lst [XObj (External _) _ _, XObj (Sym path _) _ _]) _ (Just t) ->
registerInInterfaceIfNeeded ctx path interface t
_ -> return ctx
define :: Bool -> Context -> XObj -> IO Context
@ -173,15 +223,18 @@ define hidden ctx@(Context globalEnv _ typeEnv _ proj _ _ _) annXObj =
"' from " ++ show previousTypeUnwrapped ++ " to " ++ show (forceTy annXObj))
putStrLnWithColor White "" -- To restore color for sure.
Nothing -> return ()
case registerDefnOrDefInInterfaceIfNeeded ctx annXObj of
Left err ->
do case contextExecMode ctx of
Check -> let fppl = projectFilePathPrintLength (contextProj ctx)
in putStrLn (machineReadableInfoFromXObj fppl annXObj ++ " " ++ err)
_ -> putStrLnWithColor Red err
return ctx
Right ctx' ->
return (ctx' { contextGlobalEnv = envInsertAt globalEnv (getPath annXObj) (Binder adjustedMeta annXObj) })
case Map.lookup "implements" (getMeta previousMeta) of
Just (XObj (Sym interface@(SymPath _ _) _) _ _) ->
case registerDefnOrDefInInterfaceIfNeeded ctx annXObj interface of
Left err ->
do case contextExecMode ctx of
Check ->
let fppl = projectFilePathPrintLength (contextProj ctx)
in putStrLn (machineReadableInfoFromXObj fppl annXObj ++ " " ++ err)
_ -> putStrLnWithColor Red err
return ctx
Right ctx' -> return (ctx' {contextGlobalEnv = envInsertAt globalEnv (getPath annXObj) (Binder adjustedMeta annXObj)})
_ -> return (ctx {contextGlobalEnv = envInsertAt globalEnv (getPath annXObj) (Binder adjustedMeta annXObj)})
primitiveRegisterType :: Primitive
primitiveRegisterType _ ctx [XObj (Sym (SymPath [] t) _) _ _] =
@ -375,7 +428,8 @@ primitiveMetaSet _ ctx [target@(XObj (Sym path@(SymPath _ name) _) _ _), XObj (S
setMetaOn ctx (Just foundEnv) binder
Nothing ->
case path of
-- | If the path is unqualified, create a binder and set the meta on that one. This enables docstrings before function exists.
-- | If the path is unqualified, create a binder and set the meta on that one.
-- This enables docstrings and implementation declarations before function exists.
(SymPath [] name) ->
setMetaOn ctx Nothing (Binder emptyMeta (XObj (Lst [XObj DocStub Nothing Nothing,
XObj (Sym (SymPath pathStrings name) Symbol) Nothing Nothing])
@ -401,15 +455,15 @@ primitiveMetaSet _ ctx [XObj (Sym _ _) _ _, key, _] =
primitiveMetaSet _ ctx [target, _, _] =
argumentErr ctx "meta-set!" "a symbol" "first" target
retroactivelyRegisterInterfaceFunctions :: Context -> String -> Ty -> IO Context
retroactivelyRegisterInterfaceFunctions ctx name t = do
retroactivelyRegisterInterfaceFunctions :: Context -> SymPath -> IO Context
retroactivelyRegisterInterfaceFunctions ctx interface@(SymPath _ inter) = do
let env = contextGlobalEnv ctx
found = multiLookupALL name env
binders = map snd found
impls = recursiveLookupAll interface lookupImplementations env
resultCtx = foldl' (\maybeCtx binder -> case maybeCtx of
Right ok -> registerDefnOrDefInInterfaceIfNeeded ok (binderXObj binder)
Right ok ->
registerDefnOrDefInInterfaceIfNeeded ok (binderXObj binder) interface
Left err -> Left err)
(Right ctx) binders
(Right ctx) impls
case resultCtx of
Left err -> error err
Right ctx' -> return ctx'
@ -429,8 +483,7 @@ primitiveDefinterface xobj ctx [nameXObj@(XObj (Sym path@(SymPath [] name) _) _
Nothing ->
let interface = defineInterface name t [] (info nameXObj)
typeEnv' = TypeEnv (envInsertAt typeEnv (SymPath [] name) (Binder emptyMeta interface))
in do
newCtx <- retroactivelyRegisterInterfaceFunctions (ctx { contextTypeEnv = typeEnv' }) name t
in do newCtx <- retroactivelyRegisterInterfaceFunctions (ctx { contextTypeEnv = typeEnv' }) path
return (newCtx, dynamicNil)
Nothing ->
return (evalError ctx ("Invalid type for interface `" ++ name ++ "`: " ++ pretty ty) (info ty))
@ -450,11 +503,8 @@ registerInternal ctx name ty override = do
(info ty) (Just t)
meta = existingMeta globalEnv registration
env' = envInsertAt globalEnv path (Binder meta registration)
in case registerInInterfaceIfNeeded ctx path t of
Left errorMessage ->
return (makeEvalError ctx Nothing errorMessage (info ty))
Right ctx' ->
do return (ctx' { contextGlobalEnv = env' }, dynamicNil)
in return (ctx { contextGlobalEnv = env' }, dynamicNil)
-- TODO: Retroactively register in interface if implements metadata is present.
Nothing ->
return (evalError ctx
("Can't understand type when registering '" ++ name ++ "'") (info ty))
@ -532,9 +582,10 @@ primitiveDeftype xobj ctx (name:rest) =
})
in do ctxWithDeps <- liftIO (foldM (define True) ctx' deps)
let ctxWithInterfaceRegistrations =
foldM (\context (path, sig) -> registerInInterfaceIfNeeded context path sig) ctxWithDeps
[(SymPath (pathStrings ++ [typeModuleName]) "str", FuncTy [RefTy structTy (VarTy "q")] StringTy StaticLifetimeTy)
,(SymPath (pathStrings ++ [typeModuleName]) "copy", FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy)]
-- Since these functions are autogenerated, we treat them as a special case and automatically implement the interfaces.
foldM (\context (path, sig, interface) -> registerInInterfaceIfNeeded context path interface sig) ctxWithDeps
[(SymPath (pathStrings ++ [typeModuleName]) "str", FuncTy [RefTy structTy (VarTy "q")] StringTy StaticLifetimeTy, (SymPath [] "str"))
,(SymPath (pathStrings ++ [typeModuleName]) "copy", FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy, (SymPath [] "copy"))]
case ctxWithInterfaceRegistrations of
Left err -> do
liftIO (putStrLnWithColor Red err)

1
src/StartingEnv.hs
View File

@ -360,6 +360,7 @@ dynamicModule = Env { envBindings = bindings
, makePrim "eval" 1 "evaluates a list." "(eval mycode)" primitiveEval
, makePrim "defined?" 1 "checks whether a symbol is defined." "(defined? mysymbol)" primitiveDefined
, makePrim "deftemplate" 4 "defines a new C template." "(deftemplate symbol Type declString defString)" primitiveDeftemplate
, makePrim "implements" 2 "designates a function as an implementation of an interface." "(implements zero Maybe.zero)" primitiveImplements
]
++ [("String", Binder emptyMeta (XObj (Mod dynamicStringModule) Nothing Nothing))
,("Symbol", Binder emptyMeta (XObj (Mod dynamicSymModule) Nothing Nothing))

4
test-for-errors/no_matching_instance.carp
View File

@ -4,7 +4,9 @@
(definterface some-interface (Fn [a] Bool))
;; A module implements it, accepting Int:s
(defmodule A (defn some-interface [x] (Int.= x 1)))
(defmodule A
(defn some-interface [x] (Int.= x 1))
(implements some-interface A.some-interface))
;; The function 'f' uses the interface, should still have a generic type though.
(defn f [x] (some-interface x))

4
test-for-errors/trick_resolution.carp
View File

@ -2,7 +2,7 @@
;; This shouldn't resolve!
(definterface blurgh (Fn [a] Bool))
(defmodule A (defn blurgh [x] (Int.= x 1)))
(defmodule B (defn blurgh [x] (Float.= x 1.0f)))
(defmodule A (defn blurgh [x] (Int.= x 1)) (implements blurgh A.blurgh))
(defmodule B (defn blurgh [x] (Float.= x 1.0f)) (implements blurgh B.blurgh))
(defn f [x] (blurgh x))
(defn g [] (f "hello"))

49
test/interface.carp Normal file
View File

@ -0,0 +1,49 @@
;; Test Interfaces
(load "Test.carp")
(use Test)
(definterface foo (Fn [a] Int))
;; A module implements an interface using implements.
;; Implementations don't need to share names with interfaces.
(defmodule A
(defn bar [x] x)
(implements foo A.bar))
;; Implementations may be declared before definitions
;; like `doc`, the name is relative to the module environment
(defmodule B
(implements foo baz)
(defn baz [y] (if y 5 0)))
;; Interfaces may be implemented retroactively
;; global functions can also implement interfaces.
(defn gojira [s] @s)
(implements monster gojira)
(definterface monster (Fn [a] String))
;; An interface name can be used as a default implementation
(defn monster [scary?] (if scary? @"RAWR" @"meow"))
(implements monster monster)
(deftest test
(assert-equal test
&2
&(foo 2) ;; A.foo
"Implements works as expected.")
(assert-equal test
&5
&(foo true) ;; B.foo
"Implementations can be declared before definitions.")
(assert-equal test
"SKRYEEE"
&(monster "SKRYEEE")
"Interfaces can be implemented retroactively.")
(assert-equal test
"meow"
&(monster false)
"Implementations may be global, and an implementation with the same name may
be used as a default.")
)

2
test/memory.carp
View File

@ -291,9 +291,11 @@
(defn < [a b]
(< (Array.length a)
(Array.length b)))
(implements < ArrayCompareExtension.<)
(defn > [a b]
(> (Array.length a)
(Array.length b))))
(implements > ArrayCompareExtension.>)
(defn array-sort-1 []
(let [xs [[0 0] [0 0 0] [0 0 0 0] [0]]
ys (Array.sort xs)]

6
test/nested.carp
View File

@ -15,11 +15,13 @@
;; A function with correct nr of args but just generic types used to really confuse the type checker:
(defmodule Confuse
(defn = [a b]
true))
true)
(implements = Confuse.=))
(defmodule Young
(defn = [y1 y2]
(Int.= @(age y1) @(age y2))))
(Int.= @(age y1) @(age y2)))
(implements = Young.=))
;; Now I want to use 'Young.=' in with 'Ur.compare'
(defn f []

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

@ -1,3 +1,3 @@
no_matching_instance.carp:10:14 Can't find matching lookup for symbol 'some-interface' of type (Fn [Float] Bool)
no_matching_instance.carp:12:14 Can't find matching lookup for symbol 'some-interface' of type (Fn [Float] Bool)
None of the possibilities have the correct signature:
A.some-interface : (Fn [Int] Bool)

3
test/reload.carp
View File

@ -9,7 +9,8 @@
(defmodule Foo
(defn = [a b]
(= (Foo.x a) (Foo.x b))))
(= (Foo.x a) (Foo.x b)))
(implements = Foo.=))
;;(deftype (Foo t) [x t]) ;; <- this was the bug, simulate a reload of deftype