X 0.1.0.0 → 0.2.0.0

raw patch · 10 files changed

+1055/−202 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• X.cabal +10/−2
• src/Common.hs +2/−1
• src/Text/XML.hs +55/−1
• src/Text/XML/Cursor.hs +54/−1
• src/Text/XML/Input.hs +128/−14
• src/Text/XML/Lexer.hs +276/−89
• src/Text/XML/Output.hs +147/−87
• src/Text/XML/Proc.hs +54/−2
• src/Text/XML/Types.hs +152/−5
• src/Utils.hs +177/−0

@@ -1,6 +1,6 @@ cabal-version:   2.2 name:            X-version:         0.1.0.0+version:         0.2.0.0  license:         BSD-3-Clause AND GPL-3.0-or-later license-files:   LICENSE LICENSE.GPLv3@@ -11,11 +11,18 @@  synopsis:        A light-weight XML library category:        Text, XML-bug-reports:     https://github.com/hvr/issues+bug-reports:     https://github.com/hvr/X/issues description:   Light-weight XML library derived from the [`xml` package](http://hackage.haskell.org/package/xml)   for simple parsing and creation of XML documents.   It only depends on @base@, @deepseq@, @bytestring@, @text@, and @text-short@.+  .+  This library provides support for the following specifications:+  .+  * <http://www.w3.org/TR/xml/ Extensible Markup Language (XML) 1.0 (5ed)>+  .+  * <http://www.w3.org/TR/xml-names/ Namespaces in XML 1.0 (3ed)>+  .  library   hs-source-dirs: src@@ -29,6 +36,7 @@    other-modules:       Common+      Utils       Text.XML.Lexer    build-depends:

@@ -13,10 +13,11 @@ import           Data.Data           as X (Data) import           Data.Foldable       as X (Foldable) import           Data.Maybe          as X-import           Data.Monoid         as X (Monoid (mappend, mempty))+import           Data.Monoid         as X (Monoid (mappend, mconcat, mempty)) 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           GHC.Generics        as X (Generic)+

