Skip to content

Commit

Permalink
Provide a QuasiQuoter for UUID literals
Browse files Browse the repository at this point in the history
  • Loading branch information
jessekempf authored and Jesse Kempf committed Aug 22, 2018
1 parent d1cedd8 commit a0bce93
Show file tree
Hide file tree
Showing 4 changed files with 61 additions and 12 deletions.
6 changes: 6 additions & 0 deletions uuid-types/Data/UUID/Types/Internal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -56,6 +56,8 @@ import Data.Data
import Data.Functor ((<$>))
import Data.Hashable
import Data.List (elemIndices)
import Data.Maybe (fromMaybe)
import qualified Data.String as S (IsString (..))
import Foreign.Ptr (Ptr)

import Foreign.Storable
Expand All @@ -79,6 +81,10 @@ import System.Random
-- <http://tools.ietf.org/html/rfc4122 RFC 4122>.
data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
deriving (Eq, Ord, Typeable)

instance S.IsString UUID where
fromString str = fromMaybe (error ("'" ++ str ++ "' is not a valid UUID")) $ fromString str

{-
Prior to uuid-types-1.0.4:
!Word32 !Word32 !Word32 !Word32
Expand Down
30 changes: 30 additions & 0 deletions uuid/Data/UUID/TH.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,30 @@
{-# LANGUAGE TemplateHaskell #-}

module Data.UUID.TH (uuid) where

import Data.Maybe (fromMaybe)
import Data.UUID (fromString, fromWords, toWords)
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax

uuid :: QuasiQuoter
uuid = QuasiQuoter
{ quoteExp = uuidExp
, quotePat = \_ -> fail "illegal UUID QuasiQuote (allowed as expression only, used as a pattern)"
, quoteType = \_ -> fail "illegal UUID QuasiQuote (allowed as expression only, used as a type)"
, quoteDec = \_ -> fail "illegal UUID QuasiQuote (allowed as expression only, used as a declaration)"
}

uuidExp :: String -> Q Exp
uuidExp uuidStr =
return $ AppE (AppE (AppE (AppE (VarE 'fromWords) w1e) w2e) w3e) w4e

where
(w1, w2, w3, w4) = toWords parsedUUID
wordExp = LitE . IntegerL . fromIntegral
w1e = wordExp w1
w2e = wordExp w2
w3e = wordExp w3
w4e = wordExp w4
parsedUUID = fromMaybe (error errmsg) $ fromString uuidStr
errmsg = "'" ++ uuidStr ++ "' is not a valid UUID"
12 changes: 11 additions & 1 deletion uuid/tests/TestUUID.hs
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ViewPatterns #-}

import Control.Monad (replicateM)
Expand All @@ -8,6 +9,7 @@ import Data.List (nub, (\\))
import Data.Maybe
import Data.Word
import qualified Data.UUID as U
import Data.UUID.TH (uuid)
import qualified Data.UUID.V1 as U
import qualified Data.UUID.V3 as U3
import qualified Data.UUID.V5 as U5
Expand Down Expand Up @@ -65,6 +67,13 @@ test_v5 =
where name = map (fromIntegral . ord) "www.widgets.com" :: [Word8]
uV5 = fromJust $ U.fromString "21f7f8de-8051-5b89-8680-0195ef798b6a"

test_qq :: Test
test_qq =
testCase "Quasiquoter" $
[uuid|123e4567-e89b-12d3-a456-426655440000|] @?= expected

where
expected = fromJust $ U.fromString "123e4567-e89b-12d3-a456-426655440000"

prop_randomsValid :: Test
prop_randomsValid = testProperty "Random valid" randomsValid
Expand Down Expand Up @@ -101,7 +110,8 @@ main = do
test_null,
test_v1 v1s,
test_v3,
test_v5
test_v5,
test_qq
]
, [ prop_randomsValid,
prop_v3NotNull,
Expand Down
25 changes: 14 additions & 11 deletions uuid/uuid.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -30,20 +30,22 @@ Source-Repository head
Subdir: uuid

Library
Build-Depends: base >= 4.3 && < 5
, binary >= 0.4 && < 0.9
, bytestring >= 0.10 && < 0.11
, cryptohash-sha1 >= 0.11.100 && < 0.12
, cryptohash-md5 >= 0.11.100 && < 0.12
, entropy >= 0.3.7 && < 0.5
, network-info == 0.2.*
, random >= 1.0.1 && < 1.2
, time >= 1.1 && < 1.9
, text >= 1.2.3 && < 1.3
, uuid-types >= 1.0.2 && < 2
Build-Depends: base >= 4.3 && < 5
, binary >= 0.4 && < 0.9
, bytestring >= 0.10 && < 0.11
, cryptohash-sha1 >= 0.11.100 && < 0.12
, cryptohash-md5 >= 0.11.100 && < 0.12
, entropy >= 0.3.7 && < 0.5
, network-info == 0.2.*
, random >= 1.0.1 && < 1.2
, template-haskell >= 2.7 && < 3
, time >= 1.1 && < 1.9
, text >= 1.2.3 && < 1.3
, uuid-types >= 1.0.2 && < 2

Exposed-Modules:
Data.UUID
Data.UUID.TH
Data.UUID.Util
Data.UUID.V1
Data.UUID.V3
Expand Down Expand Up @@ -72,6 +74,7 @@ Test-Suite testuuid
, base
, bytestring
, random
, template-haskell
-- deps w/o inherited constraints
, QuickCheck == 2.11.*
, tasty == 1.0.*
Expand Down

0 comments on commit a0bce93

Please sign in to comment.