diff --git a/X.cabal b/X.cabal --- a/X.cabal +++ b/X.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: X -version: 0.2.0.0 +version: 0.3.0.0 license: BSD-3-Clause AND GPL-3.0-or-later license-files: LICENSE LICENSE.GPLv3 @@ -38,6 +38,7 @@ Common Utils Text.XML.Lexer + Text.XML.Types.Internal build-depends: , base ^>= 4.7.0 diff --git a/src/Common.hs b/src/Common.hs --- a/src/Common.hs +++ b/src/Common.hs @@ -12,12 +12,15 @@ import Control.DeepSeq as X (NFData (rnf), deepseq) import Data.Data as X (Data) import Data.Foldable as X (Foldable) +import Data.List as X (sort) import Data.Maybe as X import Data.Monoid as X (Monoid (mappend, mconcat, mempty)) +import Data.Ord as X import Data.String as X (IsString (fromString)) import Data.Text as X (Text) import Data.Text.Short as X (ShortText) import Data.Traversable as X (Traversable, traverse) import Data.Typeable as X (Typeable) +import Data.Word as X import GHC.Generics as X (Generic) diff --git a/src/Text/XML.hs b/src/Text/XML.hs --- a/src/Text/XML.hs +++ b/src/Text/XML.hs @@ -74,12 +74,26 @@ -- module Text.XML ( + -- * Smart Element node constructor - module Text.XML, + Node(..), + + -- ** Unqualified names + unqual, + unode, + + -- * Attribute helpers + add_attr, + add_attrs, + + -- * 'Content' conversion/casts + IsContent(toContent, fromContent), + + -- * Reexports module Text.XML.Types, module Text.XML.Proc, module Text.XML.Input, - module Text.XML.Output + module Text.XML.Output, ) where @@ -90,7 +104,9 @@ import Text.XML.Proc import Text.XML.Types -import qualified Data.Text.Short as TS +import Text.XML.Types.Internal (IsContent (..)) + +import qualified Data.Text.Short as TS -- | Add an attribute to an element. add_attr :: Attr -> Element -> Element diff --git a/src/Text/XML/Cursor.hs b/src/Text/XML/Cursor.hs --- a/src/Text/XML/Cursor.hs +++ b/src/Text/XML/Cursor.hs @@ -1,5 +1,10 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {- @@ -65,17 +70,23 @@ -- an XML document. This implementation is based on the general -- tree zipper written by Krasimir Angelov and Iavor S. Diatchki. -- +-- __NOTE__: The Cursor API has been significantly altered in 0.3.0, +-- hence this module's API is to be considered \"since 0.3.0\" +-- +-- @since 0.3.0 module Text.XML.Cursor ( Tag(..), getTag, setTag, fromTag - , Cursor(..), Path + , Cursor, Cursor'(..), Path -- * Conversions - , fromContent - , fromElement - , fromForest - , toForest - , toTree + , fromRootElement + , fromRoot + , toRootElement + , toRoot + , upCast + , downCast + -- * Moving around , parent , root @@ -101,11 +112,6 @@ , hasChildren , getNodeIndex - -- * Updates - , setContent - , modifyContent - , modifyContentM - -- ** Inserting content , insertLeft , insertRight @@ -123,6 +129,7 @@ import Common import Text.XML.Types +import Text.XML.Types.Internal data Tag = Tag { tagName :: QName @@ -145,61 +152,77 @@ , elContent = cs } +-- | Parent path (with the root as last element) consisting of list of +-- left siblings, parent, and right siblings type Path = [([Content],Tag,[Content])] +-- | General cursor +type Cursor = Cursor' Content + -- | The position of a piece of content in an XML document. -data Cursor = Cur - { current :: Content -- ^ The currently selected content. +-- +-- @since 0.3.0 +data Cursor' content = Cur + { current :: content -- ^ The currently selected content. , lefts :: [Content] -- ^ Siblings on the left, closest first. , rights :: [Content] -- ^ Siblings on the right, closest first. - , parents :: Path -- ^ The contexts of the parent elements of this location. - } deriving (Show,Generic,Typeable,Data) + , parents :: Path -- ^ The contexts of the parent elements of this location. + } deriving (Show,Generic,Typeable,Data,Functor,Foldable,Traversable) -instance NFData Cursor +instance NFData content => NFData (Cursor' content) -- Moving around --------------------------------------------------------------- -- | The parent of the given location. -parent :: Cursor -> Maybe Cursor +parent :: IsContent content => Cursor' content -> Maybe (Cursor' Element) parent loc = case parents loc of (pls,v,prs) : ps -> Just - Cur { current = Elem - (fromTag v - (combChildren (lefts loc) (current loc) (rights loc))) - , lefts = pls, rights = prs, parents = ps + Cur { current = fromTag v $ + combChildren (lefts loc) (toContent (current loc)) (rights loc) + , lefts = pls + , rights = prs + , parents = ps } [] -> Nothing - -- | The top-most parent of the given location. -root :: Cursor -> Cursor -root loc = maybe loc root (parent loc) +root :: IsContent content => Cursor' content -> Cursor' Element +root loc = maybe loc' root (parent loc :: Maybe (Cursor' Element)) + where + loc' :: Cursor' Element + loc' = case traverse toElem loc of + Nothing -> error "root: invalid cursor" + Just x -> x + -- | The left sibling of the given location. -left :: Cursor -> Maybe Cursor +left :: IsContent content => Cursor' content -> Maybe Cursor left loc = case lefts loc of - t : ts -> Just loc { current = t, lefts = ts - , rights = current loc : rights loc } + t : ts -> Just loc { current = t + , lefts = ts + , rights = toContent (current loc) : rights loc + } [] -> Nothing -- | The right sibling of the given location. -right :: Cursor -> Maybe Cursor +right :: IsContent content => Cursor' content -> Maybe Cursor right loc = case rights loc of - t : ts -> Just loc { current = t, lefts = current loc : lefts loc - , rights = ts } + t : ts -> Just loc { current = t + , lefts = toContent (current loc) : lefts loc + , rights = ts } [] -> Nothing -- | The first child of the given location. -firstChild :: Cursor -> Maybe Cursor +firstChild :: IsContent content => Cursor' content -> Maybe Cursor firstChild loc = do (t : ts, ps) <- downParents loc return Cur { current = t, lefts = [], rights = ts , parents = ps } -- | The last child of the given location. -lastChild :: Cursor -> Maybe Cursor +lastChild :: IsContent content => Cursor' content -> Maybe Cursor lastChild loc = do (ts, ps) <- downParents loc case reverse ts of @@ -208,35 +231,43 @@ [] -> Nothing -- | Find the next left sibling that satisfies a predicate. -findLeft :: (Cursor -> Bool) -> Cursor -> Maybe Cursor -findLeft p loc = do loc1 <- left loc - if p loc1 then return loc1 else findLeft p loc1 +findLeft :: IsContent content => (Cursor -> Bool) -> Cursor' content -> Maybe Cursor +findLeft p loc = do + loc1 <- left loc + if p loc1 then return loc1 else findLeft p loc1 -- | Find the next right sibling that satisfies a predicate. -findRight :: (Cursor -> Bool) -> Cursor -> Maybe Cursor -findRight p loc = do loc1 <- right loc - if p loc1 then return loc1 else findRight p loc1 +findRight :: IsContent content => (Cursor -> Bool) -> Cursor' content -> Maybe Cursor +findRight p loc = do + loc1 <- right loc + if p loc1 then return loc1 else findRight p loc1 -- | The first child that satisfies a predicate. -findChild :: (Cursor -> Bool) -> Cursor -> Maybe Cursor -findChild p loc = - do loc1 <- firstChild loc - if p loc1 then return loc1 else findRight p loc1 +findChild :: IsContent content => (Cursor -> Bool) -> Cursor' content -> Maybe Cursor +findChild p loc = do + loc1 <- firstChild loc + if p loc1 then return loc1 else findRight p loc1 -- | The next position in a left-to-right depth-first traversal of a document: -- either the first child, right sibling, or the right sibling of a parent that -- has one. -nextDF :: Cursor -> Maybe Cursor -nextDF c = firstChild c <|> up c - where up x = right x <|> (up =<< parent x) +nextDF :: IsContent content => Cursor' content -> Maybe Cursor +nextDF c = firstChild c <|> up (toContent <$> c) + where + up :: Cursor -> Maybe Cursor + up x = right x <|> (up =<< y) + where + y = fmap Elem <$> parent x -- | Perform a depth first search for a descendant that satisfies the -- given predicate. -findRec :: (Cursor -> Bool) -> Cursor -> Maybe Cursor -findRec p c = if p c then Just c else findRec p =<< nextDF c +findRec :: IsContent content => (Cursor -> Bool) -> Cursor' content -> Maybe Cursor +findRec p c = if p c' then Just c' else findRec p =<< nextDF c' + where + c' = upCast c -- | The child with the given index (starting from 0). -getChild :: Int -> Cursor -> Maybe Cursor +getChild :: IsContent content => Word -> Cursor' content -> Maybe Cursor getChild n loc = do (ts,ps) <- downParents loc (ls,t,rs) <- splitChildren ts n @@ -244,102 +275,115 @@ -- | private: computes the parent for "down" operations. -downParents :: Cursor -> Maybe ([Content], Path) +downParents :: IsContent content => Cursor' content -> Maybe ([Content], Path) downParents loc = - case current loc of - Elem e -> Just ( elContent e + case toElem (current loc) of + Just e -> Just ( elContent e , (lefts loc, getTag e, rights loc) : parents loc ) - _ -> Nothing + Nothing -> Nothing -- Conversions ----------------------------------------------------------------- --- | A cursor for the given content. -fromContent :: Content -> Cursor -fromContent t = Cur { current = t, lefts = [], rights = [], parents = [] } +-- | Generalize content type of current 'Cursor' location +-- +-- @since 0.3.0 +upCast :: IsContent content => Cursor' content -> Cursor +upCast = fmap toContent --- | A cursor for the given element. -fromElement :: Element -> Cursor -fromElement e = fromContent (Elem e) +-- | Specialize content type of current 'Cursor' location +-- +-- @since 0.3.0 +downCast :: IsContent content => Cursor -> Maybe (Cursor' content) +downCast = traverse fromContent --- | The location of the first tree in a forest. -fromForest :: [Content] -> Maybe Cursor -fromForest (t:ts) = Just Cur { current = t, lefts = [], rights = ts - , parents = [] } -fromForest [] = Nothing +-- | A cursor for the given (root) element. +-- +-- @since 0.3.0 +fromRootElement :: Element -> Cursor' Element +fromRootElement e = Cur { current = e, lefts = [], rights = [], parents = [] } --- | Computes the tree containing this location. -toTree :: Cursor -> Content -toTree loc = current (root loc) +-- | Construct cursor from document 'Root' +-- +-- @since 0.3.0 +fromRoot :: Root -> Cursor' Element +fromRoot r = Cur { current = rootElement r + , lefts = map toContent (rootPreElem r ++ maybe [] snd (rootDoctype r)) + , rights = map toContent (rootPostElem r) + , parents = [] + } --- | Computes the forest containing this location. -toForest :: Cursor -> [Content] -toForest loc = let r = root loc in combChildren (lefts r) (current r) (rights r) +-- | Computes the root element containing this location. +-- +-- __NOTE__: The root element might have siblings; see 'toRoot' or 'root' if you need to deal with such siblings. +-- +-- @since 0.3.0 +toRootElement :: IsContent content => Cursor' content -> Element +toRootElement loc = current (root loc) +-- | Constructs the document 'Root' containing this location. +-- +-- Returns 'Nothing' if invalid top-level \"miscellaneous\" nodes are encountered. +-- +-- @since 0.3.0 +toRoot :: IsContent content => Cursor' content -> Maybe Root +toRoot loc = do + rootPreElem <- traverse fromContent l + rootPostElem <- traverse fromContent r + pure Root{..} + where + Cur rootElement l r [] = root loc + rootXmlDeclaration = Nothing + rootDoctype = Nothing -- Queries --------------------------------------------------------------------- -- | Are we at the top of the document? -isRoot :: Cursor -> Bool +isRoot :: Cursor' content -> Bool isRoot loc = null (parents loc) --- | Are we at the left end of the the document? -isFirst :: Cursor -> Bool +-- | Are we at the left end of the the document (i.e. the locally left-most sibling)? +isFirst :: Cursor' content -> Bool isFirst loc = null (lefts loc) --- | Are we at the right end of the document? -isLast :: Cursor -> Bool +-- | Are we at the right end of the document (i.e. the locally right-most sibling)? +isLast :: Cursor' content -> Bool isLast loc = null (rights loc) -- | Are we at the bottom of the document? -isLeaf :: Cursor -> Bool -isLeaf loc = isNothing (downParents loc) +isLeaf :: IsContent content => Cursor' content -> Bool +isLeaf loc = isNothing (firstChild loc) -- | Do we have a parent? -isChild :: Cursor -> Bool +isChild :: Cursor' content -> Bool isChild loc = not (isRoot loc) --- | Get the node index inside the sequence of children -getNodeIndex :: Cursor -> Int -getNodeIndex loc = length (lefts loc) +-- | Get the node index inside the sequence of children\/siblings +getNodeIndex :: Cursor' content -> Word +getNodeIndex loc = fromIntegral (length (lefts loc)) -- | Do we have children? -hasChildren :: Cursor -> Bool +hasChildren :: IsContent content => Cursor' content -> Bool hasChildren loc = not (isLeaf loc) - - -- Updates --------------------------------------------------------------------- --- | Change the current content. -setContent :: Content -> Cursor -> Cursor -setContent t loc = loc { current = t } - --- | Modify the current content. -modifyContent :: (Content -> Content) -> Cursor -> Cursor -modifyContent f loc = setContent (f (current loc)) loc - --- | Modify the current content, allowing for an effect. -modifyContentM :: Monad m => (Content -> m Content) -> Cursor -> m Cursor -modifyContentM f loc = do x <- f (current loc) - return (setContent x loc) - -- | Insert content to the left of the current position. -insertLeft :: Content -> Cursor -> Cursor -insertLeft t loc = loc { lefts = t : lefts loc } +insertLeft :: IsContent c => c -> Cursor' content -> Cursor' content +insertLeft t loc = loc { lefts = toContent t : lefts loc } -- | Insert content to the right of the current position. -insertRight :: Content -> Cursor -> Cursor -insertRight t loc = loc { rights = t : rights loc } +insertRight :: IsContent c => c -> Cursor' content -> Cursor' content +insertRight t loc = loc { rights = toContent t : rights loc } -- | Remove the content on the left of the current position, if any. -removeLeft :: Cursor -> Maybe (Content,Cursor) +removeLeft :: Cursor' content -> Maybe (Content,Cursor' content) removeLeft loc = case lefts loc of l : ls -> return (l,loc { lefts = ls }) [] -> Nothing -- | Remove the content on the right of the current position, if any. -removeRight :: Cursor -> Maybe (Content,Cursor) +removeRight :: Cursor' content -> Maybe (Content,Cursor' content) removeRight loc = case rights loc of l : ls -> return (l,loc { rights = ls }) [] -> Nothing @@ -347,31 +391,31 @@ -- | Insert content to the left of the current position. -- The new content becomes the current position. -insertGoLeft :: Content -> Cursor -> Cursor -insertGoLeft t loc = loc { current = t, rights = current loc : rights loc } +insertGoLeft :: IsContent content2 => content -> Cursor' content2 -> Cursor' content +insertGoLeft t loc = loc { current = t, rights = toContent (current loc) : rights loc } -- | Insert content to the right of the current position. -- The new content becomes the current position. -insertGoRight :: Content -> Cursor -> Cursor -insertGoRight t loc = loc { current = t, lefts = current loc : lefts loc } +insertGoRight :: IsContent content2 => content -> Cursor' content2 -> Cursor' content +insertGoRight t loc = loc { current = t, lefts = toContent (current loc) : lefts loc } -- | Remove the current element. -- The new position is the one on the left. -removeGoLeft :: Cursor -> Maybe Cursor +removeGoLeft :: Cursor' content -> Maybe Cursor removeGoLeft loc = case lefts loc of l : ls -> Just loc { current = l, lefts = ls } [] -> Nothing -- | Remove the current element. -- The new position is the one on the right. -removeGoRight :: Cursor -> Maybe Cursor +removeGoRight :: Cursor' content -> Maybe Cursor removeGoRight loc = case rights loc of l : ls -> Just loc { current = l, rights = ls } [] -> Nothing -- | Remove the current element. -- The new position is the parent of the old position. -removeGoUp :: Cursor -> Maybe Cursor +removeGoUp :: Cursor' content -> Maybe Cursor removeGoUp loc = case parents loc of (pls,v,prs) : ps -> Just @@ -380,15 +424,14 @@ } [] -> Nothing - -- | private: Gets the given element of a list. -- Also returns the preceding elements (reversed) and the following elements. -splitChildren :: [a] -> Int -> Maybe ([a],a,[a]) -splitChildren _ n | n < 0 = Nothing -splitChildren cs pos = loop [] cs pos - where loop acc (x:xs) 0 = Just (acc,x,xs) - loop acc (x:xs) n = loop (x:acc) xs $! n-1 - loop _ _ _ = Nothing +splitChildren :: [a] -> Word -> Maybe ([a],a,[a]) +splitChildren = go [] + where + go acc (x:xs) 0 = Just (acc,x,xs) + go acc (x:xs) n = go (x:acc) xs $! n-1 + go _ [] _ = Nothing -- | private: combChildren ls x ys = reverse ls ++ [x] ++ ys combChildren :: [a] -> a -> [a] -> [a] diff --git a/src/Text/XML/Input.hs b/src/Text/XML/Input.hs --- a/src/Text/XML/Input.hs +++ b/src/Text/XML/Input.hs @@ -66,9 +66,10 @@ ElemF el : rest -> case traverse fromContentF el of Right e' -> pure (e',rest) Left err -> Left err - _ -> Left (-1,"empty document (i.e. missing root element)") + Failure pos msg : _ -> Left (pos,msg) + _ -> Left (-1,"empty document (i.e. missing root element)") - _:_ -> Left (-1,"unexpected (non-misc) content nodes after root element") + _:_ -> Left (-1,"unexpected (non-misc) content nodes before root element") [] -> Left (-1,"empty document (i.e. missing root element)") (rootPostElem,ts5) <- mnodes2 ts4 @@ -149,10 +150,10 @@ -- Information about namespaces. -- The first component is a map that associates prefixes to URIs, -- the second is the URI for the default namespace, if one was provided. -type NSInfo = ([(ShortText,URI)],Maybe URI) +type NSInfo = ([(ShortText,URI)],URI) nsinfo0 :: NSInfo -nsinfo0 = ([("xml",xmlNamesNS),("xmlns",xmlnsNS)],Nothing) +nsinfo0 = ([("xml",xmlNamesNS),("xmlns",xmlnsNS)],nullNs) nodes :: NSInfo -> [QName] -> [Token] -> ([ContentF], [QName], [Token]) nodes ns ps (TokError pos msg : _) = @@ -209,33 +210,37 @@ nodes ns ps (TokEnd pos t : ts) = case ps of - p1:_ | t1 == p1 -> ([],[],ts) + p1:_ | qLName t == qLName p1 + , qPrefix t == qPrefix p1 + -> ([],[],ts) _ -> let (es,qs,ts1) = nodes ns ps ts in (Failure pos "start/end-tag mismatch" : es, qs, ts1) - where - t1 = annotName ns t -nodes _ ps [] = ([],ps,[]) - +nodes _ ps [] + = case ps of + [] -> ([],[],[]) -- done + _:_ -> ([Failure (-1) "premature eof before end-tag"], ps, []) annotName :: NSInfo -> QName -> QName -annotName (namespaces,def_ns) n = n { qURI = maybe def_ns (`lookup` namespaces) (qPrefix n) } - +annotName (namespaces,def_ns) n = n { qURI = lookupNs (qPrefix n) } + where + lookupNs Nothing = def_ns + lookupNs (Just pfx) = fromMaybe (error "annotName: the impossible") (lookup pfx namespaces) annotAttr :: NSInfo -> Attr -> Attr annotAttr ns a@(Attr { attrKey = k}) = case (qPrefix k, qLName k) of -- see https://www.w3.org/2000/xmlns/ - (Nothing, "xmlns") -> a { attrKey = k { qURI = Just xmlnsNS } } + (Nothing, "xmlns") -> a { attrKey = k { qURI = xmlnsNS } } -- Do not apply the default name-space to unqualified -- attributes. See Section 6.2 of . - (Nothing, _) -> a - _ -> a { attrKey = annotName ns k } + (Nothing, _) -> a + _ -> a { attrKey = annotName ns k } addNS :: Attr -> NSInfo -> NSInfo addNS (Attr { attrKey = key, attrVal = val }) (ns,def) = case (qPrefix key, qLName key) of - (Nothing,"xmlns") -> (ns, if T.null val then Nothing else Just (URI (TS.fromText val))) + (Nothing,"xmlns") -> (ns, if T.null val then nullNs else (URI (TS.fromText val))) (Just "xmlns", "xml") -> (ns,def) (Just "xmlns", k) -> ((unLName k, URI (TS.fromText val)) : ns, def) _ -> (ns,def) diff --git a/src/Text/XML/Lexer.hs b/src/Text/XML/Lexer.hs --- a/src/Text/XML/Lexer.hs +++ b/src/Text/XML/Lexer.hs @@ -77,6 +77,9 @@ import qualified Data.Text.Short as TS import Numeric (readHex) +nullNs :: URI +nullNs = URI mempty + class XmlSource s where uncons :: s -> Maybe (Char,s) @@ -290,7 +293,7 @@ special [] = eofErr qualName :: LString -> (QName,LString) -qualName xs = (QName { qURI = Nothing +qualName xs = (QName { qURI = nullNs , qPrefix = fmap fromString q , qLName = LName (fromString n) }, bs) diff --git a/src/Text/XML/Output.hs b/src/Text/XML/Output.hs --- a/src/Text/XML/Output.hs +++ b/src/Text/XML/Output.hs @@ -99,16 +99,20 @@ -- -- * Don't insert newlines between prolog/epilog nodes -- +-- * Do not sort attributes +-- defaultSerializeXMLOptions :: SerializeXMLOptions defaultSerializeXMLOptions = SerializeXMLOptions { serializeAllowEmptyTag = const True , serializeProEpilogAddNLs = False + , serializeSortAttributes = False } -- | Options for tweaking XML serialization output data SerializeXMLOptions = SerializeXMLOptions { serializeAllowEmptyTag :: QName -> Bool , serializeProEpilogAddNLs :: Bool + , serializeSortAttributes :: Bool } -- | Serialize a XML 'Root' @@ -148,7 +152,7 @@ Comm t -> ppCommS t xs ppElementS :: SerializeXMLOptions -> Element -> ShowS -ppElementS c e xs = tagStart (elName e) (elAttribs e) $ case elContent e of +ppElementS c e xs = tagStart (serializeSortAttributes c) (elName e) (elAttribs e) $ case elContent e of [] | allowEmpty -> "/>" ++ xs [Text t] -> ">" ++ showCDataS t (tagEnd name xs) cs -> '>' : foldr (ppContentS c) (tagEnd name xs) cs @@ -213,9 +217,12 @@ tagEnd :: QName -> ShowS tagEnd qn rs = '<':'/':showQName qn ++ '>':rs -tagStart :: QName -> [Attr] -> ShowS -tagStart qn as rs = '<':showQName qn ++ as_str ++ rs - where as_str = if null as then "" else ' ' : unwords (map showAttr as) +tagStart :: Bool -> QName -> [Attr] -> ShowS +tagStart sortAttr qn as rs = '<':showQName qn ++ as_str ++ rs + where + as_str = if null as then "" else ' ' : unwords (map showAttr as') + as' | sortAttr = sort as + | otherwise = as showAttr :: Attr -> String showAttr (Attr qn v) = showQName qn ++ '=' : '"' : escStrAttr (T.unpack v) "\"" diff --git a/src/Text/XML/Types.hs b/src/Text/XML/Types.hs --- a/src/Text/XML/Types.hs +++ b/src/Text/XML/Types.hs @@ -93,7 +93,7 @@ -- @since 0.2.0 type MiscNodes = [Either Comment PI] --- | Denotes the @@ declaration +-- | Denotes the @\@ declaration -- -- @since 0.2.0 data XmlDeclaration = XmlDeclaration (Maybe ShortText) (Maybe Bool) @@ -175,24 +175,37 @@ type NCName = ShortText -- | XML (expanded) qualified names +-- data QName = QName - { qLName :: !LName - , qURI :: Maybe URI + { 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 = compare q1 q2 == EQ + 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 q1 q2 = - case compare (qLName q1) (qLName q2) of - EQ -> case (qURI q1, qURI q2) of - (Nothing,Nothing) -> compare (qPrefix q1) (qPrefix q2) - (u1,u2) -> compare u1 u2 - x -> x + 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 -- @@ -206,10 +219,26 @@ -- | URIs resembling @anyURI@ -- --- Invariant: MUST not be @""@ +-- 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 @@ -219,14 +248,13 @@ -- A negative value denotes EOF type Pos = Int - -- blank elements -------------------------------------------------------------- -- | Blank names blank_name :: QName blank_name = QName { qLName = LName mempty - , qURI = Nothing + , qURI = URI mempty , qPrefix = Nothing } @@ -247,23 +275,43 @@ -- | Smart constructor for @xmlns:\ = \@ -- --- @since 0.2.0 -xmlns_attr :: NCName -- ^ non-empty namespace prefix +-- 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 uri) - | TS.null pfx = error "Text.XML.xmlns_attr: empty namespace prefix" - | otherwise = Attr (QName { qPrefix = Just (TS.pack "xmlns"), qLName = LName pfx, qURI = Just xmlnsNS }) (TS.toText uri) +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 = [\|""]@ +-- | Smart constructor for @xmlns = [\|""]@ (i.e. for declaring the default namespace) -- --- @since 0.2.0 -xmlns_def_attr :: Maybe URI -- ^ Default namespace URI (or 'Nothing' to reset default namespace) - -> Attr -xmlns_def_attr muri - = Attr (QName { qPrefix = Nothing, qLName = LName (TS.pack "xmlns"), qURI = Just xmlnsNS }) - (case muri of { Nothing -> mempty; Just (URI uri) -> TS.toText uri}) +-- 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')) diff --git a/src/Text/XML/Types/Internal.hs b/src/Text/XML/Types/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/Types/Internal.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE FlexibleInstances #-} + +{- + +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 + . + +-} + +-- | +-- Module : Text.XML.Types.Internal +-- Copyright : (c) Herbert Valerio Riedel 2019 +-- SPDX-License-Identifier: GPL-3.0-or-later +-- +-- @since 0.3 +module Text.XML.Types.Internal where + +import Common +import Text.XML.Types + +-- | Convenience class for converting to/from 'Content' values +-- +-- @since 0.3.0 +class IsContent x where + -- | /upcast/ or generalize to 'Content' + toContent :: x -> Content + + -- | /downcast/ or specialize (if possible) to a specific 'Content' subtype + fromContent :: Content -> Maybe x + + -- | (currently private) Specialize to an 'Element' if possible + -- + -- This method is included in this class as an optimization over the default impl below + toElem :: x -> Maybe Element + toElem = fromContent . toContent + +---------------------------------------------------------------------------- +-- trivial instance +instance IsContent Content where + toContent = id + fromContent = Just + + toElem (Elem el) = Just el + toElem _ = Nothing + +---------------------------------------------------------------------------- +-- primitive instances +instance IsContent Element where + toContent = Elem + fromContent (Elem x) = Just x + fromContent _ = Nothing + + toElem = Just + +instance IsContent Comment where + toContent = Comm + fromContent (Comm x) = Just x + fromContent _ = Nothing + + toElem _ = Nothing + +instance IsContent PI where + toContent = Proc + fromContent (Proc x) = Just x + fromContent _ = Nothing + + toElem _ = Nothing + +instance IsContent CData where + toContent = Text + fromContent (Text x) = Just x + fromContent _ = Nothing + + toElem _ = Nothing + +---------------------------------------------------------------------------- +-- | Convenient for e.g. 'MiscNodes' +instance (IsContent l, IsContent r) => IsContent (Either l r) where + toContent = either toContent toContent + fromContent c = (Left <$> fromContent c) <|> (Right <$> fromContent c) + toElem = either toElem toElem