{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {- Copyright (c) 2019 Herbert Valerio Riedel This file is free software: you may copy, redistribute and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This file is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program (see `LICENSE.GPLv3`). If not, see . This file incorporates work covered by the following copyright and permission notice: (c) 2007 Galois Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} -- | -- Module : Text.XML.Types -- Copyright : (c) Galois, Inc. 2007 -- (c) Herbert Valerio Riedel 2019 -- SPDX-License-Identifier: BSD-3-Clause AND GPL-3.0-or-later -- -- Basic XML types. -- module Text.XML.Types where import Common import qualified Data.Text.Short as TS import Utils type Root = Root' Content -- | Represents the implicit root node of an XML document -- -- @since 0.2.0 data Root' cnode = Root { rootXmlDeclaration :: Maybe XmlDeclaration -- ^ (optional) XML declaration , rootPreElem :: MiscNodes -- ^ Miscellaneous nodes before root element & DOCTYPE declaration , rootDoctype :: Maybe (Text,MiscNodes) -- ^ optional DOCTYPE declaration and more miscellaneous nodes between DOCTYPE and root element , rootElement :: Element' cnode -- ^ The single root document element , rootPostElem :: MiscNodes -- ^ Miscellaneous nodes after root element } deriving (Show, Typeable, Data, Generic, Functor, Foldable, Traversable) instance NFData cnode => NFData (Root' cnode) -- | Sequence of \"miscellaneous\" nodes -- -- @since 0.2.0 type MiscNodes = [Either Comment PI] -- | Denotes the @\@ declaration -- -- @since 0.2.0 data XmlDeclaration = XmlDeclaration (Maybe ShortText) (Maybe Bool) deriving (Show, Typeable, Data, Generic) instance NFData XmlDeclaration -- | Processing instruction -- -- @since 0.2.0 data PI = PI { piTarget :: !ShortText -- ^ Invariant: MUST not be @[Xx][Mm][Ll]@ , piData :: !Text -- ^ Invariant: MUST not contain @?>@ } deriving (Show, Typeable, Data, Generic) instance NFData PI -- | Represents a XML comment -- -- Invariant: SHOULD not contain @--@ (occurences of @--@ will be automatically substituted by @-~@ on serialization) -- -- @since 0.2.0 newtype Comment = Comment Text deriving (Show, Typeable, Data, Generic, NFData) -- | XML content -- -- @since 0.2.0 data Content = Elem Element | Text CData | CRef !ShortText | Proc PI | Comm Comment deriving (Show, Typeable, Data, Generic) instance NFData Content type Element = Element' Content -- | XML elements data Element' cnode = Element { elName :: !QName , elAttribs :: [Attr] , elContent :: [cnode] } deriving (Show, Typeable, Data, Generic, Functor, Foldable, Traversable) instance NFData cnode => NFData (Element' cnode) -- | XML attributes data Attr = Attr { attrKey :: !QName , attrVal :: !Text } deriving (Eq, Ord, Show, Typeable, Data, Generic) instance NFData Attr -- | XML CData data CData = CData { cdVerbatim :: !CDataKind , cdData :: !Text } deriving (Show, Typeable, Data, Generic) instance NFData CData data CDataKind = CDataText -- ^ Ordinary character data; pretty printer escapes &, < etc. | CDataVerbatim -- ^ Unescaped character data; pretty printer embeds it in -- -- NB: Among other properties this means that an 'NCName' shall never be the empty string. -- -- @since 0.2.0 type NCName = ShortText -- | XML (expanded) qualified names -- data QName = QName { qLName :: !LName -- ^ Local name part , qURI :: !URI -- ^ Invariant: the `qURI' field MUST always be populated with the proper namespace. Specifically, entities belonging to the or must have the 'qURI' field accordingly , qPrefix :: Maybe NCName -- ^ Invariant: MUST be a proper } deriving (Show, Typeable, Data, Generic) instance NFData QName -- | Compares namespace URI and local name for equality (i.e. the namespace prefix is ignored) -- -- @since 0.3.0 instance Eq QName where q1 == q2 = xn q1 == xn q2 where xn (QName ln ns _) = (ns,ln) -- | Compares namespace URI and local name for equality (i.e. the namespace prefix is effectively ignored) -- -- The namespace is considered less than any other namespace (including the null namespace) -- -- @since 0.3.0 instance Ord QName where compare = comparing sortKey where sortKey (QName ln ns pfx) = (not isXmlns,ns,key2) where isXmlns = URI ns_xmlns_uri == ns key2 | isXmlns = if isNothing pfx then LName mempty else ln | otherwise = ln -- | XML local names -- -- Invariant: MUST be a proper newtype LName = LName { unLName :: NCName } deriving (Ord, Eq, Typeable, Data, IsString, NFData, Generic) -- due to the IsString instance we can just drop the constructor name instance Show LName where showsPrec p (LName s) = showsPrec p s -- | URIs resembling @anyURI@ -- -- Invariant: MUST be a valid @URI-reference@ as defined in -- newtype URI = URI { unURI :: ShortText } deriving (Ord, Eq, Typeable, Data, IsString, NFData, Generic) -- | Test for /empty/ 'URI' -- -- >>> isNullURI (URI mempty) -- True -- -- >>> isNullURI (URI "") -- True -- -- >>> isNullURI (URI " ") -- False -- -- @since 0.3.0 isNullURI :: URI -> Bool isNullURI (URI u) = TS.null u -- due to the IsString instance we can just drop the constructor name instance Show URI where showsPrec p (URI s) = showsPrec p s -- | Position expressed in number of code-points -- -- A negative value denotes EOF type Pos = Int -- blank elements -------------------------------------------------------------- -- | Blank names blank_name :: QName blank_name = QName { qLName = LName mempty , qURI = URI mempty , qPrefix = Nothing } -- | Blank cdata blank_cdata :: CData blank_cdata = CData { cdVerbatim = CDataText , cdData = mempty } -- | Blank elements blank_element :: Element blank_element = Element { elName = blank_name , elAttribs = mempty , elContent = mempty } -- | Smart constructor for @xmlns:\ = \@ -- -- Invariant: @\@ MUST be non-empty for non-empty prefixes -- -- @since 0.3.0 xmlns_attr :: ShortText -- ^ namespace prefix (if empty, denotes the default namespace; see also 'xmlns_def_attr') -> URI -- ^ Namespace URI -> Attr xmlns_attr pfx uri | TS.null pfx = xmlns_def_attr uri | not (isNCName (TS.unpack pfx)) = error "Text.XML.xmlns_attr: non-empty prefix is not a proper NCName" | isNullURI uri = error "Text.XML.xmlns_attr: empty namespace URI for non-empty prefix" | otherwise = Attr (QName { qPrefix = Just (TS.pack "xmlns"), qLName = LName pfx, qURI = xmlnsNS }) (TS.toText (unURI uri)) where xmlnsNS = URI ns_xmlns_uri -- | Smart constructor for @xmlns = [\|""]@ (i.e. for declaring the default namespace) -- -- prop> xmlns_attr "" ns == xmlns_def_attr ns -- -- @since 0.3.0 xmlns_def_attr :: URI -- ^ Default namespace URI (use /empty/ 'URI' to reset default namespace) -> Attr xmlns_def_attr uri = Attr (QName { qPrefix = Nothing, qLName = LName (TS.pack "xmlns"), qURI = xmlnsNS }) (if isNullURI uri then mempty else TS.toText (unURI uri)) where xmlnsNS = URI ns_xmlns_uri -- | Convert @xmlns@ 'Attr' into a @(prefix,namespace-uri)@ pair; returns 'Nothing' if the argument isn't a @xmlns@ attribute. -- -- An empty prefix denotes the default-namespace -- -- prop> xmlns_from_attr (xmlns_attr pfx ns) == Just (pfx,ns) -- -- @since 0.3.0 xmlns_from_attr :: Attr -> Maybe (ShortText,URI) xmlns_from_attr (Attr (QName ln ns pfx) ns') | ns /= URI ns_xmlns_uri = Nothing | otherwise = Just $ case pfx of Nothing -> (mempty, URI (TS.fromText ns')) Just _ -> (unLName ln, URI (TS.fromText ns'))