diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,14 @@ +# Changelog for hashable-accelerate + +Notable changes to the project will be documented in this file. + +The format is based on [Keep a Changelog](http://keepachangelog.com/) and the +project adheres to the [Haskell Package Versioning +Policy (PVP)](https://pvp.haskell.org) + +## [0.1.0.0] - 2020-08-28 +### New + * Initial version + +[0.1.0.0]: https://github.com/tmcdonell/hashable-accelerate/compare/0b4e0893af766722836333776b9415e8e6e7941a...v0.1.0.0 + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Trevor L. McDonell (c) 2020 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Trevor L. McDonell nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,25 @@ +
+henlo, my name is Theia + +# hashable-accelerate + +[![GitHub CI](https://github.com/tmcdonell/hashable-accelerate/workflows/CI/badge.svg)](https://github.com/tmcdonell/hashable-accelerate/actions) +[![Gitter](https://img.shields.io/gitter/room/nwjs/nw.js.svg)](https://gitter.im/AccelerateHS/Lobby) +
+[![Stackage LTS](https://stackage.org/package/hashable-accelerate/badge/lts)](https://stackage.org/lts/package/hashable-accelerate) +[![Stackage Nightly](https://stackage.org/package/hashable-accelerate/badge/nightly)](https://stackage.org/nightly/package/hashable-accelerate) +[![Hackage](https://img.shields.io/hackage/v/hashable-accelerate.svg)](https://hackage.haskell.org/package/hashable-accelerate) + +
+ +A class for types which can be converted to a hash value. Based on the +[hashable][hashable] library. For details on Accelerate see the [main +repository][accelerate]. + +Contributions and bug reports are welcome!
+Please feel free to contact me through [GitHub][accelerate] or [gitter.im][gitter.im]. + + [hashable]: http://hackage.haskell.org/package/hashable + [accelerate]: https://github.com/AccelerateHS/accelerate + [gitter.im]: https://gitter.im/AccelerateHS/Lobby + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hashable-accelerate.cabal b/hashable-accelerate.cabal new file mode 100644 --- /dev/null +++ b/hashable-accelerate.cabal @@ -0,0 +1,40 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 311ae20bdafe08bcf8608d32bb057d5525fb0e6d722f5426b94607f4142641cb + +name: hashable-accelerate +version: 0.1.0.0 +synopsis: A class for types which can be converted into a hash value +description: Please see the README on GitHub at +category: Accelerate, Data +homepage: https://github.com/tmcdonell/hashable-accelerate#readme +bug-reports: https://github.com/tmcdonell/hashable-accelerate/issues +author: Trevor L. McDonell +maintainer: Trevor L. McDonell +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/tmcdonell/hashable-accelerate + +library + exposed-modules: + Data.Array.Accelerate.Data.Hashable + other-modules: + Paths_hashable_accelerate + hs-source-dirs: + src + build-depends: + accelerate >=1.3 + , base >=4.7 && <5 + , template-haskell + default-language: Haskell2010 diff --git a/src/Data/Array/Accelerate/Data/Hashable.hs b/src/Data/Array/Accelerate/Data/Hashable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/Data/Hashable.hs @@ -0,0 +1,255 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Data.Array.Accelerate.Data.Hashable +-- Copyright : [2020] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- This module defines a class 'Hashable', for types that can be converted +-- to a hash value. +-- + +module Data.Array.Accelerate.Data.Hashable ( + + Hashable(..), + hashUsing, defaultHashWithSalt, + +) where + +import Data.Array.Accelerate +import Data.Array.Accelerate.Data.Bits +import Data.Array.Accelerate.Data.Complex +import Data.Array.Accelerate.Data.Either +import Data.Array.Accelerate.Data.Maybe +import Data.Array.Accelerate.Data.Monoid +import Data.Array.Accelerate.Data.Ratio +import Data.Array.Accelerate.Data.Semigroup + +import Prelude ( (<$>), id, concat ) +import Control.Monad ( mapM ) +import Language.Haskell.TH hiding ( Exp, match ) +import qualified Prelude as P +import qualified Data.Bits as P +import qualified Data.List as P + +#include "MachDeps.h" + +infixl 0 `hashWithSalt` + +-- | The class of types that can be converted to a hash value. +-- +class Elt a => Hashable a where + -- | Return a hash value for the argument, using the given salt. + -- + -- The general contract of 'hashWithSalt' is: + -- + -- * If two values are equal according to the '==' method, then + -- applying the 'hashWithSalt' method on each of the two values + -- /must/ produce the same integer result if the same salt is + -- used in each case. + -- + -- * It is /not/ required that if two values are unequal + -- according to the '==' method, then applying the + -- 'hashWithSalt' method on each of the two values must produce + -- distinct integer results. However, the programmer should be + -- aware that producing distinct integer results for unequal + -- values may improve the performance of hashing-based data + -- structures. + -- + -- * This method can be used to compute different hash values for + -- the same input by providing a different salt in each + -- application of the method. This implies that any instance + -- that defines 'hashWithSalt' /must/ make use of the salt in + -- its implementation. + -- + hashWithSalt :: Exp Int -> Exp a -> Exp Int + + -- | Like 'hashWithSalt', but no salt is used. The default + -- implementation uses 'hashWithSalt' with some default salt. + -- Instances might want to implement this method to provide a more + -- efficient implementation than the default implementation. + -- + hash :: Exp a -> Exp Int + hash = hashWithSalt defaultSalt + +-- | Transform a value into a 'Hashable' value, then hash the transformed +-- value using the given salt. +-- +-- This is a useful shorthand in cases where a type can easily be mapped to +-- another type that is already an instance of 'Hashable'. +-- +hashUsing + :: Hashable b + => (Exp a -> Exp b) -- ^ transformation function + -> Exp Int -- ^ salt + -> Exp a -- ^ value to transform + -> Exp Int +hashUsing f salt x = hashWithSalt salt (f x) + +-- | A default salt used in the implementation of 'hash'. +-- +defaultSalt :: Exp Int +#if WORD_SIZE_IN_BITS == 64 +defaultSalt = -2578643520546668380 -- 0xdc36d1615b7400a4 +#else +defaultSalt = 0x087fc72c +#endif + +defaultHashWithSalt :: Hashable a => Exp Int -> Exp a -> Exp Int +defaultHashWithSalt salt x = salt `combine` hash x + +-- | Combine two given hash values. 'combine' has zero as a left identity. +-- +combine :: Exp Int -> Exp Int -> Exp Int +combine h1 h2 = (h1 * 16777619) `xor` h2 + +instance Hashable Int where + hash = id + hashWithSalt = defaultHashWithSalt + +instance Hashable Int8 where + hash = fromIntegral + hashWithSalt = defaultHashWithSalt + +instance Hashable Int16 where + hash = fromIntegral + hashWithSalt = defaultHashWithSalt + +instance Hashable Int32 where + hash = fromIntegral + hashWithSalt = defaultHashWithSalt + +instance Hashable Int64 where + hash x + | P.finiteBitSize (undefined :: Int) P.== 64 = fromIntegral x + | otherwise = fromIntegral (fromIntegral x `xor` + (fromIntegral x `shiftR` 32 :: Exp Word64)) + hashWithSalt = defaultHashWithSalt + +instance Hashable Word where + hash = fromIntegral + hashWithSalt = defaultHashWithSalt + +instance Hashable Word8 where + hash = fromIntegral + hashWithSalt = defaultHashWithSalt + +instance Hashable Word16 where + hash = fromIntegral + hashWithSalt = defaultHashWithSalt + +instance Hashable Word32 where + hash = fromIntegral + hashWithSalt = defaultHashWithSalt + +instance Hashable Word64 where + hash x + | P.finiteBitSize (undefined :: Int) P.== 64 = fromIntegral x + | otherwise = fromIntegral (x `xor` (x `shiftR` 32)) + hashWithSalt = defaultHashWithSalt + +instance Hashable () where + hash _ = constant (P.fromEnum ()) + hashWithSalt = defaultHashWithSalt + +instance Hashable Bool where + hash = boolToInt + hashWithSalt = defaultHashWithSalt + +instance Hashable Char where + hash = ord + hashWithSalt = defaultHashWithSalt + +instance Hashable Half where + hash x = + if x == 0.0 || x == -0.0 + then 0 + else hash (bitcast x :: Exp Word16) + hashWithSalt = defaultHashWithSalt + +instance Hashable Float where + hash x = + if x == 0.0 || x == -0.0 + then 0 + else hash (bitcast x :: Exp Word32) + hashWithSalt = defaultHashWithSalt + +instance Hashable Double where + hash x = + if x == 0.0 || x == -0.0 + then 0 + else hash (bitcast x :: Exp Word64) + hashWithSalt = defaultHashWithSalt + +instance Hashable a => Hashable (Complex a) where + hash (r ::+ i) = hash r `hashWithSalt` i + hashWithSalt s (r ::+ i) = s `hashWithSalt` r `hashWithSalt` i + +instance Hashable a => Hashable (Ratio a) where + hash a = hash (numerator a) `hashWithSalt` denominator a + hashWithSalt s a = s `hashWithSalt` numerator a `hashWithSalt` denominator a + +-- | A value with bit pattern (01)* (or 5* in hexa), for any size of Int. +-- It is used as data constructor distinguisher. +-- +distinguisher :: Exp Int +distinguisher = fromIntegral $ (maxBound :: Exp Word) `quot` 3 + +instance Hashable a => Hashable (Maybe a) where + hash = match \case + Nothing_ -> 0 + Just_ x -> distinguisher `hashWithSalt` x + hashWithSalt = defaultHashWithSalt + +instance (Hashable a, Hashable b) => Hashable (Either a b) where + hash = match \case + Left_ x -> 0 `hashWithSalt` x + Right_ x -> distinguisher `hashWithSalt` x + hashWithSalt = defaultHashWithSalt + +instance Hashable a => Hashable (Min a) where + hashWithSalt s (Min_ a) = hashWithSalt s a + +instance Hashable a => Hashable (Max a) where + hashWithSalt s (Max_ a) = hashWithSalt s a + +instance Hashable a => Hashable (Sum a) where + hashWithSalt s (Sum_ a) = hashWithSalt s a + +instance Hashable a => Hashable (Product a) where + hashWithSalt s (Product_ a) = hashWithSalt s a + +$(runQ $ + let + tupT :: [TypeQ] -> TypeQ + tupT tup = + let n = P.length tup + in P.foldl' (\ts t -> [t| $ts $t |]) (tupleT n) tup + + mkTup :: Int -> Q [Dec] + mkTup n = + let + xs = [ mkName ('x':P.show i) | i <- [0 .. n-1] ] + ctx = tupT (P.map (\x -> [t| Hashable $(varT x) |]) xs) + res = tupT (P.map varT xs) + pat = conP (mkName ('T':P.show n)) (P.map varP xs) + in + [d| instance $ctx => Hashable $res where + hash $pat = $(P.foldl' (\vs v -> [| $vs `hashWithSalt` $v |]) [| hash $(varE (P.head xs))|] (P.map varE (P.tail xs))) + hashWithSalt = defaultHashWithSalt + |] + + in + concat <$> mapM mkTup [2..16] + ) +