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