git.iko.soy/typeable/uuid
on 10d0bad help sign in
typeable/uuid/Data/UUID.hs
170 lines 3.8 kB history raw
1{-# INCLUDE "cbits.h" #-}
2{-# LANGUAGE ForeignFunctionInterface, CPP #-}
4module Data.UUID(UUID
5 ,fromString
6 ,toString
7 ,toStringUpper
8 ,toStringLower
9 ,generate
10 ,generateRandom
11 ,generateTime
12 ,null
13 )
14where
16import Foreign.C.String
17import Foreign.C
18import Foreign
20import Data.Char
22import Prelude hiding (null)
24#if defined(__GLASGOW_HASKELL__)
25import GHC.Base (unsafeChr)
26#endif
28newtype UUID = U C_UUID
30type C_UUID = Ptr ()
32instance Eq UUID where
33 (U a) == (U b) = c_compare a b == 0
35instance Ord UUID where
36 compare (U p1) (U p2) =
37 case c_compare p1 p2 of
38 0 -> EQ
39 n|n<0 -> LT
40 |n>0 -> GT
42instance Show UUID where
43 show = toString
45generate :: IO UUID
46generate = do
47 p <- mallocBytes 16
48 c_generate p
49 return $ U p
51generateRandom :: IO UUID
52generateRandom = do
53 p <- mallocBytes 16
54 c_generate_random p
55 return $ U p
57generateTime :: IO UUID
58generateTime = do
59 p <- mallocBytes 16
60 c_generate_time p
61 return $ U p
63null :: UUID -> Bool
64null (U p) = c_null p /= 0
66fromString :: String -> Maybe UUID
67fromString s = unsafePerformIO $ do
68 p <- mallocBytes 16
69 chars <- mallocBytes 37
70 pack 0 s chars
71 res <- c_read p (castPtr chars)
72 case res of
73 0 -> return . Just $ U p
74 _ -> return Nothing
76pack :: Int -> String -> Ptr Word8 -> IO ()
77pack 37 _ p = pokeByteOff p 37 (0 :: Word8)
78pack n (c:cs) p = do
79 pokeByteOff p n (c2w c)
80 pack (n+1) cs p
81pack n [] p = pokeByteOff p n (0 :: Word8)
83unpack :: Ptr Word8 -> Int -> IO String
84unpack p 37 = return []
85unpack p n = do
86 c <- peekByteOff p n
87 case c of
88 0 -> return []
89 _ -> do
90 cs <- unpack p (n+1)
91 return $ (w2c c) : cs
93toString :: UUID -> String
94toString (U p) = unsafePerformIO $ do
95 chars <- mallocBytes 37
96 c_show p chars
97 unpack (castPtr chars) 0
99toStringLower :: UUID -> String
100toStringLower (U p) = unsafePerformIO $ do
101 chars <- mallocBytes 37
102 c_show_lower p chars
103 unpack (castPtr chars) 0
105toStringUpper :: UUID -> String
106toStringUpper (U p) = unsafePerformIO $ do
107 chars <- mallocBytes 37
108 c_show_upper p chars
109 unpack (castPtr chars) 0
111-- | Conversion between 'Word8' and 'Char'. Should compile to a no-op.
112-- Shamelessly stolen from the 'bytestring' package.
113w2c :: Word8 -> Char
114#if !defined(__GLASGOW_HASKELL__)
115w2c = chr . fromIntegral
116#else
117w2c = unsafeChr . fromIntegral
118#endif
119{-# INLINE w2c #-}
121-- | Unsafe conversion between 'Char' and 'Word8'. This is a no-op and
122-- silently truncates to 8 bits Chars > '\255'. It is provided as
123-- convenience for ByteString construction.
124-- Shamelessly stolen from the 'bytestring' package.
125c2w :: Char -> Word8
126c2w = fromIntegral . ord
127{-# INLINE c2w #-}
129-- comparing UUIDs
130foreign import ccall unsafe "c_compare"
131 c_compare :: C_UUID -> C_UUID -> CInt
133-- making random UUIDs
134foreign import ccall unsafe "c_generate"
135 c_generate :: C_UUID -> IO ()
137foreign import ccall unsafe "c_generate_time"
138 c_generate_time :: C_UUID -> IO ()
140foreign import ccall unsafe "c_generate_random"
141 c_generate_random :: C_UUID -> IO ()
143-- Null check
144foreign import ccall unsafe "c_null"
145 c_null :: C_UUID -> CInt
148-- Parsing
149foreign import ccall unsafe "c_read"
150 c_read :: C_UUID -> CString ->IO CInt
152-- Showing
154foreign import ccall unsafe "c_show"
155 c_show :: C_UUID -> CString -> IO ()
157foreign import ccall unsafe "c_show_lower"
158 c_show_lower :: C_UUID -> CString -> IO ()
160foreign import ccall unsafe "c_show_upper"
161 c_show_upper :: C_UUID -> CString -> IO ()
164-- Queries
166foreign import ccall unsafe "c_type"
167 c_type :: C_UUID -> CInt
169foreign import ccall unsafe "c_variant"
170 c_variant :: C_UUID -> CInt