content: -- This file is part of purebred
  -- Copyright (C) 2017-2021 Fraser Tweedale and Róman Joost
  --
  -- purebred is free software: you can redistribute it and/or modify
  -- it under the terms of the GNU Affero General Public License as published by
  -- the Free Software Foundation, either version 3 of the License, or
  -- (at your option) any later version.
  --
  -- This program is distributed in the hope that it will be useful,
  -- but WITHOUT ANY WARRANTY; without even the implied warranty of
  -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  -- GNU Affero General Public License for more details.
  --
  -- You should have received a copy of the GNU Affero General Public License
  -- along with this program.  If not, see <http://www.gnu.org/licenses/>.
  --
  
  -- | This module provides functions to parse tagging operations. These
  -- operations are used for annotating mails or threads with
  -- labels. Notmuch does not support the labelling of threads as such
  -- even though Purebred exposes the functionality. Labeling threads
  -- just means labelling all mails in a thread.
  --
  module Purebred.Storage.Tags
    (
    -- * Constructing tags
      parseTag
  
    -- * Tag operations
    , TagOp(..)
    , parseTagOps
  
    -- * Managing an item's tags
    , ManageTags(..)
    , hasTag
    , tagItem
    , addTags
    , removeTags
    ) where
  
  import Control.Applicative ((<|>), optional)
  import Data.Attoparsec.ByteString.Char8
    ( Parser, parseOnly, isSpace, char, sepBy, takeWhile1 )
  import qualified Data.ByteString as B
  import Data.Functor (($>))
  import Data.List (union)
  import Control.Lens (Lens', over, set, view, _Left)
  import qualified Data.Text as T
  import qualified Data.Text.Encoding as T
  
  import Notmuch (mkTag)
  
  import Purebred.Types
  import Purebred.Types.Parser.ByteString (niceEndOfInput, skipSpaces)
  import Purebred.UI.Notifications (makeWarning)
  
  -- | Tag operations
  data TagOp = RemoveTag Tag | AddTag Tag | ResetTags
    deriving (Eq, Show)
  
  tagOp :: Parser TagOp
  tagOp =
    (char '+' *> (AddTag <$> takeTag))
    <|> (char '-' *> (RemoveTag <$> takeTag))
    where
    takeTag = takeWhile1 (not . isSpace) >>= parseTag
  
  resetOp :: Parser TagOp
  resetOp = char '=' $> ResetTags
  
  allTagOps :: Parser [TagOp]
  allTagOps = tagOp `sepBy` skipSpaces
  
  tagOpsWithReset :: Parser [TagOp]
  tagOpsWithReset = do
    r <- resetOp
    _ <- optional skipSpaces -- no space needed after '='
    ops <- allTagOps
    pure $ r : ops
  
  parseTagOps :: T.Text -> Either UserMessage [TagOp]
  parseTagOps = over _Left (makeWarning StatusBar . T.pack) . parseOnly p . T.encodeUtf8
    where
    p =
      (tagOpsWithReset <|> allTagOps)
      <* optional skipSpaces  -- skip any trailing whitespace
      <* niceEndOfInput       -- assert EOF
  
  parseTag :: B.ByteString -> Parser Tag
  parseTag s = maybe
    (fail $ "not a valid tag: " <> show s)
    pure
    (mkTag s)
  
  -- | Tag either a 'NotmuchMail' or a 'NotmuchThread'
  --
  -- Tag operations are applied left to right.
  --
  tagItem :: ManageTags a => [TagOp] -> a -> a
  tagItem ops mail = foldl (flip applyTagOp) mail ops
  
  applyTagOp :: (ManageTags a) => TagOp -> a -> a
  applyTagOp (AddTag t) = addTags [t]
  applyTagOp (RemoveTag t) = removeTags [t]
  applyTagOp ResetTags = setTags []
  
  class ManageTags a  where
      tags :: Lens' a [Tag]
  
  setTags :: (ManageTags a) => [Tag] -> a -> a
  setTags = set tags
  
  addTags :: (ManageTags a) => [Tag] -> a -> a
  addTags tgs = over tags (`union` tgs)
  
  removeTags :: (ManageTags a) => [Tag] -> a -> a
  removeTags tgs = over tags (filter (`notElem` tgs))
  
  hasTag :: (ManageTags a) => Tag -> a -> Bool
  hasTag t x = t `elem` view tags x
  
  instance ManageTags NotmuchMail where
    tags = mailTags
  
  instance ManageTags NotmuchThread where
    tags = thTags
  