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