@@ -2,9 +2,10 @@
2{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeFamilies #-}
4{-# LANGUAGE ViewPatterns #-}
4{-# LANGUAGE ViewPatterns #-}
5+#if __GLASGOW_HASKELL__ >= 704
5{-# LANGUAGE Unsafe #-}
6{-# LANGUAGE Unsafe #-}
6−{-# LANGUAGE DeriveLift #-}
7+#endif
7−{-# LANGUAGE StandaloneDeriving #-}
8+
8{-# OPTIONS_HADDOCK hide #-}
9{-# OPTIONS_HADDOCK hide #-}
@@ -46,11 +47,13 @@ module Data.UUID.Types.Internal
47import Prelude hiding (null)
48import Prelude hiding (null)
50+import Control.Applicative ((<*>))
49import Control.DeepSeq (NFData (..))
51import Control.DeepSeq (NFData (..))
50import Control.Monad (guard, liftM2)
52import Control.Monad (guard, liftM2)
51import Data.Bits
53import Data.Bits
52import Data.Char
54import Data.Char
53import Data.Data
55import Data.Data
56+import Data.Functor ((<$>))
54import Data.Hashable
57import Data.Hashable
55import Data.List (elemIndices)
58import Data.List (elemIndices)
56import Foreign.Ptr (Ptr)
59import Foreign.Ptr (Ptr)
@@ -69,15 +72,13 @@ import qualified Data.Text.Encoding as T
70import Data.UUID.Types.Internal.Builder
73import Data.UUID.Types.Internal.Builder
72−import System.Random (Random (..), uniform)
75+import System.Random
73−import System.Random.Stateful (Uniform (..), uniformWord64)
75−import Language.Haskell.TH.Syntax (Lift)
77-- | Type representing <https://en.wikipedia.org/wiki/UUID Universally Unique Identifiers (UUID)> as specified in
78-- | Type representing <https://en.wikipedia.org/wiki/UUID Universally Unique Identifiers (UUID)> as specified in
78-- <http://tools.ietf.org/html/rfc4122 RFC 4122>.
79-- <http://tools.ietf.org/html/rfc4122 RFC 4122>.
79data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
80data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
80− deriving (Eq, Ord)
81+ deriving (Eq, Ord, Typeable)
82 Prior to uuid-types-1.0.4:
83 Prior to uuid-types-1.0.4:
83 !Word32 !Word32 !Word32 !Word32
84 !Word32 !Word32 !Word32 !Word32
@@ -333,25 +334,19 @@ fromString' s0 = do
335toString :: UUID -> String
336toString :: UUID -> String
336−toString uuid = hexw0 w0 $ hexw1 w1 ""
337+toString uuid = hexw w0 $ hexw' w1 $ hexw' w2 $ hexw w3 ""
337− where hexw0 :: Word64 -> String -> String
338+ where hexw :: Word32 -> String -> String
338− hexw0 w s = hexn w 60 : hexn w 56 : hexn w 52 : hexn w 48
339− : hexn w 44 : hexn w 40 : hexn w 36 : hexn w 32
340− : '-' : hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16
339+ hexw w s = hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16
341− : '-' : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0
340+ : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0 : s
344− hexw1 :: Word64 -> String -> String
342+ hexw' :: Word32 -> String -> String
345− hexw1 w s = '-' : hexn w 60 : hexn w 56 : hexn w 52 : hexn w 48
343+ hexw' w s = '-' : hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16
346− : '-' : hexn w 44 : hexn w 40 : hexn w 36 : hexn w 32
347− : hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16
348− : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0
344+ : '-' : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0 : s
351− hexn :: Word64 -> Int -> Char
346+ hexn :: Word32 -> Int -> Char
352 hexn w r = intToDigit $ fromIntegral ((w `shiftR` r) .&. 0xf)
347 hexn w r = intToDigit $ fromIntegral ((w `shiftR` r) .&. 0xf)
354− (w0,w1) = toWords64 uuid
349+ (w0,w1,w2,w3) = toWords uuid
356-- | If the passed in `Text` can be parsed as an ASCII representation of
351-- | If the passed in `Text` can be parsed as an ASCII representation of
357-- a `UUID`, it will be. The hyphens may not be omitted.
352-- a `UUID`, it will be. The hyphens may not be omitted.
@@ -455,13 +450,23 @@ fromASCIIBytes bs = do
455-- | Similar to `toASCIIBytes` except we produce a lazy `BL.ByteString`.
450-- | Similar to `toASCIIBytes` except we produce a lazy `BL.ByteString`.
456toLazyASCIIBytes :: UUID -> BL.ByteString
451toLazyASCIIBytes :: UUID -> BL.ByteString
457toLazyASCIIBytes =
452toLazyASCIIBytes =
453+#if MIN_VERSION_bytestring(0,10,0)
458 BL.fromStrict
454 BL.fromStrict
456+ BL.fromChunks . return
459 . toASCIIBytes
458 . toASCIIBytes
461-- | Similar to `fromASCIIBytes` except parses from a lazy `BL.ByteString`.
460-- | Similar to `fromASCIIBytes` except parses from a lazy `BL.ByteString`.
462fromLazyASCIIBytes :: BL.ByteString -> Maybe UUID
461fromLazyASCIIBytes :: BL.ByteString -> Maybe UUID
463fromLazyASCIIBytes bs =
462fromLazyASCIIBytes bs =
464− if BL.length bs == 36 then fromASCIIBytes (BL.toStrict bs) else Nothing
463+ if BL.length bs == 36 then fromASCIIBytes (
464+#if MIN_VERSION_bytestring(0,10,0)
467+ B.concat $ BL.toChunks bs
467-- Class Instances
472-- Class Instances
@@ -470,15 +475,26 @@ fromLazyASCIIBytes bs =
470-- | This 'Random' instance produces __insecure__ version 4 UUIDs as
475-- | This 'Random' instance produces __insecure__ version 4 UUIDs as
471-- specified in <http://tools.ietf.org/html/rfc4122 RFC 4122>.
476-- specified in <http://tools.ietf.org/html/rfc4122 RFC 4122>.
472instance Random UUID where
477instance Random UUID where
473− random = uniform
478+ random g = (fromGenNext w0 w1 w2 w3 w4, g4)
479+ where (w0, g0) = next g
474 randomR _ = random -- range is ignored
484 randomR _ = random -- range is ignored
476−-- @since 1.0.4
486+-- |Build a UUID from the results of five calls to next on a StdGen.
477−instance Uniform UUID where
487+-- While next on StdGet returns an Int, it doesn't provide 32 bits of
478− uniformM gen = do
488+-- randomness. This code relies on at last 28 bits of randomness in the
479− w0 <- uniformWord64 gen
489+-- and optimizes its use so as to make only five random values, not six.
480− w1 <- uniformWord64 gen
490+fromGenNext :: Int -> Int -> Int -> Int -> Int -> UUID
491+fromGenNext w0 w1 w2 w3 w4 =
481− pure $ buildFromBytes 4 /-/ w0 /-/ w1
492+ buildFromBytes 4 /-/ (ThreeByte w0)
494+ /-/ w2 -- use all 4 bytes because we know the version
495+ -- field will "cover" the upper, non-random bits
483-- |A ByteSource to extract only three bytes from an Int, since next on StdGet
499-- |A ByteSource to extract only three bytes from an Int, since next on StdGet
484-- only returns 31 bits of randomness.
500-- only returns 31 bits of randomness.
@@ -572,4 +588,10 @@ instance Data UUID where
572uuidType :: DataType
588uuidType :: DataType
573uuidType = mkNoRepType "Data.UUID.Types.UUID"
589uuidType = mkNoRepType "Data.UUID.Types.UUID"
575−deriving instance Lift UUID
591+#if !MIN_VERSION_base(4,5,0)
592+unsafeShiftR, unsafeShiftL :: Bits w => w -> Int -> w
593+{-# INLINE unsafeShiftR #-}
594+unsafeShiftR = shiftR
595+{-# INLINE unsafeShiftL #-}
596+unsafeShiftL = shiftL