X 0.3.0.0 → 0.3.1.0

raw patch · 15 files changed

+860/−410 lines, 15 filesdep ~basedep ~bytestringdep ~textsetup-changedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, bytestring, text

API changes (from Hackage documentation)

Files

• ChangeLog.md +19/−0
• Setup.hs +0/−2
• X.cabal +19/−1
• src/Common.hs +3/−1
• src/Text/XML.hs +1/−0
• src/Text/XML/Cursor.hs +1/−0
• src/Text/XML/Input.hs +25/−40
• src/Text/XML/Lexer.hs +111/−75
• src/Text/XML/NS.hs +229/−0
• src/Text/XML/Output.hs +2/−1
• src/Text/XML/Proc.hs +2/−0
• src/Text/XML/Types.hs +38/−282
• src/Text/XML/Types/Core.hs +290/−0
• src/Text/XML/Types/Internal.hs +62/−1
• src/Utils.hs +58/−7

@@ -0,0 +1,19 @@+See also http://pvp.haskell.org/faq++### 0.3.1.0++- New `xmlns_elem_wellformed` predicate for verifying namespace-wellformedness+- New `qnameToText` and `qnameFromText` conversion functions+- Explicitly declare SafeHaskell levels; ensure all public modules are "Safe"+- Fix pure exception bypassing proper failure reporting+- Fix attribute uniqueness violations not being detected+- Fix too lax validation of `PITarget`s+- Improve too lax validation of namespace names+- Fix too lax validation of entity references++## 0.3.0.0++- New `SerializeXMLOptions(serializeSortAttributes)` option+- Add new `Serializexmlroot+- Major refactoring of `Text.XML.Cursor` API+- un-`Maybe` the `QName(qURI)` field

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -1,6 +1,6 @@ cabal-version:   2.2 name:            X-version:         0.3.0.0+version:         0.3.1.0  license:         BSD-3-Clause AND GPL-3.0-or-later license-files:   LICENSE LICENSE.GPLv3@@ -24,6 +24,9 @@   * <http://www.w3.org/TR/xml-names/ Namespaces in XML 1.0 (3ed)>   . +extra-source-files:+  ChangeLog.md+ library   hs-source-dirs: src   exposed-modules:@@ -38,6 +41,8 @@       Common       Utils       Text.XML.Lexer+      Text.XML.NS+      Text.XML.Types.Core       Text.XML.Types.Internal    build-depends:@@ -47,6 +52,7 @@               || ^>= 4.10.0               || ^>= 4.11.0               || ^>= 4.12.0+              || ^>= 4.13.0     , bytestring ^>= 0.10.4     , deepseq    ^>= 1.3.0               || ^>= 1.4.0@@ -56,8 +62,20 @@   ghc-options:        -Wall   default-language:   Haskell2010   other-extensions:+      BangPatterns       DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveTraversable       FlexibleInstances+      GeneralizedNewtypeDeriving+      LambdaCase+      OverloadedStrings+      RecordWildCards+      Safe+      ScopedTypeVariables+      Trustworthy       TypeSynonymInstances  source-repository head

@@ -1,3 +1,5 @@+{-# LANGUAGE Safe #-}+ -- | -- Module    : Common -- Copyright : (c) Herbert Valerio Riedel 2019@@ -10,6 +12,7 @@  import           Control.Applicative as X import           Control.DeepSeq     as X (NFData (rnf), deepseq)+import           Control.Monad       as X (guard) import           Data.Data           as X (Data) import           Data.Foldable       as X (Foldable) import           Data.List           as X (sort)@@ -23,4 +26,3 @@ import           Data.Typeable       as X (Typeable) import           Data.Word           as X import           GHC.Generics        as X (Generic)-

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE Safe              #-}  {- 

@@ -4,6 +4,7 @@ {-# LANGUAGE DeriveGeneric       #-} {-# LANGUAGE DeriveTraversable   #-} {-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE Safe                #-} {-# LANGUAGE ScopedTypeVariables #-}  {-

@@ -1,9 +1,9 @@-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase                 #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE LambdaCase         #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE RecordWildCards    #-}+{-# LANGUAGE Safe               #-}  -- | -- Module    : Text.XML.Input@@ -31,6 +31,7 @@ import           Utils  import           Text.XML.Lexer+import           Text.XML.NS import           Text.XML.Types  import qualified Data.Text       as T@@ -75,10 +76,10 @@     (rootPostElem,ts5) <- mnodes2 ts4      case ts5 of-      [] -> pure Root{..}+      []    -> pure Root{..}       (_:_) -> Left (-1,"unexpected (non-misc) content nodes after root element")   where-    ts0 = scanXML (dropBOM xs0)+    ts0 = scanXML' (dropBOM xs0)      -- mnodes :: [Token] -> Either _ ([MiscNodes],[Token]) @@ -101,9 +102,9 @@           | isWsCdata cdata          = go acc rest         go acc xs                    = pure (reverse acc, xs) --isWsCdata :: CData -> Bool-isWsCdata (CData _ t) = T.all isS t+    isWsCdata :: CData -> Bool+    isWsCdata (CData CDataText t) = T.all isS t+    isWsCdata (CData _ _)         = False  -- | parseXML to a list of 'Content' chunks --@@ -187,18 +188,22 @@  nodes cur_info ps (TokStart pos t as empty' : ts) = (node : siblings, open, toks)   where-    new_name  = annotName new_info t+    new_name  = if nsfail then t else annotName new_info t     prefixes  = filter (/= "xmlns") $ mapMaybe qPrefix (t : [ k | Attr k _ <- as ])     nsfail    = any (==Nothing) [ lookup pfx (fst new_info) | pfx <- prefixes ]-    rsvnsfail = not (all checkNS as)+    rsvnsfail = not (all xmlns_attr_wellformed as)     new_info  = foldr addNS cur_info as     node | rsvnsfail = Failure pos "invalid namespace declaration"          | nsfail    = Failure pos "undefined namespace prefix"+         | Just "xmlns" <- qPrefix t = Failure pos "invalid 'xmlns'-prefixed element name"          | otherwise =-                ElemF Element { elName    = new_name-                              , elAttribs = map (annotAttr new_info) as-                              , elContent = children-                              }+             let as' = map (annotAttr new_info) as+             in if not (noDupes (map attrKey as'))+                then Failure pos "attribute uniqueness violated"+                else ElemF Element { elName    = new_name+                                   , elAttribs = as'+                                   , elContent = children+                                   }      (children,(siblings,open,toks))       | empty'    = ([], nodes cur_info ps ts)@@ -240,27 +245,7 @@ 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 nullNs else (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)---- | Check rules imposed on reserved namespaces by https://www.w3.org/TR/xml-names/-checkNS :: Attr -> Bool-checkNS = \case-    (Attr (QName { qPrefix = Just "xmlns", qLName = "xmlns"}) _  ) -> False-    (Attr (QName { qPrefix = Just "xmlns", qLName = "xml"})   uri) -> uri == xmlNamesNS'-    (Attr (QName { qPrefix = Just "xmlns", qLName = _})       uri) -> not (T.null uri) && isNotRsvd uri-    (Attr (QName { qPrefix = Nothing     , qLName = "xmlns"}) "")  -> True-    (Attr (QName { qPrefix = Nothing     , qLName = "xmlns"}) uri) -> isNotRsvd uri-    _                                                              -> True-  where-    xmlNamesNS' = TS.toText (unURI xmlNamesNS)-    xmlnsNS'    = TS.toText (unURI xmlnsNS)-    isNotRsvd uri = not (uri == xmlNamesNS' || uri == xmlnsNS')--xmlNamesNS :: URI-xmlNamesNS = URI ns_xml_uri--xmlnsNS :: URI-xmlnsNS = URI ns_xmlns_uri+    (Just "xmlns", k)     -> ((unLName k, URI (TS.fromText val)) : ns, def)+    _                     -> (ns,def)

@@ -3,6 +3,7 @@ {-# LANGUAGE DeriveGeneric        #-} {-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE Safe                 #-} {-# LANGUAGE TypeSynonymInstances #-}  {-@@ -75,7 +76,6 @@ import qualified Data.Text       as T import qualified Data.Text.Lazy  as TL import qualified Data.Text.Short as TS-import           Numeric         (readHex)  nullNs :: URI nullNs = URI mempty@@ -112,6 +112,8 @@ type LChar              = (Pos,Char) type LString            = [LChar] +type LexCont            = LString -> [Token]+ -- | XML Lexer token. data Token              = TokStart !Pos QName [Attr] Bool                           -- ^ opening start-tag (the 'Bool' field denotes whether this is an empty tag)@@ -132,12 +134,18 @@  -- | Run XML lexer over 'XmlSource' scanXML :: XmlSource source => source -> [Token]-scanXML = tokens0 . eolNorm . go 0+scanXML = tokens2 . eolNorm . go 0   where     go !n src = case uncons src of       Just (c,src') -> (n,c) : go (n+1) src'       Nothing       -> [] +scanXML' :: XmlSource source => source -> [Token]+scanXML' = tokens1 . eolNorm . go 0+  where+    go !n src = case uncons src of+      Just (c,src') -> (n,c) : go (n+1) src'+      Nothing       -> []  {- @@ -155,32 +163,45 @@ eolNorm ((n,'\xD'):cs)             = (n,'\xA') : eolNorm cs eolNorm (c:cs)                     = c         : eolNorm cs ---tokens0 :: LString -> [Token]--- tokens0 ((_,'<'):(_,'?'):(_,'x'):(_,'m'):(_,'l'):(_,c):cs)---   | isS c = go1 (dropSpace cs)---   where---     go1 ((_,'v'):(_,'e'):(_,'r'):(_,'s'):(_,'i'):(_,'o'):(_,'n'):cs)-tokens0 cs = tokens' cs+-- prolog+tokens1 :: LexCont+tokens1 []                       = []+tokens1 ((_,'<') : (_,'!') : cs) = special  tokens1 cs+tokens1 ((n,'<') : (_,'?') : cs) = procins  tokens1 n cs+tokens1 ((_,'<') : cs)           = tag      tokens2 cs+tokens1 cs@(_:_)                 = sData    tokens1 cs +sData :: LexCont -> LString -> [Token]+sData lcont [] = lcont []+sData lcont cs@((n,_):_)+  = case breakn (not . isS) cs of+      ("",_:_) -> [TokError n "unexpected (non-misc) content nodes before root element"]+      (as,bs)  -> TokText CData { cdVerbatim = CDataText, cdData = T.pack as } : lcont bs -tokens' :: LString -> [Token]-tokens' ((_,'<') : (_,'!') : cs) = special cs-tokens' ((n,'<') : (_,'?') : cs) = procins n cs-tokens' ((_,'<') : cs) = tag cs-tokens' [] = []-tokens' cs@((n,_):_) = let (as,bs) = breakn ('<' ==) cs-                       in foldr cvt (tokens' bs) (decode_text as)+-- after prolog+tokens2 :: LexCont+tokens2 []                       = []+tokens2 ((_,'<') : (_,'!') : cs) = special  tokens2 cs+tokens2 ((n,'<') : (_,'?') : cs) = procins  tokens2 n cs+tokens2 ((_,'<') : cs)           = tag      tokens2 cs+tokens2 cs@(_:_)                 = charData tokens2 cs -  -- XXX: Note, some of the lines might be a bit inacuarate+charData :: LexCont -> LString -> [Token]+charData lcont [] = lcont []+charData lcont cs@((n,_):_)+  = let (as,bs) = breakn ('<' ==) cs+    in foldr cvt (lcont bs) (decode_text as)   where+    cvt :: Txt -> ([Token] -> [Token])+    -- XXX: Note, some of the lines might be a bit inacuarate     cvt (TxtBit x)  cont+      | T.isInfixOf "]]>" dat = [TokError n "invalid literal ']]>' sequence in text content"]       | T.all isChar dat = TokText CData { cdVerbatim = CDataText, cdData = dat } : cont       | otherwise        = [TokError n "invalid code-point in text content"]       where         dat = T.pack x-    cvt (CRefBit x) cont = case cref_to_char x of+    cvt (CRefBit _ False) _ = [TokError n "invalid character reference"]+    cvt (CRefBit x True) cont = case cref_to_char x of       Just c         | isChar c -> TokText CData { cdVerbatim = CDataText, cdData = T.singleton c } : cont         | otherwise -> [TokError n "invalid character reference"]@@ -189,17 +210,18 @@ -- -- PI        ::= '<?' PITarget (S (Char* - (Char* '?>' Char*)))? '?>' -- PITarget  ::= Name - (('X' | 'x') ('M' | 'm') ('L' | 'l'))-procins :: Pos -> LString -> [Token]-procins n0 = go ""+procins :: LexCont -> Pos -> LString -> [Token]+procins lcont n0 = go ""   where-    go acc ((_,'?') : (_,'>') : ds) = mkPI (reverse acc) (tokens' ds)+    go acc ((_,'?') : (_,'>') : ds) = mkPI (reverse acc) (lcont ds)     go acc ((_,c) : ds)             = go (c:acc) ds     go _   []                       = eofErr      mkPI :: String -> [Token] -> [Token]     mkPI s0 ts       | tgt == "xml"  = mkXMLDecl s' ts-      | map toLower (TS.unpack tgt) == "xml" = [TokError (n0+2) "Invalid PI name"]+      | map toLower tgt0 == "xml" || not (isNCName tgt0) = [TokError (n0+2) "Invalid PI name"]+      | not (T.all isChar payload) = [TokError (n0+2) "invalid code-point in PI data"]       | otherwise     = TokPI n0 (PI tgt payload) : ts       where         (tgt0,s') = break isS s0@@ -238,9 +260,9 @@           | otherwise = [TokError n0 "Bad 'standalone' value in XML declaration"]         go3 enc rest = go4 enc Nothing rest -        go4 enc sd [] = TokXmlDecl (XmlDeclaration enc sd) : ts+        go4 enc sd []   = TokXmlDecl (XmlDeclaration enc sd) : ts         go4 enc sd [""] = TokXmlDecl (XmlDeclaration enc sd) : ts-        go4 _ _ _ = [TokError n0 "unexpected or malformed attribute in XML declaration"]+        go4 _ _ _       = [TokError n0 "unexpected or malformed attribute in XML declaration"]          isEnc [] = False         isEnc (c:cs) = (isAsciiLower c || isAsciiUpper c) &&@@ -255,32 +277,35 @@         unbrack _         = Nothing  -special :: LString -> [Token]+special :: LexCont -> LString -> [Token] -- <!-- -- -- Comment ::=  '<!--' ((Char - '-') | ('-' (Char - '-')))* '-->'-special ((_,'-') : (_,'-') : cs) = go "" cs+special lcont ((n0,'-') : (_,'-') : cs) = go "" cs   where     go acc ((n,'-') : (_,'-') : (_,x) : ds)-      | x == '>' = TokComment (Comment $ T.pack (reverse acc)) : tokens' ds+      | x == '>' = let dat = T.pack (reverse acc)+                   in if T.all isChar dat+                      then TokComment (Comment dat) : lcont ds+                      else [TokError (n0-2) "invalid code-point in comment"]       | otherwise = [TokError n "double hyphen within comment"]     go acc ((_,c) : ds) = go (c:acc) ds     go _ [] = eofErr  -- <![CDATA[-special ((n,'[') : (_,'C') : (_,'D') : (_,'A') : (_,'T') : (_,'A') : (_,'[') : cs) =+special lcont ((n,'[') : (_,'C') : (_,'D') : (_,'A') : (_,'T') : (_,'A') : (_,'[') : cs) =   let (xs,ts) = cdata cs       dat = T.pack xs-  in if T.all isChar dat then TokText CData { cdVerbatim = CDataVerbatim, cdData = dat } : tokens' ts+  in if T.all isChar dat then TokText CData { cdVerbatim = CDataVerbatim, cdData = dat } : lcont ts                          else [TokError (n-2) "invalid code-point in CDATA block"]   where     cdata ((_,']') : (_,']') : (_,'>') : ds) = ([],ds)-    cdata ((_,d) : ds)  = let (xs,ys) = cdata ds in (d:xs,ys)-    cdata [] = ([],[])+    cdata ((_,d) : ds)                       = let (xs,ys) = cdata ds in (d:xs,ys)+    cdata []                                 = ([],[])  -- <!DOCTYPE-special ((_,'D') : (_,'O') : (_,'C') : (_,'T') : (_,'Y') : (_,'P') : (_,'E') : cs) =-  let (xs,ts) = munch "" 0 cs in TokDTD (T.pack (reverse xs)) : tokens' ts+special lcont ((_,'D') : (_,'O') : (_,'C') : (_,'T') : (_,'Y') : (_,'P') : (_,'E') : cs) =+  let (xs,ts) = munch "" 0 cs in TokDTD (T.pack (reverse xs)) : lcont ts   where     munch acc nesting ((_,'>') : ds)      | nesting == (0::Int)            = (acc,ds)@@ -289,8 +314,8 @@     munch acc n ((_,x) : ds)          = munch (x:acc) n ds     munch acc _ []                    = (acc,[]) -- unterminated DTD markup -special ((n,_):_) = [TokError (n-1) "invalid element name"]-special [] = eofErr+special _ ((n,_):_) = [TokError (n-1) "invalid element name"]+special _ [] = eofErr  qualName :: LString -> (QName,LString) qualName xs = (QName { qURI    = nullNs@@ -314,46 +339,52 @@ Attribute     ::=  Name Eq AttValue  -}-tag :: LString -> [Token]-tag ((p,'/') : cs)+tag :: LexCont -> LString -> [Token]+tag lcont ((p,'/') : cs)   | isValidQName n   = TokEnd p n : case dropSpace ds of-                   (_,'>') : es -> tokens' es+                   (_,'>') : es -> lcont es                    -- tag was not properly closed...                    (p',_) : _   -> [TokError p' "expected '>'"]                    []           -> eofErr   | otherwise = [TokError p "invalid element name"]   where-    (n,ds) = qualName (dropSpace cs)-tag [] = eofErr-tag cs@((pos,_):_)-  | not (isValidQName n) = [TokError pos "invalid element name"]+    (n,ds) = qualName cs+tag _ [] = eofErr+tag lcont cs@((pos,_):_)+  | not (isValidQName n)                  = [TokError pos "invalid element name"]   | not (all (isValidQName . attrKey) as) = [TokError pos "invalid attribute name"]   | not (all (T.all isChar . attrVal) as) = [TokError pos "invalid attribute value"]-  | otherwise            = TokStart pos n as b : ts+  | otherwise                             = TokStart pos n as b : ts   where     (n,ds)    = qualName cs-    (as,b,ts) = attribs (dropSpace ds)+    (as,b,ts) = attribs lcont ds +attribs :: LexCont -> LString -> ([Attr], Bool, [Token])+attribs lcont = go+  where+    go cs = case (isS' cs, dropSpace cs) of+      (_,(_,'>') : ds) -> ([], False, lcont ds)+      (_,(_,'/') : ds) -> ([], True, case ds of+                              (_,'>') : es -> lcont es+                              (pos,_) : _  -> [TokError pos "expected '>'"]+                              []           -> eofErr)+      (_,(_,'?') : (_,'>') : ds) -> ([], True, lcont ds) -attribs :: LString -> ([Attr], Bool, [Token])-attribs cs = case cs of-    (_,'>') : ds -> ([], False, tokens' ds)-    (_,'/') : ds -> ([], True, case ds of-                            (_,'>') : es -> tokens' es-                            (pos,_) : _  -> [TokError pos "expected '>'"]-                            []           -> eofErr)-    (_,'?') : (_,'>') : ds -> ([], True, tokens' ds)+      -- doc ended within a tag..+      (_,[])       -> ([],False,eofErr) -    -- doc ended within a tag..-    []       -> ([],False,eofErr)+      (True,cs')   -> let (a,cs1) = attrib cs'+                          (as,b,ts) = go cs1+                      in (a:as,b,ts) -    _        -> let (a,cs1) = attrib cs-                    (as,b,ts) = attribs cs1-                in (a:as,b,ts)+      (False,(pos,_):_)  -> ([], False, [TokError pos "expected whitespace"]) +    isS' ((_,c):_) = isS c+    isS' []        = False+ attrib :: LString -> (Attr,LString)-attrib cs = ((Attr ks (fromString $ decode_attr vs)),dropSpace cs2)+attrib cs = ((Attr ks (fromString $ decode_attr vs)),cs2)   where     (vs,cs2) = attr_val (dropSpace cs1)     (ks,cs1) = qualName cs@@ -389,42 +420,46 @@ decode_attr cs = concatMap cvt (decode_text cs)   where     cvt (TxtBit x) = norm x-    cvt (CRefBit x)+    cvt (CRefBit _ False) = "\0"+    cvt (CRefBit x True)       | Just c <- cref_to_char x = [c]-      | otherwise                = "\0" -- triggers error lateron+      | otherwise                = "\0" -- triggers error lateron (we can't represent refs in att-values)      norm []         = []     norm ('\x9':xs) = '\x20' : norm xs     norm ('\xA':xs) = '\x20' : norm xs+    norm ('<':xs)   = '<' : '\0' : norm xs -- hack: trigger error; literal '<'s are not allowed here     norm (x:xs)     = x : norm xs -data Txt = TxtBit String | CRefBit String deriving Show+data Txt = TxtBit  String+         | CRefBit String Bool  decode_text :: [Char] -> [Txt]-decode_text xs@('&' : cs) = case break (';' ==) cs of-                              (as,_:bs) -> CRefBit as : decode_text bs-                              _         -> [TxtBit xs]+decode_text ('&' : cs) = case break (';' ==) cs of+                           (as,_:bs) -> CRefBit as True : decode_text bs+                           (as,"")   -> [CRefBit as False] decode_text []  = [] decode_text cs  = let (as,bs) = break ('&' ==) cs                   in TxtBit as : decode_text bs  cref_to_char :: [Char] -> Maybe Char cref_to_char cs = case cs of-  '#' : ds -> num_esc ds+  '#' : ds -> maybe (Just '\0') Just $ -- trigger error lateron+              num_esc ds   "lt"     -> Just '<'   "gt"     -> Just '>'   "amp"    -> Just '&'   "apos"   -> Just '\''   "quot"   -> Just '"'-  _        -> Nothing +  ""       -> Just '\0' -- trigger error+  (x:xs) | isNameStartChar x, all isNameChar xs -> Nothing+         | otherwise -> Just '\0' -- invalid name+ num_esc :: String -> Maybe Char num_esc cs = case cs of-               'x' : ds -> check (readHex ds)-               _        -> check (reads cs)--  where check [(n,"")] = cvt_char n-        check _        = Nothing+               'x' : ds -> decodeCharRefHex ds+               _        -> decodeCharRefDec cs  cvt_char :: Int -> Maybe Char cvt_char x@@ -436,8 +471,10 @@ simpleTokenize :: String -> [String] simpleTokenize [] = [] simpleTokenize (c:cs)-  | isSorEQ c = let (sep,rest) = span isSorEQ (c:cs)-                in  (if ('=' `elem` sep) then "=" else "") : simpleTokenize rest+  | isSorEQ c = case span isS (c:cs) of+                 (_,'=':rest) -> "=" : simpleTokenize (dropWhile isS rest)+                 (_:_,rest)   -> "" : simpleTokenize rest+                 ([],_)       -> error "impossible"    | c == '\'' = case break (== '\'') cs of                   (_,"")       -> [c:cs]@@ -454,4 +491,3 @@ isValidQName :: QName -> Bool isValidQName (QName { qPrefix = Just pfx, qLName = LName ln }) = isNCName (TS.unpack pfx) && isNCName (TS.unpack ln) isValidQName (QName { qPrefix = Nothing, qLName = LName ln })  = isNCName (TS.unpack ln)-

@@ -0,0 +1,229 @@+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Safe              #-}++{-++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.NS+-- Copyright : (c) Herbert Valerio Riedel 2019+-- SPDX-License-Identifier: GPL-3.0-or-later+--+-- XML Namespace related helpers+--+module Text.XML.NS+    ( xmlns_attr+    , xmlns_def_attr+    , xmlns_from_attr++    , ns_xmlns_uri, xmlNamesNS+    , ns_xml_uri, xmlnsNS++    , xmlns_attr_wellformed++    , xmlns_elem_wellformed+    , xmlns_elem_wellformed'+    ) where++import           Common+import           Data.Char+import           Data.Either         (partitionEithers)+import qualified Data.Text           as T+import qualified Data.Text.Short     as TS+import           Text.XML.Types.Core+import           Utils++xmlNamesNS :: URI+xmlNamesNS = URI ns_xml_uri++xmlnsNS :: URI+xmlnsNS = URI ns_xmlns_uri++{-# NOINLINE ns_xml_uri #-}+ns_xml_uri :: ShortText+ns_xml_uri = "http://www.w3.org/XML/1998/namespace"++-- | Smart constructor for @xmlns:\<prefix\> = \<namespace-uri\>@+--+-- 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+  | 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))++-- | Smart constructor for @xmlns = [\<namespace-uri\>|""]@ (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))++-- | 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'))++-- not public API yet+-- | Check rules imposed on reserved namespaces by+-- <https://www.w3.org/TR/xml-names/> as well as other basic+-- constraints.+xmlns_attr_wellformed :: Attr -> Bool+xmlns_attr_wellformed = \case+    (Attr (QName { qPrefix = Just "xmlns", qLName = "xmlns"}) _  ) -> False+    (Attr (QName { qPrefix = Just "xmlns", qLName = "xml"})   uri) -> uri == xmlNamesNS'+    (Attr (QName { qPrefix = Just "xmlns", qLName = _})       uri) -> not (T.null uri) && isNotRsvd uri && validURI uri+    (Attr (QName { qPrefix = Nothing     , qLName = "xmlns"}) "")  -> True+    (Attr (QName { qPrefix = Nothing     , qLName = "xmlns"}) uri) -> isNotRsvd uri && (T.null uri || validURI uri)+    _                                                              -> True -- not an attribute covered by xml-names+  where+    xmlNamesNS' = TS.toText (unURI xmlNamesNS)+    xmlnsNS'    = TS.toText (unURI xmlnsNS)+    isNotRsvd uri = not (uri == xmlNamesNS' || uri == xmlnsNS')++    -- simple heuristic; TODO: implement proper RFC3986 syntax test+    validURI = T.all validUriChar++    -- as per RFC3986+    validUriChar c = isAsciiLower c || isAsciiUpper c || isDigit c ||+                     c `elem` ("%-._~:/?#[]@!$&'()*+,;=" :: [Char])++-- | Verify whether sub-tree is wellformed with respect to namespaces+--+-- The first argument denotes an optional parent context of+-- @xmlns@-declarations that are in scope (where 'ShortText' and 'URI'+-- have the same semantics as for the arguments of 'xmlns_attr'). In+-- case of duplicate prefixes, earlier entries shadow later entries.+--+-- __NOTE__: This function doesn't take into account the namespace+-- prefixes of @xs:QName@-valued text-nodes or attributes; if you need+-- to handle such cases, see the 'xmlns_elem_wellformed'' function.+--+-- @since 0.3.1+xmlns_elem_wellformed :: [(ShortText,URI)] -> Element -> Bool+xmlns_elem_wellformed parentScope curElement = and+    [ qnameWF False (elName curElement)+    , all xmlns_attr_wellformed (elAttribs curElement)+    , noDupes xmlnsAttrs+    , all (qnameWF True . attrKey) nonXmlnsAttrs+    , noDupes nonXmlnsAttrs+    -- recurse into children+    , all (xmlns_elem_wellformed curScope0) children+    ]+  where+    (xmlnsAttrs, nonXmlnsAttrs) =+      partitionEithers .+      map (\attr -> maybe (Right attr) Left (xmlns_from_attr attr)) $+      elAttribs curElement++    curScope0 = xmlnsAttrs ++ parentScope+    curScope1 = ("xml",xmlNamesNS):("xmlns",xmlnsNS):curScope0++    curDefNS = fromMaybe "" (lookup "" curScope0)++    qnameWF False (QName _ uri Nothing)     = uri == curDefNS+    qnameWF True  (QName _ uri Nothing)     = isNullURI uri -- attributes are agnostic to xmlns=...+    qnameWF _     (QName _ uri (Just pfx))+       | Just uri' <- lookup pfx curScope1  = uri == uri'+       | otherwise                          = False++    children :: [Element]+    children = [ el | Elem el <- elContent curElement ]++-- | Variant of 'xmlns_elem_wellformed' which supports introspecting @xs:QName@ valued attributes and text-nodes.+--+-- The first argument is a function for extracting a (possibly empty) list of 'QName's from attribute values and text-nodes:+--+-- - Its first @'Either' 'Attr' ['Content']@ argument denotes either a (non-empty) attribute or an element's children which contain at least one non-empty text-node fragment.+--+-- - The second argument of type @['QName']@ denotes the path of element 'QName's in reverse order (i.e. the top-level element of the traversal is last item in this list) leading to the currently focused attribute or text-node.+--+-- This 'QName' extracing function may return a list to accomodate for test fields which may contain multiple @xs:QName@ such as e.g. for+--+-- > <xs:list itemType="xs:QName" />+--+-- The 'Text.XML.Types.qnameFromText' function can be useful for decoding @xs:QName@s text values.+--+-- prop> xmlns_elem_wellformed' (\_ _ -> []) topns el = xmlns_elem_wellformed topns el+--+-- @since 0.3.1+xmlns_elem_wellformed' :: (Either Attr [Content] -> [QName] -> [QName])+                       -> [(ShortText,URI)] -> Element -> Bool+xmlns_elem_wellformed' qnameMatcher = go []+  where+    go parentPath parentScope curElement = and+        [ qnameWF False (elName curElement)+        , all xmlns_attr_wellformed (elAttribs curElement)+        , noDupes xmlnsAttrs+        , all (qnameWF True . attrKey) nonXmlnsAttrs+        , noDupes nonXmlnsAttrs+        -- xs:QName in text-nodes and attrib values+        , all (qnameWF False) cdataQName+        , all (qnameWF False) attrQNames+        -- recurse into children+        , all (go curPath curScope0) children+        ]+      where+        curPath = elName curElement : parentPath++        cdataQName = if and [ T.all isS (cdData cd) | Text cd <- elContent curElement ]+                     then []+                     else qnameMatcher (Right (elContent curElement)) curPath++        attrQNames = concat [ qnameMatcher (Left attr) curPath+                            | attr@(Attr _ v) <- nonXmlnsAttrs, not (T.all isS v) ]++        (xmlnsAttrs, nonXmlnsAttrs) =+          partitionEithers .+          map (\attr -> maybe (Right attr) Left (xmlns_from_attr attr)) $+          elAttribs curElement++        curScope0 = xmlnsAttrs ++ parentScope+        curScope1 = ("xml",xmlNamesNS):("xmlns",xmlnsNS):curScope0++        curDefNS = fromMaybe "" (lookup "" curScope0)++        qnameWF False (QName _ uri Nothing)     = uri == curDefNS+        qnameWF True  (QName _ uri Nothing)     = isNullURI uri -- attributes are agnostic to xmlns=...+        qnameWF _     (QName _ uri (Just pfx))+           | Just uri' <- lookup pfx curScope1  = uri == uri'+           | otherwise                          = False++        children :: [Element]+        children = [ el | Elem el <- elContent curElement ]

@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE Safe              #-}  {- @@ -122,7 +123,7 @@     maybeToList xmldecl ++     map bMisc rootPreElem ++     (case rootDoctype of-       Nothing -> []+       Nothing             -> []        Just (dtd,moreMisc) -> ("<!DOCTYPE" <+> TLB.fromText dtd <+> ">") : map bMisc moreMisc     ) ++     [TLB.fromString (ppElementS sopts rootElement "")] ++

@@ -1,3 +1,5 @@+{-# LANGUAGE Safe #-}+ {-  Copyright (c) 2019  Herbert Valerio Riedel <hvr@gnu.org>

@@ -1,9 +1,4 @@-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveFoldable             #-}-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE DeriveTraversable          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE Safe #-}  {- @@ -23,295 +18,56 @@  along with this program (see `LICENSE.GPLv3`).  If not, see  <https://www.gnu.org/licenses/gpl-3.0.html>. -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+-- Copyright : (c) Herbert Valerio Riedel 2019+-- SPDX-License-Identifier: 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 @\<?xml version="1.0" encoding="..." standalone="..." ?\>@ 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 <![CDATA[..-  | CDataRaw       -- ^ As-is character data; pretty printer passes it along without any escaping or CDATA wrap-up.-  deriving (Eq, Show, Typeable, Data, Generic)--instance NFData CDataKind---- | A <https://www.w3.org/TR/xml-names/#NT-NCName NCName>------ 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 <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  = 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 = 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 <https://www.w3.org/TR/xml-names/#NT-NCName NCName>-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 <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+module Text.XML.Types+    ( -- * Root node representation+      Root, Root'(..)+    , MiscNodes+    , XmlDeclaration(..) --- due to the IsString instance we can just drop the constructor name-instance Show URI where-  showsPrec p (URI s) = showsPrec p s+      -- * Element nodes+    , Element+    , Element'(..)+    , blank_element --- | Position expressed in number of code-points------ A negative value denotes EOF-type Pos = Int+    , xmlns_elem_wellformed+    , xmlns_elem_wellformed' --- blank elements --------------------------------------------------------------+      -- ** Element attributes+    , Attr(..) --- | Blank names-blank_name :: QName-blank_name = QName-  { qLName  = LName mempty-  , qURI    = URI mempty-  , qPrefix = Nothing-  }+    , xmlns_attr+    , xmlns_def_attr+    , xmlns_from_attr --- | Blank cdata-blank_cdata :: CData-blank_cdata = CData-  { cdVerbatim = CDataText-  , cdData     = mempty-  }+      -- * Non-element content nodes+    , Content(..)+    , PI(..)+    , CData(..), CDataKind(..), blank_cdata+    , Comment(..) --- | Blank elements-blank_element :: Element-blank_element = Element-  { elName    = blank_name-  , elAttribs = mempty-  , elContent = mempty-  }+      -- * Namespace-qualified names+    , QName(..), blank_name+    , qnameToText+    , qnameFromText --- | Smart constructor for @xmlns:\<prefix\> = \<namespace-uri\>@------ 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-  | 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+      -- ** Components of 'QName's+    , NCName+    , LName(..)+    , URI(..), isNullURI --- | Smart constructor for @xmlns = [\<namespace-uri\>|""]@ (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+      -- * Miscellaneous+    , Pos+    ) where --- | 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'))+import           Text.XML.NS+import           Text.XML.Types.Core+import           Text.XML.Types.Internal

@@ -0,0 +1,290 @@+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE Trustworthy                #-}++{-++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>.++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.Core where++import           Common+import qualified Data.Text.Short as TS++{-# NOINLINE ns_xmlns_uri #-}+ns_xmlns_uri :: ShortText+ns_xmlns_uri = "http://www.w3.org/2000/xmlns/"++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 @\<?xml version="1.0" encoding="..." standalone="..." ?\>@ 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 be a 'NCName' but not be @[Xx][Mm][Ll]@ (see also <https://www.w3.org/TR/xml/#NT-PITarget PITarget> and <https://www.w3.org/TR/xml-names/>)+  , 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 -- ^ Note that the default namespace doesn't apply to unprefixed names+  , 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 <![CDATA[..+  | CDataRaw       -- ^ As-is character data; pretty printer passes it along without any escaping or CDATA wrap-up.+  deriving (Eq, Show, Typeable, Data, Generic)++instance NFData CDataKind++-- | A <https://www.w3.org/TR/xml-names/#NT-NCName NCName>+--+-- NB: Among other properties this means that an 'NCName' shall never be the empty string.+--+-- @since 0.2.0+type NCName = ShortText++-- | XML (expanded) namespace-qualified names+--+-- Used by 'attrKey' and 'elName'.+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 <http://www.w3.org/2000/xmlns/> or <http://www.w3.org/XML/1998/namespace> must have the 'qURI' field set accordingly. The special empty 'URI' (see also 'isNullURI') is only allowed /iff/ 'qPrefix' is 'Nothing' (i.e. when the name is /unprefixed/)+  , qPrefix :: Maybe NCName+    -- ^ 'Nothing' denotes an unprefixed name; 'Just' denotes a prefixed name.+    --+    -- Invariant: MUST be a proper <https://www.w3.org/TR/xml-names/#NT-NCName NCName> (unless 'Nothing')+  } 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 <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 = 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 <https://www.w3.org/TR/xml-names/#NT-NCName NCName>+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 <https://tools.ietf.org/html/rfc3986 RFC3986>+--+-- __NOTE__: The special empty 'URI' is valid for denoting 'QName's that aren't in any namespace.+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 --------------------------------------------------------------++-- TODO: consider removing these in X-0.4.0++-- | Blank names+--+-- __NOTE__: This value is not a proper 'QName'.+blank_name :: QName+blank_name = QName+  { qLName  = LName mempty+  , qURI    = URI mempty+  , qPrefix = Nothing+  }++-- | Empty text-node+blank_cdata :: CData+blank_cdata = CData+  { cdVerbatim = CDataText+  , cdData     = mempty+  }++-- | Blank elements+--+-- __NOTE: This value is not a propler 'Element'.+blank_element :: Element+blank_element = Element+  { elName    = blank_name+  , elAttribs = mempty+  , elContent = mempty+  }

@@ -29,7 +29,10 @@ module Text.XML.Types.Internal where  import           Common-import           Text.XML.Types+import qualified Data.Text           as T+import qualified Data.Text.Short     as TS+import           Text.XML.Types.Core+import           Utils  -- | Convenience class for converting to/from 'Content' values --@@ -92,3 +95,61 @@   toContent = either toContent toContent   fromContent c = (Left <$> fromContent c) <|> (Right <$> fromContent c)   toElem = either toElem toElem++-- | Convert a 'QName' to its text-representation, i.e.+--+-- > QName          ::= PrefixedName | UnprefixedName+-- > PrefixedName   ::= Prefix ':' LocalPart+-- > UnprefixedName ::= LocalPart+-- > Prefix         ::= NCName+-- > LocalPart      ::= NCName+--+-- See also 'NCName'+--+-- >>> qnameToText (QName "foo" "urn:example.org:bar" (Just "doo"))+-- "doo:foo"+--+-- >>> qnameToText (QName "foo" "urn:example.org:bar" Nothing)+-- "foo"+--+-- See also 'qnameFromText'+--+-- @since 0.3.1+qnameToText :: QName -> Text+qnameToText (QName (LName ln) _uri Nothing)    = TS.toText ln+qnameToText (QName (LName ln) _uri (Just pfx)) = TS.toText (mconcat [pfx, TS.singleton ':', ln])++-- | Decode a 'QName' from its text-representation (see 'qnameToText')+--+-- This is the inverse to the 'qnameToText' function. However,+-- 'qnameToText' is a lossy conversion, therefore this function needs+-- to reconstruct the namespace (i.e. 'qURI') with the help of a+-- lookup function provided in the first argument: The lookup+-- functions takes a 'ShortText' which can be either+--+-- - the empty string (i.e. @""@) which denotes an unprefixed name, or+-- - a non-empty @NCName@ string which denotes a prefixed name.+--+-- The result of this function shall be the respective namespace 'URI'+-- to associate with this QName. An empty 'URI' may be returned In+-- case of unprefixed names to denote the name being in no namespace.+--+-- Finally, this function returns 'Nothing' in case of syntax errors+-- or when the prefix lookup function returns an empty 'URI' (see+-- 'isNullURI') for a /prefixed/ name.+--+-- @since 0.3.1+qnameFromText :: (ShortText -> URI) -> Text -> Maybe QName+qnameFromText nslup txt+  = case T.split (==':') txt of+      [ln] | isName ln -> Just (QName (LName (TS.fromText ln)) (nslup mempty) Nothing)+      [ln,pfx] | isName ln, isName pfx -> do+                   let pfx' = TS.fromText pfx+                       uri  = nslup pfx'+                   guard (not (isNullURI uri))+                   pure (QName (LName (TS.fromText ln)) uri (Just pfx'))+      _ -> Nothing+  where+    isName t+      | Just (c,t') <- T.uncons t  = isNameStartChar c && T.all isNameChar t'+      | otherwise                  = False

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Safe              #-}  {- @@ -46,7 +47,7 @@ isS _      = False  isNCName :: String -> Bool-isNCName [] = False+isNCName []     = False isNCName (c:cs) = isNameStartChar c && c /= ':' && all (\c' -> isNameChar c' && c' /= ':') cs  -- |@@ -166,12 +167,62 @@ bUnlines (x:xs@(_:_)) = x <+> TLB.singleton '\n' <+> bUnlines xs  -{-# NOINLINE ns_xmlns_uri #-}-ns_xmlns_uri :: ShortText-ns_xmlns_uri = "http://www.w3.org/2000/xmlns/"+{-# INLINEABLE noDupes #-}+-- | Return 'True' if list contains duplicate values+noDupes :: Ord a => [a] -> Bool+noDupes []      = True+noDupes [_]     = True+noDupes [x,y]   = x /= y+noDupes [x,y,z] = x /= y && x /= z && y /= z+noDupes xs0+  = case sort xs0 of+      []     -> True -- unreachable+      (x:xs) -> go x xs+  where+    go _  []      = True+    go x1 (x2:xs)+      | x1 == x2  = False+      | otherwise = go x2 xs -{-# NOINLINE ns_xml_uri #-}-ns_xml_uri :: ShortText-ns_xml_uri = "http://www.w3.org/XML/1998/namespace"+-- decode numeric char-reference taking into account 'isChar'+decodeCharRefHex :: [Char] -> Maybe Char+decodeCharRefHex = go 0 . dropWhile (=='0') -- NB: U+00 is invalid+  where+    go acc _ | acc > 0x10ffff = Nothing+    go acc [] = let c = toEnum acc+                in if isChar c then Just c else Nothing+    go acc (c:cs)+      | n < 0     = Nothing+      | otherwise = go ((acc*16) + n) cs+      where+        n = c2n c +    c2n :: Char -> Int+    c2n c+      | fromEnum '0' <= n, n <= fromEnum '9' = n - fromEnum '0'+      | fromEnum 'a' <= n, n <= fromEnum 'f' = n - (fromEnum 'a' - 10)+      | fromEnum 'A' <= n, n <= fromEnum 'F' = n - (fromEnum 'A' - 10)+      | otherwise = -1+      where+        n = fromEnum c+++decodeCharRefDec :: [Char] -> Maybe Char+decodeCharRefDec = go 0 . dropWhile (=='0') -- NB: U+00 is invalid+  where+    go acc _ | acc > 0x10ffff = Nothing+    go acc [] = let c = toEnum acc+                in if isChar c then Just c else Nothing+    go acc (c:cs)+      | n < 0     = Nothing+      | otherwise = go ((acc*10) + n) cs+      where+        n = c2n c++    c2n :: Char -> Int+    c2n c+      | fromEnum '0' <= n, n <= fromEnum '9' = n - fromEnum '0'+      | otherwise = -1+      where+        n = fromEnum c