Data/OldTypeable.hs

    {-# LANGUAGE Trustworthy #-}
    {-# LANGUAGE CPP
               , NoImplicitPrelude
               , OverlappingInstances
               , ScopedTypeVariables
               , FlexibleInstances
      #-}
    {-# OPTIONS_GHC -funbox-strict-fields -fno-warn-warnings-deprecations #-}

    -- The -XOverlappingInstances flag allows the user to over-ride
    -- the instances for Typeable given here.  In particular, we provide an instance
    --      instance ... => Typeable (s a)
    -- But a user might want to say
    --      instance ... => Typeable (MyType a b)

    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Data.Typeable
    -- Copyright   :  (c) The University of Glasgow, CWI 2001--2004
    -- License     :  BSD-style (see the file libraries/base/LICENSE)
    --
    -- Maintainer  :  libraries@haskell.org
    -- Stability   :  experimental
    -- Portability :  portable
    --
    -- This module defines the old, kind-monomorphic 'Typeable' class. It is now
    -- deprecated; users are recommended to use the kind-polymorphic
    -- "Data.Typeable" module instead.
    --
    -- /Since: 4.7.0.0/
    -----------------------------------------------------------------------------

    module Data.OldTypeable {-# DEPRECATED "Use Data.Typeable instead" #-} -- deprecated in 7.8
      (

            -- * The Typeable class
            Typeable( typeOf ),     -- :: a -> TypeRep

            -- * Type-safe cast
            cast,                   -- :: (Typeable a, Typeable b) => a -> Maybe b
            gcast,                  -- a generalisation of cast

            -- * Type representations
            TypeRep,        -- abstract, instance of: Eq, Show, Typeable
            showsTypeRep,

            TyCon,          -- abstract, instance of: Eq, Show, Typeable
            tyConString,    -- :: TyCon   -> String
            tyConPackage,   -- :: TyCon   -> String
            tyConModule,    -- :: TyCon   -> String
            tyConName,      -- :: TyCon   -> String

            -- * Construction of type representations
            mkTyCon,        -- :: String  -> TyCon
            mkTyCon3,       -- :: String  -> String -> String -> TyCon
            mkTyConApp,     -- :: TyCon   -> [TypeRep] -> TypeRep
            mkAppTy,        -- :: TypeRep -> TypeRep   -> TypeRep
            mkFunTy,        -- :: TypeRep -> TypeRep   -> TypeRep

            -- * Observation of type representations
            splitTyConApp,  -- :: TypeRep -> (TyCon, [TypeRep])
            funResultTy,    -- :: TypeRep -> TypeRep   -> Maybe TypeRep
            typeRepTyCon,   -- :: TypeRep -> TyCon
            typeRepArgs,    -- :: TypeRep -> [TypeRep]
            typeRepKey,     -- :: TypeRep -> IO TypeRepKey
            TypeRepKey,     -- abstract, instance of Eq, Ord

            -- * The other Typeable classes
            -- | /Note:/ The general instances are provided for GHC only.
            Typeable1( typeOf1 ),   -- :: t a -> TypeRep
            Typeable2( typeOf2 ),   -- :: t a b -> TypeRep
            Typeable3( typeOf3 ),   -- :: t a b c -> TypeRep
            Typeable4( typeOf4 ),   -- :: t a b c d -> TypeRep
            Typeable5( typeOf5 ),   -- :: t a b c d e -> TypeRep
            Typeable6( typeOf6 ),   -- :: t a b c d e f -> TypeRep
            Typeable7( typeOf7 ),   -- :: t a b c d e f g -> TypeRep
            gcast1,                 -- :: ... => c (t a) -> Maybe (c (t' a))
            gcast2,                 -- :: ... => c (t a b) -> Maybe (c (t' a b))

            -- * Default instances
            -- | /Note:/ These are not needed by GHC, for which these instances
            -- are generated by general instance declarations.
            typeOfDefault,  -- :: (Typeable1 t, Typeable a) => t a -> TypeRep
            typeOf1Default, -- :: (Typeable2 t, Typeable a) => t a b -> TypeRep
            typeOf2Default, -- :: (Typeable3 t, Typeable a) => t a b c -> TypeRep
            typeOf3Default, -- :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep
            typeOf4Default, -- :: (Typeable5 t, Typeable a) => t a b c d e -> TypeRep
            typeOf5Default, -- :: (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep
            typeOf6Default  -- :: (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep

      ) where

    import Data.OldTypeable.Internal hiding (mkTyCon)

    import Unsafe.Coerce
    import Data.Maybe

    import GHC.Base

    import GHC.Fingerprint.Type
    import GHC.Fingerprint

    #include "OldTypeable.h"

    {-# DEPRECATED typeRepKey "TypeRep itself is now an instance of Ord" #-} -- deprecated in 7.2
    -- | (DEPRECATED) Returns a unique key associated with a 'TypeRep'.
    -- This function is deprecated because 'TypeRep' itself is now an
    -- instance of 'Ord', so mappings can be made directly with 'TypeRep'
    -- as the key.
    --
    typeRepKey :: TypeRep -> IO TypeRepKey
    typeRepKey (TypeRep f _ _) = return (TypeRepKey f)

            --
            -- let fTy = mkTyCon "Foo" in show (mkTyConApp (mkTyCon ",,")
            --                                 [fTy,fTy,fTy])
            --
            -- returns "(Foo,Foo,Foo)"
            --
            -- The TypeRep Show instance promises to print tuple types
            -- correctly. Tuple type constructors are specified by a
            -- sequence of commas, e.g., (mkTyCon ",,,,") returns
            -- the 5-tuple tycon.

    newtype TypeRepKey = TypeRepKey Fingerprint
      deriving (Eq,Ord)

    ----------------- Construction ---------------------

    {-# DEPRECATED mkTyCon "either derive Typeable, or use mkTyCon3 instead" #-} -- deprecated in 7.2
    -- | Backwards-compatible API
    mkTyCon :: String       -- ^ unique string
            -> TyCon        -- ^ A unique 'TyCon' object
    mkTyCon name = TyCon (fingerprintString name) "" "" name

    -------------------------------------------------------------
    --
    --              Type-safe cast
    --
    -------------------------------------------------------------

    -- | The type-safe cast operation
    cast :: (Typeable a, Typeable b) => a -> Maybe b
    cast x = r
           where
             r = if typeOf x == typeOf (fromJust r)
                   then Just $ unsafeCoerce x
                   else Nothing

    -- | A flexible variation parameterised in a type constructor
    gcast :: (Typeable a, Typeable b) => c a -> Maybe (c b)
    gcast x = r
     where
      r = if typeOf (getArg x) == typeOf (getArg (fromJust r))
            then Just $ unsafeCoerce x
            else Nothing
      getArg :: c x -> x
      getArg = undefined

    -- | Cast for * -> *
    gcast1 :: (Typeable1 t, Typeable1 t') => c (t a) -> Maybe (c (t' a))
    gcast1 x = r
     where
      r = if typeOf1 (getArg x) == typeOf1 (getArg (fromJust r))
           then Just $ unsafeCoerce x
           else Nothing
      getArg :: c x -> x
      getArg = undefined

    -- | Cast for * -> * -> *
    gcast2 :: (Typeable2 t, Typeable2 t') => c (t a b) -> Maybe (c (t' a b))
    gcast2 x = r
     where
      r = if typeOf2 (getArg x) == typeOf2 (getArg (fromJust r))
           then Just $ unsafeCoerce x
           else Nothing
      getArg :: c x -> x
      getArg = undefined