better git-annex tag handling
Allow the tag to contain a value. Better extraction of the attribute value.
This commit is contained in:
parent
b827afba03
commit
dbff2a1d73
1 changed files with 8 additions and 8 deletions
|
@ -38,23 +38,23 @@ class GitAnnexTaggable a where
|
||||||
hasGitAnnexTag = isJust . extractGitAnnexTag
|
hasGitAnnexTag = isJust . extractGitAnnexTag
|
||||||
|
|
||||||
instance GitAnnexTaggable Message where
|
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
|
extractGitAnnexTag = headMaybe . filter isGitAnnexTag . messagePayloads
|
||||||
|
|
||||||
instance GitAnnexTaggable Presence where
|
instance GitAnnexTaggable Presence where
|
||||||
-- always mark extended away
|
-- 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
|
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 :: GitAnnexTaggable a => a -> Maybe (Name, Text)
|
||||||
getGitAnnexAttrValue a = case extractGitAnnexTag a of
|
getGitAnnexAttrValue a = case extractGitAnnexTag a of
|
||||||
Just (Element _ [(attr, content)] []) -> Just $
|
Just (tag@(Element _ [(attr, _)] _)) -> (,)
|
||||||
(attr, T.concat $ map unpack content)
|
<$> pure attr
|
||||||
|
<*> attributeText attr tag
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
where
|
|
||||||
unpack (ContentText t) = t
|
|
||||||
unpack (ContentEntity t) = t
|
|
||||||
|
|
||||||
{- A presence with a git-annex tag in it. -}
|
{- A presence with a git-annex tag in it. -}
|
||||||
gitAnnexPresence :: Element -> Presence
|
gitAnnexPresence :: Element -> Presence
|
||||||
|
|
Loading…
Reference in a new issue