Remove Serapeum

coalton.asd

@@ -8,9 +8,9 @@
   :depends-on (#:alexandria
                #:global-vars
                #:trivia
-               #:serapeum
                #:fset
                #:float-features
+               #:split-sequence
                #:uiop)
   :in-order-to ((asdf:test-op (asdf:test-op #:coalton/tests)))
   :around-compile (lambda (compile)

src/algorithm/immutable-listmap.lisp

@@ -5,8 +5,8 @@
 ;; Wrapper around fset:map<fset:seq>
 ;;
 
-(serapeum:defstruct-read-only immutable-listmap
-  (data (fset:empty-map (fset:empty-seq)) :type fset:map))
+(defstruct immutable-listmap
+  (data (fset:empty-map (fset:empty-seq)) :type fset:map) :read-only t)
 
 (defun immutable-listmap-lookup (m key &key no-error)
   "Lookup key in M"

src/algorithm/immutable-map.lisp

@@ -6,8 +6,14 @@
 ;; Wrapper around fset:map
 ;;
 
-(serapeum:defstruct-read-only immutable-map
-  (data (fset:empty-map) :type fset:map))
+(defstruct immutable-map
+  (data (fset:empty-map) :type fset:map :read-only t))
+
+(defmethod make-load-form ((self immutable-map) &optional env)
+  (make-load-form-saving-slots
+   self
+   :slot-names '(data)
+   :environment env))
 
 (defun immutable-map-lookup (m key)
   "Lookup KEY in M"

src/ast/node.lisp

@@ -1,9 +1,7 @@
 (in-package #:coalton-impl/ast)
 
-(serapeum:defstruct-read-only
-    (node
-     (:constructor nil))
-  (unparsed :type t))
+(defstruct (node (:constructor nil))
+  (unparsed (required 'unparsed) :type t :read-only t))
 
 (defun node-list-p (x)
   (and (alexandria:proper-list-p x)
@@ -45,102 +43,102 @@
 #+sbcl
 (declaim (sb-ext:freeze-type literal-value))
 
-(serapeum:defstruct-read-only
+(defstruct
     (node-literal
      (:include node)
      (:constructor node-literal (unparsed value)))
   "A literal value. These include things like integers and strings."
-  (value :type literal-value))
+  (value (required 'value) :type literal-value :read-only t))
 
 #+sbcl
 (declaim (sb-ext:freeze-type node-literal))
 
-(serapeum:defstruct-read-only
+(defstruct
     (node-variable
      (:include node)
      (:constructor node-variable (unparsed name)))
-  (name :type symbol))
+  (name (required 'name) :type symbol :read-only t))
 
 #+sbcl
 (declaim (sb-ext:freeze-type node-variable))
 
-(serapeum:defstruct-read-only
+(defstruct
     (node-application
      (:include node)
      (:constructor node-application (unparsed rator rands)))
-  (rator :type node)
-  (rands :type node-list))
+  (rator (required 'rator) :type node      :read-only t)
+  (rands (required 'rands) :type node-list :read-only t))
 
 #+sbcl
 (declaim (sb-ext:freeze-type node-application))
 
-(serapeum:defstruct-read-only
+(defstruct
     (node-abstraction
      (:include node)
      (:constructor node-abstraction (unparsed vars subexpr name-map)))
-  (vars    :type symbol-list)
-  (subexpr :type node)
-  (name-map :type list))
+  (vars     (required 'vars)     :type t :read-only t)
+  (subexpr  (required 'subexpr)  :type node        :read-only t)
+  (name-map (required 'name-map) :type list        :read-only t))
 
 #+sbcl
 (declaim (sb-ext:freeze-type node-abstraction))
 
-(serapeum:defstruct-read-only
+(defstruct
     (node-let
      (:include node)
      (:constructor node-let (unparsed bindings subexpr name-map)))
-  (bindings :type binding-list)
-  (subexpr  :type node)
-  (name-map :type list))
+  (bindings (required 'bindings) :type binding-list :read-only t)
+  (subexpr  (required 'subexpr)  :type node         :read-only t)
+  (name-map (required 'name-map) :type list         :read-only t))
 
 #+sbcl
 (declaim (sb-ext:freeze-type node-let))
 
-(serapeum:defstruct-read-only
+(defstruct
     (node-lisp
      (:include node)
      (:constructor node-lisp (unparsed type variables form)))
-  (type :type t)
-  (variables :type list)
-  (form :type t))
+  (type      (required 'type)      :type t :read-only t)
+  (variables (required 'variables) :type t :read-only t)
+  (form      (required 'form)      :type t :read-only t))
 
 #+sbcl
 (declaim (sb-ext:freeze-type node-lisp))
 
-(serapeum:defstruct-read-only match-branch
-  (unparsed :type t)
-  (pattern :type pattern)
-  (subexpr :type node)
-  (name-map :type list))
+(defstruct match-branch
+  (unparsed  (required 'unparsed) :type t       :read-only t)
+  (pattern   (required 'pattern)  :type pattern :read-only t)
+  (subexpr   (required 'subexpr)  :type node    :read-only t)
+  (name-map  (required 'name-map) :type list    :read-only t))
 
 #+sbcl
 (declaim (sb-ext:freeze-type match-branch))
 
-(serapeum:defstruct-read-only
+(defstruct
     (node-match
      (:include node)
      (:constructor node-match (unparsed expr branches)))
-  (expr     :type node)
-  (branches :type list))
+  (expr     (required 'expr)     :type node :read-only t)
+  (branches (required 'branches) :type list :read-only t))
 
 #+sbcl
 (declaim (sb-ext:freeze-type node-match))
 
-(serapeum:defstruct-read-only
+(defstruct
     (node-seq
      (:include node)
      (:constructor node-seq (unparsed subnodes)))
-     (subnodes :type node-list))
+     (subnodes (required 'subnodes) :type node-list :read-only t))
 
 #+sbcl
 (declaim (sb-ext:freeze-type node-seq))
 
-(serapeum:defstruct-read-only
+(defstruct
     (node-the
      (:include node)
      (:constructor node-the (unparsed type subnode)))
-  (type :type t)
-  (subnode :type node))
+  (type    (required 'type)       :type t    :read-only t)
+  (subnode (required 'subnode)    :type node :read-only t))
 
 #+sbcl
 (declaim (sb-ext:freeze-type node-the))

src/ast/pattern.lisp

@@ -4,7 +4,7 @@
 ;;; Patterns
 ;;;
 
-(serapeum:defstruct-read-only (pattern (:constructor nil)))
+(defstruct (pattern (:constructor nil)))
 
 (defun pattern-list-p (x)
   (and (alexandria:proper-list-p x)
@@ -16,38 +16,38 @@
 #+sbcl
 (declaim (sb-ext:freeze-type pattern-list))
 
-(serapeum:defstruct-read-only
+(defstruct
     (pattern-var
      (:include pattern)
      (:constructor pattern-var (id)))
-  (id :type symbol))
+  (id (required 'id) :type symbol :read-only t))
 
 #+sbcl
 (declaim (sb-ext:freeze-type pattern-var))
 
-(serapeum:defstruct-read-only
+(defstruct
     (pattern-wildcard
      (:include pattern)
      (:constructor pattern-wildcard)))
 
 #+sbcl
 (declaim (sb-ext:freeze-type pattern-wildcard))
 
-(serapeum:defstruct-read-only
+(defstruct
     (pattern-literal
      (:include pattern)
      (:constructor pattern-literal (value)))
-  (value  :type node-literal))
+  (value (required 'value) :type node-literal :read-only t))
 
 #+sbcl
 (declaim (sb-ext:freeze-type pattern-literal))
 
-(serapeum:defstruct-read-only
+(defstruct
     (pattern-constructor
      (:include pattern)
-     (:constructor pattern-constructor (name patterns)))
-  (name      :type symbol)
-  (patterns  :type pattern-list))
+     (:coNstructor Pattern-constructor (name patterns)))
+  (name      (required 'name) :type symbol       :read-only t)
+  (patterns  (required 'type) :type pattern-list :read-only t))
 
 #+sbcl
 (declaim (sb-ext:freeze-type pattern-constructor))

src/codegen/function-entry.lisp

@@ -2,10 +2,10 @@
 
 ;; We need to evaluate this early so the macro below can inline calls
 (eval-when (:load-toplevel)
-  (serapeum:defstruct-read-only function-entry
-    (arity :type fixnum)
-    (function :type function)
-    (curried :type function))
+  (defstruct function-entry
+    (arity    (required 'arity)    :type fixnum   :read-only t)
+    (function (required 'function) :type function :read-only t)
+    (curried  (required 'curried)  :type function :read-only t))
   #+sbcl
   (declaim (sb-ext:freeze-type function-entry)))
 

src/codegen/optimizer.lisp

@@ -1,9 +1,10 @@
 (in-package #:coalton-impl/codegen)
 
-(serapeum:defstruct-read-only (optimizer
-                               (:constructor optimizer (env toplevel-functions)))
-  (env :type environment)
-  (toplevel-functions :type list))
+(defstruct
+    (optimizer
+     (:constructor optimizer (env toplevel-functions)))
+  (env                (required 'env)                :type environment :read-only t)
+  (toplevel-functions (required 'toplevel-functions) :type list        :read-only t))
 
 (defun make-optimizer (env)
   (declare (type environment env)

src/codegen/utilities.lisp

@@ -1,8 +1,8 @@
 (in-package #:coalton-impl/codegen)
 
-(serapeum:defstruct-read-only struct-or-class-field
-  (name :type symbol)
-  (type :type t))
+(defstruct struct-or-class-field
+  (name (required 'name) :type symbol :read-only t)
+  (type (required 'type) :type t      :read-only t))
 
 #+sbcl
 (declaim (sb-ext:freeze-type struct-or-class-field))

src/library/vector.lisp

@@ -46,8 +46,8 @@
     "Return a new vector containing the same elements as V"
     (match v
       ((Vector v)
-        (lisp (Vector :a) (v)
-          (Vector (alexandria:copy-array v))))))
+       (lisp (Vector :a) (v)
+         (Vector (alexandria:copy-array v))))))
 
   (declare vector-push (:a -> (Vector :a) -> Integer))
   (define (vector-push item v)
@@ -272,10 +272,25 @@
   (define-instance (Into (Vector :a) (List :a))
     (define (into v)
       (let ((inner
-            (fn (v index)
-              (if (>= index (vector-length v))
-                  Nil
-                  (Cons (vector-index-unsafe index v) (inner v (+ 1 index)))))))
-      (inner v 0))))
+              (fn (v index)
+                (if (>= index (vector-length v))
+                    Nil
+                    (Cons (vector-index-unsafe index v) (inner v (+ 1 index)))))))
+        (inner v 0))))
 
-  (define-instance (Iso (Vector :a) (List :a))))
+  (define-instance (Iso (Vector :a) (List :a)))
+
+  (coalton-toplevel
+    (declare vector-to-list ((Vector :a) -> (List :a)))
+    (define (vector-to-list v)
+      (match v
+        ((Vector v)
+         (lisp (List :a) (v) 
+           (cl:coerce v 'cl:list)))))))
+
+
+(coalton-toplevel
+  (declare v (Vector Integer))
+  (define v (into (make-list 1 2 3 4 5)))
+
+  (define v2 (map (+ 2) v)))

src/package.lisp

@@ -104,8 +104,6 @@
   (:use #:cl
         #:coalton-impl/algorithm
         #:coalton-impl/ast)
-  (:import-from #:serapeum
-                #:true)
   (:export
    #:ty                                 ; STRUCT
    #:ty-scheme                          ; STRUCT

src/typechecker/context-reduction.lisp

@@ -4,6 +4,11 @@
 ;; Context reduction
 ;;
 
+(defun true (x)
+  (if x
+      t
+      nil))
+
 (defun by-super (env pred)
   "Recursively get all super classes of predicate