@@ -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,22 +46,15 @@ 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
51−import Data.Functor ((<$>))
53+import Data.Data
5254import Data.Hashable
5355import Data.List (elemIndices)
5456import Foreign.Ptr (Ptr)
5557
56−#if MIN_VERSION_base(4,0,0)
57−import Data.Data
58−#else
59−import Data.Generics.Basics
60−#endif
61−
6258import Foreign.Storable
6359
6460import Data.Binary
@@ -69,19 +65,19 @@ import qualified Data.ByteString.Internal as BI
6965import qualified Data.ByteString.Lazy as BL
7066import qualified Data.ByteString.Unsafe as BU
7167import Data.Text (Text)
72−import qualified Data.Text as T
68+import qualified Data.Text.Encoding as T
7369
7470import Data.UUID.Types.Internal.Builder
7571
76−import System.Random
72+import System.Random (Random (..), uniform)
73+import System.Random.Stateful (Uniform (..), uniformWord64)
7774
75+import Language.Haskell.TH.Syntax (Lift)
7876
79−-- |The UUID type. A 'Random' instance is provided which produces
80−-- insecure version 4 UUIDs as specified in <http://tools.ietf.org/html/rfc4122 RFC 4122>. The 'Storable' and
81−-- 'Binary' instances are compatible with <http://tools.ietf.org/html/rfc4122 RFC 4122>, storing the fields in
82−-- 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>.
8379data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
84− deriving (Eq, Ord, Typeable)
80+ deriving (Eq, Ord)
8581{-
8682 Prior to uuid-types-1.0.4:
8783 !Word32 !Word32 !Word32 !Word32
@@ -100,6 +96,9 @@ data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
10096-- Useful for when you need to serialize a UUID and
10197-- neither 'Storable' nor 'Binary' are appropriate.
10298--
99+-- >>> toWords <$> fromString "550e8400-e29b-41d4-a716-446655440000"
100+-- Just (1427014656,3801825748,2803254374,1430519808)
101+--
103102-- See also 'toWords64'.
104103--
105104-- /Since: @uuid-1.2.2@/
@@ -127,6 +126,9 @@ fromWords w1 w2 w3 w4 = UUID (w32to64 w1 w2) (w32to64 w3 w4)
127126
128127-- | Convert a 'UUID' into a pair of 'Word64's.
129128--
129+-- >>> toWords64 <$> fromString "550e8400-e29b-41d4-a716-446655440000"
130+-- Just (6128981282234515924,12039885860129472512)
131+--
130132-- See also 'toWords'.
131133--
132134-- @since 1.0.4
@@ -193,10 +195,10 @@ pack unpacked =
193195
194196-- |Build a Word32 from four Word8 values, presented in big-endian order
195197word :: Word8 -> Word8 -> Word8 -> Word8 -> Word32
196−word a b c d = (fromIntegral a `shiftL` 24)
197− .|. (fromIntegral b `shiftL` 16)
198− .|. (fromIntegral c `shiftL` 8)
199− .|. (fromIntegral d )
198+word a b c d = (fromIntegral a `unsafeShiftL` 24)
199+ .|. (fromIntegral b `unsafeShiftL` 16)
200+ .|. (fromIntegral c `unsafeShiftL` 8)
201+ .|. (fromIntegral d )
200202
201203-- |Extract a Word8 from a Word64. Bytes, high to low, are numbered from 7 to 0,
202204byte :: Int -> Word64 -> Word8
@@ -205,7 +207,7 @@ byte i w = fromIntegral (w `shiftR` (i * 8))
205207-- |Build a Word16 from two Word8 values, presented in big-endian order.
206208w8to16 :: Word8 -> Word8 -> Word16
207209w8to16 w0s w1s =
208− (w0 `shiftL` 8) .|. w1
210+ (w0 `unsafeShiftL` 8) .|. w1
209211 where
210212 w0 = fromIntegral w0s
211213 w1 = fromIntegral w1s
@@ -239,7 +241,7 @@ buildFromBytes v b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf =
239241 where b6' = b6 .&. 0x0f .|. (v `shiftL` 4)
240242 b8' = b8 .&. 0x3f .|. 0x80
241243
242−-- |Build a UUID of a given version from Word32 values.
244+-- |Build a UUID of a given version from 'Word32' values.
243245buildFromWords :: Word8 -> Word32 -> Word32 -> Word32 -> Word32 -> UUID
244246buildFromWords v w0 w1 w2 w3 = fromWords w0 w1' w2' w3
245247 where w1' = w1 .&. 0xffff0fff .|. ((fromIntegral v) `shiftL` 12)
@@ -273,8 +275,8 @@ null = (== nil)
273275 -- null (UUID 0 0 0 0) = True
274276 -- null _ = False
275277
276−-- |The nil UUID, as defined in <http://tools.ietf.org/html/rfc4122 RFC 4122>.
277−-- 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'@.
278280nil :: UUID
279281nil = UUID 0 0
280282
@@ -284,6 +286,8 @@ fromByteString :: BL.ByteString -> Maybe UUID
284286fromByteString = fromList . BL.unpack
285287
286288-- |Encode a UUID into a 'ByteString' in network order.
289+--
290+-- This uses the same encoding as the 'Binary' instance.
287291toByteString :: UUID -> BL.ByteString
288292toByteString = BL.pack . toList
289293
@@ -291,9 +295,8 @@ toByteString = BL.pack . toList
291295-- The hyphens may not be omitted.
292296-- Example:
293297--
294−-- @
295−-- fromString \"c2cc10e1-57d6-4b6f-9899-38d972112d8c\"
296−-- @
298+-- >>> fromString "c2cc10e1-57d6-4b6f-9899-38d972112d8c"
299+-- Just c2cc10e1-57d6-4b6f-9899-38d972112d8c
297300--
298301-- Hex digits may be upper or lower-case.
299302fromString :: String -> Maybe UUID
@@ -325,32 +328,39 @@ fromString' s0 = do
325328-- | Convert a UUID into a hypenated string using lower-case letters.
326329-- Example:
327330--
328−-- @
329−-- toString \<$\> fromString \"550e8400-e29b-41d4-a716-446655440000\"
330−-- @
331+-- >>> toString <$> fromString "550e8400-e29b-41d4-a716-446655440000"
332+-- Just "550e8400-e29b-41d4-a716-446655440000"
333+--
334+--
331335toString :: UUID -> String
332−toString uuid = hexw w0 $ hexw' w1 $ hexw' w2 $ hexw w3 ""
333− where hexw :: Word32 -> String -> String
334− hexw w s = hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16
335− : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0 : s
336−
337− hexw' :: Word32 -> String -> String
338− hexw' w s = '-' : hexn w 28 : hexn w 24 : hexn w 20 : hexn w 16
339− : '-' : hexn w 12 : hexn w 8 : hexn w 4 : hexn w 0 : s
340−
341− 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
342352 hexn w r = intToDigit $ fromIntegral ((w `shiftR` r) .&. 0xf)
343353
344− (w0,w1,w2,w3) = toWords uuid
354+ (w0,w1) = toWords64 uuid
345355
346356-- | If the passed in `Text` can be parsed as an ASCII representation of
347357-- a `UUID`, it will be. The hyphens may not be omitted.
348358fromText :: Text -> Maybe UUID
349−fromText = fromString . T.unpack
359+fromText = fromASCIIBytes . T.encodeUtf8
350360
351361-- | Convert a UUID into a hyphentated string using lower-case letters.
352362toText :: UUID -> Text
353−toText = T.pack . toString
363+toText = T.decodeLatin1 . toASCIIBytes
354364
355365-- | Convert a UUID into a hyphentated string using lower-case letters, packed
356366-- as ASCII bytes into `B.ByteString`.
@@ -445,49 +455,30 @@ fromASCIIBytes bs = do
445455-- | Similar to `toASCIIBytes` except we produce a lazy `BL.ByteString`.
446456toLazyASCIIBytes :: UUID -> BL.ByteString
447457toLazyASCIIBytes =
448−#if MIN_VERSION_bytestring(0,10,0)
449458 BL.fromStrict
450−#else
451− BL.fromChunks . return
452−#endif
453459 . toASCIIBytes
454460
455461-- | Similar to `fromASCIIBytes` except parses from a lazy `BL.ByteString`.
456462fromLazyASCIIBytes :: BL.ByteString -> Maybe UUID
457463fromLazyASCIIBytes bs =
458− if BL.length bs == 36 then fromASCIIBytes (
459−#if MIN_VERSION_bytestring(0,10,0)
460− BL.toStrict bs
461−#else
462− B.concat $ BL.toChunks bs
463−#endif
464− ) else Nothing
464+ if BL.length bs == 36 then fromASCIIBytes (BL.toStrict bs) else Nothing
465465
466466--
467467-- Class Instances
468468--
469469
470+-- | This 'Random' instance produces __insecure__ version 4 UUIDs as
471+-- specified in <http://tools.ietf.org/html/rfc4122 RFC 4122>.
470472instance Random UUID where
471− random g = (fromGenNext w0 w1 w2 w3 w4, g4)
472− where (w0, g0) = next g
473− (w1, g1) = next g0
474− (w2, g2) = next g1
475− (w3, g3) = next g2
476− (w4, g4) = next g3
473+ random = uniform
477474 randomR _ = random -- range is ignored
478475
479−-- |Build a UUID from the results of five calls to next on a StdGen.
480−-- While next on StdGet returns an Int, it doesn't provide 32 bits of
481−-- randomness. This code relies on at last 28 bits of randomness in the
482−-- and optimizes its use so as to make only five random values, not six.
483−fromGenNext :: Int -> Int -> Int -> Int -> Int -> UUID
484−fromGenNext w0 w1 w2 w3 w4 =
485− buildFromBytes 4 /-/ (ThreeByte w0)
486− /-/ (ThreeByte w1)
487− /-/ w2 -- use all 4 bytes because we know the version
488− -- field will "cover" the upper, non-random bits
489− /-/ (ThreeByte w3)
490− /-/ (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
491482
492483-- |A ByteSource to extract only three bytes from an Int, since next on StdGet
493484-- only returns 31 bits of randomness.
@@ -495,8 +486,8 @@ type instance ByteSink ThreeByte g = Takes3Bytes g
495486newtype ThreeByte = ThreeByte Int
496487instance ByteSource ThreeByte where
497488 f /-/ (ThreeByte w) = f b1 b2 b3
498− where b1 = fromIntegral (w `shiftR` 16)
499− b2 = fromIntegral (w `shiftR` 8)
489+ where b1 = fromIntegral (w `unsafeShiftR` 16)
490+ b2 = fromIntegral (w `unsafeShiftR` 8)
500491 b3 = fromIntegral w
501492
502493instance NFData UUID where
@@ -513,6 +504,11 @@ instance Hashable UUID where
513504 `hashWithSalt` w2
514505 `hashWithSalt` w3
515506
507+-- | Pretty prints a 'UUID' (without quotation marks). See also 'toString'.
508+--
509+-- >>> show nil
510+-- "00000000-0000-0000-0000-000000000000"
511+--
516512instance Show UUID where
517513 show = toString
518514
@@ -523,7 +519,7 @@ instance Read UUID where
523519 Nothing -> []
524520 Just u -> [(u,drop 36 noSpaces)]
525521
526−
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__.
527523instance Storable UUID where
528524 sizeOf _ = 16
529525 alignment _ = 4
@@ -560,6 +556,7 @@ instance Storable UUID where
560556 pokeByteOff p (off+14) x9
561557 pokeByteOff p (off+15) x10
562558
559+-- | This 'Binary' instance is compatible with <http://tools.ietf.org/html/rfc4122 RFC 4122>, storing the fields in network order as 16 bytes.
563560instance Binary UUID where
564561 put (UUID w0 w1) = putWord64be w0 >> putWord64be w1
565562 get = liftM2 UUID getWord64be getWord64be
@@ -575,13 +572,4 @@ instance Data UUID where
575572uuidType :: DataType
576573uuidType = mkNoRepType "Data.UUID.Types.UUID"
577574
578−#if !(MIN_VERSION_base(4,2,0))
579−mkNoRepType :: String -> DataType
580−mkNoRepType = mkNorepType
581−#endif
582−
583−#if !MIN_VERSION_base(4,5,0)
584−unsafeShiftR, unsafeShiftL :: Word64 -> Int -> Word64
585−unsafeShiftR = shiftR
586−unsafeShiftL = shiftL
587−#endif
575+deriving instance Lift UUID