From efe6dd67db37b105f2d59c9f1267f44283843541 Mon Sep 17 00:00:00 2001 From: Owen Shepherd Date: Tue, 26 Dec 2023 12:10:10 +0100 Subject: [PATCH] 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 --- Data/DList/DNonEmpty.hs | 9 +++- Data/DList/DNonEmpty/Internal.hs | 68 ++++++++++++++++----------- dlist.cabal | 8 ++-- tests/DNonEmptyProperties.hs | 79 ++++++++++++++++++++++++++++---- tests/Main.hs | 3 -- 5 files changed, 121 insertions(+), 46 deletions(-) diff --git a/Data/DList/DNonEmpty.hs b/Data/DList/DNonEmpty.hs index 3be1b81..00b4e0e 100644 --- a/Data/DList/DNonEmpty.hs +++ b/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 diff --git a/Data/DList/DNonEmpty/Internal.hs b/Data/DList/DNonEmpty/Internal.hs index 69b130b..b8f5e0f 100644 --- a/Data/DList/DNonEmpty/Internal.hs +++ b/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 diff --git a/dlist.cabal b/dlist.cabal index 1e1763c..5738c71 100644 --- a/dlist.cabal +++ b/dlist.cabal @@ -50,10 +50,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 @@ -78,8 +77,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, diff --git a/tests/DNonEmptyProperties.hs b/tests/DNonEmptyProperties.hs index 6123930..8ae42f2 100644 --- a/tests/DNonEmptyProperties.hs +++ b/tests/DNonEmptyProperties.hs @@ -1,10 +1,11 @@ {-# LANGUAGE CPP #-} --- CPP: GHC >= 7.8 for Safe Haskell -#if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE Safe #-} -#endif - +#if MIN_VERSION_base(4,9,0) +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-orphans #-} -------------------------------------------------------------------------------- -- | QuickCheck property tests for DNonEmpty. @@ -22,11 +23,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,11 +42,11 @@ 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) @@ -48,6 +54,18 @@ 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 @@ -61,6 +79,14 @@ prop_map f = eqWith (NonEmpty.map f) (toNonEmpty . map f . fromNonEmpty) prop_show_read :: NonEmpty Int -> Bool 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 ++ ")" where @@ -87,6 +113,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 +138,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 diff --git a/tests/Main.hs b/tests/Main.hs index b69f40a..3ab7ffe 100644 --- a/tests/Main.hs +++ b/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)