Back to symbol-hashtable

exceptions/src/Effect/Exception.ss

@@ -16,37 +16,40 @@
             make-message-condition
             condition?
             message-condition?)
+          (only (purs runtime pstring) pstring->string string->pstring)
           (only (rnrs io ports) call-with-string-output-port)
           (only (rnrs exceptions) with-exception-handler raise-continuable)
           (only (chezscheme) format call/cc display-condition))
 
   (define showErrorImpl
     (lambda (err)
-      (if (condition? err)
-        (call-with-string-output-port
-          (lambda (p) (display-condition err p)))
-        (format "Exception: ~s" err))))
+      (string->pstring
+        (if (condition? err)
+          (call-with-string-output-port
+            (lambda (p) (display-condition err p)))
+          (format "Exception: ~s" err)))))
 
   (define error
     (lambda (msg)
-      (make-message-condition msg)))
+      (make-message-condition (pstring->string msg))))
 
   (define errorWithCause
     (lambda (msg)
       (lambda (cause)
         (condition
-          (make-message-condition msg)
+          (make-message-condition (pstring->string msg))
           cause))))
 
   (define message
     (lambda (e)
-      (if (message-condition? e)
-        (condition-message e)
-        (format "Exception: ~s" e))))
+      (string->pstring
+        (if (message-condition? e)
+          (condition-message e)
+          (format "Exception: ~s" e)))))
 
   (define name
     (lambda (e)
-      "Exception"))
+      (string->pstring "Exception")))
 
   (define stackImpl
     (lambda (just)

foreign-object/src/Foreign/Object.ss

@@ -15,112 +15,145 @@
           fromHomogeneousImpl
           toArrayWithKey
           keys)
-  (import (only (rnrs base) define lambda if let let-values begin)
+  (import (only (rnrs base) define lambda if let let* let-values begin)
           (prefix (chezscheme) scm:)
+          (prefix (purs runtime) rt:)
           (prefix (purs runtime srfi :214) arrays:)
-          (only (purs runtime pstring) pstring->string string->pstring))
+          (only (purs runtime pstring) pstring->symbol string->pstring))
+
+  (define symbol->pstring
+    (lambda (s)
+      (string->pstring (scm:symbol->string s))))
 
   (define _copyST
     (lambda (m)
       (lambda ()
-        (scm:hashtable-copy m #t))))
+        (scm:cons
+          (scm:hashtable-copy (scm:car m) #t)
+          (scm:list-copy (scm:cdr m))))))
 
-  (define empty (scm:make-hashtable scm:string-hash scm:string=?))
+  (define empty
+    (scm:cons
+      (scm:make-hashtable scm:symbol-hash scm:symbol=? 32)
+      (scm:quote ())))
 
   (define runST
     (lambda (f)
       (f)))
 
   (define _fmapObject
     (lambda (m0 f)
-      (let ([m (scm:hashtable-copy m0 #t)])
-        (scm:hash-table-for-each
-          m0
-          (lambda (k v)
-            (scm:hashtable-set! m k (f v)))))))
+      (let ([m (scm:hashtable-copy (scm:car m0) #t)])
+        (let-values ([(ks1 vs1) (scm:hashtable-entries (scm:car m0))])
+          (let loop ([ks (scm:vector->list ks1)]
+                    [vs (scm:vector->list vs1)])
+            (if (scm:null? ks)
+                (scm:cons m (scm:list-copy (scm:cdr m0)))
+                (begin
+                  (scm:symbol-hashtable-set! m (scm:car ks) (f (scm:car vs)))
+                  (loop (scm:cdr ks) (scm:cdr vs)))))))))
 
   (define _mapWithKey
     (lambda (m0 f)
-      (let ([m (scm:hashtable-copy m0 #t)])
-        (scm:hash-table-for-each
-          m0
-          (lambda (k v)
-            (scm:hashtable-set! m k ((f (string->pstring k)) v)))))))
+      (let ([m (scm:hashtable-copy (scm:car m0) #t)])
+        (let-values ([(ks1 vs1) (scm:hashtable-entries (scm:car m0))])
+          (let loop ([ks (scm:vector->list ks1)]
+                    [vs (scm:vector->list vs1)])
+            (if (scm:null? ks)
+                (scm:cons m (scm:list-copy (scm:cdr m0)))
+                (begin
+                  (scm:symbol-hashtable-set! m (scm:car ks) ((f (symbol->pstring (scm:car ks))) (scm:car vs)))
+                  (loop (scm:cdr ks) (scm:cdr vs)))))))))
 
   (define _foldM
     (lambda (bind)
       (lambda (f)
         (lambda (mz)
-          (scm:trace-lambda foldMtrace (m)
-            (let-values ([(ks vs) (scm:hashtable-entries m)])
-              (let ([g (lambda (k)
-                        (lambda (z)
-                          (((f z) (string->pstring k)) (scm:hashtable-ref m k #f))))])
-                (let loop ([ks (scm:vector->list ks)]
-                          [vs (scm:vector->list vs)]
-                          [acc mz])
-                  (if (scm:null? ks)
-                      acc
-                      (loop (scm:cdr ks) (scm:cdr vs) ((bind acc) (g (scm:car ks)))))))))))))
-
-  (define _foldSCObject 7)
+          (lambda (m)
+            (let ([ks1 (scm:reverse (scm:cdr m))]
+                  [g (lambda (k)
+                      (lambda (z)
+                        (((f z) (symbol->pstring k)) (scm:symbol-hashtable-ref (scm:car m) k #f))))])
+              (let loop ([ks ks1]
+                        [acc mz])
+                (if (scm:null? ks)
+                  acc
+                  (loop (scm:cdr ks) ((bind acc) (g (scm:car ks))))))))))))
+
+  (define _foldSCObject
+    (lambda (m z f fromMaybe)
+      (let ([ks1 (scm:reverse (scm:cdr m))])
+        (let loop ([ks ks1]
+                  [acc z])
+          (if (scm:null? ks)
+            acc
+            (let* ([k (scm:car ks)]
+                  [v (scm:symbol-hashtable-ref (scm:car m) k #f)]
+                  [maybeR (((f acc) (symbol->pstring k)) v)]
+                  [r ((fromMaybe (scm:quote undefined)) maybeR)])
+              (if (scm:eq? r (scm:quote undefined))
+                acc
+                (loop (scm:cdr ks) r))))))))
 
   (define all
     (lambda (f)
-      (scm:trace-lambda alltrace (m)
-        (let-values ([(ks vs) (scm:hashtable-entries m)])
+      (lambda (m)
+        (let-values ([(ks vs) (scm:hashtable-entries (scm:car m))])
           (let loop ([ks (scm:vector->list ks)]
                     [vs (scm:vector->list vs)])
             (if (scm:null? ks)
                 #t
-                (if ((f (string->pstring (scm:car ks))) (scm:car vs))
+                (if ((f (symbol->pstring (scm:car ks))) (scm:car vs))
                     (loop (scm:cdr ks) (scm:cdr vs))
                     #f)))))))
 
   (define size
     (lambda (m)
-      (scm:hashtable-size m)))
+      (scm:hashtable-size (scm:car m))))
 
   (define _lookup
     (lambda (no yes k m)
-      (if (scm:hashtable-contains? m (pstring->string k))
-          (yes (scm:hashtable-ref m (pstring->string k) #f))
+      (if (scm:symbol-hashtable-contains? (scm:car m) (pstring->symbol k))
+          (yes (scm:symbol-hashtable-ref (scm:car m) (pstring->symbol k) #f))
           no)))
 
   (define _lookupST
     (lambda (no yes k m)
       (lambda ()
-        (if (scm:hashtable-contains? m (pstring->string k))
-            (yes (scm:hashtable-ref m (pstring->string k) #f))
+        (if (scm:symbol-hashtable-contains? (scm:car m) (pstring->symbol k))
+            (yes (scm:symbol-hashtable-ref (scm:car m) (pstring->symbol k) #f))
             no))))
 
   (define fromHomogeneousImpl
     (lambda (r)
-      (let loop ([r r] [acc (scm:make-hashtable scm:string-hash scm:string=?)])
+      (let loop ([r r]
+                [ht (scm:make-hashtable scm:symbol-hash scm:symbol=?)]
+                [ks (scm:quote ())])
         (if (scm:null? r)
-            acc
+            (scm:cons ht ks)
             (let ([k (scm:caar r)]
                   [v (scm:cdar r)])
-              (scm:hashtable-set! acc (scm:symbol->string k) v)
-              (loop (scm:cdr r) acc))))))
+              (scm:symbol-hashtable-set! ht k v)
+              (loop (scm:cdr r) ht (scm:cons k ks)))))))
 
   (define toArrayWithKey
-    (scm:trace-lambda toArrayWithKey1 (f)
-      (scm:trace-lambda toArrayWithKey2 (m)
-        (let-values ([(ks vs) (scm:hashtable-entries m)])
-          (let loop ([ks (scm:vector->list ks)]
-                    [vs (scm:vector->list vs)]
+    (lambda (f)
+      (lambda (m)
+        (let ([ks1 (scm:reverse (scm:cdr m))])
+          (let loop ([ks ks1]
+                    [vs (scm:map (lambda (k) (scm:symbol-hashtable-ref (scm:car m) k #f)) ks1)]
                     [i 0]
-                    [acc (arrays:make-flexvector (scm:hashtable-size m))])
+                    [acc (arrays:make-flexvector (scm:length ks1))])
             (if (scm:null? ks)
-                acc
-                (begin
-                  (arrays:flexvector-set! acc i ((f (string->pstring (scm:car ks))) (scm:car vs)))
-                  (loop (scm:cdr ks) (scm:cdr vs) (scm:+ i 1) acc))))))))
+              acc
+              (begin
+                (arrays:flexvector-set! acc i ((f (symbol->pstring (scm:car ks))) (scm:car vs)))
+                (loop (scm:cdr ks) (scm:cdr vs) (scm:+ i 1) acc))))))))
 
   (define keys
     (lambda (m)
-      (arrays:flexvector-map! (lambda (k) (string->pstring k))
-        (arrays:vector->flexvector
-          (scm:hashtable-keys m)))))
+      (arrays:list->flexvector
+        (scm:map
+          symbol->pstring
+          (scm:reverse (scm:cdr m))))))
 )

foreign-object/src/Foreign/Object/ST.ss

@@ -5,36 +5,52 @@
           peekImpl
           poke
           delete)
-  (import (only (rnrs base) define lambda if)
+  (import (only (rnrs base) define lambda if let)
           (prefix (chezscheme) scm:)
-          (only (purs runtime pstring) pstring->string))
+          (prefix (purs runtime) rt:)
+          (only (purs runtime pstring) pstring->symbol))
+
+  (define remove-1st
+    (lambda (x ls)
+      (if (scm:null? ls)                 ; If an empty list
+        (scm:quote ())                   ; Return an empty list
+        (if (scm:equal? x (scm:car ls))  ; Otherwise, if first item in list
+          (scm:cdr ls)                   ; Return rest of list, done
+          (scm:cons (scm:car ls) (remove-1st x (scm:cdr ls)))))))
+          ; Otherwise, cons first item and
+          ; rest of list with our item removed
+
 
   (define new
     (lambda ()
-      (scm:make-hashtable scm:string-hash scm:string=?)))
+      (scm:cons
+        (scm:make-hashtable scm:symbol-hash scm:symbol=? 32)
+        (scm:quote ()))))
 
   (define peekImpl
     (lambda (just)
       (lambda (nothing)
         (lambda (k)
           (lambda (m)
             (lambda ()
-              (if (scm:hashtable-contains? m (pstring->string k))
-                  (just (scm:hashtable-ref m (pstring->string k) #f))
+              (if (scm:symbol-hashtable-contains? (scm:car m) (pstring->symbol k))
+                  (just (scm:symbol-hashtable-ref (scm:car m) (pstring->symbol k) #f))
                   nothing)))))))
 
   (define poke
     (lambda (k)
       (lambda (v)
         (lambda (m)
           (lambda ()
-            (scm:hashtable-set! m (pstring->string k) v)
+            (scm:symbol-hashtable-set! (scm:car m) (pstring->symbol k) v)
+            (scm:set-cdr! m (scm:cons (pstring->symbol k) (scm:cdr m)))
             m)))))
 
   (define delete
     (lambda (k)
       (lambda (m)
         (lambda ()
-          (scm:hashtable-delete! m (pstring->string k))
+          (scm:symbol-hashtable-delete! (scm:car m) (pstring->symbol k))
+          (scm:set-cdr! m (remove-1st (pstring->symbol k) (scm:cdr m)))
           m))))
 )

foreign-object/src/Foreign/Object/Unsafe.ss

@@ -4,12 +4,12 @@
   (export unsafeIndex)
   (import (only (rnrs base) define lambda if)
           (prefix (chezscheme) scm:)
-          (only (purs runtime pstring) pstring->string))
+          (only (purs runtime pstring) pstring->symbol))
 
   (define unsafeIndex
     (lambda (m)
       (lambda (k)
-        (if (scm:hashtable-contains? m (pstring->string k))
-            (scm:hashtable-ref m (pstring->string k) #f)
+        (if (scm:symbol-hashtable-contains? (scm:car m) (pstring->symbol k))
+            (scm:symbol-hashtable-ref (scm:car m) (pstring->symbol k) #f)
             (scm:raise (scm:condition (scm:make-error) (scm:make-message-condition "unsafeIndex: key not found")))))))
 )

partial/src/Partial.ss

@@ -2,10 +2,11 @@
 
 (library (Partial foreign)
   (export _crashWith)
-  (import (only (rnrs base) define lambda error))
+  (import (only (rnrs base) define lambda error)
+          (only (purs runtime pstring) pstring->string))
 
   (define _crashWith
     (lambda (msg)
-      (error #f msg)))
+      (error #f (pstring->string msg))))
 
 )

prelude/src/Data/Show.ss

@@ -45,7 +45,7 @@
                                [(char=? c #\return) (pstring #\\ #\r)]
                                [(char=? c #\tab) (pstring #\\ #\t)]
                                [(char=? c #\vtab) (pstring #\\ #\v)]
-                               [else c])))])
+                               [else (pstring c)])))])
         (pstring-concat
           (pstring #\")
           (pstring-regex-replace-by regex s replacement)

quickcheck/src/Test/QuickCheck/Arbitrary.purs

@@ -17,7 +17,7 @@ import Control.Monad.Gen.Class (chooseBool)
 import Control.Monad.Gen.Common as MGC
 import Control.Monad.ST as ST
 import Data.Array ((:))
-import Data.Array.NonEmpty (NonEmptyArray)
+import Data.Array.NonEmpty (NonEmptyArray, cons')
 import Data.Array.NonEmpty as NEA
 import Data.Array.ST as STA
 import Data.Either (Either(..))
@@ -106,7 +106,8 @@ instance coarbNonEmptyString :: Coarbitrary NonEmptyString where
   coarbitrary = coarbitrary <<< NES.toString
 
 instance arbChar :: Arbitrary Char where
-  arbitrary = toEnumWithDefaults bottom top <$> chooseInt 0 65536
+  arbitrary = toEnumWithDefaults bottom top <$> oneOf
+    (cons' (chooseInt 0 55295) [ chooseInt 57344 65536 ])
 
 instance coarbChar :: Coarbitrary Char where
   coarbitrary c = coarbitrary $ fromEnum c