From 0e53a1d535dfcb2078e2d94773271a497b8e3fd0 Mon Sep 17 00:00:00 2001 From: David Feuer Date: Mon, 20 Dec 2021 21:40:47 -0500 Subject: [PATCH 1/3] Add Lift instances Closes #342 --- Data/HashMap/Internal.hs | 13 +++++++++---- Data/HashMap/Internal/Array.hs | 25 +++++++++++++++++++++++++ Data/HashSet/Internal.hs | 3 +++ unordered-containers.cabal | 3 ++- 4 files changed, 39 insertions(+), 5 deletions(-) diff --git a/Data/HashMap/Internal.hs b/Data/HashMap/Internal.hs index c65c368e..9b82ea2f 100644 --- a/Data/HashMap/Internal.hs +++ b/Data/HashMap/Internal.hs @@ -1,10 +1,13 @@ -{-# LANGUAGE BangPatterns, CPP, MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE LambdaCase #-} #if __GLASGOW_HASKELL__ >= 802 {-# LANGUAGE TypeInType #-} {-# LANGUAGE UnboxedSums #-} @@ -179,6 +182,7 @@ import GHC.Exts (TYPE, Int (..), Int#) import Data.Functor.Identity (Identity (..)) import Control.Applicative (Const (..)) import Data.Coerce (coerce) +import qualified Language.Haskell.TH.Syntax as TH -- | A set of values. A set cannot contain duplicate values. ------------------------------------------------------------------------ @@ -188,7 +192,7 @@ hash :: H.Hashable a => a -> Hash hash = fromIntegral . H.hash data Leaf k v = L !k v - deriving (Eq) + deriving (Eq, TH.Lift) instance (NFData k, NFData v) => NFData (Leaf k v) where rnf (L k v) = rnf k `seq` rnf v @@ -214,6 +218,7 @@ data HashMap k v | Leaf !Hash !(Leaf k v) | Full !(A.Array (HashMap k v)) | Collision !Hash !(A.Array (Leaf k v)) + deriving (TH.Lift) type role HashMap nominal representational diff --git a/Data/HashMap/Internal/Array.hs b/Data/HashMap/Internal/Array.hs index 0ed6b088..4ddffb11 100644 --- a/Data/HashMap/Internal/Array.hs +++ b/Data/HashMap/Internal/Array.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns, CPP, MagicHash, Rank2Types, UnboxedTuples, ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskellQuotes #-} {-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-} {-# OPTIONS_HADDOCK not-home #-} @@ -69,6 +70,7 @@ module Data.HashMap.Internal.Array , traverse' , toList , fromList + , fromList' ) where import Control.Applicative (liftA2) @@ -84,6 +86,8 @@ import GHC.Exts (SmallArray#, newSmallArray#, readSmallArray#, writeSmallArray#, SmallMutableArray#, sizeofSmallArray#, copySmallArray#, thawSmallArray#, sizeofSmallMutableArray#, copySmallMutableArray#, cloneSmallMutableArray#) +import qualified Language.Haskell.TH.Syntax as TH + #if defined(ASSERTS) import qualified Prelude #endif @@ -474,6 +478,27 @@ fromList n xs0 = go (x:xs) mary i = do write mary i x go xs mary (i+1) +fromList' :: Int -> [a] -> Array a +fromList' n xs0 = + CHECK_EQ("fromList'", n, Prelude.length xs0) + run $ do + mary <- new_ n + go xs0 mary 0 + where + go [] !mary !_ = return mary + go (!x:xs) mary i = do write mary i x + go xs mary (i+1) + +instance TH.Lift a => TH.Lift (Array a) where +#if MIN_VERSION_template_haskell(2,16,0) + liftTyped ar = [|| fromList' arlen arlist ||] +#else + lift ar = [| fromList' arlen arlist |] +#endif + where + arlen = length ar + arlist = toList ar + toList :: Array a -> [a] toList = foldr (:) [] diff --git a/Data/HashSet/Internal.hs b/Data/HashSet/Internal.hs index 0d349a81..5b54944c 100644 --- a/Data/HashSet/Internal.hs +++ b/Data/HashSet/Internal.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveLift #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Trustworthy #-} @@ -113,11 +114,13 @@ import qualified Data.Hashable.Lifted as H #if MIN_VERSION_deepseq(1,4,3) import qualified Control.DeepSeq as NF #endif +import qualified Language.Haskell.TH.Syntax as TH -- | A set of values. A set cannot contain duplicate values. newtype HashSet a = HashSet { asMap :: HashMap a () } + } deriving (TH.Lift) type role HashSet nominal diff --git a/unordered-containers.cabal b/unordered-containers.cabal index 8bff7c96..776da726 100644 --- a/unordered-containers.cabal +++ b/unordered-containers.cabal @@ -56,7 +56,8 @@ library build-depends: base >= 4.9 && < 5, deepseq >= 1.1, - hashable >= 1.0.1.1 && < 1.5 + hashable >= 1.0.1.1 && < 1.5, + template-haskell default-language: Haskell2010 From e4a8963bfb5a135a8610dc948457b653be4f6ed5 Mon Sep 17 00:00:00 2001 From: David Feuer Date: Tue, 21 Dec 2021 09:11:20 -0500 Subject: [PATCH 2/3] Update unordered-containers.cabal Co-authored-by: Simon Jakobi --- unordered-containers.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unordered-containers.cabal b/unordered-containers.cabal index 776da726..85d102e0 100644 --- a/unordered-containers.cabal +++ b/unordered-containers.cabal @@ -57,7 +57,7 @@ library base >= 4.9 && < 5, deepseq >= 1.1, hashable >= 1.0.1.1 && < 1.5, - template-haskell + template-haskell < 2.19 default-language: Haskell2010 From 8d9679b5e0e987d19b47da5431db7e8f78c9f033 Mon Sep 17 00:00:00 2001 From: David Feuer Date: Wed, 22 Dec 2021 16:11:13 -0500 Subject: [PATCH 3/3] Build values eagerly on lift --- CHANGES.md | 2 ++ Data/HashMap/Internal.hs | 16 ++++++++++++++-- Data/HashSet/Internal.hs | 5 ++++- 3 files changed, 20 insertions(+), 3 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 32375997..8635179c 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -2,6 +2,8 @@ * Define `dataCast1` for `HashMap`. +* [Add `Lift` instances for Template Haskell](https://github.com/haskell-unordered-containers/unordered-containers/pull/343) + ## [0.2.16.0] * [Increase maximum branching factor from 16 to 32](https://github.com/haskell-unordered-containers/unordered-containers/pull/317) diff --git a/Data/HashMap/Internal.hs b/Data/HashMap/Internal.hs index 9b82ea2f..9af96dd1 100644 --- a/Data/HashMap/Internal.hs +++ b/Data/HashMap/Internal.hs @@ -6,6 +6,8 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UnboxedTuples #-} #if __GLASGOW_HASKELL__ >= 802 @@ -192,11 +194,19 @@ hash :: H.Hashable a => a -> Hash hash = fromIntegral . H.hash data Leaf k v = L !k v - deriving (Eq, TH.Lift) + deriving (Eq) instance (NFData k, NFData v) => NFData (Leaf k v) where rnf (L k v) = rnf k `seq` rnf v +-- | @since 0.2.17.0 +instance (TH.Lift k, TH.Lift v) => TH.Lift (Leaf k v) where +#if MIN_VERSION_template_haskell(2,16,0) + liftTyped (L k v) = [|| L k $! v ||] +#else + lift (L k v) = [| L k $! v |] +#endif + #if MIN_VERSION_deepseq(1,4,3) -- | @since 0.2.14.0 instance NFData k => NF.NFData1 (Leaf k) where @@ -218,10 +228,12 @@ data HashMap k v | Leaf !Hash !(Leaf k v) | Full !(A.Array (HashMap k v)) | Collision !Hash !(A.Array (Leaf k v)) - deriving (TH.Lift) type role HashMap nominal representational +-- | @since 0.2.17.0 +deriving instance (TH.Lift k, TH.Lift v) => TH.Lift (HashMap k v) + instance (NFData k, NFData v) => NFData (HashMap k v) where rnf Empty = () rnf (BitmapIndexed _ ary) = rnf ary diff --git a/Data/HashSet/Internal.hs b/Data/HashSet/Internal.hs index 5b54944c..1071fc7e 100644 --- a/Data/HashSet/Internal.hs +++ b/Data/HashSet/Internal.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Trustworthy #-} {-# OPTIONS_HADDOCK not-home #-} @@ -120,10 +121,12 @@ import qualified Language.Haskell.TH.Syntax as TH newtype HashSet a = HashSet { asMap :: HashMap a () } - } deriving (TH.Lift) type role HashSet nominal +-- | @since 0.2.17.0 +deriving instance TH.Lift a => TH.Lift (HashSet a) + instance (NFData a) => NFData (HashSet a) where rnf = rnf . asMap {-# INLINE rnf #-}