Issue justinethier#206 - Support hash-table-ref default values

Author: justinethier

ChangeLog.markdown

@@ -1,6 +1,11 @@
 v3.19.2
 --------
 
+New Features:
+
+- Allow a `default` thunk to be passed to `hash-table-ref`.
+- Added `hash-table-ref/default`.
+
 Bug Fixes:
 
 - Fixed `rational?` to properly handle floating-point numbers.

hs-src/Language/Scheme/Core.hs

@@ -43,6 +43,7 @@ module Language.Scheme.Core
     , updateList
     , updateVector
     , updateByteVector
+    , hashTblRef
     -- * Error handling
     , addToCallHistory
     , throwErrorWithCallHistory
@@ -1075,7 +1076,7 @@ nullEnvWithImport :: IO Env
 nullEnvWithImport = nullEnv >>= 
   (flip extendEnv [
     ((varNamespace, "%import"), EvalFunc evalfuncImport),
-    ((varNamespace, "hash-table-ref"), IOFunc $ wrapHashTbl hashTblRef)])
+    ((varNamespace, "hash-table-ref"), EvalFunc hashTblRef)])
 
 -- |Load the standard r5rs environment, including libraries
 r5rsEnv :: IO Env
@@ -1426,6 +1427,7 @@ evalFunctions =  [  ("apply", evalfuncApply)
                   , ("current-environment", evalfuncInteractionEnv)
                   , ("interaction-environment", evalfuncInteractionEnv)
                   , ("make-environment", evalfuncMakeEnv)
+                  , ("hash-table-ref", hashTblRef)
 
                -- Non-standard extensions
 #ifdef UseFfi
@@ -1452,3 +1454,36 @@ addToCallHistory :: LispVal -> [LispVal] -> [LispVal]
 addToCallHistory f history 
   | null history = [f]
   | otherwise = (lastN' 9 history) ++ [f]
+
+-- | Retrieve the value from the hashtable for the given key.
+--   An error is thrown if the key is not found.
+--
+--   Note this had to be made an EvalFunc because a thunk
+--   can be passed as an optional argument to be executed 
+--   if the key is not found.
+--
+--   Arguments:
+--
+--   * Current continuation
+--   * HashTable to copy
+--   * Object that is the key to query the table for
+--
+--   Returns: Object containing the key's value
+--
+hashTblRef :: [LispVal] -> IOThrowsError LispVal
+hashTblRef [_, (HashTable ht), key] = do
+  case Data.Map.lookup key ht of
+    Just val -> return val
+    Nothing -> throwError $ BadSpecialForm "Hash table does not contain key" key
+hashTblRef [cont, (HashTable ht), key, thunk] = do
+  case Data.Map.lookup key ht of
+    Just val -> return $ val
+    Nothing -> apply cont thunk []
+{- FUTURE: a thunk can optionally be specified, this drives definition of /default
+Nothing -> apply thunk [] -}
+hashTblRef (cont : p@(Pointer _ _) : args) = do
+  ht <- derefPtr p
+  hashTblRef (cont : ht : args)
+hashTblRef [_, badType] = throwError $ TypeMismatch "hash-table" badType
+hashTblRef badArgList = throwError $ NumArgs (Just 2) (tail badArgList)
+

hs-src/Language/Scheme/Environments.hs

@@ -132,7 +132,6 @@ ioPrimitives = [("open-input-file", makePort openFile ReadMode ),
 
               ("hash-table?",       wrapHashTbl isHashTbl),
               ("hash-table-exists?",wrapHashTbl hashTblExists),
-              ("hash-table-ref",    wrapHashTbl hashTblRef),
               ("hash-table-size",   wrapHashTbl hashTblSize),
               ("hash-table->alist", wrapHashTbl hashTbl2List),
               ("hash-table-keys",   wrapHashTbl hashTblKeys),

hs-src/Language/Scheme/Primitives.hs

@@ -44,7 +44,6 @@ module Language.Scheme.Primitives (
  , byteVectorStr2Utf
  -- ** Hash Table
  , hashTblExists 
- , hashTblRef
  , hashTblSize 
  , hashTbl2List
  , hashTblKeys
@@ -1217,31 +1216,6 @@ hashTblExists [(HashTable ht), key] = do
 hashTblExists [] = throwError $ NumArgs (Just 2) []
 hashTblExists args@(_ : _) = throwError $ NumArgs (Just 2) args
 
--- | Retrieve the value from the hashtable for the given key.
---   An error is thrown if the key is not found.
---
---   Arguments:
---
---   * HashTable to copy
---
---   * Object that is the key to query the table for
---
---   Returns: Object containing the key's value
---
-hashTblRef :: [LispVal] -> ThrowsError LispVal
-hashTblRef [(HashTable ht), key] = do
-  case Data.Map.lookup key ht of
-    Just val -> return val
-    Nothing -> throwError $ BadSpecialForm "Hash table does not contain key" key
-hashTblRef [(HashTable ht), key, Func {}] = do
-  case Data.Map.lookup key ht of
-    Just val -> return $ val
-    Nothing -> throwError $ NotImplemented "thunk"
-{- FUTURE: a thunk can optionally be specified, this drives definition of /default
-Nothing -> apply thunk [] -}
-hashTblRef [badType] = throwError $ TypeMismatch "hash-table" badType
-hashTblRef badArgList = throwError $ NumArgs (Just 2) badArgList
-
 -- | Return the number of key/value associations in the hashtable
 --
 --   Arguments:

lib/core.scm

@@ -404,6 +404,9 @@
     (exit-fail))
 
 ;; Hashtable derived forms
+(define (hash-table-ref/default ht key default)
+  (hash-table-ref ht key (lambda () default)))
+
 (define hash-table-walk
   (lambda (ht proc)
     (map 

lib/srfi/69.sld

@@ -6,7 +6,7 @@
         ;hash-table-equivalence-function 
         ;hash-table-hash-function
         hash-table-ref 
-        ;hash-table-ref/default 
+        hash-table-ref/default 
         ;hash-table-set! 
         ;TODO: should implement this: hash-table-delete! 
         hash-table-exists? 

tests/t-hashtable.scm

@@ -56,6 +56,9 @@
 (hash-table-merge! ht test-ht2)
 (assert/equal (hash-table-ref ht "test") "testing")
 
+;; Test default values
+(assert/equal (hash-table-ref/default (make-hash-table) 2 #f) #f)
+
 (define ht (make-hash-table))
 (hash-table-set! ht 1 1)
 (hash-table-set! ht 2 2)