From dbff2a1d732b767a6c91da1520605969c0d74b45 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 7 Nov 2012 15:47:30 -0400 Subject: [PATCH] better git-annex tag handling Allow the tag to contain a value. Better extraction of the attribute value. --- Assistant/XMPP.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs index 37cf003748..48357bd610 100644 --- a/Assistant/XMPP.hs +++ b/Assistant/XMPP.hs @@ -38,23 +38,23 @@ class GitAnnexTaggable a where hasGitAnnexTag = isJust . extractGitAnnexTag instance GitAnnexTaggable Message where - insertGitAnnexTag m e = m { messagePayloads = e : messagePayloads m } + insertGitAnnexTag m elt = m { messagePayloads = elt : messagePayloads m } extractGitAnnexTag = headMaybe . filter isGitAnnexTag . messagePayloads instance GitAnnexTaggable Presence where -- always mark extended away - insertGitAnnexTag p e = p { presencePayloads = extendedAway : e : presencePayloads p } + insertGitAnnexTag p elt = p { presencePayloads = extendedAway : elt : presencePayloads p } extractGitAnnexTag = headMaybe . filter isGitAnnexTag . presencePayloads -{- Gets the attr and value from a git-annex tag. -} +{- Gets the attr and its value value from a git-annex tag. + - + - Each git-annex tag has a single attribute. -} getGitAnnexAttrValue :: GitAnnexTaggable a => a -> Maybe (Name, Text) getGitAnnexAttrValue a = case extractGitAnnexTag a of - Just (Element _ [(attr, content)] []) -> Just $ - (attr, T.concat $ map unpack content) + Just (tag@(Element _ [(attr, _)] _)) -> (,) + <$> pure attr + <*> attributeText attr tag _ -> Nothing - where - unpack (ContentText t) = t - unpack (ContentEntity t) = t {- A presence with a git-annex tag in it. -} gitAnnexPresence :: Element -> Presence