Skip to content

Commit

Permalink
feat: Support DNonEmpty on older base versions
Browse files Browse the repository at this point in the history
* 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
  • Loading branch information
414owen authored and spl committed Feb 19, 2024
1 parent 8ce1a13 commit efe6dd6
Show file tree
Hide file tree
Showing 5 changed files with 121 additions and 46 deletions.
9 changes: 8 additions & 1 deletion Data/DList/DNonEmpty.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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

-----------------------------------------------------------------------------
Expand Down Expand Up @@ -41,8 +44,10 @@ module Data.DList.DNonEmpty
DNonEmpty((:|)),

-- * Conversion
#if MIN_VERSION_base(4,9,0)
fromNonEmpty,
toNonEmpty,
#endif
toList,
fromList,

Expand All @@ -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

Expand Down
68 changes: 40 additions & 28 deletions Data/DList/DNonEmpty/Internal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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 -}
{-|
Expand All @@ -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 -}
{-|
Expand Down Expand Up @@ -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 #-}
Expand All @@ -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

{-
Expand All @@ -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

Expand All @@ -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
8 changes: 3 additions & 5 deletions dlist.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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,
Expand Down
79 changes: 70 additions & 9 deletions tests/DNonEmptyProperties.hs
Original file line number Diff line number Diff line change
@@ -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.
Expand All @@ -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)
Expand All @@ -36,18 +42,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
Expand All @@ -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
Expand All @@ -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),
Expand All @@ -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
3 changes: 0 additions & 3 deletions tests/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down

0 comments on commit efe6dd6

Please sign in to comment.