content: {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  
  -- | This modules provides marshalling facilities from XML to datatypes
  --
  -- It's modeled closely after Aeson's @FromJSON@, with a couple of differences.
  --
  -- Aeson's @(.:)@ is replaced by three parsing primitives:
  --
  -- - 'attr', which parses string attributes of an element
  -- - 'child', which looks for the first child element with a given name
  -- - 'children', which looks for all child elements with a given name
  --
  -- Use 'parseXML' to parse from a strict Text to your specific datatype
  --
  -- === Optionality
  --
  -- In Aeson, we use @(.:?) :: FromJSON a => Object -> Text -> Parser (Maybe a)@
  -- to allow for elements that might not exist. In 'FromXML' parsers, we use a
  -- slightly different pattern with 'optional' from 'Alternative':
  --
  -- > data Foo = Foo Text
  -- >
  -- > instance FromXML Foo where
  -- >   parseElement el = do
  -- >     maybeBaz <- optional (child "baz" el)
  -- >     case maybeBaz of
  -- >       Nothing -> pure (Foo "defaultbaz")
  -- >       Just baz -> pure (Foo baz)
  --
  -- Similar to Aeson, which has @(.:!) :: Parser (Maybe a) -> a -> Parser a@ as
  -- a helper for defaults, we have 'defaultsTo' which is meant to be used infix:
  --
  -- > instance FromXML Foo where
  -- >   parseElement el = do
  -- >     baz <- optional (child "baz" el) `defaultsTo` "defaultbaz"
  -- >     pure (Foo baz)
  --
  -- Or with Functor/Applicative syntax:
  --
  -- > instance FromXML Foo where
  -- >   parseElement el =
  -- >     Foo <$> optional (child "baz" el) `defaultsTo` "defaultbaz"
  module Parse.XML (
    -- * Types
    FromXML (..),
    Parser (..),
    parseXML,
  
    -- * Parsing an XML element
    attr,
    child,
    children,
    content,
  
    -- * Helper functions
    defaultsTo,
  
    -- * Error formatting
    ParseError (..),
    ParsePath,
    xmlErrorPretty,
  ) where
  
  import Prelude
  
  import Control.Algebra
  import Control.Carrier.Error.Either
  import Control.Carrier.NonDet.Church
  import Control.Carrier.Reader
  import Data.Functor.Identity (Identity)
  import Data.Map.Strict qualified as Map
  import Data.Maybe (fromMaybe)
  import Data.String.Conversion (toText)
  import Data.Text qualified as Text
  import Text.XML.Light qualified as XML
  
  -- | A type that can be converted from XML
  --
  -- This is largely modeled after Aeson's FromJSON class, and has similar
  -- semantics. XML is a little more flexible (everything is modeled as Elements),
  -- so the failure modes are a little less precise.
  class FromXML a where
    parseElement :: XML.Element -> Parser a
  
  instance FromXML XML.Element where
    parseElement = pure
  
  instance FromXML Text.Text where
    parseElement = content
  
  instance FromXML v => FromXML (Map.Map Text.Text v) where
    parseElement el = Map.fromList <$> traverse mkSingle (XML.elChildren el)
      where
        mkSingle e = do
          let key :: Text.Text
              key = toText (XML.qName (XML.elName e))
          value <- parseElement e
          pure (key, value)
  
  newtype Parser a = Parser {unParser :: ReaderC ParsePath (ErrorC ParseError Identity) a}
    deriving (Functor, Applicative, Monad)
  
  instance Alternative Parser where
    ma <|> mb = Parser (unParser ma `catchError` (\(_ :: ParseError) -> unParser mb))
    empty = Parser $ ask >>= \path -> throwError (UnknownError path "Parser.empty")
  
  instance MonadFail Parser where
    fail msg = Parser $ ask >>= \path -> throwError (UnknownError path msg)
  
  runParser :: String -> Parser a -> Either ParseError a
  runParser rootName = run . runError . runReader [rootName] . unParser
  
  data ParseError
    = -- | A 'child' element was missing
      ParseElementMissing ParsePath String
    | -- | An 'attr' was missing
      ParseAttrMissing ParsePath String
    | -- | The input 'Text.Text' didn't contain valid XML
      ParseXMLDocFailed
    | -- | A custom error, likely invoked via 'fail'
      UnknownError ParsePath String
    deriving (Eq, Ord, Show)
  
  -- | Pretty-print a ParseError into strict 'Text.Text'
  xmlErrorPretty :: ParseError -> Text.Text
  xmlErrorPretty = \case
    ParseElementMissing path childName -> "Missing child at " <> renderPath path <> "; childName: " <> toText childName
    ParseAttrMissing path attrName -> "Missing attribute at " <> renderPath path <> "; attrName: " <> toText attrName
    UnknownError path err -> "UnknownError at " <> renderPath path <> "; err: " <> toText err
    ParseXMLDocFailed -> "parseXMLDoc failed"
  
  -- | Render a ParsePath as 'Text.Text'
  renderPath :: ParsePath -> Text.Text
  renderPath [] = "[no path]"
  renderPath xs = (\path -> "[" <> path <> "]") . Text.intercalate "." . map toText . reverse $ xs
  
  -- | Reversed parse path. As we parse into elements, we /prepend/ them to this list
  type ParsePath = [String]
  
  -- | Parse a 'FromXML' value from a strict 'Text.Text'
  parseXML :: FromXML a => Text.Text -> Either ParseError a
  parseXML inp =
    case XML.parseXMLDoc inp of
      Nothing -> Left ParseXMLDocFailed
      Just root -> runParser (XML.qName (XML.elName root)) (parseElement root)
  
  -- | Parse an attribute from an XML Element. This will fail if the attribute
  -- does not exist
  --
  -- For example, given the following as @el@:
  --
  -- > <myelement attrOne="foo" attrTwo="bar"></myelement>
  --
  -- this would succeed:
  --
  -- > (,) <$> attr "attrOne" el <*> attr "attrTwo" el
  attr :: String -> XML.Element -> Parser Text.Text
  attr attrName el =
    case XML.findAttrBy (\elName -> XML.qName elName == attrName) el of
      Nothing -> Parser $ ask >>= \path -> throwError (ParseAttrMissing path attrName)
      Just a -> pure (toText a)
  
  -- | Find a child of an XML Element by its name. This will fail if a child with
  -- the given name does not exist
  --
  -- For example, given the following as @el@:
  --
  -- > <foo><bar></bar></foo>
  --
  -- @child "bar" el@ would succeed.
  --
  -- If there are multiple children with the same name, this returns the first
  child :: FromXML a => String -> XML.Element -> Parser a
  child childName el =
    case XML.filterChildName (\elName -> XML.qName elName == childName) el of
      Nothing -> Parser $ ask >>= \path -> throwError (ParseElementMissing path childName)
      Just a -> subparse childName a
  
  -- | Find all children of an XML element with a given name. __This never
  -- fails__, and will return an empty list if no elements are found.
  --
  -- For example, given the following as @el@:
  --
  -- > <foo><bar></bar><bar></bar></foo>
  --
  -- @children "bar" el@ would produce a two-element list.
  -- @children "baz" el@ would produce an empty list.
  children :: FromXML a => String -> XML.Element -> Parser [a]
  children name = traverse (subparse name) . XML.filterChildrenName (\elName -> XML.qName elName == name)
  
  -- | Get the string content from an XML Element
  --
  -- For example, given the following as @el@:
  --
  -- > <foo>bar baz quux</foo>
  --
  -- @content el@ would produce "bar baz quux"
  content :: XML.Element -> Parser Text.Text
  content = pure . toText . XML.strContent
  
  -- | Helper function to default an optional field to a specific value
  --
  -- This is meant to be used in conjunction with 'optional' from 'Alternative'
  --
  -- For example, given this datatype and parser:
  --
  -- > data Foo = Foo Text
  -- >
  -- > instance FromXML Foo where
  -- >   parseElement el = Foo <$> optional (child "bar" el >>= content) `defaultsTo` "baz"
  --
  -- If the "bar" child exists, we produce the content of that element. Otherwise,
  -- we produce "baz"
  defaultsTo :: Parser (Maybe a) -> a -> Parser a
  defaultsTo fa a = fmap (fromMaybe a) fa
  
  -- parse a child element, and add its name to the parse path
  subparse :: FromXML a => String -> XML.Element -> Parser a
  subparse path el = Parser $ local (path :) (unParser (parseElement el))
  