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