{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
-- | All documentation examples assume the following setup:
--
-- > :set -XOverloadedStrings
-- > import Data.Attoparsec.ByteString
-- > import Data.XML.Parser.High
module Data.XML.Parser.High.NameParser
( NameParser(..)
, anyName
, anyNameExcept
) where
import Control.Applicative
import Control.Arrow
import Control.Monad
import Data.String
import Data.XML.Parser.Low
-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Data.Attoparsec.ByteString
-- >>> import Data.XML.Parser.High
-- | How to parse tag names.
newtype NameParser a = NameParser { runNameParser :: QName -> Maybe a }
deriving instance Functor NameParser
deriving via (WrappedArrow (Kleisli Maybe) QName) instance Applicative NameParser
-- | Can be combined with @\<|\>@
deriving via (WrappedArrow (Kleisli Maybe) QName) instance Alternative NameParser
-- | Match a single 'QName' in a concise way.
--
-- >>> parseOnly (runTokenParser $ tag' "foo" anyAttr anyContent) ""
-- Right ()
instance (a ~ ()) => IsString (NameParser a) where
fromString s = NameParser $ \(QName _ name) ->
unless (fromString s == name) mempty
-- | Match any qualified name.
anyName :: NameParser QName
anyName = NameParser Just
-- | Match any qualified name, except for the given value.
--
-- >>> parseOnly (runTokenParser $ tag' (anyNameExcept "foo") anyAttr anyContent) ""
-- Left ...
-- >>> parseOnly (runTokenParser $ tag' (anyNameExcept "foo") anyAttr anyContent) ""
-- Right ()
anyNameExcept :: QName -> NameParser QName
anyNameExcept name = NameParser $ \name' -> do
guard $ name /= name'
return name'