feat: Support DNonEmpty on older base versions

* Add CPP guards around some instances
* Remove some conditional cabal
* Use NonEmpty-based fold functions directly
* Add tests for fold instance
* Disable DNonEmpty test suite on base <4.9.0

Author: 414owen

Data/DList/DNonEmpty.hs

@@ -8,9 +8,12 @@
 
 -----------------------------------------------------------------------------
 
+-- GHC >=8 supports this flag
+#if MIN_VERSION_base(4,9,0)
 -- CPP: Ignore unused imports when Haddock is run
-#if defined(__HADDOCK_VERSION__)
+# if defined(__HADDOCK_VERSION__)
 {-# OPTIONS_GHC -Wno-unused-imports #-}
+# endif
 #endif
 
 -----------------------------------------------------------------------------
@@ -41,8 +44,10 @@ module Data.DList.DNonEmpty
     DNonEmpty((:|)),
 
     -- * Conversion
+#if MIN_VERSION_base(4,9,0)
     fromNonEmpty,
     toNonEmpty,
+#endif
     toList,
     fromList,
 
@@ -64,7 +69,9 @@ import Data.DList.DNonEmpty.Internal
 
 -- CPP: Import only for Haddock
 #if defined(__HADDOCK_VERSION__)
+# if MIN_VERSION_base(4,9,0)
 import Data.List.NonEmpty (NonEmpty)
+# endif
 import Data.DList (DList)
 #endif
 

Data/DList/DNonEmpty/Internal.hs

@@ -50,9 +50,14 @@ import Data.DList (DList)
 import qualified Data.DList as DList
 import qualified Data.Foldable as Foldable
 import Data.Function (on)
+#if !MIN_VERSION_base(4,8,0)
+import Data.Monoid (mappend)
+#endif
+#if MIN_VERSION_base(4,9,0)
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as NonEmpty
 import qualified Data.Semigroup as Semigroup
+#endif
 import Data.String (IsString (..))
 import qualified GHC.Exts as Exts
 import qualified Text.Read as Read
@@ -123,9 +128,11 @@ More likely, you will convert from a 'NonEmpty', perform some operation on the
 -}
 {- ORMOLU_ENABLE -}
 
