[commit: packages/containers] changelog-foldtree, cleaned_bugfix394, master, merge-doc-target, merge-fixes-5.9, merge-restrict-fix-5.8, revert-184-generic, revert-408-bugfix_394: Add pattern synonyms for sequences (fa85383)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/containers

On branches: changelog-foldtree,cleaned_bugfix394,master,merge-doc-target,merge-fixes-5.9,merge-restrict-fix-5.8,revert-184-generic,revert-408-bugfix_394
Link       : http://git.haskell.org/packages/containers.git/commitdiff/fa85383c542841883aa50aac1a0335e20481c6d6

>---------------------------------------------------------------

commit fa85383c542841883aa50aac1a0335e20481c6d6
Author: David Feuer <David.Feuer at gmail.com>
Date:   Wed Apr 20 21:35:17 2016 -0400

    Add pattern synonyms for sequences
    
    Allow `Seq` to be matched with `Empty`, `:<|`, and `:|>`.
    Unfortunately, there's quite a lot of CPP noise resulting
    from various developments in pattern synonyms in different
    versions. Also unfortunately, there's not yet any way to
    let GHC know that matching on `Empty` and `:<|`, or on
    `Empty` and `:|>`, will be exhaustive.


>---------------------------------------------------------------

fa85383c542841883aa50aac1a0335e20481c6d6
 .gitignore              |  1 +
 Data/Sequence.hs        | 66 ++++++++++++++++++++++++++++++++++++++++++++++---
 tests/seq-properties.hs |  8 +++---
 3 files changed, 68 insertions(+), 7 deletions(-)

diff --git a/.gitignore b/.gitignore
index f5c7aee..fb03447 100644
--- a/.gitignore
+++ b/.gitignore
@@ -8,3 +8,4 @@
 GNUmakefile
 dist-install
 ghc.mk
+.stack-work
diff --git a/Data/Sequence.hs b/Data/Sequence.hs
index 0103d71..2a90928 100644
--- a/Data/Sequence.hs
+++ b/Data/Sequence.hs
@@ -1,4 +1,7 @@
 {-# LANGUAGE CPP #-}
+#if __GLASGOW_HASKELL__ >= 708
+#define DEFINE_PATTERN_SYNONYMS 1
+#endif
 #if __GLASGOW_HASKELL__
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE StandaloneDeriving #-}
@@ -10,6 +13,10 @@
 #if __GLASGOW_HASKELL__ >= 708
 {-# LANGUAGE TypeFamilies #-}
 #endif
+#ifdef DEFINE_PATTERN_SYNONYMS
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
+#endif
 
 #include "containers.h"
 
@@ -56,10 +63,24 @@
 -----------------------------------------------------------------------------
 
 module Data.Sequence (
-#if !defined(TESTING)
-    Seq,
+#if defined(TESTING)
+    Elem(..), FingerTree(..), Node(..), Digit(..),
+#if __GLASGOW_HASKELL__ >= 800
+    Seq (.., Empty, (:<|), (:|>)),
+#else
+    Seq (..),
+#endif
+
+#elif __GLASGOW_HASKELL__ >= 800
+    Seq (Empty, (:<|), (:|>)),
 #else
-    Seq(..), Elem(..), FingerTree(..), Node(..), Digit(..),
+    Seq,
+#if defined(DEFINE_PATTERN_SYNONYMS)
+    -- * Pattern synonyms
+    pattern Empty,  -- :: Seq a
+    pattern (:<|),  -- :: a -> Seq a -> Seq a
+    pattern (:|>),  -- :: Seq a -> a -> Seq a
+#endif
 #endif
     -- * Construction
     empty,          -- :: Seq a
@@ -220,6 +241,45 @@ infixr 5 ><
 infixr 5 <|, :<
 infixl 5 |>, :>
 
+#ifdef DEFINE_PATTERN_SYNONYMS
+infixr 5 :<|
+infixl 5 :|>
+
+-- TODO: Once GHC implements some way to prevent non-exhaustive
+-- pattern match warnings for pattern synonyms, we should be
+-- sure to take advantage of that.
+
+-- Unfortunately, there's some extra noise here because
+-- pattern synonyms could not have signatures until 7.10,
+-- but 8.0 at least will warn if they're missing.
+#if __GLASGOW_HASKELL__ >= 710
+pattern Empty :: Seq a
+#endif
+pattern Empty = Seq EmptyT
+
+-- Non-trivial bidirectional pattern synonyms are only
+-- available in GHC >= 7.10. In earlier versions, these
+-- can be used to match, but not to construct.
+
+#if __GLASGOW_HASKELL__ >= 710
+pattern (:<|) :: a -> Seq a -> Seq a
+#endif
+pattern x :<| xs <- (viewl -> x :< xs)
+#if __GLASGOW_HASKELL__ >= 710
+  where
+    x :<| xs = x <| xs
+#endif
+
+#if __GLASGOW_HASKELL__ >= 710
+pattern (:|>) :: Seq a -> a -> Seq a
+#endif
+pattern xs :|> x <- (viewr -> xs :> x)
+#if __GLASGOW_HASKELL__ >= 710
+  where
+    xs :|> x = xs |> x
+#endif
+#endif
+
 class Sized a where
     size :: a -> Int
 
diff --git a/tests/seq-properties.hs b/tests/seq-properties.hs
index c70a8a2..64c84fe 100644
--- a/tests/seq-properties.hs
+++ b/tests/seq-properties.hs
@@ -116,7 +116,7 @@ instance (Arbitrary a, Sized a) => Arbitrary (FingerTree a) where
     arbitrary = sized arb
       where
         arb :: (Arbitrary b, Sized b) => Int -> Gen (FingerTree b)
-        arb 0 = return Empty
+        arb 0 = return EmptyT
         arb 1 = Single <$> arbitrary
         arb n = do
             pr <- arbitrary
@@ -128,13 +128,13 @@ instance (Arbitrary a, Sized a) => Arbitrary (FingerTree a) where
             m <- arb n_m
             return $ deep pr m sf
 
-    shrink (Deep _ (One a) Empty (One b)) = [Single a, Single b]
+    shrink (Deep _ (One a) EmptyT (One b)) = [Single a, Single b]
     shrink (Deep _ pr m sf) =
         [deep pr' m sf | pr' <- shrink pr] ++
         [deep pr m' sf | m' <- shrink m] ++
         [deep pr m sf' | sf' <- shrink sf]
     shrink (Single x) = map Single (shrink x)
-    shrink Empty = []
+    shrink EmptyT = []
 
 instance (Arbitrary a, Sized a) => Arbitrary (Node a) where
     arbitrary = oneof [
@@ -176,7 +176,7 @@ instance Valid (Seq a) where
     valid (Seq xs) = valid xs
 
 instance (Sized a, Valid a) => Valid (FingerTree a) where
-    valid Empty = True
+    valid EmptyT = True
     valid (Single x) = valid x
     valid (Deep s pr m sf) =
         s == size pr + size m + size sf && valid pr && valid m && valid sf