From 900cbe415e3ee26ab3269bb3d9eccf4d0f3edefb Mon Sep 17 00:00:00 2001
From: Philipp Balzarek <p.balzarek@googlemail.com>
Date: Mon, 17 Jun 2013 13:52:45 +0200
Subject: [PATCH] add jid quasi quoter (jidQ)

---
 pontarius-xmpp.cabal         |  2 ++
 source/Network/Xmpp.hs       |  1 +
 source/Network/Xmpp/Types.hs | 20 ++++++++++++++++++++
 3 files changed, 23 insertions(+)

diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal
index f47d74b..84f7d23 100644
--- a/pontarius-xmpp.cabal
+++ b/pontarius-xmpp.cabal
@@ -56,6 +56,7 @@ Library
                  , split                >=0.1.2.3
                  , stm                  >=2.1.2.1
                  , stringprep           >=0.1.3
+                 , template-haskell     >=2.5
                  , text                 >=0.11.1.5
                  , tls                  >=1.1.0
                  , tls-extra            >=0.5.0
@@ -91,6 +92,7 @@ Library
                  , split                >=0.1.2.3
                  , stm                  >=2.1.2.1
                  , stringprep           >=0.1.3
+                 , template-haskell     >=2.5
                  , text                 >=0.11.1.5
                  , tls                  >=1.1.0
                  , tls-extra            >=0.5.0
diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs
index b5aab7e..56952e6 100644
--- a/source/Network/Xmpp.hs
+++ b/source/Network/Xmpp.hs
@@ -45,6 +45,7 @@ module Network.Xmpp
   -- for addressing entities in the network. It is somewhat similar to an e-mail
   -- address, but contains three parts instead of two.
   , Jid
+  , jidQ
   , isBare
   , isFull
   , jidFromText
diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs
index 8a651b1..4a34341 100644
--- a/source/Network/Xmpp/Types.hs
+++ b/source/Network/Xmpp/Types.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE StandaloneDeriving #-}
@@ -43,6 +44,7 @@ module Network.Xmpp.Types
     , StreamConfiguration(..)
     , langTag
     , Jid(..)
+    , jidQ
     , isBare
     , isFull
     , jidFromText
@@ -76,6 +78,8 @@ import           Data.Text (Text)
 import qualified Data.Text as Text
 import           Data.Typeable(Typeable)
 import           Data.XML.Types
+import           Language.Haskell.TH.Quote
+import           Language.Haskell.TH
 import           Network
 import           Network.DNS
 import           Network.TLS hiding (Version)
@@ -960,6 +964,22 @@ instance Read Jid where
         [(parseJid (read s' :: String), r)] -- May fail with "Prelude.read: no parse"
                                             -- or the `parseJid' error message (see below)
 
+jidQ :: QuasiQuoter
+jidQ = QuasiQuoter { quoteExp = \s -> case jidFromText (Text.pack s) of
+                         Nothing -> fail $ "Could not parse JID " ++ s
+                         Just j -> [| Jid $(mbTextE $ localpart_ j)
+                                          $(textE   $ domainpart_ j)
+                                          $(mbTextE $ resourcepart_ j)
+                                    |]
+                  , quotePat = fail "Jid patterns aren't implemented"
+                  , quoteType = fail "jid QQ can't be used in type context"
+                  , quoteDec  = fail "jid QQ can't be used in declaration context"
+                  }
+  where
+    textE t = [| Text.pack $(stringE $ Text.unpack t) |]
+    mbTextE Nothing = [| Nothing |]
+    mbTextE (Just s) = [| Just $(textE s) |]
+
 -- | Parses a JID string.
 --
 -- Note: This function is only meant to be used to reverse @Jid@ Show