fix warnings (including moving things around to avoid orphan
authorSimon Marlow <marlowsd@gmail.com>
Mon, 11 Jul 2011 11:59:49 +0000 (12:59 +0100)
committerSimon Marlow <marlowsd@gmail.com>
Mon, 11 Jul 2011 11:59:49 +0000 (12:59 +0100)
instances)

Data/Typeable.hs
Data/Typeable.hs-boot
Data/Typeable/Internal.hs
Data/Typeable/Internal.hs-boot
Foreign/Storable.hs
GHC/Fingerprint.hs

index c8ad3cf..688c2aa 100644 (file)
@@ -6,9 +6,6 @@
            , FlexibleInstances
   #-}
 {-# OPTIONS_GHC -funbox-strict-fields #-}
-#ifdef __GLASGOW_HASKELL__
-{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
-#endif
 
 -- The -XOverlappingInstances flag allows the user to over-ride
 -- the instances for Typeable given here.  In particular, we provide an instance
@@ -96,35 +93,12 @@ module Data.Typeable
 
 import Data.Typeable.Internal hiding (mkTyCon)
 
-import qualified Data.HashTable as HT
-import Data.Maybe
-import Data.Int
-import Data.Word
-import Data.List( foldl, intersperse )
 import Unsafe.Coerce
+import Data.Maybe
 
 #ifdef __GLASGOW_HASKELL__
 import GHC.Base
-import GHC.Show         (Show(..), ShowS,
-                         shows, showString, showChar, showParen)
 import GHC.Err          (undefined)
-import GHC.Num          (Integer, (+))
-import GHC.Real         ( rem, Ratio )
-import GHC.IORef        (IORef,newIORef)
-import GHC.IO           (mask_, unsafePerformIO)
-
--- These imports are so we can define Typeable instances
--- It'd be better to give Typeable instances in the modules themselves
--- but they all have to be compiled before Typeable
-import GHC.IOArray
-import GHC.MVar
-import GHC.ST           ( ST )
-import GHC.STRef        ( STRef )
-import GHC.Ptr          ( Ptr, FunPtr )
-import GHC.Stable       ( StablePtr, newStablePtr, freeStablePtr,
-                          deRefStablePtr, castStablePtrToPtr,
-                          castPtrToStablePtr )
-import GHC.Arr          ( Array, STArray )
 
 import GHC.Fingerprint.Type
 import {-# SOURCE #-} GHC.Fingerprint
@@ -184,69 +158,7 @@ typeRepKey (TypeRep f _ _) = return (TypeRepKey f)
 newtype TypeRepKey = TypeRepKey Fingerprint
   deriving (Eq,Ord)
 
------------------ Construction --------------------
-
--- | Applies a type constructor to a sequence of types
-mkTyConApp  :: TyCon -> [TypeRep] -> TypeRep
-mkTyConApp tc@(TyCon tc_k _ _ _) []
-  = TypeRep tc_k tc [] -- optimisation: all derived Typeable instances
-                       -- end up here, and it helps generate smaller
-                       -- code for derived Typeable.
-mkTyConApp tc@(TyCon tc_k _ _ _) args
-  = TypeRep (fingerprintFingerprints (tc_k : arg_ks)) tc args
-  where
-    arg_ks = [k | TypeRep k _ _ <- args]
-
--- | A special case of 'mkTyConApp', which applies the function 
--- type constructor to a pair of types.
-mkFunTy  :: TypeRep -> TypeRep -> TypeRep
-mkFunTy f a = mkTyConApp funTc [f,a]
-
--- | Splits a type constructor application
-splitTyConApp :: TypeRep -> (TyCon,[TypeRep])
-splitTyConApp (TypeRep _ tc trs) = (tc,trs)
-
--- | Applies a type to a function type.  Returns: @'Just' u@ if the
--- first argument represents a function of type @t -> u@ and the
--- second argument represents a function of type @t@.  Otherwise,
--- returns 'Nothing'.
-funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep
-funResultTy trFun trArg
-  = case splitTyConApp trFun of
-      (tc, [t1,t2]) | tc == funTc && t1 == trArg -> Just t2
-      _ -> Nothing
-
--- | Adds a TypeRep argument to a TypeRep.
-mkAppTy :: TypeRep -> TypeRep -> TypeRep
-mkAppTy (TypeRep tr_k tc trs) arg_tr
-  = let (TypeRep arg_k _ _) = arg_tr
-     in  TypeRep (fingerprintFingerprints [tr_k,arg_k]) tc (trs++[arg_tr])
-
--- If we enforce the restriction that there is only one
--- @TyCon@ for a type & it is shared among all its uses,
--- we can map them onto Ints very simply. The benefit is,
--- of course, that @TyCon@s can then be compared efficiently.
-
--- Provided the implementor of other @Typeable@ instances
--- takes care of making all the @TyCon@s CAFs (toplevel constants),
--- this will work. 
-
--- If this constraint does turn out to be a sore thumb, changing
--- the Eq instance for TyCons is trivial.
-
--- | Builds a 'TyCon' object representing a type constructor.  An
--- implementation of "Data.Typeable" should ensure that the following holds:
---
--- >  A==A' ^ B==B' ^ C==C' ==> mkTyCon A B C == mkTyCon A' B' C'
---
-
---
-mkTyCon3 :: String       -- ^ package name
-         -> String       -- ^ module name
-         -> String       -- ^ the name of the type constructor
-         -> TyCon        -- ^ A unique 'TyCon' object
-mkTyCon3 pkg modl name =
-  TyCon (fingerprintString (pkg++modl++name)) pkg modl name
+----------------- Construction ---------------------
 
 {-# DEPRECATED mkTyCon "use mkTyCon3 instead" #-}
 -- | Backwards-compatible API
@@ -254,283 +166,6 @@ mkTyCon :: String       -- ^ unique string
         -> TyCon        -- ^ A unique 'TyCon' object
 mkTyCon name = TyCon (fingerprintString name) "" "" name
 
------------------ Observation ---------------------
-
--- | Observe the type constructor of a type representation
-typeRepTyCon :: TypeRep -> TyCon
-typeRepTyCon (TypeRep _ tc _) = tc
-
--- | Observe the argument types of a type representation
-typeRepArgs :: TypeRep -> [TypeRep]
-typeRepArgs (TypeRep _ _ args) = args
-
--- | Observe string encoding of a type representation
-tyConString :: TyCon   -> String
-tyConString = tyConName
-
------------------ Showing TypeReps --------------------
-
-instance Show TypeRep where
-  showsPrec p (TypeRep _ tycon tys) =
-    case tys of
-      [] -> showsPrec p tycon
-      [x]   | tycon == listTc -> showChar '[' . shows x . showChar ']'
-      [a,r] | tycon == funTc  -> showParen (p > 8) $
-                                 showsPrec 9 a .
-                                 showString " -> " .
-                                 showsPrec 8 r
-      xs | isTupleTyCon tycon -> showTuple xs
-         | otherwise         ->
-            showParen (p > 9) $
-            showsPrec p tycon . 
-            showChar ' '      . 
-            showArgs tys
-
-showsTypeRep :: TypeRep -> ShowS
-showsTypeRep = shows
-
-instance Show TyCon where
-  showsPrec _ t = showString (tyConName t)
-
-isTupleTyCon :: TyCon -> Bool
-isTupleTyCon (TyCon _ _ _ ('(':',':_)) = True
-isTupleTyCon _                         = False
-
--- Some (Show.TypeRep) helpers:
-
-showArgs :: Show a => [a] -> ShowS
-showArgs [] = id
-showArgs [a] = showsPrec 10 a
-showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as 
-
-showTuple :: [TypeRep] -> ShowS
-showTuple args = showChar '('
-               . (foldr (.) id $ intersperse (showChar ',') 
-                               $ map (showsPrec 10) args)
-               . showChar ')'
-
--------------------------------------------------------------
---
---      The Typeable class and friends
---
--------------------------------------------------------------
-
-{- Note [Memoising typeOf]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-IMPORTANT: we don't want to recalculate the type-rep once per
-call to the dummy argument.  This is what went wrong in Trac #3245
-So we help GHC by manually keeping the 'rep' *outside* the value 
-lambda, thus
-    
-    typeOfDefault :: forall t a. (Typeable1 t, Typeable a) => t a -> TypeRep
-    typeOfDefault = \_ -> rep
-      where
-        rep = typeOf1 (undefined :: t a) `mkAppTy` 
-              typeOf  (undefined :: a)
-
-Notice the crucial use of scoped type variables here!
--}
-
--- | The class 'Typeable' allows a concrete representation of a type to
--- be calculated.
-class Typeable a where
-  typeOf :: a -> TypeRep
-  -- ^ Takes a value of type @a@ and returns a concrete representation
-  -- of that type.  The /value/ of the argument should be ignored by
-  -- any instance of 'Typeable', so that it is safe to pass 'undefined' as
-  -- the argument.
-
--- | Variant for unary type constructors
-class Typeable1 t where
-  typeOf1 :: t a -> TypeRep
-
-#ifdef __GLASGOW_HASKELL__
--- | For defining a 'Typeable' instance from any 'Typeable1' instance.
-typeOfDefault :: forall t a. (Typeable1 t, Typeable a) => t a -> TypeRep
-typeOfDefault = \_ -> rep
- where
-   rep = typeOf1 (undefined :: t a) `mkAppTy` 
-         typeOf  (undefined :: a)
-   -- Note [Memoising typeOf]
-#else
--- | For defining a 'Typeable' instance from any 'Typeable1' instance.
-typeOfDefault :: (Typeable1 t, Typeable a) => t a -> TypeRep
-typeOfDefault x = typeOf1 x `mkAppTy` typeOf (argType x)
- where
-   argType :: t a -> a
-   argType = undefined
-#endif
-
--- | Variant for binary type constructors
-class Typeable2 t where
-  typeOf2 :: t a b -> TypeRep
-
-#ifdef __GLASGOW_HASKELL__
--- | For defining a 'Typeable1' instance from any 'Typeable2' instance.
-typeOf1Default :: forall t a b. (Typeable2 t, Typeable a) => t a b -> TypeRep
-typeOf1Default = \_ -> rep 
- where
-   rep = typeOf2 (undefined :: t a b) `mkAppTy` 
-         typeOf  (undefined :: a)
-   -- Note [Memoising typeOf]
-#else
--- | For defining a 'Typeable1' instance from any 'Typeable2' instance.
-typeOf1Default :: (Typeable2 t, Typeable a) => t a b -> TypeRep
-typeOf1Default x = typeOf2 x `mkAppTy` typeOf (argType x)
- where
-   argType :: t a b -> a
-   argType = undefined
-#endif
-
--- | Variant for 3-ary type constructors
-class Typeable3 t where
-  typeOf3 :: t a b c -> TypeRep
-
-#ifdef __GLASGOW_HASKELL__
--- | For defining a 'Typeable2' instance from any 'Typeable3' instance.
-typeOf2Default :: forall t a b c. (Typeable3 t, Typeable a) => t a b c -> TypeRep
-typeOf2Default = \_ -> rep 
- where
-   rep = typeOf3 (undefined :: t a b c) `mkAppTy` 
-         typeOf  (undefined :: a)
-   -- Note [Memoising typeOf]
-#else
--- | For defining a 'Typeable2' instance from any 'Typeable3' instance.
-typeOf2Default :: (Typeable3 t, Typeable a) => t a b c -> TypeRep
-typeOf2Default x = typeOf3 x `mkAppTy` typeOf (argType x)
- where
-   argType :: t a b c -> a
-   argType = undefined
-#endif
-
--- | Variant for 4-ary type constructors
-class Typeable4 t where
-  typeOf4 :: t a b c d -> TypeRep
-
-#ifdef __GLASGOW_HASKELL__
--- | For defining a 'Typeable3' instance from any 'Typeable4' instance.
-typeOf3Default :: forall t a b c d. (Typeable4 t, Typeable a) => t a b c d -> TypeRep
-typeOf3Default = \_ -> rep
- where
-   rep = typeOf4 (undefined :: t a b c d) `mkAppTy` 
-         typeOf  (undefined :: a)
-   -- Note [Memoising typeOf]
-#else
--- | For defining a 'Typeable3' instance from any 'Typeable4' instance.
-typeOf3Default :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep
-typeOf3Default x = typeOf4 x `mkAppTy` typeOf (argType x)
- where
-   argType :: t a b c d -> a
-   argType = undefined
-#endif
-   
--- | Variant for 5-ary type constructors
-class Typeable5 t where
-  typeOf5 :: t a b c d e -> TypeRep
-
-#ifdef __GLASGOW_HASKELL__
--- | For defining a 'Typeable4' instance from any 'Typeable5' instance.
-typeOf4Default :: forall t a b c d e. (Typeable5 t, Typeable a) => t a b c d e -> TypeRep
-typeOf4Default = \_ -> rep 
- where
-   rep = typeOf5 (undefined :: t a b c d e) `mkAppTy` 
-         typeOf  (undefined :: a)
-   -- Note [Memoising typeOf]
-#else
--- | For defining a 'Typeable4' instance from any 'Typeable5' instance.
-typeOf4Default :: (Typeable5 t, Typeable a) => t a b c d e -> TypeRep
-typeOf4Default x = typeOf5 x `mkAppTy` typeOf (argType x)
- where
-   argType :: t a b c d e -> a
-   argType = undefined
-#endif
-
--- | Variant for 6-ary type constructors
-class Typeable6 t where
-  typeOf6 :: t a b c d e f -> TypeRep
-
-#ifdef __GLASGOW_HASKELL__
--- | For defining a 'Typeable5' instance from any 'Typeable6' instance.
-typeOf5Default :: forall t a b c d e f. (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep
-typeOf5Default = \_ -> rep
- where
-   rep = typeOf6 (undefined :: t a b c d e f) `mkAppTy` 
-         typeOf  (undefined :: a)
-   -- Note [Memoising typeOf]
-#else
--- | For defining a 'Typeable5' instance from any 'Typeable6' instance.
-typeOf5Default :: (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep
-typeOf5Default x = typeOf6 x `mkAppTy` typeOf (argType x)
- where
-   argType :: t a b c d e f -> a
-   argType = undefined
-#endif
-
--- | Variant for 7-ary type constructors
-class Typeable7 t where
-  typeOf7 :: t a b c d e f g -> TypeRep
-
-#ifdef __GLASGOW_HASKELL__
--- | For defining a 'Typeable6' instance from any 'Typeable7' instance.
-typeOf6Default :: forall t a b c d e f g. (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep
-typeOf6Default = \_ -> rep
- where
-   rep = typeOf7 (undefined :: t a b c d e f g) `mkAppTy` 
-         typeOf  (undefined :: a)
-   -- Note [Memoising typeOf]
-#else
--- | For defining a 'Typeable6' instance from any 'Typeable7' instance.
-typeOf6Default :: (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep
-typeOf6Default x = typeOf7 x `mkAppTy` typeOf (argType x)
- where
-   argType :: t a b c d e f g -> a
-   argType = undefined
-#endif
-
-#ifdef __GLASGOW_HASKELL__
--- Given a @Typeable@/n/ instance for an /n/-ary type constructor,
--- define the instances for partial applications.
--- Programmers using non-GHC implementations must do this manually
--- for each type constructor.
--- (The INSTANCE_TYPEABLE/n/ macros in Typeable.h include this.)
-
--- | One Typeable instance for all Typeable1 instances
-instance (Typeable1 s, Typeable a)
-       => Typeable (s a) where
-  typeOf = typeOfDefault
-
--- | One Typeable1 instance for all Typeable2 instances
-instance (Typeable2 s, Typeable a)
-       => Typeable1 (s a) where
-  typeOf1 = typeOf1Default
-
--- | One Typeable2 instance for all Typeable3 instances
-instance (Typeable3 s, Typeable a)
-       => Typeable2 (s a) where
-  typeOf2 = typeOf2Default
-
--- | One Typeable3 instance for all Typeable4 instances
-instance (Typeable4 s, Typeable a)
-       => Typeable3 (s a) where
-  typeOf3 = typeOf3Default
-
--- | One Typeable4 instance for all Typeable5 instances
-instance (Typeable5 s, Typeable a)
-       => Typeable4 (s a) where
-  typeOf4 = typeOf4Default
-
--- | One Typeable5 instance for all Typeable6 instances
-instance (Typeable6 s, Typeable a)
-       => Typeable5 (s a) where
-  typeOf5 = typeOf5Default
-
--- | One Typeable6 instance for all Typeable7 instances
-instance (Typeable7 s, Typeable a)
-       => Typeable6 (s a) where
-  typeOf6 = typeOf6Default
-
-#endif /* __GLASGOW_HASKELL__ */
-
 -------------------------------------------------------------
 --
 --              Type-safe cast
@@ -575,114 +210,3 @@ gcast2 x = r
   getArg :: c x -> x 
   getArg = undefined
 
--------------------------------------------------------------
---
---      Instances of the Typeable classes for Prelude types
---
--------------------------------------------------------------
-
-INSTANCE_TYPEABLE0((),unitTc,"()")
-INSTANCE_TYPEABLE1([],listTc,"[]")
-#if defined(__GLASGOW_HASKELL__)
-listTc :: TyCon
-listTc = typeRepTyCon (typeOf [()])
-#endif
-INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe")
-INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio")
-#if defined(__GLASGOW_HASKELL__)
-{-
-TODO: Deriving this instance fails with:
-libraries/base/Data/Typeable.hs:589:1:
-    Can't make a derived instance of `Typeable2 (->)':
-      The last argument of the instance must be a data or newtype application
-    In the stand-alone deriving instance for `Typeable2 (->)'
--}
-instance Typeable2 (->) where { typeOf2 _ = mkTyConApp funTc [] }
-funTc :: TyCon
-funTc = mkTyCon3 "ghc-prim" "GHC.Types" "->"
-#else
-INSTANCE_TYPEABLE2((->),funTc,"->")
-#endif
-INSTANCE_TYPEABLE1(IO,ioTc,"IO")
-
-#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
--- Types defined in GHC.MVar
-INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" )
-#endif
-
-INSTANCE_TYPEABLE2(Array,arrayTc,"Array")
-INSTANCE_TYPEABLE2(IOArray,iOArrayTc,"IOArray")
-
-#ifdef __GLASGOW_HASKELL__
--- Hugs has these too, but their Typeable<n> instances are defined
--- elsewhere to keep this module within Haskell 98.
--- This is important because every invocation of runhugs or ffihugs
--- uses this module via Data.Dynamic.
-INSTANCE_TYPEABLE2(ST,stTc,"ST")
-INSTANCE_TYPEABLE2(STRef,stRefTc,"STRef")
-INSTANCE_TYPEABLE3(STArray,sTArrayTc,"STArray")
-#endif
-
-#ifndef __NHC__
-INSTANCE_TYPEABLE2((,),pairTc,"(,)")
-INSTANCE_TYPEABLE3((,,),tup3Tc,"(,,)")
-INSTANCE_TYPEABLE4((,,,),tup4Tc,"(,,,)")
-INSTANCE_TYPEABLE5((,,,,),tup5Tc,"(,,,,)")
-INSTANCE_TYPEABLE6((,,,,,),tup6Tc,"(,,,,,)")
-INSTANCE_TYPEABLE7((,,,,,,),tup7Tc,"(,,,,,,)")
-#endif /* __NHC__ */
-
-INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr")
-INSTANCE_TYPEABLE1(FunPtr,funPtrTc,"FunPtr")
-#ifndef __GLASGOW_HASKELL__
-INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr")
-#endif
-INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr")
-INSTANCE_TYPEABLE1(IORef,iORefTc,"IORef")
-
--------------------------------------------------------
---
--- Generate Typeable instances for standard datatypes
---
--------------------------------------------------------
-
-INSTANCE_TYPEABLE0(Bool,boolTc,"Bool")
-INSTANCE_TYPEABLE0(Char,charTc,"Char")
-INSTANCE_TYPEABLE0(Float,floatTc,"Float")
-INSTANCE_TYPEABLE0(Double,doubleTc,"Double")
-INSTANCE_TYPEABLE0(Int,intTc,"Int")
-#ifndef __NHC__
-INSTANCE_TYPEABLE0(Word,wordTc,"Word" )
-#endif
-INSTANCE_TYPEABLE0(Integer,integerTc,"Integer")
-INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering")
-#ifndef __GLASGOW_HASKELL__
-INSTANCE_TYPEABLE0(Handle,handleTc,"Handle")
-#endif
-
-INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8")
-INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16")
-INSTANCE_TYPEABLE0(Int32,int32Tc,"Int32")
-INSTANCE_TYPEABLE0(Int64,int64Tc,"Int64")
-
-INSTANCE_TYPEABLE0(Word8,word8Tc,"Word8" )
-INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16")
-INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32")
-INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64")
-
-INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon")
-INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")
-
-#ifdef __GLASGOW_HASKELL__
-{-
-TODO: This can't be derived currently:
-libraries/base/Data/Typeable.hs:674:1:
-    Can't make a derived instance of `Typeable RealWorld':
-      The last argument of the instance must be a data or newtype application
-    In the stand-alone deriving instance for `Typeable RealWorld'
--}
-realWorldTc :: TyCon; \
-realWorldTc = mkTyCon3 "ghc-prim" "GHC.Types" "RealWorld"; \
-instance Typeable RealWorld where { typeOf _ = mkTyConApp realWorldTc [] }
-
-#endif
index a404f73..3eae5fb 100644 (file)
@@ -1,14 +1,9 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 
-module Data.Typeable where
+module Data.Typeable (Typeable, mkTyConApp, cast) where
 
 import Data.Maybe
 import {-# SOURCE #-} Data.Typeable.Internal
 
-mkTyConApp   :: TyCon -> [TypeRep] -> TypeRep
-
 cast :: (Typeable a, Typeable b) => a -> Maybe b
 
-class Typeable a where
-  typeOf :: a -> TypeRep
-
index 1f4f644..f28a079 100644 (file)
 --
 -----------------------------------------------------------------------------
 
-{-# LANGUAGE NoImplicitPrelude,
-             MagicHash #-}
+{-# LANGUAGE CPP
+           , NoImplicitPrelude
+           , OverlappingInstances
+           , ScopedTypeVariables
+           , FlexibleInstances
+           , MagicHash #-}
+#ifdef __GLASGOW_HASKELL__
+{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
+#endif
+
 module Data.Typeable.Internal (
     TypeRep(..),
     TyCon(..),
-    mkTyCon
+    mkTyCon,
+    mkTyCon3,
+    mkTyConApp,
+    mkAppTy,
+    typeRepTyCon,
+    typeOfDefault,
+    typeOf1Default,
+    typeOf2Default,
+    typeOf3Default,
+    typeOf4Default,
+    typeOf5Default,
+    typeOf6Default,
+    Typeable(..),
+    Typeable1(..),
+    Typeable2(..),
+    Typeable3(..),
+    Typeable4(..),
+    Typeable5(..),
+    Typeable6(..),
+    Typeable7(..),
+    mkFunTy,
+    splitTyConApp,
+    funResultTy,
+    typeRepArgs,
+    showsTypeRep,
+    tyConString,
+#if defined(__GLASGOW_HASKELL__)
+    listTc, funTc
+#endif
   ) where
 
 import GHC.Base
 import GHC.Word
+import GHC.Show
+import GHC.Err          (undefined)
+import Data.Maybe
+import Data.List        (intersperse)
+import GHC.Num
+import GHC.Real
+import GHC.IORef
+import GHC.IOArray
+import GHC.MVar
+import GHC.ST           ( ST )
+import GHC.STRef        ( STRef )
+import GHC.Ptr          ( Ptr, FunPtr )
+import GHC.Stable
+import GHC.Arr          ( Array, STArray )
+import Data.Int
+
 import GHC.Fingerprint.Type
+import {-# SOURCE #-} GHC.Fingerprint
+   -- loop: GHC.Fingerprint -> Foreign.Ptr -> Data.Typeable
+   -- Better to break the loop here, because we want non-SOURCE imports
+   -- of Data.Typeable as much as possible so we can optimise the derived
+   -- instances.
 
 -- | A concrete representation of a (monomorphic) type.  'TypeRep'
 -- supports reasonably efficient equality.
@@ -42,6 +99,8 @@ data TyCon = TyCon {
 instance Eq TyCon where
   (TyCon t1 _ _ _) == (TyCon t2 _ _ _) = t1 == t2
 
+----------------- Construction --------------------
+
 #include "MachDeps.h"
 
 -- mkTyCon is an internal function to make it easier for GHC to
@@ -57,3 +116,446 @@ mkTyCon :: Word#   -> Word#   -> String -> String -> String -> TyCon
 #endif
 mkTyCon high# low# pkg modl name
   = TyCon (Fingerprint (W64# high#) (W64# low#)) pkg modl name
+
+-- | Applies a type constructor to a sequence of types
+mkTyConApp  :: TyCon -> [TypeRep] -> TypeRep
+mkTyConApp tc@(TyCon tc_k _ _ _) []
+  = TypeRep tc_k tc [] -- optimisation: all derived Typeable instances
+                       -- end up here, and it helps generate smaller
+                       -- code for derived Typeable.
+mkTyConApp tc@(TyCon tc_k _ _ _) args
+  = TypeRep (fingerprintFingerprints (tc_k : arg_ks)) tc args
+  where
+    arg_ks = [k | TypeRep k _ _ <- args]
+
+-- | A special case of 'mkTyConApp', which applies the function 
+-- type constructor to a pair of types.
+mkFunTy  :: TypeRep -> TypeRep -> TypeRep
+mkFunTy f a = mkTyConApp funTc [f,a]
+
+-- | Splits a type constructor application
+splitTyConApp :: TypeRep -> (TyCon,[TypeRep])
+splitTyConApp (TypeRep _ tc trs) = (tc,trs)
+
+-- | Applies a type to a function type.  Returns: @'Just' u@ if the
+-- first argument represents a function of type @t -> u@ and the
+-- second argument represents a function of type @t@.  Otherwise,
+-- returns 'Nothing'.
+funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep
+funResultTy trFun trArg
+  = case splitTyConApp trFun of
+      (tc, [t1,t2]) | tc == funTc && t1 == trArg -> Just t2
+      _ -> Nothing
+
+-- | Adds a TypeRep argument to a TypeRep.
+mkAppTy :: TypeRep -> TypeRep -> TypeRep
+mkAppTy (TypeRep tr_k tc trs) arg_tr
+  = let (TypeRep arg_k _ _) = arg_tr
+     in  TypeRep (fingerprintFingerprints [tr_k,arg_k]) tc (trs++[arg_tr])
+
+-- | Builds a 'TyCon' object representing a type constructor.  An
+-- implementation of "Data.Typeable" should ensure that the following holds:
+--
+-- >  A==A' ^ B==B' ^ C==C' ==> mkTyCon A B C == mkTyCon A' B' C'
+--
+
+--
+mkTyCon3 :: String       -- ^ package name
+         -> String       -- ^ module name
+         -> String       -- ^ the name of the type constructor
+         -> TyCon        -- ^ A unique 'TyCon' object
+mkTyCon3 pkg modl name =
+  TyCon (fingerprintString (pkg++modl++name)) pkg modl name
+
+----------------- Observation ---------------------
+
+-- | Observe the type constructor of a type representation
+typeRepTyCon :: TypeRep -> TyCon
+typeRepTyCon (TypeRep _ tc _) = tc
+
+-- | Observe the argument types of a type representation
+typeRepArgs :: TypeRep -> [TypeRep]
+typeRepArgs (TypeRep _ _ args) = args
+
+-- | Observe string encoding of a type representation
+tyConString :: TyCon   -> String
+tyConString = tyConName
+
+-------------------------------------------------------------
+--
+--      The Typeable class and friends
+--
+-------------------------------------------------------------
+
+{- Note [Memoising typeOf]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+IMPORTANT: we don't want to recalculate the type-rep once per
+call to the dummy argument.  This is what went wrong in Trac #3245
+So we help GHC by manually keeping the 'rep' *outside* the value 
+lambda, thus
+    
+    typeOfDefault :: forall t a. (Typeable1 t, Typeable a) => t a -> TypeRep
+    typeOfDefault = \_ -> rep
+      where
+        rep = typeOf1 (undefined :: t a) `mkAppTy` 
+              typeOf  (undefined :: a)
+
+Notice the crucial use of scoped type variables here!
+-}
+
+-- | The class 'Typeable' allows a concrete representation of a type to
+-- be calculated.
+class Typeable a where
+  typeOf :: a -> TypeRep
+  -- ^ Takes a value of type @a@ and returns a concrete representation
+  -- of that type.  The /value/ of the argument should be ignored by
+  -- any instance of 'Typeable', so that it is safe to pass 'undefined' as
+  -- the argument.
+
+-- | Variant for unary type constructors
+class Typeable1 t where
+  typeOf1 :: t a -> TypeRep
+
+#ifdef __GLASGOW_HASKELL__
+-- | For defining a 'Typeable' instance from any 'Typeable1' instance.
+typeOfDefault :: forall t a. (Typeable1 t, Typeable a) => t a -> TypeRep
+typeOfDefault = \_ -> rep
+ where
+   rep = typeOf1 (undefined :: t a) `mkAppTy` 
+         typeOf  (undefined :: a)
+   -- Note [Memoising typeOf]
+#else
+-- | For defining a 'Typeable' instance from any 'Typeable1' instance.
+typeOfDefault :: (Typeable1 t, Typeable a) => t a -> TypeRep
+typeOfDefault x = typeOf1 x `mkAppTy` typeOf (argType x)
+ where
+   argType :: t a -> a
+   argType = undefined
+#endif
+
+-- | Variant for binary type constructors
+class Typeable2 t where
+  typeOf2 :: t a b -> TypeRep
+
+#ifdef __GLASGOW_HASKELL__
+-- | For defining a 'Typeable1' instance from any 'Typeable2' instance.
+typeOf1Default :: forall t a b. (Typeable2 t, Typeable a) => t a b -> TypeRep
+typeOf1Default = \_ -> rep 
+ where
+   rep = typeOf2 (undefined :: t a b) `mkAppTy` 
+         typeOf  (undefined :: a)
+   -- Note [Memoising typeOf]
+#else
+-- | For defining a 'Typeable1' instance from any 'Typeable2' instance.
+typeOf1Default :: (Typeable2 t, Typeable a) => t a b -> TypeRep
+typeOf1Default x = typeOf2 x `mkAppTy` typeOf (argType x)
+ where
+   argType :: t a b -> a
+   argType = undefined
+#endif
+
+-- | Variant for 3-ary type constructors
+class Typeable3 t where
+  typeOf3 :: t a b c -> TypeRep
+
+#ifdef __GLASGOW_HASKELL__
+-- | For defining a 'Typeable2' instance from any 'Typeable3' instance.
+typeOf2Default :: forall t a b c. (Typeable3 t, Typeable a) => t a b c -> TypeRep
+typeOf2Default = \_ -> rep 
+ where
+   rep = typeOf3 (undefined :: t a b c) `mkAppTy` 
+         typeOf  (undefined :: a)
+   -- Note [Memoising typeOf]
+#else
+-- | For defining a 'Typeable2' instance from any 'Typeable3' instance.
+typeOf2Default :: (Typeable3 t, Typeable a) => t a b c -> TypeRep
+typeOf2Default x = typeOf3 x `mkAppTy` typeOf (argType x)
+ where
+   argType :: t a b c -> a
+   argType = undefined
+#endif
+
+-- | Variant for 4-ary type constructors
+class Typeable4 t where
+  typeOf4 :: t a b c d -> TypeRep
+
+#ifdef __GLASGOW_HASKELL__
+-- | For defining a 'Typeable3' instance from any 'Typeable4' instance.
+typeOf3Default :: forall t a b c d. (Typeable4 t, Typeable a) => t a b c d -> TypeRep
+typeOf3Default = \_ -> rep
+ where
+   rep = typeOf4 (undefined :: t a b c d) `mkAppTy` 
+         typeOf  (undefined :: a)
+   -- Note [Memoising typeOf]
+#else
+-- | For defining a 'Typeable3' instance from any 'Typeable4' instance.
+typeOf3Default :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep
+typeOf3Default x = typeOf4 x `mkAppTy` typeOf (argType x)
+ where
+   argType :: t a b c d -> a
+   argType = undefined
+#endif
+   
+-- | Variant for 5-ary type constructors
+class Typeable5 t where
+  typeOf5 :: t a b c d e -> TypeRep
+
+#ifdef __GLASGOW_HASKELL__
+-- | For defining a 'Typeable4' instance from any 'Typeable5' instance.
+typeOf4Default :: forall t a b c d e. (Typeable5 t, Typeable a) => t a b c d e -> TypeRep
+typeOf4Default = \_ -> rep 
+ where
+   rep = typeOf5 (undefined :: t a b c d e) `mkAppTy` 
+         typeOf  (undefined :: a)
+   -- Note [Memoising typeOf]
+#else
+-- | For defining a 'Typeable4' instance from any 'Typeable5' instance.
+typeOf4Default :: (Typeable5 t, Typeable a) => t a b c d e -> TypeRep
+typeOf4Default x = typeOf5 x `mkAppTy` typeOf (argType x)
+ where
+   argType :: t a b c d e -> a
+   argType = undefined
+#endif
+
+-- | Variant for 6-ary type constructors
+class Typeable6 t where
+  typeOf6 :: t a b c d e f -> TypeRep
+
+#ifdef __GLASGOW_HASKELL__
+-- | For defining a 'Typeable5' instance from any 'Typeable6' instance.
+typeOf5Default :: forall t a b c d e f. (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep
+typeOf5Default = \_ -> rep
+ where
+   rep = typeOf6 (undefined :: t a b c d e f) `mkAppTy` 
+         typeOf  (undefined :: a)
+   -- Note [Memoising typeOf]
+#else
+-- | For defining a 'Typeable5' instance from any 'Typeable6' instance.
+typeOf5Default :: (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep
+typeOf5Default x = typeOf6 x `mkAppTy` typeOf (argType x)
+ where
+   argType :: t a b c d e f -> a
+   argType = undefined
+#endif
+
+-- | Variant for 7-ary type constructors
+class Typeable7 t where
+  typeOf7 :: t a b c d e f g -> TypeRep
+
+#ifdef __GLASGOW_HASKELL__
+-- | For defining a 'Typeable6' instance from any 'Typeable7' instance.
+typeOf6Default :: forall t a b c d e f g. (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep
+typeOf6Default = \_ -> rep
+ where
+   rep = typeOf7 (undefined :: t a b c d e f g) `mkAppTy` 
+         typeOf  (undefined :: a)
+   -- Note [Memoising typeOf]
+#else
+-- | For defining a 'Typeable6' instance from any 'Typeable7' instance.
+typeOf6Default :: (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep
+typeOf6Default x = typeOf7 x `mkAppTy` typeOf (argType x)
+ where
+   argType :: t a b c d e f g -> a
+   argType = undefined
+#endif
+
+#ifdef __GLASGOW_HASKELL__
+-- Given a @Typeable@/n/ instance for an /n/-ary type constructor,
+-- define the instances for partial applications.
+-- Programmers using non-GHC implementations must do this manually
+-- for each type constructor.
+-- (The INSTANCE_TYPEABLE/n/ macros in Typeable.h include this.)
+
+-- | One Typeable instance for all Typeable1 instances
+instance (Typeable1 s, Typeable a)
+       => Typeable (s a) where
+  typeOf = typeOfDefault
+
+-- | One Typeable1 instance for all Typeable2 instances
+instance (Typeable2 s, Typeable a)
+       => Typeable1 (s a) where
+  typeOf1 = typeOf1Default
+
+-- | One Typeable2 instance for all Typeable3 instances
+instance (Typeable3 s, Typeable a)
+       => Typeable2 (s a) where
+  typeOf2 = typeOf2Default
+
+-- | One Typeable3 instance for all Typeable4 instances
+instance (Typeable4 s, Typeable a)
+       => Typeable3 (s a) where
+  typeOf3 = typeOf3Default
+
+-- | One Typeable4 instance for all Typeable5 instances
+instance (Typeable5 s, Typeable a)
+       => Typeable4 (s a) where
+  typeOf4 = typeOf4Default
+
+-- | One Typeable5 instance for all Typeable6 instances
+instance (Typeable6 s, Typeable a)
+       => Typeable5 (s a) where
+  typeOf5 = typeOf5Default
+
+-- | One Typeable6 instance for all Typeable7 instances
+instance (Typeable7 s, Typeable a)
+       => Typeable6 (s a) where
+  typeOf6 = typeOf6Default
+
+#endif /* __GLASGOW_HASKELL__ */
+
+----------------- Showing TypeReps --------------------
+
+instance Show TypeRep where
+  showsPrec p (TypeRep _ tycon tys) =
+    case tys of
+      [] -> showsPrec p tycon
+      [x]   | tycon == listTc -> showChar '[' . shows x . showChar ']'
+      [a,r] | tycon == funTc  -> showParen (p > 8) $
+                                 showsPrec 9 a .
+                                 showString " -> " .
+                                 showsPrec 8 r
+      xs | isTupleTyCon tycon -> showTuple xs
+         | otherwise         ->
+            showParen (p > 9) $
+            showsPrec p tycon . 
+            showChar ' '      . 
+            showArgs tys
+
+showsTypeRep :: TypeRep -> ShowS
+showsTypeRep = shows
+
+instance Show TyCon where
+  showsPrec _ t = showString (tyConName t)
+
+isTupleTyCon :: TyCon -> Bool
+isTupleTyCon (TyCon _ _ _ ('(':',':_)) = True
+isTupleTyCon _                         = False
+
+-- Some (Show.TypeRep) helpers:
+
+showArgs :: Show a => [a] -> ShowS
+showArgs [] = id
+showArgs [a] = showsPrec 10 a
+showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as 
+
+showTuple :: [TypeRep] -> ShowS
+showTuple args = showChar '('
+               . (foldr (.) id $ intersperse (showChar ',') 
+                               $ map (showsPrec 10) args)
+               . showChar ')'
+
+#if defined(__GLASGOW_HASKELL__)
+listTc :: TyCon
+listTc = typeRepTyCon (typeOf [()])
+
+funTc :: TyCon
+funTc = mkTyCon3 "ghc-prim" "GHC.Types" "->"
+#endif
+
+-------------------------------------------------------------
+--
+--      Instances of the Typeable classes for Prelude types
+--
+-------------------------------------------------------------
+
+#include "Typeable.h"
+
+INSTANCE_TYPEABLE0((),unitTc,"()")
+INSTANCE_TYPEABLE1([],listTc,"[]")
+INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe")
+INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio")
+#if defined(__GLASGOW_HASKELL__)
+{-
+TODO: Deriving this instance fails with:
+libraries/base/Data/Typeable.hs:589:1:
+    Can't make a derived instance of `Typeable2 (->)':
+      The last argument of the instance must be a data or newtype application
+    In the stand-alone deriving instance for `Typeable2 (->)'
+-}
+instance Typeable2 (->) where { typeOf2 _ = mkTyConApp funTc [] }
+#else
+INSTANCE_TYPEABLE2((->),funTc,"->")
+#endif
+INSTANCE_TYPEABLE1(IO,ioTc,"IO")
+
+#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
+-- Types defined in GHC.MVar
+INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" )
+#endif
+
+INSTANCE_TYPEABLE2(Array,arrayTc,"Array")
+INSTANCE_TYPEABLE2(IOArray,iOArrayTc,"IOArray")
+
+#ifdef __GLASGOW_HASKELL__
+-- Hugs has these too, but their Typeable<n> instances are defined
+-- elsewhere to keep this module within Haskell 98.
+-- This is important because every invocation of runhugs or ffihugs
+-- uses this module via Data.Dynamic.
+INSTANCE_TYPEABLE2(ST,stTc,"ST")
+INSTANCE_TYPEABLE2(STRef,stRefTc,"STRef")
+INSTANCE_TYPEABLE3(STArray,sTArrayTc,"STArray")
+#endif
+
+#ifndef __NHC__
+INSTANCE_TYPEABLE2((,),pairTc,"(,)")
+INSTANCE_TYPEABLE3((,,),tup3Tc,"(,,)")
+INSTANCE_TYPEABLE4((,,,),tup4Tc,"(,,,)")
+INSTANCE_TYPEABLE5((,,,,),tup5Tc,"(,,,,)")
+INSTANCE_TYPEABLE6((,,,,,),tup6Tc,"(,,,,,)")
+INSTANCE_TYPEABLE7((,,,,,,),tup7Tc,"(,,,,,,)")
+#endif /* __NHC__ */
+
+INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr")
+INSTANCE_TYPEABLE1(FunPtr,funPtrTc,"FunPtr")
+#ifndef __GLASGOW_HASKELL__
+INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr")
+#endif
+INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr")
+INSTANCE_TYPEABLE1(IORef,iORefTc,"IORef")
+
+-------------------------------------------------------
+--
+-- Generate Typeable instances for standard datatypes
+--
+-------------------------------------------------------
+
+INSTANCE_TYPEABLE0(Bool,boolTc,"Bool")
+INSTANCE_TYPEABLE0(Char,charTc,"Char")
+INSTANCE_TYPEABLE0(Float,floatTc,"Float")
+INSTANCE_TYPEABLE0(Double,doubleTc,"Double")
+INSTANCE_TYPEABLE0(Int,intTc,"Int")
+#ifndef __NHC__
+INSTANCE_TYPEABLE0(Word,wordTc,"Word" )
+#endif
+INSTANCE_TYPEABLE0(Integer,integerTc,"Integer")
+INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering")
+#ifndef __GLASGOW_HASKELL__
+INSTANCE_TYPEABLE0(Handle,handleTc,"Handle")
+#endif
+
+INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8")
+INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16")
+INSTANCE_TYPEABLE0(Int32,int32Tc,"Int32")
+INSTANCE_TYPEABLE0(Int64,int64Tc,"Int64")
+
+INSTANCE_TYPEABLE0(Word8,word8Tc,"Word8" )
+INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16")
+INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32")
+INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64")
+
+INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon")
+INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")
+
+#ifdef __GLASGOW_HASKELL__
+{-
+TODO: This can't be derived currently:
+libraries/base/Data/Typeable.hs:674:1:
+    Can't make a derived instance of `Typeable RealWorld':
+      The last argument of the instance must be a data or newtype application
+    In the stand-alone deriving instance for `Typeable RealWorld'
+-}
+realWorldTc :: TyCon; \
+realWorldTc = mkTyCon3 "ghc-prim" "GHC.Types" "RealWorld"; \
+instance Typeable RealWorld where { typeOf _ = mkTyConApp realWorldTc [] }
+
+#endif
index 7539eb0..d640e58 100644 (file)
@@ -1,8 +1,10 @@
 {-# LANGUAGE CPP, NoImplicitPrelude, MagicHash #-}
 module Data.Typeable.Internal (
+    Typeable(typeOf),
     TypeRep,
     TyCon,
-    mkTyCon
+    mkTyCon,
+    mkTyConApp
   ) where
 
 import GHC.Base
@@ -17,3 +19,8 @@ mkTyCon :: Word64# -> Word64# -> String -> String -> String -> TyCon
 #else
 mkTyCon :: Word#   -> Word#   -> String -> String -> String -> TyCon
 #endif
+
+mkTyConApp   :: TyCon -> [TypeRep] -> TypeRep
+
+class Typeable a where
+  typeOf :: a -> TypeRep
index 482b5d9..62c1151 100644 (file)
@@ -1,5 +1,8 @@
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE CPP, NoImplicitPrelude, ScopedTypeVariables #-}
+#ifdef __GLASGOW_HASKELL__
+{-# LANGUAGE BangPatterns #-}
+#endif
 
 -----------------------------------------------------------------------------
 -- |
@@ -51,6 +54,9 @@ import GHC.Word
 import GHC.Ptr
 import GHC.Err
 import GHC.Base
+import GHC.Fingerprint.Type
+import Data.Bits
+import GHC.Real
 #else
 import Data.Int
 import Data.Word
@@ -244,3 +250,37 @@ STORABLE(Int64,SIZEOF_INT64,ALIGNMENT_INT64,
          readInt64OffPtr,writeInt64OffPtr)
 
 #endif
+
+-- XXX: here to avoid orphan instance in GHC.Fingerprint
+#ifdef __GLASGOW_HASKELL__
+instance Storable Fingerprint where
+  sizeOf _ = 16
+  alignment _ = 8
+  peek = peekFingerprint
+  poke = pokeFingerprint
+
+-- peek/poke in fixed BIG-endian 128-bit format
+peekFingerprint :: Ptr Fingerprint -> IO Fingerprint
+peekFingerprint p0 = do
+      let peekW64 :: Ptr Word8 -> Int -> Word64 -> IO Word64
+          peekW64 _  0  !i = return i
+          peekW64 !p !n !i = do
+                w8 <- peek p
+                peekW64 (p `plusPtr` 1) (n-1) 
+                    ((i `shiftL` 8) .|. fromIntegral w8)
+
+      high <- peekW64 (castPtr p0) 8 0
+      low  <- peekW64 (castPtr p0 `plusPtr` 8) 8 0
+      return (Fingerprint high low)
+
+pokeFingerprint :: Ptr Fingerprint -> Fingerprint -> IO ()
+pokeFingerprint p0 (Fingerprint high low) = do
+      let pokeW64 :: Ptr Word8 -> Int -> Word64 -> IO ()
+          pokeW64 _ 0  _  = return ()
+          pokeW64 p !n !i = do
+                pokeElemOff p (n-1) (fromIntegral i)
+                pokeW64 p (n-1) (i `shiftR` 8)
+
+      pokeW64 (castPtr p0) 8 high
+      pokeW64 (castPtr p0 `plusPtr` 8) 8 low
+#endif
index 9059e0d..817afa8 100644 (file)
@@ -34,40 +34,12 @@ import GHC.Fingerprint.Type
 -- for SIZEOF_STRUCT_MD5CONTEXT:
 #include "HsBaseConfig.h"
 
+-- XXX instance Storable Fingerprint
+-- defined in Foreign.Storable to avoid orphan instance
+
 fingerprint0 :: Fingerprint
 fingerprint0 = Fingerprint 0 0
 
-instance Storable Fingerprint where
-  sizeOf _ = 16
-  alignment _ = 8
-  peek = peekFingerprint
-  poke = pokeFingerprint
-
--- peek/poke in fixed BIG-endian 128-bit format
-peekFingerprint :: Ptr Fingerprint -> IO Fingerprint
-peekFingerprint p = do
-      let peekW64 :: Ptr Word8 -> Int -> Word64 -> IO Word64
-          peekW64 _  0  !i = return i
-          peekW64 !p !n !i = do
-                w8 <- peek p
-                peekW64 (p `plusPtr` 1) (n-1) 
-                    ((i `shiftL` 8) .|. fromIntegral w8)
-
-      high <- peekW64 (castPtr p) 8 0
-      low  <- peekW64 (castPtr p `plusPtr` 8) 8 0
-      return (Fingerprint high low)
-
-pokeFingerprint :: Ptr Fingerprint -> Fingerprint -> IO ()
-pokeFingerprint p (Fingerprint high low) = do
-      let pokeW64 :: Ptr Word8 -> Int -> Word64 -> IO ()
-          pokeW64 p 0  !i = return ()
-          pokeW64 p !n !i = do
-                pokeElemOff p (n-1) (fromIntegral i)
-                pokeW64 p (n-1) (i `shiftR` 8)
-
-      pokeW64 (castPtr p) 8 high
-      pokeW64 (castPtr p `plusPtr` 8) 8 low
-
 fingerprintFingerprints :: [Fingerprint] -> Fingerprint
 fingerprintFingerprints fs = unsafeDupablePerformIO $
   withArrayLen fs $ \len p -> do
@@ -80,7 +52,7 @@ fingerprintData buf len = do
     c_MD5Update pctxt buf (fromIntegral len)
     allocaBytes 16 $ \pdigest -> do
       c_MD5Final pdigest pctxt
-      peekFingerprint (castPtr pdigest)
+      peek (castPtr pdigest :: Ptr Fingerprint)
 
 fingerprintString :: String -> Fingerprint
 fingerprintString str = unsafeDupablePerformIO $