Add Lift instances for Data.Sequence

Add `Lift` instances for `Seq`, `ViewL`, and `ViewR`. The `Seq` instance
tries to be a bit clever about the shape of the resulting tree and the
size of the splice; everything else is straightforward.

Author: treeowl

containers-tests/containers-tests.cabal

@@ -37,6 +37,7 @@ common deps
       array    >=0.4.0.0
     , base     >=4.9.1   && <5
     , deepseq  >=1.2     && <1.5
+    , template-haskell
 
 common test-deps
   import: deps

containers-tests/tests/seq-properties.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 #include "containers.h"
 
@@ -41,11 +42,17 @@ import Test.QuickCheck.Poly (A, OrdA, B, OrdB, C)
 import Control.Monad.Zip (MonadZip (..))
 import Control.DeepSeq (deepseq)
 import Control.Monad.Fix (MonadFix (..))
+import Test.Tasty.HUnit
+import qualified Language.Haskell.TH.Syntax as TH
 
 
 main :: IO ()
 main = defaultMain $ testGroup "seq-properties"
-       [ testProperty "fmap" prop_fmap
+       [ test_lift
+#if MIN_VERSION_template_haskell(2,16,0)
+       , test_liftTyped
+#endif
+       , testProperty "fmap" prop_fmap
        , testProperty "(<$)" prop_constmap
        , testProperty "foldr" prop_foldr
        , testProperty "foldr'" prop_foldr'
@@ -911,11 +918,28 @@ instance Applicative M where
     Action m f <*> Action n x = Action (m+n) (f x)
 
 instance Monad M where
-    return x = Action 0 x
     Action m x >>= f = let Action n y = f x in Action (m+n) y
 
 instance Foldable M where
     foldMap f (Action _ x) = f x
 
 instance Traversable M where
     traverse f (Action n x) = Action n <$> f x
+
+-- ----------
+--
+-- Unit tests
+--
+-- ----------
+
+test_lift :: TestTree
+test_lift = testCase "lift" $ do
+  (mempty :: Seq Int) @=? $([| $(TH.lift (fromList [] :: Seq Integer)) |])
+  fromList [1..3 :: Int] @=? $([| $(TH.lift (fromList [1..3 :: Integer])) |])
+
+#if MIN_VERSION_template_haskell(2,16,0)
+test_liftTyped :: TestTree
+test_liftTyped = testCase "liftTyped" $ do
+  (mempty :: Seq Int) @=? $$([|| $$(TH.liftTyped (fromList [])) ||])
+  fromList [1..3 :: Int] @=? $$([|| $$(TH.liftTyped (fromList [1..3])) ||])
+#endif

containers/changelog.md

@@ -7,6 +7,11 @@
 * Bump Cabal version for tests, and use `common` clauses to reduce
   duplication.
 
+### New instances
+
+* `Data.Sequence` now offers `Lift` instances for `Seq`, `ViewL`, and `ViewR`
+  for use with Template Haskell.
+
 ## 0.6.5.1
 
 ### Bug fixes

containers/containers.cabal

@@ -33,7 +33,7 @@ source-repository head
 
 Library
     default-language: Haskell2010
-    build-depends: base >= 4.9.1 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5
+    build-depends: base >= 4.9.1 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5, template-haskell
     hs-source-dirs: src
     ghc-options: -O2 -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates
 

containers/src/Data/Sequence/Internal.hs

@@ -4,18 +4,20 @@
 #if __GLASGOW_HASKELL__
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveLift #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
 {-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 #endif
 #ifdef DEFINE_PATTERN_SYNONYMS
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ViewPatterns #-}
 #endif
 {-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TypeOperators #-}
 
 {-# OPTIONS_HADDOCK not-home #-}
 {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
@@ -223,8 +225,7 @@ import Text.Read (Lexeme(Ident), lexP, parens, prec,
     readPrec, readListPrec, readListPrecDefault)
 import Data.Data
 import Data.String (IsString(..))
-#endif
-#if __GLASGOW_HASKELL__
+import qualified Language.Haskell.TH.Syntax as TH
 import GHC.Generics (Generic, Generic1)
 #endif
 
@@ -339,6 +340,41 @@ instance Sized (ForceBox a) where
 -- | General-purpose finite sequences.
 newtype Seq a = Seq (FingerTree (Elem a))
 
+#ifdef __GLASGOW_HASKELL__
+-- | @since 0.7
+instance TH.Lift a => TH.Lift (Seq a) where
+#  if MIN_VERSION_template_haskell(2,16,0)
+  liftTyped t = [|| coerceFT z ||]
+#  else
+  lift t = [| coerceFT z |]
+#  endif
+    where
+      -- We rebalance the sequence to use only 3-nodes before lifting its
+      -- underlying finger tree. This should minimize the size and depth of the
+      -- tree generated at run-time. It also reduces the size of the splice,
+      -- but I don't know how that affects the size of the resulting Core once
+      -- all the types are added.
+      Seq ft = zipWith (flip const) (replicate (length t) ()) t
+
+      -- We remove the 'Elem' constructors to reduce the size of the splice
+      -- and the number of types and coercions in the generated Core. Instead
+      -- of, say,
+      --
+      --   Seq (Deep 3 (Two (Elem 1) (Elem 2)) EmptyT (One (Elem 3)))
+      --
+      -- we generate
+      --
+      --   coerceFT (Deep 3 (Two 1 2)) EmptyT (One 3)
+      z :: FingerTree a
+      z = coerce ft
+
+-- | We use this to help the types work out for splices in the
+-- Lift instance. Things get a bit yucky otherwise.
+coerceFT :: FingerTree a -> Seq a
+coerceFT = coerce
+
+#endif
+
 instance Functor Seq where
     fmap = fmapSeq
 #ifdef __GLASGOW_HASKELL__
@@ -974,6 +1010,8 @@ deriving instance Generic1 FingerTree
 
 -- | @since 0.6.1
 deriving instance Generic (FingerTree a)
+
+deriving instance TH.Lift a => TH.Lift (FingerTree a)
 #endif
 
 instance Sized a => Sized (FingerTree a) where
@@ -1165,6 +1203,8 @@ deriving instance Generic1 Digit
 
 -- | @since 0.6.1
 deriving instance Generic (Digit a)
+
+deriving instance TH.Lift a => TH.Lift (Digit a)
 #endif
 
 foldDigit :: (b -> b -> b) -> (a -> b) -> Digit a -> b
@@ -1266,6 +1306,8 @@ deriving instance Generic1 Node
 
 -- | @since 0.6.1
 deriving instance Generic (Node a)
+
+deriving instance TH.Lift a => TH.Lift (Node a)
 #endif
 
 foldNode :: (b -> b -> b) -> (a -> b) -> Node a -> b
@@ -2131,6 +2173,9 @@ deriving instance Generic1 ViewL
 
 -- | @since 0.5.8
 deriving instance Generic (ViewL a)
+
+-- | @since 0.7
+deriving instance TH.Lift a => TH.Lift (ViewL a)
 #endif
 
 instance Functor ViewL where
@@ -2195,6 +2240,9 @@ deriving instance Generic1 ViewR
 
 -- | @since 0.5.8
 deriving instance Generic (ViewR a)
+
+-- | @since 0.7
+deriving instance TH.Lift a => TH.Lift (ViewR a)
 #endif
 
 instance Functor ViewR where