@@ -2,6 +2,9 @@
22{-# LANGUAGE DeriveDataTypeable #-}
33{-# LANGUAGE TypeFamilies #-}
44{-# LANGUAGE ViewPatterns #-}
5+{-# LANGUAGE Unsafe #-}
6+{-# LANGUAGE DeriveLift #-}
7+{-# LANGUAGE StandaloneDeriving #-}
58{-# OPTIONS_HADDOCK hide #-}
69
710-- |
@@ -43,13 +46,11 @@ module Data.UUID.Types.Internal
4346
4447import Prelude hiding (null)
4548
46−import Control.Applicative ((<*>))
4749import Control.DeepSeq (NFData (..))
4850import Control.Monad (guard, liftM2)
4951import Data.Bits
5052import Data.Char
5153import Data.Data
52−import Data.Functor ((<$>))
5354import Data.Hashable
5455import Data.List (elemIndices)
5556import Foreign.Ptr (Ptr)
@@ -64,19 +65,19 @@ import qualified Data.ByteString.Internal as BI
6465import qualified Data.ByteString.Lazy as BL
6566import qualified Data.ByteString.Unsafe as BU
6667import Data.Text (Text)
67−import qualified Data.Text as T
68+import qualified Data.Text.Encoding as T
6869
6970import Data.UUID.Types.Internal.Builder
7071
71−import System.Random
72+import System.Random (Random (..), uniform)
73+import System.Random.Stateful (Uniform (..), uniformWord64)
7274
75+import Language.Haskell.TH.Syntax (Lift)
7376
74−-- |The UUID type. A 'Random' instance is provided which produces
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
77−-- network order as 16 bytes.
77+-- | Type representing <https://en.wikipedia.org/wiki/UUID Universally Unique Identifiers (UUID)> as specified in
78+-- <http://tools.ietf.org/html/rfc4122 RFC 4122>.
7879data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
79− deriving (Eq, Ord, Typeable)
80+ deriving (Eq, Ord)
8081{-
8182 Prior to uuid-types-1.0.4:
8283 !Word32 !Word32 !Word32 !Word32
@@ -95,6 +96,9 @@ data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
9596-- Useful for when you need to serialize a UUID and
9697-- neither 'Storable' nor 'Binary' are appropriate.
9798--
99+-- >>> toWords <$> fromString "550e8400-e29b-41d4-a716-446655440000"
100+-- Just (1427014656,3801825748,2803254374,1430519808)
101+--
98102-- See also 'toWords64'.
99103--
100104-- /Since: @uuid-1.2.2@/
@@ -122,6 +126,9 @@ fromWords w1 w2 w3 w4 = UUID (w32to64 w1 w2) (w32to64 w3 w4)
122126
123127-- | Convert a 'UUID' into a pair of 'Word64's.
124128--
129+-- >>> toWords64 <$> fromString "550e8400-e29b-41d4-a716-446655440000"
130+-- Just (6128981282234515924,12039885860129472512)
131+--
125132-- See also 'toWords'.
126133--
127134-- @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 =
234241 where b6' = b6 .&. 0x0f .|. (v `shiftL` 4)
235242 b8' = b8 .&. 0x3f .|. 0x80
236243
237−-- |Build a UUID of a given version from Word32 values.
244+-- |Build a UUID of a given version from 'Word32' values.
238245buildFromWords :: Word8 -> Word32 -> Word32 -> Word32 -> Word32 -> UUID
239246buildFromWords v w0 w1 w2 w3 = fromWords w0 w1' w2' w3
240247 where w1' = w1 .&. 0xffff0fff .|. ((fromIntegral v) `shiftL` 12)
@@ -268,8 +275,8 @@ null = (== nil)
268275 -- null (UUID 0 0 0 0) = True
269276 -- null _ = False
270277
271−-- |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'@.
278+-- |The 'nil' UUID, as defined in <http://tools.ietf.org/html/rfc4122 RFC 4122>.
279+-- It is a UUID of all zeros. @'null' u@ /iff/ @'u' == 'nil'@.
273280nil :: UUID
274281nil = UUID 0 0
275282
@@ -279,6 +286,8 @@ fromByteString :: BL.ByteString -> Maybe UUID
279286fromByteString = fromList . BL.unpack
280287
281288-- |Encode a UUID into a 'ByteString' in network order.
289+--
290+-- This uses the same encoding as the 'Binary' instance.
282291toByteString :: UUID -> BL.ByteString
283292toByteString = BL.pack . toList
284293
@@ -286,9 +295,8 @@ toByteString = BL.pack . toList
286295-- The hyphens may not be omitted.
287296-- Example:
288297--
289−-- @
290−-- fromString \"c2cc10e1-57d6-4b6f-9899-38d972112d8c\"
291−-- @
298+-- >>> fromString "c2cc10e1-57d6-4b6f-9899-38d972112d8c"
299+-- Just c2cc10e1-57d6-4b6f-9899-38d972112d8c
292300--
293301-- Hex digits may be upper or lower-case.
294302fromString :: String -> Maybe UUID
@@ -320,32 +328,39 @@ fromString' s0 = do
320328-- | Convert a UUID into a hypenated string using lower-case letters.
321329-- Example:
322330--
323−-- @
324−-- toString \<$\> fromString \"550e8400-e29b-41d4-a716-446655440000\"
325−-- @
331+-- >>> toString <$> fromString "550e8400-e29b-41d4-a716-446655440000"
332+-- Just "550e8400-e29b-41d4-a716-446655440000"
333+--
334+--
326335toString :: UUID -> String
327−toString uuid = hexw w0 $ hexw' w1 $ hexw' w2 $ hexw w3 ""
328− where hexw :: Word32 -> String -> String
329− hexw w s = 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
331−
332− hexw' :: Word32 -> String -> String
333− hexw' w s = '-' : 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
335−
336− hexn :: Word32 -> Int -> Char
336+toString uuid = hexw0 w0 $ hexw1 w1 ""
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
340+ : '-' : 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
342+ : s
343+
344+ hexw1 :: Word64 -> String -> String
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
348+ : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0
349+ : s
350+
351+ hexn :: Word64 -> Int -> Char
337352 hexn w r = intToDigit $ fromIntegral ((w `shiftR` r) .&. 0xf)
338353
339− (w0,w1,w2,w3) = toWords uuid
354+ (w0,w1) = toWords64 uuid
340355
341356-- | If the passed in `Text` can be parsed as an ASCII representation of
342357-- a `UUID`, it will be. The hyphens may not be omitted.
343358fromText :: Text -> Maybe UUID
344−fromText = fromString . T.unpack
359+fromText = fromASCIIBytes . T.encodeUtf8
345360
346361-- | Convert a UUID into a hyphentated string using lower-case letters.
347362toText :: UUID -> Text
348−toText = T.pack . toString
363+toText = T.decodeLatin1 . toASCIIBytes
349364
350365-- | Convert a UUID into a hyphentated string using lower-case letters, packed
351366-- as ASCII bytes into `B.ByteString`.
@@ -440,49 +455,30 @@ fromASCIIBytes bs = do
440455-- | Similar to `toASCIIBytes` except we produce a lazy `BL.ByteString`.
441456toLazyASCIIBytes :: UUID -> BL.ByteString
442457toLazyASCIIBytes =
443−#if MIN_VERSION_bytestring(0,10,0)
444458 BL.fromStrict
445−#else
446− BL.fromChunks . return
447−#endif
448459 . toASCIIBytes
449460
450461-- | Similar to `fromASCIIBytes` except parses from a lazy `BL.ByteString`.
451462fromLazyASCIIBytes :: BL.ByteString -> Maybe UUID
452463fromLazyASCIIBytes bs =
453− if BL.length bs == 36 then fromASCIIBytes (
454−#if MIN_VERSION_bytestring(0,10,0)
455− BL.toStrict bs
456−#else
457− B.concat $ BL.toChunks bs
458−#endif
459− ) else Nothing
464+ if BL.length bs == 36 then fromASCIIBytes (BL.toStrict bs) else Nothing
460465
461466--
462467-- Class Instances
463468--
464469
470+-- | This 'Random' instance produces __insecure__ version 4 UUIDs as
471+-- specified in <http://tools.ietf.org/html/rfc4122 RFC 4122>.
465472instance Random UUID where
466− random g = (fromGenNext w0 w1 w2 w3 w4, g4)
467− where (w0, g0) = next g
468− (w1, g1) = next g0
469− (w2, g2) = next g1
470− (w3, g3) = next g2
471− (w4, g4) = next g3
473+ random = uniform
472474 randomR _ = random -- range is ignored
473475
474−-- |Build a UUID from the results of five calls to next on a StdGen.
475−-- While next on StdGet returns an Int, it doesn't provide 32 bits of
476−-- randomness. This code relies on at last 28 bits of randomness in the
477−-- and optimizes its use so as to make only five random values, not six.
478−fromGenNext :: Int -> Int -> Int -> Int -> Int -> UUID
479−fromGenNext w0 w1 w2 w3 w4 =
480− buildFromBytes 4 /-/ (ThreeByte w0)
481− /-/ (ThreeByte w1)
482− /-/ w2 -- use all 4 bytes because we know the version
483− -- field will "cover" the upper, non-random bits
484− /-/ (ThreeByte w3)
485− /-/ (ThreeByte w4)
476+-- @since 1.0.4
477+instance Uniform UUID where
478+ uniformM gen = do
479+ w0 <- uniformWord64 gen
480+ w1 <- uniformWord64 gen
481+ pure $ buildFromBytes 4 /-/ w0 /-/ w1
486482
487483-- |A ByteSource to extract only three bytes from an Int, since next on StdGet
488484-- only returns 31 bits of randomness.
@@ -508,6 +504,11 @@ instance Hashable UUID where
508504 `hashWithSalt` w2
509505 `hashWithSalt` w3
510506
507+-- | Pretty prints a 'UUID' (without quotation marks). See also 'toString'.
508+--
509+-- >>> show nil
510+-- "00000000-0000-0000-0000-000000000000"
511+--
511512instance Show UUID where
512513 show = toString
513514
@@ -518,7 +519,7 @@ instance Read UUID where
518519 Nothing -> []
519520 Just u -> [(u,drop 36 noSpaces)]
520521
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__.
522523instance Storable UUID where
523524 sizeOf _ = 16
524525 alignment _ = 4
@@ -555,6 +556,7 @@ instance Storable UUID where
555556 pokeByteOff p (off+14) x9
556557 pokeByteOff p (off+15) x10
557558
559+-- | This 'Binary' instance is compatible with <http://tools.ietf.org/html/rfc4122 RFC 4122>, storing the fields in network order as 16 bytes.
558560instance Binary UUID where
559561 put (UUID w0 w1) = putWord64be w0 >> putWord64be w1
560562 get = liftM2 UUID getWord64be getWord64be
@@ -570,10 +572,4 @@ instance Data UUID where
570572uuidType :: DataType
571573uuidType = mkNoRepType "Data.UUID.Types.UUID"
572574
573−#if !MIN_VERSION_base(4,5,0)
574−unsafeShiftR, unsafeShiftL :: Bits w => w -> Int -> w
575−{-# INLINE unsafeShiftR #-}
576−unsafeShiftR = shiftR
577−{-# INLINE unsafeShiftL #-}
578−unsafeShiftL = shiftL
579−#endif
575+deriving instance Lift UUID