module Purebred.Tags
( parseTag
, parseTagOps
) where
import Control.Applicative ((<|>), optional)
import qualified Data.Attoparsec.Internal.Types as AT
import Data.Attoparsec.ByteString.Char8
( Parser, parseOnly, isSpace, space, char, sepBy
, skipMany1, takeWhile1, endOfInput, peekChar' )
import qualified Data.ByteString as B
import Data.Functor (($>))
import Control.Lens (over, _Left)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Notmuch (Tag, mkTag)
import Types
import Error
tagOp :: Parser TagOp
tagOp =
(char '+' *> (AddTag <$> takeTag))
<|> (char '-' *> (RemoveTag <$> takeTag))
where
takeTag = takeWhile1 (not . isSpace) >>= parseTag
resetOp :: Parser TagOp
resetOp = char '=' $> ResetTags
skipSpaces :: Parser ()
skipSpaces = skipMany1 space
allTagOps :: Parser [TagOp]
allTagOps = tagOp `sepBy` skipSpaces
tagOpsWithReset :: Parser [TagOp]
tagOpsWithReset = do
r <- resetOp
_ <- optional skipSpaces
ops <- allTagOps
pure $ r : ops
parseTagOps :: T.Text -> Either Error [TagOp]
parseTagOps = over _Left (GenericError . show) . parseOnly p . T.encodeUtf8
where
p =
(tagOpsWithReset <|> allTagOps)
<* optional skipSpaces
<* niceEndOfInput
parseTag :: B.ByteString -> Parser Tag
parseTag s = maybe
(fail $ "not a valid tag: " <> show s)
pure
(mkTag s)
niceEndOfInput :: Parser ()
niceEndOfInput = endOfInput <|> p
where
p = do
c <- peekChar'
off <- offset
fail $ "unexpected " <> show c <> " at offset " <> show off
offset :: AT.Parser i Int
offset = AT.Parser $ \t pos more _lose suc -> suc t pos more (AT.fromPos pos)