Skip to content

Commit

Permalink
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
lisp -> coal
Browse files Browse the repository at this point in the history
hash.coal

builtin.coal

math/arith.coal

num.coal

bounded.coal
jbouwman committed Aug 21, 2024
1 parent 9e6b4cf commit d5bd300
Showing 14 changed files with 1,294 additions and 1,307 deletions.
12 changes: 6 additions & 6 deletions coalton.asd
Original file line number Diff line number Diff line change
@@ -45,17 +45,17 @@
(:file "utils")
(:coalton-file "types")
(:coalton-file "primitive-types")
(:file "classes")
(:file "hash")
(:file "builtin")
(:coalton-file "classes")
(:coalton-file "hash")
(:coalton-file "builtin")
(:coalton-file "functions")
(:coalton-file "boolean")
(:coalton-file "bits")
(:module "math"
:serial t
:components ((:file "arith")
(:file "num")
(:file "bounded")
:components ((:coalton-file "arith")
(:coalton-file "num")
(:coalton-file "bounded")
(:file "conversions")
(:file "fraction")
(:file "integral")
60 changes: 60 additions & 0 deletions library/builtin.coal
Original file line number Diff line number Diff line change
@@ -0,0 +1,60 @@
(package coalton-library/builtin
(import
coalton-library/classes)
(export
unreachable
undefined
error ; re-export from classes
not
xor
boolean-not
boolean-or
boolean-and
boolean-xor))

(lisp-toplevel ()
(cl:eval-when (:compile-toplevel)
(cl:defmacro unreachable (cl:&optional (datum "Unreachable") cl:&rest arguments)
"Signal an error with CL format string DATUM and optional format arguments ARGUMENTS."
`(lisp :a ()
(cl:error ,datum ,@arguments)))))

(define (undefined _)
"A function which can be used in place of any value, throwing an error at runtime."
(error "Undefined"))

(define not
"Synonym for `boolean-not`."
boolean-not)

(define xor
"Synonym for `boolean-xor`."
boolean-xor)

(declare boolean-not (Boolean -> Boolean))
(define (boolean-not x)
"The logical negation of `x`. Is `x` false?"
(match x
((True) False)
((False) True)))

(declare boolean-or (Boolean -> Boolean -> Boolean))
(define (boolean-or x y)
"Is either `x` or `y` true? Note that this is a *function* which means both `x` and `y` will be evaluated. Use the `or` macro for short-circuiting behavior."
(match x
((True) True)
((False) y)))

(declare boolean-and (Boolean -> Boolean -> Boolean))
(define (boolean-and x y)
"Are both `x` and `y` true? Note that this is a *function* which means both `x` and `y` will be evaluated. Use the `and` macro for short-circuiting behavior."
(match x
((True) y)
((False) False)))

(declare boolean-xor (Boolean -> Boolean -> Boolean))
(define (boolean-xor x y)
"Are `x` or `y` true, but not both?"
(match x
((True) (boolean-not y))
((False) y)))
71 changes: 0 additions & 71 deletions library/builtin.lisp

This file was deleted.

340 changes: 340 additions & 0 deletions library/classes.coal
Original file line number Diff line number Diff line change
@@ -0,0 +1,340 @@
(package coalton-library/classes
(import
(coalton-library/types as types))
(export
Signalable
error
Tuple
Optional Some None
Result Ok Err
Eq ==
Ord LT EQ GT
<=> > < >= <=
max
min
Num + - * fromInt
Semigroup <>
Monoid mempty
Functor map
Applicative pure liftA2
Monad >>=
>>
MonadFail fail
Alternative alt empty
Foldable fold foldr mconcat
Traversable traverse
Bifunctor bimap map-fst map-snd
sequence
Into
TryInto
Iso
Unwrappable unwrap-or-else with-default unwrap expect as-optional
default defaulting-unwrap default?))

;;;
;;; Signaling errors and warnings
;;;

;;
;; Signalling errors on supported types
;;
(define-class (Signalable :a)
"Signals errors or warnings by calling their respective lisp conditions."
(error "Signal an error with a type-specific error string." (:a -> :b)))

(define-instance (Signalable String)
(define (error str)
(lisp :a (str)
(cl:error str))))

;;
;; Base Types
;;

(define-struct (Tuple :a :b)
"A heterogeneous collection of items."
(first :a)
(second :b))

(define-type (Optional :a)
"Represents something that may not have a value."
(Some :a)
None)

(define-type (Result :bad :good)
"Represents something that may have failed."
;; We write (Result :bad :good) instead of (Result :good :bad)
;; because of the limitations of how we deal with higher-kinded
;; types; we want to implement Functor on this.
(Ok :good)
(Err :bad))

;;
;; Eq
;;

(define-class (Eq :a)
"Types which have equality defined."
(== (:a -> :a -> Boolean)))

(define-instance (Eq types:LispType)
(define (== a b)
(lisp Boolean (a b)
(cl:equalp a b))))

(define-class (Eq :a => Num :a)
"Types which have numeric operations defined."
(+ (:a -> :a -> :a))
(- (:a -> :a -> :a))
(* (:a -> :a -> :a))
(fromInt (Integer -> :a)))

(define-instance (Eq Unit)
(define (== _ _) True))

;;
;; Ord
;;

(repr :enum)
(define-type Ord
"The result of an ordered comparison."
LT
EQ
GT)

(define-instance (Eq Ord)
(define (== a b)
(match (Tuple a b)
((Tuple (LT) (LT)) True)
((Tuple (EQ) (EQ)) True)
((Tuple (GT) (GT)) True)
(_ False))))

(define-instance (Ord Ord)
(define (<=> a b)
(match (Tuple a b)
((Tuple (LT) (LT)) EQ)
((Tuple (LT) (EQ)) LT)
((Tuple (LT) (GT)) LT)
((Tuple (EQ) (LT)) GT)
((Tuple (EQ) (EQ)) EQ)
((Tuple (EQ) (GT)) LT)
((Tuple (GT) (LT)) GT)
((Tuple (GT) (EQ)) GT)
((Tuple (GT) (GT)) EQ))))

(define-class (Eq :a => Ord :a)
"Types whose values can be ordered."
(<=> (:a -> :a -> Ord)))

(declare > (Ord :a => :a -> :a -> Boolean))
(define (> x y)
"Is `x` greater than `y`?"
(match (<=> x y)
((GT) True)
(_ False)))

(declare < (Ord :a => :a -> :a -> Boolean))
(define (< x y)
"Is `x` less than `y`?"
(match (<=> x y)
((LT) True)
(_ False)))

(declare >= (Ord :a => :a -> :a -> Boolean))
(define (>= x y)
"Is `x` greater than or equal to `y`?"
(match (<=> x y)
((LT) False)
(_ True)))

(declare <= (Ord :a => :a -> :a -> Boolean))
(define (<= x y)
"Is `x` less than or equal to `y`?"
(match (<=> x y)
((GT) False)
(_ True)))

(declare max (Ord :a => :a -> :a -> :a))
(define (max x y)
"Returns the greater element of `x` and `y`."
(if (> x y)
x
y))

(declare min (Ord :a => :a -> :a -> :a))
(define (min x y)
"Returns the lesser element of `x` and `y`."
(if (< x y)
x
y))

;;
;; Haskell
;;

(define-class (Semigroup :a)
"Types with an associative binary operation defined."
(<> (:a -> :a -> :a)))

(define-class (Semigroup :a => Monoid :a)
"Types with an associative binary operation and identity defined."
(mempty :a))

(define-class (Functor :f)
"Types which can map an inner type where the mapping adheres to the identity and composition laws."
(map ((:a -> :b) -> :f :a -> :f :b)))

(define-class (Functor :f => Applicative :f)
"Types which are a functor which can embed pure expressions and sequence operations."
(pure (:a -> (:f :a)))
(liftA2 ((:a -> :b -> :c) -> :f :a -> :f :b -> :f :c)))

(define-class (Applicative :m => Monad :m)
"Types which are monads as defined in Haskell. See https://wiki.haskell.org/Monad for more information."
(>>= (:m :a -> (:a -> :m :b) -> :m :b)))

(declare >> (Monad :m => (:m :a) -> (:m :b) -> (:m :b)))
(define (>> a b)
(>>= a (fn (_) b)))

(define-class (Monad :m => MonadFail :m)
(fail (String -> :m :a)))

(define-class (Applicative :f => Alternative :f)
"Types which are monoids on applicative functors."
(alt (:f :a -> :f :a -> :f :a))
(empty (:f :a)))

(define-class (Foldable :container)
"Types which can be folded into a single element."
(fold "A left tail-recursive fold." ((:accum -> :elt -> :accum) -> :accum -> :container :elt -> :accum))
(foldr "A right non-tail-recursive fold."((:elt -> :accum -> :accum) -> :accum -> :container :elt -> :accum)))

(declare mconcat ((Foldable :f) (Monoid :a) => :f :a -> :a))
(define mconcat
"Fold a container of monoids into a single element."
(fold <> mempty))

(define-class (Traversable :t)
(traverse (Applicative :f => (:a -> :f :b) -> :t :a -> :f (:t :b))))

(declare sequence ((Traversable :t) (Applicative :f) => :t (:f :b) -> :f (:t :b)))
(define sequence (traverse (fn (x) x)))

(define-class (Bifunctor :f)
"Types which take two type arguments and are functors on both."
(bimap ((:a -> :b) -> (:c -> :d) -> :f :a :c -> :f :b :d)))

(declare map-fst (Bifunctor :f => (:a -> :b) -> :f :a :c -> :f :b :c))
(define (map-fst f b)
"Map over the first argument of a `Bifunctor`."
(bimap f (fn (x) x) b))

(declare map-snd (Bifunctor :f => (:b -> :c) -> :f :a :b -> :f :a :c))
(define (map-snd f b)
"Map over the second argument of a `Bifunctor`."
(bimap (fn (x) x) f b))

;;
;; Conversions
;;

(define-class (Into :a :b)
"`INTO` imples *every* element of `:a` can be represented by an element of `:b`. This conversion might not be bijective (i.e., there may be elements in `:b` that don't correspond to any in `:a`)."
(into (:a -> :b)))

(define-class ((Into :a :b) (Into :b :a) => Iso :a :b)
"Opting into this marker typeclass imples that the instances for `(Into :a :b)` and `(Into :b :a)` form a bijection.")

(define-instance (Into :a :a)
(define (into x) x))

(define-class (TryInto :a :b :c (:a :b -> :c))
"`TRY-INTO` implies some elements of `:a` can be represented exactly by an element of `:b`, but sometimes not. If not, an error of type `:c` is returned."
(tryInto (:a -> (Result :c :b))))

(define-instance (Iso :a :a))

;;
;; Unwrappable for fallible unboxing
;;

(define-class (Unwrappable :container)
"Containers which can be unwrapped to get access to their contents.
`(unwrap-or-else succeed fail container)` should invoke the `succeed` continuation on the unwrapped contents of
`container` when successful, or invoke the `fail` continuation with no arguments (i.e., with `Unit` as an argument)
when unable to unwrap a value.
The `succeed` continuation will often, but not always, be the identity function. `as-optional` passes `Some` to
construct an `Optional`.
Typical `fail` continuations are:
- Return a default value, or
- Signal an error."
(unwrap-or-else ((:elt -> :result)
-> (Unit -> :result)
-> (:container :elt)
-> :result)))

(declare expect ((Unwrappable :container) =>
String
-> (:container :element)
-> :element))
(define (expect reason container)
"Unwrap `container`, signaling an error with the description `reason` on failure."
(unwrap-or-else (fn (elt) elt)
(fn () (error reason))
container))

(declare unwrap ((Unwrappable :container) =>
(:container :element)
-> :element))
(define (unwrap container)
"Unwrap `container`, signaling an error on failure."
(unwrap-or-else (fn (elt) elt)
(fn () (error (lisp String (container)
(cl:format cl:nil "Unexpected ~a in UNWRAP"
container))))
container))

(declare with-default ((Unwrappable :container) =>
:element
-> (:container :element)
-> :element))
(define (with-default default container)
"Unwrap `container`, returning `default` on failure."
(unwrap-or-else (fn (elt) elt)
(fn () default)
container))

(declare as-optional ((Unwrappable :container) => (:container :elt) -> (Optional :elt)))
(define (as-optional container)
"Convert any Unwrappable container into an `Optional`, constructing Some on a successful unwrap and None on a failed unwrap."
(unwrap-or-else Some
(fn () None)
container))


;;
;; Default
;;

(define-class (Default :a)
"Types which have default values."
(default (Unit -> :a)))

(declare defaulting-unwrap ((Unwrappable :container) (Default :element) =>
(:container :element) -> :element))
(define (defaulting-unwrap container)
"Unwrap an `unwrappable`, returning `(default)` of the wrapped type on failure. "
(unwrap-or-else (fn (elt) elt)
(fn () (default))
container))

(declare default? ((Default :a) (Eq :a) => :a -> Boolean))
(define (default? x)
"Is `x` the default item of its type?"
(== x (default)))
358 changes: 0 additions & 358 deletions library/classes.lisp

This file was deleted.

84 changes: 84 additions & 0 deletions library/hash.coal
Original file line number Diff line number Diff line change
@@ -0,0 +1,84 @@
(package coalton-library/hash
(import
coalton-library/classes)
(export
Hash
combine-hashes
combine-hashes-order-independent))

#+sbcl
(repr :native (cl:unsigned-byte 62))

#+allegro
(repr :native (cl:unsigned-byte 0 32))

;; https://github.com/Clozure/ccl/blob/ff51228259d9dbc8a9cc7bbb08858ef4aa9fe8d0/level-0/l0-hash.lisp#L1885
#+ccl
(repr :native (cl:and cl:fixnum cl:unsigned-byte))

#+(not (or sbcl allegro ccl))
#.(cl:error "hashing is not supported on ~A" (cl:lisp-implementation-type))

(define-type Hash
"Implementation dependent hash code")

(define-class (Eq :a => Hash :a)
"Types which can be hashed for storage in hash tables.
The hash function must satisfy the invariant that `(== left right)` implies `(== (hash left) (hash right))`."
(hash (:a -> Hash)))

(declare combine-hashes (Hash -> Hash -> Hash))
(define (combine-hashes lhs rhs)
(lisp Hash (lhs rhs)
;; SBCL has a hash combination function
#+sbcl (sb-int:mix lhs rhs)

;;
;; Generic hash combination functions copied from:
;; https://stackoverflow.com/questions/5889238/why-is-xor-the-default-way-to-combine-hashes/27952689#27952689
;;

;; 32bit hash combination
#+allegro (cl:logxor lhs (cl:+ rhs #x9e3779b9 (cl:ash lhs 6) (cl:ash lhs -2)))

;; 64bit hash combination
;; logand required on ccl to force the output to be a fixnum
#+ccl (cl:logand (cl:logxor lhs (cl:+ rhs #x517cc1b727220a95 (cl:ash lhs 6) (cl:ash lhs -2))) cl:most-positive-fixnum)))

(declare combine-hashes-order-independent (Hash -> Hash -> Hash))
(define (combine-hashes-order-independent lhs rhs)
(lisp Hash (lhs rhs)
(cl:logxor lhs rhs)))

(define-instance (Eq Hash)
(define (== a b)
(lisp Boolean (a b)
(cl:= a b))))

(define-instance (Ord Hash)
(define (<=> a b)
(if (== a b)
EQ
(if (lisp Boolean (a b) (to-boolean (cl:> a b)))
GT
LT))))

(define-instance (Semigroup Hash)
(define (<> a b)
(combine-hashes a b)))

(define-instance (Monoid Hash)
(define mempty
(lisp Hash ()
0)))

(define-instance (Default Hash)
(define (default)
(lisp Hash ()
0)))

(define-instance (Hash Hash)
(define (hash item)
(lisp Hash (item)
(cl:sxhash item))))
101 changes: 0 additions & 101 deletions library/hash.lisp

This file was deleted.

192 changes: 192 additions & 0 deletions library/math/arith.coal
Original file line number Diff line number Diff line change
@@ -0,0 +1,192 @@
;;;; Number types and basic arithmetic.

(package coalton-library/math/arith
(import
coalton-library/builtin
coalton-library/classes
coalton-library/functions
coalton-library/utils)
(export
Reciprocable
/
reciprocal
Dividable
general/
/
Transfinite
infinity
infinite?
finite?
negative-infinity
nan
nan?
negate
abs
sign
ash
1+
1-
positive?
negative?
nonpositive?
nonnegative?
zero?
nonzero?))

;;
;; Division
;;

(define-class (Num :a => Reciprocable :a)
"Any number with a multiplicative inverse (reciprocal) where:
1 = (* (reciprocal x) x) = (* x (reciprocal x))
(/ x y) = (* x (reciprocal y))
If no reciprocal exists for an element, produce a run-time error (e.g., zero).
"
(/ (:a -> :a -> :a))
(reciprocal (:a -> :a)))

(define-class (Dividable :arg-type :res-type)
"The representation of a type such that division within that type possibly results in another type. For instance,
(Dividable Integer Fraction)
establishes that division of two `Integer`s can result in a `Fraction`, whereas
(Dividable Single-Float Single-Float)
establishes that division of two `Single-Float`s can result in a `Single-Float`.
Note that `Dividable` does *not* establish a default result type; you must constrain the result type yourself.
The function `general/` is partial, and will error produce a run-time error if the divisor is zero.
"
;; This is a type that is more pragmatic and less mathematical in
;; nature. It expresses a division relationship between one input
;; type and one output type.
(general/ (:arg-type -> :arg-type -> :res-type)))

(define-instance (Reciprocable :a => Dividable :a :a)
(define (general/ a b) (/ a b)))

(define-class (Transfinite :a)
"Numeric type with a value for (positive) infinity and/or NaN."
(infinity :a)
(infinite? (:a -> Boolean))
(nan :a)
(nan? (:a -> Boolean)))

(declare finite? ((Transfinite :a) => :a -> Boolean))
(define (finite? x)
"Neither infinite or NaN."
(or (infinite? x) (nan? x)))

(declare negative-infinity ((Transfinite :a) (Num :a) => :a))
(define negative-infinity
(negate infinity))

(define-instance (Transfinite Single-Float)
(define infinity
(lisp Single-Float ()
float-features:single-float-positive-infinity))
(define nan
(lisp Single-Float ()
float-features:single-float-nan))
(define (nan? x)
(Lisp Boolean (x)
#+(not allegro)
(float-features:float-NaN-p x)
#+allegro
(cl:and (float-features:float-NaN-p x) cl:t)))
(define (infinite? x)
(Lisp Boolean (x)
(float-features:float-infinity-p x))))

(define-instance (Transfinite Double-Float)
(define infinity
(lisp Double-Float ()
float-features:double-float-positive-infinity))
(define nan
(lisp Double-Float ()
float-features:double-float-nan))
(define (nan? x)
(Lisp Boolean (x)
#+(not allegro)
(float-features:float-NaN-p x)
#+allegro
(cl:and (float-features:float-NaN-p x) cl:t)))
(define (infinite? x)
(Lisp Boolean (x)
(float-features:float-infinity-p x))))

(declare negate (Num :a => :a -> :a))
(define (negate x)
"The negation, or additive inverse, of `x`."
(- 0 x))

(declare abs ((Ord :a) (Num :a) => :a -> :a))
(define (abs x)
"Absolute value of `x`."
(if (< x 0)
(negate x)
x))

(declare sign ((Ord :a) (Num :a) (Num :b) => :a -> :b))
(define (sign x)
"The sign of `x`, where `(sign 0) = 1`."
(if (< x 0)
-1
1))

(declare ash (Integer -> Integer -> Integer))
(define (ash x n)
"Compute the \"arithmetic shift\" of `x` by `n`. "
(lisp Integer (x n) (cl:ash x n)))

(declare 1+ ((Num :num) => :num -> :num))
(define (1+ num)
"Increment `num`."
(+ num 1))

(declare 1- ((Num :num) => :num -> :num))
(define (1- num)
"Decrement `num`."
(- num 1))

(declare positive? ((Num :a) (Ord :a) => :a -> Boolean))
(define (positive? x)
"Is `x` positive?"
(> x 0))

(declare negative? ((Num :a) (Ord :a) => :a -> Boolean))
(define (negative? x)
"Is `x` negative?"
(< x 0))

(declare nonpositive? ((Num :a) (Ord :a) => :a -> Boolean))
(define (nonpositive? x)
"Is `x` not positive?"
(<= x 0))

(declare nonnegative? ((Num :a) (Ord :a) => :a -> Boolean))
(define (nonnegative? x)
"Is `x` not negative?"
(>= x 0))

(declare zero? (Num :a => :a -> Boolean))
(define (zero? x)
"Is `x` zero?"
(== x 0))

(declare nonzero? (Num :a => :a -> Boolean))
(define (nonzero? x)
"Is `x` not zero?"
(/= x 0))
206 changes: 0 additions & 206 deletions library/math/arith.lisp

This file was deleted.

62 changes: 62 additions & 0 deletions library/math/bounded.coal
Original file line number Diff line number Diff line change
@@ -0,0 +1,62 @@
;;;; Numerical types with fixed bounds

(package coalton-library/math/bounded
(import
coalton-library/builtin
coalton-library/classes
coalton-library/functions)
(export
Bounded
minBound
maxBound))

(define-class (Bounded :a)
"Types which have a maximum and minumum bound."
(minBound :a)
(maxBound :a))

(define-instance (Bounded U8)
(define minBound 0) ; 0
(define maxBound 255)) ; 2^8-1

(define-instance (Bounded I8)
(define minBound -128) ; -1 * ceiling((2^8-1)/2)
(define maxBound 127)) ; ceiling((2^8-1)/2)

(define-instance (Bounded U16)
(define minBound 0) ; 0
(define maxBound 65535)) ; 2^16-1

(define-instance (Bounded I16)
(define minBound -32768) ; -1 * floor((2^16-1)/2)
(define maxBound 32767)) ; ceiling((2^16-1)/2)

(define-instance (Bounded U32)
(define minBound 0) ; 0
(define maxBound 4294967295)) ; 2^32-1

(define-instance (Bounded I32)
(define minBound -2147483648) ; -1 * ceiling((2^32-1)/2)
(define maxBound 2147483647)) ; floor((2^32-1)/2)

(define-instance (Bounded U64)
(define minBound 0) ; 0
(define maxBound 18446744073709551615)) ; 2^64-1

(define-instance (Bounded I64)
(define minBound -9223372036854775808) ; -1 * ceiling((2^64-1)/2)
(define maxBound 9223372036854775807)) ; floor((2^32-1)/2)

(define-instance (Bounded IFix)
(define minBound
(lisp IFix ()
cl:most-negative-fixnum))
(define maxBound
(lisp IFix ()
cl:most-positive-fixnum)))

(define-instance (Bounded UFix)
(define minBound 0)
(define maxBound
(lisp UFix ()
cl:most-positive-fixnum)))
74 changes: 0 additions & 74 deletions library/math/bounded.lisp

This file was deleted.

544 changes: 544 additions & 0 deletions library/math/num.coal

Large diffs are not rendered by default.

488 changes: 0 additions & 488 deletions library/math/num.lisp

This file was deleted.

9 changes: 6 additions & 3 deletions library/string.lisp
Original file line number Diff line number Diff line change
@@ -5,7 +5,7 @@
#:coalton-library/classes)
(:import-from
#:coalton-library/hash
#:define-sxhash-hasher)
#:Hash)
(:import-from
#:coalton-library/vector
#:Vector)
@@ -234,9 +234,12 @@ does not have that suffix."
(Ok z))))))

(define-instance (Default String)
(define (default) "")))
(define (default) ""))

(define-sxhash-hasher String)
(define-instance (Hash String)
(define (hash item)
(lisp Hash (item)
(cl:sxhash item)))))

#+sb-package-locks
(sb-ext:lock-package "COALTON-LIBRARY/STRING")

0 comments on commit d5bd300

Please sign in to comment.