Hashable with hashWithSeed

src/Data/Hashable.js

@@ -0,0 +1,49 @@
+"use strict";
+
+// Inspired by immutable.js, except for not dropping the highest bit
+// and taking a seed.
+exports.hashNumber = function (s) {
+  return function (f) {
+    var o = f;
+    if (o !== o || o === Infinity) {
+      return s;
+    }
+    var h = o | 0;
+    if (h !== o) {
+      h ^= o * 0xffffffff;
+    }
+    while (o > 0xffffffff) {
+      o /= 0xffffffff;
+      h ^= o;
+    }
+      return (s+h)|0;
+  };
+};
+
+exports.hashString = function (seed) {
+  return function (s) {
+    var h = s;
+    for (var i = 0; i < s.length; i++) {
+      h = (31 * h + s.charCodeAt(i)) | 0;
+    }
+    return h;
+  };
+};
+
+exports.hashArray = function (hash) {
+  return function (s) {
+    return function (as) {
+      var h = s;
+      for (var i = 0; i < as.length; i++) {
+        h = (31 * h + hash(as[i])) | 0;
+      }
+      return h;
+    };
+  };
+};
+
+exports.hashChar = function (s) {
+  return function (c) {
+    return (s+c.charCodeAt(0))|0;
+  };
+};

src/Data/Hashable.purs

@@ -0,0 +1,123 @@
+module Data.Hashable (
+  class Hashable,
+  hashWithSalt,
+  hash,
+
+  class HashableRecord,
+  hashRecord,
+
+  Hash(Hash)
+) where
+
+import Data.Eq (class Eq, class EqRecord)
+import Data.Ord (class Ord)
+import Data.Ordering (Ordering(..))
+import Data.Ring ((-))
+import Data.Semigroup ((<>))
+import Data.Semiring ((*), (+))
+import Data.Show (class Show, show)
+import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
+import Data.Unit (Unit)
+import Data.Void (Void)
+import Prim.Row as Row
+import Prim.RowList (class RowToList, Cons, Nil, kind RowList)
+import Record.Unsafe (unsafeGet)
+import Type.Data.RowList (RLProxy(..))
+
+-- | The `Hashable` type class represents types with decidable
+-- | equality and a seeded hash function whose result can approximate
+-- | equality for use in hash-based algorithms and data structures.
+-- |
+-- | Instances of `Hashable` must satisfy the following law:
+-- |
+-- | ```PureScript
+-- | (a == b) `implies` (hashWithSalt s a == hashWithSalt s b)
+-- | ```
+-- |
+-- | That is, unequal hash values are a safe approximation of
+-- | inequality. In other words, two objects whose hash values differ,
+-- | are never equal. The reverse is not necessarily true.
+-- |
+-- | Hash values produced by `hashWithSalt` are not cryptographically
+-- | secure, must not be relied upon to be stable across multiple
+-- | executions of a program, and should not be stored externally.
+class Eq a <= Hashable a where
+  hashWithSalt :: Int -> a -> Hash a
+
+-- | The `Hash a` newtype wraps the hash code of a value of type `a`.
+-- |
+-- | Hash values should not be stored externally, as they must not be
+-- | relied upon to be stable across multiple executions of a program.
+newtype Hash a = Hash Int
+
+-- | A convenience function that calls `hashWithSalt` on its argument
+-- | with some seed. This seed is fixed for the runtime of a program,
+-- | but may change between runs. Do not store hashes externally.
+hash :: forall a. Hashable a => a -> Hash a
+hash = hashWithSalt 42
+
+instance showHash :: Show (Hash a) where
+  show (Hash n) = "(Hash " <> show n <> ")"
+derive newtype instance eqHash :: Eq (Hash a)
+derive newtype instance ordHash :: Ord (Hash a)
+
+instance hashableBoolean :: Hashable Boolean where
+  hashWithSalt s b = Hash (s + if b then 1 else 0)
+
+instance hashableInt :: Hashable Int where
+  hashWithSalt s n = Hash (s + n)
+
+foreign import hashNumber :: Int -> Number -> Hash Number
+
+instance hashableNumber :: Hashable Number where
+  hashWithSalt = hashNumber
+
+foreign import hashChar :: Int -> Char -> Hash Char
+
+instance hashableChar :: Hashable Char where
+  hashWithSalt = hashChar
+
+foreign import hashString :: Int -> String -> Hash String
+
+instance hashableString :: Hashable String where
+  hashWithSalt = hashString
+
+foreign import hashArray :: forall a. (a -> Hash a) -> Int -> Array a -> Hash (Array a)
+
+instance hashableArray :: Hashable a => Hashable (Array a) where
+  hashWithSalt = hashArray hash
+
+instance hashableUnit :: Hashable Unit where
+  hashWithSalt s _ = Hash (s + 1)
+
+instance hashableVoid :: Hashable Void where
+  hashWithSalt s _ = Hash s
+
+instance hashableOrdering :: Hashable Ordering where
+  hashWithSalt s LT = Hash (s - 1)
+  hashWithSalt s GT = Hash (s + 1)
+  hashWithSalt s EQ = Hash (s + 0)
+
+class EqRecord l r <= HashableRecord l r | l -> r where
+  hashRecord :: Int -> RLProxy l -> Record r -> Hash (Record r)
+
+instance hashableRecordNil :: HashableRecord Nil r where
+  hashRecord s _ _ = Hash s
+
+instance hashableRecordCons ::
+  ( Hashable vt
+  , HashableRecord tl r
+  , IsSymbol l
+  , Row.Cons l vt whatev r
+  ) => HashableRecord (Cons l vt tl) r where
+  hashRecord s rlp record =
+    let (Hash rHash) = hashRecord s (RLProxy :: RLProxy tl) record
+        field :: vt
+        field = unsafeGet (reflectSymbol (SProxy :: SProxy l)) record
+        (Hash fHash) = hashWithSalt s field
+    in Hash (rHash * 31 + fHash)
+
+instance hashableRecord ::
+  (RowToList r l, HashableRecord l r, EqRecord l r)
+  => Hashable (Record r) where
+  hashWithSalt s = hashRecord s (RLProxy :: RLProxy l)

src/Prelude.purs

@@ -15,6 +15,7 @@ module Prelude
   , module Data.Field
   , module Data.Function
   , module Data.Functor
+  , module Data.Hashable
   , module Data.HeytingAlgebra
   , module Data.Monoid
   , module Data.NaturalTransformation
@@ -45,6 +46,7 @@ import Data.EuclideanRing (class EuclideanRing, degree, div, mod, (/), gcd, lcm)
 import Data.Field (class Field)
 import Data.Function (const, flip, ($), (#))
 import Data.Functor (class Functor, flap, map, void, ($>), (<#>), (<$), (<$>), (<@>))
+import Data.Hashable (class Hashable, Hash(..), hash, hashWithSalt)
 import Data.HeytingAlgebra (class HeytingAlgebra, conj, disj, not, (&&), (||))
 import Data.Monoid (class Monoid, mempty)
 import Data.NaturalTransformation (type (~>))

test/Test/Main.purs

@@ -120,6 +120,7 @@ testIntDegree = do
 testRecordInstances :: AlmostEff
 testRecordInstances = do
   assert "Record equality" $ { a: 1 } == { a: 1 }
+  assert "Record hash" $ hash { a: 1 } == hash { a: 1 }
   assert "Record inequality" $ { a: 2 } /= { a: 1 }
   assert "Record show" $ show { a: 1 } == "{ a: 1 }"
   assert "Record +" $ ({ a: 1, b: 2.0 } + { a: 0, b: (-2.0) }) == { a: 1, b: 0.0 }