{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DerivingVia                #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude          #-}
{-# LANGUAGE StandaloneDeriving         #-}
-- | All documentation examples assume the following setup:
--
-- > :set -XOverloadedStrings
-- > import Data.Attoparsec.ByteString
-- > import Data.XML.Parser.High
module Data.XML.Parser.High.AttrParser
  ( AttrParser(..)
  , anyAttr
  , noAttr
  , attrValue
  , hasAttr
  ) where

import           Control.Applicative
import           Control.Arrow
import           Control.Monad.Compat
import           Control.Monad.Fail.Compat
import           Data.Map                  (Map)
import qualified Data.Map                  as Map
import           Data.Text                 (Text)
import qualified Data.Text                 as Text
import           Data.XML.Parser.Low.Name
import           Prelude.Compat

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

-- | How to parse tag attributes.
newtype AttrParser a = AttrParser { AttrParser a -> Map QName Text -> Either String a
runAttrParser :: Map QName Text -> Either String a }

deriving instance Functor AttrParser
deriving via (WrappedArrow (Kleisli (Either String)) (Map QName Text)) instance Applicative AttrParser

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

-- | Can be combined with @>>=@. Attributes map is forwarded without change.
instance Monad AttrParser where
  (AttrParser Map QName Text -> Either String a
f) >>= :: AttrParser a -> (a -> AttrParser b) -> AttrParser b
>>= a -> AttrParser b
g = (Map QName Text -> Either String b) -> AttrParser b
forall a. (Map QName Text -> Either String a) -> AttrParser a
AttrParser ((Map QName Text -> Either String b) -> AttrParser b)
-> (Map QName Text -> Either String b) -> AttrParser b
forall a b. (a -> b) -> a -> b
$ \Map QName Text
attributes -> do
    a
a <- Map QName Text -> Either String a
f Map QName Text
attributes
    let AttrParser Map QName Text -> Either String b
g' = a -> AttrParser b
g a
a
    Map QName Text -> Either String b
g' Map QName Text
attributes

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

-- | Parse any set of attributes.
--
-- >>> parseOnly (runTokenParser $ tag' anyName anyAttr noContent) "<tag></tag>"
-- Right ()
-- >>> parseOnly (runTokenParser $ tag' anyName anyAttr noContent) "<tag key='value'></tag>"
-- Right ()
anyAttr :: AttrParser ()
anyAttr :: AttrParser ()
anyAttr = () -> AttrParser ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Assert that no attributes exist.
--
-- >>> parseOnly (runTokenParser $ tag' anyName noAttr noContent) "<tag></tag>"
-- Right ()
-- >>> parseOnly (runTokenParser $ tag' anyName noAttr noContent) "<tag key='value'></tag>"
-- Left ...
noAttr :: AttrParser ()
noAttr :: AttrParser ()
noAttr = (Map QName Text -> Either String ()) -> AttrParser ()
forall a. (Map QName Text -> Either String a) -> AttrParser a
AttrParser ((Map QName Text -> Either String ()) -> AttrParser ())
-> (Map QName Text -> Either String ()) -> AttrParser ()
forall a b. (a -> b) -> a -> b
$ \Map QName Text
attributes -> if Map QName Text -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map QName Text
attributes then () -> Either String ()
forall a b. b -> Either a b
Right () else String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ String
"Expected no attribute, instead got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Map QName Text -> String
forall a. Show a => a -> String
show Map QName Text
attributes

-- | Parse attribute by name, and return its value.
--
-- >>> parseOnly (runTokenParser $ tag' anyName (attrValue "foo") noContent) "<tag></tag>"
-- Left ...
-- >>> parseOnly (runTokenParser $ tag' anyName (attrValue "foo") noContent) "<tag foo='bar'></tag>"
-- Right ()
attrValue :: QName -> AttrParser Text
attrValue :: QName -> AttrParser Text
attrValue QName
name = (Map QName Text -> Either String Text) -> AttrParser Text
forall a. (Map QName Text -> Either String a) -> AttrParser a
AttrParser ((Map QName Text -> Either String Text) -> AttrParser Text)
-> (Map QName Text -> Either String Text) -> AttrParser Text
forall a b. (a -> b) -> a -> b
$ Either String Text
-> (Text -> Either String Text) -> Maybe Text -> Either String Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String Text
forall a b. a -> Either a b
Left (String -> Either String Text) -> String -> Either String Text
forall a b. (a -> b) -> a -> b
$ String
"Missing attribute named " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> QName -> String
forall a. Show a => a -> String
show QName
name) Text -> Either String Text
forall a b. b -> Either a b
Right (Maybe Text -> Either String Text)
-> (Map QName Text -> Maybe Text)
-> Map QName Text
-> Either String Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Map QName Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QName
name

-- | Assert that an attribute exists, with given name and value.
--
-- >>> parseOnly (runTokenParser $ tag' anyName (hasAttr "foo" "bar") noContent) "<tag></tag>"
-- Left ...
-- >>> parseOnly (runTokenParser $ tag' anyName (hasAttr "foo" "bar") noContent) "<tag foo='baz'></tag>"
-- Left ...
-- >>> parseOnly (runTokenParser $ tag' anyName (hasAttr "foo" "bar") noContent) "<tag foo='bar'></tag>"
-- Right ()
hasAttr :: QName -> Text -> AttrParser ()
hasAttr :: QName -> Text -> AttrParser ()
hasAttr QName
name Text
value = QName -> AttrParser Text
attrValue QName
name AttrParser Text -> (Text -> AttrParser ()) -> AttrParser ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Text
value' -> if Text
value Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
value' then () -> AttrParser ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () else String -> AttrParser ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> AttrParser ()) -> String -> AttrParser ()
forall a b. (a -> b) -> a -> b
$ String
"Expected attribute value " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
value 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
Text.unpack Text
value'