Provide a QuasiQuoter for UUID literals

haskell-hvr · Aug 22, 2018 · a0bce93 · a0bce93
1 parent d1cedd8
commit a0bce93
Show file tree

Hide file tree

Showing 4 changed files with 61 additions and 12 deletions.
diff --git a/uuid-types/Data/UUID/Types/Internal.hs b/uuid-types/Data/UUID/Types/Internal.hs
@@ -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
@@ -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

diff --git a/uuid/Data/UUID/TH.hs b/uuid/Data/UUID/TH.hs
@@ -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"
diff --git 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.TH (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
@@ -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
@@ -72,6 +74,7 @@ Test-Suite testuuid
                      , base
                      , bytestring
                      , random
+                     , template-haskell
                        -- deps w/o inherited constraints
                      , QuickCheck       == 2.11.*
                      , tasty            == 1.0.*