mirror of
https://github.com/carp-lang/Carp.git
synced 2024-09-11 05:25:28 +03:00
Merge pull request #769 from scolsen/implement-prim
Add an `implements` primitive, update core
This commit is contained in:
commit
aae743fb35
@ -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]
|
||||
|
@ -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))
|
||||
|
@ -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,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
15
core/Collection.carp
Normal 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))))
|
||||
)
|
@ -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"
|
||||
|
@ -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.>)
|
||||
)
|
||||
|
@ -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
|
||||
|
@ -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.>)
|
||||
)
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
)
|
||||
|
@ -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)
|
||||
)
|
||||
|
@ -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.")
|
||||
|
@ -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)
|
||||
)
|
||||
|
@ -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)
|
||||
)
|
||||
|
||||
|
@ -106,6 +106,7 @@ It is the inverse of [`success?`](#success?).")
|
||||
(match-ref b
|
||||
(Success _) false
|
||||
(Error y) (= x y))))
|
||||
(implements = Result.=)
|
||||
)
|
||||
|
||||
(defmodule Maybe
|
||||
|
@ -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")
|
||||
|
@ -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
120
core/StdInt.carp
@ -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.=)
|
||||
)
|
||||
|
@ -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))
|
||||
|
@ -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]
|
||||
|
@ -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))
|
||||
|
@ -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)
|
||||
|
@ -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])
|
||||
|
@ -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)
|
||||
|
@ -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,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)
|
||||
|
@ -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,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))
|
||||
|
@ -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
49
test/interface.carp
Normal 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.")
|
||||
)
|
@ -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)]
|
||||
|
@ -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 []
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user