Commit 9efb1de1 authored by David Feuer's avatar David Feuer
Browse files

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.
parent f4aec7fe
......@@ -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
......
{-# 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,7 +918,6 @@ 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
......@@ -919,3 +925,21 @@ instance Foldable M where
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
......@@ -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
......
......@@ -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
......
......@@ -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
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment