X 0.2.0.0 → 0.3.0.0

raw patch · 9 files changed

+387/−167 lines, 9 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• X.cabal +2/−1
• src/Common.hs +3/−0
• src/Text/XML.hs +19/−3
• src/Text/XML/Cursor.hs +161/−118
• src/Text/XML/Input.hs +20/−15
• src/Text/XML/Lexer.hs +4/−1
• src/Text/XML/Output.hs +11/−4
• src/Text/XML/Types.hs +73/−25
• src/Text/XML/Types/Internal.hs +94/−0

@@ -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

@@ -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) 

@@ -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

@@ -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]

@@ -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 <http://www.w3.org/TR/REC-xml-names>.-    (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)

@@ -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)

@@ -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) "\""

@@ -93,7 +93,7 @@ -- @since 0.2.0 type MiscNodes = [Either Comment PI] --- | Denotes the @<?xml version="1.0" encoding="..." standalone="..." ?>@ declaration+-- | Denotes the @\<?xml version="1.0" encoding="..." standalone="..." ?\>@ 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 <http://www.w3.org/2000/xmlns/> or <http://www.w3.org/XML/1998/namespace> must have the 'qURI' field accordingly   , qPrefix :: Maybe NCName -- ^ Invariant: MUST be a proper <https://www.w3.org/TR/xml-names/#NT-NCName NCName>   } 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 <http://www.w3.org/2000/xmlns/> 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 <https://tools.ietf.org/html/rfc3986 RFC3986>+-- 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:\<prefix\> = \<namespace-uri\>@ ----- @since 0.2.0-xmlns_attr :: NCName -- ^ non-empty namespace prefix+-- Invariant: @\<namespace-uri\>@ 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 = [\<namespace-uri\>|""]@+-- | Smart constructor for @xmlns = [\<namespace-uri\>|""]@ (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'))

@@ -0,0 +1,94 @@+{-# LANGUAGE FlexibleInstances #-}++{-++Copyright (c) 2019  Herbert Valerio Riedel <hvr@gnu.org>++ 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+ <https://www.gnu.org/licenses/gpl-3.0.html>.++-}++-- |+-- 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