@@ -1,5 +1,59 @@ {-# 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>.++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 -- Copyright : (c) Galois, Inc. 2007

@@ -1,7 +1,60 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric      #-} ---------------------------------------------------------------------+{-++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.Cursor -- Copyright : (c) Galois, Inc. 2008

@@ -1,7 +1,9 @@ {-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE DeriveGeneric              #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-} {-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RecordWildCards            #-}  -- | -- Module    : Text.XML.Input@@ -16,6 +18,7 @@     ( -- * High-level DOM Parser       parseXML     , parseXMLDoc+    , parseXMLRoot        -- * Token Scanner     , XmlSource(uncons)@@ -25,29 +28,95 @@     ) where  import           Common+import           Utils  import           Text.XML.Lexer-import           Text.XML.Proc import           Text.XML.Types  import qualified Data.Text       as T import qualified Data.Text.Short as TS --- | parseXMLDoc, parse a XML document to an 'Element'+-- | Parse a XML document to an 'Element'+--+-- If you need access to the prolog and epilog use 'parseXMLRoot'+--+-- An optional (single) leading BOM (@U+FEFF@) character will be discard (and not counted in the source positions). parseXMLDoc :: XmlSource s => s -> Either (Pos,String) Element-parseXMLDoc xs0 = parseXML xs0 >>= strip+parseXMLDoc xs0 = rootElement <$> parseXMLRoot xs0++-- | Parse a XML document+--+-- An optional (single) leading BOM (@U+FEFF@) character will be discard (and not counted in the source positions).+parseXMLRoot :: XmlSource s => s -> Either (Pos,String) Root+parseXMLRoot xs0 = do+    (rootXmlDeclaration,ts1) <- case ts0 of+      TokXmlDecl xd : rest -> pure (Just xd, rest)+      rest                 -> pure (Nothing, rest)++    (rootPreElem,ts2) <- mnodes ts1++    (rootDoctype,ts3) <- case ts2 of+      TokDTD dtd : ts3a -> do+        (ns,rest) <- mnodes ts3a+        pure (Just (dtd,ns), rest)+      rest -> pure (Nothing, rest)++    (rootElement,ts4) <- case ts3 of+      TokStart {} : _ -> case parse ts3 of+        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)")++      _:_ -> Left (-1,"unexpected (non-misc) content nodes after root element")+      [] -> Left (-1,"empty document (i.e. missing root element)")++    (rootPostElem,ts5) <- mnodes2 ts4++    case ts5 of+      [] -> pure Root{..}+      (_:_) -> Left (-1,"unexpected (non-misc) content nodes after root element")   where-    strip cs = case onlyElems cs of-                 e : es-                   | "?xml" `TS.isPrefixOf` unLName (qLName (elName e))-                     -> strip (map Elem es)-                   | otherwise -> Right e-                 [] -> Left (-1,"empty document")+    ts0 = scanXML (dropBOM xs0) +    -- mnodes :: [Token] -> Either _ ([MiscNodes],[Token])++    mnodes = go []+      where+        go _   (TokError n e : _)    = Left (n,e)+        go acc (TokComment x : rest) = go (Left x:acc) rest+        go acc (TokPI _ x : rest)    = go (Right x:acc) rest+        go acc (TokText cdata : rest)+          | isWsCdata cdata          = go acc rest+        go acc xs                    = pure (reverse acc, xs)+++    mnodes2 = go []+      where+        go _   (Failure n e : _)     = Left (n,e)+        go acc (CommF x : rest)      = go (Left x:acc) rest+        go acc (ProcF x : rest)      = go (Right x:acc) rest+        go acc (TextF cdata : rest)+          | isWsCdata cdata          = go acc rest+        go acc xs                    = pure (reverse acc, xs)+++isWsCdata :: CData -> Bool+isWsCdata (CData _ t) = T.all isS t+ -- | parseXML to a list of 'Content' chunks+--+-- __NOTE__: As opposed to 'parseXMLDoc', this function will /not/ discard any BOM characters. parseXML :: XmlSource s => s -> Either (Pos,String) [Content] parseXML = traverse fromContentF . parse . scanXML +-- | Drop a single leading @U+FEFF@ character+dropBOM :: XmlSource s => s -> s+dropBOM s0 = case uncons s0 of+               Just ('\xFEFF',s1) -> s1+               Just _             -> s0+               Nothing            -> s0+ ------------------------------------------------------------------------  -- | Variant of 'Content' that can encode parser 'Failure's@@ -55,6 +124,8 @@   = ElemF (Element' ContentF)   | TextF CData   | CRefF !ShortText+  | ProcF PI+  | CommF Comment   | Failure !Int String   deriving (Show, Typeable, Data, Generic) @@ -63,6 +134,8 @@ fromContentF :: ContentF -> Either (Pos,String) Content fromContentF (CRefF ref)       = Right (CRef ref) fromContentF (TextF cd)        = Right (Text cd)+fromContentF (ProcF x)         = Right (Proc x)+fromContentF (CommF x)         = Right (Comm x) fromContentF (ElemF el)        = Elem <$> traverse fromContentF el fromContentF (Failure pos err) = Left (pos,err) @@ -70,7 +143,7 @@  parse :: [Token] -> [ContentF] parse [] = []-parse ts = let (es,_,ts1) = nodes ([],Nothing) [] ts+parse ts = let (es,_,ts1) = nodes nsinfo0 [] ts            in es ++ parse ts1  -- Information about namespaces.@@ -78,17 +151,30 @@ -- the second is the URI for the default namespace, if one was provided. type NSInfo = ([(ShortText,URI)],Maybe URI) +nsinfo0 :: NSInfo+nsinfo0 = ([("xml",xmlNamesNS),("xmlns",xmlnsNS)],Nothing)  nodes :: NSInfo -> [QName] -> [Token] -> ([ContentF], [QName], [Token])- nodes ns ps (TokError pos msg : _) =   let (es,qs,ts1) = nodes ns ps []   in (Failure pos msg : es, qs, ts1) +-- TODO+nodes ns ps (TokXmlDecl _ : ts) = nodes ns ps ts+nodes ns ps (TokDTD _     : ts) = nodes ns ps ts+ nodes ns ps (TokCRef ref : ts) =   let (es,qs,ts1) = nodes ns ps ts   in (CRefF ref : es, qs, ts1) +nodes ns ps (TokComment x : ts) =+  let (es,qs,ts1) = nodes ns ps ts+  in (CommF x : es, qs, ts1)++nodes ns ps (TokPI _ x : ts) =+  let (es,qs,ts1) = nodes ns ps ts+  in (ProcF x : es, qs, ts1)+ nodes ns ps (TokText txt : ts) =   let (es,qs,ts1) = nodes ns ps ts       (more,es1)  = case es of@@ -98,11 +184,17 @@    in (TextF txt { cdData = cdData txt `T.append` more } : es1, qs, ts1) -nodes cur_info ps (TokStart _ t as empty' : ts) = (node : siblings, open, toks)+nodes cur_info ps (TokStart pos t as empty' : ts) = (node : siblings, open, toks)   where     new_name  = 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)     new_info  = foldr addNS cur_info as-    node      = ElemF Element { elName    = new_name+    node | rsvnsfail = Failure pos "invalid namespace declaration"+         | nsfail    = Failure pos "undefined namespace prefix"+         | otherwise =+                ElemF Element { elName    = new_name                               , elAttribs = map (annotAttr new_info) as                               , elContent = children                               }@@ -133,15 +225,37 @@ 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 } }     -- 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 } - 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)))+    (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

@@ -2,8 +2,63 @@ {-# LANGUAGE DeriveDataTypeable   #-} {-# LANGUAGE DeriveGeneric        #-} {-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE OverloadedStrings    #-} {-# LANGUAGE TypeSynonymInstances #-} +{-++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.Lexer -- Copyright : (c) Galois, Inc. 2007@@ -14,11 +69,13 @@  import           Common import           Text.XML.Types+import           Utils -import qualified Data.Text      as TS-import qualified Data.Text      as T-import qualified Data.Text.Lazy as TL-import           Numeric        (readHex)+import           Data.Char       (isAsciiLower, isAsciiUpper, isDigit, toLower)+import qualified Data.Text       as T+import qualified Data.Text.Lazy  as TL+import qualified Data.Text.Short as TS+import           Numeric         (readHex)  class XmlSource s where   uncons :: s -> Maybe (Char,s)@@ -27,8 +84,8 @@   uncons (c:s) = Just (c,s)   uncons ""    = Nothing -instance XmlSource TS.Text where-  uncons = TS.uncons+instance XmlSource T.Text where+  uncons = T.uncons  instance XmlSource TL.Text where   uncons = TL.uncons@@ -59,6 +116,10 @@                         | TokCRef       ShortText -- ^ character entity reference                         | TokText       CData     -- ^ character data                         | TokError !Pos String    -- ^ Lexer error+                        | TokXmlDecl    XmlDeclaration+                        | TokComment    Comment+                        | TokPI    !Pos PI+                        | TokDTD        Text                         deriving (Show,Data,Typeable,Generic)  instance NFData Token@@ -68,63 +129,166 @@  -- | Run XML lexer over 'XmlSource' scanXML :: XmlSource source => source -> [Token]-scanXML = tokens' . go 0+scanXML = tokens0 . eolNorm . go 0   where     go !n src = case uncons src of       Just (c,src') -> (n,c) : go (n+1) src'       Nothing       -> []  +{-++> [XML 1.0] 2.11 End-of-Line Handling+>+> [...] the XML processor must behave as if it normalized all line breaks+> in external parsed entities (including the document entity) on input,+> before parsing, by translating both the two-character sequence #xD #xA+> and any #xD that is not followed by #xA to a single #xA character.++-}+eolNorm :: LString -> LString+eolNorm []                         = []+eolNorm ((_,'\xD'):c@(_,'\xA'):cs) = c         : eolNorm cs+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++ tokens' :: LString -> [Token]-tokens' ((_,'<') : c@(_,'!') : cs) = special c cs+tokens' ((_,'<') : (_,'!') : cs) = special cs+tokens' ((n,'<') : (_,'?') : cs) = procins n cs tokens' ((_,'<') : cs) = tag cs tokens' [] = []-tokens' cs@((_,_):_) = let (as,bs) = breakn ('<' ==) cs-                       in map cvt (decode_text as) ++ tokens' bs+tokens' cs@((n,_):_) = let (as,bs) = breakn ('<' ==) cs+                       in foldr cvt (tokens' bs) (decode_text as)    -- XXX: Note, some of the lines might be a bit inacuarate-  where cvt (TxtBit x)  = TokText CData { cdVerbatim = CDataText-                                        , cdData = fromString x-                                        }-        cvt (CRefBit x) = case cref_to_char x of-                            Just c -> TokText CData { cdVerbatim = CDataText-                                                    , cdData = T.singleton c-                                                    }-                            Nothing -> TokCRef (fromString x)+  where+    cvt (TxtBit x)  cont+      | 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+      Just c+        | isChar c -> TokText CData { cdVerbatim = CDataText, cdData = T.singleton c } : cont+        | otherwise -> [TokError n "invalid character reference"]+      Nothing -> TokCRef (fromString x) : cont +--+-- PI        ::= '<?' PITarget (S (Char* - (Char* '?>' Char*)))? '?>'+-- PITarget  ::= Name - (('X' | 'x') ('M' | 'm') ('L' | 'l'))+procins :: Pos -> LString -> [Token]+procins n0 = go ""+  where+    go acc ((_,'?') : (_,'>') : ds) = mkPI (reverse acc) (tokens' ds)+    go acc ((_,c) : ds)             = go (c:acc) ds+    go _   []                       = eofErr -special :: LChar -> LString -> [Token]-special (_,_) ((_,'-') : (_,'-') : cs) = skip cs+    mkPI :: String -> [Token] -> [Token]+    mkPI s0 ts+      | tgt == "xml"  = mkXMLDecl s' ts+      | map toLower (TS.unpack tgt) == "xml" = [TokError (n0+2) "Invalid PI name"]+      | otherwise     = TokPI n0 (PI tgt payload) : ts+      where+        (tgt0,s') = break isS s0+        tgt = TS.fromString tgt0+        payload = T.pack (dropWhile isS s')++    {-+       XMLDecl      ::=  '<?xml' VersionInfo EncodingDecl? SDDecl? S? '?>'+       VersionInfo  ::=  S 'version' Eq ("'" VersionNum "'" | '"' VersionNum '"')+       EncodingDecl ::=  S 'encoding' Eq ('"' EncName '"' | "'" EncName "'" )+       SDDecl       ::=  S 'standalone' Eq (("'" ('yes' | 'no') "'") | ('"' ('yes' | 'no') '"'))++       Eq           ::=  S? '=' S?++       VersionNum   ::=  '1.0'+       EncName      ::=  [A-Za-z] ([A-Za-z0-9._] | '-')*++    -}++    -- needs serious rewrite...+    mkXMLDecl s0 ts+      | n0 > 0    = [TokError n0 "XML declaration allowed only at the start of the document"]+      | otherwise = go1 (simpleTokenize s0)+      where+        go1 ("":"version":"=":ver:rest)+          | Just "1.0" <- unbrack ver = go2 rest+        go1 _ = [TokError n0 "Unsupported or missing 'version' in XML declaration"]++        go2 ("":"encoding":"=":enc:rest)+          | Just enc' <- unbrack enc, isEnc enc' = go3 (Just $ TS.pack enc') rest+          | otherwise = [TokError n0 "Bad 'encoding' value in XML declaration"]+        go2 rest = go3 Nothing rest++        go3 enc ("":"standalone":"=":sd:rest)+          | Just sd' <- unbrack sd, Just sd'' <- isBoo sd' = go4 enc (Just sd'') rest+          | 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 _ _ _ = [TokError n0 "unexpected or malformed attribute in XML declaration"]++        isEnc [] = False+        isEnc (c:cs) = (isAsciiLower c || isAsciiUpper c) &&+                       all (\c' -> isAsciiLower c' || isAsciiUpper c' || isDigit c' || c' `elem` ['.','_','-']) cs++        isBoo "yes" = Just True+        isBoo "no"  = Just False+        isBoo _     = Nothing++        unbrack ('\'':xs) | Just (s,'\'') <- unsnoc xs = Just s+        unbrack ('"':xs)  | Just (s,'"')  <- unsnoc xs = Just s+        unbrack _         = Nothing+++special :: LString -> [Token]+-- <!--+--+-- Comment ::=  '<!--' ((Char - '-') | ('-' (Char - '-')))* '-->'+special ((_,'-') : (_,'-') : cs) = go "" cs   where-    skip ((pos,'-') : (_,'-') : (_,x) : ds)-      | x == '>' = tokens' ds-      | otherwise = [TokError pos "double hyphen within comment"]-    skip (_ : ds)                           = skip ds-    skip []                                 = eofErr+    go acc ((n,'-') : (_,'-') : (_,x) : ds)+      | x == '>' = TokComment (Comment $ T.pack (reverse acc)) : tokens' ds+      | otherwise = [TokError n "double hyphen within comment"]+    go acc ((_,c) : ds) = go (c:acc) ds+    go _ [] = eofErr -special _ ((_,'[') : (_,'C') : (_,'D') : (_,'A') : (_,'T') : (_,'A') : (_,'[') : cs) =+-- <![CDATA[+special ((n,'[') : (_,'C') : (_,'D') : (_,'A') : (_,'T') : (_,'A') : (_,'[') : cs) =   let (xs,ts) = cdata cs-  in TokText CData { cdVerbatim = CDataVerbatim-                   , cdData = fromString xs-                   } : tokens' ts-  where cdata ((_,']') : (_,']') : (_,'>') : ds) = ([],ds)-        cdata ((_,d) : ds)  = let (xs,ys) = cdata ds in (d:xs,ys)-        cdata [] = ([],[])+      dat = T.pack xs+  in if T.all isChar dat then TokText CData { cdVerbatim = CDataVerbatim, cdData = dat } : tokens' 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 [] = ([],[]) -special _ cs =-  let (xs,ts) = munch "" 0 cs-  in TokText CData { cdVerbatim = CDataRaw-                   , cdData = fromString ('<':'!':reverse xs)-                   } : tokens' ts-  where munch acc nesting ((_,'>') : ds)-         | nesting == (0::Int) = ('>':acc,ds)-         | otherwise           = munch ('>':acc) (nesting-1) ds-        munch acc nesting ((_,'<') : ds)-         = munch ('<':acc) (nesting+1) ds-        munch acc n ((_,x) : ds) = munch (x:acc) n ds-        munch acc _ [] = (acc,[]) -- unterminated DTD markup---special c cs = tag (c : cs) -- invalid specials are processed as tags+-- <!DOCTYPE+special ((_,'D') : (_,'O') : (_,'C') : (_,'T') : (_,'Y') : (_,'P') : (_,'E') : cs) =+  let (xs,ts) = munch "" 0 cs in TokDTD (T.pack (reverse xs)) : tokens' ts+  where+    munch acc nesting ((_,'>') : ds)+     | nesting == (0::Int)            = (acc,ds)+     | otherwise                      = munch ('>':acc) (nesting-1) ds+    munch acc nesting ((_,'<') : ds)  = munch ('<':acc) (nesting+1) ds+    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+ qualName :: LString -> (QName,LString) qualName xs = (QName { qURI    = Nothing                      , qPrefix = fmap fromString q@@ -136,7 +300,7 @@                 (q1,_:n1) -> (Just q1, n1)                 _         -> (Nothing, as) -    endName x = isSpace x || x == '=' || x == '>' || x == '/'+    endName x = isS x || x == '=' || x == '>' || x == '/'  {- @@ -149,41 +313,47 @@ -} tag :: LString -> [Token] tag ((p,'/') : cs)+  | isValidQName n   = TokEnd p n : case dropSpace ds of                    (_,'>') : es -> tokens' 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-  = TokStart (fst (head cs)) n as b : ts+tag 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   where     (n,ds)    = qualName cs     (as,b,ts) = attribs (dropSpace 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)+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) -                      _        -> let (a,cs1) = attrib cs-                                      (as,b,ts) = attribs cs1-                                  in (a:as,b,ts)+    _        -> let (a,cs1) = attrib cs+                    (as,b,ts) = attribs cs1+                in (a:as,b,ts) -attrib             :: LString -> (Attr,LString)-attrib cs           = let (ks,cs1)  = qualName cs-                          (vs,cs2)  = attr_val (dropSpace cs1)-                      in ((Attr ks (fromString $ decode_attr vs)),dropSpace cs2)+attrib :: LString -> (Attr,LString)+attrib cs = ((Attr ks (fromString $ decode_attr vs)),dropSpace cs2)+  where+    (vs,cs2) = attr_val (dropSpace cs1)+    (ks,cs1) = qualName cs  {- AttValue       ::=  '"' ([^<&"] | Reference)* '"'@@ -192,28 +362,16 @@ attr_val           :: LString -> (String,LString) attr_val ((_,'=') : cs0) = string (dropSpace cs0)   where-    -- | Match the value for an attribute.  For malformed XML we do-    -- our best to guess the programmer's intention.+    -- | Match the value for an attribute.     string :: LString -> (String,LString)-    string ((_,'"') : cs)   = break' ('"' ==) cs-    string ((_,'\'') : cs)  = break' ('\'' ==) cs-    -- Allow attributes that are not enclosed by anything.-    string cs           = breakn eos cs-      where eos x = isSpace x || x == '>' || x == '/'-attr_val cs             = ("",cs)---{---S ::= (#x20 | #x9 | #xD | #xA)++    string ((_,'"') : cs)  = break' ('"' ==) cs+    string ((_,'\'') : cs) = break' ('\'' ==) cs+    -- hack: inject invalid \0 character to trigger failure in caller+    string cs              = ("\0",cs)+attr_val cs = ("\0",cs) --} dropSpace :: LString -> LString-dropSpace = dropWhile (isSpace . snd)--isSpace :: Char -> Bool-isSpace = (`elem` "\x20\x09\x0D\x0A")-+dropSpace = dropWhile (isS . snd)  break' :: (a -> Bool) -> [(b,a)] -> ([a],[(b,a)]) break' p xs         = let (as,bs) = breakn p xs@@ -224,14 +382,19 @@ breakn :: (a -> Bool) -> [(b,a)] -> ([a],[(b,a)]) breakn p l = (map snd as,bs) where (as,bs) = break (p . snd) l - decode_attr :: String -> String decode_attr cs = concatMap cvt (decode_text cs)-  where cvt (TxtBit x) = x-        cvt (CRefBit x) = case cref_to_char x of-                            Just c  -> [c]-                            Nothing -> '&' : x ++ ";"+  where+    cvt (TxtBit x) = norm x+    cvt (CRefBit x)+      | Just c <- cref_to_char x = [c]+      | otherwise                = "\0" -- triggers error lateron +    norm []         = []+    norm ('\x9':xs) = '\x20' : norm xs+    norm ('\xA':xs) = '\x20' : norm xs+    norm (x:xs)     = x : norm xs+ data Txt = TxtBit String | CRefBit String deriving Show  decode_text :: [Char] -> [Txt]@@ -265,3 +428,27 @@   | fromEnum (minBound :: Char) <= x && x <= fromEnum (maxBound::Char)                 = Just (toEnum x)   | otherwise = Nothing+++simpleTokenize :: String -> [String]+simpleTokenize [] = []+simpleTokenize (c:cs)+  | isSorEQ c = let (sep,rest) = span isSorEQ (c:cs)+                in  (if ('=' `elem` sep) then "=" else "") : simpleTokenize rest++  | c == '\'' = case break (== '\'') cs of+                  (_,"")       -> [c:cs]+                  (str,_:rest) -> (c:str++"'") : simpleTokenize rest+  | c == '"' = case break (== '"') cs of+                  (_,"")       -> [c:cs]+                  (str,_:rest) -> (c:str++"\"") : simpleTokenize rest+  | otherwise = let (t,rest) = break isSorEQ (c:cs)+                in t : simpleTokenize rest+  where+    isSorEQ x = isS x || x == '='+++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)+

@@ -1,6 +1,60 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-} ---------------------------------------------------------------------+{-++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.Output -- Copyright : (c) Galois, Inc. 2007@@ -13,104 +67,103 @@ module Text.XML.Output   ( serializeXML   , serializeXMLDoc+  , serializeXMLRoot+  , SerializeXMLOptions(..), defaultSerializeXMLOptions   ) where  import           Common-import           Data.Char-import qualified Data.Text       as T-import qualified Data.Text.Lazy  as TL-import qualified Data.Text.Short as TS+import qualified Data.Text              as T+import qualified Data.Text.Lazy         as TL+import qualified Data.Text.Lazy.Builder as TLB+import qualified Data.Text.Short        as TS import           Text.XML.Types+import           Utils + -- | Serialize XML 1.0 document prefixed by the XML prologue -- \"@\<?xml version='1.0' ?\>@\" -- serializeXMLDoc :: Element -> TL.Text-serializeXMLDoc = TL.pack . showTopElement+serializeXMLDoc el+  = serializeXMLRoot defaultSerializeXMLOptions+    (Root (Just (XmlDeclaration Nothing Nothing)) [] Nothing el [])  -- | Serialize a sequence of XML 'Content' nodes serializeXML :: [Content] -> TL.Text-serializeXML = TL.pack . foldr (ppContentS defaultConfigPP "") ""+serializeXML = TL.pack . foldr (ppContentS defaultSerializeXMLOptions) "" --- | The XML 1.0 header-xml_header :: String-xml_header = "<?xml version='1.0' ?>" ----------------------------------------------------------------------------------data ConfigPP = ConfigPP-  { prettify :: !Bool+-- | Default rendering options+--+--  * Allow empty tags for all non-special elements+--+--  * Don't insert newlines between prolog/epilog nodes+--+defaultSerializeXMLOptions :: SerializeXMLOptions+defaultSerializeXMLOptions = SerializeXMLOptions+  { serializeAllowEmptyTag     = const True+  , serializeProEpilogAddNLs   = False   } --- | Default pretty printing configuration.---  * Always use abbreviate empty tags.-defaultConfigPP :: ConfigPP-defaultConfigPP = ConfigPP { prettify = False }--{---- | A configuration that tries to make things pretty--- (possibly at the cost of changing the semantics a bit--- through adding white space.)-prettyConfigPP     :: ConfigPP-prettyConfigPP      = defaultConfigPP { prettify = True }+-- | Options for tweaking XML serialization output+data SerializeXMLOptions = SerializeXMLOptions+  { serializeAllowEmptyTag   :: QName -> Bool+  , serializeProEpilogAddNLs :: Bool+  } --- | Pretty printing renders XML documents faithfully,--- with the exception that whitespace may be added\/removed--- in non-verbatim character data.-ppTopElement       :: Element -> String-ppTopElement        = ppcTopElement prettyConfigPP+-- | Serialize a XML 'Root'+serializeXMLRoot :: SerializeXMLOptions -> Root -> TL.Text+serializeXMLRoot sopts Root{..} = TLB.toLazyText $+    (if serializeProEpilogAddNLs sopts then bUnlines else mconcat) $+    maybeToList xmldecl +++    map bMisc rootPreElem +++    (case rootDoctype of+       Nothing -> []+       Just (dtd,moreMisc) -> ("<!DOCTYPE" <+> TLB.fromText dtd <+> ">") : map bMisc moreMisc+    ) +++    [TLB.fromString (ppElementS sopts rootElement "")] +++    map bMisc rootPostElem+  where+    xmldecl = case rootXmlDeclaration of+                Nothing -> Nothing+                Just (XmlDeclaration Nothing Nothing) -> Just "<?xml version=\"1.0\"?>"+                Just (XmlDeclaration menc mstand) -> Just $+                  ("<?xml version=\"1.0\"" <+>) $+                  (maybe id (\enc cont -> " encoding=\"" <+> bFromShortText enc <+> "\"" <+> cont) menc) $+                  (maybe id (\b cont -> " standalone=\"" <+> (if b then "yes" else "no") <+> "\"" <+> cont) mstand) $+                  "?>" --- | Pretty printing renders XML documents faithfully,--- with the exception that whitespace may be added\/removed--- in non-verbatim character data.-ppcTopElement      :: ConfigPP -> Element -> String-ppcTopElement c e   = unlines [xml_header,ppcElement c e]+    bMisc (Left (Comment t)) = "<!--" <+> TLB.fromText (T.replace "--" "-~" t) <+> "-->"+    bMisc (Right (PI tgt dat)) = "<?" <+> bFromShortText tgt <+> (if T.null dat then mempty else " ") <+> TLB.fromText dat <+> "?>" --- | Pretty printing elements-ppcElement         :: ConfigPP -> Element -> String-ppcElement c e      = ppElementS c "" e ""--}+--------------------------------------------------------------------------------  -- | Pretty printing content using ShowS-ppContentS         :: ConfigPP -> String -> Content -> ShowS-ppContentS c i x xs = case x of-  Elem e -> ppElementS c i e xs-  Text t -> ppCDataS c i t xs-  CRef r -> showCRefS r xs+ppContentS :: SerializeXMLOptions -> Content -> ShowS+ppContentS c x xs = case x of+    Elem e -> ppElementS c e xs+    Text t -> showCDataS t xs+    CRef r -> showCRefS r xs+    Proc p -> ppProcS p xs+    Comm t -> ppCommS t xs -ppElementS         :: ConfigPP -> String -> Element -> ShowS-ppElementS c i e xs = i ++ (tagStart (elName e) (elAttribs e) $-  case elContent e of-    [] | "?" `TS.isPrefixOf` unLName (qLName name) -> " ?>" ++ xs-       | otherwise                                 -> " />" ++ xs-    [Text t] -> ">" ++ ppCDataS c "" t (tagEnd name xs)-    cs -> '>' : nl ++ foldr ppSub (i ++ tagEnd name xs) cs-      where ppSub e1 = ppContentS c (sp ++ i) e1 . showString nl-            (nl,sp)  = if prettify c then ("\n","  ") else ("","")-  )+ppElementS :: SerializeXMLOptions -> Element -> ShowS+ppElementS c e xs = tagStart (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   where     name = elName e+    allowEmpty = serializeAllowEmptyTag c name -ppCDataS           :: ConfigPP -> String -> CData -> ShowS-ppCDataS c i t xs   = i ++ if cdVerbatim t /= CDataText || not (prettify c)-                             then showCDataS t xs-                             else foldr cons xs (showCData t)+ppCommS :: Comment -> ShowS+ppCommS (Comment t) xs = "<!--" ++ T.unpack (T.replace "--" "-~" t) ++ "-->" ++ xs -  where cons         :: Char -> String -> String-        cons '\n' ys = "\n" ++ i ++ ys-        cons y ys    = y : ys+ppProcS :: PI -> ShowS+ppProcS (PI tgt dat) xs = "<?" ++ TS.unpack tgt ++ (if T.null dat then mempty else " ") ++ T.unpack dat ++ "?>" ++ xs  -------------------------------------------------------------------------------- --- | Adds the <?xml?> header.-showTopElement     :: Element -> String-showTopElement c    = xml_header ++ showElement c--showElement        :: Element -> String-showElement c       = ppElementS defaultConfigPP "" c ""--showCData          :: CData -> String-showCData c         = ppCDataS defaultConfigPP "" c ""- -- Note: crefs should not contain '&', ';', etc. showCRefS          :: ShortText -> ShowS showCRefS r xs      = '&' : TS.unpack r ++ ';' : xs@@ -124,32 +177,39 @@                                            . showString "]]>"    CDataRaw      -> \ xs -> T.unpack (cdData cd) ++ xs ----------------------------------------------------------------------------------escCData           :: String -> ShowS+-- escape text in `<![CDATA[  ]]>` blocks+escCData :: String -> ShowS escCData (']' : ']' : '>' : cs) = showString "]]]]><![CDATA[>" . escCData cs escCData (c : cs)               = showChar c . escCData cs escCData []                     = id -escChar            :: Char -> ShowS+-- escape char in text-nodes+escChar :: Char -> ShowS escChar c = case c of-  '<'   -> showString "&lt;"-  '>'   -> showString "&gt;"-  '&'   -> showString "&amp;"-  '"'   -> showString "&quot;"-  -- we use &#39 instead of &apos; because IE apparently has difficulties-  -- rendering &apos; in xhtml.-  -- Reported by Rohan Drape <rohan.drape@gmail.com>.-  '\''  -> showString "&#39;"+  '<'    -> showString "&lt;"   -- MUST+  '>'    -> showString "&gt;"   -- MUST ("for compatibility")+  '&'    -> showString "&amp;"  -- MUST+  '\x0D' -> showString "&#xD;"  -- MUST (due to EOL normalization)+  _      -> showChar c -  -- NOTE: We escape '\r' explicitly because otherwise they get lost-  -- when parsed back in because of then end-of-line normalization rules.-  _ | isPrint c || c == '\n' -> showChar c-    | otherwise -> showString "&#" . shows oc . showChar ';'-      where oc = ord c+-- escape char in attribute value+escCharAttr :: Char -> ShowS+escCharAttr c = case c of+  '<'    -> showString "&lt;"   -- MUST+  '&'    -> showString "&amp;"  -- MUST+  '"'    -> showString "&quot;" -- MUST (for attr enclosed by ")+  '\x09' -> showString "&#x9;"  -- MUST (due to attr WS normalization)+  '\x0A' -> showString "&#xA;"  -- MUST (due to attr WS normalization)+  '\x0D' -> showString "&#xD;"  -- MUST (due to EOL normalization)+  _      -> showChar c + escStr             :: String -> ShowS escStr cs rs        = foldr escChar rs cs +escStrAttr         :: String -> ShowS+escStrAttr cs rs    = foldr escCharAttr rs cs+ tagEnd             :: QName -> ShowS tagEnd qn rs        = '<':'/':showQName qn ++ '>':rs @@ -158,7 +218,7 @@  where as_str       = if null as then "" else ' ' : unwords (map showAttr as)  showAttr           :: Attr -> String-showAttr (Attr qn v) = showQName qn ++ '=' : '"' : escStr (T.unpack v) "\""+showAttr (Attr qn v) = showQName qn ++ '=' : '"' : escStrAttr (T.unpack v) "\""  showQName          :: QName -> String showQName q         = pre ++ showLName (qLName q)

@@ -1,11 +1,63 @@---------------------------------------------------------------------+{-++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.Proc -- Copyright : (c) Galois, Inc. 2007 --             (c) Herbert Valerio Riedel 2019 -- SPDX-License-Identifier: BSD-3-Clause AND GPL-3.0-or-later -----------------------------------------------------------------------  module Text.XML.Proc where 

@@ -5,7 +5,60 @@ {-# LANGUAGE DeriveTraversable          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{- +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@@ -17,12 +70,64 @@ 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@@ -62,11 +167,18 @@  instance NFData CDataKind --- | XML qualified names+-- | 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   , qURI    :: Maybe URI-  , qPrefix :: Maybe ShortText+  , 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@@ -83,13 +195,25 @@       x   -> x  -- | XML local names-newtype LName = LName { unLName :: ShortText }-  deriving (Show, Ord, Eq, Typeable, Data, IsString, NFData, Generic)+--+-- 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 not be @""@ newtype URI = URI { unURI :: ShortText }-  deriving (Show, Ord, Eq, Typeable, Data, IsString, NFData, Generic)+  deriving (Ord, Eq, Typeable, Data, IsString, NFData, Generic) +-- 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@@ -120,3 +244,26 @@   , elAttribs = mempty   , elContent = mempty   }++-- | Smart constructor for @xmlns:\<prefix\> = \<namespace-uri\>@+--+-- @since 0.2.0+xmlns_attr :: NCName -- ^ non-empty namespace prefix+           -> 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)+  where+    xmlnsNS = URI ns_xmlns_uri++-- | Smart constructor for @xmlns = [\<namespace-uri\>|""]@+--+-- @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})+  where+    xmlnsNS = URI ns_xmlns_uri

@@ -0,0 +1,177 @@+{-# LANGUAGE OverloadedStrings #-}++{-++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    : Utils+-- Copyright : (c) Herbert Valerio Riedel 2019+-- SPDX-License-Identifier: GPL-3.0-or-later+--+-- Internal helpers+--++module Utils where++import           Common+import qualified Data.Text.Lazy.Builder as TLB+import qualified Data.Text.Short        as TS++-- |+--+-- > S ::=  (#x20 | #x9 | #xD | #xA)++--+isS :: Char -> Bool+isS '\x20' = True+isS '\x09' = True+isS '\x0D' = True+isS '\x0A' = True+isS _      = False++isNCName :: String -> Bool+isNCName [] = False+isNCName (c:cs) = isNameStartChar c && c /= ':' && all (\c' -> isNameChar c' && c' /= ':') cs++-- |+--+-- Char ::= #x9 | #xA | #xD | [#x20-#xD7FF] | [#xE000-#xFFFD] | [#x10000-#x10FFFF]+--+isChar :: Char -> Bool+isChar c+  | c <  '\x20'     = c == '\x0A' || c == '\x09' || c == '\x0D'+  | c <  '\xD800'   = True+  | c <  '\xE000'   = False+  | c == '\xFFFE'   = False+  | c == '\xFFFF'   = False+  | otherwise       = True++-- |+--+-- NameStartChar ::= ":" | [A-Z] | "_" | [a-z] | [#xC0-#xD6] | [#xD8-#xF6] | [#xF8-#x2FF] | [#x370-#x37D] | [#x37F-#x1FFF] | [#x200C-#x200D] | [#x2070-#x218F] | [#x2C00-#x2FEF] | [#x3001-#xD7FF] | [#xF900-#xFDCF] | [#xFDF0-#xFFFD] | [#x10000-#xEFFFF]+--+-- NameChar ::= NameStartChar | "-" | "." | [0-9] | #xB7 | [#x0300-#x036F] | [#x203F-#x2040]+--+-- Name ::= NameStartChar (NameChar)*+--+isNameStartChar :: Char -> Bool+isNameStartChar c+  | c == ':'        = True+  | c <  'A'        = False+  | c <= 'Z'        = True+  | c == '_'        = True+  | c <  'a'        = False+  | c <= 'z'        = True+  | c <  '\xC0'     = False+  | c <= '\xD6'     = True+  | c <  '\xD8'     = False+  | c <= '\xF6'     = True+  | c <  '\xF8'     = False+  | c <= '\x2FF'    = True+  | c <  '\x370'    = False+  | c <= '\x37D'    = True+  | c <  '\x37F'    = False+  | c <= '\x1FFF'   = True+  | c <  '\x200C'   = False+  | c <= '\x200D'   = True+  | c <  '\x2070'   = False+  | c <= '\x218F'   = True+  | c <  '\x2C00'   = False+  | c <= '\x2FEF'   = True+  | c <  '\x3001'   = False+  | c <= '\xD7FF'   = True+  | c <  '\xF900'   = False+  | c <= '\xFDCF'   = True+  | c <  '\xFDF0'   = False+  | c <= '\xFFFD'   = True+  | c <  '\x10000'  = False+  | c <= '\xEFFFF'  = True+  | otherwise       = False++-- | See 'isNameStartChar'+isNameChar :: Char -> Bool+isNameChar c+  | c == '.'        = True+  | c == '-'        = True+  | c <  '0'        = False+  | c <= ':'        = True+  | c <  'A'        = False+  | c <= 'Z'        = True+  | c == '_'        = True+  | c <  'a'        = False+  | c <= 'z'        = True+  | c == '\xB7'     = True+  | c <  '\xC0'     = False+  | c <= '\xD6'     = True+  | c <  '\xD8'     = False+  | c <= '\xF6'     = True+  | c <  '\xF8'     = False+  | c <= '\x2FF'    = True+  | c <  '\x300'    = False+  | c <= '\x37D'    = True+  | c <  '\x37F'    = False+  | c <= '\x1FFF'   = True+  | c <  '\x200C'   = False+  | c <= '\x200D'   = True+  | c <  '\x203F'   = False+  | c <= '\x2040'   = True+  | c <  '\x2070'   = False+  | c <= '\x218F'   = True+  | c <  '\x2C00'   = False+  | c <= '\x2FEF'   = True+  | c <  '\x3001'   = False+  | c <= '\xD7FF'   = True+  | c <  '\xF900'   = False+  | c <= '\xFDCF'   = True+  | c <  '\xFDF0'   = False+  | c <= '\xFFFD'   = True+  | c <  '\x10000'  = False+  | c <= '\xEFFFF'  = True+  | otherwise       = False++++unsnoc :: [x] -> Maybe ([x],x)+unsnoc [] = Nothing+unsnoc xs = Just (init xs, last xs)+++infixr 6 <+>++(<+>) :: TLB.Builder -> TLB.Builder -> TLB.Builder+(<+>) = mappend++bFromShortText :: ShortText -> TLB.Builder+bFromShortText = TLB.fromText . TS.toText++bUnlines :: [TLB.Builder] -> TLB.Builder+bUnlines []           = mempty+bUnlines [x]          = x+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/"++{-# NOINLINE ns_xml_uri #-}+ns_xml_uri :: ShortText+ns_xml_uri = "http://www.w3.org/XML/1998/namespace"++