text-show-0.7: tests/Instances/Derived.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#include "overlap.h"
__LANGUAGE_OVERLAPPING_INSTANCES__
#if __GLASGOW_HASKELL__ >= 706
-- GHC 7.4 also supports PolyKinds, but Template Haskell doesn't seem to play
-- -- nicely with it for some reason.
{-# LANGUAGE PolyKinds #-}
#endif
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-|
Module: Instances.Derived
Copyright: (C) 2014-2015 Ryan Scott
License: BSD-style (see the file LICENSE)
Maintainer: Ryan Scott
Stability: Experimental
Portability: GHC
Defines data types with derived 'Show' instances (using "Text.Show.Text.TH")
for testing purposes, including 'Arbitrary' instances.
-}
module Instances.Derived (
showbNullary
, showbPhantomNullary
, showbMonomorphicUnaryPrec
, showbPolymorphicUnaryPrec
, showbMonomorphicProductPrec
, showbPolymorphicProductPrec
, showbMonomorphicRecordPrec
, showbPolymorphicRecordPrec
, showbMonomorphicInfixPrec
, showbPolymorphicInfixPrec
, showbMonomorphicForallPrec
, showbPolymorphicForallPrec
, showbAllAtOncePrec
, showbGADTPrec
, showbPrimADTPrec#
, showbLeftAssocTreePrec
, showbRightAssocTreePrec
, showbQuestionMarkPrec
-- , showbHigherKindedTypeParamsPrec
-- , showbRestrictionPrec
-- , showbRestrictedContextPrec
-- , showbFixPrec
#if MIN_VERSION_template_haskell(2,7,0)
, showbASNullary
, showbASUnaryPrec
, showbASProductPrec
, showbASRecordPrec
, showbASInfixPrec
, showbNASShowPrec
, showbOneDataInstancePrec
, showbAssocData1Prec
, showbAssocData2Prec
-- , showbAssocData3Prec
# if __GLASGOW_HASKELL__ >= 708
, showbNullaryDataPrec
# endif
, showbGADTFamPrec
#endif
) where
#if !(MIN_VERSION_base(4,8,0))
import Control.Applicative ((<*>), pure)
import Data.Functor ((<$>))
#endif
import Derived
import GHC.Exts (Char(..), Double(..), Float(..), Int(..), Word(..))
import Prelude hiding (Show)
import Test.Tasty.QuickCheck (Arbitrary(..), Gen, oneof)
import Text.Show.Text (Show(showb, showbPrec), Builder)
import Text.Show.Text.TH (deriveShow, mkShowbPrec)
showbNullary :: Nullary -> Builder
showbNullary = showb
showbPhantomNullary :: Show a => PhantomNullary a -> Builder
showbPhantomNullary = showb
showbMonomorphicUnaryPrec :: Int -> MonomorphicUnary -> Builder
showbMonomorphicUnaryPrec = showbPrec
showbPolymorphicUnaryPrec :: (Show a, Show b) => Int -> PolymorphicUnary a b -> Builder
showbPolymorphicUnaryPrec = showbPrec
showbMonomorphicProductPrec :: Int -> MonomorphicProduct -> Builder
showbMonomorphicProductPrec = showbPrec
showbPolymorphicProductPrec :: (Show a, Show b, Show c, Show d)
=> Int -> PolymorphicProduct a b c d -> Builder
showbPolymorphicProductPrec = showbPrec
showbMonomorphicRecordPrec :: Int -> MonomorphicRecord -> Builder
showbMonomorphicRecordPrec = showbPrec
showbPolymorphicRecordPrec :: (Show a, Show b, Show c, Show d)
=> Int -> PolymorphicRecord a b c d -> Builder
showbPolymorphicRecordPrec = showbPrec
showbMonomorphicInfixPrec :: Int -> MonomorphicInfix -> Builder
showbMonomorphicInfixPrec = showbPrec
showbPolymorphicInfixPrec :: (Show a, Show b, Show c)
=> Int -> PolymorphicInfix a b c -> Builder
showbPolymorphicInfixPrec = showbPrec
showbMonomorphicForallPrec :: Int -> MonomorphicForall -> Builder
showbMonomorphicForallPrec = showbPrec
showbPolymorphicForallPrec :: (Show a, Show b) => Int -> PolymorphicForall a b -> Builder
showbPolymorphicForallPrec = showbPrec
showbAllAtOncePrec :: (Show a, Show b, Show c, Show d)
=> Int -> AllAtOnce a b c d -> Builder
showbAllAtOncePrec = showbPrec
showbGADTPrec :: (Show a, Show b, Show c) => Int -> GADT a b c -> Builder
showbGADTPrec = showbPrec
showbPrimADTPrec# :: Show a => Int -> PrimADT# a -> Builder
showbPrimADTPrec# = showbPrec
showbLeftAssocTreePrec :: Show a => Int -> LeftAssocTree a -> Builder
showbLeftAssocTreePrec = showbPrec
showbRightAssocTreePrec :: Show a => Int -> RightAssocTree a -> Builder
showbRightAssocTreePrec = showbPrec
showbQuestionMarkPrec :: (Show a, Show b) => Int -> a :?: b -> Builder
showbQuestionMarkPrec = showbPrec
-- showbHigherKindedTypeParamsPrec :: Show (f a)
-- => Int -> HigherKindedTypeParams f a -> Builder
-- showbHigherKindedTypeParamsPrec = showbPrec
--
-- showbRestrictionPrec :: (Read a, Show a) => Int -> Restriction a -> Builder
-- showbRestrictionPrec = showbPrec
--
-- showbRestrictedContextPrec :: (Read a, Show a) => Int -> RestrictedContext a -> Builder
-- showbRestrictedContextPrec = showbPrec
--
-- showbFixPrec :: Show (f (Fix f)) => Int -> Fix f -> Builder
-- showbFixPrec = showbPrec
#if MIN_VERSION_template_haskell(2,7,0)
showbASNullary :: (Show c, Show d) => AllShow () () c d -> Builder
showbASNullary = showb
showbASUnaryPrec :: (Show b, Show c, Show d) => Int -> AllShow Int b c d -> Builder
showbASUnaryPrec = showbPrec
showbASProductPrec :: (Show c, Show d) => Int -> AllShow Bool Bool c d -> Builder
showbASProductPrec = showbPrec
showbASRecordPrec :: (Show c, Show d) => Int -> AllShow Char Double c d -> Builder
showbASRecordPrec = showbPrec
showbASInfixPrec :: (Show c, Show d) => Int -> AllShow Float Ordering c d -> Builder
showbASInfixPrec = showbPrec
showbNASShowPrec :: (Show b, Show d) => Int -> NotAllShow Int b Int d -> Builder
showbNASShowPrec = showbPrec
showbOneDataInstancePrec :: (Show a, Show b, Show c, Show d)
=> Int -> OneDataInstance a b c d -> Builder
showbOneDataInstancePrec = showbPrec
showbAssocData1Prec :: Int -> AssocData1 () -> Builder
showbAssocData1Prec = showbPrec
showbAssocData2Prec :: Int -> AssocData2 () Int Int -> Builder
showbAssocData2Prec = showbPrec
-- showbAssocData3Prec :: Int -> AssocData3 () b c -> Builder
-- showbAssocData3Prec = showbPrec
# if __GLASGOW_HASKELL__ >= 708
showbNullaryDataPrec :: Int -> NullaryData -> Builder
showbNullaryDataPrec = showbPrec
# endif
showbGADTFamPrec :: (Show a, Show b, Show c) => Int -> GADTFam a b c -> Builder
showbGADTFamPrec = showbPrec
#endif
-------------------------------------------------------------------------------
$(deriveShow ''Nullary)
instance Arbitrary Nullary where
arbitrary = pure Nullary
$(deriveShow ''PhantomNullary)
instance Arbitrary (PhantomNullary a) where
arbitrary = pure PhantomNullary
$(deriveShow ''MonomorphicUnary)
deriving instance Arbitrary MonomorphicUnary
$(deriveShow ''PolymorphicUnary)
deriving instance Arbitrary a => Arbitrary (PolymorphicUnary a b)
$(deriveShow ''MonomorphicProduct)
instance Arbitrary MonomorphicProduct where
arbitrary = MonomorphicProduct <$> arbitrary <*> arbitrary <*> arbitrary
$(deriveShow ''PolymorphicProduct)
instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (PolymorphicProduct a b c d) where
arbitrary = PolymorphicProduct <$> arbitrary <*> arbitrary <*> arbitrary
$(deriveShow ''MonomorphicRecord)
instance Arbitrary MonomorphicRecord where
arbitrary = MonomorphicRecord <$> arbitrary <*> arbitrary <*> arbitrary
$(deriveShow ''PolymorphicRecord)
instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (PolymorphicRecord a b c d) where
arbitrary = PolymorphicRecord <$> arbitrary <*> arbitrary <*> arbitrary
$(deriveShow ''MonomorphicInfix)
instance Arbitrary MonomorphicInfix where
arbitrary = (:/:) <$> arbitrary <*> arbitrary
$(deriveShow ''PolymorphicInfix)
instance (Arbitrary a, Arbitrary b) => Arbitrary (PolymorphicInfix a b c) where
arbitrary = PolyInf <$> arbitrary <*> arbitrary
$(deriveShow ''MonomorphicForall)
instance Arbitrary MonomorphicForall where
arbitrary = MonomorphicForall <$> (arbitrary :: Gen Int)
$(deriveShow ''PolymorphicForall)
instance Arbitrary a => Arbitrary (PolymorphicForall a b) where
arbitrary = PolymorphicForall <$> arbitrary <*> (arbitrary :: Gen Int)
$(deriveShow ''AllAtOnce)
instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (AllAtOnce a b c d) where
arbitrary = oneof [ pure AAONullary
, AAOUnary <$> arbitrary
, AAOProduct <$> arbitrary <*> arbitrary <*> arbitrary
, AAORecord <$> arbitrary <*> arbitrary <*> arbitrary
, (:/\:) <$> arbitrary <*> arbitrary
, AAOForall <$> arbitrary <*> arbitrary <*> (arbitrary :: Gen Int)
]
$(deriveShow ''GADT)
instance __OVERLAPPING__ Arbitrary (GADT Char b c) where
arbitrary = pure GADTCon1
instance __OVERLAPPING__ Arbitrary (GADT Double Double c) where
arbitrary = GADTCon2 <$> arbitrary
instance __OVERLAPPING__ Arbitrary (GADT Int String c) where
arbitrary = GADTCon3 <$> arbitrary
instance __OVERLAPPABLE__ Arbitrary a => Arbitrary (GADT a b c) where
arbitrary = GADTCon4 <$> arbitrary
instance __OVERLAPPING__ Arbitrary b => Arbitrary (GADT b b c) where
arbitrary = GADTCon5 <$> arbitrary
$(deriveShow ''PrimADT#)
instance Arbitrary (PrimADT# a) where
arbitrary = do
i@(I# i#) <- arbitrary
F# f# <- arbitrary
D# d# <- arbitrary
C# c# <- arbitrary
W# w# <- arbitrary
oneof $ map pure [ PrimNormal# i# f# d# c# w#
, PrimRecord# i# f# d# c# w#
, i# `PrimInfixIntegral#` w#
, f# `PrimInfixFloating#` d#
, c# `PrimInfixChar#` c#
, PrimForall# i i# f# d# c# w#
]
$(deriveShow ''LeftAssocTree)
instance Arbitrary a => Arbitrary (LeftAssocTree a) where
arbitrary = oneof [ LeftAssocLeaf <$> arbitrary
, (:<:) <$> (LeftAssocLeaf <$> arbitrary)
<*> (LeftAssocLeaf <$> arbitrary)
]
$(deriveShow ''RightAssocTree)
instance Arbitrary a => Arbitrary (RightAssocTree a) where
arbitrary = oneof [ RightAssocLeaf <$> arbitrary
, (:>:) <$> (RightAssocLeaf <$> arbitrary)
<*> (RightAssocLeaf <$> arbitrary)
]
$(deriveShow ''(:?:))
instance (Arbitrary a, Arbitrary b) => Arbitrary (a :?: b) where
arbitrary = (:?:) <$> arbitrary <*> arbitrary
instance Show (f a) => Show (HigherKindedTypeParams f a) where
showbPrec = $(mkShowbPrec ''HigherKindedTypeParams)
deriving instance Arbitrary (f a) => Arbitrary (HigherKindedTypeParams f a)
instance (Read a, Show a) => Show (Restriction a) where
showbPrec = $(mkShowbPrec ''Restriction)
deriving instance Arbitrary a => Arbitrary (Restriction a)
instance (Read a, Show a) => Show (RestrictedContext a) where
showbPrec = $(mkShowbPrec ''RestrictedContext)
deriving instance Arbitrary a => Arbitrary (RestrictedContext a)
instance Show (f (Fix f)) => Show (Fix f) where
showbPrec = $(mkShowbPrec ''Fix)
deriving instance Arbitrary (f (Fix f)) => Arbitrary (Fix f)
#if MIN_VERSION_template_haskell(2,7,0)
$(deriveShow ''AllShow)
instance Arbitrary (AllShow () () c d) where
arbitrary = pure ASNullary
deriving instance Arbitrary (AllShow Int b c d)
instance Arbitrary (AllShow Bool Bool c d) where
arbitrary = ASProduct <$> arbitrary <*> arbitrary
instance Arbitrary c => Arbitrary (AllShow Char Double c d) where
arbitrary = ASRecord <$> arbitrary <*> arbitrary <*> arbitrary
instance Arbitrary (AllShow Float Ordering c d) where
arbitrary = ASInfix <$> arbitrary <*> arbitrary
$(deriveShow 'NASShow1)
instance Arbitrary b => Arbitrary (NotAllShow Int b Int d) where
arbitrary = oneof [NASShow1 <$> arbitrary <*> arbitrary, NASShow2 <$> arbitrary]
$(deriveShow ''OneDataInstance)
instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (OneDataInstance a b c d) where
arbitrary = oneof [ pure ODINullary
, ODIUnary <$> arbitrary
, ODIProduct <$> arbitrary <*> arbitrary
, ODIRecord <$> arbitrary <*> arbitrary <*> arbitrary
, ODIInfix <$> arbitrary <*> arbitrary
]
$(deriveShow ''AssocData1)
deriving instance Arbitrary (AssocData1 ())
$(deriveShow 'AssocCon2)
deriving instance Arbitrary (AssocData2 () Int Int)
#if __GLASGOW_HASKELL__ >= 708
$(deriveShow 'NullaryCon)
deriving instance Arbitrary NullaryData
#endif
$(deriveShow 'GADTFamCon1)
instance __OVERLAPPING__ Arbitrary (GADTFam Char b c) where
arbitrary = pure GADTFamCon1
instance __OVERLAPPING__ Arbitrary (GADTFam Double Double c) where
arbitrary = GADTFamCon2 <$> arbitrary
instance __OVERLAPPING__ Arbitrary (GADTFam Int String c) where
arbitrary = GADTFamCon3 <$> arbitrary
instance __OVERLAPPABLE__ Arbitrary a => Arbitrary (GADTFam a b c) where
arbitrary = GADTFamCon4 <$> arbitrary
instance __OVERLAPPING__ Arbitrary b => Arbitrary (GADTFam b b c) where
arbitrary = GADTFamCon5 <$> arbitrary
#endif