1{-# LANGUAGE CPP #-} 2#ifdef LANGUAGE_DeriveDataTypeable 3{-# LANGUAGE DeriveDataTypeable #-} 4#endif 5#if __GLASGOW_HASKELL__ >= 706 6{-# LANGUAGE PolyKinds #-} 7#endif 8#if __GLASGOW_HASKELL__ >= 702 9{-# LANGUAGE DeriveGeneric #-} 10#if __GLASGOW_HASKELL__ < 710 11{-# LANGUAGE Trustworthy #-} 12#endif 13#endif 14 15{-# OPTIONS_GHC -fno-warn-deprecations #-} 16---------------------------------------------------------------------------- 17-- | 18-- Module : Data.Tagged 19-- Copyright : 2009-2015 Edward Kmett 20-- License : BSD3 21-- 22-- Maintainer : Edward Kmett <ekmett@gmail.com> 23-- Stability : experimental 24-- Portability : portable 25-- 26------------------------------------------------------------------------------- 27 28module Data.Tagged 29 ( 30 -- * Tagged values 31 Tagged(..) 32 , retag 33 , untag 34 , tagSelf 35 , untagSelf 36 , asTaggedTypeOf 37 , witness 38 -- * Conversion 39 , proxy 40 , unproxy 41 , tagWith 42 -- * Proxy methods GHC dropped 43 , reproxy 44 ) where 45 46#if MIN_VERSION_base(4,8,0) 47import Control.Applicative (liftA2) 48#else 49import Control.Applicative ((<$>), liftA2, Applicative(..)) 50import Data.Traversable (Traversable(..)) 51import Data.Monoid 52#endif 53import Data.Bits 54import Data.Foldable (Foldable(..)) 55#ifdef MIN_VERSION_deepseq 56import Control.DeepSeq (NFData(..)) 57#endif 58#ifdef MIN_VERSION_transformers 59import Data.Functor.Classes ( Eq1(..), Ord1(..), Read1(..), Show1(..) 60# if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) 61 , Eq2(..), Ord2(..), Read2(..), Show2(..) 62# endif 63 ) 64#endif 65import Control.Monad (liftM) 66#if MIN_VERSION_base(4,8,0) 67import Data.Bifunctor 68#endif 69#if MIN_VERSION_base(4,10,0) 70import Data.Bifoldable (Bifoldable(..)) 71import Data.Bitraversable (Bitraversable(..)) 72#endif 73#ifdef __GLASGOW_HASKELL__ 74import Data.Data 75#endif 76import Data.Ix (Ix(..)) 77#if __GLASGOW_HASKELL__ < 707 78import Data.Proxy 79#endif 80#if MIN_VERSION_base(4,9,0) 81import Data.Semigroup (Semigroup(..)) 82#endif 83import Data.String (IsString(..)) 84import Foreign.Ptr (castPtr) 85import Foreign.Storable (Storable(..)) 86#if __GLASGOW_HASKELL__ >= 702 87import GHC.Generics (Generic) 88#if __GLASGOW_HASKELL__ >= 706 89import GHC.Generics (Generic1) 90#endif 91#endif 92 93-- | A @'Tagged' s b@ value is a value @b@ with an attached phantom type @s@. 94-- This can be used in place of the more traditional but less safe idiom of 95-- passing in an undefined value with the type, because unlike an @(s -> b)@, 96-- a @'Tagged' s b@ can't try to use the argument @s@ as a real value. 97-- 98-- Moreover, you don't have to rely on the compiler to inline away the extra 99-- argument, because the newtype is \"free\" 100-- 101-- 'Tagged' has kind @k -> * -> *@ if the compiler supports @PolyKinds@, therefore 102-- there is an extra @k@ showing in the instance haddocks that may cause confusion. 103newtype Tagged s b = Tagged { unTagged :: b } deriving 104 ( Eq, Ord, Ix, Bounded 105#if __GLASGOW_HASKELL__ >= 702 106 , Generic 107#if __GLASGOW_HASKELL__ >= 706 108 , Generic1 109#endif 110#endif 111 112#if __GLASGOW_HASKELL__ >= 707 113 , Typeable 114#endif 115 116 ) 117 118#ifdef __GLASGOW_HASKELL__ 119#if __GLASGOW_HASKELL__ < 707 120instance Typeable2 Tagged where 121 typeOf2 _ = mkTyConApp taggedTyCon [] 122 123taggedTyCon :: TyCon 124#if __GLASGOW_HASKELL__ < 704 125taggedTyCon = mkTyCon "Data.Tagged.Tagged" 126#else 127taggedTyCon = mkTyCon3 "tagged" "Data.Tagged" "Tagged" 128#endif 129 130#endif 131 132instance (Data s, Data b) => Data (Tagged s b) where 133 gfoldl f z (Tagged b) = z Tagged `f` b 134 toConstr _ = taggedConstr 135 gunfold k z c = case constrIndex c of 136 1 -> k (z Tagged) 137 _ -> error "gunfold" 138 dataTypeOf _ = taggedDataType 139 dataCast1 f = gcast1 f 140 dataCast2 f = gcast2 f 141 142taggedConstr :: Constr 143taggedConstr = mkConstr taggedDataType "Tagged" [] Prefix 144{-# INLINE taggedConstr #-} 145 146taggedDataType :: DataType 147taggedDataType = mkDataType "Data.Tagged.Tagged" [taggedConstr] 148{-# INLINE taggedDataType #-} 149#endif 150 151instance Show b => Show (Tagged s b) where 152 showsPrec n (Tagged b) = showParen (n > 10) $ 153 showString "Tagged " . 154 showsPrec 11 b 155 156instance Read b => Read (Tagged s b) where 157 readsPrec d = readParen (d > 10) $ \r -> 158 [(Tagged a, t) | ("Tagged", s) <- lex r, (a, t) <- readsPrec 11 s] 159 160#if MIN_VERSION_base(4,9,0) 161instance Semigroup a => Semigroup (Tagged s a) where 162 Tagged a <> Tagged b = Tagged (a <> b) 163 stimes n (Tagged a) = Tagged (stimes n a) 164 165instance (Semigroup a, Monoid a) => Monoid (Tagged s a) where 166 mempty = Tagged mempty 167 mappend = (<>) 168#else 169instance Monoid a => Monoid (Tagged s a) where 170 mempty = Tagged mempty 171 mappend (Tagged a) (Tagged b) = Tagged (mappend a b) 172#endif 173 174instance Functor (Tagged s) where 175 fmap f (Tagged x) = Tagged (f x) 176 {-# INLINE fmap #-} 177 178#if MIN_VERSION_base(4,8,0) 179-- this instance is provided by the bifunctors package for GHC<7.9 180instance Bifunctor Tagged where 181 bimap _ g (Tagged b) = Tagged (g b) 182 {-# INLINE bimap #-} 183#endif 184 185#if MIN_VERSION_base(4,10,0) 186-- these instances are provided by the bifunctors package for GHC<8.1 187instance Bifoldable Tagged where 188 bifoldMap _ g (Tagged b) = g b 189 {-# INLINE bifoldMap #-} 190 191instance Bitraversable Tagged where 192 bitraverse _ g (Tagged b) = Tagged <$> g b 193 {-# INLINE bitraverse #-} 194#endif 195 196#ifdef MIN_VERSION_deepseq 197instance NFData b => NFData (Tagged s b) where 198 rnf (Tagged b) = rnf b 199#endif 200 201#ifdef MIN_VERSION_transformers 202# if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,5,0)) 203instance Eq1 (Tagged s) where 204 eq1 = (==) 205 206instance Ord1 (Tagged s) where 207 compare1 = compare 208 209instance Read1 (Tagged s) where 210 readsPrec1 = readsPrec 211 212instance Show1 (Tagged s) where 213 showsPrec1 = showsPrec 214# else 215instance Eq1 (Tagged s) where 216 liftEq eq (Tagged a) (Tagged b) = eq a b 217 218instance Ord1 (Tagged s) where 219 liftCompare cmp (Tagged a) (Tagged b) = cmp a b 220 221instance Read1 (Tagged s) where 222 liftReadsPrec rp _ d = readParen (d > 10) $ \r -> 223 [(Tagged a, t) | ("Tagged", s) <- lex r, (a, t) <- rp 11 s] 224 225instance Show1 (Tagged s) where 226 liftShowsPrec sp _ n (Tagged b) = showParen (n > 10) $ 227 showString "Tagged " . 228 sp 11 b 229 230instance Eq2 Tagged where 231 liftEq2 _ eq (Tagged a) (Tagged b) = eq a b 232 233instance Ord2 Tagged where 234 liftCompare2 _ cmp (Tagged a) (Tagged b) = cmp a b 235 236instance Read2 Tagged where 237 liftReadsPrec2 _ _ rp _ d = readParen (d > 10) $ \r -> 238 [(Tagged a, t) | ("Tagged", s) <- lex r, (a, t) <- rp 11 s] 239 240instance Show2 Tagged where 241 liftShowsPrec2 _ _ sp _ n (Tagged b) = showParen (n > 10) $ 242 showString "Tagged " . 243 sp 11 b 244# endif 245#endif 246 247instance Applicative (Tagged s) where 248 pure = Tagged 249 {-# INLINE pure #-} 250 Tagged f <*> Tagged x = Tagged (f x) 251 {-# INLINE (<*>) #-} 252 _ *> n = n 253 {-# INLINE (*>) #-} 254 255instance Monad (Tagged s) where 256 return = pure 257 {-# INLINE return #-} 258 Tagged m >>= k = k m 259 {-# INLINE (>>=) #-} 260 (>>) = (*>) 261 {-# INLINE (>>) #-} 262 263instance Foldable (Tagged s) where 264 foldMap f (Tagged x) = f x 265 {-# INLINE foldMap #-} 266 fold (Tagged x) = x 267 {-# INLINE fold #-} 268 foldr f z (Tagged x) = f x z 269 {-# INLINE foldr #-} 270 foldl f z (Tagged x) = f z x 271 {-# INLINE foldl #-} 272 foldl1 _ (Tagged x) = x 273 {-# INLINE foldl1 #-} 274 foldr1 _ (Tagged x) = x 275 {-# INLINE foldr1 #-} 276 277instance Traversable (Tagged s) where 278 traverse f (Tagged x) = Tagged <$> f x 279 {-# INLINE traverse #-} 280 sequenceA (Tagged x) = Tagged <$> x 281 {-# INLINE sequenceA #-} 282 mapM f (Tagged x) = liftM Tagged (f x) 283 {-# INLINE mapM #-} 284 sequence (Tagged x) = liftM Tagged x 285 {-# INLINE sequence #-} 286 287instance Enum a => Enum (Tagged s a) where 288 succ = fmap succ 289 pred = fmap pred 290 toEnum = Tagged . toEnum 291 fromEnum (Tagged x) = fromEnum x 292 enumFrom (Tagged x) = map Tagged (enumFrom x) 293 enumFromThen (Tagged x) (Tagged y) = map Tagged (enumFromThen x y) 294 enumFromTo (Tagged x) (Tagged y) = map Tagged (enumFromTo x y) 295 enumFromThenTo (Tagged x) (Tagged y) (Tagged z) = 296 map Tagged (enumFromThenTo x y z) 297 298instance Num a => Num (Tagged s a) where 299 (+) = liftA2 (+) 300 (-) = liftA2 (-) 301 (*) = liftA2 (*) 302 negate = fmap negate 303 abs = fmap abs 304 signum = fmap signum 305 fromInteger = Tagged . fromInteger 306 307instance Real a => Real (Tagged s a) where 308 toRational (Tagged x) = toRational x 309 310instance Integral a => Integral (Tagged s a) where 311 quot = liftA2 quot 312 rem = liftA2 rem 313 div = liftA2 div 314 mod = liftA2 mod 315 quotRem (Tagged x) (Tagged y) = (Tagged a, Tagged b) where 316 (a, b) = quotRem x y 317 divMod (Tagged x) (Tagged y) = (Tagged a, Tagged b) where 318 (a, b) = divMod x y 319 toInteger (Tagged x) = toInteger x 320 321instance Fractional a => Fractional (Tagged s a) where 322 (/) = liftA2 (/) 323 recip = fmap recip 324 fromRational = Tagged . fromRational 325 326instance Floating a => Floating (Tagged s a) where 327 pi = Tagged pi 328 exp = fmap exp 329 log = fmap log 330 sqrt = fmap sqrt 331 sin = fmap sin 332 cos = fmap cos 333 tan = fmap tan 334 asin = fmap asin 335 acos = fmap acos 336 atan = fmap atan 337 sinh = fmap sinh 338 cosh = fmap cosh 339 tanh = fmap tanh 340 asinh = fmap asinh 341 acosh = fmap acosh 342 atanh = fmap atanh 343 (**) = liftA2 (**) 344 logBase = liftA2 logBase 345 346instance RealFrac a => RealFrac (Tagged s a) where 347 properFraction (Tagged x) = (a, Tagged b) where 348 (a, b) = properFraction x 349 truncate (Tagged x) = truncate x 350 round (Tagged x) = round x 351 ceiling (Tagged x) = ceiling x 352 floor (Tagged x) = floor x 353 354instance RealFloat a => RealFloat (Tagged s a) where 355 floatRadix (Tagged x) = floatRadix x 356 floatDigits (Tagged x) = floatDigits x 357 floatRange (Tagged x) = floatRange x 358 decodeFloat (Tagged x) = decodeFloat x 359 encodeFloat m n = Tagged (encodeFloat m n) 360 exponent (Tagged x) = exponent x 361 significand = fmap significand 362 scaleFloat n = fmap (scaleFloat n) 363 isNaN (Tagged x) = isNaN x 364 isInfinite (Tagged x) = isInfinite x 365 isDenormalized (Tagged x) = isDenormalized x 366 isNegativeZero (Tagged x) = isNegativeZero x 367 isIEEE (Tagged x) = isIEEE x 368 atan2 = liftA2 atan2 369 370instance Bits a => Bits (Tagged s a) where 371 Tagged a .&. Tagged b = Tagged (a .&. b) 372 Tagged a .|. Tagged b = Tagged (a .|. b) 373 xor (Tagged a) (Tagged b) = Tagged (xor a b) 374 complement (Tagged a) = Tagged (complement a) 375 shift (Tagged a) i = Tagged (shift a i) 376 shiftL (Tagged a) i = Tagged (shiftL a i) 377 shiftR (Tagged a) i = Tagged (shiftR a i) 378 rotate (Tagged a) i = Tagged (rotate a i) 379 rotateL (Tagged a) i = Tagged (rotateL a i) 380 rotateR (Tagged a) i = Tagged (rotateR a i) 381 bit i = Tagged (bit i) 382 setBit (Tagged a) i = Tagged (setBit a i) 383 clearBit (Tagged a) i = Tagged (clearBit a i) 384 complementBit (Tagged a) i = Tagged (complementBit a i) 385 testBit (Tagged a) i = testBit a i 386 isSigned (Tagged a) = isSigned a 387 bitSize (Tagged a) = bitSize a -- deprecated, but still required :( 388#if MIN_VERSION_base(4,5,0) 389 unsafeShiftL (Tagged a) i = Tagged (unsafeShiftL a i) 390 unsafeShiftR (Tagged a) i = Tagged (unsafeShiftR a i) 391 popCount (Tagged a) = popCount a 392#endif 393#if MIN_VERSION_base(4,7,0) 394 bitSizeMaybe (Tagged a) = bitSizeMaybe a 395 zeroBits = Tagged zeroBits 396#endif 397 398#if MIN_VERSION_base(4,7,0) 399instance FiniteBits a => FiniteBits (Tagged s a) where 400 finiteBitSize (Tagged a) = finiteBitSize a 401# if MIN_VERSION_base(4,8,0) 402 countLeadingZeros (Tagged a) = countLeadingZeros a 403 countTrailingZeros (Tagged a) = countTrailingZeros a 404# endif 405#endif 406 407instance IsString a => IsString (Tagged s a) where 408 fromString = Tagged . fromString 409 410instance Storable a => Storable (Tagged s a) where 411 sizeOf t = sizeOf a 412 where 413 Tagged a = Tagged undefined `asTypeOf` t 414 alignment t = alignment a 415 where 416 Tagged a = Tagged undefined `asTypeOf` t 417 peek ptr = Tagged <$> peek (castPtr ptr) 418 poke ptr (Tagged a) = poke (castPtr ptr) a 419 peekElemOff ptr i = Tagged <$> peekElemOff (castPtr ptr) i 420 pokeElemOff ptr i (Tagged a) = pokeElemOff (castPtr ptr) i a 421 peekByteOff ptr i = Tagged <$> peekByteOff (castPtr ptr) i 422 pokeByteOff ptr i (Tagged a) = pokeByteOff (castPtr ptr) i a 423 424-- | Some times you need to change the tag you have lying around. 425-- Idiomatic usage is to make a new combinator for the relationship between the 426-- tags that you want to enforce, and define that combinator using 'retag'. 427-- 428-- @ 429-- data Succ n 430-- retagSucc :: 'Tagged' n a -> 'Tagged' (Succ n) a 431-- retagSucc = 'retag' 432-- @ 433retag :: Tagged s b -> Tagged t b 434retag = Tagged . unTagged 435{-# INLINE retag #-} 436 437-- | Alias for 'unTagged' 438untag :: Tagged s b -> b 439untag = unTagged 440 441-- | Tag a value with its own type. 442tagSelf :: a -> Tagged a a 443tagSelf = Tagged 444{-# INLINE tagSelf #-} 445 446-- | 'asTaggedTypeOf' is a type-restricted version of 'const'. It is usually used as an infix operator, and its typing forces its first argument (which is usually overloaded) to have the same type as the tag of the second. 447asTaggedTypeOf :: s -> tagged s b -> s 448asTaggedTypeOf = const 449{-# INLINE asTaggedTypeOf #-} 450 451witness :: Tagged a b -> a -> b 452witness (Tagged b) _ = b 453{-# INLINE witness #-} 454 455-- | 'untagSelf' is a type-restricted version of 'untag'. 456untagSelf :: Tagged a a -> a 457untagSelf (Tagged x) = x 458{-# INLINE untagSelf #-} 459 460-- | Convert from a 'Tagged' representation to a representation 461-- based on a 'Proxy'. 462proxy :: Tagged s a -> proxy s -> a 463proxy (Tagged x) _ = x 464{-# INLINE proxy #-} 465 466-- | Convert from a representation based on a 'Proxy' to a 'Tagged' 467-- representation. 468unproxy :: (Proxy s -> a) -> Tagged s a 469unproxy f = Tagged (f Proxy) 470{-# INLINE unproxy #-} 471 472-- | Another way to convert a proxy to a tag. 473tagWith :: proxy s -> a -> Tagged s a 474tagWith _ = Tagged 475{-# INLINE tagWith #-} 476 477-- | Some times you need to change the proxy you have lying around. 478-- Idiomatic usage is to make a new combinator for the relationship 479-- between the proxies that you want to enforce, and define that 480-- combinator using 'reproxy'. 481-- 482-- @ 483-- data Succ n 484-- reproxySucc :: proxy n -> 'Proxy' (Succ n) 485-- reproxySucc = 'reproxy' 486-- @ 487reproxy :: proxy a -> Proxy b 488reproxy _ = Proxy 489