+#if MIN_VERSION_base(4,9,0)
 {-# INLINE fromNonEmpty #-}
 fromNonEmpty :: NonEmpty a -> DNonEmpty a
 fromNonEmpty ~(x NonEmpty.:| xs) = x :| DList.fromList xs
+#endif
 
 {- ORMOLU_DISABLE -}
 {-|
@@ -147,9 +154,11 @@ you achieved due to laziness in the construction.
 -}
 {- ORMOLU_ENABLE -}
 
+#if MIN_VERSION_base(4,9,0)
 {-# INLINE toNonEmpty #-}
 toNonEmpty :: DNonEmpty a -> NonEmpty a
 toNonEmpty ~(x :| xs) = x NonEmpty.:| DList.toList xs
+#endif
 
 {- ORMOLU_DISABLE -}
 {-|
@@ -378,23 +387,26 @@ map :: (a -> b) -> DNonEmpty a -> DNonEmpty b
 map f ~(x :| xs) = f x :| DList.map f xs
 
 instance Eq a => Eq (DNonEmpty a) where
-  (==) = (==) `on` toNonEmpty
+  (==) = (==) `on` toList
 
 instance Ord a => Ord (DNonEmpty a) where
-  compare = compare `on` toNonEmpty
+  compare = compare `on` toList
 
 instance Read a => Read (DNonEmpty a) where
   readPrec = Read.parens $
     Read.prec 10 $ do
       Read.Ident "fromNonEmpty" <- Read.lexP
-      dl <- Read.readPrec
-      return $ fromNonEmpty dl
+      Read.parens $ do
+        x <- Read.prec 5 Read.readPrec
+        Read.Symbol ":|" <- Read.lexP
+        xs <- Read.prec 5 Read.readPrec
+        return $ x :| DList.fromList xs
   readListPrec = Read.readListPrecDefault
 
 instance Show a => Show (DNonEmpty a) where
-  showsPrec p dl =
+  showsPrec p (x :| xs)=
     showParen (p > 10) $
-      showString "fromNonEmpty " . showsPrec 11 (toNonEmpty dl)
+      showString "fromNonEmpty (" . showsPrec 5 x . showString " :| " . showsPrec 5 (DList.toList xs) . showString ")"
 
 instance Functor DNonEmpty where
   {-# INLINE fmap #-}
@@ -416,36 +428,32 @@ instance Monad DNonEmpty where
   return = Applicative.pure
 
 instance Foldable.Foldable DNonEmpty where
-  {-# INLINE fold #-}
-  fold = Foldable.fold . toNonEmpty
-
-  {-# INLINE foldMap #-}
-  foldMap f = Foldable.foldMap f . toNonEmpty
-
-  {-# INLINE foldr #-}
-  foldr f x = Foldable.foldr f x . toNonEmpty
-
-  {-# INLINE foldl #-}
-  foldl f x = Foldable.foldl f x . toNonEmpty
+  foldr f x = Foldable.foldr f x . toList
+  foldl f x = Foldable.foldl f x . toList
 
-  {-# INLINE foldr1 #-}
-  foldr1 f = Foldable.foldr1 f . toNonEmpty
-
-  {-# INLINE foldl1 #-}
-  foldl1 f = Foldable.foldl1 f . toNonEmpty
-
-  {-# INLINE foldl' #-}
-  foldl' f x = Foldable.foldl' f x . toNonEmpty
+#if MIN_VERSION_base(4,6,0)
+  foldl' f x = Foldable.foldl' f x . toList
+  foldr' f x = Foldable.foldr' f x . toList
+#endif
 
-  {-# INLINE foldr' #-}
-  foldr' f x = Foldable.foldr' f x . toNonEmpty
+  -- These are based on their NonEmpty counterparts
+  -- We don't convert to NonEmpty, because we support
+  -- base <4.9.0.0
+  fold ~(x :| xs) = x `mappend` Foldable.fold xs
+  foldMap f ~(x :| xs) = f x `mappend` Foldable.foldMap f xs
+  foldr1 f (p :| ps) = Foldable.foldr go id ps p
+    where
+      go x r prev = f prev (r x)
+  foldl1 f (x :| xs) = Foldable.foldl f x (DList.toList xs)
 
+#if MIN_VERSION_base(4,8,0)
   {-# INLINE toList #-}
   toList = toList
+#endif
 
 instance NFData a => NFData (DNonEmpty a) where
   {-# INLINE rnf #-}
-  rnf = rnf . toNonEmpty
+  rnf = rnf . toList
 
 {-
 
@@ -460,6 +468,7 @@ instance a ~ Char => IsString (DNonEmpty a) where
   {-# INLINE fromString #-}
   fromString = fromList
 
+#if MIN_VERSION_base(4,7,0)
 instance Exts.IsList (DNonEmpty a) where
   type Item (DNonEmpty a) = a
 
@@ -468,7 +477,10 @@ instance Exts.IsList (DNonEmpty a) where
 
   {-# INLINE toList #-}
   toList = toList
+#endif
 
+#if MIN_VERSION_base(4,9,0)
 instance Semigroup.Semigroup (DNonEmpty a) where
   {-# INLINE (<>) #-}
   (<>) = append
+#endif

dlist.cabal

@@ -49,10 +49,9 @@ library
                         deepseq >= 1.1 && < 1.6
   exposed-modules:      Data.DList
                         Data.DList.Unsafe
+                        Data.DList.DNonEmpty
   other-modules:        Data.DList.Internal
-  if impl(ghc >= 8.0)
-    exposed-modules:    Data.DList.DNonEmpty
-    other-modules:      Data.DList.DNonEmpty.Internal
+                        Data.DList.DNonEmpty.Internal
   default-language:     Haskell2010
   default-extensions:   TypeOperators
   ghc-options:          -Wall
@@ -77,8 +76,7 @@ test-suite test
   other-modules:        DListProperties
                         OverloadedStrings
                         QuickCheckUtil
-  if impl(ghc >= 8.0)
-    other-modules:      DNonEmptyProperties
+                        DNonEmptyProperties
   hs-source-dirs:       tests
   build-depends:        dlist,
                         base,

tests/DNonEmptyProperties.hs

@@ -1,10 +1,10 @@
 {-# LANGUAGE CPP #-}
 
--- CPP: GHC >= 7.8 for Safe Haskell
-#if __GLASGOW_HASKELL__ >= 708
+#if MIN_VERSION_base(4,9,0)
 {-# LANGUAGE Safe #-}
-#endif
-
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DeriveFunctor #-}
 --------------------------------------------------------------------------------
 
 -- | QuickCheck property tests for DNonEmpty.
@@ -22,11 +22,16 @@ import QuickCheckUtil
 import Test.QuickCheck
 import Text.Show.Functions ()
 import Prelude hiding (head, map, tail)
+import Data.Monoid (Sum)
+
+-- NonEmpty.append was only added in base 4.16
+nonEmptyAppend :: NonEmpty a -> NonEmpty a -> NonEmpty a
+nonEmptyAppend (x NonEmpty.:| xs) ys = x NonEmpty.:| (xs ++ NonEmpty.toList ys)
 
 --------------------------------------------------------------------------------
 
-prop_model :: NonEmpty Int -> Bool
-prop_model = eqWith id (toNonEmpty . fromNonEmpty)
+prop_model :: DNonEmpty Int -> Bool
+prop_model = eqWith id id
 
 prop_singleton :: Int -> Bool
 prop_singleton = eqWith Applicative.pure (toNonEmpty . singleton)
@@ -36,18 +41,30 @@ prop_cons c = eqWith (NonEmpty.cons c) (toNonEmpty . cons c . fromNonEmpty)
 
 prop_snoc :: NonEmpty Int -> Int -> Bool
 prop_snoc xs c =
-  xs Semigroup.<> Applicative.pure c == toNonEmpty (snoc (fromNonEmpty xs) c)
+  xs `nonEmptyAppend` Applicative.pure c == toNonEmpty (snoc (fromNonEmpty xs) c)
 
 prop_append :: NonEmpty Int -> NonEmpty Int -> Bool
 prop_append xs ys =
-  xs Semigroup.<> ys == toNonEmpty (fromNonEmpty xs `append` fromNonEmpty ys)
+  xs `nonEmptyAppend` ys == toNonEmpty (fromNonEmpty xs `append` fromNonEmpty ys)
 
 prop_head :: NonEmpty Int -> Bool
 prop_head = eqWith NonEmpty.head (head . fromNonEmpty)
 
 prop_tail :: NonEmpty Int -> Bool
 prop_tail = eqWith NonEmpty.tail (DList.toList . tail . fromNonEmpty)
 
+prop_foldr :: Eq b => (a -> b -> b) -> b -> NonEmpty a -> Bool
+prop_foldr f initial l = foldr f initial l == foldr f initial (fromNonEmpty l)
+
+prop_foldr1 :: Eq a => (a -> a -> a) -> NonEmpty a -> Bool
+prop_foldr1 f l = foldr1 f l == foldr1 f (fromNonEmpty l)
+
+prop_foldl :: Eq b => (b -> a -> b) -> b -> NonEmpty a -> Bool
+prop_foldl f initial l = foldl f initial l == foldl f initial (fromNonEmpty l)
+
+prop_foldMap :: (Eq b, Monoid b) => (a -> b) -> NonEmpty a -> Bool
+prop_foldMap f l = foldMap f l == foldMap f (fromNonEmpty l)
+
 prop_unfoldr :: (Int -> (Int, Maybe Int)) -> Int -> Int -> Property
 prop_unfoldr f n =
   eqOn
@@ -59,7 +76,15 @@ prop_map :: (Int -> Int) -> NonEmpty Int -> Bool
 prop_map f = eqWith (NonEmpty.map f) (toNonEmpty . map f . fromNonEmpty)
 
 prop_show_read :: NonEmpty Int -> Bool
-prop_show_read = eqWith id (read . show)
+prop_show_read = eqWith id (read . show) . fromNonEmpty
+
+prop_inner_show_read ::
+  ( Eq (f (DNonEmpty a))
+  , Show (f (DNonEmpty a))
+  , Read (f (DNonEmpty a))
+  , Functor f
+  ) => f (NonEmpty a) -> Bool
+prop_inner_show_read = eqWith id (read . show) . fmap fromNonEmpty
 
 prop_read_show :: NonEmpty Int -> Bool
 prop_read_show x = eqWith id (show . f . read) $ "fromNonEmpty (" ++ show x ++ ")"
@@ -87,6 +112,21 @@ prop_Semigroup_append xs ys =
 
 --------------------------------------------------------------------------------
 
+newtype Single a = Single a
+  deriving (Eq, Read, Show, Functor)
+
+instance Arbitrary a => Arbitrary (Single a) where
+  arbitrary = Single <$> arbitrary
+
+instance Arbitrary a => Arbitrary (DList.DList a) where
+  arbitrary = DList.fromList <$> arbitrary
+
+instance Arbitrary a => Arbitrary (DNonEmpty a) where
+  arbitrary = do
+    x <- arbitrary
+    xs <- arbitrary
+    pure $ x :| xs
+
 properties :: [(String, Property)]
 properties =
   [ ("model", property prop_model),
@@ -97,10 +137,30 @@ properties =
     ("head", property prop_head),
     ("tail", property prop_tail),
     ("unfoldr", property prop_unfoldr),
+    ("foldr", property (prop_foldr @Int @Int)),
+    ("foldr1", property (prop_foldr1 @Int)),
+    ("foldl", property (prop_foldl @Int @Int)),
+    ("foldMap", property (prop_foldMap @(Sum Int) @Int)),
     ("map", property prop_map),
     ("read . show", property prop_show_read),
+    ("read . show", property (prop_inner_show_read @Single @Int)),
+    ("read . show", property (prop_inner_show_read @((,) Int) @(Int, Int))),
+    ("read . show", property (prop_inner_show_read @Single @(DNonEmpty Int))),
     ("show . read", property prop_read_show),
     ("toList", property prop_toList),
     ("fromList", property prop_fromList),
     ("Semigroup <>", property prop_Semigroup_append)
   ]
+
+#else
+
+#warning Skipping DNonEmptyProperties tests due to old version of base
+
+module DNonEmptyProperties (properties) where
+
+import Test.QuickCheck
+
+properties :: [(String, Property)]
+properties = []
+
+#endif

tests/Main.hs

@@ -13,10 +13,7 @@ module Main (main) where
 --------------------------------------------------------------------------------
 
 import qualified DListProperties
--- CPP: GHC >= 8 for DNonEmpty
-#if __GLASGOW_HASKELL__ >= 800
 import qualified DNonEmptyProperties
-#endif
 import qualified OverloadedStrings
 import QuickCheckUtil (quickCheckLabeledProperties)
 import Control.Monad (unless)
@@ -30,8 +27,5 @@ main = do
   OverloadedStrings.test
   result <- quickCheckLabeledProperties $
     DListProperties.properties
-  -- CPP: GHC >= 8 for DNonEmpty
-#if __GLASGOW_HASKELL__ >= 800
     ++ DNonEmptyProperties.properties
-#endif
   unless (isSuccess result) exitFailure