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