-- Copyright (c) 2010 John Millikin
--
-- Permission is hereby granted, free of charge, to any person
-- obtaining a copy of this software and associated documentation
-- files (the "Software"), to deal in the Software without
-- restriction, including without limitation the rights to use,
-- copy, modify, merge, publish, distribute, sublicense, and/or sell
-- copies of the Software, and to permit persons to whom the
-- Software is furnished to do so, subject to the following
-- conditions:
--
-- The above copyright notice and this permission notice shall be
-- included in all copies or substantial portions of the Software.
--
-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
-- OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
-- HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
-- WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-- FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
-- OTHER DEALINGS IN THE SOFTWARE.

module Data.XML.Types
	( -- * Types
	  -- ** Document prologue
	  Document (..)
	, Prologue (..)
	, Instruction (..)
	, Miscellaneous (..)
	
	-- ** Document body
	, Node (..)
	, Element (..)
	, Attribute (..)
	, Content (..)
	, Name (..)
	, Named (..)
	
	-- ** Doctypes
	, Doctype (..)
	, ExternalID (..)
	, InternalSubset
	
	-- ** Incremental processing
	, Event (..)
	
	-- * Predicates
	, isElement
	, isInstruction
	, isContent
	, isComment
	, isNamed
	
	-- * Filters
	, nodeChildren
	, elementChildren
	, hasAttribute
	, position
	) where
import Control.Monad ((>=>))
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as T
import Data.String (IsString, fromString)

data Document = Document
	{ documentPrologue :: Prologue
	, documentRoot :: Element
	, documentEpilogue :: [Miscellaneous]
	}
	deriving (Show, Eq)

data Prologue = Prologue
	{ prologueBefore :: [Miscellaneous]
	, prologueDoctype :: Maybe Doctype
	, prologueAfter :: [Miscellaneous]
	}
	deriving (Show, Eq)

data Instruction = Instruction
	{ instructionTarget :: Text
	, instructionData :: Text
	}
	deriving (Show, Eq)

data Miscellaneous
	= MiscInstruction Instruction
	| MiscComment Text
	deriving (Show, Eq)

data Node
	= NodeElement Element
	| NodeInstruction Instruction
	| NodeContent Content
	| NodeComment Text
	deriving (Show, Eq)

data Element = Element
	{ elementName :: Name
	, elementAttributes :: [Attribute]
	, elementNodes :: [Node]
	}
	deriving (Show, Eq)

data Attribute = Attribute
	{ attributeName :: Name
	, attributeContent :: [Content]
	}
	deriving (Show, Eq)

data Content
	= ContentText Text
	| ContentEntity Text
	deriving (Show, Eq)

-- | The 'Eq' instance for 'Name' ignores prefixes.
--
-- The 'IsString' instance for 'Name' allows entry using Clark notation;
-- see <http://www.jclark.com/xml/xmlns.htm> and
-- <http://infohost.nmt.edu/tcc/help/pubs/pylxml/etree-QName.html>
data Name = Name
	{ nameLocalName :: Text
	, nameNamespace :: Maybe Text
	, namePrefix :: Maybe Text
	}
	deriving (Show)

-- Ignore prefixes when comparing names
instance Eq Name where
	x == y = and
		[ nameLocalName x == nameLocalName y
		, nameNamespace x == nameNamespace y
		]

instance IsString Name where
	fromString "" = Name T.empty Nothing Nothing
	fromString full@('{':rest) = case break (== '}') rest of
		(_, "") -> error ("Invalid Clark notation: " ++ show full)
		(ns, local) -> Name (T.pack (drop 1 local)) (Just (T.pack ns)) Nothing
	fromString local = Name (T.pack local) Nothing Nothing

class Named a where
	getName :: a -> Name

instance Named Element where
	getName = elementName

instance Named Attribute where
	getName = attributeName

data Doctype = Doctype
	{ doctypeName :: Text
	, doctypeExternalID :: Maybe ExternalID
	, doctypeInternalSubsets :: [InternalSubset]
	}
	deriving (Show, Eq)

data ExternalID
	= SystemID Text
	| PublicID Text Text
	deriving (Show, Eq)

data InternalSubset = InternalSubset
	-- TODO
	deriving (Show, Eq)

-- | Some XML processing tools are incremental, and work in terms of events
-- rather than node trees. Defining the event type here, even though it won't
-- be useful to most users, allows these packages to interoperate more easily.
data Event
	= EventBeginDocument
	| EventEndDocument
	| EventInstruction Instruction
	| EventDoctype Doctype
	| EventBeginElement Name [Attribute]
	| EventEndElement Name
	| EventContent Content
	| EventComment Text
	deriving (Show, Eq)

isElement :: Node -> [Element]
isElement (NodeElement e) = [e]
isElement _ = []

isInstruction :: Node -> [Instruction]
isInstruction (NodeInstruction i) = [i]
isInstruction _ = []

isContent :: Node -> [Content]
isContent (NodeContent c) = [c]
isContent _ = []

isComment :: Node -> [Text]
isComment (NodeComment t) = [t]
isComment _ = []

isNamed :: Named a => Name -> a -> [a]
isNamed n x = [x | getName x == n]

elementChildren :: Element -> [Element]
elementChildren = elementNodes >=> isElement

nodeChildren :: Node -> [Node]
nodeChildren = isElement >=> elementNodes

position :: Integer -> (a -> [b]) -> a -> [b]
position n f e = safeHead n (f e)

safeHead :: Integer -> [a] -> [a]
safeHead _ [] = []
safeHead 0 (x:_) = [x]
safeHead n (_:xs) = safeHead (n - 1) xs

hasAttribute :: (Attribute -> [Attribute]) -> Element -> [Element]
hasAttribute f e = [e | not $ null (elementAttributes e >>= f)]