From 5c76183c7df35efb3f664b204dd9c9bf83908cd0 Mon Sep 17 00:00:00 2001
From: Philipp Balzarek <p.balzarek@googlemail.com>
Date: Tue, 15 Dec 2015 15:27:24 +0100
Subject: [PATCH] fix doctests

---
 source/Network/Xmpp/Types.hs  | 11 ++++++-----
 tests/Doctest.hs              |  1 +
 tests/Tests/Arbitrary/Xmpp.hs | 27 +++++++++++++++------------
 3 files changed, 22 insertions(+), 17 deletions(-)

diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs
index 5b27fca..1ccdc2c 100644
--- a/source/Network/Xmpp/Types.hs
+++ b/source/Network/Xmpp/Types.hs
@@ -1029,6 +1029,11 @@ parseJid s = case jidFromText $ Text.pack s of
 -- >>> resourcepart <$> jidFromText "foo@bar/quux"
 -- Just (Just "quux")
 --
+-- @ and / can occur in the domain part
+--
+-- >>> jidFromText "foo/bar@quux/foo"
+-- Just parseJid "foo/bar@quux/foo"
+--
 -- * Counterexamples
 --
 -- A JID must only have one \'\@\':
@@ -1036,11 +1041,6 @@ parseJid s = case jidFromText $ Text.pack s of
 -- >>> jidFromText "foo@bar@quux"
 -- Nothing
 --
--- \'\@\' must come before \'/\':
---
--- >>> jidFromText "foo/bar@quux"
--- Nothing
---
 -- The domain part can\'t be empty:
 --
 -- >>> jidFromText "foo@/quux"
@@ -1057,6 +1057,7 @@ parseJid s = case jidFromText $ Text.pack s of
 --
 -- >>> jidToTexts <$> jidFromText "bar/"
 -- Nothing
+--
 jidFromText :: Text -> Maybe Jid
 jidFromText t = do
     (l, d, r) <- eitherToMaybe $ AP.parseOnly jidParts t
diff --git a/tests/Doctest.hs b/tests/Doctest.hs
index 39ea019..f1d33b9 100644
--- a/tests/Doctest.hs
+++ b/tests/Doctest.hs
@@ -15,6 +15,7 @@ main :: IO ()
 main = doctest $
     "-isource"
   : "-itests"
+  : "-w"
   : "-idist/build/autogen"
   : "-hide-all-packages"
   : "-XQuasiQuotes"
diff --git a/tests/Tests/Arbitrary/Xmpp.hs b/tests/Tests/Arbitrary/Xmpp.hs
index 158e334..6072db3 100644
--- a/tests/Tests/Arbitrary/Xmpp.hs
+++ b/tests/Tests/Arbitrary/Xmpp.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
 module Tests.Arbitrary.Xmpp where
 
 import           Control.Applicative ((<$>), (<*>))
@@ -30,29 +31,31 @@ instance Arbitrary Jid where
         Just jid <- tryJid `suchThat` isJust
         return jid
       where
-        tryJid = jidFromTexts <$> maybeGen (genString nodeprepProfile)
-                              <*> genString (SP.namePrepProfile False)
-                              <*> maybeGen (genString resourceprepProfile)
+        tryJid = jidFromTexts <$> maybeGen (genString nodeprepProfile False)
+                              <*> genString (SP.namePrepProfile False) False
+                              <*> maybeGen (genString resourceprepProfile True)
 
-        genString profile = Text.pack . take 1024 <$> listOf1 genChar
+        genString profile node = Text.pack . take 1024 <$> listOf1 genChar
           where
             genChar = arbitrary `suchThat` (not . isProhibited)
             prohibited = Ranges.toSet $ concat (SP.prohibited profile)
             isProhibited x = Ranges.member x prohibited
-                             || x `elem` "@/"
+                             || if node
+                                then False
+                                else x `elem` ['@','/']
 
     shrink (Jid lp dp rp) = [ Jid lp' dp  rp  | lp' <- shrinkMaybe shrink lp]
                          ++ [ Jid lp  dp' rp  | dp' <- shrink dp]
                          ++ [ Jid lp  dp  rp' | rp' <- shrinkMaybe shrink rp]
 
 
-string :: SP.StringPrepProfile -> Gen [Char]
-string profile = take 1024 <$> listOf1 genChar
-  where
-    genChar = arbitrary `suchThat` (not . isProhibited)
-    prohibited = Ranges.toSet $ concat (SP.prohibited profile)
-    isProhibited x = Ranges.member x prohibited
-                     || x `elem` "@/"
+-- string :: SP.StringPrepProfile -> Gen [Char]
+-- string profile = take 1024 <$> listOf1 genChar
+--   where
+--     genChar = arbitrary `suchThat` (not . isProhibited)
+--     prohibited = Ranges.toSet $ concat (SP.prohibited profile)
+--     isProhibited x = Ranges.member x prohibited
+--                      || x `elem` "@/"
 
 instance Arbitrary LangTag where
     arbitrary = LangTag <$> genTag <*> listOf genTag