lisp -> coal

Convert standard library to .coal files

coalton.asd

@@ -48,8 +48,8 @@
                (:file "classes")
                (:file "hash")
                (:file "builtin")
-               (:file "functions")
-               (:file "boolean")
+               (:coalton-file "functions")
+               (:coalton-file "boolean")
                (:coalton-file "bits")
                (:module "math"
                 :serial t
@@ -65,15 +65,15 @@
                              (:file "dyadic")
                              (:file "dual")))
                (:file "randomaccess")
-               (:file "cell")
+               (:coalton-file "cell")
                (:file "tuple")
                (:file "iterator")
                (:file "optional")
                (:file "result")
                (:file "lisparray")
                (:file "list")
                (:file "vector")
-               (:file "char")
+               (:coalton-file "char")
                (:file "string")
                (:file "slice")
                (:file "hashtable")

library/bits.coal

@@ -0,0 +1,25 @@
+(package coalton-library/bits
+  (shadow
+     and
+     or
+     xor
+     not)
+  (import-from
+   coalton-library/classes
+   Num)
+  (export
+   Bits
+   and
+   or
+   xor
+   not
+   shift))
+
+(define-class (Num :int => Bits :int)
+  "Operations on the bits of twos-complement integers"
+  (and (:int -> :int -> :int))
+  (or (:int -> :int -> :int))
+  (xor (:int -> :int -> :int))
+  (not (:int -> :int))
+  (shift (Integer -> :int -> :int)))
+

library/boolean.coal

@@ -0,0 +1,33 @@
+(package coalton-library/boolean
+  (import
+    coalton-library/classes
+    coalton-library/hash))
+
+;;
+;; Boolean instances
+;;
+
+(define-instance (Hash Boolean)
+  (define (hash item)
+    (lisp Hash (item)
+      (cl:sxhash item))))
+
+(define-instance (Eq Boolean)
+  (define (== x y)
+    (lisp Boolean (x y)
+      (cl:eq x y))))
+
+(define-instance (Ord Boolean)
+  (define (<=> x y)
+    (match x
+      ((True)
+        (match y
+          ((True) EQ)
+          ((False) GT)))
+      ((False)
+        (match y
+          ((True) LT)
+          ((False) EQ))))))
+
+(define-instance (Default Boolean)
+  (define (default) False))

library/cell.coal

@@ -0,0 +1,141 @@
+(package coalton-library/cell
+  (import
+    coalton-library/builtin
+    coalton-library/classes)
+  (export
+    Cell
+    new
+    read
+    swap!
+    write!
+    update!
+    update-swap!
+    push!
+    pop!
+    increment!
+    decrement!))
+
+(lisp-toplevel ()
+  (cl:eval-when (:compile-toplevel)
+
+    (cl:declaim (cl:inline make-cell-internal))
+
+    (cl:defstruct cell-internal
+      (inner (cl:error "") :type cl:t))
+
+    (cl:defmethod cl:print-object ((self cell-internal) stream)
+      (cl:format stream "#.(CELL ~A)" (cell-internal-inner self))
+      self)
+
+    #+sbcl
+    (cl:declaim (sb-ext:freeze-type cell-internal))))
+
+(repr :native cell-internal)
+(define-type (Cell :a)
+  "Internally mutable cell")
+
+(declare new (:a -> Cell :a))
+(define (new data)
+  "Create a new mutable cell"
+  (lisp (Cell :a) (data)
+    (make-cell-internal :inner data)))
+
+(declare read (Cell :a -> :a))
+(define (read cel)
+  "Read the value of a mutable cell"
+  (lisp :a (cel)
+    (cell-internal-inner cel)))
+
+(declare swap! (Cell :a -> :a -> :a))
+(define (swap! cel data)
+  "Replace the value of a mutable cell with a new value, then return the old value"
+  (lisp :a (data cel)
+    (cl:let* ((old (cell-internal-inner cel)))
+      (cl:setf (cell-internal-inner cel) data)
+      old)))
+
+(declare write! (Cell :a -> :a -> :a))
+(define (write! cel data)
+  "Set the value of a mutable cell, returning the new value"
+  (lisp :a (data cel)
+    (cl:setf (cell-internal-inner cel) data)))
+
+(declare update! ((:a -> :a) -> Cell :a -> :a))
+(define (update! f cel)
+  "Apply F to the contents of CEL, storing and returning the result"
+  (write! cel (f (read cel))))
+
+(declare update-swap! ((:a -> :a) -> Cell :a -> :a))
+(define (update-swap! f cel)
+  "Apply F to the contents of CEL, swapping the result for the old value"
+  (swap! cel (f (read cel))))
+
+;;; operators on cells of lists
+(declare push! (Cell (List :elt) -> :elt -> List :elt))
+(define (push! cel new-elt)
+  "Push NEW-ELT onto the start of the list in CEL."
+  (update! (Cons new-elt) cel))
+
+(declare pop! (Cell (List :elt) -> Optional :elt))
+(define (pop! cel)
+  "Remove and return the first element of the list in CEL."
+  (match (read cel)
+    ((Cons fst rst)
+      (write! cel rst)
+      (Some fst))
+    ((Nil) None)))
+
+;;; operators on cells of numbers
+(declare increment! (Num :counter => Cell :counter -> :counter))
+(define (increment! cel)
+  "Add one to the contents of CEL, storing and returning the new value"
+  (update! (+ 1) cel))
+
+(declare decrement! (Num :counter => (Cell :counter) -> :counter))
+(define (decrement! cel)
+  "Subtract one from the contents of CEL, storing and returning the new value"
+  (update! (+ -1) cel))
+
+  ;; i am very skeptical of these instances
+(define-instance (Eq :a => Eq (Cell :a))
+  (define (== c1 c2)
+    (== (read c1) (read c2))))
+
+(define-instance (Ord :a => Ord (Cell :a))
+  (define (<=> c1 c2)
+    (match (<=> (read c1) (read c2))
+      ((LT) LT)
+      ((GT) GT)
+      ((EQ) EQ))))
+
+(define-instance (Num :a => Num (Cell :a))
+  (define (+ c1 c2)
+    (new (+ (read c1) (read c2))))
+  (define (- c1 c2)
+    (new (- (read c1) (read c2))))
+  (define (* c1 c2)
+    (new (* (read c1) (read c2))))
+  (define (fromInt i)
+    (new (fromInt i))))
+
+(define-instance (Semigroup :a => Semigroup (Cell :a))
+  (define (<> a b)
+    (new (<> (read a) (read b)))))
+
+(define-instance (Functor Cell)
+  (define (map f c)
+    (new (f (read c)))))
+
+(define-instance (Applicative Cell)
+  (define pure new)
+  (define (liftA2 f c1 c2)
+    (new (f (read c1) (read c2)))))
+
+(define-instance (Into :a (Cell :a))
+  (define into new))
+
+(define-instance (Into (Cell :a) :a)
+  (define into read))
+
+(define-instance (Default :a => Default (Cell :a))
+  (define (default) (new (default))))