text-show-0.3.0.0: tests/Instances/BaseAndFriends.hs
{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, StandaloneDeriving #-}
#if MIN_VERSION_base(4,4,0)
{-# LANGUAGE FlexibleContexts, TypeOperators #-}
#endif
#if MIN_VERSION_base(4,7,0)
{-# LANGUAGE TypeFamilies #-}
#endif
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
-- |
-- Module : Instances.BaseAndFriends
-- Copyright : (C) 2014 Ryan Scott
-- License : BSD-style (see the file LICENSE)
-- Maintainer : Ryan Scott
-- Stability : Experimental
-- Portability : GHC
--
-- Provides 'Arbitrary' instances for data types located in @base@ and other
-- common libraries. This module also defines 'Show' instances for some data
-- types as well (e.g., those which do not derive 'Show' in older versions
-- of GHC).
----------------------------------------------------------------------------
module Instances.BaseAndFriends () where
import Control.Applicative (ZipList(..), (<$>), (<*>), pure)
import Control.Exception
import Control.Monad.ST (ST, fixST)
#if MIN_VERSION_bytestring(0,10,4)
import Data.ByteString.Short (ShortByteString, pack)
#endif
import Data.Char (GeneralCategory(..))
import qualified Data.Data as D (Fixity(..))
import Data.Data (Constr, ConstrRep(..), DataRep(..), DataType,
mkConstr, mkDataType)
import Data.Dynamic (Dynamic, toDyn)
import Data.Monoid (All(..), Any(..), Dual(..), First(..),
Last(..), Product(..), Sum(..))
#if MIN_VERSION_base(4,6,0)
import Data.Ord (Down(..))
#endif
#if MIN_VERSION_base(4,7,0)
import Data.Proxy (Proxy(..))
#endif
import Data.Text.Lazy.Builder (Builder, fromString)
#if MIN_VERSION_base(4,7,0)
import Data.Coerce (Coercible)
import Data.Type.Coercion (Coercion(..))
import Data.Type.Equality ((:~:)(..))
#endif
#if MIN_VERSION_base(4,4,0)
import Data.Typeable.Internal (Typeable, TyCon(..), TypeRep(..),
mkTyConApp, splitTyConApp, typeOf)
import GHC.Fingerprint.Type (Fingerprint(..))
import Data.Word (Word)
#if !(MIN_VERSION_base(4,7,0))
import Data.Word (Word64)
import Numeric (showHex)
#endif
#endif
import Data.Version (Version(..))
import Foreign.C.Types
import Foreign.Ptr (FunPtr, IntPtr, Ptr, WordPtr,
castPtrToFunPtr, nullPtr, plusPtr,
ptrToIntPtr, ptrToWordPtr)
import GHC.Conc (BlockReason(..), ThreadStatus(..))
#if MIN_VERSION_base(4,4,0)
import GHC.IO.Encoding.Failure (CodingFailureMode(..))
import GHC.IO.Encoding.Types (CodingProgress(..))
import qualified GHC.Generics as G (Fixity(..))
import GHC.Generics (U1(..), Par1(..), Rec1(..), K1(..),
M1(..), (:+:)(..), (:*:)(..), (:.:)(..),
Associativity(..), Arity(..))
#endif
#if MIN_VERSION_base(4,5,0)
import GHC.Stats (GCStats(..))
#endif
import System.Exit (ExitCode(..))
import System.IO (BufferMode(..), IOMode(..), Newline(..),
NewlineMode(..), SeekMode(..))
import System.Posix.Types
import Test.QuickCheck
instance Arbitrary Builder where
arbitrary = fromString <$> arbitrary
#if MIN_VERSION_bytestring(0,10,4)
instance Arbitrary ShortByteString where
arbitrary = pack <$> arbitrary
#endif
instance Arbitrary (Ptr a) where
arbitrary = plusPtr nullPtr <$> arbitrary
instance Arbitrary (FunPtr a) where
arbitrary = castPtrToFunPtr <$> arbitrary
instance Arbitrary IntPtr where
arbitrary = ptrToIntPtr <$> arbitrary
instance Arbitrary WordPtr where
arbitrary = ptrToWordPtr <$> arbitrary
-- TODO: instance Arbitrary (ForeignPtr a)
instance Arbitrary GeneralCategory where
arbitrary = oneof $ map pure [ UppercaseLetter
, LowercaseLetter
, TitlecaseLetter
, ModifierLetter
, OtherLetter
, NonSpacingMark
, SpacingCombiningMark
, EnclosingMark
, DecimalNumber
, LetterNumber
, OtherNumber
, ConnectorPunctuation
, DashPunctuation
, OpenPunctuation
, ClosePunctuation
, InitialQuote
, FinalQuote
, OtherPunctuation
, MathSymbol
, CurrencySymbol
, ModifierSymbol
, OtherSymbol
, Space
, LineSeparator
, ParagraphSeparator
, Control
, Format
, Surrogate
, PrivateUse
, NotAssigned
]
instance Arbitrary Version where
arbitrary = Version <$> arbitrary <*> arbitrary
-- TODO: Be more creative with this instance
instance Arbitrary SomeException where
arbitrary = SomeException <$> (arbitrary :: Gen AssertionFailed)
-- instance Arbitrary IOException
instance Arbitrary ArithException where
arbitrary = oneof $ map pure [ Overflow
, Underflow
, LossOfPrecision
, DivideByZero
, Denormal
#if MIN_VERSION_base(4,6,0)
, RatioZeroDenominator
#endif
]
instance Arbitrary ArrayException where
arbitrary = oneof [ IndexOutOfBounds <$> arbitrary
, UndefinedElement <$> arbitrary
]
instance Arbitrary AssertionFailed where
arbitrary = AssertionFailed <$> arbitrary
#if MIN_VERSION_base(4,7,0)
-- TODO: Be more creative with this instance
instance Arbitrary SomeAsyncException where
arbitrary = SomeAsyncException <$> (arbitrary :: Gen AsyncException)
#endif
instance Arbitrary AsyncException where
arbitrary = oneof $ map pure [ StackOverflow
, HeapOverflow
, ThreadKilled
, UserInterrupt
]
instance Arbitrary NonTermination where
arbitrary = pure NonTermination
instance Arbitrary NestedAtomically where
arbitrary = pure NestedAtomically
instance Arbitrary BlockedIndefinitelyOnMVar where
arbitrary = pure BlockedIndefinitelyOnMVar
instance Arbitrary BlockedIndefinitelyOnSTM where
arbitrary = pure BlockedIndefinitelyOnSTM
instance Arbitrary Deadlock where
arbitrary = pure Deadlock
instance Arbitrary NoMethodError where
arbitrary = NoMethodError <$> arbitrary
instance Arbitrary PatternMatchFail where
arbitrary = PatternMatchFail <$> arbitrary
instance Arbitrary RecConError where
arbitrary = RecConError <$> arbitrary
instance Arbitrary RecSelError where
arbitrary = RecSelError <$> arbitrary
instance Arbitrary RecUpdError where
arbitrary = RecUpdError <$> arbitrary
-- ErrorCall is a newtype starting with base-4.7.0.0, but we'll
-- manually derive Arbitrary to support older versions of GHC.
--
-- deriving instance Arbitrary ErrorCall
instance Arbitrary ErrorCall where
arbitrary = ErrorCall <$> arbitrary
instance Arbitrary MaskingState where
arbitrary = oneof $ map pure [ Unmasked
, MaskedInterruptible
, MaskedUninterruptible
]
-- instance Arbitrary Lexeme
-- #if MIN_VERSION_base(4,7,0)
-- instance Arbitrary Number
-- #endif
#if MIN_VERSION_base(4,7,0)
instance Arbitrary (Proxy s) where
arbitrary = pure Proxy
#endif
#if MIN_VERSION_base(4,4,0)
-- Borrowed from the concrete-typerep package
instance Arbitrary TypeRep where
arbitrary = do
nargs <- elements [0,1,2]
mkTyConApp <$> (genTyCon nargs) <*> (vectorOf nargs arbitrary)
genTyCon :: Int -- ^ Number of arguments; must be in [0,1,2]
-> Gen TyCon
genTyCon 0 = elements [tyConOf (__::Int), tyConOf (__::Word), tyConOf (__::Double), tyConOf (__::Bool)]
genTyCon 1 = elements [tyConOf (__::Maybe Int), tyConOf (__::IO Int), tyConOf (__::[Int])]
genTyCon 2 = elements [tyConOf (__::Either Int Int), tyConOf (__::Int -> Int)]
genTyCon _ = genTyCon 0
tyConOf :: Typeable a => a -> TyCon
tyConOf ty = fst $ splitTyConApp (typeOf ty)
__ :: t
__ = undefined
instance Arbitrary TyCon where
arbitrary = TyCon <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
instance Arbitrary Fingerprint where
arbitrary = Fingerprint <$> arbitrary <*> arbitrary
#if !(MIN_VERSION_base(4,7,0))
instance Show Fingerprint where
show (Fingerprint w1 w2) = hex16 w1 ++ hex16 w2
where
-- | Formats a 64 bit number as 16 digits hex.
hex16 :: Word64 -> String
hex16 i = let hex = showHex i ""
in replicate (16 - length hex) '0' ++ hex
#endif
#endif
-- TODO: Be more creative with this instance
instance Arbitrary Dynamic where
arbitrary = toDyn <$> (arbitrary :: Gen Int)
instance Arbitrary Constr where
arbitrary = mkConstr <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
instance Arbitrary ConstrRep where
arbitrary = oneof [ AlgConstr <$> arbitrary
, IntConstr <$> arbitrary
, FloatConstr <$> arbitrary
, CharConstr <$> arbitrary
]
instance Arbitrary DataRep where
arbitrary = oneof [ AlgRep <$> arbitrary
, pure IntRep
, pure FloatRep
, pure CharRep
, pure NoRep
]
instance Arbitrary DataType where
arbitrary = mkDataType <$> arbitrary <*> arbitrary
instance Arbitrary D.Fixity where
arbitrary = oneof $ map pure [D.Prefix, D.Infix]
#if MIN_VERSION_base(4,7,0)
instance Coercible a b => Arbitrary (Coercion a b) where
arbitrary = pure Coercion
instance a ~ b => Arbitrary (a :~: b) where
arbitrary = pure Refl
#endif
instance Arbitrary BlockReason where
arbitrary = oneof $ map pure [ BlockedOnMVar
, BlockedOnBlackHole
, BlockedOnException
, BlockedOnSTM
, BlockedOnForeignCall
, BlockedOnOther
]
-- instance Arbitrary ThreadId
instance Arbitrary ThreadStatus where
arbitrary = oneof [ pure ThreadRunning
, pure ThreadFinished
, ThreadBlocked <$> arbitrary
, pure ThreadDied
]
instance Arbitrary (ST s a) where
arbitrary = pure $ fixST undefined
-- instance Arbitrary Handle
-- instance Arbitrary HandlePosn
instance Arbitrary IOMode where
arbitrary = oneof $ map pure [ReadMode, WriteMode, AppendMode, ReadWriteMode]
instance Arbitrary BufferMode where
arbitrary = oneof [ pure NoBuffering
, pure LineBuffering
, BlockBuffering <$> arbitrary
]
instance Arbitrary SeekMode where
arbitrary = oneof $ map pure [AbsoluteSeek, RelativeSeek, SeekFromEnd]
instance Arbitrary Newline where
arbitrary = oneof $ map pure [LF, CRLF]
instance Arbitrary NewlineMode where
arbitrary = NewlineMode <$> arbitrary <*> arbitrary
#if MIN_VERSION_base(4,3,0)
-- instance Arbitrary TextEncoding
#else
deriving instance Show Newline
deriving instance Show NewlineMode
#endif
#if MIN_VERSION_base(4,4,0)
instance Arbitrary CodingProgress where
arbitrary = oneof $ map pure [InputUnderflow, OutputUnderflow, InvalidSequence]
instance Arbitrary CodingFailureMode where
arbitrary = oneof $ map pure [ ErrorOnCodingFailure
, IgnoreCodingFailure
, TransliterateCodingFailure
, RoundtripFailure
]
#endif
#if MIN_VERSION_base(4,5,0)
instance Arbitrary GCStats where
arbitrary = GCStats <$> arbitrary <*> arbitrary <*> arbitrary
<*> arbitrary <*> arbitrary <*> arbitrary
<*> arbitrary <*> arbitrary <*> arbitrary
<*> arbitrary <*> arbitrary <*> arbitrary
<*> arbitrary <*> arbitrary <*> arbitrary
<*> arbitrary <*> arbitrary <*> arbitrary
#endif
-- #if MIN_VERSION_base(4,4,0)
-- instance Arbitrary Event
-- instance Arbitrary FdKey
-- #endif
#if MIN_VERSION_base(4,4,0)
instance Arbitrary (U1 p) where
arbitrary = pure U1
instance Arbitrary p => Arbitrary (Par1 p) where
arbitrary = Par1 <$> arbitrary
instance Arbitrary (f p) => Arbitrary (Rec1 f p) where
arbitrary = Rec1 <$> arbitrary
instance Arbitrary c => Arbitrary (K1 i c p) where
arbitrary = K1 <$> arbitrary
instance Arbitrary (f p) => Arbitrary (M1 i c f p) where
arbitrary = M1 <$> arbitrary
instance (Arbitrary (f p), Arbitrary (g p)) => Arbitrary ((f :+: g) p) where
arbitrary = oneof [L1 <$> arbitrary, R1 <$> arbitrary]
instance (Arbitrary (f p), Arbitrary (g p)) => Arbitrary ((f :*: g) p) where
arbitrary = (:*:) <$> arbitrary <*> arbitrary
instance Arbitrary (f (g p)) => Arbitrary ((f :.: g) p) where
arbitrary = Comp1 <$> arbitrary
instance Arbitrary G.Fixity where
arbitrary = oneof [pure G.Prefix, G.Infix <$> arbitrary <*> arbitrary]
instance Arbitrary Associativity where
arbitrary = oneof $ map pure [LeftAssociative, RightAssociative, NotAssociative]
instance Arbitrary Arity where
arbitrary = oneof [pure NoArity, Arity <$> arbitrary]
#if !(MIN_VERSION_base(4,7,0))
deriving instance Show (U1 p)
deriving instance Show p => Show (Par1 p)
deriving instance Show (f p) => Show (Rec1 f p)
deriving instance Show c => Show (K1 i c p)
deriving instance Show (f p) => Show (M1 i c f p)
deriving instance (Show (f p), Show (g p)) => Show ((f :+: g) p)
-- Due to a GHC bug (https://ghc.haskell.org/trac/ghc/ticket/9830), this Show
-- instance produces output with the wrong precedence on older versions of GHC.
-- I'll manually define the Show instance to get the correct behavior.
--
-- deriving instance (Show (f p), Show (g p)) => Show ((f :*: g) p)
instance (Show (f p), Show (g p)) => Show ((f :*: g) p) where
showsPrec p (l :*: r) = showParen (p > prec) $
showsPrec (prec + 1) l
. showString " :*: "
. showsPrec (prec + 1) r
where prec = 6
deriving instance Show (f (g p)) => Show ((f :.: g) p)
#endif
#endif
deriving instance Arbitrary CChar
deriving instance Arbitrary CSChar
deriving instance Arbitrary CUChar
deriving instance Arbitrary CShort
deriving instance Arbitrary CUShort
deriving instance Arbitrary CInt
deriving instance Arbitrary CUInt
deriving instance Arbitrary CLong
deriving instance Arbitrary CULong
deriving instance Arbitrary CLLong
deriving instance Arbitrary CULLong
deriving instance Arbitrary CFloat
deriving instance Arbitrary CDouble
deriving instance Arbitrary CPtrdiff
deriving instance Arbitrary CSize
deriving instance Arbitrary CWchar
deriving instance Arbitrary CSigAtomic
deriving instance Arbitrary CClock
deriving instance Arbitrary CTime
deriving instance Arbitrary CUSeconds
deriving instance Arbitrary CSUSeconds
deriving instance Arbitrary CIntPtr
deriving instance Arbitrary CUIntPtr
deriving instance Arbitrary CIntMax
deriving instance Arbitrary CUIntMax
instance Arbitrary ExitCode where
arbitrary = oneof [pure ExitSuccess, ExitFailure <$> arbitrary]
deriving instance Arbitrary CDev
deriving instance Arbitrary CIno
deriving instance Arbitrary CMode
deriving instance Arbitrary COff
deriving instance Arbitrary CPid
deriving instance Arbitrary CSsize
deriving instance Arbitrary CGid
deriving instance Arbitrary CNlink
deriving instance Arbitrary CUid
deriving instance Arbitrary CCc
deriving instance Arbitrary CSpeed
deriving instance Arbitrary CTcflag
deriving instance Arbitrary CRLim
deriving instance Arbitrary Fd
deriving instance Arbitrary All
deriving instance Arbitrary Any
deriving instance Arbitrary a => Arbitrary (Dual a)
deriving instance Arbitrary a => Arbitrary (First a)
deriving instance Arbitrary a => Arbitrary (Last a)
deriving instance Arbitrary a => Arbitrary (Product a)
deriving instance Arbitrary a => Arbitrary (Sum a)
deriving instance Arbitrary a => Arbitrary (ZipList a)
#if !(MIN_VERSION_base(4,7,0))
deriving instance Show a => Show (ZipList a)
#endif
#if MIN_VERSION_base(4,6,0)
deriving instance Arbitrary a => Arbitrary (Down a)
#if !(MIN_VERSION_base(4,7,0))
deriving instance Show a => Show (Down a)
#endif
#endif