1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
module Types (module Types) where
import Prelude.Compat
import Math.NumberTheory.Logarithms (intLog2)
import Control.Applicative ((<$>))
import Data.Data
import Data.Functor.Compose (Compose (..))
import Data.Functor.Identity (Identity (..))
import Data.Hashable (Hashable (..))
#if !MIN_VERSION_base(4,16,0)
import Data.Semigroup (Option)
#endif
import Data.Text
import Data.Time (Day (..), fromGregorian)
import GHC.Generics
import Test.QuickCheck (Arbitrary (..), Property, counterexample, scale)
import qualified Data.Map as Map
import Data.Aeson
import Data.Aeson.Types
type I = Identity
type Compose3 f g h = Compose (Compose f g) h
type Compose3' f g h = Compose f (Compose g h)
data Foo = Foo {
fooInt :: Int
, fooDouble :: Double
, fooTuple :: (String, Text, Int)
-- This definition causes an infinite loop in genericTo and genericFrom!
-- , fooMap :: Map.Map String Foo
, fooMap :: Map.Map String (Text,Int)
} deriving (Show, Typeable, Data)
data UFoo = UFoo {
_UFooInt :: Int
, uFooInt :: Int
} deriving (Show, Eq, Data, Typeable)
data NoConstructors
data OneConstructor = OneConstructor
deriving (Show, Eq, Typeable, Data)
data Product2 a b = Product2 a b
deriving (Show, Eq, Typeable, Data)
data Product6 a b c d e f = Product6 a b c d e f
deriving (Show, Eq, Typeable, Data)
data Sum4 a b c d = Alt1 a | Alt2 b | Alt3 c | Alt4 d
deriving (Show, Eq, Typeable, Data)
class ApproxEq a where
(=~) :: a -> a -> Bool
newtype Approx a = Approx { fromApprox :: a }
deriving (Show, Data, Typeable, ApproxEq, Num)
instance (ApproxEq a) => Eq (Approx a) where
Approx a == Approx b = a =~ b
data Nullary = C1 | C2 | C3 deriving (Eq, Show)
data SomeType a = Nullary
| Unary Int
| Product String (Maybe Char) a
| Record { testOne :: Double
, testTwo :: Maybe Bool
, testThree :: Maybe a
}
| List [a]
deriving (Eq, Show)
-- | This type requires IncoherentInstances for the instances of the type
-- classes Data.Aeson.TH.LookupField and Data.Aeson.Types.FromJSON.FromRecord.
--
-- The minimum known requirements for this type are:
-- * Record type with at least two fields
-- * One field type is either a type parameter or a type/data family
-- * Another field type is a @Maybe@ of the above field type
data IncoherentInstancesNeeded a = IncoherentInstancesNeeded
{ incoherentInstancesNeededMaybeNot :: a
, incoherentInstancesNeededMaybeYes :: Maybe a
} deriving Generic
-- Used for testing UntaggedValue SumEncoding
data EitherTextInt
= LeftBool Bool
| RightInt Int
| BothTextInt Text Int
| NoneNullary
deriving (Eq, Show)
data GADT a where
GADT :: { gadt :: String } -> GADT String
deriving Typeable
deriving instance Data (GADT String)
deriving instance Eq (GADT a)
deriving instance Show (GADT a)
newtype MaybeField = MaybeField { maybeField :: Maybe Int }
#if !MIN_VERSION_base(4,16,0)
newtype OptionField = OptionField { optionField :: Option Int }
deriving (Eq, Show)
#endif
deriving instance Generic Foo
deriving instance Generic UFoo
deriving instance Generic NoConstructors
deriving instance Generic OneConstructor
deriving instance Generic (Product2 a b)
deriving instance Generic (Product6 a b c d e f)
deriving instance Generic (Sum4 a b c d)
deriving instance Generic (Approx a)
deriving instance Generic Nullary
deriving instance Generic (SomeType a)
deriving instance Generic1 SomeType
#if !MIN_VERSION_base(4,16,0)
deriving instance Generic OptionField
#endif
deriving instance Generic EitherTextInt
failure :: Show a => String -> String -> a -> Property
failure func msg v = counterexample
(func ++ " failed: " ++ msg ++ ", " ++ show v) False
newtype BCEDay = BCEDay Day
deriving (Eq, Show)
zeroDay :: Day
zeroDay = fromGregorian 0 0 0
instance Arbitrary BCEDay where
arbitrary = fmap (BCEDay . ModifiedJulianDay . (+ toModifiedJulianDay zeroDay)) arbitrary
instance ToJSON BCEDay where
toJSON (BCEDay d) = toJSON d
toEncoding (BCEDay d) = toEncoding d
instance FromJSON BCEDay where
parseJSON = fmap BCEDay . parseJSON
-- | Scale the size of Arbitrary with ''
newtype LogScaled a = LogScaled { getLogScaled :: a }
deriving (Eq, Ord, Show)
instance Hashable a => Hashable (LogScaled a) where
hashWithSalt salt (LogScaled a) = hashWithSalt salt a
instance Arbitrary a => Arbitrary (LogScaled a) where
arbitrary = LogScaled <$> scale (\x -> intLog2 $ x + 1) arbitrary
shrink = fmap LogScaled . shrink . getLogScaled
instance ToJSON a => ToJSON (LogScaled a) where
toJSON (LogScaled d) = toJSON d
toEncoding (LogScaled d) = toEncoding d
instance FromJSON a => FromJSON (LogScaled a) where
parseJSON = fmap LogScaled . parseJSON
instance (ToJSONKey a) => ToJSONKey (LogScaled a) where
toJSONKey = contramapToJSONKeyFunction getLogScaled toJSONKey
toJSONKeyList = contramapToJSONKeyFunction (fmap getLogScaled) toJSONKeyList
instance (FromJSONKey a) => FromJSONKey (LogScaled a) where
fromJSONKey = fmap LogScaled fromJSONKey
fromJSONKeyList = coerceFromJSONKeyFunction (fromJSONKeyList :: FromJSONKeyFunction [a])
|
