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.

Author: treeowl

.gitignore

@@ -8,3 +8,4 @@
 GNUmakefile
 dist-install
 ghc.mk
+.stack-work

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
 

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