{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DerivingVia                #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude          #-}
{-# 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.Compat
import           Control.Monad.Fail.Compat
import           Data.String
import           Data.XML.Parser.Low
import           Prelude.Compat

-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Data.Attoparsec.ByteString
-- >>> import Data.XML.Parser.High

-- | How to parse tag names.
newtype NameParser a = NameParser { NameParser a -> QName -> Either String a
runNameParser :: QName -> Either String a }

deriving instance Functor NameParser
deriving via (WrappedArrow (Kleisli (Either String)) QName) instance Applicative NameParser

-- | Can be combined with @\<|\>@
deriving via (WrappedArrow (Kleisli (Either String)) QName) instance Alternative NameParser

-- | Match a single 'QName' in a concise way.
--
-- >>> parseOnly (runTokenParser $ tag' "foo" anyAttr anyContent) "<foo></foo>"
-- Right ()
instance (a ~ ()) => IsString (NameParser a) where
  fromString :: String -> NameParser a
fromString String
s = NameParser QName
anyName NameParser QName -> (QName -> NameParser ()) -> NameParser ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(QName Text
_ Text
name) ->
    Bool -> NameParser () -> NameParser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Text
forall a. IsString a => String -> a
fromString String
s Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
name) (NameParser () -> NameParser ()) -> NameParser () -> NameParser ()
forall a b. (a -> b) -> a -> b
$ String -> NameParser ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> NameParser ()) -> String -> NameParser ()
forall a b. (a -> b) -> a -> b
$ String
"Expected tag named " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", instead got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
name

-- | Can be combined with @>>=@. Qualified name is forwarded without change.
instance Monad NameParser where
  (NameParser QName -> Either String a
f) >>= :: NameParser a -> (a -> NameParser b) -> NameParser b
>>= a -> NameParser b
g = (QName -> Either String b) -> NameParser b
forall a. (QName -> Either String a) -> NameParser a
NameParser ((QName -> Either String b) -> NameParser b)
-> (QName -> Either String b) -> NameParser b
forall a b. (a -> b) -> a -> b
$ \QName
name -> do
    a
a <- QName -> Either String a
f QName
name
    let NameParser QName -> Either String b
g' = a -> NameParser b
g a
a
    QName -> Either String b
g' QName
name

instance MonadFail NameParser where
  fail :: String -> NameParser a
fail String
message = (QName -> Either String a) -> NameParser a
forall a. (QName -> Either String a) -> NameParser a
NameParser ((QName -> Either String a) -> NameParser a)
-> (QName -> Either String a) -> NameParser a
forall a b. (a -> b) -> a -> b
$ Either String a -> QName -> Either String a
forall a b. a -> b -> a
const (Either String a -> QName -> Either String a)
-> Either String a -> QName -> Either String a
forall a b. (a -> b) -> a -> b
$ String -> Either String a
forall a b. a -> Either a b
Left String
message

-- | Match any qualified name.
anyName :: NameParser QName
anyName :: NameParser QName
anyName = (QName -> Either String QName) -> NameParser QName
forall a. (QName -> Either String a) -> NameParser a
NameParser QName -> Either String QName
forall a b. b -> Either a b
Right

-- | Match any qualified name, except for the given value.
--
-- >>> parseOnly (runTokenParser $ tag' (anyNameExcept "foo") anyAttr anyContent) "<foo></foo>"
-- Left ...
-- >>> parseOnly (runTokenParser $ tag' (anyNameExcept "foo") anyAttr anyContent) "<bar></bar>"
-- Right ()
anyNameExcept :: QName -> NameParser QName
anyNameExcept :: QName -> NameParser QName
anyNameExcept QName
name = (QName -> Either String QName) -> NameParser QName
forall a. (QName -> Either String a) -> NameParser a
NameParser ((QName -> Either String QName) -> NameParser QName)
-> (QName -> Either String QName) -> NameParser QName
forall a b. (a -> b) -> a -> b
$ \QName
name' -> if QName
name QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
name'
  then String -> Either String QName
forall a b. a -> Either a b
Left (String -> Either String QName) -> String -> Either String QName
forall a b. (a -> b) -> a -> b
$ String
"Expected any tag name except " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> QName -> String
forall a. Show a => a -> String
show QName
name
  else QName -> Either String QName
forall a b. b -> Either a b
Right QName
name'