Add Lift instances (#343)

Add Lift instances

Author: treeowl

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)

Data/HashMap/Internal.hs

@@ -1,10 +1,15 @@
-{-# LANGUAGE BangPatterns, CPP, MagicHash #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveLift #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MagicHash #-}
 {-# LANGUAGE PatternGuards #-}
 {-# LANGUAGE RoleAnnotations #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UnboxedTuples #-}
-{-# LANGUAGE LambdaCase #-}
 #if __GLASGOW_HASKELL__ >= 802
 {-# LANGUAGE TypeInType #-}
 {-# LANGUAGE UnboxedSums #-}
@@ -179,6 +184,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.
 ------------------------------------------------------------------------
@@ -193,6 +199,14 @@ data Leaf k v = L !k v
 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
@@ -217,6 +231,9 @@ data HashMap k v
 
 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

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 (:) []
 

Data/HashSet/Internal.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveLift #-}
 {-# LANGUAGE RoleAnnotations #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE Trustworthy #-}
 {-# OPTIONS_HADDOCK not-home #-}
@@ -113,6 +115,7 @@ 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 {
@@ -121,6 +124,9 @@ newtype HashSet a = HashSet {
 
 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 #-}

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 < 2.19
 
   default-language: Haskell2010