mirror of
https://github.com/carp-lang/Carp.git
synced 2024-09-11 05:25:28 +03:00
Add an implements primitive, update core
This change adds a new primitive Implements which changes interface implementations from being implicit to being explicit. Going forward, users will have to declare (implements <interface> <implementation>) to explicitly add a function to an interface. This provides two benefits: - Prevents unwitting name clashes. Previously, if one defined a function that happened to have the same name as an interface, it was automatically assumed the function implemented that interface when this is not always the intention, especially in large programs. - Name flexibility. One can now implement an interface with a function that has a different name than the interface, which allows for greater flexibility. I've updated core to make the necessary calls to the new primitive. Since str and copy are derived automatically for types, we treat these functions as a special case and auto-implement the interfaces.
This commit is contained in:
scottolsen
parent
4c08c68513
commit
040e9e4391
@ -295,6 +295,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]
|
||||
|
||||
@ -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))
|
||||
|
||||
@ -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.>)
|
||||
)
|
||||
|
||||
@ -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,6 +52,7 @@
|
||||
(or (alpha? c) (num? c)))
|
||||
|
||||
(defn zero [] (the Char (from-int 0)))
|
||||
(implements zero Char.zero)
|
||||
)
|
||||
|
||||
(defmodule CharRef
|
||||
|
||||
11
core/Collection.carp
Normal file
11
core/Collection.carp
Normal file
@ -0,0 +1,11 @@
|
||||
(definterface unsafe-nth (Fn [(Ref (a b) c) Int] &b))
|
||||
(definterface length (Fn [(Ref (a b))] Int))
|
||||
|
||||
(defmodule Collections
|
||||
(defn empty? [a]
|
||||
(= 0 (length a)))
|
||||
(defn first [a]
|
||||
(if (empty? a)
|
||||
(Maybe.Nothing)
|
||||
(Maybe.Just @(unsafe-nth a 0))))
|
||||
)
|
||||
@ -21,6 +21,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 +56,28 @@
|
||||
(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.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,15 +87,19 @@ 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 inc Double.dec)
|
||||
|
||||
(defn add-ref [x y]
|
||||
(Double.+ @x @y))
|
||||
(implements add-ref Double.add-ref)
|
||||
)
|
||||
|
||||
(defmodule DoubleRef
|
||||
|
||||
@ -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,44 @@ 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.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
|
||||
|
||||
@ -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,13 +88,8 @@
|
||||
(+ 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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
)
|
||||
|
||||
|
||||
@ -32,6 +32,18 @@
|
||||
(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
|
||||
@ -63,6 +75,18 @@
|
||||
(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
|
||||
@ -94,6 +118,18 @@
|
||||
(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
|
||||
@ -125,6 +161,18 @@
|
||||
(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
|
||||
@ -156,6 +204,18 @@
|
||||
(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
|
||||
@ -187,6 +247,18 @@
|
||||
(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
|
||||
@ -218,6 +290,18 @@
|
||||
(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
|
||||
@ -249,6 +333,18 @@
|
||||
(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
|
||||
|
||||
@ -24,6 +24,13 @@
|
||||
(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 +72,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 +95,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 +167,99 @@
|
||||
|
||||
(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)))
|
||||
|
||||
(defn str [s]
|
||||
(str &(the String s)))
|
||||
(implements str StringCopy.str)
|
||||
)
|
||||
|
||||
(defmodule Bool
|
||||
(register str (Fn [Bool] String))
|
||||
(register format (Fn [&String Bool] String))
|
||||
(implements format Bool.format)
|
||||
)
|
||||
|
||||
(defmodule Int
|
||||
(register str (Fn [Int] String))
|
||||
(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))
|
||||
(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))
|
||||
(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))
|
||||
(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))
|
||||
(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))
|
||||
(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))
|
||||
)
|
||||
|
||||
(defmodule BoolRef
|
||||
(defn prn [x] (Bool.str @x))
|
||||
(implements prn BoolRef.prn)
|
||||
(defn str [x] (Bool.str @x)))
|
||||
|
||||
(defmodule ByteRef
|
||||
(defn prn [x] (Byte.str @x))
|
||||
(implements prn ByteRef.prn)
|
||||
(defn str [x] (Byte.str @x))
|
||||
)
|
||||
|
||||
(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))
|
||||
|
||||
@ -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 }
|
||||
|
||||
@ -114,10 +114,36 @@ 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
|
||||
in case def of
|
||||
Just (_, Binder meta defobj) ->
|
||||
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)
|
||||
_ -> return $ evalError
|
||||
ctx ("Couldn't find a defintion for " ++ show impl ++ " did you define it?") (info x)
|
||||
primitiveImplements xobj ctx [x, y] =
|
||||
return $ evalError ctx ("`implements` expects symbol arguemnts.") (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 _ name) interface@(SymPath [] inter) 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 +153,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 '" ++ inter ++ "' 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 +203,8 @@ 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) })
|
||||
return (ctx {contextGlobalEnv = envInsertAt globalEnv (getPath annXObj) (Binder adjustedMeta annXObj)})
|
||||
-- TODO: Retroactively register interface impls when implements metadata is present.
|
||||
|
||||
primitiveRegisterType :: Primitive
|
||||
primitiveRegisterType _ ctx [XObj (Sym (SymPath [] t) _) _ _] =
|
||||
@ -401,13 +424,13 @@ 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 -> String -> SymPath -> IO Context
|
||||
retroactivelyRegisterInterfaceFunctions ctx name interface = do
|
||||
let env = contextGlobalEnv ctx
|
||||
found = multiLookupALL name env
|
||||
binders = map snd found
|
||||
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
|
||||
case resultCtx of
|
||||
@ -430,8 +453,8 @@ primitiveDefinterface xobj ctx [nameXObj@(XObj (Sym path@(SymPath [] name) _) _
|
||||
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
|
||||
return (newCtx, dynamicNil)
|
||||
-- TODO: Retroactively register functions with an implements meta for this interface.
|
||||
return (ctx { contextTypeEnv = typeEnv' }, dynamicNil)
|
||||
Nothing ->
|
||||
return (evalError ctx ("Invalid type for interface `" ++ name ++ "`: " ++ pretty ty) (info ty))
|
||||
primitiveDefinterface _ ctx [name, _] = do
|
||||
@ -450,11 +473,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 +552,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)
|
||||
|
||||
@ -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))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user