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