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