@@ -2,6 +2,9 @@
2{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeFamilies #-}
4{-# LANGUAGE ViewPatterns #-}
4{-# LANGUAGE ViewPatterns #-}
5+{-# LANGUAGE Unsafe #-}
6+{-# LANGUAGE DeriveLift #-}
7+{-# LANGUAGE StandaloneDeriving #-}
5{-# OPTIONS_HADDOCK hide #-}
8{-# OPTIONS_HADDOCK hide #-}
@@ -43,13 +46,11 @@ module Data.UUID.Types.Internal
44import Prelude hiding (null)
47import Prelude hiding (null)
46−import Control.Applicative ((<*>))
47import Control.DeepSeq (NFData (..))
49import Control.DeepSeq (NFData (..))
48import Control.Monad (guard, liftM2)
50import Control.Monad (guard, liftM2)
49import Data.Bits
51import Data.Bits
50import Data.Char
52import Data.Char
51import Data.Data
53import Data.Data
52−import Data.Functor ((<$>))
53import Data.Hashable
54import Data.Hashable
54import Data.List (elemIndices)
55import Data.List (elemIndices)
55import Foreign.Ptr (Ptr)
56import Foreign.Ptr (Ptr)
@@ -64,19 +65,19 @@ import qualified Data.ByteString.Internal as BI
64import qualified Data.ByteString.Lazy as BL
65import qualified Data.ByteString.Lazy as BL
65import qualified Data.ByteString.Unsafe as BU
66import qualified Data.ByteString.Unsafe as BU
66import Data.Text (Text)
67import Data.Text (Text)
67−import qualified Data.Text as T
68+import qualified Data.Text.Encoding as T
69import Data.UUID.Types.Internal.Builder
70import Data.UUID.Types.Internal.Builder
71−import System.Random
72+import System.Random (Random (..), uniform)
73+import System.Random.Stateful (Uniform (..), uniformWord64)
75+import Language.Haskell.TH.Syntax (Lift)
74−-- |The UUID type. A 'Random' instance is provided which produces
77+-- | Type representing <https://en.wikipedia.org/wiki/UUID Universally Unique Identifiers (UUID)> as specified in
75−-- insecure version 4 UUIDs as specified in <http://tools.ietf.org/html/rfc4122 RFC 4122>. The 'Storable' and
76−-- 'Binary' instances are compatible with <http://tools.ietf.org/html/rfc4122 RFC 4122>, storing the fields in
78+-- <http://tools.ietf.org/html/rfc4122 RFC 4122>.
77−-- network order as 16 bytes.
78data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
79data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
79− deriving (Eq, Ord, Typeable)
80+ deriving (Eq, Ord)
81 Prior to uuid-types-1.0.4:
82 Prior to uuid-types-1.0.4:
82 !Word32 !Word32 !Word32 !Word32
83 !Word32 !Word32 !Word32 !Word32
@@ -95,6 +96,9 @@ data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
95-- Useful for when you need to serialize a UUID and
96-- Useful for when you need to serialize a UUID and
96-- neither 'Storable' nor 'Binary' are appropriate.
97-- neither 'Storable' nor 'Binary' are appropriate.
99+-- >>> toWords <$> fromString "550e8400-e29b-41d4-a716-446655440000"
100+-- Just (1427014656,3801825748,2803254374,1430519808)
98-- See also 'toWords64'.
102-- See also 'toWords64'.
100-- /Since: @uuid-1.2.2@/
104-- /Since: @uuid-1.2.2@/
@@ -122,6 +126,9 @@ fromWords w1 w2 w3 w4 = UUID (w32to64 w1 w2) (w32to64 w3 w4)
123-- | Convert a 'UUID' into a pair of 'Word64's.
127-- | Convert a 'UUID' into a pair of 'Word64's.
129+-- >>> toWords64 <$> fromString "550e8400-e29b-41d4-a716-446655440000"
130+-- Just (6128981282234515924,12039885860129472512)
125-- See also 'toWords'.
132-- See also 'toWords'.
127-- @since 1.0.4
134-- @since 1.0.4
@@ -234,7 +241,7 @@ buildFromBytes v b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf =
234 where b6' = b6 .&. 0x0f .|. (v `shiftL` 4)
241 where b6' = b6 .&. 0x0f .|. (v `shiftL` 4)
235 b8' = b8 .&. 0x3f .|. 0x80
242 b8' = b8 .&. 0x3f .|. 0x80
237−-- |Build a UUID of a given version from Word32 values.
244+-- |Build a UUID of a given version from 'Word32' values.
238buildFromWords :: Word8 -> Word32 -> Word32 -> Word32 -> Word32 -> UUID
245buildFromWords :: Word8 -> Word32 -> Word32 -> Word32 -> Word32 -> UUID
239buildFromWords v w0 w1 w2 w3 = fromWords w0 w1' w2' w3
246buildFromWords v w0 w1 w2 w3 = fromWords w0 w1' w2' w3
240 where w1' = w1 .&. 0xffff0fff .|. ((fromIntegral v) `shiftL` 12)
247 where w1' = w1 .&. 0xffff0fff .|. ((fromIntegral v) `shiftL` 12)
@@ -268,8 +275,8 @@ null = (== nil)
268 -- null (UUID 0 0 0 0) = True
275 -- null (UUID 0 0 0 0) = True
269 -- null _ = False
276 -- null _ = False
271−-- |The nil UUID, as defined in <http://tools.ietf.org/html/rfc4122 RFC 4122>.
278+-- |The 'nil' UUID, as defined in <http://tools.ietf.org/html/rfc4122 RFC 4122>.
272−-- It is a UUID of all zeros. @'null' u@ iff @'u' == 'nil'@.
279+-- It is a UUID of all zeros. @'null' u@ /iff/ @'u' == 'nil'@.
273nil :: UUID
280nil :: UUID
274nil = UUID 0 0
281nil = UUID 0 0
@@ -279,6 +286,8 @@ fromByteString :: BL.ByteString -> Maybe UUID
279fromByteString = fromList . BL.unpack
286fromByteString = fromList . BL.unpack
281-- |Encode a UUID into a 'ByteString' in network order.
288-- |Encode a UUID into a 'ByteString' in network order.
290+-- This uses the same encoding as the 'Binary' instance.
282toByteString :: UUID -> BL.ByteString
291toByteString :: UUID -> BL.ByteString
283toByteString = BL.pack . toList
292toByteString = BL.pack . toList
@@ -286,9 +295,8 @@ toByteString = BL.pack . toList
286-- The hyphens may not be omitted.
295-- The hyphens may not be omitted.
287-- Example:
296-- Example:
290−-- fromString \"c2cc10e1-57d6-4b6f-9899-38d972112d8c\"
298+-- >>> fromString "c2cc10e1-57d6-4b6f-9899-38d972112d8c"
291−-- @
299+-- Just c2cc10e1-57d6-4b6f-9899-38d972112d8c
293-- Hex digits may be upper or lower-case.
301-- Hex digits may be upper or lower-case.
294fromString :: String -> Maybe UUID
302fromString :: String -> Maybe UUID
@@ -320,32 +328,39 @@ fromString' s0 = do
320-- | Convert a UUID into a hypenated string using lower-case letters.
328-- | Convert a UUID into a hypenated string using lower-case letters.
321-- Example:
329-- Example:
324−-- toString \<$\> fromString \"550e8400-e29b-41d4-a716-446655440000\"
331+-- >>> toString <$> fromString "550e8400-e29b-41d4-a716-446655440000"
325−-- @
332+-- Just "550e8400-e29b-41d4-a716-446655440000"
326toString :: UUID -> String
335toString :: UUID -> String
327−toString uuid = hexw w0 $ hexw' w1 $ hexw' w2 $ hexw w3 ""
336+toString uuid = hexw0 w0 $ hexw1 w1 ""
328− where hexw :: Word32 -> String -> String
337+ where hexw0 :: Word64 -> 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
329− hexw w s = hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16
340+ : '-' : hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16
330− : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0 : s
341+ : '-' : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0
332− hexw' :: Word32 -> String -> String
344+ hexw1 :: Word64 -> String -> String
333− hexw' w s = '-' : hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16
345+ hexw1 w s = '-' : hexn w 60 : hexn w 56 : hexn w 52 : hexn w 48
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
334− : '-' : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0 : s
348+ : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0
336− hexn :: Word32 -> Int -> Char
351+ hexn :: Word64 -> Int -> Char
337 hexn w r = intToDigit $ fromIntegral ((w `shiftR` r) .&. 0xf)
352 hexn w r = intToDigit $ fromIntegral ((w `shiftR` r) .&. 0xf)
339− (w0,w1,w2,w3) = toWords uuid
354+ (w0,w1) = toWords64 uuid
341-- | If the passed in `Text` can be parsed as an ASCII representation of
356-- | If the passed in `Text` can be parsed as an ASCII representation of
342-- a `UUID`, it will be. The hyphens may not be omitted.
357-- a `UUID`, it will be. The hyphens may not be omitted.
343fromText :: Text -> Maybe UUID
358fromText :: Text -> Maybe UUID
344−fromText = fromString . T.unpack
359+fromText = fromASCIIBytes . T.encodeUtf8
346-- | Convert a UUID into a hyphentated string using lower-case letters.
361-- | Convert a UUID into a hyphentated string using lower-case letters.
347toText :: UUID -> Text
362toText :: UUID -> Text
348−toText = T.pack . toString
363+toText = T.decodeLatin1 . toASCIIBytes
350-- | Convert a UUID into a hyphentated string using lower-case letters, packed
365-- | Convert a UUID into a hyphentated string using lower-case letters, packed
351-- as ASCII bytes into `B.ByteString`.
366-- as ASCII bytes into `B.ByteString`.
@@ -440,49 +455,30 @@ fromASCIIBytes bs = do
440-- | Similar to `toASCIIBytes` except we produce a lazy `BL.ByteString`.
455-- | Similar to `toASCIIBytes` except we produce a lazy `BL.ByteString`.
441toLazyASCIIBytes :: UUID -> BL.ByteString
456toLazyASCIIBytes :: UUID -> BL.ByteString
442toLazyASCIIBytes =
457toLazyASCIIBytes =
443−#if MIN_VERSION_bytestring(0,10,0)
444 BL.fromStrict
458 BL.fromStrict
446− BL.fromChunks . return
448 . toASCIIBytes
459 . toASCIIBytes
450-- | Similar to `fromASCIIBytes` except parses from a lazy `BL.ByteString`.
461-- | Similar to `fromASCIIBytes` except parses from a lazy `BL.ByteString`.
451fromLazyASCIIBytes :: BL.ByteString -> Maybe UUID
462fromLazyASCIIBytes :: BL.ByteString -> Maybe UUID
452fromLazyASCIIBytes bs =
463fromLazyASCIIBytes bs =
453− if BL.length bs == 36 then fromASCIIBytes (
464+ if BL.length bs == 36 then fromASCIIBytes (BL.toStrict bs) else Nothing
454−#if MIN_VERSION_bytestring(0,10,0)
457− B.concat $ BL.toChunks bs
462-- Class Instances
467-- Class Instances
470+-- | This 'Random' instance produces __insecure__ version 4 UUIDs as
471+-- specified in <http://tools.ietf.org/html/rfc4122 RFC 4122>.
465instance Random UUID where
472instance Random UUID where
466− random g = (fromGenNext w0 w1 w2 w3 w4, g4)
473+ random = uniform
467− where (w0, g0) = next g
472 randomR _ = random -- range is ignored
474 randomR _ = random -- range is ignored
474−-- |Build a UUID from the results of five calls to next on a StdGen.
476+-- @since 1.0.4
475−-- While next on StdGet returns an Int, it doesn't provide 32 bits of
477+instance Uniform UUID where
476−-- randomness. This code relies on at last 28 bits of randomness in the
478+ uniformM gen = do
477−-- and optimizes its use so as to make only five random values, not six.
479+ w0 <- uniformWord64 gen
478−fromGenNext :: Int -> Int -> Int -> Int -> Int -> UUID
480+ w1 <- uniformWord64 gen
479−fromGenNext w0 w1 w2 w3 w4 =
480− buildFromBytes 4 /-/ (ThreeByte w0)
481+ pure $ buildFromBytes 4 /-/ w0 /-/ w1
482− /-/ w2 -- use all 4 bytes because we know the version
483− -- field will "cover" the upper, non-random bits
487-- |A ByteSource to extract only three bytes from an Int, since next on StdGet
483-- |A ByteSource to extract only three bytes from an Int, since next on StdGet
488-- only returns 31 bits of randomness.
484-- only returns 31 bits of randomness.
@@ -508,6 +504,11 @@ instance Hashable UUID where
508 `hashWithSalt` w2
504 `hashWithSalt` w2
509 `hashWithSalt` w3
505 `hashWithSalt` w3
507+-- | Pretty prints a 'UUID' (without quotation marks). See also 'toString'.
510+-- "00000000-0000-0000-0000-000000000000"
511instance Show UUID where
512instance Show UUID where
512 show = toString
513 show = toString
@@ -518,7 +519,7 @@ instance Read UUID where
518 Nothing -> []
519 Nothing -> []
519 Just u -> [(u,drop 36 noSpaces)]
520 Just u -> [(u,drop 36 noSpaces)]
521−
522+-- | This 'Storable' instance uses the memory layout as described in <http://tools.ietf.org/html/rfc4122 RFC 4122>, but in contrast to the 'Binary' instance, __the fields are stored in host byte order__.
522instance Storable UUID where
523instance Storable UUID where
523 sizeOf _ = 16
524 sizeOf _ = 16
524 alignment _ = 4
525 alignment _ = 4
@@ -555,6 +556,7 @@ instance Storable UUID where
555 pokeByteOff p (off+14) x9
556 pokeByteOff p (off+14) x9
556 pokeByteOff p (off+15) x10
557 pokeByteOff p (off+15) x10
559+-- | This 'Binary' instance is compatible with <http://tools.ietf.org/html/rfc4122 RFC 4122>, storing the fields in network order as 16 bytes.
558instance Binary UUID where
560instance Binary UUID where
559 put (UUID w0 w1) = putWord64be w0 >> putWord64be w1
561 put (UUID w0 w1) = putWord64be w0 >> putWord64be w1
560 get = liftM2 UUID getWord64be getWord64be
562 get = liftM2 UUID getWord64be getWord64be
@@ -570,10 +572,4 @@ instance Data UUID where
570uuidType :: DataType
572uuidType :: DataType
571uuidType = mkNoRepType "Data.UUID.Types.UUID"
573uuidType = mkNoRepType "Data.UUID.Types.UUID"
573−#if !MIN_VERSION_base(4,5,0)
575+deriving instance Lift UUID
574−unsafeShiftR, unsafeShiftL :: Bits w => w -> Int -> w
575−{-# INLINE unsafeShiftR #-}
576−unsafeShiftR = shiftR
577−{-# INLINE unsafeShiftL #-}
578−unsafeShiftL = shiftL