diff --git a/uuid/Data/UUID/Quasi.hs b/uuid/Data/UUID/Quasi.hs new file mode 100644 index 0000000..da75d0b --- /dev/null +++ b/uuid/Data/UUID/Quasi.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Data.UUID.Quasi (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" diff --git a/uuid/tests/TestUUID.hs b/uuid/tests/TestUUID.hs index 4650354..c893b88 100644 --- a/uuid/tests/TestUUID.hs +++ b/uuid/tests/TestUUID.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ViewPatterns #-} import Control.Monad (replicateM) @@ -8,6 +9,7 @@ import Data.List (nub, (\\)) import Data.Maybe import Data.Word import qualified Data.UUID as U +import Data.UUID.Quasi (uuid) import qualified Data.UUID.V1 as U import qualified Data.UUID.V3 as U3 import qualified Data.UUID.V5 as U5 @@ -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 @@ -101,7 +110,8 @@ main = do test_null, test_v1 v1s, test_v3, - test_v5 + test_v5, + test_qq ] , [ prop_randomsValid, prop_v3NotNull, diff --git a/uuid/uuid.cabal b/uuid/uuid.cabal index d373e9c..1a3d384 100644 --- a/uuid/uuid.cabal +++ b/uuid/uuid.cabal @@ -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 && < 2.14 + , time >= 1.1 && < 1.9 + , text >= 1.2.3 && < 1.3 + , uuid-types >= 1.0.2 && < 2 Exposed-Modules: Data.UUID + Data.UUID.Quasi Data.UUID.Util Data.UUID.V1 Data.UUID.V3 @@ -72,6 +74,7 @@ Test-Suite testuuid , base , bytestring , random + , template-haskell -- deps w/o inherited constraints , QuickCheck == 2.11.* , tasty == 1.0.*