diff --git a/source/Network/Xmpp.hs b/source/Network/Xmpp.hs index f230e8f..25712ef 100644 --- a/source/Network/Xmpp.hs +++ b/source/Network/Xmpp.hs @@ -46,7 +46,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 -#if __GLASGOW_HASKELL >= 706 +#if __GLASGOW_HASKELL__ >= 706 , jidQ #endif , isBare @@ -174,6 +174,7 @@ module Network.Xmpp , LangTag , langTagFromText , langTagToText + , parseLangTag , XmppFailure(..) , StreamErrorInfo(..) , StreamErrorCondition(..) diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 8181c34..0e66478 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL >= 706 +#if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE TemplateHaskell #-} #endif @@ -22,6 +22,7 @@ module Network.Xmpp.Types , LangTag (..) , langTagFromText , langTagToText + , parseLangTag , Message(..) , message , MessageError(..) @@ -50,7 +51,7 @@ module Network.Xmpp.Types , ConnectionDetails(..) , StreamConfiguration(..) , Jid(..) -#if __GLASGOW_HASKELL >= 706 +#if __GLASGOW_HASKELL__ >= 706 , jidQ #endif , isBare @@ -86,7 +87,7 @@ import Data.Text (Text) import qualified Data.Text as Text import Data.Typeable(Typeable) import Data.XML.Types -#if __GLASGOW_HASKELL >= 706 +#if __GLASGOW_HASKELL__ >= 706 import Language.Haskell.TH import Language.Haskell.TH.Quote #endif @@ -598,7 +599,7 @@ versionParser = do -- has a primary tag and a number of subtags. Two language tags are considered -- equal if and only if they contain the same tags (case-insensitive). data LangTag = LangTag { primaryTag :: !Text - , subtags :: ![Text] } deriving (Read, Show) + , subtags :: ![Text] } -- Equals for language tags is not case-sensitive. instance Eq LangTag where @@ -774,7 +775,7 @@ instance Read Jid where [(parseJid (read s' :: String), r)] -- May fail with "Prelude.read: no parse" -- or the `parseJid' error message (see below) -#if __GLASGOW_HASKELL >= 706 +#if __GLASGOW_HASKELL__ >= 706 jidQ :: QuasiQuoter jidQ = QuasiQuoter { quoteExp = \s -> do when (head s == ' ') . fail $ "Leading whitespaces in JID" ++ show s @@ -796,6 +797,28 @@ jidQ = QuasiQuoter { quoteExp = \s -> do mbTextE (Just s) = [| Just $(textE s) |] #endif +-- Produces a LangTag value in the format "parseLangTag \"\"". +instance Show LangTag where + show l = "parseLangTag " ++ show (langTagToText l) + +-- The string must be in the format "parseLangTag \"\"". This is based +-- on parseJid, and suffers the same problems. +instance Read LangTag where + readsPrec _ s = do + let (s', r) = case lex s of + [] -> error "Expected `parseLangTag \"\"'" + [("parseLangTag", r')] -> case lex r' of + [] -> error "Expected `parseLangTag \"\"'" + [(s'', r'')] -> (s'', r'') + _ -> error "Expected `parseLangTag \"\"'" + _ -> error "Expected `parseLangTag \"\"'" + [(parseLangTag (read s' :: String), r)] + +parseLangTag :: String -> LangTag +parseLangTag s = case langTagFromText $ Text.pack s of + Just l -> l + Nothing -> error $ "Language tag value (" ++ s ++ ") did not validate" + -- | Parses a JID string. -- -- Note: This function is only meant to be used to reverse @Jid@ Show