1-- | 2-- Module : DefaultSpec 3-- Description : Ensure that deriving via (Default a) newtype works 4-- License : BSD-3-Clause 5-- 6-- Maintainer : generics@haskell.org 7-- Stability : experimental 8-- Portability : non-portable 9-- 10-- Tests DerivingVia on GHC versions 8.6 and above. There are no tests on 11-- versions below. 12-- 13-- The test check a miscellany of properties of the derived type classes. 14-- (Testing all the required properties is beyond the scope of this module.) 15{-# LANGUAGE CPP #-} 16#if __GLASGOW_HASKELL__ >= 806 17{-# LANGUAGE DeriveFunctor #-} 18{-# LANGUAGE DeriveGeneric #-} 19{-# LANGUAGE DerivingVia #-} 20{-# LANGUAGE ScopedTypeVariables #-} 21{-# LANGUAGE StandaloneDeriving #-} 22#endif 23 24module DefaultSpec where 25 26import Test.Hspec 27 28#if __GLASGOW_HASKELL__ >= 806 29import Test.Hspec.QuickCheck 30 31import Data.Semigroup (First(..)) 32import Data.Foldable (sequenceA_) 33import Generics.Deriving hiding (universe) 34import Generics.Deriving.Default () 35import Generics.Deriving.Foldable (GFoldable(..)) 36import Generics.Deriving.Semigroup (GSemigroup(..)) 37#endif 38 39spec :: Spec 40spec = do 41 describe "DerivingVia Default" $ do 42 43#if __GLASGOW_HASKELL__ >= 806 44 it "GEq is commutative for derivingVia (Default MyType)" . sequenceA_ $ 45 let commutative :: GEq a => a -> a -> Expectation 46 commutative x y = x `geq` y `shouldBe` y `geq` x 47 48 universe :: [MyType] 49 universe = MyType <$> [False, True] 50 51 in commutative <$> universe <*> universe 52 53 it "GShow for MyType is like Show for Bool with derivingVia (Default MyType) but prefixed with 'MyType '" $ do 54 gshowsPrec 0 (MyType False) "" `shouldBe` "MyType " <> showsPrec 0 False "" 55 gshowsPrec 0 (MyType True) "" `shouldBe` "MyType " <> showsPrec 0 True "" 56 57 it "GEq is commutative for parameterized derivingVia (Default (MyType1 Bool))" . sequenceA_ $ 58 let commutative :: GEq a => a -> a -> Expectation 59 commutative x y = x `geq` y `shouldBe` y `geq` x 60 61 universe :: [MyType1 Bool] 62 universe = MyType1 <$> [False, True] 63 64 in commutative <$> universe <*> universe 65 66 it "GShow for MyType1 Bool is like Show for Bool with derivingVia (Default (MyType1 Bool)) but prefixed with 'MyType1 '" $ do 67 gshowsPrec 0 (MyType1 False) "" `shouldBe` "MyType1 " <> showsPrec 0 False "" 68 gshowsPrec 0 (MyType1 True) "" `shouldBe` "MyType1 " <> showsPrec 0 True "" 69 70 it "GEq is commutative for derivingVia (Default Bool)" . sequenceA_ $ 71 let commutative :: GEq a => a -> a -> Expectation 72 commutative x y = x `geq` y `shouldBe` y `geq` x 73 74 universe :: [TestEq] 75 universe = TestEq <$> [False, True] 76 77 in commutative <$> universe <*> universe 78 79 it "GENum is correct for derivingVia (Default Bool)" $ 80 genum `shouldBe` [TestEnum False, TestEnum True] 81 82 it "GShow for TestShow is the same as Show for Bool with derivingVia (Default Bool)" $ do 83 gshowsPrec 0 (TestShow False) "" `shouldBe` showsPrec 0 False "" 84 gshowsPrec 0 (TestShow True) "" `shouldBe` showsPrec 0 True "" 85 86 it "GSemigroup is like First when instantiated with derivingVia (First Bool)" . sequenceA_ $ 87 let first' :: (Eq a, Show a, GSemigroup a) => a -> a -> Expectation 88 first' x y = x `gsappend` y `shouldBe` x 89 90 universe :: [FirstSemigroup] 91 universe = FirstSemigroup <$> [False, True] 92 93 in first' <$> universe <*> universe 94 95 prop "GFoldable with derivingVia (Default1 Option) acts like mconcat with Maybe (First Bool)" $ \(xs :: [Maybe Bool]) -> 96 let ys :: [Maybe (First Bool)] 97 -- Note that there is no Arbitrary instance for this type 98 ys = fmap First <$> xs 99 100 unTestFoldable :: TestFoldable a -> Maybe a 101 unTestFoldable (TestFoldable x) = x 102 103 in gfoldMap unTestFoldable (TestFoldable <$> ys) `shouldBe` mconcat ys 104 105 it "GFunctor for TestFunctor Bool is as Functor for Maybe Bool" . sequenceA_ $ 106 let universe :: [Maybe Bool] 107 universe = [Nothing, Just False, Just True] 108 109 functor_prop :: Maybe Bool -> Expectation 110 functor_prop x = gmap not (TestFunctor x) `shouldBe` TestFunctor (not <$> x) 111 112 in functor_prop <$> universe 113 114#endif 115 return () 116 117#if __GLASGOW_HASKELL__ >= 806 118 119-- These types all implement instances using `DerivingVia`: most via 120-- `Default` (one uses `First`). 121 122newtype TestEq = TestEq Bool 123 deriving (GEq) via (Default Bool) 124newtype TestEnum = TestEnum Bool 125 deriving stock (Eq, Show) 126 deriving (GEnum) via (Default Bool) 127newtype TestShow = TestShow Bool 128 deriving (GShow) via (Default Bool) 129 130newtype FirstSemigroup = FirstSemigroup Bool 131 deriving stock (Eq, Show) 132 deriving (GSemigroup) via (First Bool) 133 134newtype TestFoldable a = TestFoldable (Maybe a) 135 deriving (GFoldable) via (Default1 Maybe) 136 137newtype TestFunctor a = TestFunctor (Maybe a) 138 deriving stock (Eq, Show, Functor) 139 deriving (GFunctor) via (Default1 Maybe) 140 141newtype TestHigherEq a = TestHigherEq (Maybe a) 142 deriving stock (Generic) 143 deriving (GEq) via (Default (TestHigherEq a)) 144 145-- These types correspond to the hypothetical examples in the module 146-- documentation. 147 148data MyType = MyType Bool 149 deriving (Generic) 150 deriving (GEq) via (Default MyType) 151 152deriving via (Default MyType) instance GShow MyType 153 154data MyType1 a = MyType1 a 155 deriving (Generic, Generic1) 156 deriving (GEq) via (Default (MyType1 a)) 157 deriving (GFunctor) via (Default1 MyType1) 158 159deriving via Default (MyType1 a) instance GShow a => GShow (MyType1 a) 160deriving via (Default1 MyType1) instance GFoldable MyType1 161#endif 162