text-show-0.8: 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 #-}
#if __GLASGOW_HASKELL__ >= 711
-- The TH deriving mechanism isn't smart enough at the moment to eliminate
-- redundant constraints in Show instance declarations.
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
#endif
{-|
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
, showbNormalGADTPrec
, showbExistentialGADTPrec
, 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
import Derived
import GHC.Exts (Char(..), Double(..), Float(..), Int(..), Word(..))
import Prelude ()
import Prelude.Compat hiding (Show)
import Test.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
showbNormalGADTPrec :: Int -> NormalGADT -> Builder
showbNormalGADTPrec = showbPrec
showbExistentialGADTPrec :: (Show a, Show b, Show c) => Int -> ExistentialGADT a b c -> Builder
showbExistentialGADTPrec = 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
-- TODO: Uncomment when these type signatures are generated via Template Haskell
--
-- 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 b => Arbitrary (PolymorphicUnary a b)
$(deriveShow ''MonomorphicProduct)
instance Arbitrary MonomorphicProduct where
arbitrary = MonomorphicProduct <$> arbitrary <*> arbitrary <*> arbitrary
$(deriveShow ''PolymorphicProduct)
instance (Arbitrary a, Arbitrary b, Arbitrary d) => 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 d) => Arbitrary (PolymorphicRecord a b c d) where
arbitrary = (:%%%:) <$> arbitrary <*> arbitrary <*> arbitrary
$(deriveShow ''MonomorphicInfix)
instance Arbitrary MonomorphicInfix where
arbitrary = (:/:) <$> arbitrary <*> arbitrary
$(deriveShow ''PolymorphicInfix)
instance (Arbitrary a, Arbitrary c) => 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 ''NormalGADT)
instance Arbitrary NormalGADT where
arbitrary = oneof [ (:.) <$> arbitrary <*> arbitrary
, (:..) <$> arbitrary <*> arbitrary
]
$(deriveShow ''ExistentialGADT)
instance __OVERLAPPING__ Arbitrary (ExistentialGADT Char b c) where
arbitrary = pure GADTCon1
instance __OVERLAPPING__ Arbitrary (ExistentialGADT Double Double c) where
arbitrary = GADTCon2 <$> arbitrary
instance __OVERLAPPING__ Arbitrary (ExistentialGADT Int String c) where
arbitrary = GADTCon3 <$> arbitrary
instance __OVERLAPPABLE__ Arbitrary a => Arbitrary (ExistentialGADT a b c) where
arbitrary = GADTCon4 <$> arbitrary
instance __OVERLAPPING__ Arbitrary b => Arbitrary (ExistentialGADT 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