{-# LANGUAGE CPP #-}
#ifdef LANGUAGE_DeriveDataTypeable
{-# LANGUAGE DeriveDataTypeable #-}
#endif
#if __GLASGOW_HASKELL__ >= 706
{-# LANGUAGE PolyKinds #-}
#endif
#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE DeriveGeneric #-}
#if __GLASGOW_HASKELL__ < 710
{-# LANGUAGE Trustworthy #-}
#endif
#endif
{-# OPTIONS_GHC -fno-warn-deprecations #-}
module Data.Tagged
(
Tagged(..)
, retag
, untag
, tagSelf
, untagSelf
, asTaggedTypeOf
, witness
, proxy
, unproxy
, tagWith
, reproxy
) where
#if MIN_VERSION_base(4,8,0)
import Control.Applicative (liftA2)
#else
import Control.Applicative ((<$>), liftA2, Applicative(..))
import Data.Traversable (Traversable(..))
import Data.Monoid
#endif
import Data.Bits
import Data.Foldable (Foldable(..))
#ifdef MIN_VERSION_deepseq
import Control.DeepSeq (NFData(..))
#endif
#ifdef MIN_VERSION_transformers
import Data.Functor.Classes ( Eq1(..), Ord1(..), Read1(..), Show1(..)
# if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0)
, Eq2(..), Ord2(..), Read2(..), Show2(..)
# endif
)
#endif
import Control.Monad (liftM)
#if MIN_VERSION_base(4,8,0)
import Data.Bifunctor
#endif
#if MIN_VERSION_base(4,10,0)
import Data.Bifoldable (Bifoldable(..))
import Data.Bitraversable (Bitraversable(..))
#endif
#ifdef __GLASGOW_HASKELL__
import Data.Data
#endif
import Data.Ix (Ix(..))
#if __GLASGOW_HASKELL__ < 707
import Data.Proxy
#endif
#if MIN_VERSION_base(4,9,0)
import Data.Semigroup (Semigroup(..))
#endif
import Data.String (IsString(..))
import Foreign.Ptr (castPtr)
import Foreign.Storable (Storable(..))
#if __GLASGOW_HASKELL__ >= 702
import GHC.Generics (Generic)
#if __GLASGOW_HASKELL__ >= 706
import GHC.Generics (Generic1)
#endif
#endif
newtype Tagged s b = Tagged { unTagged :: b } deriving
( Eq, Ord, Ix, Bounded
#if __GLASGOW_HASKELL__ >= 702
, Generic
#if __GLASGOW_HASKELL__ >= 706
, Generic1
#endif
#endif
#if __GLASGOW_HASKELL__ >= 707
, Typeable
#endif
)
#ifdef __GLASGOW_HASKELL__
#if __GLASGOW_HASKELL__ < 707
instance Typeable2 Tagged where
typeOf2 _ = mkTyConApp taggedTyCon []
taggedTyCon :: TyCon
#if __GLASGOW_HASKELL__ < 704
taggedTyCon = mkTyCon "Data.Tagged.Tagged"
#else
taggedTyCon = mkTyCon3 "tagged" "Data.Tagged" "Tagged"
#endif
#endif
instance (Data s, Data b) => Data (Tagged s b) where
gfoldl f z (Tagged b) = z Tagged `f` b
toConstr _ = taggedConstr
gunfold k z c = case constrIndex c of
1 -> k (z Tagged)
_ -> error "gunfold"
dataTypeOf _ = taggedDataType
dataCast1 f = gcast1 f
dataCast2 f = gcast2 f
taggedConstr :: Constr
taggedConstr = mkConstr taggedDataType "Tagged" [] Prefix
{-# INLINE taggedConstr #-}
taggedDataType :: DataType
taggedDataType = mkDataType "Data.Tagged.Tagged" [taggedConstr]
{-# INLINE taggedDataType #-}
#endif
instance Show b => Show (Tagged s b) where
showsPrec n (Tagged b) = showParen (n > 10) $
showString "Tagged " .
showsPrec 11 b
instance Read b => Read (Tagged s b) where
readsPrec d = readParen (d > 10) $ \r ->
[(Tagged a, t) | ("Tagged", s) <- lex r, (a, t) <- readsPrec 11 s]
#if MIN_VERSION_base(4,9,0)
instance Semigroup a => Semigroup (Tagged s a) where
Tagged a <> Tagged b = Tagged (a <> b)
stimes n (Tagged a) = Tagged (stimes n a)
instance (Semigroup a, Monoid a) => Monoid (Tagged s a) where
mempty = Tagged mempty
mappend = (<>)
#else
instance Monoid a => Monoid (Tagged s a) where
mempty = Tagged mempty
mappend (Tagged a) (Tagged b) = Tagged (mappend a b)
#endif
instance Functor (Tagged s) where
fmap f (Tagged x) = Tagged (f x)
{-# INLINE fmap #-}
#if MIN_VERSION_base(4,8,0)
instance Bifunctor Tagged where
bimap _ g (Tagged b) = Tagged (g b)
{-# INLINE bimap #-}
#endif
#if MIN_VERSION_base(4,10,0)
instance Bifoldable Tagged where
bifoldMap _ g (Tagged b) = g b
{-# INLINE bifoldMap #-}
instance Bitraversable Tagged where
bitraverse _ g (Tagged b) = Tagged <$> g b
{-# INLINE bitraverse #-}
#endif
#ifdef MIN_VERSION_deepseq
instance NFData b => NFData (Tagged s b) where
rnf (Tagged b) = rnf b
#endif
#ifdef MIN_VERSION_transformers
# if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0))
instance Eq1 (Tagged s) where
eq1 = (==)
instance Ord1 (Tagged s) where
compare1 = compare
instance Read1 (Tagged s) where
readsPrec1 = readsPrec
instance Show1 (Tagged s) where
showsPrec1 = showsPrec
# else
instance Eq1 (Tagged s) where
liftEq eq (Tagged a) (Tagged b) = eq a b
instance Ord1 (Tagged s) where
liftCompare cmp (Tagged a) (Tagged b) = cmp a b
instance Read1 (Tagged s) where
liftReadsPrec rp _ d = readParen (d > 10) $ \r ->
[(Tagged a, t) | ("Tagged", s) <- lex r, (a, t) <- rp 11 s]
instance Show1 (Tagged s) where
liftShowsPrec sp _ n (Tagged b) = showParen (n > 10) $
showString "Tagged " .
sp 11 b
instance Eq2 Tagged where
liftEq2 _ eq (Tagged a) (Tagged b) = eq a b
instance Ord2 Tagged where
liftCompare2 _ cmp (Tagged a) (Tagged b) = cmp a b
instance Read2 Tagged where
liftReadsPrec2 _ _ rp _ d = readParen (d > 10) $ \r ->
[(Tagged a, t) | ("Tagged", s) <- lex r, (a, t) <- rp 11 s]
instance Show2 Tagged where
liftShowsPrec2 _ _ sp _ n (Tagged b) = showParen (n > 10) $
showString "Tagged " .
sp 11 b
# endif
#endif
instance Applicative (Tagged s) where
pure = Tagged
{-# INLINE pure #-}
Tagged f <*> Tagged x = Tagged (f x)
{-# INLINE (<*>) #-}
_ *> n = n
{-# INLINE (*>) #-}
instance Monad (Tagged s) where
return = pure
{-# INLINE return #-}
Tagged m >>= k = k m
{-# INLINE (>>=) #-}
(>>) = (*>)
{-# INLINE (>>) #-}
instance Foldable (Tagged s) where
foldMap f (Tagged x) = f x
{-# INLINE foldMap #-}
fold (Tagged x) = x
{-# INLINE fold #-}
foldr f z (Tagged x) = f x z
{-# INLINE foldr #-}
foldl f z (Tagged x) = f z x
{-# INLINE foldl #-}
foldl1 _ (Tagged x) = x
{-# INLINE foldl1 #-}
foldr1 _ (Tagged x) = x
{-# INLINE foldr1 #-}
instance Traversable (Tagged s) where
traverse f (Tagged x) = Tagged <$> f x
{-# INLINE traverse #-}
sequenceA (Tagged x) = Tagged <$> x
{-# INLINE sequenceA #-}
mapM f (Tagged x) = liftM Tagged (f x)
{-# INLINE mapM #-}
sequence (Tagged x) = liftM Tagged x
{-# INLINE sequence #-}
instance Enum a => Enum (Tagged s a) where
succ = fmap succ
pred = fmap pred
toEnum = Tagged . toEnum
fromEnum (Tagged x) = fromEnum x
enumFrom (Tagged x) = map Tagged (enumFrom x)
enumFromThen (Tagged x) (Tagged y) = map Tagged (enumFromThen x y)
enumFromTo (Tagged x) (Tagged y) = map Tagged (enumFromTo x y)
enumFromThenTo (Tagged x) (Tagged y) (Tagged z) =
map Tagged (enumFromThenTo x y z)
instance Num a => Num (Tagged s a) where
(+) = liftA2 (+)
(-) = liftA2 (-)
(*) = liftA2 (*)
negate = fmap negate
abs = fmap abs
signum = fmap signum
fromInteger = Tagged . fromInteger
instance Real a => Real (Tagged s a) where
toRational (Tagged x) = toRational x
instance Integral a => Integral (Tagged s a) where
quot = liftA2 quot
rem = liftA2 rem
div = liftA2 div
mod = liftA2 mod
quotRem (Tagged x) (Tagged y) = (Tagged a, Tagged b) where
(a, b) = quotRem x y
divMod (Tagged x) (Tagged y) = (Tagged a, Tagged b) where
(a, b) = divMod x y
toInteger (Tagged x) = toInteger x
instance Fractional a => Fractional (Tagged s a) where
(/) = liftA2 (/)
recip = fmap recip
fromRational = Tagged . fromRational
instance Floating a => Floating (Tagged s a) where
pi = Tagged pi
exp = fmap exp
log = fmap log
sqrt = fmap sqrt
sin = fmap sin
cos = fmap cos
tan = fmap tan
asin = fmap asin
acos = fmap acos
atan = fmap atan
sinh = fmap sinh
cosh = fmap cosh
tanh = fmap tanh
asinh = fmap asinh
acosh = fmap acosh
atanh = fmap atanh
(**) = liftA2 (**)
logBase = liftA2 logBase
instance RealFrac a => RealFrac (Tagged s a) where
properFraction (Tagged x) = (a, Tagged b) where
(a, b) = properFraction x
truncate (Tagged x) = truncate x
round (Tagged x) = round x
ceiling (Tagged x) = ceiling x
floor (Tagged x) = floor x
instance RealFloat a => RealFloat (Tagged s a) where
floatRadix (Tagged x) = floatRadix x
floatDigits (Tagged x) = floatDigits x
floatRange (Tagged x) = floatRange x
decodeFloat (Tagged x) = decodeFloat x
encodeFloat m n = Tagged (encodeFloat m n)
exponent (Tagged x) = exponent x
significand = fmap significand
scaleFloat n = fmap (scaleFloat n)
isNaN (Tagged x) = isNaN x
isInfinite (Tagged x) = isInfinite x
isDenormalized (Tagged x) = isDenormalized x
isNegativeZero (Tagged x) = isNegativeZero x
isIEEE (Tagged x) = isIEEE x
atan2 = liftA2 atan2
instance Bits a => Bits (Tagged s a) where
Tagged a .&. Tagged b = Tagged (a .&. b)
Tagged a .|. Tagged b = Tagged (a .|. b)
xor (Tagged a) (Tagged b) = Tagged (xor a b)
complement (Tagged a) = Tagged (complement a)
shift (Tagged a) i = Tagged (shift a i)
shiftL (Tagged a) i = Tagged (shiftL a i)
shiftR (Tagged a) i = Tagged (shiftR a i)
rotate (Tagged a) i = Tagged (rotate a i)
rotateL (Tagged a) i = Tagged (rotateL a i)
rotateR (Tagged a) i = Tagged (rotateR a i)
bit i = Tagged (bit i)
setBit (Tagged a) i = Tagged (setBit a i)
clearBit (Tagged a) i = Tagged (clearBit a i)
complementBit (Tagged a) i = Tagged (complementBit a i)
testBit (Tagged a) i = testBit a i
isSigned (Tagged a) = isSigned a
bitSize (Tagged a) = bitSize a
#if MIN_VERSION_base(4,5,0)
unsafeShiftL (Tagged a) i = Tagged (unsafeShiftL a i)
unsafeShiftR (Tagged a) i = Tagged (unsafeShiftR a i)
popCount (Tagged a) = popCount a
#endif
#if MIN_VERSION_base(4,7,0)
bitSizeMaybe (Tagged a) = bitSizeMaybe a
zeroBits = Tagged zeroBits
#endif
#if MIN_VERSION_base(4,7,0)
instance FiniteBits a => FiniteBits (Tagged s a) where
finiteBitSize (Tagged a) = finiteBitSize a
# if MIN_VERSION_base(4,8,0)
countLeadingZeros (Tagged a) = countLeadingZeros a
countTrailingZeros (Tagged a) = countTrailingZeros a
# endif
#endif
instance IsString a => IsString (Tagged s a) where
fromString = Tagged . fromString
instance Storable a => Storable (Tagged s a) where
sizeOf t = sizeOf a
where
Tagged a = Tagged undefined `asTypeOf` t
alignment t = alignment a
where
Tagged a = Tagged undefined `asTypeOf` t
peek ptr = Tagged <$> peek (castPtr ptr)
poke ptr (Tagged a) = poke (castPtr ptr) a
peekElemOff ptr i = Tagged <$> peekElemOff (castPtr ptr) i
pokeElemOff ptr i (Tagged a) = pokeElemOff (castPtr ptr) i a
peekByteOff ptr i = Tagged <$> peekByteOff (castPtr ptr) i
pokeByteOff ptr i (Tagged a) = pokeByteOff (castPtr ptr) i a
retag :: Tagged s b -> Tagged t b
retag = Tagged . unTagged
{-# INLINE retag #-}
untag :: Tagged s b -> b
untag = unTagged
tagSelf :: a -> Tagged a a
tagSelf = Tagged
{-# INLINE tagSelf #-}
asTaggedTypeOf :: s -> tagged s b -> s
asTaggedTypeOf = const
{-# INLINE asTaggedTypeOf #-}
witness :: Tagged a b -> a -> b
witness (Tagged b) _ = b
{-# INLINE witness #-}
untagSelf :: Tagged a a -> a
untagSelf (Tagged x) = x
{-# INLINE untagSelf #-}
proxy :: Tagged s a -> proxy s -> a
proxy (Tagged x) _ = x
{-# INLINE proxy #-}
unproxy :: (Proxy s -> a) -> Tagged s a
unproxy f = Tagged (f Proxy)
{-# INLINE unproxy #-}
tagWith :: proxy s -> a -> Tagged s a
tagWith _ = Tagged
{-# INLINE tagWith #-}
reproxy :: proxy a -> Proxy b
reproxy _ = Proxy