diff --git a/src/Data/Hashable.js b/src/Data/Hashable.js new file mode 100644 index 00000000..cb6ea7ae --- /dev/null +++ b/src/Data/Hashable.js @@ -0,0 +1,42 @@ +"use strict"; + +// Same as immutable.js, except for not dropping the highest bit. +exports.hashNumber = function (f) { + var o = f; + if (o !== o || o === Infinity) { + return 0; + } + var h = o | 0; + if (h !== o) { + h ^= o * 0xffffffff; + } + while (o > 0xffffffff) { + o /= 0xffffffff; + h ^= o; + } + return h; +}; + +// Same as Java. Improvements welcome. +exports.hashString = function (s) { + var h = 0; + for (var i = 0; i < s.length; i++) { + h = (31 * h + s.charCodeAt(i)) | 0; + } + return h; +}; + +// Almost the same as Java. Improvements welcome. +exports.hashArray = function (hash) { + return function (as) { + var h = as.length; + for (var i = 0; i < as.length; i++) { + h = (31 * h + hash(as[i])) | 0; + } + return h; + }; +}; + +exports.hashChar = function (c) { + return c.charCodeAt(0); +}; diff --git a/src/Data/Hashable.purs b/src/Data/Hashable.purs new file mode 100644 index 00000000..b47d01b8 --- /dev/null +++ b/src/Data/Hashable.purs @@ -0,0 +1,118 @@ +module Data.Hashable ( + class Hashable, + 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 (negate) +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 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` (hash a == hash 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 `hash` 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 + hash :: 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 + +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 + hash b = if b then Hash 1 else Hash 0 + +instance hashableInt :: Hashable Int where + hash n = Hash n + +foreign import hashNumber :: Number -> Hash Number + +instance hashableNumber :: Hashable Number where + hash = hashNumber + +foreign import hashChar :: Char -> Hash Char + +instance hashableChar :: Hashable Char where + hash = hashChar + +foreign import hashString :: String -> Hash String + +instance hashableString :: Hashable String where + hash = hashString + +foreign import hashArray :: forall a. (a -> Hash a) -> Array a -> Hash (Array a) + +instance hashableArray :: Hashable a => Hashable (Array a) where + hash = hashArray hash + +instance hashableUnit :: Hashable Unit where + hash _ = Hash 1 + +instance hashableVoid :: Hashable Void where + hash _ = Hash 0 + +instance hashableOrdering :: Hashable Ordering where + hash LT = Hash (-1) + hash GT = Hash 1 + hash EQ = Hash 0 + +class EqRecord l r <= HashableRecord l r | l -> r where + hashRecord :: RLProxy l -> Record r -> Hash (Record r) + +instance hashableRecordNil :: HashableRecord Nil r where + hashRecord _ _ = Hash 0 + +instance hashableRecordCons :: + ( Hashable vt + , HashableRecord tl r + , IsSymbol l + , Row.Cons l vt whatev r + ) => HashableRecord (Cons l vt tl) r where + hashRecord rlp record = + let (Hash rHash) = hashRecord (RLProxy :: RLProxy tl) record + field :: vt + field = unsafeGet (reflectSymbol (SProxy :: SProxy l)) record + (Hash fHash) = hash field + -- this mimics Java's hash function for arrays + in Hash (rHash * 31 + fHash) + +instance hashableRecord :: + (RowToList r l, HashableRecord l r, EqRecord l r) + => Hashable (Record r) where + hash = hashRecord (RLProxy :: RLProxy l) diff --git a/src/Prelude.purs b/src/Prelude.purs index 3a1cd439..01eda529 100644 --- a/src/Prelude.purs +++ b/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) import Data.HeytingAlgebra (class HeytingAlgebra, conj, disj, not, (&&), (||)) import Data.Monoid (class Monoid, mempty) import Data.NaturalTransformation (type (~>)) diff --git a/test/Test/Main.purs b/test/Test/Main.purs index 2a7a896b..aab1e76f 100644 --- a/test/Test/Main.purs +++ b/test/Test/Main.purs @@ -3,6 +3,7 @@ module Test.Main where import Prelude import Data.HeytingAlgebra (ff, tt, implies) import Data.Ord (abs) +import Data.Hashable (hash) type AlmostEff = Unit -> Unit @@ -120,6 +121,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 }