packages feed

yuuko 2010.11.5 → 2010.11.28

raw patch · 124 files changed

+46162/−10 lines, 124 filesdep +bytestringdep +containersdep +curldep −hxtdep −tagsoup

Dependencies added: bytestring, containers, curl, deepseq, directory, filepath, mtl, network, parsec

Dependencies removed: hxt, tagsoup

Files

LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2009, Jinjing Wang+Copyright (c) 2009-2010, Jinjing Wang  All rights reserved.
+ LICENSE-hxt view
@@ -0,0 +1,9 @@+The MIT License++Copyright (c) 2005 Uwe Schmidt, Martin Schmidt, Torben Kuseler++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ LICENSE-tagsoup view
@@ -0,0 +1,30 @@+Copyright Neil Mitchell 2006-2009.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * 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.++    * Neither the name of Neil Mitchell nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 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 COPYRIGHT+OWNER 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.
readme.md view
@@ -35,7 +35,7 @@ Who is Yuuko? ============= -![yuuko](http://github.com/nfjinjing/yuuko/raw/master/yuuko.gif)+![yuuko](https://github.com/nfjinjing/yuuko/raw/master/yuuko.gif)  * [Yūko Ichihara](http://en.wikipedia.org/wiki/Y%C5%ABko_Ichihara#Y.C5.ABko_Ichihara) * [xxxHolic](http://en.wikipedia.org/wiki/XxxHolic )
+ src/Text/HTML/Download.hs view
@@ -0,0 +1,76 @@+{-|+    /DEPRECATED/: Use the HTTP package instead:++    > import Network.HTTP+    > openURL x = getResponseBody =<< simpleHTTP (getRequest x)++    This module simply downloads a page off the internet. It is very restricted,+    and it not intended for proper use.+    +    The original version was by Alistair Bayley, with additional help from+    Daniel McAllansmith. It is taken from the Haskell-Cafe mailing list+    \"Simple HTTP lib for Windows?\", 18 Jan 2007.+    <http://thread.gmane.org/gmane.comp.lang.haskell.cafe/18443/>+-}++module Text.HTML.Download(openURL, openItem) where++import System.IO+import System.IO.Unsafe+import Network+import Data.List++{-# DEPRECATED openItem, openURL "Use package HTTP, module Network.HTTP, getResponseBody =<< simpleHTTP (getRequest url)" #-}+++-- | This function opens a URL on the internet.+--   Any @http:\/\/@ prefix is ignored.+--+-- > openURL "www.haskell.org/haskellwiki/Haskell"+--+-- Known Limitations:+--+-- * Only HTTP on port 80+--+-- * Outputs the HTTP Headers as well+--+-- * Does not work with all servers+--+-- It is hoped that a more reliable version of this function will be+-- placed in a new HTTP library at some point!+openURL :: String -> IO String+openURL url | "http://" `isPrefixOf` url = openURL (drop 7 url)+openURL url = client server 80 (if null path then "/" else path)+    where (server,path) = break (== '/') url+++client :: [Char] -> PortNumber -> [Char] -> IO String+client server port page = withSocketsDo $ do+    hndl <- connectTo server (PortNumber port)+    let out x = hPutStrLn hndl (x ++ "\r")+    hSetBuffering hndl NoBuffering++    out $ "GET " ++ page ++ " HTTP/1.1"+    out $ "Host: " ++ server ++ ""+    out $ "Connection: close"+    out ""+    out ""+    readResponse hndl+++readResponse :: Handle -> IO String+readResponse hndl = do+    closed <- hIsClosed hndl+    eof <- hIsEOF hndl+    if closed || eof+        then return []+        else do+            c <- hGetChar hndl+            cs <- unsafeInterleaveIO $ readResponse hndl+            return (c:cs)+++-- | Open a URL (if it starts with @http:\/\/@) or a file otherwise+openItem :: String -> IO String+openItem x | "http://" `isPrefixOf` x = openURL x+           | otherwise = readFile x
+ src/Text/HTML/TagSoup.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE TypeSynonymInstances, PatternGuards #-}++{-|+    This module is for working with HTML/XML. It deals with both well-formed XML and+    malformed HTML from the web. It features:++    * A lazy parser, based on the HTML 5 specification - see 'parseTags'.++    * A renderer that can write out HTML/XML - see 'renderTags'.++    * Utilities for extracting information from a document - see '~==', 'sections' and 'partitions'.++    The standard practice is to parse a 'String' to @[@'Tag' 'String'@]@ using 'parseTags',+    then operate upon it to extract the necessary information.+-}++module Text.HTML.TagSoup(+    -- * Data structures and parsing+    Tag(..), Row, Column, Attribute,+    module Text.HTML.TagSoup.Parser,+    module Text.HTML.TagSoup.Render,+    canonicalizeTags,++    -- * Tag identification+    isTagOpen, isTagClose, isTagText, isTagWarning, isTagPosition,+    isTagOpenName, isTagCloseName,++    -- * Extraction+    fromTagText, fromAttrib,+    maybeTagText, maybeTagWarning,+    innerText,++    -- * Utility+    sections, partitions,+    +    -- * Combinators+    TagRep, (~==),(~/=)+    ) where++import Text.HTML.TagSoup.Type+import Text.HTML.TagSoup.Parser+import Text.HTML.TagSoup.Render+import Data.Char+import Data.List+import Text.StringLike+++-- | Turns all tag names and attributes to lower case and+--   converts DOCTYPE to upper case.+canonicalizeTags :: StringLike str => [Tag str] -> [Tag str]+canonicalizeTags = map f+    where+        f (TagOpen tag attrs) | Just ('!',name) <- uncons tag = TagOpen ('!' `cons` ucase name) attrs+        f (TagOpen name attrs) = TagOpen (lcase name) [(lcase k, v) | (k,v) <- attrs]+        f (TagClose name) = TagClose (lcase name)+        f a = a++        ucase = fromString . map toUpper . toString+        lcase = fromString . map toLower . toString+++-- | Define a class to allow String's or Tag str's to be used as matches+class TagRep a where+    toTagRep :: StringLike str => a -> Tag str++instance StringLike str => TagRep (Tag str) where toTagRep = fmap castString++instance TagRep String where+    toTagRep x = case parseTags x of+                     [a] -> toTagRep a+                     _ -> error $ "When using a TagRep it must be exactly one tag, you gave: " ++ x++++-- | Performs an inexact match, the first item should be the thing to match.+-- If the second item is a blank string, that is considered to match anything.+-- For example:+--+-- > (TagText "test" ~== TagText ""    ) == True+-- > (TagText "test" ~== TagText "test") == True+-- > (TagText "test" ~== TagText "soup") == False+--+-- For 'TagOpen' missing attributes on the right are allowed.+(~==) :: (StringLike str, TagRep t) => Tag str -> t -> Bool+(~==) a b = f a (toTagRep b)+    where+        f (TagText y) (TagText x) = strNull x || x == y+        f (TagClose y) (TagClose x) = strNull x || x == y+        f (TagOpen y ys) (TagOpen x xs) = (strNull x || x == y) && all g xs+            where+                g (name,val) | strNull name = val  `elem` map snd ys+                             | strNull val  = name `elem` map fst ys+                g nameval = nameval `elem` ys+        f _ _ = False++-- | Negation of '~=='+(~/=) :: (StringLike str, TagRep t) => Tag str -> t -> Bool+(~/=) a b = not (a ~== b)++++-- | This function takes a list, and returns all suffixes whose+--   first item matches the predicate.+sections :: (a -> Bool) -> [a] -> [[a]]+sections p = filter (p . head) . init . tails++-- | This function is similar to 'sections', but splits the list+--   so no element appears in any two partitions.+partitions :: (a -> Bool) -> [a] -> [[a]]+partitions p =+   let notp = not . p+   in  groupBy (const notp) . dropWhile notp
+ src/Text/HTML/TagSoup/Entity.hs view
@@ -0,0 +1,337 @@+-- | This module converts between HTML/XML entities (i.e. @&amp;@) and+--   the characters they represent.+module Text.HTML.TagSoup.Entity(+    lookupEntity, lookupNamedEntity, lookupNumericEntity,+    escapeXMLChar,+    xmlEntities, htmlEntities+    ) where++import Data.Char+import Data.Ix+import Numeric+++-- | Lookup an entity, using 'lookupNumericEntity' if it starts with+--   @#@ and 'lookupNamedEntity' otherwise+lookupEntity :: String -> Maybe Char+lookupEntity ('#':xs) = lookupNumericEntity xs+lookupEntity xs = lookupNamedEntity xs++-- | Lookup a numeric entity, the leading @\'#\'@ must have already been removed.+--+-- > lookupNumericEntity "65" == Just 'A'+-- > lookupNumericEntity "x41" == Just 'A'+-- > lookupNumericEntity "x4E" === Just 'N'+-- > lookupNumericEntity "x4e" === Just 'N'+-- > lookupNumericEntity "Haskell" == Nothing+-- > lookupNumericEntity "" == Nothing+-- > lookupNumericEntity "89439085908539082" == Nothing+lookupNumericEntity :: String -> Maybe Char+lookupNumericEntity = f+        -- entity = '&#' [0-9]+ ';' | '&#x' [0-9a-fA-F]+ ';'+    where+        f ('x':xs) = g [('0','9'),('a','f'),('A','F')] readHex xs+        f xs = g [('0','9')] reads xs++        g :: [(Char,Char)] -> ReadS Integer -> String -> Maybe Char+        g valid reader xs = do+            let test b = if b then Just () else Nothing+            test $ isValid valid xs+            test $ not $ null xs+            case reader xs of+                [(a,"")] -> do+                    test $ inRange (toInteger $ ord minBound, toInteger $ ord maxBound) a+                    return $ chr $ fromInteger a+                _ -> Nothing++        isValid :: [(Char,Char)] -> String -> Bool+        isValid valid xs = all (\x -> any (`inRange` x) valid) xs+++-- | Lookup a named entity, using 'htmlEntities'+--+-- > lookupNamedEntity "amp" == Just '&'+-- > lookupNamedEntity "haskell" == Nothing+lookupNamedEntity :: String -> Maybe Char+lookupNamedEntity x = fmap chr $ lookup x htmlEntities+++-- | Escape a character before writing it out to XML.+--+-- > escapeXMLChar 'a' == Nothing+-- > escapeXMLChar '&' == Just "amp"+escapeXMLChar :: Char -> Maybe String+escapeXMLChar x = case [a | (a,b) <- xmlEntities, b == ord x] of+                       (y:_) -> Just y+                       _ -> Nothing+++-- | A table mapping XML entity names to code points.+--   Does /not/ include @apos@ as Internet Explorer does not know about it.+xmlEntities :: [(String, Int)]+xmlEntities = let a*b = (a,ord b) in+    ["quot" * '"'+    ,"amp"  * '&'+    -- ,"apos" * '\''    -- Internet Explorer does not know that+    ,"lt"   * '<'+    ,"gt"   * '>'+    ]++-- | A table mapping HTML entity names to code points+htmlEntities :: [(String, Int)]+htmlEntities = let (*) = (,) in+    xmlEntities +++    ["apos"    * ord '\''  -- quirky IE!!!++    ,"nbsp"    * 160+    ,"iexcl"   * 161+    ,"cent"    * 162+    ,"pound"   * 163+    ,"curren"  * 164+    ,"yen"     * 165+    ,"brvbar"  * 166+    ,"sect"    * 167+    ,"uml"     * 168+    ,"copy"    * 169+    ,"ordf"    * 170+    ,"laquo"   * 171+    ,"not"     * 172+    ,"shy"     * 173+    ,"reg"     * 174+    ,"macr"    * 175+    ,"deg"     * 176+    ,"plusmn"  * 177+    ,"sup2"    * 178+    ,"sup3"    * 179+    ,"acute"   * 180+    ,"micro"   * 181+    ,"para"    * 182+    ,"middot"  * 183+    ,"cedil"   * 184+    ,"sup1"    * 185+    ,"ordm"    * 186+    ,"raquo"   * 187+    ,"frac14"  * 188+    ,"frac12"  * 189+    ,"frac34"  * 190+    ,"iquest"  * 191+    ,"Agrave"  * 192+    ,"Aacute"  * 193+    ,"Acirc"   * 194+    ,"Atilde"  * 195+    ,"Auml"    * 196+    ,"Aring"   * 197+    ,"AElig"   * 198+    ,"Ccedil"  * 199+    ,"Egrave"  * 200+    ,"Eacute"  * 201+    ,"Ecirc"   * 202+    ,"Euml"    * 203+    ,"Igrave"  * 204+    ,"Iacute"  * 205+    ,"Icirc"   * 206+    ,"Iuml"    * 207+    ,"ETH"     * 208+    ,"Ntilde"  * 209+    ,"Ograve"  * 210+    ,"Oacute"  * 211+    ,"Ocirc"   * 212+    ,"Otilde"  * 213+    ,"Ouml"    * 214+    ,"times"   * 215+    ,"Oslash"  * 216+    ,"Ugrave"  * 217+    ,"Uacute"  * 218+    ,"Ucirc"   * 219+    ,"Uuml"    * 220+    ,"Yacute"  * 221+    ,"THORN"   * 222+    ,"szlig"   * 223+    ,"agrave"  * 224+    ,"aacute"  * 225+    ,"acirc"   * 226+    ,"atilde"  * 227+    ,"auml"    * 228+    ,"aring"   * 229+    ,"aelig"   * 230+    ,"ccedil"  * 231+    ,"egrave"  * 232+    ,"eacute"  * 233+    ,"ecirc"   * 234+    ,"euml"    * 235+    ,"igrave"  * 236+    ,"iacute"  * 237+    ,"icirc"   * 238+    ,"iuml"    * 239+    ,"eth"     * 240+    ,"ntilde"  * 241+    ,"ograve"  * 242+    ,"oacute"  * 243+    ,"ocirc"   * 244+    ,"otilde"  * 245+    ,"ouml"    * 246+    ,"divide"  * 247+    ,"oslash"  * 248+    ,"ugrave"  * 249+    ,"uacute"  * 250+    ,"ucirc"   * 251+    ,"uuml"    * 252+    ,"yacute"  * 253+    ,"thorn"   * 254+    ,"yuml"    * 255++    ,"OElig"   * 338+    ,"oelig"   * 339+    ,"Scaron"  * 352+    ,"scaron"  * 353+    ,"Yuml"    * 376+    ,"circ"    * 710+    ,"tilde"   * 732++    ,"ensp"    * 8194+    ,"emsp"    * 8195+    ,"thinsp"  * 8201+    ,"zwnj"    * 8204+    ,"zwj"     * 8205+    ,"lrm"     * 8206+    ,"rlm"     * 8207+    ,"ndash"   * 8211+    ,"mdash"   * 8212+    ,"lsquo"   * 8216+    ,"rsquo"   * 8217+    ,"sbquo"   * 8218+    ,"ldquo"   * 8220+    ,"rdquo"   * 8221+    ,"bdquo"   * 8222+    ,"dagger"  * 8224+    ,"Dagger"  * 8225+    ,"permil"  * 8240+    ,"lsaquo"  * 8249+    ,"rsaquo"  * 8250+    ,"euro"    * 8364++    ,"fnof"    * 402+    ,"Alpha"   * 913+    ,"Beta"    * 914+    ,"Gamma"   * 915+    ,"Delta"   * 916+    ,"Epsilon" * 917+    ,"Zeta"    * 918+    ,"Eta"     * 919+    ,"Theta"   * 920+    ,"Iota"    * 921+    ,"Kappa"   * 922+    ,"Lambda"  * 923+    ,"Mu"      * 924+    ,"Nu"      * 925+    ,"Xi"      * 926+    ,"Omicron" * 927+    ,"Pi"      * 928+    ,"Rho"     * 929+    ,"Sigma"   * 931+    ,"Tau"     * 932+    ,"Upsilon" * 933+    ,"Phi"     * 934+    ,"Chi"     * 935+    ,"Psi"     * 936+    ,"Omega"   * 937+    ,"alpha"   * 945+    ,"beta"    * 946+    ,"gamma"   * 947+    ,"delta"   * 948+    ,"epsilon" * 949+    ,"zeta"    * 950+    ,"eta"     * 951+    ,"theta"   * 952+    ,"iota"    * 953+    ,"kappa"   * 954+    ,"lambda"  * 955+    ,"mu"      * 956+    ,"nu"      * 957+    ,"xi"      * 958+    ,"omicron" * 959+    ,"pi"      * 960+    ,"rho"     * 961+    ,"sigmaf"  * 962+    ,"sigma"   * 963+    ,"tau"     * 964+    ,"upsilon" * 965+    ,"phi"     * 966+    ,"chi"     * 967+    ,"psi"     * 968+    ,"omega"   * 969+    ,"thetasym"* 977+    ,"upsih"   * 978+    ,"piv"     * 982+    ,"bull"    * 8226+    ,"hellip"  * 8230+    ,"prime"   * 8242+    ,"Prime"   * 8243+    ,"oline"   * 8254+    ,"frasl"   * 8260+    ,"weierp"  * 8472+    ,"image"   * 8465+    ,"real"    * 8476+    ,"trade"   * 8482+    ,"alefsym" * 8501+    ,"larr"    * 8592+    ,"uarr"    * 8593+    ,"rarr"    * 8594+    ,"darr"    * 8595+    ,"harr"    * 8596+    ,"crarr"   * 8629+    ,"lArr"    * 8656+    ,"uArr"    * 8657+    ,"rArr"    * 8658+    ,"dArr"    * 8659+    ,"hArr"    * 8660+    ,"forall"  * 8704+    ,"part"    * 8706+    ,"exist"   * 8707+    ,"empty"   * 8709+    ,"nabla"   * 8711+    ,"isin"    * 8712+    ,"notin"   * 8713+    ,"ni"      * 8715+    ,"prod"    * 8719+    ,"sum"     * 8721+    ,"minus"   * 8722+    ,"lowast"  * 8727+    ,"radic"   * 8730+    ,"prop"    * 8733+    ,"infin"   * 8734+    ,"ang"     * 8736+    ,"and"     * 8743+    ,"or"      * 8744+    ,"cap"     * 8745+    ,"cup"     * 8746+    ,"int"     * 8747+    ,"there4"  * 8756+    ,"sim"     * 8764+    ,"cong"    * 8773+    ,"asymp"   * 8776+    ,"ne"      * 8800+    ,"equiv"   * 8801+    ,"le"      * 8804+    ,"ge"      * 8805+    ,"sub"     * 8834+    ,"sup"     * 8835+    ,"nsub"    * 8836+    ,"sube"    * 8838+    ,"supe"    * 8839+    ,"oplus"   * 8853+    ,"otimes"  * 8855+    ,"perp"    * 8869+    ,"sdot"    * 8901+    ,"lceil"   * 8968+    ,"rceil"   * 8969+    ,"lfloor"  * 8970+    ,"rfloor"  * 8971+    ,"lang"    * 9001+    ,"rang"    * 9002+    ,"loz"     * 9674+    ,"spades"  * 9824+    ,"clubs"   * 9827+    ,"hearts"  * 9829+    ,"diams"   * 9830+    ]
+ src/Text/HTML/TagSoup/Generated.hs view
@@ -0,0 +1,2 @@+module Text.HTML.TagSoup.Generated(parseTagsOptions) where+import Text.HTML.TagSoup.Manual
+ src/Text/HTML/TagSoup/Implementation.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE RecordWildCards, PatternGuards, ScopedTypeVariables #-}++module Text.HTML.TagSoup.Implementation where++import Data.List+import Text.HTML.TagSoup.Type+import Text.HTML.TagSoup.Options+import Text.StringLike as Str+import Numeric+import Data.Char+import Control.Exception(assert)+import Control.Arrow++---------------------------------------------------------------------+-- BOTTOM LAYER++data Out+    = Char Char+    | Tag          -- <+    | TagShut      -- </+    | AttName+    | AttVal+    | TagEnd       -- >+    | TagEndClose  -- />+    | Comment      -- <!--+    | CommentEnd   -- -->+    | Entity       -- &+    | EntityNum    -- &#+    | EntityHex    -- &#x+    | EntityEnd    -- ;+    | EntityEndAtt -- missing the ; and in an attribute+    | Warn String+    | Pos Position+      deriving (Show,Eq)++errSeen x = Warn $ "Unexpected " ++ show x+errWant x = Warn $ "Expected " ++ show x++data S = S+    {s :: S+    ,tl :: S+    ,hd :: Char+    ,eof :: Bool+    ,next :: String -> Maybe S+    ,pos :: [Out] -> [Out]+    }+++expand :: Position -> String -> S+expand p text = res+    where res = S{s = res+                 ,tl = expand (positionChar p (head text)) (tail text)+                 ,hd = if null text then '\0' else head text+                 ,eof = null text+                 ,next = next p text+                 ,pos = (Pos p:)+                 }++          next p (t:ext) (s:tr) | t == s = next (positionChar p t) ext tr+          next p text [] = Just $ expand p text+          next _ _ _ = Nothing+++infixr &++class Outable a where (&) :: a -> [Out] -> [Out]+instance Outable Char where (&) = ampChar+instance Outable Out where (&) = ampOut+ampChar x y = Char x : y+ampOut x y = x : y+++state :: String -> S+state s = expand nullPosition s++---------------------------------------------------------------------+-- TOP LAYER+++output :: forall str . StringLike str => ParseOptions str -> [Out] -> [Tag str]+output ParseOptions{..} x = (if optTagTextMerge then tagTextMerge else id) $ go ((nullPosition,[]),x)+    where+        -- main choice loop+        go :: ((Position,[Tag str]),[Out]) -> [Tag str]+        go ((p,ws),xs) | p `seq` False = [] -- otherwise p is a space leak when optTagPosition == False+        go ((p,ws),xs) | not $ null ws = (if optTagWarning then (reverse ws++) else id) $ go ((p,[]),xs)+        go ((p,ws),Pos p2:xs) = go ((p2,ws),xs)++        go x | isChar x = pos x $ TagText a : go y+            where (y,a) = charsStr x+        go x | isTag x = pos x $ TagOpen a b : (if isTagEndClose z then pos x $ TagClose a : go (next z) else go (skip isTagEnd z))+            where (y,a) = charsStr $ next x+                  (z,b) = atts y+        go x | isTagShut x = pos x $ (TagClose a:) $+                (if not (null b) then warn x "Unexpected attributes in close tag" else id) $+                if isTagEndClose z then warn x "Unexpected self-closing in close tag" $ go (next z) else go (skip isTagEnd z)+            where (y,a) = charsStr $ next x+                  (z,b) = atts y+        go x | isComment x = pos x $ TagComment a : go (skip isCommentEnd y)+            where (y,a) = charsStr $ next x+        go x | isEntity x = poss x ((if optTagWarning then id else filter (not . isTagWarning)) $ optEntityData a) ++ go (skip isEntityEnd y) +            where (y,a) = charsStr $ next x+        go x | isEntityChr x = pos x $ TagText (fromChar $ entityChr x a) : go (skip isEntityEnd y)+            where (y,a) = chars $ next x+        go x | Just a <- fromWarn x = if optTagWarning then pos x $ TagWarning (fromString a) : go (next x) else go (next x)+        go x | isEof x = []++        atts :: ((Position,[Tag str]),[Out]) -> ( ((Position,[Tag str]),[Out]) , [(str,str)] )+        atts x | isAttName x = second ((a,b):) $ atts z+            where (y,a) = charsStr (next x)+                  (z,b) = if isAttVal y then charsEntsStr (next y) else (y, empty)+        atts x | isAttVal x = second ((empty,a):) $ atts y+            where (y,a) = charsEntsStr (next x)+        atts x = (x, [])++        -- chars+        chars x = charss False x+        charsStr x = (id *** fromString) $ chars x+        charsEntsStr x = (id *** fromString) $ charss True x++        -- loop round collecting characters, if the b is set including entity+        charss :: Bool -> ((Position,[Tag str]),[Out]) -> ( ((Position,[Tag str]),[Out]) , String)+        charss t x | Just a <- fromChr x = (y, a:b)+            where (y,b) = charss t (next x)+        charss t x | t, isEntity x = second (toString n ++) $ charss t $ addWarns m z+            where (y,a) = charsStr $ next x+                  b = not $ isEntityEndAtt y+                  z = if b then skip isEntityEnd y else next y+                  (n,m) = optEntityAttrib (a,b)+        charss t x | t, isEntityChr x = second (entityChr x a:) $ charss t z+            where (y,a) = chars $ next x+                  (z,b) = charss t $ if isEntityEnd y then next y else skip isEntityEndAtt y+        charss t ((_,w),Pos p:xs) = charss t ((p,w),xs)+        charss t x | Just a <- fromWarn x = charss t $ (if optTagWarning then addWarns [TagWarning $ fromString a] else id) $ next x+        charss t x = (x, [])++        -- utility functions+        next x = second (drop 1) x+        skip f x = assert (isEof x || f x) (next x)+        addWarns ws x@((p,w),y) = ((p, reverse (poss x ws) ++ w), y)+        pos ((p,_),_) rest = if optTagPosition then tagPosition p : rest else rest+        warn x s rest = if optTagWarning then pos x $ TagWarning (fromString s) : rest else rest+        poss x = concatMap (\w -> pos x [w]) +++entityChr x s | isEntityNum x = chr $ read s+              | isEntityHex x = chr $ fst $ head $ readHex s+++isEof (_,[]) = True; isEof _ = False+isChar (_,Char{}:_) = True; isChar _ = False+isTag (_,Tag{}:_) = True; isTag _ = False+isTagShut (_,TagShut{}:_) = True; isTagShut _ = False+isAttName (_,AttName{}:_) = True; isAttName _ = False+isAttVal (_,AttVal{}:_) = True; isAttVal _ = False+isTagEnd (_,TagEnd{}:_) = True; isTagEnd _ = False+isTagEndClose (_,TagEndClose{}:_) = True; isTagEndClose _ = False+isComment (_,Comment{}:_) = True; isComment _ = False+isCommentEnd (_,CommentEnd{}:_) = True; isCommentEnd _ = False+isEntity (_,Entity{}:_) = True; isEntity _ = False+isEntityChr (_,EntityNum{}:_) = True; isEntityChr (_,EntityHex{}:_) = True; isEntityChr _ = False+isEntityNum (_,EntityNum{}:_) = True; isEntityNum _ = False+isEntityHex (_,EntityHex{}:_) = True; isEntityHex _ = False+isEntityEnd (_,EntityEnd{}:_) = True; isEntityEnd _ = False+isEntityEndAtt (_,EntityEndAtt{}:_) = True; isEntityEndAtt _ = False+isWarn (_,Warn{}:_) = True; isWarn _ = False++fromChr (_,Char x:_) = Just x ; fromChr _ = Nothing+fromWarn (_,Warn x:_) = Just x ; fromWarn _ = Nothing+++-- Merge all adjacent TagText bits+tagTextMerge :: StringLike str => [Tag str] -> [Tag str]+tagTextMerge (TagText x:xs) = TagText (strConcat (x:a)) : tagTextMerge b+    where+        (a,b) = f xs++        -- additional brackets on 3 lines to work around HSE 1.3.2 bugs with pattern fixities+        f (TagText x:xs) = (x:a,b)+            where (a,b) = f xs+        f (TagPosition{}:(x@TagText{}:xs)) = f $ x : xs+        f x = g x id x++        g o op (p@TagPosition{}:(w@TagWarning{}:xs)) = g o (op . (p:) . (w:)) xs+        g o op (w@TagWarning{}:xs) = g o (op . (w:)) xs+        g o op (p@TagPosition{}:(x@TagText{}:xs)) = f $ p : x : op xs+        g o op (x@TagText{}:xs) = f $ x : op xs+        g o op _ = ([], o)++tagTextMerge (x:xs) = x : tagTextMerge xs+tagTextMerge [] = []
+ src/Text/HTML/TagSoup/Manual.hs view
@@ -0,0 +1,13 @@++module Text.HTML.TagSoup.Manual(parseTagsOptions) where++import Text.HTML.TagSoup.Specification+import Text.HTML.TagSoup.Implementation+import Text.HTML.TagSoup.Type+import Text.HTML.TagSoup.Options+import Text.StringLike+++parseTagsOptions :: StringLike str => ParseOptions str -> str -> [Tag str]+parseTagsOptions opts = output opts . parse . toString+
+ src/Text/HTML/TagSoup/Match.hs view
@@ -0,0 +1,88 @@+module Text.HTML.TagSoup.Match where++import Text.HTML.TagSoup.Type (Tag(..), Attribute)+import Data.List+++-- | match an opening tag+tagOpen :: (str -> Bool) -> ([Attribute str] -> Bool) -> Tag str -> Bool+tagOpen pName pAttrs (TagOpen name attrs) =+   pName name && pAttrs attrs+tagOpen _ _ _ = False++-- | match an closing tag+tagClose :: (str -> Bool) -> Tag str -> Bool+tagClose pName (TagClose name) = pName name+tagClose _ _ = False++-- | match a text+tagText :: (str -> Bool) -> Tag str -> Bool+tagText p (TagText text) = p text+tagText _ _ = False++tagComment :: (str -> Bool) -> Tag str -> Bool+tagComment p (TagComment text) = p text+tagComment _ _ = False+++-- | match a opening tag's name literally+tagOpenLit :: Eq str => str -> ([Attribute str] -> Bool) -> Tag str -> Bool+tagOpenLit name = tagOpen (name==)++-- | match a closing tag's name literally+tagCloseLit :: Eq str => str -> Tag str -> Bool+tagCloseLit name = tagClose (name==)++tagOpenAttrLit :: Eq str => str -> Attribute str -> Tag str -> Bool+tagOpenAttrLit name attr =+   tagOpenLit name (anyAttrLit attr)++{- |+Match a tag with given name, that contains an attribute+with given name, that satisfies a predicate.+If an attribute occurs multiple times,+all occurrences are checked.+-}+tagOpenAttrNameLit :: Eq str => str -> str -> (str -> Bool) -> Tag str -> Bool+tagOpenAttrNameLit tagName attrName pAttrValue =+   tagOpenLit tagName+      (anyAttr (\(name,value) -> name==attrName && pAttrValue value))+++-- | Check if the 'Tag str' is 'TagOpen' and matches the given name+tagOpenNameLit :: Eq str => str -> Tag str -> Bool+tagOpenNameLit name = tagOpenLit name (const True)++-- | Check if the 'Tag str' is 'TagClose' and matches the given name+tagCloseNameLit :: Eq str => str -> Tag str -> Bool+tagCloseNameLit name = tagCloseLit name+++++anyAttr :: ((str,str) -> Bool) -> [Attribute str] -> Bool+anyAttr = any++anyAttrName :: (str -> Bool) -> [Attribute str] -> Bool+anyAttrName p = any (p . fst)++anyAttrValue :: (str -> Bool) -> [Attribute str] -> Bool+anyAttrValue p = any (p . snd)+++anyAttrLit :: Eq str => (str,str) -> [Attribute str] -> Bool+anyAttrLit attr = anyAttr (attr==)++anyAttrNameLit :: Eq str => str -> [Attribute str] -> Bool+anyAttrNameLit name = anyAttrName (name==)++anyAttrValueLit :: Eq str => str -> [Attribute str] -> Bool+anyAttrValueLit value = anyAttrValue (value==)++++getTagContent :: Eq str => str -> ([Attribute str] -> Bool) -> [Tag str] -> [Tag str]+getTagContent name pAttrs =+   takeWhile (not . tagCloseLit name) . drop 1 .+   head . sections (tagOpenLit name pAttrs)+    where sections p = filter (p . head) . init . tails
+ src/Text/HTML/TagSoup/Options.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Text.HTML.TagSoup.Options where++import Data.Typeable+import Text.HTML.TagSoup.Type+import Text.HTML.TagSoup.Entity+import Text.StringLike+++-- | These options control how 'parseTags' works.+data ParseOptions str = ParseOptions+    {optTagPosition :: Bool -- ^ Should 'TagPosition' values be given before some items (default=False,fast=False)+    ,optTagWarning :: Bool  -- ^ Should 'TagWarning' values be given (default=False,fast=False)+    ,optEntityData :: str -> [Tag str] -- ^ How to lookup an entity+    ,optEntityAttrib :: (str,Bool) -> (str,[Tag str]) -- ^ How to lookup an entity in an attribute (Bool = has ending @';'@?)+    ,optTagTextMerge :: Bool -- ^ Require no adjacent 'TagText' values (default=True,fast=False)+    }+    deriving Typeable+++-- | The default parse options value, described in 'ParseOptions'.+parseOptions :: StringLike str => ParseOptions str+parseOptions = ParseOptions False False entityData entityAttrib True+    where+        entityData x = case lookupEntity y of+            Just y -> [TagText $ fromChar y]+            Nothing -> [TagText $ fromString $ "&" ++ y ++ ";"+                       ,TagWarning $ fromString $ "Unknown entity: " ++ y]+            where y = toString x++        entityAttrib (x,b) = case lookupEntity y of+            Just y -> (fromChar y, [])+            Nothing -> (fromString $ "&" ++ y ++ [';'|b], [TagWarning $ fromString $ "Unknown entity: " ++ y])+            where y = toString x+++-- | A 'ParseOptions' structure optimised for speed, following the fast options.+parseOptionsFast :: StringLike str => ParseOptions str+parseOptionsFast = parseOptions{optTagTextMerge=False}+++-- | Change the underlying string type of a 'ParseOptions' value.+fmapParseOptions :: (StringLike from, StringLike to) => ParseOptions from -> ParseOptions to+fmapParseOptions (ParseOptions a b c d e) = ParseOptions a b c2 d2 e+    where+        c2 x = map (fmap castString) $ c $ castString x+        d2 (x,y) = (castString r, map (fmap castString) s)+            where (r,s) = d (castString x, y)+
+ src/Text/HTML/TagSoup/Parser.hs view
@@ -0,0 +1,26 @@++module Text.HTML.TagSoup.Parser(+    parseTags, parseTagsOptions,+    ParseOptions(..), parseOptions, parseOptionsFast+    ) where++import Text.HTML.TagSoup.Type+import Text.HTML.TagSoup.Options+import Text.StringLike+import qualified Text.HTML.TagSoup.Generated as Gen+++-- | Parse a string to a list of tags, using an HTML 5 compliant parser.+--+-- > parseTags "<hello>my&amp;</world>" == [TagOpen "hello" [],TagText "my&",TagClose "world"]+parseTags :: StringLike str => str -> [Tag str]+parseTags = parseTagsOptions parseOptions+++-- | Parse a string to a list of tags, using settings supplied by the 'ParseOptions' parameter,+--   eg. to output position information:+--+-- > parseTagsOptions parseOptions{optTagPosition = True} "<hello>my&amp;</world>" ==+-- >    [TagPosition 1 1,TagOpen "hello" [],TagPosition 1 8,TagText "my&",TagPosition 1 15,TagClose "world"]+parseTagsOptions :: StringLike str => ParseOptions str -> str -> [Tag str]+parseTagsOptions = Gen.parseTagsOptions
+ src/Text/HTML/TagSoup/Render.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE PatternGuards #-}+{-|+    This module converts a list of 'Tag' back into a string.+-}++module Text.HTML.TagSoup.Render+    (+    renderTags, renderTagsOptions,+    RenderOptions(..), renderOptions+    ) where++import Data.Char+import qualified Data.IntMap as IntMap+import Text.HTML.TagSoup.Entity+import Text.HTML.TagSoup.Type+import Text.StringLike+++-- | These options control how 'renderTags' works.+--+--   The strange quirk of only minimizing @\<br\>@ tags is due to Internet Explorer treating+--   @\<br\>\<\/br\>@ as @\<br\>\<br\>@.+data RenderOptions str = RenderOptions+    {optEscape :: str -> str        -- ^ Escape a piece of text (default = escape the four characters @&\"\<\>@)+    ,optMinimize :: str -> Bool     -- ^ Minimise \<b\>\<\/b\> -> \<b/\> (default = minimise only @\<br\>@ tags)+    }+++-- | The default render options value, described in 'RenderOptions'.+renderOptions :: StringLike str => RenderOptions str+renderOptions = RenderOptions+        (\x -> fromString $ concatMap esc1 $ toString x)+        (\x -> toString x == "br")+    where esc = IntMap.fromList [(b, "&"++a++";") | (a,b) <- htmlEntities]+          esc1 x = IntMap.findWithDefault [x] (ord x) esc+++fmapRenderOptions :: (StringLike a, StringLike b) => RenderOptions a -> RenderOptions b+fmapRenderOptions (RenderOptions x y) = RenderOptions (castString . x . castString) (y . castString)+++-- | Show a list of tags, as they might have been parsed, using the default settings given in+--   'RenderOptions'.+--+-- > renderTags [TagOpen "hello" [],TagText "my&",TagClose "world"] == "<hello>my&amp;</world>"+renderTags :: StringLike str => [Tag str] -> str+renderTags = renderTagsOptions renderOptions+++-- | Show a list of tags using settings supplied by the 'RenderOptions' parameter,+--   eg. to avoid escaping any characters one could do:+--+-- > renderTagsOptions renderOptions{optEscape = id} [TagText "my&"] == "my&"+renderTagsOptions :: StringLike str => RenderOptions str -> [Tag str] -> str+renderTagsOptions opts = strConcat . tags+    where+        s = fromString+        ss x = [s x]+    +        tags (TagOpen name atts:TagClose name2:xs)+            | name == name2 && optMinimize opts name = open name atts (s " /") ++ tags xs+        tags (TagOpen name atts:xs) | Just ('?',_) <- uncons name = open name atts (s " ?") ++ tags xs+        tags (x:xs) = tag x ++ tags xs+        tags [] = []++        tag (TagOpen name atts) = open name atts (s "")+        tag (TagClose name) = [s "</", name, s ">"]+        tag (TagText text) = [txt text]+        tag (TagComment text) = ss "<!--" ++ com text ++ ss "-->"+        tag _ = ss ""++        txt = optEscape opts+        open name atts shut = [s "<",name] ++ concatMap att atts ++ [shut,s ">"]+        att (x,y) | xnull && ynull = [s " \"\""]+                  | ynull = [s " ", x]+                  | xnull = [s " \"",txt y,s "\""]+                  | otherwise = [s " ",x,s "=\"",txt y,s "\""]+            where (xnull, ynull) = (strNull x, strNull y)++        com xs | Just ('-',xs) <- uncons xs, Just ('-',xs) <- uncons xs, Just ('>',xs) <- uncons xs = s "-- >" : com xs+        com xs = case uncons xs of+            Nothing -> []+            Just (x,xs) -> fromChar x : com xs
+ src/Text/HTML/TagSoup/Specification.hs view
@@ -0,0 +1,308 @@+{-# LANGUAGE RecordWildCards, PatternGuards #-}++module Text.HTML.TagSoup.Specification(parse) where++import Text.HTML.TagSoup.Implementation+import Data.Char+++white x = x `elem` "\t\n\f "++-- We make some generalisations:+-- <!name is a valid tag start closed by >+-- <?name is a valid tag start closed by ?>+-- </!name> is a valid closing tag+-- </?name> is a valid closing tag+-- <a "foo"> is a valid tag attibute, i.e missing an attribute name+-- We also don't do lowercase conversion+-- Entities are handled without a list of known entity names+-- We don't have RCData, CData or Escape modes (only effects dat and tagOpen)++-- 9.2.4 Tokenization++type Parser = S -> [Out]++parse :: String -> [Out]+parse = dat . state ++-- 9.2.4.1 Data state+dat :: Parser+dat S{..} = pos $ case hd of+    '&' -> charReference tl+    '<' -> tagOpen tl+    _ | eof -> []+    _ -> hd & dat tl+++-- 9.2.4.2 Character reference data state+charReference s = charRef dat False Nothing s+++-- 9.2.4.3 Tag open state+tagOpen S{..} = case hd of+    '!' -> markupDeclOpen tl+    '/' -> closeTagOpen tl+    _ | isAlpha hd -> Tag & hd & tagName False tl+    '>' -> errSeen "<>" & '<' & '>' & dat tl+    '?' -> neilXmlTagOpen tl -- NEIL+    _ -> errSeen  "<" & '<' & dat s+++-- seen "<?", emitted []+neilXmlTagOpen S{..} = pos $ case hd of+    _ | isAlpha hd -> Tag & '?' & hd & tagName True tl+    _ -> errSeen "<?" & '<' & '?' & dat s++-- seen "?", expecting ">"+neilXmlTagClose S{..} = pos $ case hd of+    '>' -> TagEnd & dat tl+    _ -> errSeen "?" & beforeAttName True s+++-- just seen ">" at the end, am given tl+neilTagEnd xml S{..}+    | xml = pos $ errWant "?>" & TagEnd & dat s+    | otherwise = pos $ TagEnd & dat s+++-- 9.2.4.4 Close tag open state+-- Deviation: We ignore the if CDATA/RCDATA bits and tag matching+-- Deviation: On </> we output </> to the text+-- Deviation: </!name> is a closing tag, not a bogus comment+closeTagOpen S{..} = case hd of+    _ | isAlpha hd || hd `elem` "?!" -> TagShut & hd & tagName False tl+    '>' -> errSeen "</>" & '<' & '/' & '>' & dat tl+    _ | eof -> '<' & '/' & dat s+    _ -> errWant "tag name" & bogusComment s+++-- 9.2.4.5 Tag name state+tagName xml S{..} = pos $ case hd of+    _ | white hd -> beforeAttName xml tl+    '/' -> selfClosingStartTag xml tl+    '>' -> neilTagEnd xml tl+    '?' | xml -> neilXmlTagClose tl+    _ | isAlpha hd -> hd & tagName xml tl+    _ | eof -> errWant (if xml then "?>" else ">") & dat s+    _ -> hd & tagName xml tl+++-- 9.2.4.6 Before attribute name state+beforeAttName xml S{..} = pos $ case hd of+    _ | white hd -> beforeAttName xml tl+    '/' -> selfClosingStartTag xml tl+    '>' -> neilTagEnd xml tl+    '?' | xml -> neilXmlTagClose tl+    _ | hd `elem` "\'\"" -> beforeAttValue xml s -- NEIL+    _ | hd `elem` "\"'<=" -> errSeen [hd] & AttName & hd & attName xml tl+    _ | eof -> errWant (if xml then "?>" else ">") & dat s+    _ -> AttName & hd & attName xml tl+++-- 9.2.4.7 Attribute name state+attName xml S{..} = pos $ case hd of+    _ | white hd -> afterAttName xml tl+    '/' -> selfClosingStartTag xml tl+    '=' -> beforeAttValue xml tl+    '>' -> neilTagEnd xml tl+    '?' | xml -> neilXmlTagClose tl+    _ | hd `elem` "\"'<" -> errSeen [hd] & def+    _ | eof -> errWant (if xml then "?>" else ">") & dat s+    _ -> def+    where def = hd & attName xml tl+++-- 9.2.4.8 After attribute name state+afterAttName xml S{..} = pos $ case hd of+    _ | white hd -> afterAttName xml tl+    '/' -> selfClosingStartTag xml tl+    '=' -> beforeAttValue xml tl+    '>' -> neilTagEnd xml tl+    '?' | xml -> neilXmlTagClose tl+    _ | hd `elem` "\"'" -> AttVal & beforeAttValue xml s -- NEIL+    _ | hd `elem` "\"'<" -> errSeen [hd] & def+    _ | eof -> errWant (if xml then "?>" else ">") & dat s+    _ -> def+    where def = AttName & hd & attName xml tl++-- 9.2.4.9 Before attribute value state+beforeAttValue xml S{..} = pos $ case hd of+    _ | white hd -> beforeAttValue xml tl+    '\"' -> AttVal & attValueDQuoted xml tl+    '&' -> AttVal & attValueUnquoted xml s+    '\'' -> AttVal & attValueSQuoted xml tl+    '>' -> errSeen "=" & neilTagEnd xml tl+    '?' | xml -> neilXmlTagClose tl+    _ | hd `elem` "<=" -> errSeen [hd] & def+    _ | eof -> errWant (if xml then "?>" else ">") & dat s+    _ -> def+    where def = AttVal & hd & attValueUnquoted xml tl+++-- 9.2.4.10 Attribute value (double-quoted) state+attValueDQuoted xml S{..} = pos $ case hd of+    '\"' -> afterAttValueQuoted xml tl+    '&' -> charRefAttValue (attValueDQuoted xml) (Just '\"') tl+    _ | eof -> errWant "\"" & dat s+    _ -> hd & attValueDQuoted xml tl+++-- 9.2.4.11 Attribute value (single-quoted) state+attValueSQuoted xml S{..} = pos $ case hd of+    '\'' -> afterAttValueQuoted xml tl+    '&' -> charRefAttValue (attValueSQuoted xml) (Just '\'') tl+    _ | eof -> errWant "\'" & dat s+    _ -> hd & attValueSQuoted xml tl+++-- 9.2.4.12 Attribute value (unquoted) state+attValueUnquoted xml S{..} = pos $ case hd of+    _ | white hd -> beforeAttName xml tl+    '&' -> charRefAttValue (attValueUnquoted xml) Nothing tl+    '>' -> neilTagEnd xml tl+    '?' | xml -> neilXmlTagClose tl+    _ | hd `elem` "\"'<=" -> errSeen [hd] & def+    _ | eof -> errWant (if xml then "?>" else ">") & dat s+    _ -> def+    where def = hd & attValueUnquoted xml tl+++-- 9.2.4.13 Character reference in attribute value state+charRefAttValue :: Parser -> Maybe Char -> Parser+charRefAttValue resume c s = charRef resume True c s+++-- 9.2.4.14 After attribute value (quoted) state+afterAttValueQuoted xml S{..} = pos $ case hd of+    _ | white hd -> beforeAttName xml tl+    '/' -> selfClosingStartTag xml tl+    '>' -> neilTagEnd xml tl+    '?' | xml -> neilXmlTagClose tl+    _ | eof -> dat s+    _ -> errSeen [hd] & beforeAttName xml s+++-- 9.2.4.15 Self-closing start tag state+selfClosingStartTag xml S{..} = pos $ case hd of+    _ | xml -> errSeen "/" & beforeAttName xml s+    '>' -> TagEndClose & dat tl+    _ | eof -> errWant ">" & dat s+    _ -> errSeen "/" & beforeAttName xml s+++-- 9.2.4.16 Bogus comment state+bogusComment S{..} = Comment & bogusComment1 s+bogusComment1 S{..} = pos $ case hd of+    '>' -> CommentEnd & dat tl+    _ | eof -> CommentEnd & dat s+    _ -> hd & bogusComment1 tl+++-- 9.2.4.17 Markup declaration open state+markupDeclOpen S{..} = pos $ case hd of+    _ | Just s <- next "--" -> Comment & commentStart s+    _ | isAlpha hd -> Tag & '!' & hd & tagName False tl -- NEIL+    _ | Just s <- next "[CDATA[" -> cdataSection s+    _ -> errWant "tag name" & bogusComment s+++-- 9.2.4.18 Comment start state+commentStart S{..} = pos $ case hd of+    '-' -> commentStartDash tl+    '>' -> errSeen "<!-->" & CommentEnd & dat tl+    _ | eof -> errWant "-->" & CommentEnd & dat s+    _ -> hd & comment tl+++-- 9.2.4.19 Comment start dash state+commentStartDash S{..} = pos $ case hd of+    '-' -> commentEnd tl+    '>' -> errSeen "<!--->" & CommentEnd & dat tl+    _ | eof -> errWant "-->" & CommentEnd & dat s+    _ -> '-' & hd & comment tl+++-- 9.2.4.20 Comment state+comment S{..} = pos $ case hd of+    '-' -> commentEndDash tl+    _ | eof -> errWant "-->" & CommentEnd & dat s+    _ -> hd & comment tl+++-- 9.2.4.21 Comment end dash state+commentEndDash S{..} = pos $ case hd of+    '-' -> commentEnd tl+    _ | eof -> errWant "-->" & CommentEnd & dat s+    _ -> '-' & hd & comment tl+++-- 9.2.4.22 Comment end state+commentEnd S{..} = pos $ case hd of+    '>' -> CommentEnd & dat tl+    '-' -> errWant "-->" & '-' & commentEnd tl+    _ | white hd -> errSeen "--" & '-' & '-' & hd & commentEndSpace tl+    '!' -> errSeen "!" & commentEndBang tl+    _ | eof -> errWant "-->" & CommentEnd & dat s+    _ -> errSeen "--" & '-' & '-' & hd & comment tl+++-- 9.2.4.23 Comment end bang state+commentEndBang S{..} = pos $ case hd of+    '>' -> CommentEnd & dat tl+    '-' -> '-' & '-' & '!' & commentEndDash tl+    _ | eof -> errWant "-->" & CommentEnd & dat s+    _ -> '-' & '-' & '!' & hd & comment tl+++-- 9.2.4.24 Comment end space state+commentEndSpace S{..} = pos $ case hd of+    '>' -> CommentEnd & dat tl+    '-' -> commentEndDash tl+    _ | white hd -> hd & commentEndSpace tl+    _ | eof -> errWant "-->" & CommentEnd & dat s+    _ -> hd & comment tl+++-- 9.2.4.38 CDATA section state+cdataSection S{..} = pos $ case hd of+    _ | Just s <- next "]]>" -> dat s+    _ | eof -> dat s+    _ | otherwise -> hd & cdataSection tl+++-- 9.2.4.39 Tokenizing character references+-- Change from spec: this is reponsible for writing '&' if nothing is to be written+charRef :: Parser -> Bool -> Maybe Char -> S -> [Out]+charRef resume att end S{..} = pos $ case hd of+    _ | eof || hd `elem` "\t\n\f <&" || maybe False (== hd) end -> '&' & resume s+    '#' -> charRefNum resume s tl+    _ -> charRefAlpha resume att s++charRefNum resume o S{..} = pos $ case hd of+    _ | hd `elem` "xX" -> charRefNum2 resume o True tl+    _ -> charRefNum2 resume o False s++charRefNum2 resume o hex S{..} = pos $ case hd of+    _ | hexChar hex hd -> (if hex then EntityHex else EntityNum) & hd & charRefNum3 resume hex tl+    _ -> errSeen "&" & '&' & resume o++charRefNum3 resume hex S{..} = pos $ case hd of+    _ | hexChar hex hd -> hd & charRefNum3 resume hex tl+    ';' -> EntityEnd & resume tl+    _ -> errWant ";" & EntityEnd & resume s++charRefAlpha resume att S{..} = pos $ case hd of+    _ | isAlpha hd -> Entity & hd & charRefAlpha2 resume att tl+    _ -> errSeen "&" & '&' & resume s++charRefAlpha2 resume att S{..} = pos $ case hd of+    _ | alphaChar hd -> hd & charRefAlpha2 resume att tl+    ';' -> EntityEnd & resume tl+    _ | att -> EntityEndAtt & resume s+    _ -> errWant ";" & EntityEnd & resume s+++alphaChar x = isAlphaNum x || x `elem` ":-_"++hexChar False x = isDigit x+hexChar True  x = isDigit x || (x >= 'a' && x <= 'f') || (x >= 'A' && x <= 'F')
+ src/Text/HTML/TagSoup/Tree.hs view
@@ -0,0 +1,75 @@+{-|+    /NOTE/: This module is preliminary and may change at a future date.+    If you wish to use its features, please email me and I will+    help evolve an API that suits you.++    This module is intended to help converting a list of tags into a+    tree of tags.+-}++module Text.HTML.TagSoup.Tree+    {-# DEPRECATED "Not quite ready for use yet, email me if it looks useful to you" #-}+    (+    TagTree(..), tagTree,+    flattenTree, transformTree, universeTree+    ) where++import Text.HTML.TagSoup.Type+import Control.Arrow+++data TagTree str = TagBranch str [Attribute str] [TagTree str]+                 | TagLeaf (Tag str)+                   deriving Show++instance Functor TagTree where+    fmap f (TagBranch x y z) = TagBranch (f x) (map (f***f) y) (map (fmap f) z)+    fmap f (TagLeaf x) = TagLeaf (fmap f x)+++-- | Convert a list of tags into a tree. This version is not lazy at+--   all, that is saved for version 2.+tagTree :: Eq str => [Tag str] -> [TagTree str]+tagTree = g+    where+        g :: Eq str => [Tag str] -> [TagTree str]+        g [] = []+        g xs = a ++ map TagLeaf (take 1 b) ++ g (drop 1 b)+            where (a,b) = f xs++        -- the second tuple is either null or starts with a close+        f :: Eq str => [Tag str] -> ([TagTree str],[Tag str])+        f (TagOpen name atts:rest) =+            case f rest of+                (inner,[]) -> (TagLeaf (TagOpen name atts):inner, [])+                (inner,TagClose x:xs)+                    | x == name -> let (a,b) = f xs in (TagBranch name atts inner:a, b)+                    | otherwise -> (TagLeaf (TagOpen name atts):inner, TagClose x:xs)+                _ -> error "TagSoup.Tree.tagTree: safe as - forall x . isTagClose (snd (f x))"++        f (TagClose x:xs) = ([], TagClose x:xs)+        f (x:xs) = (TagLeaf x:a,b)+            where (a,b) = f xs+        f [] = ([], [])+++flattenTree :: [TagTree str] -> [Tag str]+flattenTree xs = concatMap f xs+    where+        f (TagBranch name atts inner) =+            TagOpen name atts : flattenTree inner ++ [TagClose name]+        f (TagLeaf x) = [x]+++universeTree :: [TagTree str] -> [TagTree str]+universeTree = concatMap f+    where+        f t@(TagBranch _ _ inner) = t : universeTree inner+        f x = [x]+++transformTree :: (TagTree str -> [TagTree str]) -> [TagTree str] -> [TagTree str]+transformTree act = concatMap f+    where+        f (TagBranch a b inner) = act $ TagBranch a b (transformTree act inner)+        f x = act x
+ src/Text/HTML/TagSoup/Type.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE DeriveDataTypeable #-}+-- | The central type in TagSoup++module Text.HTML.TagSoup.Type(+    -- * Data structures and parsing+    StringLike, Tag(..), Attribute, Row, Column,+    +    -- * Position manipulation+    Position(..), tagPosition, nullPosition, positionChar, positionString,++    -- * Tag identification+    isTagOpen, isTagClose, isTagText, isTagWarning, isTagPosition,+    isTagOpenName, isTagCloseName,++    -- * Extraction+    fromTagText, fromAttrib,+    maybeTagText, maybeTagWarning,+    innerText,+    ) where+++import Data.Char+import Data.List+import Data.Maybe+import Text.StringLike+import Data.Data(Data, Typeable)++-- | An HTML attribute @id=\"name\"@ generates @(\"id\",\"name\")@+type Attribute str = (str,str)++-- | The row/line of a position, starting at 1+type Row = Int++-- | The column of a position, starting at 1+type Column = Int+++--- All positions are stored as a row and a column, with (1,1) being the+--- top-left position+data Position = Position !Row !Column deriving (Show,Eq,Ord)++nullPosition :: Position+nullPosition = Position 1 1++positionString :: Position -> String -> Position+positionString = foldl' positionChar++positionChar :: Position -> Char -> Position+positionChar (Position r c) x = case x of+    '\n' -> Position (r+1) 1+    '\t' -> Position r (c + 8 - mod (c-1) 8)+    _    -> Position r (c+1)++tagPosition :: Position -> Tag str+tagPosition (Position r c) = TagPosition r c+++-- | A single HTML element. A whole document is represented by a list of @Tag@.+--   There is no requirement for 'TagOpen' and 'TagClose' to match.+data Tag str =+     TagOpen str [Attribute str]  -- ^ An open tag with 'Attribute's in their original order+   | TagClose str                 -- ^ A closing tag+   | TagText str                  -- ^ A text node, guaranteed not to be the empty string+   | TagComment str               -- ^ A comment+   | TagWarning str               -- ^ Meta: A syntax error in the input file+   | TagPosition !Row !Column     -- ^ Meta: The position of a parsed element+     deriving (Show, Eq, Ord, Data, Typeable)++instance Functor Tag where+    fmap f (TagOpen x y) = TagOpen (f x) [(f a, f b) | (a,b) <- y]+    fmap f (TagClose x) = TagClose (f x)+    fmap f (TagText x) = TagText (f x)+    fmap f (TagComment x) = TagComment (f x)+    fmap f (TagWarning x) = TagWarning (f x)+    fmap f (TagPosition x y) = TagPosition x y+++-- | Test if a 'Tag' is a 'TagOpen'+isTagOpen :: Tag str -> Bool+isTagOpen (TagOpen {})  = True; isTagOpen  _ = False++-- | Test if a 'Tag' is a 'TagClose'+isTagClose :: Tag str -> Bool+isTagClose (TagClose {}) = True; isTagClose _ = False++-- | Test if a 'Tag' is a 'TagText'+isTagText :: Tag str -> Bool+isTagText (TagText {})  = True; isTagText  _ = False++-- | Extract the string from within 'TagText', otherwise 'Nothing'+maybeTagText :: Tag str -> Maybe str+maybeTagText (TagText x) = Just x+maybeTagText _ = Nothing++-- | Extract the string from within 'TagText', crashes if not a 'TagText'+fromTagText :: Show str => Tag str -> str+fromTagText (TagText x) = x+fromTagText x = error $ "(" ++ show x ++ ") is not a TagText"++-- | Extract all text content from tags (similar to Verbatim found in HaXml)+innerText :: StringLike str => [Tag str] -> str+innerText = strConcat . mapMaybe maybeTagText++-- | Test if a 'Tag' is a 'TagWarning'+isTagWarning :: Tag str -> Bool+isTagWarning (TagWarning {})  = True; isTagWarning _ = False++-- | Extract the string from within 'TagWarning', otherwise 'Nothing'+maybeTagWarning :: Tag str -> Maybe str+maybeTagWarning (TagWarning x) = Just x+maybeTagWarning _ = Nothing++-- | Test if a 'Tag' is a 'TagPosition'+isTagPosition :: Tag str -> Bool+isTagPosition TagPosition{} = True; isTagPosition _ = False++-- | Extract an attribute, crashes if not a 'TagOpen'.+--   Returns @\"\"@ if no attribute present.+fromAttrib :: (Show str, Eq str, StringLike str) => str -> Tag str -> str+fromAttrib att (TagOpen _ atts) = fromMaybe empty $ lookup att atts+fromAttrib _ x = error ("(" ++ show x ++ ") is not a TagOpen")+++-- | Returns True if the 'Tag' is 'TagOpen' and matches the given name+isTagOpenName :: Eq str => str -> Tag str -> Bool+isTagOpenName name (TagOpen n _) = n == name+isTagOpenName _ _ = False++-- | Returns True if the 'Tag' is 'TagClose' and matches the given name+isTagCloseName :: Eq str => str -> Tag str -> Bool+isTagCloseName name (TagClose n) = n == name+isTagCloseName _ _ = False
src/Text/HTML/Yuuko.hs view
@@ -1,7 +1,7 @@ module Text.HTML.Yuuko where -import Text.XML.HXT.Arrow-import qualified Text.XML.HXT.Arrow.XPathSimple as XS+import Yuuko.Text.XML.HXT.Arrow+import qualified Yuuko.Text.XML.HXT.Arrow.XPathSimple as XS import System.IO.Unsafe  in_html :: [(String, String)]
+ src/Text/StringLike.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE TypeSynonymInstances #-}++-- | /WARNING/: This module is /not/ intended for use outside the TagSoup library.+--+--   This module provides an abstraction for String's as used inside TagSoup. It allows+--   TagSoup to work with String (list of Char), ByteString.Char8 and ByteString.Lazy.Char8.+module Text.StringLike where++import Data.List+import Data.Maybe+import Data.Typeable++import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as LBS+++-- | A class to generalise TagSoup parsing over many types of string-like types.+--   Examples are given for the String type.+class (Typeable a, Eq a) => StringLike a where+    -- | > empty = ""+    empty :: a+    -- | > cons = (:)+    cons :: Char -> a -> a+    -- | > uncons []     = Nothing+    --   > uncons (x:xs) = Just (x, xs)+    uncons :: a -> Maybe (Char, a)++    -- | > toString = id+    toString :: a -> String+    -- | > fromString = id+    fromString :: String -> a+    -- | > fromChar = return+    fromChar :: Char -> a+    -- | > strConcat = concat+    strConcat :: [a] -> a+    -- | > strNull = null+    strNull :: a -> Bool+    -- | > append = (++)+    append :: a -> a -> a+++-- | Convert a String from one type to another.+castString :: (StringLike a, StringLike b) => a -> b+castString = fromString . toString+++instance StringLike String where+    uncons [] = Nothing+    uncons (x:xs) = Just (x, xs)+    toString = id+    fromString = id+    fromChar = (:[])+    strConcat = concat+    empty = []+    strNull = null+    cons c = (c:)+    append = (++)++instance StringLike BS.ByteString where+    uncons = BS.uncons+    toString = BS.unpack+    fromString = BS.pack+    fromChar = BS.singleton+    strConcat = BS.concat+    empty = BS.empty+    strNull = BS.null+    cons = BS.cons+    append = BS.append++instance StringLike LBS.ByteString where+    uncons = LBS.uncons+    toString = LBS.unpack+    fromString = LBS.pack+    fromChar = LBS.singleton+    strConcat = LBS.concat+    empty = LBS.empty+    strNull = LBS.null+    cons = LBS.cons+    append = LBS.append
+ src/Yuuko/Control/Arrow/ArrowIO.hs view
@@ -0,0 +1,71 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Control.Arrow.ArrowIO+   Copyright  : Copyright (C) 2005 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)+   Stability  : experimental+   Portability: portable+   Version    : $Id: ArrowIO.hs,v 1.6 2005/09/02 17:09:39 hxml Exp $++Lifting of IO actions to arrows++-}++-- ------------------------------------------------------------++module Yuuko.Control.Arrow.ArrowIO+    ( ArrowIO(..)+    , ArrowIOIf(..)+    )+where++import Control.Arrow++-- | the interface for converting an IO action into an arrow++class Arrow a => ArrowIO a where++    -- | construct an arrow from an IO action+    arrIO		:: (b -> IO c) -> a b c++    -- | construct an arrow from an IO action without any parameter+    arrIO0		:: IO c -> a b c+    arrIO0 f		= arrIO (const f)++    -- | construction of a 2 argument arrow from a binary IO action+    -- |+    -- | example: @ a1 &&& a2 >>> arr2 f @++    arrIO2		:: (b1 -> b2 -> IO c) -> a (b1, b2) c+    arrIO2 f		= arrIO (\ ~(x1, x2) -> f x1 x2)++    -- | construction of a 3 argument arrow from a 3-ary IO action+    -- |+    -- | example: @ a1 &&& a2 &&& a3 >>> arr3 f @++    arrIO3		:: (b1 -> b2 -> b3 -> IO c) -> a (b1, (b2, b3)) c+    arrIO3 f		= arrIO (\ ~(x1, ~(x2, x3)) -> f x1 x2 x3)++    -- | construction of a 4 argument arrow from a 4-ary IO action+    -- |+    -- | example: @ a1 &&& a2 &&& a3 &&& a4 >>> arr4 f @++    arrIO4		:: (b1 -> b2 -> b3 -> b4 -> IO c) -> a (b1, (b2, (b3, b4))) c+    arrIO4 f		= arrIO (\ ~(x1, ~(x2, ~(x3, x4))) -> f x1 x2 x3 x4)+++-- | the interface for converting an IO predicate into a list arrow++class (Arrow a, ArrowIO a) => ArrowIOIf a where++    -- | builds an arrow from an IO predicate+    --+    -- if the predicate holds, the single list containing the input is returned, else the empty list,+    -- similar to 'Yuuko.Control.Arrow.ArrowList.isA'++    isIOA		:: (b -> IO Bool) -> a b b++-- ------------------------------------------------------------
+ src/Yuuko/Control/Arrow/ArrowIf.hs view
@@ -0,0 +1,158 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Control.Arrow.ArrowIf+   Copyright  : Copyright (C) 2005 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)+   Stability  : experimental+   Portability: portable+   Version    : $Id: ArrowIf.hs,v 1.8 2006/05/04 14:17:53 hxml Exp $++Conditionals for List Arrows++This module defines conditional combinators for list arrows.++The empty list as result represents False, none empty lists True.++-}++-- ------------------------------------------------------------++module Yuuko.Control.Arrow.ArrowIf+    ( module Yuuko.Control.Arrow.ArrowIf+    )+where++import Control.Arrow+import Yuuko.Control.Arrow.ArrowList++import Data.List+    ( partition )++-- ------------------------------------------------------------++-- | The interface for arrows as conditionals.+--+-- Requires list arrows because False is represented as empty list, True as none empty lists.+--+-- Only 'ifA' and 'orElse' don't have default implementations++class ArrowList a => ArrowIf a where++    -- | if lifted to arrows++    ifA			:: a b c -> a b d -> a b d -> a b d++    -- | shortcut: @ ifP p = ifA (isA p) @++    ifP			:: (b -> Bool) -> a b d -> a b d -> a b d+    ifP p		= ifA (isA p)++    -- | negation: @ neg f = ifA f none this @++    neg			:: a b c -> a b b+    neg	f		= ifA f none this++    -- | @ f \`when\` g @ : when the predicate g holds, f is applied, else the identity filter this++    when		:: a b b -> a b c -> a b b+    f `when` g		= ifA g f this++    -- | shortcut: @ f \`whenP\` p = f \`when\` (isA p) @++    whenP		:: a b b -> (b -> Bool) -> a b b+    f `whenP` g		= ifP g f this++    -- | @ f \`whenNot\` g @ : when the predicate g does not hold, f is applied, else the identity filter this++    whenNot		:: a b b -> a b c -> a b b+    f `whenNot` g	= ifA g this f++    -- | like 'whenP'++    whenNotP		:: a b b -> (b -> Bool) -> a b b+    f `whenNotP` g	= ifP g this f++    -- | @ g \`guards\` f @ : when the predicate g holds, f is applied, else none++    guards		:: a b c -> a b d -> a b d+    f `guards` g	= ifA f g none++    -- | like 'whenP'++    guardsP		:: (b -> Bool) -> a b d -> a b d+    f `guardsP` g	= ifP f g none++    -- | shortcut for @ f `guards` this @++    filterA		:: a b c -> a b b+    filterA f		= ifA f this none++    -- | @ f \`containing\` g @ : keep only those results from f for which g holds+    --+    -- definition: @ f \`containing\` g = f >>> g \`guards\` this @++    containing		:: a b c -> a c d -> a b c+    f `containing` g	= f >>> g `guards` this++    -- | @ f \`notContaining\` g @ : keep only those results from f for which g does not hold+    --+    -- definition: @ f \`notContaining\` g = f >>> ifA g none this @++    notContaining	:: a b c -> a c d -> a b c+    f `notContaining` g	= f >>> ifA g none this++    -- | @ f \`orElse\` g @ : directional choice: if f succeeds, the result of f is the result, else g is applied+    orElse		:: a b c -> a b c -> a b c++    -- | generalisation of 'orElse' for multi way branches like in case expressions.+    --+    -- An auxiliary data type 'IfThen' with an infix constructor ':->' is used for writing multi way branches+    --+    -- example: @ choiceA [ p1 :-> e1, p2 :-> e2, this :-> default ] @+    choiceA		:: [IfThen (a b c) (a b d)] -> a b d+    choiceA 		= foldr ifA' none+			  where+			  ifA' (g :-> f) = ifA g f+++    -- | tag a value with Left or Right, if arrow has success, input is tagged with Left, else with Right+    tagA		:: a b c -> a b (Either b b)+    tagA p		= ifA p (arr Left) (arr Right)+++    -- | split a list value with an arrow and returns a pair of lists.+    -- This is the arrow version of 'span'. The arrow is deterministic.+    --+    -- example: @ runLA (spanA (isA (\/= \'-\'))) \"abc-def\" @ gives @ [(\"abc\",\"-def\")] @ as result++    spanA		:: a b b -> a [b] ([b],[b])+    spanA p		= ifA ( arrL (take 1) >>> p )+			  ( arr head &&& (arr tail >>> spanA p)+			    >>>+			    arr (\ ~(x, ~(xs,ys)) -> (x : xs, ys))+			  )+                          ( arr (\ l -> ([],l)) )++    -- | partition a list of values into a pair of lists+    --+    -- This is the arrow Version of 'Data.List.partition'++    partitionA		:: a b b -> a [b] ([b],[b])+    partitionA	p	= listA ( arrL id >>> tagA p )+			  >>^+			  ( (\ ~(l1, l2) -> (unTag l1, unTag l2) ) . partition (isLeft) )+	                  where+			  isLeft (Left _) = True+			  isLeft _        = False+			  unTag	= map (either id id)++-- ------------------------------------------------------------++-- | an auxiliary data type for 'choiceA'++data IfThen a b	= a :-> b++-- ------------------------------------------------------------
+ src/Yuuko/Control/Arrow/ArrowList.hs view
@@ -0,0 +1,346 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Control.Arrow.ArrowList+   Copyright  : Copyright (C) 2005 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)+   Stability  : experimental+   Portability: portable+   Version    : $Id: ArrowList.hs,v 1.11 2006/06/01 12:59:04 hxml Exp $++The List Arrow Class++This module defines the interface for list arrows.++A list arrow is a function, that gives a list of results+for a given argument. A single element result represents a normal function.+An empty list oven indicates, the function is undefined for the given argument.+The empty list may also represent False, none empty lists True.+A list with more than one element gives all results for a nondeterministic function.++-}++-- ------------------------------------------------------------++module Yuuko.Control.Arrow.ArrowList+    ( ArrowList(..)+    )+where++import Control.Arrow++infixl 8 >>., >.++infixl 2 $<, $<<, $<<<, $<<<<+infixl 2 $<$++-- ------------------------------------------------------------++-- | The interface for list arrows+--+-- Only 'mkA', 'arr2A', 'isA' '(>>.)' don't have default implementations++class (Arrow a, ArrowPlus a, ArrowZero a, ArrowApply a) => ArrowList a where++    -- | construction of a 2 argument arrow from a binary function+    -- |+    -- | example: @ a1 &&& a2 >>> arr2 f @++    arr2		:: (b1 -> b2 -> c) -> a (b1, b2) c+    arr2		= arr . uncurry++    -- | construction of a 3 argument arrow from a 3-ary function+    -- |+    -- | example: @ a1 &&& a2 &&& a3 >>> arr3 f @++    arr3		:: (b1 -> b2 -> b3 -> c) -> a (b1, (b2, b3)) c+    arr3 f		= arr (\ ~(x1, ~(x2, x3)) -> f x1 x2 x3)++    -- | construction of a 4 argument arrow from a 4-ary function+    -- |+    -- | example: @ a1 &&& a2 &&& a3 &&& a4 >>> arr4 f @++    arr4		:: (b1 -> b2 -> b3 -> b4 -> c) -> a (b1, (b2, (b3, b4))) c+    arr4 f		= arr (\ ~(x1, ~(x2, ~(x3, x4))) -> f x1 x2 x3 x4)++    -- | construction of a 2 argument arrow from a singe argument arrow++    arr2A		:: (b -> a c d) -> a (b, c) d++    -- | constructor for a list arrow from a function with a list as result++    arrL		:: (b -> [c]) -> a b c++    -- | constructor for a list arrow with 2 arguments++    arr2L		:: (b -> c -> [d]) -> a (b, c) d+    arr2L		= arrL . uncurry++    -- | constructor for a const arrow: @ constA = arr . const @++    constA		:: c -> a b c+    constA		= arr . const++    -- | constructor for a const arrow: @ constL = arrL . const @++    constL		:: [c] -> a b c+    constL		= arrL . const++    -- | builds an arrow from a predicate.+    -- If the predicate holds, the single list containing the input is returned, else the empty list++    isA			:: (b -> Bool) -> a b b++    -- | combinator for converting the result of a list arrow into another list+    --+    -- example: @ foo >>. reverse @ reverses the the result of foo+    --+    -- example: @ foo >>. take 1 @ constructs a deterministic version of foo by deleting all further results++    (>>.)		:: a b c -> ([c] -> [d]) -> a b d++    -- | combinator for converting the result of an arrow into a single element result++    (>.)		:: a b c -> ([c] ->  d ) -> a b d+    af >. f		= af >>. ((:[]) . f)++    -- | combinator for converting an arrow into a determinstic version with all results collected in a single element list+    --+    -- @ listA af = af >>. (:[]) @+    --+    -- this is useful when the list of results computed by an arrow must be manipulated (e.g. sorted)+    --+    -- example for sorting the results of a filter+    --+    -- > collectAndSort         :: a b c -> a b c+    -- >+    -- > collectAndSort collect = listA collect >>> arrL sort++    listA		:: a b c -> a b [c]+    listA af		= af >>.  (:[])++    -- | the inverse of 'listA'+    --+    -- @ listA af >>> unlistA = af @+    --+    -- unlistA is defined as @ arrL id @++    unlistA		:: a [b] b+    unlistA		= arrL id++    -- | the identity arrow, alias for returnA++    this		:: a b b+    this		= returnA++    -- | the zero arrow, alias for zeroArrow++    none		:: a b c+    none		= zeroArrow++    -- | converts an arrow, that may fail, into an arrow that always succeeds+    --+    -- example: @ withDefault none \"abc\" @ is equivalent to @ constA \"abc\" @++    withDefault		:: a b c -> c -> a b c+    withDefault	a d	= a >>. \ x -> if null x then [d] else x++    -- | makes a list arrow deterministic, the number of results is at most 1+    --+    -- definition+    --+    -- > single f = f >>. take 1+    --+    -- examples with strings:+    --+    -- > runLA ( single none ) "x" == []+    -- > runLA ( single this ) "x" == ["x"]+    -- > runLA ( single+    -- >         (constA "y"+    -- >          <+> this ) ) "x" == ["y"]++    single		:: a b c -> a b c+    single f		= f >>. take 1++    -- | compute an arrow from the input and apply the arrow to this input+    --+    -- definition: @ (f &&& this) >>> app @+    --+    -- in a point free style, there is no way to use an argument in 2 places,+    -- this is a combinator for simulating this. first the argument is used to compute an arrow,+    -- then this new arrow is applied to the input+    --+    -- applyA coresponds to: @ apply f x = let g = f x in g x @+    --+    -- see also: '$<', '$<<', '$<<<', '$<<<<', '$<$'++    applyA		:: a b (a b c) -> a b c+    applyA f            = (f &&& this) >>> app++    -- | compute the parameter for an arrow with extra parameters from the input+    -- and apply the arrow for all parameter values to the input+    --+    -- a kind of \"function call\" for arrows, useful for joining arrows+    --+    -- > infixl 2 ($<)+    --+    -- definition:+    --+    -- > g $< f = applyA (f >>> arr g)+    --+    -- if @f@ fails, the whole arrow fails, e.g. @ g \$\< none == none @+    --+    -- if @f@ computes n values and @g@ is deterministic, the whole arrow computes n values+    --+    -- examples with simple list arrows with strings+    --+    -- > prefixString   :: String -> a String String+    -- > prefixString s =  arr (s++)+    -- >+    -- > runLA ( prefixString $< none           ) "x" == []+    -- > runLA ( prefixString $< constA "y"     ) "x" == ["yx"]+    -- > runLA ( prefixString $< this           ) "x" == ["xx"]+    -- > runLA ( prefixString $< constA "y"+    -- >                         <+> constA "z" ) "x" == ["yx","zx"]+    -- > runLA ( prefixString $< constA "y"+    -- >                         <+> this+    -- >                         <+> constA "z" ) "x" == ["yx","xx","zx"]+    --+    -- see also: 'applyA', '$<<', '$<<<', '$<<<<', '$<$'++    ($<)		:: (c -> a b d) -> a b c -> a b d+    g $< f		= applyA (f >>> arr g)++    -- | binary version of '$<'+    --+    -- example with simple list arrows with strings+    --+    -- > infixString    :: String -> String -> a String String+    -- > infixString s1 s2+    -- >                = arr (\ s -> s1 ++ s ++ s2)+    -- >+    -- > runLA ( infixString $<< constA "y" &&& constA "z" ) "x" = ["yxz"]+    -- > runLA ( infixString $<< this &&& this             ) "x" = ["xxx"]+    -- > runLA ( infixString $<< constA "y"+    -- >                         &&& (constA "z" <+> this) ) "x" = ["yxz", "yxx"]++    ($<<)		:: (c1 -> c2 -> a b d) -> a b (c1, c2) -> a b d+    f $<< g		= applyA (g >>> arr2 f)++    -- | version of '$<' for arrows with 3 extra parameters+    --+    -- typical usage+    --+    -- > f $<<< g1 &&& g2 &&& g3++    ($<<<)		:: (c1 -> c2 -> c3 -> a b d) -> a b (c1, (c2, c3)) -> a b d+    f $<<< g		= applyA (g >>> arr3 f)++    -- | version of '$<' for arrows with 4 extra parameters+    --+    -- typical usage+    --+    -- > f $<<<< g1 &&& g2 &&& g3 &&& g4++    ($<<<<)		:: (c1 -> c2 -> c3 -> c4 -> a b d) -> a b (c1, (c2, (c3, c4))) -> a b d+    f $<<<< g		= applyA (g >>> arr4 f)++    -- | compute the parameter for an arrow @f@ with an extra parameter by an arrow @g@+    -- and apply all the results from @g@ sequentially to the input+    --+    -- > infixl 2 ($<$)+    --+    -- typical usage:+    --+    -- > g :: a b c+    -- > g = ...+    -- >+    -- > f :: c -> a b b+    -- > f x = ... x ...+    -- >+    -- > f $<$ g+    --+    -- @f@ computes the extra parameters for @g@ from the input of type @b@ and @g@ is applied with this+    -- parameter to the input. This allows programming in a point wise style in @g@, which becomes+    -- neccessary, when a value is needed more than once.+    --+    -- this combinator is useful, when transforming a single value (document) step by step,+    -- with @g@ for collecting the data for all steps, and @f@ for transforming the input step by step+    --+    -- if @g@ is deterministic (computes exactly one result),+    -- @ g $\<$ f == g $\< f @ holds+    --+    -- if @g@ fails, @ f $<$ g == this @+    --+    -- if @g@ computes more than one result, @f@ is applied sequentially to the input for every result from @g@+    --+    -- examples with simple list arrows with strings+    --+    -- > prefixString   :: String -> a String String+    -- > prefixString s =  arr (s++)+    -- >+    -- > runLA ( prefixString $<$ none                      ) "x" == ["x"]+    -- > runLA ( prefixString $<$ constA "y"                ) "x" == ["yx"]+    -- > runLA ( prefixString $<$ constA "y" <+> constA "z" ) "x" == ["zyx"]+    -- > runLA ( prefixString $<$ constA "y" <+> this+    -- >                          <+> constA "z"            ) "x" == ["zxyx"]+    --+    -- example with two extra parameter+    --+    -- > g1 :: a b c1+    -- > g2 :: a b c2+    -- >+    -- > f          :: (c1, c2) -> a b b+    -- > f (x1, x2) =  ... x1 ... x2 ... +    -- >+    -- > f $<$ g1 &&& g2+    --+    -- see also: 'applyA', '$<'++    ($<$)		:: (c -> (a b b)) -> a b c -> a b b+    g $<$ f		= applyA (listA (f >>> arr g) >>> arr seqA)++    -- | merge the result pairs of an arrow with type @a a1 (b1, b2)@+    -- by combining the tuple components with the @op@ arrow+    --+    -- examples with simple list arrows working on strings and XmlTrees+    --+    -- >     a1 :: a String (XmlTree, XmlTree)+    -- >     a1 = selem "foo" [this >>> mkText]+    -- > 	  &&&+    -- > 	  selem "bar" [arr (++"0") >>> mkText]+    -- > +    -- >     runLA (a1 >>> mergeA (<+>) >>> xshow this) "42" == ["<foo>42</foo>","<bar>420</bar>"]+    -- >     runLA (a1 >>> mergeA (+=)  >>> xshow this) "42" == ["<foo>42<bar>420</bar></foo>"]+    --+    -- see also: 'applyA', '$<' and '+=' in class 'Yuuko.Text.XML.HXT.Arrow.ArrowXml'++    mergeA		:: (a (a1, b1) a1 -> a (a1, b1) b1 -> a (a1, b1) c) ->+			   a (a1, b1) c+    mergeA op		= (\ x -> arr fst `op` constA (snd x)) $< this++    -- | useful only for arrows with side effects: perform applies an arrow to the input+    -- ignores the result and returns the input+    --+    -- example: @ ... >>> perform someTraceArrow >>> ... @++    perform		:: a b c -> a b b+    perform f		= listA f &&& this >>> arr snd++    -- | generalization of arrow combinator '<+>'+    --+    -- definition: @ catA = foldl (\<+\>) none @++    catA		:: [a b c] -> a b c+    catA		= foldl (<+>) none++    -- | generalization of arrow combinator '>>>'+    --+    -- definition: @ seqA = foldl (>>>) this @++    seqA		:: [a b b] -> a b b+    seqA		= foldl (>>>) this++-- ------------------------------------------------------------
+ src/Yuuko/Control/Arrow/ArrowNF.hs view
@@ -0,0 +1,38 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Control.Arrow.ArrowNF+   Copyright  : Copyright (C) 2005-8 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)+   Stability  : experimental+   Portability: non-portable++   Arrows for evaluation of normal form results++-}++-- ------------------------------------------------------------++module Yuuko.Control.Arrow.ArrowNF+where++import Control.Arrow+import Control.DeepSeq++-- |+-- complete evaluation of an arrow result using 'Control.DeepSeq'+--+-- this is sometimes useful for preventing space leaks, especially after reading+-- and validation of a document, all DTD stuff is not longer in use and can be+-- recycled by the GC.++strictA	:: (Arrow a, NFData b) => a b b+strictA	= arr $ \ x -> deepseq x x++class (Arrow a) => ArrowNF a where+    rnfA	:: (NFData c) => a b c -> a b c+    rnfA f	= f >>> strictA++-- ------------------------------------------------------------
+ src/Yuuko/Control/Arrow/ArrowState.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}++-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Control.Arrow.ArrowState+   Copyright  : Copyright (C) 2005 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)+   Stability  : experimental+   Portability: multy parameter classes and functional depenedencies required++   Arrows for managing an explicit state++   State arrows work similar to state monads.+   A state value is threaded through the application of arrows.++-}++-- ------------------------------------------------------------++module Yuuko.Control.Arrow.ArrowState+    ( ArrowState(..)+    )+where++import Control.Arrow++-- | The interface for accessing and changing the state component.+--+-- Multi parameter classes and functional dependencies are required.++class Arrow a => ArrowState s a | a -> s where++    -- | change the state of a state arrow by applying a function+    -- for computing a new state from the old and the arrow input.+    -- Result is the arrow input++    changeState		:: (s -> b -> s) -> a b b++    -- | access the state with a function using the arrow input+    -- as data for selecting state components.++    accessState		:: (s -> b -> c) -> a b c++    -- | read the complete state, ignore arrow input+    --+    -- definition: @ getState = accessState (\\ s x -> s) @ ++    getState		:: a b s+    getState		= accessState (\ s _x -> s)++    -- | overwrite the old state+    --+    -- definition: @ setState = changeState (\\ s x -> x) @+    setState		:: a s s+    setState		= changeState (\ _s x -> x)	-- changeState (const id)++    -- | change state (and ignore input) and return new state+    --+    -- convenience function,+    -- usefull for generating e.g. unique identifiers:+    --+    -- example with SLA state list arrows+    --+    -- > newId :: SLA Int b String+    -- > newId = nextState (+1)+    -- >         >>>+    -- >         arr (('#':) . show)+    -- > +    -- > runSLA 0 (newId <+> newId <+> newId) undefined+    -- >   = ["#1", "#2", "#3"]++    nextState		:: (s -> s) -> a b s+    nextState sf	= changeState (\s -> const (sf s))+			  >>>+			  getState++-- ------------------------------------------------------------
+ src/Yuuko/Control/Arrow/ArrowTree.hs view
@@ -0,0 +1,317 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Control.Arrow.ArrowTree+   Copyright  : Copyright (C) 2005 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)+   Stability  : experimental+   Portability: portable+   Version    : $Id: ArrowTree.hs,v 1.12 2006/11/30 16:05:24 hxml Exp $++List arrows for tree processing.++Trees that implement the "Yuuko.Data.Tree.Class" interface, can be processed+with these arrows.++-}++-- ------------------------------------------------------------++module Yuuko.Control.Arrow.ArrowTree+    ( ArrowTree(..)+    , Tree+    )+where++import Yuuko.Data.Tree.Class (Tree)+import qualified Yuuko.Data.Tree.Class as T hiding (Tree)++import Control.Arrow+import Yuuko.Control.Arrow.ArrowList+import Yuuko.Control.Arrow.ArrowIf++infixl 5 />, //>, </++-- ------------------------------------------------------------++-- | The interface for tree arrows+--+-- all functions have default implementations++class (ArrowPlus a, ArrowIf a) => ArrowTree a where++    -- | construct a leaf++    mkLeaf		:: Tree t => b -> a c (t b)+    mkLeaf		= constA . T.mkLeaf++    -- | construct an inner node++    mkTree		:: Tree t => b -> [t b] -> a c (t b)+    mkTree n		= constA . T.mkTree n++    -- | select the children of the root of a tree++    getChildren		:: Tree t => a (t b) (t b)+    getChildren		= arrL T.getChildren++    -- | select the attribute of the root of a tree++    getNode		:: Tree t => a (t b) b+    getNode		= arr T.getNode++    -- | substitute the children of the root of a tree++    setChildren		:: Tree t =>            [t b] -> a (t b) (t b)+    setChildren cs	= arr (T.setChildren cs)++    -- | substitute the attribute of the root of a tree++    setNode		:: Tree t =>                b -> a (t b) (t b)+    setNode n		= arr (T.setNode n)++    -- | edit the children of the root of a tree++    changeChildren	:: Tree t => ([t b] -> [t b]) -> a (t b) (t b)+    changeChildren csf	= arr (T.changeChildren csf)++    -- | edit the attribute of the root of a tree++    changeNode		:: Tree t =>        (b  -> b) -> a (t b) (t b)+    changeNode nf	= arr (T.changeNode nf)++								-- compound arrows++    -- | apply an arrow element wise to all children of the root of a tree+    -- collect these results and substitute the children with this result+    --+    -- example: @ processChildren isText @ deletes all subtrees, for which isText does not hold+    --+    -- example: @ processChildren (none \`when\` isCmt) @ removes all children, for which isCmt holds++    processChildren	:: Tree t => a (t b) (t b) -> a (t b) (t b)+    processChildren f	= arr T.getNode+			  &&&+			  listA (arrL T.getChildren >>> f)	-- new children, deterministic filter: single element result+			  >>>+			  arr2 T.mkTree++    -- | similar to processChildren, but the new children are computed by processing+    -- the whole input tree+    --+    -- example: @ replaceChildren (deep isText) @ selects all subtrees for which isText holds+    -- and substitutes the children component of the root node with this list++    replaceChildren	:: Tree t => a (t b) (t b) -> a (t b) (t b)+    replaceChildren f	= arr T.getNode+			  &&&+			  listA f				-- compute new children+			  >>>+			  arr2 T.mkTree++    -- |+    -- pronounced \"slash\", meaning g inside f+    --+    -- defined as @ f \/> g = f >>> getChildren >>> g @+    --+    -- example: @ hasName \"html\" \/> hasName \"body\" \/> hasName \"h1\" @+    --+    -- This expression selects+    -- all \"h1\" elements in the \"body\" element of an \"html\" element, an expression, that+    -- corresponds 1-1 to the XPath selection path \"html\/body\/h1\" ++    (/>)		:: Tree t => a b (t c) -> a (t c) d -> a b d+    f /> g		= f >>> getChildren >>> g++    -- |+    -- pronounced \"double slash\", meaning g arbitrarily deep inside f+    --+    -- defined as @ f \/\/> g = f >>> getChildren >>> deep g @+    --+    -- example: @ hasName \"html\" \/\/> hasName \"table\" @+    --+    -- This expression selects+    -- all top level \"table\" elements within an \"html\" element, an expression.+    -- Attantion: This does not correspond+    -- to the XPath selection path \"html\/\/table\". The latter on matches all table elements+    -- even nested ones, but @\/\/>@ gives in many cases the appropriate functionality.++    (//>)		:: Tree t => a b (t c) -> a (t c) d -> a b d+    f //> g		= f >>> getChildren >>> deep g+++    -- |+    -- pronounced \"outside\" meaning f containing g+    --+    -- defined as @ f \<\/ g = f \`containing\` (getChildren >>> g) @++    (</)		:: Tree t => a (t b) (t b) -> a (t b) (t b) -> a (t b) (t b)+    f </ g		= f `containing` (getChildren >>> g)+++    -- | recursively searches a whole tree for subtrees, for which a predicate holds.+    -- The search is performed top down. When a tree is found, this becomes an element of the result+    -- list. The tree found is not further examined for any subtress, for which the predicate also could hold.+    -- See 'multi' for this kind of search.+    --+    -- example: @ deep isHtmlTable @ selects all top level table elements in a document+    -- (with an appropriate definition for isHtmlTable) but no tables occuring within a table cell.++    deep		:: Tree t => a (t b) c -> a (t b) c+    deep f		= f					-- success when applying f+			  `orElse`+			  (getChildren >>> deep f)		-- seach children+++    -- | recursively searches a whole tree for subrees, for which a predicate holds.+    -- The search is performed bottom up.+    --+    -- example: @ deepest isHtmlTable @ selects all innermost table elements in a document+    -- but no table elements containing tables. See 'deep' and 'multi' for other search strategies.++    deepest		:: Tree t => a (t b) c -> a (t b) c+    deepest f		= (getChildren >>> deepest f)		-- seach children+			  `orElse`+			  f					-- no success: apply f to root+++    -- | recursively searches a whole tree for subtrees, for which a predicate holds.+    -- The search is performed top down. All nodes of the tree are searched, even within the+    -- subtrees of trees for which the predicate holds.+    --+    -- example: @ multy isHtmlTable @ selects all table elements, even nested ones.++    multi		:: Tree t => a (t b) c -> a (t b) c+    multi f		= f					-- combine result for root+			  <+>+			  (getChildren >>> multi f)		-- with result for all descendants++    -- | recursively transforms a whole tree by applying an arrow to all subtrees,+    -- this is done bottom up depth first, leaves first, root as last tree+    --+    -- example: @ processBottomUp (getChildren \`when\` isHtmlFont) @ removes all font tags in a HTML document, even nested ones+    -- (with an appropriate definition of isHtmlFont)++    processBottomUp	:: Tree t => a (t b) (t b) -> a (t b) (t b)+    processBottomUp f	= processChildren (processBottomUp f)	-- process all descendants first+			  >>>+			  f					-- then process root++    -- | similar to 'processBottomUp', but recursively transforms a whole tree by applying an arrow to all subtrees+    -- with a top down depth first traversal strategie. In many cases 'processBottomUp' and 'processTopDown'+    -- give same results.++    processTopDown	:: Tree t => a (t b) (t b) -> a (t b) (t b)+    processTopDown f	= f					-- first process root+			  >>>+			  processChildren (processTopDown f)	-- then process all descendants of new root+++    -- | recursively transforms a whole tree by applying an arrow to all subtrees,+    -- but transformation stops when a predicte does not hold for a subtree,+    -- leaves are transformed first++    processBottomUpWhenNot+			:: Tree t => a (t b) (t b) -> a (t b) (t b) -> a (t b) (t b)+    processBottomUpWhenNot f p+			= ( processChildren (processBottomUpWhenNot f p)+			    >>>+			    f+			  ) `whenNot` p++    -- | recursively transforms a whole tree by applying an arrow to all subtrees,+    -- but transformation stops when a tree is successfully transformed.+    -- the transformation is done top down+    --+    -- example: @ processTopDownUntil (isHtmlTable \`guards\` tranformTable) @+    -- transforms all top level table elements into something else, but inner tables remain unchanged++    processTopDownUntil	:: Tree t => a (t b) (t b) -> a (t b) (t b)+    processTopDownUntil f+			= f+			  `orElse`+			  processChildren (processTopDownUntil f)++    -- | computes a list of trees by applying an arrow to the input+    -- and inserts this list in front of index i in the list of children+    --+    -- example: @ insertChildrenAt 0 (deep isCmt) @ selects all subtrees for which isCmt holds+    -- and copies theses in front of the existing children++    insertChildrenAt	:: Tree t =>           Int -> a (t b) (t b) -> a (t b) (t b)+    insertChildrenAt i f+			= listA f &&& this >>> arr2 insertAt+			  where+			  insertAt newcs+			      = T.changeChildren (\ cs -> let+						          (cs1, cs2) = splitAt i cs+						          in+						          cs1 ++ newcs ++ cs2+						 )++    -- | similar to 'insertChildrenAt', but the insertion position is searched with a predicate++    insertChildrenAfter	:: Tree t => a (t b) (t b) -> a (t b) (t b) -> a (t b) (t b)+    insertChildrenAfter p f+			= replaceChildren+			  ( ( ( listA getChildren+				>>>+				spanA p+			      )+			      &&&+			      listA f+			    )+			    >>> arr2L (\ (xs1, xs2) xs -> xs1 ++ xs ++ xs2)+			  )+			  +    -- | an arrow for inserting a whole subtree with some holes in it (a template)+    -- into a document. The holes can be filled with contents from the input.+    --+    -- Example+    --+    -- > insertTreeTemplateTest	:: ArrowXml a => a b XmlTree+    -- > insertTreeTemplateTest+    -- >     = doc+    -- >       >>>+    -- >       insertTemplate template pattern+    -- >     where+    -- >     doc								-- the input data+    -- > 	= constA "<x><y>The Title</y><z>The content</z></x>"+    -- > 	  >>> xread+    -- >     template								-- the output template with 2 holes: xxx and yyy+    -- > 	= constA "<html><head><title>xxx</title></head><body><h1>yyy</h1></body></html>"+    -- > 	  >>> xread+    -- >     pattern+    -- > 	= [ hasText (== "xxx")						-- fill the xxx hole with the input contents from element "x/y"+    -- > 	    :-> ( getChildren >>> hasName "y" >>> deep isText )+    -- > +    -- > 	  , hasText (== "yyy")						-- fill the yyy hole with the input contents from element "x/z"+    -- > 	    :-> ( getChildren >>> hasName "z" >>> getChildren )+    -- > 	  ]+    --+    -- computes the XML tree for the following document+    --+    -- > "<html><head><title>The Title</title></head><body><h1>The content</h1></body></html>"++    insertTreeTemplate	:: Tree t =>+			   a (t b) (t b) ->					-- the the template+			   [IfThen (a (t b) c) (a (t b) (t b))] ->		-- the list of nodes in the template to be substituted+			   a (t b) (t b)+    insertTreeTemplate template choices+	= insertTree $< this+	  where+	  insertTree t+	      = template					-- swap input and template+		>>>+		processTemplate+	      where+	      processTemplate+		  = choiceA choices'				-- check whether node is a "hole" within the template+		    `orElse`+		    processChildren processTemplate		-- else descent into template tree+	      choices'+		  = map feedTree choices			-- modify choices, such that the input is feed into the action arrows+	      feedTree (cond :-> action)+		  = cond :-> (constA t >>> action)		-- the real input becomes the input at the holes
+ src/Yuuko/Control/Arrow/IOListArrow.hs view
@@ -0,0 +1,132 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Control.Arrow.IOListArrow+   Copyright  : Copyright (C) 2005 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   Implementation of pure list arrows with IO++-}++-- ------------------------------------------------------------++module Yuuko.Control.Arrow.IOListArrow+    ( IOLA(..)+    )+where+import Prelude hiding (id, (.))++import Control.Category++import           Control.Arrow+import           Yuuko.Control.Arrow.ArrowIf+import           Yuuko.Control.Arrow.ArrowList+import           Yuuko.Control.Arrow.ArrowNF+import           Yuuko.Control.Arrow.ArrowTree+import           Yuuko.Control.Arrow.ArrowIO++import           Control.DeepSeq++-- ------------------------------------------------------------++-- | list arrow combined with IO monad++newtype IOLA a b = IOLA { runIOLA :: a -> IO [b] }++instance Category IOLA where+    id                  = IOLA $ return . (:[])++    IOLA g . IOLA f	= IOLA $ \ x -> do+					ys <- f x+					zs <- sequence . map g $ ys+					return (concat zs)++instance Arrow IOLA where+    arr f		= IOLA $ \ x -> return [f x]++    first (IOLA f)	= IOLA $ \ ~(x1, x2) -> do+					        ys1 <- f x1+					        return [ (y1, x2) | y1 <- ys1 ]++    -- just for efficiency+    second (IOLA g)	= IOLA $ \ ~(x1, x2) -> do+					        ys2 <- g x2+					        return [ (x1, y2) | y2 <- ys2 ]++    -- just for efficiency+    IOLA f *** IOLA g	= IOLA $ \ ~(x1, x2) -> do+						ys1 <- f x1+					        ys2 <- g x2+					        return [ (y1, y2) | y1 <- ys1, y2 <- ys2 ]++    -- just for efficiency+    IOLA f &&& IOLA g	= IOLA $ \ x -> do+					ys1 <- f x+					ys2 <- g x+					return [ (y1, y2) | y1 <- ys1, y2 <- ys2 ]+++instance ArrowZero IOLA where+    zeroArrow		= IOLA $ const (return [])+++instance ArrowPlus IOLA where+    IOLA f <+> IOLA g	= IOLA $ \ x -> do+					rs1 <- f x+					rs2 <- g x+					return (rs1 ++ rs2)+++instance ArrowChoice IOLA where+    left (IOLA f)	= IOLA $ either+			           (\ x -> f x >>= (\ y -> return (map Left y)))+                                   (return . (:[]) . Right)+    right (IOLA f)	= IOLA $ either+                                   (return . (:[]) . Left)+			           (\ x -> f x >>= (\ y -> return (map Right y)))++instance ArrowApply IOLA where+    app			= IOLA $ \ (IOLA f, x) -> f x++instance ArrowList IOLA where+    arrL f		= IOLA $ \ x -> return (f x)+    arr2A f		= IOLA $ \ ~(x, y) -> runIOLA (f x) y+    constA c		= IOLA $ const (return [c])+    isA p		= IOLA $ \x -> return (if p x then [x] else [])+    IOLA f >>. g	= IOLA $ \x -> do+				       ys <- f x+				       return (g ys)+++instance ArrowIf IOLA where+    ifA (IOLA p) ta ea	= IOLA $ \x -> do+				       res <- p x+				       runIOLA (if null res then ea else ta) x+    (IOLA f) `orElse` g+			= IOLA $ \x -> do+				       res <- f x+				       if null res then runIOLA g x else return res++instance ArrowIO IOLA where+    arrIO cmd		= IOLA $ \x -> do+			       	       res <- cmd x+				       return [res]++instance ArrowIOIf IOLA where+    isIOA p		= IOLA $ \x -> do+				       res <- p x+				       return (if res then [x] else [])++instance ArrowTree IOLA++instance ArrowNF IOLA where+    rnfA (IOLA f)	= IOLA $ \ x -> do+					res <- f x+					deepseq res $ return res++-- ------------------------------------------------------------
+ src/Yuuko/Control/Arrow/IOStateListArrow.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}++-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Control.Arrow.IOStateListArrow+   Copyright  : Copyright (C) 2005-8 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   Implementation of arrows with IO and a state++-}++-- ------------------------------------------------------------++module Yuuko.Control.Arrow.IOStateListArrow+    ( IOSLA(..)+    , liftSt+    , runSt+    )+where++import           Prelude hiding (id, (.))++import           Control.Category++import           Control.Arrow+import           Yuuko.Control.Arrow.ArrowIf+import           Yuuko.Control.Arrow.ArrowIO+import           Yuuko.Control.Arrow.ArrowList+import           Yuuko.Control.Arrow.ArrowNF+import           Yuuko.Control.Arrow.ArrowTree+import           Yuuko.Control.Arrow.ArrowState++import           Control.DeepSeq++-- ------------------------------------------------------------++-- | list arrow combined with a state and the IO monad++newtype IOSLA s a b = IOSLA { runIOSLA :: s -> a -> IO (s, [b]) }++instance Category (IOSLA s) where+    id                  = IOSLA $ \ s x -> return (s, [x])	-- don't defined id = arr id, this gives loops during optimization++    IOSLA g . IOSLA f	= IOSLA $ \ s x -> do+					   (s1, ys) <- f s x+					   sequence' s1 ys+					   where+					   sequence' s' []	 = return (s', [])+					   sequence' s' (x':xs') = do+								   (s1', ys') <- g s' x'+								   (s2', zs') <- sequence' s1' xs'+								   return (s2', ys' ++ zs')++instance Arrow (IOSLA s) where+    arr f		= IOSLA $ \ s x -> return (s, [f x])++    first (IOSLA f)	= IOSLA $ \ s (x1, x2) -> do+					           (s', ys1) <- f s x1+					           return (s', [ (y1, x2) | y1 <- ys1 ])++    -- just for efficiency+    second (IOSLA g)	= IOSLA $ \ s (x1, x2) -> do+					          (s', ys2) <- g s x2+					          return (s', [ (x1, y2) | y2 <- ys2 ])++    -- just for efficiency+    IOSLA f *** IOSLA g	= IOSLA $ \ s (x1, x2) -> do+						   (s1, ys1) <- f s  x1+					           (s2, ys2) <- g s1 x2+					           return (s2, [ (y1, y2) | y1 <- ys1, y2 <- ys2 ])++    -- just for efficiency+    IOSLA f &&& IOSLA g	= IOSLA $ \ s x -> do+					   (s1, ys1) <- f s  x+					   (s2, ys2) <- g s1 x+					   return (s2, [ (y1, y2) | y1 <- ys1, y2 <- ys2 ])++++instance ArrowZero (IOSLA s) where+    zeroArrow		= IOSLA $ \ s -> const (return (s, []))+++instance ArrowPlus (IOSLA s) where+    IOSLA f <+> IOSLA g	= IOSLA $ \ s x -> do+					   (s1, rs1) <- f s  x+					   (s2, rs2) <- g s1 x+					   return (s2, rs1 ++ rs2)++instance ArrowChoice (IOSLA s) where+    left (IOSLA f)	= IOSLA $ \ s -> either+			                 (\ x -> do+					         (s1, y) <- f s x+					         return (s1, map Left y)+					 )+                                         (\ x -> return (s, [Right x]))++    right (IOSLA f)	= IOSLA $ \ s -> either+                                         (\ x -> return (s, [Left x]))+			                 (\ x -> do+					         (s1, y) <- f s x+					         return (s1, map Right y)+					 )++instance ArrowApply (IOSLA s) where+    app			= IOSLA $ \ s (IOSLA f, x) -> f s x++instance ArrowList (IOSLA s) where+    arrL f		= IOSLA $ \ s x -> return (s, (f x))+    arr2A f		= IOSLA $ \ s (x, y) -> runIOSLA (f x) s y+    constA c		= IOSLA $ \ s   -> const (return (s, [c]))+    isA p		= IOSLA $ \ s x -> return (s, if p x then [x] else [])+    IOSLA f >>. g	= IOSLA $ \ s x -> do+				           (s1, ys) <- f s x+					   return (s1, g ys)+    -- just for efficency+    perform (IOSLA f)	= IOSLA $ \ s x -> do+					   (s1, _ys) <- f s x+					   return (s1, [x])++instance ArrowIf (IOSLA s) where+    ifA (IOSLA p) ta ea	= IOSLA $ \ s x -> do+				           (s1, res) <- p s x+					   runIOSLA ( if null res+						      then ea+						      else ta+						    ) s1 x++    (IOSLA f) `orElse` g+			= IOSLA $ \ s x -> do+				           r@(s1, res) <- f s x+					   if null res+					      then runIOSLA g s1 x+					      else return r+++instance ArrowIO (IOSLA s) where+    arrIO cmd		= IOSLA $ \ s x -> do+					   res <- cmd x+					   return (s, [res])++instance ArrowIOIf (IOSLA s) where+    isIOA p		= IOSLA $ \ s x -> do+					   res <- p x+					   return (s, if res then [x] else [])++instance ArrowState s (IOSLA s) where+    changeState cf	= IOSLA $ \ s x -> let s' = cf s x in return (seq s' s', [x])+    accessState	af	= IOSLA $ \ s x -> return (s, [af s x])++-- ------------------------------------------------------------++-- |+-- lift the state of an IOSLA arrow to a state with an additional component.+--+-- This is uesful, when running predefined IO arrows, e.g. for document input,+-- in a context with a more complex state component.++liftSt		:: IOSLA s1 b c -> IOSLA (s1, s2) b c+liftSt (IOSLA f)+    = IOSLA $ \ (s1, s2) x -> do+			      (s1', ys) <- f s1 x+			      return ((s1', s2), ys)+++-- |+-- run an arrow with augmented state in the context of a simple state arrow.+-- An initial value for the new state component is needed.+--+-- This is useful, when running an arrow with an extra environment component, e.g.+-- for namespace handling in XML.++runSt		:: s2 -> IOSLA (s1, s2) b c -> IOSLA s1 b c+runSt s2 (IOSLA f)+    = IOSLA $ \ s1 x -> do+			((s1', _s2'), ys) <- f (s1, s2) x+			return (s1', ys)++-- ------------------------------------------------------------++instance ArrowTree (IOSLA s)++instance (NFData s) => ArrowNF (IOSLA s) where+    rnfA (IOSLA f)	= IOSLA $ \ s x -> do+					   res <- f s x+					   deepseq res $ return res++-- ------------------------------------------------------------
+ src/Yuuko/Control/Arrow/ListArrow.hs view
@@ -0,0 +1,119 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Control.Arrow.ListArrow+   Copyright  : Copyright (C) 2005 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   Implementation of pure list arrows++-}++-- ------------------------------------------------------------++module Yuuko.Control.Arrow.ListArrow+    ( LA(..)+    , fromLA+    )+where++import           Prelude hiding (id, (.))++import           Control.Category++import           Control.Arrow+import           Yuuko.Control.Arrow.ArrowIf+import           Yuuko.Control.Arrow.ArrowList+import           Yuuko.Control.Arrow.ArrowNF+import           Yuuko.Control.Arrow.ArrowTree++import           Control.DeepSeq++import           Data.List ( partition )++-- ------------------------------------------------------------++-- | pure list arrow data type++newtype LA a b = LA { runLA :: a -> [b] }++instance Category LA where+    id                  = LA $ (:[])+    LA g . LA f		= LA $ concatMap g . f++instance Arrow LA where+    arr f		= LA $ \ x -> [f x]+    first (LA f)	= LA $ \ ~(x1, x2) -> [ (y1, x2) | y1 <- f x1 ]++    -- just for efficiency++    second (LA g)	= LA $ \ ~(x1, x2) -> [ (x1, y2) | y2 <- g x2 ]+    LA f *** LA g	= LA $ \ ~(x1, x2) -> [ (y1, y2) | y1 <- f x1, y2 <- g x2]+    LA f &&& LA g	= LA $ \ x         -> [ (y1, y2) | y1 <- f x , y2 <- g x ]++instance ArrowZero LA where+    zeroArrow		= LA $ const []+++instance ArrowPlus LA where+    LA f <+> LA g	= LA $ \ x -> f x ++ g x+++instance ArrowChoice LA where+    left  (LA f)	= LA $ either (map Left . f) ((:[]) . Right)+    right (LA f)	= LA $ either ((:[]) . Left) (map Right . f)+    LA f +++ LA g	= LA $ either (map Left . f) (map Right . g)+    LA f ||| LA g	= LA $ either f g+++instance ArrowApply LA where+    app			= LA $ \ (LA f, x) -> f x++instance ArrowList LA where+    arrL			= LA+    arr2A f		= LA $ \ ~(x, y) -> runLA (f x) y+    isA p		= LA $ \ x -> if p x then [x] else []+    LA f >>. g		= LA $ g . f+    withDefault	a d	= a >>. \ x -> if null x then [d] else x+++instance ArrowIf LA where+    ifA (LA p) t e	= LA $ \ x -> runLA ( if null (p x)+					      then e+					      else t+					    ) x++    (LA f) `orElse` (LA g)+			= LA $ \ x -> ( let+					res = f x+					in+					if null res+					then g x+					else res+				      )++    spanA p             = LA $ (:[]) . span (not . null . runLA p)++    partitionA	p	= LA $ (:[]) . partition (not . null . runLA p)++instance ArrowTree LA++instance ArrowNF LA where+    rnfA (LA f)		= LA $ \ x -> let res = f x+                                      in+                                      deepseq res res++-- ------------------------------------------------------------++-- | conversion of pure list arrows into other possibly more complex+-- list arrows++fromLA		:: ArrowList a => LA b c -> a b c+fromLA f	=  arrL (runLA f)++-- ------------------------------------------------------------+
+ src/Yuuko/Control/Arrow/ListArrows.hs view
@@ -0,0 +1,47 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Control.Arrow.ListArrows+   Copyright  : Copyright (C) 2005 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)+   Stability  : experimental+   Portability: portable++Module for importing all list arrows++-}++-- ------------------------------------------------------------++module Yuuko.Control.Arrow.ListArrows+    ( module Control.Arrow			-- arrow classes+    , module Yuuko.Control.Arrow.ArrowList+    , module Yuuko.Control.Arrow.ArrowIf+    , module Yuuko.Control.Arrow.ArrowNF+    , module Yuuko.Control.Arrow.ArrowState+    , module Yuuko.Control.Arrow.ArrowTree+    , module Yuuko.Control.Arrow.ArrowIO++    , module Yuuko.Control.Arrow.ListArrow		-- arrow types+    , module Yuuko.Control.Arrow.StateListArrow+    , module Yuuko.Control.Arrow.IOListArrow+    , module Yuuko.Control.Arrow.IOStateListArrow+    )+where++import Control.Arrow				-- arrow classes+import Yuuko.Control.Arrow.ArrowList+import Yuuko.Control.Arrow.ArrowIf+import Yuuko.Control.Arrow.ArrowNF+import Yuuko.Control.Arrow.ArrowState+import Yuuko.Control.Arrow.ArrowTree+import Yuuko.Control.Arrow.ArrowIO++import Yuuko.Control.Arrow.ListArrow			-- arrow types+import Yuuko.Control.Arrow.StateListArrow+import Yuuko.Control.Arrow.IOListArrow+import Yuuko.Control.Arrow.IOStateListArrow++-- ------------------------------------------------------------
+ src/Yuuko/Control/Arrow/StateListArrow.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}++-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Control.Arrow.StateListArrow+   Copyright  : Copyright (C) 2005-8 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   Implementation of list arrows with a state++-}++-- ------------------------------------------------------------++module Yuuko.Control.Arrow.StateListArrow+    ( SLA(..)+    , fromSLA+    )+where++import           Prelude hiding (id, (.))++import           Control.Category++import           Control.Arrow+import           Yuuko.Control.Arrow.ArrowIf+import           Yuuko.Control.Arrow.ArrowList+import           Yuuko.Control.Arrow.ArrowNF+import           Yuuko.Control.Arrow.ArrowState+import           Yuuko.Control.Arrow.ArrowTree++import           Control.DeepSeq++-- ------------------------------------------------------------++-- | list arrow combined with a state++newtype SLA s a b = SLA { runSLA :: s -> a -> (s, [b]) }++instance Category (SLA s) where+    id                  = SLA $ \ s x -> (s, [x])++    SLA g . SLA f	= SLA $ \ s x -> let+					 ~(s1, ys) = f s x+					 sequence' s' []+					     = (s', [])+					 sequence' s' (x':xs')+					     = let+					       ~(s1', ys') = g s' x'+					       ~(s2', zs') = sequence' s1' xs'+					       in+					       (s2', ys' ++ zs')+					 in+					 sequence' s1 ys+	                                 +instance Arrow (SLA s) where+    arr f		= SLA $ \ s x -> (s, [f x])++    first (SLA f)	= SLA $ \ s ~(x1, x2) -> let+						 ~(s', ys1) = f s x1+						 in+						 (s', [ (y1, x2) | y1 <- ys1 ])++    -- just for efficiency+    second (SLA g)	= SLA $ \ s ~(x1, x2) -> let+						 ~(s', ys2) = g s x2+						 in+						 (s', [ (x1, y2) | y2 <- ys2 ])++    -- just for efficiency+    SLA f *** SLA g	= SLA $ \ s ~(x1, x2) -> let+						 ~(s1, ys1) = f s  x1+						 ~(s2, ys2) = g s1 x2+						 in+						 (s2, [ (y1, y2) | y1 <- ys1, y2 <- ys2 ])++    -- just for efficiency+    SLA f &&& SLA g	= SLA $ \ s x -> let+					 ~(s1, ys1) = f s  x+					 ~(s2, ys2) = g s1 x+					 in+					 (s2, [ (y1, y2) | y1 <- ys1, y2 <- ys2 ])+++instance ArrowZero (SLA s) where+    zeroArrow		= SLA $ \ s -> const (s, [])+++instance ArrowPlus (SLA s) where+    SLA f <+> SLA g	= SLA $ \ s x -> let+					 ~(s1, rs1) = f s  x+					 ~(s2, rs2) = g s1 x+					 in+					 (s2, rs1 ++ rs2)++instance ArrowChoice (SLA s) where+    left (SLA f)	= SLA $ \ s -> let+			               lf x = (s1, map Left y)+					      where+					      ~(s1, y) = f s x+                                       rf x = (s, [Right x])+				       in+				       either lf rf++    right (SLA f)	= SLA $ \ s -> let+				       lf x = (s, [Left x])+			               rf x = (s1, map Right y)+					      where+					      ~(s1, y) = f s x+				       in+				       either lf rf+++instance ArrowApply (SLA s) where+    app			= SLA $ \ s (SLA f, x) -> f s x+++instance ArrowList (SLA s) where+    arrL f		= SLA $ \ s x -> (s, (f x))+    arr2A f		= SLA $ \ s ~(x, y) -> runSLA (f x) s y+    constA c		= SLA $ \ s   -> const (s, [c])+    isA p		= SLA $ \ s x -> (s, if p x then [x] else [])+    SLA f >>. g		= SLA $ \ s x -> let+				         ~(s1, ys) = f s x+					 in+					 (s1, g ys)+    -- just for efficency+    perform (SLA f)	= SLA $ \ s x -> let+					 ~(s1, _ys) = f s x+					 in+					 (s1, [x])++instance ArrowIf (SLA s) where+    ifA (SLA p) ta ea	= SLA $ \ s x -> let+				         ~(s1, res) = p s x+					 in+					 runSLA ( if null res+						  then ea+						  else ta+						) s1 x++    (SLA f) `orElse` g+			= SLA $ \ s x ->  let+				          r@(s1, res) = f s x+					  in+					  if null res+					  then runSLA g s1 x+					  else r+++instance ArrowState s (SLA s) where+    changeState cf	= SLA $ \ s x -> (cf s x, [x])+    accessState	af	= SLA $ \ s x -> (s, [af s x])++instance ArrowTree (SLA s)++instance (NFData s) => ArrowNF (SLA s) where+    rnfA (SLA f)	= SLA $ \ s x -> let res = f s x+                                         in+                                         deepseq res res++-- ------------------------------------------------------------++-- | conversion of state list arrows into arbitray other+-- list arrows.+--+-- allows running a state list arrow within another arrow:+--+-- example:+--+-- > ... >>> fromSLA 0 (... setState ... getState ... ) >>> ...+--+-- runs a state arrow with initial state 0 (e..g. an Int) within+-- another arrow sequence++fromSLA		:: ArrowList a => s -> SLA s b c -> a b c+fromSLA s f	=  arrL (snd . (runSLA f s))+++-- ------------------------------------------------------------
+ src/Yuuko/Data/AssocList.hs view
@@ -0,0 +1,61 @@+-- |+-- simple key value assocciation list+-- implemented as unordered list of pairs+--+-- Version : $Id: AssocList.hs,v 1.2 2005/05/27 13:15:23 hxml Exp $++module Yuuko.Data.AssocList+    ( module Yuuko.Data.AssocList+    )+where++import Data.Maybe++type AssocList k v = [(k, v)]++-- lookup 	= lookup from Prelude++-- | lookup with default value++lookupDef	:: Eq k => v -> k -> AssocList k v -> v+lookupDef d k	= fromMaybe d . lookup k++-- | lookup with empty list (empty string) as default value++lookup1		:: Eq k => k -> AssocList k [e] -> [e]+lookup1 k	= fromMaybe [] . lookup k++-- | test for existence of a key++hasEntry	:: Eq k => k -> AssocList k v -> Bool+hasEntry k	= isJust . lookup k++-- | add an entry, remove an existing entry before adding the new one at the top of the list, addEntry is strict++addEntry	:: Eq k => k -> v -> AssocList k v -> AssocList k v+addEntry k v l	= ( (k,v) : ) $! delEntry k l++ -- let l' = delEntry k l in seq l' ((k, v) : l')++-- | add a whole list of entries with 'addEntry'++addEntries	:: Eq k => AssocList k v -> AssocList k v -> AssocList k v+addEntries	= foldr (.) id . map (uncurry addEntry) . reverse++-- | delete an entry, delEntry is strict+delEntry	:: Eq k => k -> AssocList k v -> AssocList k v+delEntry _ []	= []+delEntry k (x@(k1,_) : rest)+    | k == k1	= rest+    | otherwise	= ( x : ) $! delEntry k rest++-- delEntry k	= filter ((/= k) . fst)++-- | delete a list of entries with 'delEntry'++delEntries	:: Eq k => [k] -> AssocList k v -> AssocList k v+delEntries	= foldl (.) id . map delEntry++-- -----------------------------------------------------------------------------++
+ src/Yuuko/Data/Atom.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Data.Atom+   Copyright  : Copyright (C) 2008 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)+   Stability  : experimental+   Portability: non-portable++   Unique Atoms generated from Strings and+   managed as flyweights++   Yuuko.Data.Atom can be used for caching and storage optimisation+   of frequently used strings. An @Atom@ is constructed from a @String@.+   For two equal strings the identical atom is returned.++   This module can be used for optimizing memory usage when working with+   strings or names. Many applications use data types like+   @Map String SomeAttribute@ where a rather fixed set of keys is used.+   Especially XML applications often work with a limited set of element and attribute names.+   For these applications it becomes more memory efficient when working with types like+   @Map Atom SomeAttribute@ and convert the keys into atoms before operating+   on such a map.++   Internally this module manages a map of atoms. The atoms are internally represented+   by @ByteString@s. When creating a new atom from a string, the string is first converted+   into an UTF8 @Word8@ sequence, which is packed into a @ByteString@. This @ByteString@ is looked+   up in the table of atoms. If it is already there, the value in the map is used as atom, else+   the new @ByteString@ is inserted into the map.++   Of course the implementation of this name cache uses @unsavePerformIO@ and @MVar@s+   for managing this kind of global state.++   The following laws hold for atoms++   >+   > s  ==       t => newAtom s  ==       newAtom t+   > s `compare` t => newAtom s `compare` newAtom t+   > show . newAtom == id++   Equality test for @Atom@s runs in /O(1)/, it is just a pointer comarison.+   The @Ord@ comparisons have the same runtime like the @ByteString@ comparisons.+   Internally there is an UTF8 comparison, but UTF8 encoding preserves the total order.++   Warning: The internal cache never shrinks during execution. So using it in a+   undisciplined way can lead to memory leaks.+-}++-----------------------------------------------------------------------------++module Yuuko.Data.Atom (+   -- * Atom objects+   Atom,		-- instance (Eq, Ord, Read, Show)+   newAtom, 		-- :: String -> Atom+   share		-- :: String -> String+ ) where++import           Control.Concurrent.MVar+import           Control.DeepSeq++import           Data.ByteString.Internal       ( toForeignPtr, c2w, w2c )+import           Data.ByteString                ( ByteString, pack, unpack )+import qualified Data.Map                 as M+import           Data.Typeable++import           System.IO.Unsafe               ( unsafePerformIO )++import           Yuuko.Text.XML.HXT.DOM.Unicode	( unicodeToUtf8 )+import           Yuuko.Text.XML.HXT.DOM.UTF8Decoding	( decodeUtf8 )++-- ------------------------------------------------------------++type Atoms	= M.Map ByteString ByteString++newtype Atom	= A { bs :: ByteString }+                  deriving (Typeable)++-- ------------------------------------------------------------++-- | the internal cache for the strings++theAtoms	:: MVar Atoms+theAtoms	= unsafePerformIO (newMVar M.empty)+{-# NOINLINE theAtoms #-}++-- | insert a bytestring into the atom cache++insertAtom	:: ByteString -> Atoms -> (Atoms, Atom)+insertAtom s m	= maybe (M.insert s s m, A s)+                        (\ s' -> (m, A s'))+		  .+		  M.lookup s $ m++-- | creation of an @Atom@ from a @String@++newAtom		:: String -> Atom+newAtom		= unsafePerformIO . newAtom'+{-# NOINLINE newAtom #-}++-- | The internal operation running in the IO monad+newAtom'	:: String -> IO Atom+newAtom' s	= do+		  m <- takeMVar theAtoms+		  let (m', a) = insertAtom (pack. map c2w . unicodeToUtf8 $ s) m+		  putMVar theAtoms m'+		  return a++-- | Insert a @String@ into the atom cache and convert the atom back into a @String@.+--+-- locically @share == id@ holds, but internally equal strings share the same memory.++share		:: String -> String+share		= show . newAtom++instance Eq Atom where+    a1 == a2	= fp1 == fp2+	          where+		  (fp1, _, _) = toForeignPtr . bs $ a1+		  (fp2, _, _) = toForeignPtr . bs $ a2++instance Ord Atom where+    compare a1 a2+	        | a1 == a2	= EQ+		| otherwise     = compare (bs a1) (bs a2)++instance Read Atom where+    readsPrec p str = [ (newAtom x, y) | (x, y) <- readsPrec p str ]++instance Show Atom where+    show	= fst . decodeUtf8 . map w2c . unpack . bs+    -- show	= show . toForeignPtr . bs			-- for debug only++instance NFData Atom where++-----------------------------------------------------------------------------
+ src/Yuuko/Data/Char/UTF8.hs view
@@ -0,0 +1,363 @@+{-++Copyright (c) 2002, members of the Haskell Internationalisation Working+Group All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice,+   this list of conditions and the following disclaimer.+* 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.+* Neither the name of the Haskell Internationalisation Working Group nor+   the names of its contributors may be used to endorse or promote products+   derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 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 COPYRIGHT OWNER 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.++This module provides lazy stream encoding/decoding facilities for UTF-8,+the Unicode Transformation Format with 8-bit words.++2002-09-02  Sven Moritz Hallberg <pesco@gmx.de>++-}++{-++2007-04-30 Henning Thielemann:+Slight changes to make decode lazy.+The calls of 'reverse' in the original version have broken laziness+and thus had memory leaks.++-}++module Yuuko.Data.Char.UTF8+  ( encode, decode,+    decodeEmbedErrors,+    encodeOne, decodeOne,+    Error, -- Haddock does not want to document signatures with private types+    -- these functions should be moved to a utility module+  ) where++import Data.Char (ord, chr)+import Data.Word (Word8, Word16, Word32)+import Data.Bits (Bits, shiftL, shiftR, (.&.), (.|.))++import Data.List (unfoldr)++import Yuuko.Text.XML.HXT.DOM.Util (partitionEither, swap, toMaybe)++++-- - UTF-8 in General -++-- Adapted from the Unicode standard, version 3.2,+-- Table 3.1 "UTF-8 Bit Distribution" (excluded are UTF-16 encodings):++--   Scalar                    1st Byte  2nd Byte  3rd Byte  4th Byte+--           000000000xxxxxxx  0xxxxxxx+--           00000yyyyyxxxxxx  110yyyyy  10xxxxxx+--           zzzzyyyyyyxxxxxx  1110zzzz  10yyyyyy  10xxxxxx+--   000uuuzzzzzzyyyyyyxxxxxx  11110uuu  10zzzzzz  10yyyyyy  10xxxxxx++-- Also from the Unicode standard, version 3.2,+-- Table 3.1B "Legal UTF-8 Byte Sequences":++--   Code Points         1st Byte  2nd Byte  3rd Byte  4th Byte+--     U+0000..U+007F    00..7F+--     U+0080..U+07FF    C2..DF    80..BF+--     U+0800..U+0FFF    E0        A0..BF    80..BF+--     U+1000..U+CFFF    E1..EC    80..BF    80..BF+--     U+D000..U+D7FF    ED        80..9F    80..BF+--     U+D800..U+DFFF    ill-formed+--     U+E000..U+FFFF    EE..EF    80..BF    80..BF+--    U+10000..U+3FFFF   F0        90..BF    80..BF    80..BF+--    U+40000..U+FFFFF   F1..F3    80..BF    80..BF    80..BF+--   U+100000..U+10FFFF  F4        80..8F    80..BF    80..BF++++-- - Encoding Functions -++-- Must the encoder ensure that no illegal byte sequences are output or+-- can we trust the Haskell system to supply only legal values?+-- For now I include error case for the surrogate values U+D800..U+DFFF and+-- out-of-range scalars.++-- The function is pretty much a transscript of table 3.1B with error checks.+-- It dispatches the actual encoding to functions specific to the number of+-- required bytes.++encodeOne :: Char -> [Word8]+encodeOne c+    -- The report guarantees in (6.1.2) that this won't happen:+    --   | n < 0       = error "encodeUTF8: ord returned a negative value"+    | n < 0x0080  = encodeOne_onebyte n8+    | n < 0x0800  = encodeOne_twobyte n16+    | n < 0xD800  = encodeOne_threebyte n16+    | n < 0xE000  = error "encodeUTF8: ord returned a surrogate value"+    | n < 0x10000       = encodeOne_threebyte n16+    -- Haskell 98 only talks about 16 bit characters, but ghc handles 20.1.+    | n < 0x10FFFF      = encodeOne_fourbyte n32+    | otherwise  = error "encodeUTF8: ord returned a value above 0x10FFFF"+    where+    n = ord c            :: Int+    n8 = fromIntegral n  :: Word8+    n16 = fromIntegral n :: Word16+    n32 = fromIntegral n :: Word32+++-- With the above, a stream decoder is trivial:++encode :: [Char] -> [Word8]+encode = concatMap encodeOne+++-- Now follow the individual encoders for certain numbers of bytes...+--           _+--          / |  __  ___  __ __+--         / ^| //  /__/ // //+--        /.==| \\ //_  // //+-- It's  //  || // \_/_//_//_  and it's here to stay!++encodeOne_onebyte :: Word8 -> [Word8]+encodeOne_onebyte cp = [cp]+++-- 00000yyyyyxxxxxx -> 110yyyyy 10xxxxxx++encodeOne_twobyte :: Word16 -> [Word8]+encodeOne_twobyte cp = [(0xC0.|.ys), (0x80.|.xs)]+    where+    xs, ys :: Word8+    ys = fromIntegral (shiftR cp 6)+    xs = (fromIntegral cp) .&. 0x3F+++-- zzzzyyyyyyxxxxxx -> 1110zzzz 10yyyyyy 10xxxxxx++encodeOne_threebyte :: Word16 -> [Word8]+encodeOne_threebyte cp = [(0xE0.|.zs), (0x80.|.ys), (0x80.|.xs)]+    where+    xs, ys, zs :: Word8+    xs = (fromIntegral cp) .&. 0x3F+    ys = (fromIntegral (shiftR cp 6)) .&. 0x3F+    zs = fromIntegral (shiftR cp 12)+++-- 000uuuzzzzzzyyyyyyxxxxxx -> 11110uuu 10zzzzzz 10yyyyyy 10xxxxxx++encodeOne_fourbyte :: Word32 -> [Word8]+encodeOne_fourbyte cp = [0xF0.|.us, 0x80.|.zs, 0x80.|.ys, 0x80.|.xs]+    where+    xs, ys, zs, us :: Word8+    xs = (fromIntegral cp) .&. 0x3F+    ys = (fromIntegral (shiftR cp 6)) .&. 0x3F+    zs = (fromIntegral (shiftR cp 12)) .&. 0x3F+    us = fromIntegral (shiftR cp 18)++++-- - Decoding -++-- The decoding is a bit more involved. The byte sequence could contain all+-- sorts of corruptions. The user must be able to either notice or ignore these+-- errors.++-- I will first look at the decoding of a single character. The process+-- consumes a certain number of bytes from the input. It returns the+-- remaining input and either an error and the index of its occurance in the+-- byte sequence or the decoded character.++data Error++-- The first byte in a sequence starts with either zero, two, three, or four+-- ones and one zero to indicate the length of the sequence. If it doesn't,+-- it is invalid. It is dropped and the next byte interpreted as the start+-- of a new sequence.++    = InvalidFirstByte++-- All bytes in the sequence except the first match the bit pattern 10xxxxxx.+-- If one doesn't, it is invalid. The sequence up to that point is dropped+-- and the "invalid" byte interpreted as the start of a new sequence. The error+-- includes the length of the partial sequence and the number of expected bytes.++    | InvalidLaterByte Int      -- the byte at relative index n was invalid++-- If a sequence ends prematurely, it has been truncated. It dropped and+-- decoding stops. The error reports the actual and expected lengths of the+-- sequence.++    | Truncated Int Int         -- only n of m expected bytes were present++-- Some sequences would represent code points which would be encoded as a+-- shorter sequence by a conformant encoder. Such non-shortest sequences are+-- considered erroneous and dropped. The error reports the actual and+-- expected number of bytes used.++    | NonShortest Int Int       -- n instead of m bytes were used++-- Unicode code points are in the range of [0..0x10FFFF]. Any values outside+-- of those bounds are simply invalid.++    | ValueOutOfBounds++-- There is no such thing as "surrogate pairs" any more in UTF-8. The+-- corresponding code points now form illegal byte sequences.++    | Surrogate+      deriving (Show, Eq)+++-- Second, third, and fourth bytes share the common requirement to start+-- with the bit sequence 10. So, here's the function to check that property.++first_bits_not_10 :: Word8 -> Bool+first_bits_not_10 b+    | (b.&.0xC0) /= 0x80  = True+    | otherwise           = False+++-- Erm, OK, the single-character decoding function's return type is a bit+-- longish. It is a tripel:++--  - The first component contains the decoded character or an error+--    if the byte sequence was erroneous.+--  - The second component contains the number of bytes that were consumed+--    from the input.+--  - The third component contains the remaining bytes of input.++decodeOne :: [Word8] -> (Either Error Char, Int, [Word8])+decodeOne bs@(b1:rest)+    | b1 < 0x80   = decodeOne_onebyte bs+    | b1 < 0xC0   = (Left InvalidFirstByte, 1, rest)+    | b1 < 0xE0   = decodeOne_twobyte bs+    | b1 < 0xF0   = decodeOne_threebyte bs+    | b1 < 0xF5   = decodeOne_fourbyte bs+    | otherwise   = (Left ValueOutOfBounds, 1, rest)+decodeOne [] = error "UTF8.decodeOne: No input"+++-- 0xxxxxxx -> 000000000xxxxxxx++decodeOne_onebyte :: [Word8] -> (Either Error Char, Int, [Word8])+decodeOne_onebyte (b:bs) = (Right (cpToChar b), 1, bs)+decodeOne_onebyte[] = error "UTF8.decodeOne_onebyte: No input (can't happen)"++cpToChar :: Integral a => a -> Char+cpToChar = chr . fromIntegral+++-- 110yyyyy 10xxxxxx -> 00000yyyyyxxxxxx++decodeOne_twobyte :: [Word8] -> (Either Error Char, Int, [Word8])+decodeOne_twobyte (_:[])+    = (Left (Truncated 1 2), 1, [])+decodeOne_twobyte (b1:b2:bs)+    | b1 < 0xC2            = (Left (NonShortest 2 1), 2, bs)+    | first_bits_not_10 b2 = (Left (InvalidLaterByte 1), 1, (b2:bs))+    | otherwise            = (Right (cpToChar result), 2, bs)+    where+    xs, ys, result :: Word32+    xs = fromIntegral (b2.&.0x3F)+    ys = fromIntegral (b1.&.0x1F)+    result = shiftL ys 6 .|. xs+decodeOne_twobyte[] = error "UTF8.decodeOne_twobyte: No input (can't happen)"+++-- 1110zzzz 10yyyyyy 10xxxxxx -> zzzzyyyyyyxxxxxx++decodeOne_threebyte :: [Word8] -> (Either Error Char, Int, [Word8])+decodeOne_threebyte (_:[])   = threebyte_truncated 1+decodeOne_threebyte (_:_:[]) = threebyte_truncated 2+decodeOne_threebyte bs@(b1:b2:b3:rest)+    | first_bits_not_10 b2+        = (Left (InvalidLaterByte 1), 1, drop 1 bs)+    | first_bits_not_10 b3+        = (Left (InvalidLaterByte 2), 2, drop 2 bs)+    | result < 0x0080+        = (Left (NonShortest 3 1), 3, rest)+    | result < 0x0800+        = (Left (NonShortest 3 2), 3, rest)+    | result >= 0xD800 && result < 0xE000+        = (Left Surrogate, 3, rest)+    | otherwise+        = (Right (cpToChar result), 3, rest)+    where+    xs, ys, zs, result :: Word32+    xs = fromIntegral (b3.&.0x3F)+    ys = fromIntegral (b2.&.0x3F)+    zs = fromIntegral (b1.&.0x0F)+    result = shiftL zs 12 .|. shiftL ys 6 .|. xs+decodeOne_threebyte[]+ = error "UTF8.decodeOne_threebyte: No input (can't happen)"++threebyte_truncated :: Int -> (Either Error Char, Int, [Word8])+threebyte_truncated n = (Left (Truncated n 3), n, [])+++-- 11110uuu 10zzzzzz 10yyyyyy 10xxxxxx -> 000uuuzzzzzzyyyyyyxxxxxx++decodeOne_fourbyte :: [Word8] -> (Either Error Char, Int, [Word8])+decodeOne_fourbyte (_:[])     = fourbyte_truncated 1+decodeOne_fourbyte (_:_:[])   = fourbyte_truncated 2+decodeOne_fourbyte (_:_:_:[]) = fourbyte_truncated 3+decodeOne_fourbyte bs@(b1:b2:b3:b4:rest)+    | first_bits_not_10 b2+        = (Left (InvalidLaterByte 1), 1, drop 1 bs)+    | first_bits_not_10 b3+        = (Left (InvalidLaterByte 2), 2, drop 2 bs)+    | first_bits_not_10 b4+        = (Left (InvalidLaterByte 3), 3, drop 3 bs)+    | result < 0x0080+        = (Left (NonShortest 4 1), 4, rest)+    | result < 0x0800+        = (Left (NonShortest 4 2), 4, rest)+    | result < 0x10000+        = (Left (NonShortest 4 3), 4, rest)+    | result > 0x10FFFF+        = (Left ValueOutOfBounds, 4, rest)+    | otherwise+        = (Right (cpToChar result), 4, rest)+    where+    xs, ys, zs, us, result :: Word32+    xs = fromIntegral (b4 .&. 0x3F)+    ys = fromIntegral (b3 .&. 0x3F)+    zs = fromIntegral (b2 .&. 0x3F)+    us = fromIntegral (b1 .&. 0x07)+    result = xs .|. shiftL ys 6 .|. shiftL zs 12 .|. shiftL us 18+decodeOne_fourbyte[]+ = error "UTF8.decodeOne_fourbyte: No input (can't happen)"++fourbyte_truncated :: Int -> (Either Error Char, Int, [Word8])+fourbyte_truncated n = (Left (Truncated n 4), n, [])+++-- The decoder examines all input, recording decoded characters as well as+-- error-index pairs along the way.++decode :: [Word8] -> ([Char], [(Error,Int)])+decode = swap . partitionEither . decodeEmbedErrors++decodeEmbedErrors :: [Word8] -> [Either (Error,Int) Char]+decodeEmbedErrors =+   unfoldr (\(pos,xs) ->+       toMaybe+          (not $ null xs)+          (let (c,n,rest) = decodeOne xs+           in  (either (\err -> Left (err,pos)) Right c,+                (pos+n,rest)))) .+   (,) 0
+ src/Yuuko/Data/NavTree.hs view
@@ -0,0 +1,116 @@+-- |+-- Navigable tree structure which allow a program to traverse+-- up the tree as well as down.+-- copied and modified from HXML (<http://www.flightlab.com/~joe/hxml/>)+--++module Yuuko.Data.NavTree+    ( module Yuuko.Data.NavTree+    , module Yuuko.Data.Tree.NTree.TypeDefs+    )+where++import Yuuko.Data.Tree.NTree.TypeDefs++-- -----------------------------------------------------------------------------++-- NavTree+--+-- | navigable tree with nodes of type node+--+-- a navigable tree consists of a n-ary tree for the current fragment tree,+-- a navigable tree for all ancestors, and two n-ary trees for+-- the previous- and following siblings++data NavTree a = NT+    (NTree a)		-- self+    [NavTree a]		-- ancestors+    [NTree a]		-- previous siblings (in reverse order)+    [NTree a]		-- following siblings+	deriving (Show, Eq, Ord)+++-- -----------------------------------------------------------------------------+++-- |+-- converts a n-ary tree in a navigable tree++ntree	:: NTree a -> NavTree a+ntree nd+    = NT nd [] [] []++-- |+-- converts a navigable tree in a n-ary tree++subtreeNT	:: NavTree a -> NTree a+subtreeNT (NT nd _ _ _)+    = nd+++-- |+-- function for selecting the value of the current fragment tree++dataNT	:: NavTree a -> a+dataNT (NT (NTree a _) _ _ _)+    = a+++-- -----------------------------------------------------------------------------++-- functions for traversing up, down, left and right in a navigable tree++upNT+ , downNT+ , leftNT+ , rightNT :: NavTree a -> Maybe (NavTree a)++upNT	  (NT _ (p:_) _ _)		= Just p+upNT	  (NT _ [] _ _) 		= Nothing+downNT	t@(NT (NTree _ (c:cs)) u _ _)	= Just (NT c (t:u) [] cs)+downNT 	  (NT (NTree _ []    ) _ _ _)	= Nothing+leftNT	  (NT s u (l:ls) r)		= Just (NT l u ls (s:r))+leftNT	  (NT _ _ []     _)		= Nothing+rightNT   (NT s u l (r:rs))		= Just (NT r u (s:l) rs)+rightNT   (NT _ _ _ []    ) 		= Nothing+++-- preorderNT t = t : concatMap preorderNT (children t)+-- where children = maybe [] (maybeStar rightNT) . downNT++preorderNT	:: NavTree a -> [NavTree a]+preorderNT+    = visit []+    where+    visit  k t = t : maybe k (visit' k) (downNT t)+    visit' k t = visit (maybe k (visit' k) (rightNT t)) t++revPreorderNT	:: NavTree a -> [NavTree a]+revPreorderNT t+    = t : concatMap revPreorderNT (reverse (children t))+      where+      children = maybe [] (maybeStar rightNT) . downNT++getChildrenNT	:: NavTree a -> [NavTree a]+getChildrenNT node+    = maybe [] follow (downNT node)+      where+      follow n = n : maybe [] follow (rightNT n)++-- -----------------------------------------------------------------------------+-- Miscellaneous useful combinators++-- |+-- Kleisli composition:++o' :: (Monad m) => (b -> m c) -> (a -> m b) -> (a -> m c)+f `o'` g = \x -> g x >>= f+++-- Some useful anamorphisms:++maybeStar, maybePlus :: (a -> Maybe a) -> a -> [a]+maybeStar f a = a : maybe [] (maybeStar f) (f a)+maybePlus f a =     maybe [] (maybeStar f) (f a)++-- -----------------------------------------------------------------------------
+ src/Yuuko/Data/Tree/Class.hs view
@@ -0,0 +1,92 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Data.Tree.Class+   Copyright  : Copyright (C) 2005 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   Interface definition for trees+-}++-- ------------------------------------------------------------++module Yuuko.Data.Tree.Class+    ( module Yuuko.Data.Tree.Class )+where++-- | The interface for trees++class Tree t where+    -- | tree construction: a new tree is constructed by a node attribute and a list of children+    mkTree		::              a -> [t a] -> t a++    -- | leaf construction: leafs don't have any children+    --+    -- definition: @ mkLeaf n = mkTree n [] @++    mkLeaf		::                       a -> t a+    mkLeaf n		= mkTree n []++    -- | leaf test: list of children empty?++    isLeaf		::		       t a -> Bool+    isLeaf		= null . getChildren++    -- | innner node test: @ not . isLeaf @++    isInner		::		       t a -> Bool+    isInner		= not . isLeaf++    -- | select node attribute++    getNode		::                     t a -> a++    -- | select children++    getChildren		::                     t a -> [t a]++    -- | edit node attribute++    changeNode		::         (a -> a) -> t a -> t a++    -- | edit children++    changeChildren	:: ([t a] -> [t a]) -> t a -> t a++    -- | substitute node: @ setNode n = changeNode (const n) @++    setNode		::                a -> t a -> t a+    setNode n		= changeNode (const n)++    -- | substitute children: @ setChildren cl = changeChildren (const cl) @++    setChildren		::            [t a] -> t a -> t a+    setChildren cl	= changeChildren (const cl)++    -- | fold for trees++    foldTree		::  (a -> [b] -> b) -> t a -> b++    -- | all nodes of a tree++    nodesTree		::		       t a -> [a]++    -- | depth of a tree++    depthTree		::		       t a -> Int++    -- | number of nodes in a tree++    cardTree		::                     t a -> Int++    -- | format tree for readable trace output+    --+    -- a /graphical/ representation of the tree in text format++    formatTree		::    (a -> String) -> t a -> String++-- ------------------------------------------------------------
+ src/Yuuko/Data/Tree/NTree/TypeDefs.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Data.Tree.NTree.TypeDefs+   Copyright  : Copyright (C) 2005-2008 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   Interface definition for trees++   n-ary tree structure (rose trees)++-}++-- ------------------------------------------------------------++module Yuuko.Data.Tree.NTree.TypeDefs+    ( module Yuuko.Data.Tree.Class+    , module Yuuko.Data.Tree.NTree.TypeDefs+    )+where++import Control.DeepSeq++import Yuuko.Data.Tree.Class+import Data.Typeable++-- | n-ary ordered tree (rose trees)+--+-- a tree consists of a node and a possible empty list of children.+-- If the list of children is empty, the node is a leaf, else it's+-- an inner node.+--+-- NTree implements Eq, Ord, Show and Read++data NTree  a	= NTree a (NTrees a)+    deriving+    (Eq, Ord, Show, Read, Typeable)++-- | shortcut for a sequence of n-ary trees++type NTrees   a	= [NTree a]++-- ------------------------------------------------------------++instance (NFData a) => NFData (NTree a) where+    rnf (NTree n cl)			= rnf n `seq` rnf cl++-- | NTree implements class Functor++instance Functor NTree where+    fmap f ~(NTree n cl)		= NTree (f n) (map (fmap f) cl)+++-- | Implementation of "Yuuko.Data.Tree.Class" interface for rose trees++instance Tree NTree where+    mkTree n cl				= NTree n cl++    getNode           ~(NTree n _ )	= n+    getChildren       ~(NTree _ cl)	= cl++    changeNode     cf ~(NTree n cl)	= NTree (cf n) cl+    changeChildren cf ~(NTree n cl)	= NTree n (cf cl)++    foldTree        f ~(NTree n cs)	= f n (map (foldTree f) cs)++    nodesTree		= foldTree (\ n rs -> n : concat rs)+    depthTree		= foldTree (\ _ rs -> 1 + maximum (0 : rs))+    cardTree		= foldTree (\ _ rs -> 1 + sum rs)+    formatTree nf n	= formatNTreeF nf (showString "---") (showString "   ") n ""++-- ------------------------------------------------------------+-- |+-- convert a tree into a pseudo graphical string reprsentation++formatNTreeF	:: (node -> String) -> (String -> String) -> (String -> String) -> NTree node -> String -> String++formatNTreeF node2String pf1 pf2 (NTree n l)+    = formatNode+      . formatChildren pf2 l+    where+    formatNode	= pf1 . foldr (.) id (map trNL (node2String n)) . showNL+    trNL '\n'	= showNL . pf2+    trNL c	= showChar c+    showNL	= showChar '\n'+    formatChildren _ []+	= id+    formatChildren pf (t:ts)+	| null ts+	    = pfl'+	      . formatTr pf2' t+	| otherwise+	    = pfl'+	      . formatTr pf1' t+	      . formatChildren pf ts+	where+	pf0'	= pf . showString indent1+	pf1'	= pf . showString indent2+	pf2'	= pf . showString indent3+	pfl'	= pf . showString indent4+	formatTr	= formatNTreeF node2String pf0'+	indent1 = "+---"+	indent2 = "|   "+	indent3 = "    "+	indent4 = "|\n"++-- eof ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/Arrow.hs view
@@ -0,0 +1,68 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.Arrow+   Copyright  : Copyright (C) 2006-2010 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : stable+   Portability: portable++   The HXT arrow interface++   The application programming interface to the arrow modules of the Haskell XML Toolbox.+   This module exports all important arrows for input, output, parsing, validating and transforming XML.+   It also exports all basic datatypes and functions of the toolbox.++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.Arrow+    ( module Yuuko.Control.Arrow.ListArrows++    , module Yuuko.Text.XML.HXT.DOM.Interface++    , module Yuuko.Text.XML.HXT.Arrow.XmlArrow+    , module Yuuko.Text.XML.HXT.Arrow.XmlIOStateArrow+    , module Yuuko.Text.XML.HXT.Arrow.XPath++    , module Yuuko.Text.XML.HXT.Arrow.DocumentInput+    , module Yuuko.Text.XML.HXT.Arrow.DocumentOutput+    , module Yuuko.Text.XML.HXT.Arrow.Edit+    , module Yuuko.Text.XML.HXT.Arrow.GeneralEntitySubstitution+    , module Yuuko.Text.XML.HXT.Arrow.Namespace+    , module Yuuko.Text.XML.HXT.Arrow.ProcessDocument+    , module Yuuko.Text.XML.HXT.Arrow.ReadDocument+    , module Yuuko.Text.XML.HXT.Arrow.WriteDocument+    , module Yuuko.Text.XML.HXT.Arrow.Pickle++    , module Yuuko.Text.XML.HXT.Version+    )+where++import Yuuko.Control.Arrow.ListArrows			-- arrow classes++import Yuuko.Data.Atom ()				-- import this explicitly++import Yuuko.Text.XML.HXT.DOM.Interface+import Yuuko.Text.XML.HXT.Arrow.DocumentInput+import Yuuko.Text.XML.HXT.Arrow.DocumentOutput+import Yuuko.Text.XML.HXT.Arrow.Edit+import Yuuko.Text.XML.HXT.Arrow.GeneralEntitySubstitution+import Yuuko.Text.XML.HXT.Arrow.Namespace+import Yuuko.Text.XML.HXT.Arrow.Pickle+import Yuuko.Text.XML.HXT.Arrow.ProcessDocument+import Yuuko.Text.XML.HXT.Arrow.ReadDocument+import Yuuko.Text.XML.HXT.Arrow.WriteDocument+import Yuuko.Text.XML.HXT.Arrow.XmlArrow+import Yuuko.Text.XML.HXT.Arrow.XmlIOStateArrow+import Yuuko.Text.XML.HXT.Arrow.XmlRegex ()		-- import this explicitly+import Yuuko.Text.XML.HXT.Arrow.XPath++import Yuuko.Text.XML.HXT.Arrow.XPathSimple ()	-- import this explicitly++import Yuuko.Text.XML.HXT.Version++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/Arrow/DTDProcessing.hs view
@@ -0,0 +1,513 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.Arrow.DTDProcessing+   Copyright  : Copyright (C) 2005 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable+   Version    : $Id: DTDProcessing.hs,v 1.9 2006/05/11 14:47:19 hxml Exp $++   DTD processing function for+   including external parts of a DTD+   parameter entity substitution and general entity substitution++   Implemtation completely done with arrows++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.Arrow.DTDProcessing+    ( processDTD+    )+where++import Control.Arrow				-- arrow classes+import Yuuko.Control.Arrow.ArrowList+import Yuuko.Control.Arrow.ArrowIf+import Yuuko.Control.Arrow.ArrowTree++import           Yuuko.Text.XML.HXT.DOM.Interface+import qualified Yuuko.Text.XML.HXT.DOM.XmlNode as XN++import Yuuko.Text.XML.HXT.Arrow.XmlArrow+import Yuuko.Text.XML.HXT.Arrow.XmlIOStateArrow++import Yuuko.Text.XML.HXT.Arrow.ParserInterface+    ( parseXmlDTDdecl+    , parseXmlDTDdeclPart+    , parseXmlDTDEntityValue+    , parseXmlDTDPart+    )++import Yuuko.Text.XML.HXT.Arrow.Edit+    ( transfCharRef+    )++import Yuuko.Text.XML.HXT.Arrow.DocumentInput+    ( getXmlEntityContents+    )++import Data.Maybe++import qualified Data.Map as M+    ( Map+    , empty+    , lookup+    , insert+    )++-- ------------------------------------------------------------+--++data DTDPart		= Internal+			| External+			  deriving (Eq)++type RecList		= [String]++type DTDStateArrow b c	= IOStateArrow PEEnv b c++-- ------------------------------------------------------------++newtype PEEnv		= PEEnv (M.Map String XmlTree)++emptyPeEnv	:: PEEnv+emptyPeEnv	= PEEnv M.empty++lookupPeEnv	:: String -> PEEnv -> Maybe XmlTree+lookupPeEnv k (PEEnv env)+    = M.lookup k env++addPeEntry	:: String -> XmlTree -> PEEnv -> PEEnv+addPeEntry k a (PEEnv env)+    = PEEnv $ M.insert k a env++getPeValue	:: DTDStateArrow String XmlTree+getPeValue+    = (this &&& getUserState)+      >>>+      arrL (\ (n, env) -> maybeToList . lookupPeEnv n $ env)++addPe		:: String -> DTDStateArrow XmlTree XmlTree+addPe n+    = traceMsg 2 ("substParamEntity: add entity " ++ show n ++ " to env")+      >>>+      changeUserState ins+    where+    ins t peEnv = addPeEntry n t peEnv++-- ------------------------------------------------------------++-- |+-- a filter for DTD processing+--+-- inclusion of external parts of DTD,+-- parameter entity substitution+-- conditional section evaluation+--+-- input tree must represent a complete document including root node++processDTD		:: IOStateArrow s XmlTree XmlTree+processDTD+    = runInLocalURIContext+         ( processRoot+	   >>>+	   traceTree+	   >>>+	   traceSource+	 )+      `when` ( isRoot >>> getChildren )+      where++      processRoot	:: IOStateArrow s XmlTree XmlTree+      processRoot+	  = ( traceMsg 1 ("processDTD: process parameter entities")+	      >>>+	      setParamString a_standalone ""+	      >>>+	      ( addDocType+		`whenNot`+		( getChildren >>> isDTDDoctype )+	      )+	      >>>+	      processChildren substParamEntities+	      >>>+	      setDocumentStatusFromSystemState "in XML DTD processing"+	    )+            `when`+	    documentStatusOk+	  where+	  addDocType+	      = replaceChildren ( (getChildren >>> isXmlPi)+				  <+>+				  mkDTDDoctype [] none+				  <+>+				  (getChildren >>> neg isXmlPi)+				)++substParamEntities	:: IOStateArrow s XmlTree XmlTree+substParamEntities+    = withOtherUserState emptyPeEnv processParamEntities+      `when`+      isDTDDoctype+      where++      processParamEntities	:: DTDStateArrow XmlTree XmlTree+      processParamEntities+	  = mergeEntities $<<< ( listA processPredef+				 &&&+				 listA processInt+				 &&&+				 listA (runInLocalURIContext processExt)+			       )+	  where+	  mergeEntities dtdPre dtdInt dtdExt+	      =  replaceChildren (arrL $ const $ foldl1 mergeDTDs [dtdPre, dtdInt, dtdExt])++	  processPredef+	      = predefDTDPart   >>> substParamEntity Internal []++	  processInt+	      = getChildren     >>> substParamEntity Internal []++	  processExt+	      = externalDTDPart >>> substParamEntity External []++	  mergeDTDs	:: XmlTrees -> XmlTrees -> XmlTrees+	  mergeDTDs dtdInt dtdExt+	      = dtdInt ++ (filter (filterDTDNodes dtdInt) dtdExt)++	  filterDTDNodes	:: XmlTrees -> XmlTree -> Bool+	  filterDTDNodes dtdPart t+	      = not (any (filterDTDNode t) dtdPart)++	  filterDTDNode	:: XmlTree -> XmlTree -> Bool++	  filterDTDNode	t1 t2+	      = fromMaybe False $+	        do+		dp1 <- XN.getDTDPart t1+		dp2 <- XN.getDTDPart t2+		al1 <- XN.getDTDAttrl t1+		al2 <- XN.getDTDAttrl t2+		return ( dp1 == dp2+			 &&+			 ( dp1 `elem` [ELEMENT, NOTATION, ENTITY, ATTLIST] )+			 &&+			 ( lookup a_name al1 == lookup a_name al2 )+			 &&+			 ( dp1 /= ATTLIST+			   ||+			   lookup a_value al1 == lookup a_value al2+			 )+		       )++substParamEntity	:: DTDPart -> RecList -> DTDStateArrow XmlTree XmlTree+substParamEntity loc recList+    = choiceA+      [ isDTDEntity	:-> ( traceDTD "ENTITY declaration before DTD declaration parsing"+			      >>>+			      processChildren (substPeRefsInDTDdecl recList)+			      >>>+			      parseXmlDTDdecl+			      >>>+			      substRefsInEntityValue+			      >>>+			      processEntityDecl+			      >>>+			      traceDTD "ENTITY declaration after DTD declaration parsing"+			    )+      , ( isDTDElement+	  <+>+	  isDTDAttlist+	  <+>+	  isDTDNotation+	)		:-> ( traceDTD "DTD declaration before PE substitution"+			      >>>+			      processChildren (substPeRefsInDTDdecl recList)+			      >>>+			      parseXmlDTDdecl+			      >>>+			      traceDTD "DTD declaration after DTD declaration parsing"+			    )+      , isDTDPERef	:-> substPeRefsInDTDpart recList++      , isDTDCondSect	:-> ( if loc == Internal+			      then issueErr "conditional sections in internal part of the DTD is not allowed"+			      else evalCondSect $< getDTDAttrValue a_value+			    )+      , isCmt		:-> none+      , this		:-> this+      ]+    where+    processEntityDecl		:: DTDStateArrow XmlTree XmlTree+    processEntityDecl+	= choiceA+	  [ isDTDEntity	:-> ( ifA (hasDTDAttr k_system)+			      processExternalEntity+			      processInternalEntity+			    )+	  , isDTDPEntity+			:-> ( processParamEntity $< getDTDAttrValue a_name )+	  , this	:-> none+	  ]+	where+	processExternalEntity	:: DTDStateArrow XmlTree XmlTree	-- processing external entities is delayed until first usage+	processExternalEntity						-- only the current base uri must be remembered+	    = setDTDAttrValue a_url $< ( getDTDAttrValue k_system >>> mkAbsURI )++	processInternalEntity	:: DTDStateArrow XmlTree XmlTree	-- just combine all parts of the entity value+	processInternalEntity						-- into one string+	    = replaceChildren (xshow getChildren >>> mkText)++	processParamEntity	:: String -> DTDStateArrow XmlTree XmlTree+	processParamEntity peName+	    = ifA (constA peName >>> getPeValue)+	      ( issueWarn ("parameter entity " ++ show peName ++ " already defined") )+	      ( ( ifA ( hasDTDAttr k_system )				-- is external param entity ?+		  ( runInLocalURIContext getExternalParamEntityValue )+		  ( replaceChildren (xshow getChildren >>> mkText) )	-- just combine all parts of the entity value into one string+		)+                >>>+                addPe peName+	      )++    substPERef			:: String -> DTDStateArrow XmlTree XmlTree+    substPERef pn+	= choiceA+	  [ isInternalRef	:-> issueErr ("a parameter entity reference of " ++ show pn ++ " occurs in the internal subset of the DTD")+	  , isUndefinedRef	:-> issueErr ("parameter entity " ++ show pn ++ " not found (forward reference?)")+	  , this		:-> substPE+	  ]+	  `when`+	  isDTDPERef+	where+	isInternalRef	= isA (const (loc == Internal))+	peVal		= constA pn >>> getPeValue+	isUndefinedRef	= neg peVal+	substPE+	    = replaceChildren (peVal >>> getChildren)			-- store PE value in children component+	      >>>+	      ( ( setBase $< (peVal >>> getDTDAttrValue a_url) )	-- store base uri for external refs+		`orElse`+		this+	      )+	    where+	    setBase uri	= setDTDAttrValue a_url uri++    substRefsInEntityValue	:: DTDStateArrow XmlTree XmlTree+    substRefsInEntityValue+	= ( ( processChildren ( transfCharRef+				>>>+				substPeRefsInValue []+			      )+	    )+	    `whenNot`+	    hasDTDAttr k_system						-- only apply for internal entities+	  )+	  `when` +	  ( isDTDEntity <+> isDTDPEntity )				-- only apply for entity declarations++    substPeRefsInDTDpart	:: RecList -> DTDStateArrow XmlTree XmlTree+    substPeRefsInDTDpart rl+	= recursionCheck "DTD part" rl subst+	where+	subst	:: RecList -> String -> DTDStateArrow XmlTree XmlTree+	subst recl pn+	    = substPERef pn+	      >>>+	      traceDTD "substPeRefsInDTDdecl: before parseXmlDTDPart"+	      >>>+	      ( runInPeContext ( getChildren+				 >>>+				 ( (constA ("parameter entity: " ++ pn)) &&& this )+				 >>>+				 parseXmlDTDPart+				 >>>+				 traceDTD "substPeRefsInDTDpart: after parseXmlDTDPart"+				 >>>+				 substParamEntity loc (pn : recl)+			       )+		`when`+		isDTDPERef+	      )++    substPeRefsInDTDdecl	:: RecList -> DTDStateArrow XmlTree XmlTree+    substPeRefsInDTDdecl rl+	= recursionCheck "DTD declaration" rl subst+	where+	subst	:: RecList -> String -> DTDStateArrow XmlTree XmlTree+	subst recl pn+	    = substPERef pn+	      >>>+	      traceDTD "substPeRefsInDTDdecl: before parseXmlDTDdeclPart"+	      >>>+	      ( runInPeContext ( parseXmlDTDdeclPart+				 >>>+				 traceDTD "substPeRefsInDTDdecl: after parseXmlDTDdeclPart"+				 >>>+				 processChildren ( substPeRefsInDTDdecl (pn : recl) )+			       )+		`when`+		isDTDPERef+	      )++    substPeRefsInValue		:: RecList -> DTDStateArrow XmlTree XmlTree+    substPeRefsInValue rl+	= recursionCheck "entity value" rl subst+	where+	subst	:: RecList -> String -> DTDStateArrow XmlTree XmlTree+	subst recl pn+	    = substPERef pn+	      >>>+	      parseXmlDTDEntityValue+	      >>>+	      transfCharRef+	      >>>+	      substPeRefsInValue (pn : recl)++    substPeRefsInCondSect	:: RecList -> DTDStateArrow XmlTree XmlTree+    substPeRefsInCondSect rl+	= recursionCheck "conditional section" rl subst+	where+	subst	:: RecList -> String -> DTDStateArrow XmlTree XmlTree+	subst recl pn+	    = substPERef pn+	      >>>+	      traceDTD "substPeRefsInCondSect: parseXmlDTDdeclPart"+	      >>>+	      runInPeContext ( parseXmlDTDdeclPart+			       >>>+			       traceDTD "substPeRefsInCondSect: after parseXmlDTDdeclPart"+			       >>>+			       processChildren ( substPeRefsInCondSect (pn : recl) )+			     )++    recursionCheck	:: String -> RecList -> (RecList -> String -> DTDStateArrow XmlTree XmlTree) -> DTDStateArrow XmlTree XmlTree+    recursionCheck wher rl subst+	= ( recusiveSubst  $< getDTDAttrValue a_peref )+	  `when`+	  isDTDPERef+	where+	recusiveSubst name+	    | name `elem` rl+		= issueErr ("recursive call of parameter entity " ++ show name ++ " in " ++ wher)+            | otherwise+		= subst rl name++    runInPeContext	:: DTDStateArrow XmlTree XmlTree -> DTDStateArrow XmlTree XmlTree+    runInPeContext f+	= ( runWithNewBase $< getDTDAttrValue a_url )+	  `orElse`+	  f+	where+	runWithNewBase base+	    = runInLocalURIContext+	      ( perform (constA base >>> setBaseURI)+		>>>+		f+	      )++    evalCondSect	:: String ->  DTDStateArrow XmlTree XmlTree+    evalCondSect content+	= traceDTD "evalCondSect: process conditional section"+	  >>>+	  processChildren (substPeRefsInCondSect [])+	  >>>+	  parseXmlDTDdecl+	  >>>+	  ( hasText (== k_include)+	    `guards`+	    ( ( constA "conditional section" &&& txt content )+	      >>>+	      parseXmlDTDPart+	      >>>+	      traceMsg 2 "evalCond: include DTD part"+	      >>>+	      substParamEntity External recList+	    )+	  )++predefDTDPart		:: DTDStateArrow XmlTree XmlTree+predefDTDPart+    = ( constA "predefined entities"+	&&&+	( constA predefinedEntities >>> mkText)+      )+      >>>+      parseXmlDTDPart+    where+    predefinedEntities	:: String+    predefinedEntities+	= concat [ "<!ENTITY lt   '&#38;#60;'>"+		 , "<!ENTITY gt   '&#62;'>"+		 , "<!ENTITY amp  '&#38;#38;'>"+		 , "<!ENTITY apos '&#39;'>"+		 , "<!ENTITY quot '&#34;'>"+		 ]++externalDTDPart		:: DTDStateArrow XmlTree XmlTree+externalDTDPart+    = isDTDDoctype+      `guards`+      ( hasDTDAttr k_system+	`guards`+	( getExternalDTDPart $< getDTDAttrValue k_system )+      )++getExternalDTDPart	:: String -> DTDStateArrow XmlTree XmlTree+getExternalDTDPart src+    = root [sattr a_source src] []+      >>>+      getXmlEntityContents+      >>>+      replaceChildren ( ( constA src &&& getChildren )+			>>>+			parseXmlDTDPart+		      )+      >>>+      traceDoc "processExternalDTD: parsing DTD part done"+      >>>+      getChildren++getExternalParamEntityValue	:: DTDStateArrow XmlTree XmlTree+getExternalParamEntityValue+    = isDTDPEntity+      `guards`+      ( setEntityValue $<<< ( getDTDAttrl+			      &&&+			      listA ( getEntityValue $< getDTDAttrl )+			      &&&+			      getBaseURI+			    )+      )+    where+    getEntityValue	:: Attributes -> DTDStateArrow XmlTree XmlTree+    getEntityValue al+	= root [sattr a_source (lookup1 k_system al){- <+> catA (map (uncurry sattr) al)-}] []+	  >>>+	  getXmlEntityContents+	  >>>+	  traceMsg 2 "getExternalParamEntityValue: contents read"+          >>>+	  getChildren++    setEntityValue	:: Attributes -> XmlTrees -> String -> DTDStateArrow XmlTree XmlTree+    setEntityValue al res base+	| null res+	    = issueErr ("illegal external parameter entity value for entity %" ++ peName ++";")+	| otherwise+	    = mkDTDElem PENTITY ((a_url, base) : al) (arrL $ const res)+	where+	peName = lookup1 a_name al++traceDTD	:: String -> DTDStateArrow XmlTree XmlTree+traceDTD msg	= traceMsg 3 msg >>> traceTree++-- ------------------------------------------------------------++
+ src/Yuuko/Text/XML/HXT/Arrow/DocumentInput.hs view
@@ -0,0 +1,414 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.Arrow.DocumentInput+   Copyright  : Copyright (C) 2005 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable+   Version    : $Id$++   State arrows for document input+-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.Arrow.DocumentInput+    ( getURIContents+    , getXmlContents+    , getXmlEntityContents+    , getEncoding+    , getTextEncoding+    , decodeDocument+    )+where++import Control.Arrow				-- arrow classes+import Yuuko.Control.Arrow.ArrowList+import Yuuko.Control.Arrow.ArrowIf+import Yuuko.Control.Arrow.ArrowTree+import Yuuko.Control.Arrow.ArrowIO+import Yuuko.Control.Arrow.ListArrow++import Data.List				( isPrefixOf )++import System.FilePath				( takeExtension )++import Yuuko.Text.XML.HXT.DOM.Unicode			( getDecodingFct+						, guessEncoding+						, normalizeNL+						)++import qualified Yuuko.Text.XML.HXT.IO.GetFILE	as FILE+import qualified Yuuko.Text.XML.HXT.IO.GetHTTPLibCurl	as LibCURL++import Yuuko.Text.XML.HXT.DOM.Interface++import Yuuko.Text.XML.HXT.Arrow.ParserInterface	( parseXmlDocEncodingSpec+						, parseXmlEntityEncodingSpec+						, removeEncodingSpec+						)+import Yuuko.Text.XML.HXT.Arrow.XmlArrow+import Yuuko.Text.XML.HXT.Arrow.XmlIOStateArrow++-- ----------------------------------------------------------++protocolHandlers	:: AssocList String (IOStateArrow s XmlTree XmlTree)+protocolHandlers+    = [ ("file",	getFileContents)+      , ("http",	getHttpContents)+      , ("stdin",	getStdinContents)+      ]++getProtocolHandler	:: IOStateArrow s String (IOStateArrow s XmlTree XmlTree)+getProtocolHandler+    = arr (\ s -> lookupDef getUnsupported s protocolHandlers)++getUnsupported		:: IOStateArrow s XmlTree XmlTree+getUnsupported+    = perform ( getAttrValue a_source+		>>>+		arr (("unsupported protocol in URI " ++) . show)+		>>>+		applyA (arr issueFatal)+	      )+      >>>+      setDocumentStatusFromSystemState "accessing documents"+	+getStringContents		:: IOStateArrow s XmlTree XmlTree+getStringContents+    = setCont $< getAttrValue a_source+      >>>+      addAttr transferMessage "OK"+      >>>+      addAttr transferStatus "200"+    where+    setCont contents+	= replaceChildren (txt contents')+	  >>>+	  addAttr transferURI (take 7 contents)			-- the "string:" prefix is stored, this is required by setBaseURIFromDoc+	  >>>+	  addAttr a_source (show . prefix 48 $ contents')	-- a quoted prefix of the content, max 48 chars is taken as source name+	where+	contents'  = drop (length stringProtocol) contents+	prefix l s+	    | length s' > l = take (l - 3) s' ++ "..."+	    | otherwise     = s'+	    where+	    s' = take (l + 1) s++getFileContents		:: IOStateArrow s XmlTree XmlTree+getFileContents+    = applyA ( ( ( getAttrValue  a_strict_input+		   >>>+		   arr isTrueValue+		 )+		 &&&+		 ( getAttrValue transferURI+		   >>>+		   getPathFromURI+		 )+	       )+	       >>>+	       traceValue 2 (\ (b, f) -> "read file " ++ show f ++ " (strict input = " ++ show b ++ ")")+	       >>>+	       arrIO (uncurry FILE.getCont)+	       >>>+	       ( arr (uncurry addError)	-- io error occured+		 |||+		 arr addTxtContent	-- content read+	       )+	     )+      >>>+      addMimeType++getStdinContents		:: IOStateArrow s XmlTree XmlTree+getStdinContents+    = applyA (  getAttrValue  a_strict_input+		>>>+		arr isTrueValue+		>>>+		arrIO FILE.getStdinCont+	       >>>+	       ( arr (uncurry addError)	-- io error occured+		 |||+		 arr addTxtContent	-- content read+	       )+	     )++addError		:: [(String, String)] -> String -> IOStateArrow s XmlTree XmlTree+addError al e+    = issueFatal e+      >>>+      seqA (map (uncurry addAttr) al)+      >>>+      setDocumentStatusFromSystemState "accessing documents"++addMimeType	:: IOStateArrow s XmlTree XmlTree+addMimeType+    = addMime $< ( getAttrValue transferURI+		   >>>+		   ( uriToMime $< getSysParam xio_mimeTypes )+		 )+    where+    addMime mt+	= addAttr transferMimeType mt+    uriToMime mtt+	= arr $ ( \ uri -> extensionToMimeType (drop 1 . takeExtension $ uri) mtt )++addTxtContent	:: String -> IOStateArrow s XmlTree XmlTree+addTxtContent c+    = replaceChildren (txt c)+      >>>+      addAttr transferMessage "OK"+      >>>+      addAttr transferStatus "200"++getHttpContents		:: IOStateArrow s XmlTree XmlTree+getHttpContents+    = getCont $<< ( getAttrValue transferURI+		    &&&+		    ( ( getAttrlAsAssoc		-- get all attributes of root node+			&&&+			getAllParamsString	-- get all system params+		      )+		      >>^ uncurry addEntries	-- merge them, attributes overwrite system params+		    )+		  )+      where+      getAttrlAsAssoc				-- get the attributes as assoc list+	  = listA ( getAttrl+		    >>> ( getName+			  &&&+			  xshow getChildren+			)+		  )++      getCont uri options+	  = applyA ( ( traceMsg 2 ( "get HTTP via libcurl, uri=" ++ show uri ++ " options=" ++ show options )+		       >>>+		       arrIO0 ( LibCURL.getCont options uri )+		     )+		     >>>+		     ( arr (uncurry addError)+		       |||+		       arr addContent+		     )+		   )++      addContent	:: (AssocList String String, String) -> IOStateArrow s XmlTree XmlTree+      addContent (al, c)+	  = replaceChildren (txt c)+	    >>>+	    seqA (map (uncurry addAttr) al)++getURIContents		:: IOStateArrow s XmlTree XmlTree+getURIContents+    = getContentsFromString+      `orElse`+      getContentsFromDoc+    where+    getContentsFromString+	= ( getAttrValue a_source+	    >>>+	    isA (isPrefixOf stringProtocol)+	  )+	  `guards`+	  getStringContents+	  +    getContentsFromDoc+	= ( ( addTransferURI $< getBaseURI+	      >>>+	      getCont+	    )+	    `when`+	    ( setAbsURI $< ( getAttrValue a_source+			     >>^+			     ( \ src-> (if null src then "stdin:" else src) )	-- empty document name -> read from stdin+			   )+	    )+	  )+          >>>+          setDocumentStatusFromSystemState "getURIContents"++    setAbsURI src+	= ifA ( constA src >>> changeBaseURI )+	  this+	  ( issueFatal ("illegal URI : " ++ show src) )++    addTransferURI uri+	= addAttr transferURI uri++    getCont+	= applyA ( getBaseURI				-- compute the handler and call it+		   >>>+		   traceValue 2 (("getURIContents: reading " ++) . show)+		   >>>+		   getSchemeFromURI+		   >>>+		   getProtocolHandler+		 )+	  `orElse`+	  this						-- don't change tree, when no handler can be found+	  +setBaseURIFromDoc	:: IOStateArrow s XmlTree XmlTree+setBaseURIFromDoc+    = perform ( getAttrValue transferURI+		>>>+		isA (isPrefixOf stringProtocol)		-- do not change base URI when reading from a string+		>>>+		setBaseURI+	      )++{- |+   Read the content of a document.++   This routine is usually called from 'Yuuko.Text.XML.HXT.Arrow.ProcessDocument.getDocumentContents'.++   The input must be a root node (constructed with 'Yuuko.Text.XML.HXT.Arrow.XmlArrow.root'), usually without children.+   The attribute list contains all input parameters, e.g. URI or source file name, encoding preferences, ...+   If the source name is empty, the input is read from standard input.++   The source is transformed into an absolute URI. If the source is a relative URI, or a file name,+   it is expanded into an absolut URI with respect to the current base URI.+   The default base URI is of protocol \"file\" and points to the current working directory.++   The currently supported protocols are \"http\", \"file\", \"stdin\" and \"string\".++   The latter two are internal protocols. An uri of the form \"stdin:\" stands for the content of+   the standard input stream.++   \"string:some text\" means, that \"some text\" is taken as input.+   This internal protocol is used for reading from normal 'String' values.++-}++getXmlContents		:: IOStateArrow s XmlTree XmlTree+getXmlContents+    = getXmlContents' parseXmlDocEncodingSpec+      >>>+      setBaseURIFromDoc++getXmlEntityContents		:: IOStateArrow s XmlTree XmlTree+getXmlEntityContents+    = getXmlContents' parseXmlEntityEncodingSpec+      >>>+      processChildren removeEncodingSpec+      >>>+      setBaseURIFromDoc++getXmlContents'		:: IOStateArrow s XmlTree XmlTree -> IOStateArrow s XmlTree XmlTree+getXmlContents' parseEncodingSpec+    = ( getURIContents+	>>>+	choiceA+	[ isXmlHtmlDoc	:-> ( parseEncodingSpec+			      >>>+			      filterErrorMsg+			      >>>+			      decodeDocument+			    )+	, isTextDoc	:->  decodeDocument+	, this		:-> this+	]+	>>>+	perform ( getAttrValue transferURI+		  >>>+		  traceValue 1 (("getXmlContents: content read and decoded for " ++) . show)+		)+	>>>+	traceTree+	>>>+	traceSource+      )+      `when`+      isRoot++isMimeDoc		:: (String -> Bool) -> IOStateArrow s XmlTree XmlTree+isMimeDoc isMT		= fromLA $+			  ( ( getAttrValue transferMimeType >>^ stringToLower )+			    >>>+			    isA (\ t -> null t || isMT t)+			  )+			  `guards` this++isTextDoc, isXmlHtmlDoc	:: IOStateArrow s XmlTree XmlTree++isTextDoc		= isMimeDoc isTextMimeType++isXmlHtmlDoc		= isMimeDoc (\ mt -> isHtmlMimeType mt || isXmlMimeType mt)++-- ------------------------------------------------------------++getEncoding	:: IOStateArrow s XmlTree String+getEncoding+    = catA [ xshow getChildren			-- 1. guess: guess encoding by looking at the first few bytes+	     >>>+	     arr guessEncoding+	   , getAttrValue transferEncoding	-- 2. guess: take the transfer encoding+	   , getAttrValue a_encoding		-- 3. guess: take encoding parameter in root node+	   , getParamString a_encoding		-- 4. guess: take encoding parameter in global state+	   , constA utf8			-- default : utf8+	   ]+      >. (head . filter (not . null))		-- make the filter deterministic: take 1. entry from list of guesses++getTextEncoding	:: IOStateArrow s XmlTree String+getTextEncoding+    = catA [ getAttrValue transferEncoding	-- 1. guess: take the transfer encoding+	   , getAttrValue a_encoding		-- 2. guess: take encoding parameter in root node+	   , getParamString a_encoding		-- 3. guess: take encoding parameter in global state+	   , constA isoLatin1			-- default : no encoding+	   ]+      >. (head . filter (not . null))		-- make the filter deterministic: take 1. entry from list of guesses+++decodeDocument	:: IOStateArrow s XmlTree XmlTree+decodeDocument+    = choiceA+      [ ( isRoot >>> isXmlHtmlDoc )   :-> ( decodeArr normalizeNL  $< getEncoding )+      , ( isRoot >>> isTextDoc )      :-> ( decodeArr id           $< getTextEncoding )+      , this                          :-> this+      ]+    where+    decodeArr	:: (String -> String) -> String -> IOStateArrow s XmlTree XmlTree+    decodeArr normalizeNewline enc+	= maybe notFound found . getDecodingFct $ enc+	where+	found df+	    = traceMsg 2 ("decodeDocument: encoding is " ++ show enc)+	      >>>+	      ( decodeText df $< getAttrValue a_ignore_encoding_errors )+	      >>>+	      addAttr transferEncoding enc++	notFound+	    = issueFatal ("encoding scheme not supported: " ++ show enc)+	      >>>+	      setDocumentStatusFromSystemState "decoding document"++	decodeText df ignoreErrs+	    = processChildren+	      ( getText							-- get the document content+		>>> arr df						-- decode the text, result is (string, [errMsg])+		>>> ( ( (fst >>> normalizeNewline)			-- take decoded string, normalize newline and build text node+			^>> mkText+		      )+		      <+>+		      ( if isTrueValue ignoreErrs+			then none					-- encoding errors are ignored+			else+			( arrL snd					-- take the error messages+			  >>>+			  arr ((enc ++) . (" encoding error" ++))	-- prefix with enc error+			  >>>+			  applyA (arr issueErr)				-- build issueErr arrow and apply+			  >>>+			  none						-- neccessary for type match with <+>+			)+		      )+		    )+	      )+      +-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/Arrow/DocumentOutput.hs view
@@ -0,0 +1,206 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.Arrow.DocumentOutput+   Copyright  : Copyright (C) 2005-9 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   State arrows for document output++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.Arrow.DocumentOutput+    ( putXmlDocument+    , putXmlTree+    , putXmlSource+    , encodeDocument+    , encodeDocument'+    )+where++import Control.Arrow				-- arrow classes+import Yuuko.Control.Arrow.ArrowList+import Yuuko.Control.Arrow.ArrowIf+import Yuuko.Control.Arrow.ArrowTree+import Yuuko.Control.Arrow.ArrowIO+import Yuuko.Control.Arrow.ListArrow++import Yuuko.Text.XML.HXT.DOM.Unicode			( getOutputEncodingFct )+import Yuuko.Text.XML.HXT.DOM.Interface++import Yuuko.Text.XML.HXT.Arrow.XmlArrow+import Yuuko.Text.XML.HXT.Arrow.XmlIOStateArrow++import Yuuko.Text.XML.HXT.Arrow.Edit			( addHeadlineToXmlDoc+						, addXmlPi+						, addXmlPiEncoding+						, indentDoc+						, numberLinesInXmlDoc+						, treeRepOfXmlDoc+						)++import System.IO				( Handle+						, IOMode(..)+						, openFile+						, openBinaryFile+                                                , hSetBinaryMode+						, hPutStrLn+						, hClose+						, stdout+						)++import System.IO.Error				( try )++-- ------------------------------------------------------------+--+-- output arrows++putXmlDocument	:: Bool -> String -> IOStateArrow s XmlTree XmlTree+putXmlDocument textMode dst+    = perform ( xshow getChildren+		>>>+		arrIO (\ s -> try ( hPutDocument (\h -> hPutStrLn h s)))+		>>>+		( ( traceMsg 1 ("io error, document not written to " ++ outFile)+		    >>>+		    arr show >>> mkError c_fatal+		    >>>+		    filterErrorMsg+		  )+		  |||+		  ( traceMsg 2 ("document written to " ++ outFile)+		    >>>+		    none+		  )+		)+	      )+      where+      isStdout	= null dst || dst == "-"++      outFile	= if isStdout+		  then "stdout"+		       else show dst++      hPutDocument	:: (Handle -> IO ()) -> IO ()+      hPutDocument action+	  | isStdout+	      = do+                hSetBinaryMode stdout (not textMode)+                action stdout+                hSetBinaryMode stdout False+	  | otherwise+	      = do+		handle <- ( if textMode+			    then openFile+			    else openBinaryFile+			  ) dst WriteMode+		action handle+		hClose handle++-- |+-- write the tree representation of a document to a file++putXmlTree	:: String -> IOStateArrow s XmlTree XmlTree+putXmlTree dst+    = perform ( treeRepOfXmlDoc+		>>>+		addHeadlineToXmlDoc+	        >>>+		putXmlDocument True dst+	      )++-- |+-- write a document with indentaion and line numers++putXmlSource	:: String -> IOStateArrow s XmlTree XmlTree+putXmlSource dst+    = perform ( (this ) `whenNot` isRoot+		>>>+		indentDoc+		>>>+		numberLinesInXmlDoc+		>>>+		addHeadlineToXmlDoc+	        >>>+		putXmlDocument True dst+	      )++-- ------------------------------------------------------------++getEncodingParam	:: IOStateArrow s XmlTree String+getEncodingParam+    = catA [ getParamString a_output_encoding	-- 4. guess: take output encoding parameter from global state+	   , getParamString a_encoding		-- 5. guess: take encoding parameter from global state+	   , constA utf8			-- default : utf8+           ]+      >. (head . filter (not . null))++getOutputEncoding	:: String -> IOStateArrow s XmlTree String+getOutputEncoding defaultEnc+    = getEC $< getEncodingParam+    where+    getEC enc' = fromLA $ getOutputEncoding' defaultEnc enc'++encodeDocument	:: Bool -> String -> IOStateArrow s XmlTree XmlTree+encodeDocument supressXmlPi defaultEnc+    = encode $< getOutputEncoding defaultEnc+    where+    encode enc+        = traceMsg 2 ("encodeDocument: encoding is " ++ show enc)+	  >>>+          ( encodeDocument' supressXmlPi enc+            `orElse`+            ( issueFatal ("encoding scheme not supported: " ++ show enc)+	      >>>+	      setDocumentStatusFromSystemState "encoding document"+            )+          )++-- ------------------------------------------------------------++getOutputEncoding'	:: String -> String -> LA XmlTree String+getOutputEncoding' defaultEnc defaultEnc2+    =  catA [ getChildren			-- 1. guess: evaluate <?xml ... encoding="..."?>+	      >>>+	      ( ( isPi >>> hasName t_xml )+		`guards`+		getAttrValue a_encoding+	      )+	    , constA defaultEnc			-- 2. guess: explicit parameter, may be ""+	    , getAttrValue a_output_encoding	-- 3. guess: take output encoding parameter in root node+	    , constA defaultEnc2		-- default : UNICODE or utf8+	    ]+      >. (head . filter (not . null))		-- make the filter deterministic: take 1. entry from list of guesses++encodeDocument'	:: ArrowXml a => Bool -> String -> a XmlTree XmlTree+encodeDocument' supressXmlPi defaultEnc+    = fromLA (encode $< getOutputEncoding' defaultEnc utf8)+    where+    encode	:: String -> LA XmlTree XmlTree+    encode encodingScheme+        = case getOutputEncodingFct encodingScheme of+          Nothing	-> none+          Just ef	-> ( if supressXmlPi+		             then processChildren (none `when` isXmlPi)+		             else ( addXmlPi+			            >>>+			            addXmlPiEncoding encodingScheme+			          )+		           )+		           >>>+		           replaceChildren ( xshow getChildren+				             >>>+				             arr ef+				             >>>+				             mkText+				           )+		           >>>+		           addAttr a_output_encoding encodingScheme++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/Arrow/Edit.hs view
@@ -0,0 +1,825 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.Arrow.Edit+   Copyright  : Copyright (C) 2006-9 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : stable+   Portability: portable++   common edit arrows++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.Arrow.Edit+    ( canonicalizeAllNodes+    , canonicalizeForXPath+    , canonicalizeContents+    , collapseAllXText+    , collapseXText++    , xshowEscapeXml++    , escapeXmlDoc+    , escapeHtmlDoc++    , haskellRepOfXmlDoc+    , treeRepOfXmlDoc+    , addHeadlineToXmlDoc++    , indentDoc+    , numberLinesInXmlDoc+    , preventEmptyElements+ +    , removeComment+    , removeAllComment+    , removeWhiteSpace+    , removeAllWhiteSpace+    , removeDocWhiteSpace++    , transfCdata+    , transfAllCdata+    , transfCharRef+    , transfAllCharRef++    , rememberDTDAttrl+    , addDefaultDTDecl++    , hasXmlPi+    , addXmlPi+    , addXmlPiEncoding++    , addDoctypeDecl+    , addXHtmlDoctypeStrict+    , addXHtmlDoctypeTransitional+    , addXHtmlDoctypeFrameset+    )+where++import           Control.Arrow+import           Yuuko.Control.Arrow.ArrowList+import           Yuuko.Control.Arrow.ArrowIf+import           Yuuko.Control.Arrow.ArrowTree+import 		 Yuuko.Control.Arrow.ListArrow++import           Yuuko.Text.XML.HXT.Arrow.XmlArrow+import           Yuuko.Text.XML.HXT.DOM.Interface+import qualified Yuuko.Text.XML.HXT.DOM.XmlNode 	as XN+import           Yuuko.Text.XML.HXT.DOM.Unicode		( isXmlSpaceChar )+import           Yuuko.Text.XML.HXT.DOM.FormatXmlTree 	( formatXmlTree )+import           Yuuko.Text.XML.HXT.Parser.HtmlParsec         ( emptyHtmlTags )+import           Yuuko.Text.XML.HXT.Parser.XmlEntities	( xmlEntities )+import           Yuuko.Text.XML.HXT.Parser.XhtmlEntities	( xhtmlEntities )++import           Data.List                              ( isPrefixOf )+import qualified Data.Map 			as M+import           Data.Maybe++-- ------------------------------------------------------------++-- |+-- Applies some "Canonical XML" rules to a document tree.+--+-- The rule differ slightly for canonical XML and XPath in handling of comments+--+-- Note: This is not the whole canonicalization as it is specified by the W3C+-- Recommendation. Adding attribute defaults or sorting attributes in lexicographic+-- order is done by the @transform@ function of module @Yuuko.Text.XML.HXT.Validator.Validation@.+-- Replacing entities or line feed normalization is done by the parser.+--+--+-- Not implemented yet:+--+--  - Whitespace within start and end tags is normalized+--+--  - Special characters in attribute values and character content are replaced by character references+--+-- see 'canonicalizeAllNodes' and 'canonicalizeForXPath'++canonicalizeTree'	:: LA XmlTree XmlTree -> LA XmlTree XmlTree+canonicalizeTree' toBeRemoved+    = processChildren (none `when` isText)+      >>>+      processBottomUp canonicalize1Node+      where+      canonicalize1Node	:: LA XmlTree XmlTree+      canonicalize1Node+	  = (deep isPi `when` isDTD)		-- remove DTD parts, except PIs+	    >>>+	    (none `when` toBeRemoved)		-- remove unintersting nodes+	    >>>+	    ( processAttrl ( processChildren transfCharRef+			     >>>+			     collapseXText+			   )+	      `when` isElem+	    )+	    >>>+	    transfCdata				-- CDATA -> text+	    >>>+	    transfCharRef			-- Char refs -> text+	    >>>+	    collapseXText			-- combine text+++-- |+-- Applies some "Canonical XML" rules to a document tree.+--+-- The rule differ slightly for canonical XML and XPath in handling of comments+--+-- Note: This is not the whole canonicalization as it is specified by the W3C+-- Recommendation. Adding attribute defaults or sorting attributes in lexicographic+-- order is done by the @transform@ function of module @Yuuko.Text.XML.HXT.Validator.Validation@.+-- Replacing entities or line feed normalization is done by the parser.+--+-- Rules: remove DTD parts, processing instructions, comments and substitute char refs in attribute+-- values and text+--+-- Not implemented yet:+--+--  - Whitespace within start and end tags is normalized+--+--  - Special characters in attribute values and character content are replaced by character references++canonicalizeAllNodes	:: ArrowList a => a XmlTree XmlTree+canonicalizeAllNodes+    = fromLA $+      canonicalizeTree' ( isCmt		-- remove comment+			  <+>+			  isXmlPi	-- remove xml declaration+			)++-- |+-- Canonicalize a tree for XPath+-- Like 'canonicalizeAllNodes' but comment nodes are not removed+--+-- see 'canonicalizeAllNodes'++canonicalizeForXPath	:: ArrowList a => a XmlTree XmlTree+canonicalizeForXPath+    = fromLA $+      canonicalizeTree' isXmlPi++-- |+-- Canonicalize the contents of a document+--+-- substitutes all char refs in text and attribute values,+-- removes CDATA section and combines all sequences of resulting text+-- nodes into a single text node+--+-- see 'canonicalizeAllNodes'++canonicalizeContents	:: ArrowList a => a XmlTree XmlTree+canonicalizeContents+    = fromLA $+      processBottomUp canonicalize1Node+      where+      canonicalize1Node	:: LA XmlTree XmlTree+      canonicalize1Node+	  = ( processAttrl ( processChildren transfCharRef+			     >>>+			     collapseXText+			   )+	      `when` isElem+	    )+	    >>>+	    transfCdata				-- CDATA -> text+	    >>>+	    transfCharRef			-- Char refs -> text+	    >>>+	    collapseXText			-- combine text++-- ------------------------------------------------------------++collapseXText'		:: LA XmlTree XmlTree+collapseXText'+    = replaceChildren ( listA getChildren >>> arrL (foldr mergeText' []) )+    where+    mergeText'	:: XmlTree -> XmlTrees -> XmlTrees+    mergeText' t1 (t2 : ts2)+	| XN.isText t1 && XN.isText t2+	    = let+	      s1 = fromJust . XN.getText $ t1+	      s2 = fromJust . XN.getText $ t2+	      t  = XN.mkText (s1 ++ s2)+	      in+	      t : ts2+    mergeText' t1 ts+	= t1 : ts++-- |+-- Collects sequences of text nodes in the list of children of a node into one single text node.+-- This is useful, e.g. after char and entity reference substitution++collapseXText		:: ArrowList a => a XmlTree XmlTree+collapseXText+    = fromLA $+      collapseXText'++-- |+-- Applies collapseXText recursively.+--+--+-- see also : 'collapseXText'++collapseAllXText	:: ArrowList a => a XmlTree XmlTree+collapseAllXText+    = fromLA $+      processBottomUp collapseXText'++-- ------------------------------------------------------------++-- | apply an arrow to the input and convert the resulting XML trees into an XML escaped string+--+-- This is a save variant for converting a tree into an XML string representation that is parsable with 'Yuuko.Text.XML.HXT.Arrow.ReadDocument'.+-- It is implemented with 'Yuuko.Text.XML.HXT.Arrow.XmlArrow.xshow', but xshow does no XML escaping. The XML escaping is done with+-- 'Yuuko.Text.XML.HXT.Arrow.Edit.escapeXmlDoc' before xshow is applied.+--+-- So the following law holds+--+-- > xshowEscape f >>> xread == f++xshowEscapeXml		:: ArrowXml a => a n XmlTree -> a n String+xshowEscapeXml f	= xshow (f >>> escapeXmlDoc)++-- ------------------------------------------------------------++-- |+-- escape XmlText,+-- transform all special XML chars into char- or entity- refs++type EntityRefTable	= M.Map Int String++xmlEntityRefTable+ , xhtmlEntityRefTable	:: EntityRefTable++xmlEntityRefTable   = buildEntityRefTable $ xmlEntities+xhtmlEntityRefTable = buildEntityRefTable $ xhtmlEntities++buildEntityRefTable	:: [(String, Int)] -> EntityRefTable+buildEntityRefTable	= M.fromList . map (\ (x,y) -> (y,x) )++escapeText''	:: (Char -> XmlTree) -> (Char -> Bool) -> XmlTree -> XmlTrees+escapeText'' escChar isEsc t+    = maybe [t] escape' . XN.getText $ t+    where+    escape' "" = [t]		-- empty text nodes remain empty text nodes+    escape' s  = escape s	-- they do not disapear++    escape ""+	= []+    escape (c:s1)+	| isEsc c+	    = escChar c : escape s1+    escape s+	= XN.mkText s1 : escape s2+	where+	(s1, s2) = break isEsc s++{-+escapeCharRef	:: Char -> XmlTree+escapeCharRef	= XN.mkCharRef . fromEnum+-}++escapeEntityRef	:: EntityRefTable -> Char -> XmlTree+escapeEntityRef entityTable c+    = maybe (XN.mkCharRef c') XN.mkEntityRef . M.lookup c' $ entityTable+    where+    c' = fromEnum c++escapeXmlEntityRef	:: Char -> XmlTree+escapeXmlEntityRef	= escapeEntityRef xmlEntityRefTable++escapeHtmlEntityRef	:: Char -> XmlTree+escapeHtmlEntityRef	= escapeEntityRef xhtmlEntityRefTable++-- ------------------------------------------------------------++-- |+-- escape all special XML chars into XML entity references or char references+--+-- convert the special XML chars \< and & in text nodes into prefefiened XML entity references,+-- in attribute values also \', \", \>, \\n, \\r and \\t are converted into entity or char references,+-- in comments nothing is converted (see XML standard 2.4, useful e.g. for JavaScript).++escapeXmlDoc		:: ArrowList a => a XmlTree XmlTree+escapeXmlDoc+    = fromLA $ escapeDoc escXmlText escXmlAttrValue+    where+    escXmlText+	= arrL $ escapeText'' escapeXmlEntityRef (`elem` "<&")		-- no escape for ", ' and > required: XML standard 2.4+    escXmlAttrValue+        = arrL $ escapeText'' escapeXmlEntityRef (`elem` "<>\"\'&\n\r\t")+++-- |+-- escape all special HTML chars into XHTML entity references or char references+--+-- convert the special XML chars \< and & and all none ASCII chars in text nodes into prefefiened XML or XHTML entity references,+-- in attribute values also \', \", \>, \\n, \\r and \\t are converted into entity or char references,+-- in comments nothing is converted++-- ------------------------------------------------------------++escapeHtmlDoc		:: ArrowList a => a XmlTree XmlTree+escapeHtmlDoc+    = fromLA $ escapeDoc escHtmlText escHtmlAttrValue+    where+    escHtmlText+	= arrL $ escapeText'' escapeHtmlEntityRef isHtmlTextEsc+    escHtmlAttrValue+        = arrL $ escapeText'' escapeHtmlEntityRef isHtmlAttrEsc++    isHtmlTextEsc c+	= c >= toEnum(128) || ( c `elem` "<&" )+    isHtmlAttrEsc c+	= c >= toEnum(128) || ( c `elem` "<>\"\'&\n\r\t" )++-- ------------------------------------------------------------++escapeDoc		:: LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree+escapeDoc escText escAttr+    = escape+    where+    escape+	= choiceA+	  [ isElem  :-> ( processChildren escape+			  >>>+			  processAttrl escVal+			)+	  , isText  :-> escText+	  -- , isCmt   :-> escCmt+	  , isDTD   :-> processTopDown escDTD+	  , this    :-> this+	  ]+    escVal   = processChildren escAttr+    escDTD   = escVal `when` ( isDTDEntity <+> isDTDPEntity )++-- ------------------------------------------------------------++preventEmptyElements	:: ArrowList a => [String] -> Bool -> a XmlTree XmlTree+preventEmptyElements ns isHtml+    = fromLA $ insertDummyElem+    where+    isNoneEmpty+        | not (null ns) = hasNameWith (localPart >>> (`elem` ns))+	| isHtml	= hasNameWith (localPart >>> (`notElem` emptyHtmlTags))+	| otherwise	= this++    insertDummyElem+	= processBottomUp+	  ( replaceChildren (txt "")+	    `when`+	    ( isElem+	      >>>+	      isNoneEmpty+	      >>>+	      neg getChildren+	    )+	  )++-- ------------------------------------------------------------++-- |+-- convert a document into a Haskell representation (with show).+--+-- Useful for debugging and trace output.+-- see also : 'treeRepOfXmlDoc', 'numberLinesInXmlDoc'++haskellRepOfXmlDoc	:: ArrowList a => a XmlTree XmlTree+haskellRepOfXmlDoc+    = fromLA $+      root [getAttrl] [show ^>> mkText]++-- |+-- convert a document into a text and add line numbers to the text representation.+-- +-- Result is a root node with a single text node as child.+-- Useful for debugging and trace output.+-- see also : 'haskellRepOfXmlDoc', 'treeRepOfXmlDoc'++numberLinesInXmlDoc	:: ArrowList a => a XmlTree XmlTree+numberLinesInXmlDoc+    = fromLA $+      processChildren (changeText numberLines)+    where+    numberLines	:: String -> String+    numberLines str+	= concat $+	  zipWith (\ n l -> lineNr n ++ l ++ "\n") [1..] (lines str)+	where+	lineNr	 :: Int -> String+	lineNr n = (reverse (take 6 (reverse (show n) ++ replicate 6 ' '))) ++ "  "++-- |+-- convert a document into a text representation in tree form.+--+-- Useful for debugging and trace output.+-- see also : 'haskellRepOfXmlDoc', 'numberLinesInXmlDoc'++treeRepOfXmlDoc	:: ArrowList a => a XmlTree XmlTree+treeRepOfXmlDoc+    = fromLA $+      root [getAttrl] [formatXmlTree ^>> mkText]++addHeadlineToXmlDoc	:: ArrowXml a => a XmlTree XmlTree+addHeadlineToXmlDoc+    = fromLA $ ( addTitle $< (getAttrValue a_source >>^ formatTitle) )+    where+    addTitle str+	= replaceChildren ( txt str <+> getChildren <+> txt "\n" )+    formatTitle str+	= "\n" ++ headline ++ "\n" ++ underline ++ "\n\n"+	where+	headline  = "content of: " ++ str+        underline = map (const '=') headline++-- ------------------------------------------------------------++removeComment'		:: LA XmlTree XmlTree+removeComment'		= none `when` isCmt++-- |+-- remove Comments: @none `when` isCmt@++removeComment		:: ArrowXml a => a XmlTree XmlTree+removeComment		= fromLA $ removeComment'++-- |+-- remove all comments recursively++removeAllComment	:: ArrowXml a => a XmlTree XmlTree+removeAllComment	= fromLA $ processBottomUp removeComment'++-- ----------++removeWhiteSpace'	:: LA XmlTree XmlTree+removeWhiteSpace'	= none `when` isWhiteSpace++-- |+-- simple filter for removing whitespace.+--+-- no check on sigificant whitespace, e.g. in HTML \<pre\>-elements, is done.+--+--+-- see also : 'removeAllWhiteSpace', 'removeDocWhiteSpace'++removeWhiteSpace	:: ArrowXml a => a XmlTree XmlTree+removeWhiteSpace	= fromLA $ removeWhiteSpace'++-- |+-- simple recursive filter for removing all whitespace.+--+-- removes all text nodes in a tree that consist only of whitespace.+--+--+-- see also : 'removeWhiteSpace', 'removeDocWhiteSpace'++removeAllWhiteSpace	:: ArrowXml a => a XmlTree XmlTree+removeAllWhiteSpace	= fromLA $ processBottomUp removeWhiteSpace'++-- |+-- filter for removing all not significant whitespace.+--+-- the tree traversed for removing whitespace between elements,+-- that was inserted for indentation and readability.+-- whitespace is only removed at places, where it's not significat+-- preserving whitespace may be controlled in a document tree+-- by a tag attribute @xml:space@+--+-- allowed values for this attribute are @default | preserve@+--+-- input is root node of the document to be cleaned up,+-- output the semantically equivalent simplified tree+--+--+-- see also : 'indentDoc', 'removeAllWhiteSpace'++removeDocWhiteSpace	:: ArrowXml a => a XmlTree XmlTree+removeDocWhiteSpace	= fromLA $ removeRootWhiteSpace+++removeRootWhiteSpace	:: LA XmlTree XmlTree+removeRootWhiteSpace+    =  processChildren processRootElement+       `when`+       isRoot+    where+    processRootElement	:: LA XmlTree XmlTree+    processRootElement+	= removeWhiteSpace >>> processChild+	where+	processChild+	    = choiceA [ isDTD+			:-> removeAllWhiteSpace			-- whitespace in DTD is redundant+		      , this+			:-> replaceChildren ( getChildren+					      >>. indentTrees insertNothing False 1+					    )+		      ]++-- ------------------------------------------------------------++-- |+-- filter for indenting a document tree for pretty printing.+--+-- the tree is traversed for inserting whitespace for tag indentation.+--+-- whitespace is only inserted or changed at places, where it isn't significant,+-- is's not inserted between tags and text containing non whitespace chars.+--+-- whitespace is only inserted or changed at places, where it's not significant.+-- preserving whitespace may be controlled in a document tree+-- by a tag attribute @xml:space@+--+-- allowed values for this attribute are @default | preserve@.+--+-- input is a complete document tree or a document fragment+-- result is the semantically equivalent formatted tree.+--+--+-- see also : 'removeDocWhiteSpace'++indentDoc		:: ArrowXml a => a XmlTree XmlTree+indentDoc		= fromLA $+			  ( ( isRoot `guards` indentRoot )+			    `orElse`+			    (root [] [this] >>> indentRoot >>> getChildren)+			  )++-- ------------------------------------------------------------++indentRoot		:: LA XmlTree XmlTree+indentRoot		= processChildren indentRootChildren+    where+    indentRootChildren+	= removeText >>> indentChild >>> insertNL+	where+	removeText	= none `when` isText+	insertNL	= this <+> txt "\n"+	indentChild	= ( replaceChildren+			    ( getChildren+			      >>.+			      indentTrees (insertIndentation 2) False 1+			    )+			    `whenNot` isDTD+			  )++-- ------------------------------------------------------------+--+-- copied from EditFilter and rewritten for arrows+-- to remove dependency to the filter module++indentTrees	:: (Int -> LA XmlTree XmlTree) -> Bool -> Int -> XmlTrees -> XmlTrees+indentTrees _ _ _ []+    = []+indentTrees indentFilter preserveSpace level ts+    = runLAs lsf ls+      +++      indentRest rs+      where+      runLAs f l+	  = runLA (constL l >>> f) undefined++      (ls, rs)+	  = break XN.isElem ts++      isSignificant	:: Bool+      isSignificant+	  = preserveSpace+	    ||+	    (not . null . runLAs isSignificantPart) ls++      isSignificantPart	:: LA XmlTree XmlTree+      isSignificantPart+	  = catA+	    [ isText `guards` neg isWhiteSpace+	    , isCdata+	    , isCharRef+	    , isEntityRef+	    ]++      lsf	:: LA XmlTree XmlTree+      lsf+	  | isSignificant+	      = this+	  | otherwise+	      = (none `when` isWhiteSpace)+                >>>+                (indentFilter level <+> this)++      indentRest	:: XmlTrees -> XmlTrees+      indentRest []+	  | isSignificant+	      = []+	  | otherwise+	      = runLA (indentFilter (level - 1)) undefined++      indentRest (t':ts')+	  = runLA ( ( indentElem+		      >>>+		      lsf+		    )+		    `when` isElem+		  ) t'+            +++	    ( if null ts'+	      then indentRest+	      else indentTrees indentFilter preserveSpace level+	    ) ts'+	  where+	  indentElem+	      = replaceChildren	( getChildren+				  >>.+				  indentChildren+				)++	  xmlSpaceAttrValue	:: String+	  xmlSpaceAttrValue+	      = concat . runLA (getAttrValue "xml:space") $ t'++	  preserveSpace'	:: Bool+	  preserveSpace'+	      = ( fromMaybe preserveSpace+		  .+		  lookup xmlSpaceAttrValue+	        ) [ ("preserve", True)+		  , ("default",  False)+		  ]++	  indentChildren	:: XmlTrees -> XmlTrees+	  indentChildren cs'+	      | all (maybe False (all isXmlSpaceChar) . XN.getText) cs'+		  = []+	      | otherwise+		  = indentTrees indentFilter preserveSpace' (level + 1) cs'++	+-- filter for indenting elements++insertIndentation	:: Int -> Int -> LA a XmlTree+insertIndentation indentWidth level+    = txt ('\n' : replicate (level * indentWidth) ' ')++-- filter for removing all whitespace++insertNothing		:: Int -> LA a XmlTree+insertNothing _		= none++-- ------------------------------------------------------------++transfCdata'		:: LA XmlTree XmlTree+transfCdata'		= (getCdata >>> mkText) `when` isCdata++-- |+-- converts a CDATA section node into a normal text node++transfCdata		:: ArrowXml a => a XmlTree XmlTree+transfCdata		= fromLA $+			  transfCdata'++-- |+-- converts CDATA sections in whole document tree into normal text nodes++transfAllCdata		:: ArrowXml a => a XmlTree XmlTree+transfAllCdata		= fromLA $+			  processBottomUp transfCdata'+			  +--++transfCharRef'		:: LA XmlTree XmlTree+transfCharRef'		= ( getCharRef >>> arr (\ i -> [toEnum i]) >>> mkText )+		          `when`+			  isCharRef++-- |+-- converts character references to normal text++transfCharRef		:: ArrowXml a => a XmlTree XmlTree+transfCharRef		= fromLA $+			  transfCharRef'++-- |+-- recursively converts all character references to normal text++transfAllCharRef	:: ArrowXml a => a XmlTree XmlTree+transfAllCharRef	= fromLA $+			  processBottomUp transfCharRef'++-- ------------------------------------------------------------++rememberDTDAttrl	:: ArrowList a => a XmlTree XmlTree+rememberDTDAttrl+    = fromLA $+      ( ( addDTDAttrl $< ( getChildren >>> isDTDDoctype >>> getDTDAttrl ) )+        `orElse`+        this+      )+    where+    addDTDAttrl al+        = seqA . map (uncurry addAttr) . map (first (dtdPrefix ++)) $ al++addDefaultDTDecl	:: ArrowList a => a XmlTree XmlTree+addDefaultDTDecl+    = fromLA $+      ( addDTD $< listA (getAttrl >>> (getName &&& xshow getChildren) >>> hasDtdPrefix) )+    where+    hasDtdPrefix+        = isA (fst >>> (dtdPrefix `isPrefixOf`))+          >>>+          arr (first (drop (length dtdPrefix)))+    addDTD []+        = this+    addDTD al+        = replaceChildren+          ( mkDTDDoctype al none+            <+>+            txt "\n"+            <+>+            ( getChildren >>> (none `when` isDTDDoctype) )	-- remove old DTD stuff+          )++-- ------------------------------------------------------------++hasXmlPi		:: ArrowXml a => a XmlTree XmlTree+hasXmlPi+    = fromLA+      ( getChildren+	>>>+	isPi+	>>>+	hasName t_xml+      )++-- | add an \<?xml version=\"1.0\"?\> processing instruction+-- if it's not already there++addXmlPi		:: ArrowXml a => a XmlTree XmlTree+addXmlPi+    = fromLA+      ( insertChildrenAt 0 ( ( mkPi (mkSNsName t_xml) none+			       >>>+			       addAttr a_version "1.0"+			     )+			     <+>+			     txt "\n"+			   )+	`whenNot`+	hasXmlPi+      )++-- | add an encoding spec to the \<?xml version=\"1.0\"?\> processing instruction++addXmlPiEncoding	:: ArrowXml a => String -> a XmlTree XmlTree+addXmlPiEncoding enc+    = fromLA $+      processChildren ( addAttr a_encoding enc+		        `when`+			( isPi >>> hasName t_xml )+		      )++-- | add an XHTML strict doctype declaration to a document++addXHtmlDoctypeStrict+  , addXHtmlDoctypeTransitional+  , addXHtmlDoctypeFrameset	:: ArrowXml a => a XmlTree XmlTree++-- | add an XHTML strict doctype declaration to a document++addXHtmlDoctypeStrict+    = addDoctypeDecl "html" "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"++-- | add an XHTML transitional doctype declaration to a document++addXHtmlDoctypeTransitional+    = addDoctypeDecl "html" "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"++-- | add an XHTML frameset doctype declaration to a document++addXHtmlDoctypeFrameset+    = addDoctypeDecl "html" "-//W3C//DTD XHTML 1.0 Frameset//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd"++-- | add a doctype declaration to a document+--+-- The arguments are the root element name, the PUBLIC id and the SYSTEM id++addDoctypeDecl	:: ArrowXml a => String -> String -> String -> a XmlTree XmlTree+addDoctypeDecl rootElem public system+    = fromLA $+      replaceChildren+      ( mkDTDDoctype ( ( if null public then id else ( (k_public, public) : ) )+		       .+		       ( if null system then id else ( (k_system, system) : ) )+		       $  [ (a_name, rootElem) ]+		     ) none+	<+>+	txt "\n"+	<+>+	getChildren+      )++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/Arrow/GeneralEntitySubstitution.hs view
@@ -0,0 +1,343 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.Arrow.GeneralEntitySubstitution+   Copyright  : Copyright (C) 2005 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable+   Version    : $Id: GeneralEntitySubstitution.hs,v 1.13 2006/05/01 18:56:24 hxml Exp $++   general entity substitution++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.Arrow.GeneralEntitySubstitution+    ( processGeneralEntities )+where++import Control.Arrow				-- arrow classes+import Yuuko.Control.Arrow.ArrowList+import Yuuko.Control.Arrow.ArrowIf+import Yuuko.Control.Arrow.ArrowTree++import Yuuko.Text.XML.HXT.DOM.Interface+import Yuuko.Text.XML.HXT.Arrow.XmlArrow+import Yuuko.Text.XML.HXT.Arrow.XmlIOStateArrow++import Yuuko.Text.XML.HXT.Arrow.ParserInterface+    ( parseXmlAttrValue+    , parseXmlGeneralEntityValue+    )++import Yuuko.Text.XML.HXT.Arrow.Edit+    ( transfCharRef+    )++import Yuuko.Text.XML.HXT.Arrow.DocumentInput+    ( getXmlEntityContents+    )++import qualified Data.Map as M+    ( Map+    , empty+    , lookup+    , insert+    )++-- ------------------------------------------------------------++data GEContext+    = ReferenceInContent+    | ReferenceInAttributeValue+    | ReferenceInEntityValue+    -- or OccursInAttributeValue				-- not used during substitution but during validation+    -- or ReferenceInDTD					-- not used: syntax check detects errors++type GESubstArrow	= GEContext -> RecList -> GEArrow XmlTree XmlTree++type GEArrow b c	= IOStateArrow GEEnv b c++type RecList		= [String]++-- ------------------------------------------------------------++newtype GEEnv	= GEEnv (M.Map String GESubstArrow)++emptyGeEnv	:: GEEnv+emptyGeEnv	= GEEnv M.empty++lookupGeEnv		:: String -> GEEnv -> Maybe GESubstArrow+lookupGeEnv k (GEEnv env)+    = M.lookup k env++addGeEntry	:: String -> GESubstArrow -> GEEnv -> GEEnv+addGeEntry k a (GEEnv env)+    = GEEnv $ M.insert k a env++-- ------------------------------------------------------------++-- |+-- substitution of general entities+--+-- input: a complete document tree including root node++processGeneralEntities	:: IOStateArrow s XmlTree XmlTree+processGeneralEntities+    = ( traceMsg 1 "processGeneralEntities: collect and substitute general entities"+	>>>+	withOtherUserState emptyGeEnv (processChildren (processGeneralEntity ReferenceInContent []))+	>>>+	setDocumentStatusFromSystemState "in general entity processing"+	>>>+	traceTree+	>>>+	traceSource+      )+      `when`+      documentStatusOk++      +processGeneralEntity	:: GESubstArrow+processGeneralEntity context recl+    = choiceA [ isElem		:-> ( processAttrl (processChildren substEntitiesInAttrValue)+		                      >>>+		                      processChildren (processGeneralEntity context recl)+				    )+	      , isDTDDoctype	:-> processChildren (processGeneralEntity context recl)+	      , isDTDEntity	:-> addEntityDecl+	      , isDTDAttlist	:-> substEntitiesInAttrDefaultValue+	      , isEntityRef	:-> substEntityRef+	      , this 		:-> this+	      ]+    where+    addEntityDecl	:: GEArrow XmlTree XmlTree+    addEntityDecl+	= perform ( choiceA [ isIntern		:-> addInternalEntity		-- don't change sequence of cases+			    , isExtern		:-> addExternalEntity+			    , isUnparsed	:-> addUnparsedEntity+			    ]+		  )+	where+	isIntern	= none `when` hasDTDAttr k_system+	isExtern	= none `when` hasDTDAttr k_ndata+	isUnparsed	= this++    addInternalEntity	:: GEArrow XmlTree b+    addInternalEntity+	= ( ( getDTDAttrValue a_name+	      >>>+	      traceValue 2 (("processGeneralEntity: general entity definition for " ++) . show)+	    )+	    &&&+	    xshow (getChildren >>> isText)+	  )+          >>>+	  applyA ( arr2 $ \ entity str ->+		   listA ( ( ( txt str+			       >>>+			       parseXmlGeneralEntityValue ("general internal entity" ++ show entity)+			       >>>+			       filterErrorMsg+			     )+			     `orElse` txt ""+			   )+			   >>>+			   processGeneralEntity ReferenceInEntityValue (entity : recl)+			 )+		   >>>+		   applyA (arr $ \ ts -> insertEntity (substInternal ts) entity)+		 )+	  >>>+	  none++    addExternalEntity	:: GEArrow XmlTree b+    addExternalEntity+	= ( ( getDTDAttrValue a_name+	      >>>+	      traceValue 2 (("processGeneralEntity: external entity definition for " ++) . show)+            )+	    &&&+	    getDTDAttrValue a_url 			-- the absolute URL, not the relative in attr: k_system+	  )+	  >>>+	  applyA (arr2 $ \ entity uri -> insertEntity (substExternalParsed1Time uri) entity)+	  >>>+	  none++    addUnparsedEntity	:: GEArrow XmlTree b+    addUnparsedEntity+	= getDTDAttrValue a_name+	  >>>+	  traceValue 2 (("processGeneralEntity: unparsed entity definition for " ++) . show)+          >>>+	  applyA (arr (insertEntity substUnparsed))+	  >>>+	  none++    insertEntity	:: (String -> GESubstArrow) -> String -> GEArrow b b+    insertEntity fct entity+	= ( getUserState+	    >>>+	    applyA (arr checkDefined)+	  )+	  `guards`+	  addEntity fct entity+	where+	checkDefined geEnv+	    = maybe ok alreadyDefined . lookupGeEnv entity $ geEnv+	    where+	    ok	= this+	    alreadyDefined _+		= issueWarn ("entity " ++ show entity ++ " already defined, repeated definition ignored")++    addEntity	:: (String -> GESubstArrow) -> String -> GEArrow b b+    addEntity fct entity+	= changeUserState ins+	where+	ins _ geEnv = addGeEntry entity (fct entity) geEnv++    substEntitiesInAttrDefaultValue	:: GEArrow XmlTree XmlTree+    substEntitiesInAttrDefaultValue+	= applyA ( xshow ( getDTDAttrValue a_default			-- parse the default value+			   >>>						-- substitute entities+			   mkText					-- and convert value into a string+			   >>>+			   parseXmlAttrValue "default value of attribute"+			   >>>+			   filterErrorMsg+			   >>>+			   substEntitiesInAttrValue+			 )+		   >>> arr (setDTDAttrValue a_default)+		 )+          `when` hasDTDAttr a_default++    substEntitiesInAttrValue	:: GEArrow XmlTree XmlTree+    substEntitiesInAttrValue+	= ( processGeneralEntity ReferenceInAttributeValue recl+	    `when`+	    isEntityRef+	  )+          >>>+	  changeText normalizeWhiteSpace+	  >>>+	  transfCharRef+	where+	normalizeWhiteSpace = map ( \c -> if c `elem` "\n\t\r" then ' ' else c )+++    substEntityRef	:: GEArrow XmlTree XmlTree+    substEntityRef+	= applyA ( ( ( getEntityRef				-- get the entity name and the env+		       >>>					-- and compute the arrow to be applied+		       traceValue 2 (("processGeneralEntity: entity reference for entity " ++) . show)+		       >>>+		       traceMsg 3 ("recursion list = " ++ show recl)+		     )+		     &&&+		     getUserState+		   ) >>>+		   arr2 substA+		 )+	  `orElse` this+	  where+	  substA	:: String -> GEEnv -> GEArrow XmlTree XmlTree+	  substA entity geEnv+	      = maybe entityNotFound entityFound . lookupGeEnv entity $ geEnv+	      where+	      errMsg msg+		  = issueErr msg++	      entityNotFound+		  = errMsg ("general entity reference \"&" ++ entity ++ ";\" not processed, no definition found, (forward reference?)")++	      entityFound fct+		  | entity `elem` recl+		      = errMsg ("general entity reference \"&" ++ entity ++ ";\" not processed, cyclic definition")+		  | otherwise+		      = fct context recl++    substExternalParsed1Time				:: String -> String -> GESubstArrow+    substExternalParsed1Time uri entity cx rl+ 	= perform ( traceMsg 2 ("substExternalParsed1Time: read and parse external parsed entity " ++ show entity)+		    >>>+		    runInLocalURIContext ( root [sattr a_source uri] []		-- uri must be an absolute uri+					   >>>					-- abs uri is computed during parameter entity handling+					   listA ( getXmlEntityContents+						   >>>+						   processExternalEntityContents+						 )+					 )+		    >>>+		    applyA ( arr $ \ ts -> addEntity (substExternalParsed ts) entity )+		  )+	  >>>+	  processGeneralEntity cx rl+	where+	processExternalEntityContents	:: IOStateArrow s XmlTree XmlTree+	processExternalEntityContents+	    = ( ( documentStatusOk				-- reading entity succeeded+		  >>>						-- with content stored in a text node+		  (getChildren >>> isText)+		)+		`guards`+		( getChildren+		  >>>+		  parseXmlGeneralEntityValue ("external parsed entity " ++ show entity)+		  >>>+		  filterErrorMsg+		)+	      )+	      `orElse`+	      issueErr ("illegal value for external parsed entity " ++ show entity)++    substExternalParsed					:: XmlTrees -> String -> GESubstArrow+    substExternalParsed	ts entity ReferenceInContent rl	= includedIfValidating ts rl entity+    substExternalParsed	_  entity ReferenceInAttributeValue _+                                                        = forbidden entity "external parsed general" "in attribute value"+    substExternalParsed	_  _      ReferenceInEntityValue _+                                                        = bypassed++    substInternal					:: XmlTrees -> String -> GESubstArrow+    substInternal ts entity ReferenceInContent rl	= included          ts rl entity+    substInternal ts entity ReferenceInAttributeValue rl= includedInLiteral ts rl entity+    substInternal _  _      ReferenceInEntityValue _	= bypassed++    substUnparsed					:: String -> GESubstArrow+    substUnparsed entity ReferenceInContent        _	= forbidden entity "unparsed" "content"+    substUnparsed entity ReferenceInAttributeValue _	= forbidden entity "unparsed" "attribute value"+    substUnparsed entity ReferenceInEntityValue    _	= forbidden entity "unparsed" "entity value"++									-- XML 1.0 chapter 4.4.2+    included		:: XmlTrees -> RecList -> String -> GEArrow XmlTree XmlTree+    included ts rl entity+	= arrL (const ts)+	  >>>+	  processGeneralEntity context (entity : rl)++									-- XML 1.0 chapter 4.4.3+    includedIfValidating		:: XmlTrees -> RecList -> String -> GEArrow XmlTree XmlTree+    includedIfValidating+	= included++									-- XML 1.0 chapter 4.4.4+    forbidden		:: String -> String -> String -> GEArrow XmlTree XmlTree+    forbidden entity msg cx+ 	= issueErr ("reference of " ++ msg ++ show entity ++ " forbidden in " ++ cx)++									-- XML 1.0 chapter 4.4.5+    includedInLiteral		:: XmlTrees -> RecList -> String -> GEArrow XmlTree XmlTree+    includedInLiteral+	= included++									-- XML 1.0 chapter 4.4.7+    bypassed		:: GEArrow XmlTree XmlTree+    bypassed+	= this++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/Arrow/Namespace.hs view
@@ -0,0 +1,415 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.Arrow.Namespace+   Copyright  : Copyright (C) 2005-2008 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   namespace specific arrows++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.Arrow.Namespace+    ( attachNsEnv+    , cleanupNamespaces+    , collectNamespaceDecl+    , collectPrefixUriPairs+    , isNamespaceDeclAttr+    , getNamespaceDecl+    , processWithNsEnv+    , processWithNsEnvWithoutAttrl+    , propagateNamespaces+    , uniqueNamespaces+    , uniqueNamespacesFromDeclAndQNames+    , validateNamespaces+    )+where++import Control.Arrow				-- arrow classes+import Yuuko.Control.Arrow.ArrowList+import Yuuko.Control.Arrow.ArrowIf+import Yuuko.Control.Arrow.ArrowTree+import Yuuko.Control.Arrow.ListArrow++import Yuuko.Text.XML.HXT.DOM.Interface+import Yuuko.Text.XML.HXT.Arrow.XmlArrow++import Data.Maybe		    ( isNothing+				    , fromJust+				    )+import Data.List		    ( nub )++-- ------------------------------------------------------------++-- | test whether an attribute node contains an XML Namespace declaration++isNamespaceDeclAttr	:: ArrowXml a => a XmlTree XmlTree+isNamespaceDeclAttr+    = fromLA $+      (getAttrName >>> isA isNameSpaceName) `guards` this++-- | get the namespace prefix and the namespace URI out of+-- an attribute tree with a namespace declaration (see 'isNamespaceDeclAttr')+-- for all other nodes this arrow fails++getNamespaceDecl	:: ArrowXml a => a XmlTree (String, String)+getNamespaceDecl+    = fromLA $+      isNamespaceDeclAttr+      >>>+      ( ( getAttrName+	  >>>+	  arr getNsPrefix+	)+	&&& xshow getChildren+      )+      where+      getNsPrefix = drop 6 . qualifiedName	-- drop "xmlns:"++-- ------------------------------------------------------------++-- | collect all namespace declarations contained in a document+--+-- apply 'getNamespaceDecl' to a whole XmlTree++collectNamespaceDecl	:: LA XmlTree (String, String)+collectNamespaceDecl    = multi getAttrl >>> getNamespaceDecl++-- | collect all (namePrefix, namespaceUri) pairs from a tree+--+-- all qualified names are inspected, whether a namespace uri is defined,+-- for these uris the prefix and uri is returned. This arrow is useful for+-- namespace cleanup, e.g. for documents generated with XSLT. It can be used+-- together with 'collectNamespaceDecl' to 'cleanupNamespaces'++collectPrefixUriPairs	:: LA XmlTree (String, String)+collectPrefixUriPairs+    = multi (isElem <+> getAttrl <+> isPi)+      >>>+      getQName+      >>>+      arrL getPrefixUri+    where+    getPrefixUri	:: QName -> [(String, String)]+    getPrefixUri n+	| null uri	= []+	| px == a_xmlns+	  ||+	  px == a_xml	= []				-- these ones are reserved an predefined+	| otherwise	= [(namePrefix n, uri)]+	where+	uri = namespaceUri n+	px  = namePrefix   n++-- ------------------------------------------------------------++-- | generate unique namespaces and add all namespace declarations to the root element+--+-- Calls 'cleanupNamespaces' with 'collectNamespaceDecl'++uniqueNamespaces		:: ArrowXml a => a XmlTree XmlTree+uniqueNamespaces+    = fromLA $+      cleanupNamespaces collectNamespaceDecl++-- | generate unique namespaces and add all namespace declarations for all prefix-uri pairs in all qualified names+--+-- useful for cleanup of namespaces in generated documents.+-- Calls 'cleanupNamespaces' with @ collectNamespaceDecl \<+> collectPrefixUriPairs @++uniqueNamespacesFromDeclAndQNames	:: ArrowXml a => a XmlTree XmlTree+uniqueNamespacesFromDeclAndQNames+    = fromLA $+      cleanupNamespaces (collectNamespaceDecl <+> collectPrefixUriPairs)++-- | does the real work for namespace cleanup.+--+-- The parameter is used for collecting namespace uris and prefixes from the input tree++cleanupNamespaces	:: LA XmlTree (String, String) -> LA XmlTree XmlTree+cleanupNamespaces collectNamespaces+    = renameNamespaces $< (listA collectNamespaces >>^ (toNsEnv >>> nub))+    where+    renameNamespaces :: NsEnv -> LA XmlTree XmlTree+    renameNamespaces env+	= processBottomUp+	  ( processAttrl+	    ( ( none `when` isNamespaceDeclAttr )	-- remove all namespace declarations+	      >>>+	      changeQName renamePrefix			-- update namespace prefix of attribute names, if namespace uri is set+	    )+	    >>>+	    changeQName renamePrefix			-- update namespace prefix of element names+	  )+	  >>>+	  attachEnv env1				-- all all namespaces as attributes to the root node attribute list+	where+	renamePrefix	:: QName -> QName+	renamePrefix n+	    | isNullXName uri	= n+	    | isNothing newPx	= n+	    | otherwise		= setNamePrefix' (fromJust newPx) n+	    where+	    uri   = namespaceUri' n+	    newPx = lookup uri revEnv1+	    +        revEnv1 = map (\ (x, y) -> (y, x)) env1++	env1 :: NsEnv+	env1 = newEnv [] uris++	uris :: [XName]+	uris = nub . map snd $ env++	genPrefixes :: [XName]+        genPrefixes = map (newXName . ("ns" ++) . show) [(0::Int)..]++        newEnv	:: NsEnv -> [XName] -> NsEnv+	newEnv env' []+	    = env'++	newEnv env' (uri:rest)+	    = newEnv env'' rest+	    where+	    env''    = (prefix, uri) : env'+	    prefix+		= head (filter notAlreadyUsed $ preferedPrefixes ++ genPrefixes)+	    preferedPrefixes+		= map fst . filter ((==uri).snd) $ env+	    notAlreadyUsed s+		= isNothing . lookup s $ env'++-- ------------------------------------------------------------++-- | auxiliary arrow for processing with a namespace environment+--+-- process a document tree with an arrow, containing always the+-- valid namespace environment as extra parameter.+-- The namespace environment is implemented as a 'Yuuko.Data.AssocList.AssocList'.+-- Processing of attributes can be controlled by a boolean parameter++processWithNsEnv1	:: ArrowXml a => Bool -> (NsEnv -> a XmlTree XmlTree) -> NsEnv -> a XmlTree XmlTree+processWithNsEnv1 withAttr f env+    = ifA isElem						-- the test is just an optimization+      ( processWithExtendedEnv $< arr (extendEnv env) )		-- only element nodes contain namespace declarations+      ( processWithExtendedEnv env )+    where+    processWithExtendedEnv env'+	= f env'						-- apply the env filter+	  >>>+	  ( ( if withAttr+	      then processAttrl (f env')			-- apply the env to all attributes+	      else this+	    )+	    >>>+	    processChildren (processWithNsEnv f env')		-- apply the env recursively to all children+	  )+          `when` isElem						-- attrl and children only need processing for elem nodes++    extendEnv	:: NsEnv -> XmlTree -> NsEnv+    extendEnv env' t'+	= addEntries (toNsEnv newDecls) env'+	where+	newDecls = runLA ( getAttrl >>> getNamespaceDecl ) t'++-- ------------------------------------------------------------++-- | process a document tree with an arrow, containing always the+-- valid namespace environment as extra parameter.+--+-- The namespace environment is implemented as a 'Yuuko.Data.AssocList.AssocList'++processWithNsEnv		:: ArrowXml a => (NsEnv -> a XmlTree XmlTree) -> NsEnv -> a XmlTree XmlTree+processWithNsEnv		= processWithNsEnv1 True++-- | process all element nodes of a document tree with an arrow, containing always the+-- valid namespace environment as extra parameter. Attribute lists are not processed.+--+-- See also: 'processWithNsEnv'++processWithNsEnvWithoutAttrl	:: ArrowXml a => (NsEnv -> a XmlTree XmlTree) -> NsEnv -> a XmlTree XmlTree+processWithNsEnvWithoutAttrl	= processWithNsEnv1 False++-- -----------------------------------------------------------------------------++-- | attach all valid namespace declarations to the attribute list of element nodes.+--+-- This arrow is useful for document processing, that requires access to all namespace+-- declarations at any element node, but which cannot be done with a simple 'processWithNsEnv'.++attachNsEnv	:: ArrowXml a => NsEnv -> a XmlTree XmlTree+attachNsEnv initialEnv+    = fromLA $ processWithNsEnvWithoutAttrl attachEnv initialEnv+    where++attachEnv	:: NsEnv -> LA XmlTree XmlTree+attachEnv env+    = ( processAttrl (none `when` isNamespaceDeclAttr)+	>>>+	addAttrl (catA nsAttrl)+      )+      `when` isElem+    where+    nsAttrl		:: [LA XmlTree XmlTree]+    nsAttrl		= map nsDeclToAttr env++    nsDeclToAttr	:: (XName, XName) -> LA XmlTree XmlTree+    nsDeclToAttr (n, uri)+	= mkAttr qn (txt (show uri))+	where+	qn :: QName+	qn | isNullXName n	= mkQName' nullXName  xmlnsXName xmlnsNamespaceXName+	   | otherwise		= mkQName' xmlnsXName n          xmlnsNamespaceXName++-- -----------------------------------------------------------------------------++-- |+-- propagate all namespace declarations \"xmlns:ns=...\" to all element and attribute nodes of a document.+--+-- This arrow does not check for illegal use of namespaces.+-- The real work is done by 'propagateNamespaceEnv'.+--+-- The arrow may be applied repeatedly if neccessary.++propagateNamespaces	:: ArrowXml a => a XmlTree XmlTree+propagateNamespaces	= fromLA $+			  propagateNamespaceEnv [ (xmlXName,   xmlNamespaceXName)+						, (xmlnsXName, xmlnsNamespaceXName)+						]++-- |+-- attaches the namespace info given by the namespace table+-- to a tag node and its attributes and children.++propagateNamespaceEnv	:: NsEnv -> LA XmlTree XmlTree+propagateNamespaceEnv+    = processWithNsEnv addNamespaceUri+    where+    addNamespaceUri	:: NsEnv -> LA XmlTree XmlTree+    addNamespaceUri env'+	= choiceA [ isElem :-> changeElemName (setNamespace env')+		  , isAttr :-> attachNamespaceUriToAttr env'+		  , isPi   :-> changePiName   (setNamespace env')+		  , this   :-> this+		  ]++    attachNamespaceUriToAttr	:: NsEnv -> LA XmlTree XmlTree+    attachNamespaceUriToAttr attrEnv+	= ( ( getQName >>> isA (not . null . namePrefix) )+	    `guards`+	    changeAttrName (setNamespace attrEnv)+	  )+          `orElse`+	  ( changeAttrName (const xmlnsQN)+	    `when`+	    hasName a_xmlns+	  )++-- -----------------------------------------------------------------------------++-- |+-- validate the namespace constraints in a whole tree.+--+-- Result is the list of errors concerning namespaces.+-- Predicates 'isWellformedQName', 'isWellformedQualifiedName', 'isDeclaredNamespace'+-- and 'isWellformedNSDecl' are applied to the appropriate elements and attributes.++validateNamespaces	:: ArrowXml a => a XmlTree XmlTree+validateNamespaces	= fromLA validateNamespaces1++validateNamespaces1	:: LA XmlTree XmlTree+validateNamespaces1+    = choiceA [ isRoot	:-> ( getChildren >>> validateNamespaces1 )		-- root is correct by definition+	      , this	:-> multi validate1Namespaces+	      ]++-- |+-- a single node for namespace constrains.++validate1Namespaces	:: LA XmlTree XmlTree+validate1Namespaces+    = choiceA+      [ isElem	:-> catA [ ( getQName >>> isA ( not . isWellformedQName )+			   )+			   `guards` nsError (\ n -> "element name " ++ show n ++ " is not a wellformed qualified name" )++			 , ( getQName >>> isA ( not . isDeclaredNamespace )+			   )+			   `guards` nsError (\ n -> "namespace for prefix in element name " ++ show n ++ " is undefined" )++		         , doubleOcc $< ( (getAttrl >>> getUniversalName) >>. doubles )++			 , getAttrl >>> validate1Namespaces+		         ]++      , isAttr	:-> catA [ ( getQName >>> isA ( not . isWellformedQName )+			   )+			   `guards` nsError (\ n -> "attribute name " ++ show n ++ " is not a wellformed qualified name" )++			 , ( getQName >>> isA ( not . isDeclaredNamespace )+			   )+			   `guards` nsError (\ n -> "namespace for prefix in attribute name " ++ show n ++ " is undefined" )++			 , ( hasNamePrefix a_xmlns >>> xshow getChildren >>> isA null+			   )+			   `guards` nsError (\ n -> "namespace value of namespace declaration for " ++ show n ++ " has no value" )++                         , ( getQName >>> isA (not . isWellformedNSDecl )+			   )+			   `guards`  nsError (\ n -> "illegal namespace declaration for name " ++ n ++ " starting with reserved prefix " ++ show "xml" )+			 ]++      , isDTD	:-> catA [ isDTDDoctype <+> isDTDAttlist <+> isDTDElement <+> isDTDName+		           >>>+			   getDTDAttrValue a_name+			   >>>+			   ( isA (not . isWellformedQualifiedName)+			     `guards`+			     nsErr (\ n -> "a DTD part contains a not wellformed qualified Name: " ++ show n)+			   )++			 , isDTDAttlist+			   >>>+			   getDTDAttrValue a_value+			   >>>+			   ( isA (not . isWellformedQualifiedName)+			     `guards`+			     nsErr (\ n -> "an ATTLIST declaration contains as attribute name a not wellformed qualified Name: " ++ show n)+			   )++                         , isDTDEntity <+> isDTDPEntity <+> isDTDNotation+			   >>>+			   getDTDAttrValue a_name+			   >>>+			   ( isA (not . isNCName)+                             `guards`+			     nsErr (\ n -> "an entity or notation declaration contains a not wellformed NCName: " ++ show n)+			   )+			 ]+      , isPi	:-> catA [ getName+		           >>>+			   ( isA (not . isNCName)+			     `guards`+			     nsErr (\ n -> "a PI contains a not wellformed NCName: " ++ show n)+			   )+			 ]+      ]+    where+    nsError	:: (String -> String) -> LA XmlTree XmlTree+    nsError msg+	= (getQName >>> arr show) >>> nsErr msg++    nsErr	:: (String -> String) -> LA String XmlTree+    nsErr msg	= arr msg >>> mkError c_err++    doubleOcc	:: String -> LA XmlTree XmlTree+    doubleOcc an+	= nsError (\ n -> "multiple occurences of universal name for attributes of tag " ++ show n ++ " : " ++ show an )++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/Arrow/ParserInterface.hs view
@@ -0,0 +1,135 @@+-- |+-- interface to the HXT XML and DTD parsers+--+-- version: $Id: ParserInterface.hs,v 1.1 2006/05/01 18:56:24 hxml Exp $++module Yuuko.Text.XML.HXT.Arrow.ParserInterface+    ( module Yuuko.Text.XML.HXT.Arrow.ParserInterface )+where++import Control.Arrow+import Yuuko.Control.Arrow.ArrowList+import Yuuko.Control.Arrow.ArrowIf+import Yuuko.Control.Arrow.ArrowTree+import Yuuko.Control.Arrow.ListArrow++import Yuuko.Text.XML.HXT.Parser.XmlEntities	( xmlEntities   )+import Yuuko.Text.XML.HXT.Parser.XhtmlEntities( xhtmlEntities )++import Yuuko.Text.XML.HXT.DOM.Interface+import Yuuko.Text.XML.HXT.Arrow.XmlArrow++import qualified Yuuko.Text.XML.HXT.Parser.TagSoup		 as TS+import qualified Yuuko.Text.XML.HXT.Parser.HtmlParsec          as HP+import qualified Yuuko.Text.XML.HXT.Parser.XmlParsec           as XP+import qualified Yuuko.Text.XML.HXT.Parser.XmlDTDParser	 as DP+import qualified Yuuko.Text.XML.HXT.DTDValidation.Validation   as VA++-- ------------------------------------------------------------++parseXmlDoc			:: ArrowXml a => a (String, String) XmlTree+parseXmlDoc			=  arr2L XP.parseXmlDocument++parseXmlDTDPart			:: ArrowXml a => a (String, XmlTree) XmlTree+parseXmlDTDPart			=  arr2L XP.parseXmlDTDPart++parseXmlContent			:: ArrowXml a => a String XmlTree+parseXmlContent			=  arrL XP.xread++parseXmlEntityEncodingSpec+  , parseXmlDocEncodingSpec+  , removeEncodingSpec		:: ArrowXml a => a XmlTree XmlTree++parseXmlDocEncodingSpec		=  arrL XP.parseXmlDocEncodingSpec+parseXmlEntityEncodingSpec	=  arrL XP.parseXmlEntityEncodingSpec++removeEncodingSpec		=  arrL XP.removeEncodingSpec++parseXmlDTDdeclPart		:: ArrowXml a => a XmlTree XmlTree+parseXmlDTDdeclPart		=  arrL DP.parseXmlDTDdeclPart++parseXmlDTDdecl			:: ArrowXml a => a XmlTree XmlTree+parseXmlDTDdecl			=  arrL DP.parseXmlDTDdecl++parseXmlDTDEntityValue		:: ArrowXml a => a XmlTree XmlTree+parseXmlDTDEntityValue		=  arrL DP.parseXmlDTDEntityValue++parseXmlAttrValue		:: ArrowXml a => String -> a XmlTree XmlTree+parseXmlAttrValue context	=  arrL (XP.parseXmlAttrValue context)++parseXmlGeneralEntityValue	:: ArrowXml a => String -> a XmlTree XmlTree+parseXmlGeneralEntityValue context+				=  arrL (XP.parseXmlGeneralEntityValue context)++-- ------------------------------------------------------------++parseHtmlDoc			:: ArrowList a => a (String, String) XmlTree+parseHtmlDoc			= arr2L HP.parseHtmlDocument++parseHtmlContent		:: ArrowList a => a String XmlTree+parseHtmlContent		= arrL  HP.parseHtmlContent++parseHtmlTagSoup		:: ArrowList a => Bool -> Bool -> Bool -> Bool -> Bool -> a (String, String) XmlTree+parseHtmlTagSoup withNamespaces withWarnings preserveCmt removeWS asHtml+				= arr2L (TS.parseHtmlTagSoup withNamespaces withWarnings preserveCmt removeWS asHtml)++-- ------------------------------------------------------------++validateDoc			:: ArrowList a => a XmlTree XmlTree+validateDoc			= fromLA ( VA.validate+					   `when`+					   VA.getDTDSubset	-- validate only when DTD decl is present+					 )++transformDoc			:: ArrowList a => a XmlTree XmlTree+transformDoc			= fromLA VA.transform++-- old stuff+-- validateDoc			= arrL VA.validate+-- transformDoc			= arrL VA.transform++-- ------------------------------------------------------------++-- | substitution of all predefined XHTMT entities for none ASCII chars+--+-- This arrow recurses through a whole XML tree and substitutes all+-- entity refs within text nodes and attribute values by a text node+-- containing of a single char corresponding to this entity.+--+-- Unknown entity refs remain unchanged++substHtmlEntityRefs		:: ArrowList a => a XmlTree XmlTree+substHtmlEntityRefs		= substEntityRefs xhtmlEntities+++-- | substitution of the five predefined XMT entities, works like 'substHtmlEntityRefs'++substXmlEntityRefs		:: ArrowList a => a XmlTree XmlTree+substXmlEntityRefs		= substEntityRefs xmlEntities++-- | the entity substitution arrow called from 'substXmlEntityRefs' and 'substHtmlEntityRefs'++substEntityRefs		:: ArrowList a => [(String, Int)] -> a XmlTree XmlTree+substEntityRefs entities+    = fromLA substEntities+    where+    substEntities		:: LA XmlTree XmlTree+    substEntities+	= choiceA+	  [ isEntityRef	:-> ( substEntity $< getEntityRef )+	  , isElem	:-> ( processAttrl (processChildren substEntities)+			      >>>+			      processChildren substEntities+			    )+	  , this	:-> this+	  ]+	where+	substEntity en+	    = case (lookup en entities) of+	      Just i+		  -> txt [toEnum i] 	-- constA i >>> mkCharRef+	      Nothing+		  -> this+++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/Arrow/Pickle.hs view
@@ -0,0 +1,244 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.Arrow.Pickle+   Copyright  : Copyright (C) 2005 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable+   Version    : $Id$++Pickler functions for converting between user defined data types+and XmlTree data. Usefull for persistent storage and retreival+of arbitray data as XML documents++This module is an adaptation of the pickler combinators+developed by Andrew Kennedy+( http:\/\/research.microsoft.com\/~akenn\/fun\/picklercombinators.pdf )++The difference to Kennedys approach is that the target is not+a list of Chars but a list of XmlTrees. The basic picklers will+convert data into XML text nodes. New are the picklers for+creating elements and attributes.++One extension was neccessary: The unpickling may fail.+Therefore the unpickler has a Maybe result type.+Failure is used to unpickle optional elements+(Maybe data) and lists of arbitray length++There is an example program demonstrating the use+of the picklers for a none trivial data structure.+(see \"examples\/arrows\/pickle\" directory)++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.Arrow.Pickle+    ( xpickleDocument		 -- from this module Yuuko.Text.XML.HXT.Arrow.Pickle+    , xunpickleDocument+    , xpickleWriteDTD+    , xpickleDTD+    , checkPickler+    , xpickleVal+    , xunpickleVal+    , thePicklerDTD+    , a_addDTD++      -- from Yuuko.Text.XML.HXT.Arrow.Pickle.Xml+    , pickleDoc+    , unpickleDoc++    , PU(..)+    , XmlPickler++    , xp4Tuple+    , xp5Tuple+    , xp6Tuple+    , xpAddFixedAttr+    , xpAlt+    , xpAttr+    , xpAttrFixed+    , xpAttrImplied+    , xpChoice+    , xpCondSeq+    , xpDefault+    , xpElem+    , xpElemWithAttrValue+    , xpickle+    , xpLift+    , xpLiftMaybe+    , xpList+    , xpList1+    , xpMap+    , xpOption+    , xpPair+    , xpPrim+    , xpSeq+    , xpText+    , xpText0+    , xpTextDT+    , xpText0DT+    , xpTree+    , xpTrees+    , xpTriple+    , xpUnit+    , xpWrap+    , xpWrapMaybe+    , xpXmlText+    , xpZero++      -- from Yuuko.Text.XML.HXT.Arrow.Pickle.Schema+    , Schema+    , Schemas+    , DataTypeDescr+    )+where++import           Data.Maybe++import           Yuuko.Control.Arrow.ListArrows++import           Yuuko.Text.XML.HXT.DOM.Interface+import           Yuuko.Text.XML.HXT.Arrow.XmlArrow+import           Yuuko.Text.XML.HXT.Arrow.XmlIOStateArrow+import           Yuuko.Text.XML.HXT.Arrow.ReadDocument+import           Yuuko.Text.XML.HXT.Arrow.WriteDocument++import           Yuuko.Text.XML.HXT.Arrow.Pickle.Xml+import           Yuuko.Text.XML.HXT.Arrow.Pickle.Schema+import           Yuuko.Text.XML.HXT.Arrow.Pickle.DTD++-- ------------------------------------------------------------++-- the arrow interface for pickling and unpickling++-- | store an arbitray value in a persistent XML document+--+-- The pickler converts a value into an XML tree, this is written out with+-- 'Yuuko.Text.XML.HXT.Arrow.writeDocument'. The option list is passed to 'Yuuko.Text.XML.HXT.Arrow.writeDocument'+--+-- An option evaluated by this arrow is 'a_addDTD'.+-- If 'a_addDTD' is set ('v_1'), the pickler DTD is added as an inline DTD into the document.++xpickleDocument		:: PU a -> Attributes -> String -> IOStateArrow s a XmlTree+xpickleDocument xp al dest+    = xpickleVal xp+      >>>+      traceMsg 1 "xpickleVal applied"+      >>>+      ( if lookup1 a_addDTD al == v_1+	then replaceChildren ( (constA undefined >>> xpickleDTD xp >>> getChildren)+			       <+>+			       getChildren+			     )+	else this+      )+      >>>+      writeDocument al dest++-- | Option for generating and adding DTD when document is pickled++a_addDTD	:: String+a_addDTD	= "addDTD"++-- | read an arbitray value from an XML document+--+-- The document is read with 'Yuuko.Text.XML.HXT.Arrow.readDocument'. Options are passed+-- to 'Yuuko.Text.XML.HXT.Arrow.readDocument'. The conversion from XmlTree is done with the+-- pickler.+--+-- @ xpickleDocument xp al dest >>> xunpickleDocument xp al' dest @ is the identity arrow+-- when applied with the appropriate options. When during pickling indentation is switched on,+-- the whitespace must be removed during unpickling.++xunpickleDocument	:: PU a -> Attributes -> String -> IOStateArrow s b a+xunpickleDocument xp al src+			= readDocument al src+			  >>>+			  traceMsg 1 ("xunpickleVal for " ++ show src ++ " started")+			  >>>+			  xunpickleVal xp+			  >>>+			  traceMsg 1 ("xunpickleVal for " ++ show src ++ " finished")++-- | Write out the DTD generated out of a pickler. Calls 'xpicklerDTD'++xpickleWriteDTD		:: PU b -> Attributes -> String -> IOStateArrow s b XmlTree+xpickleWriteDTD	xp al dest+			= xpickleDTD xp+			  >>>+			  writeDocument al dest++-- | The arrow for generating the DTD out of a pickler+--+-- A DTD is generated from a pickler and check for consistency.+-- Errors concerning the DTD are issued.++xpickleDTD		:: PU b -> IOStateArrow s b XmlTree+xpickleDTD xp		= root [] [ constL (thePicklerDTD xp)+				    >>>+				    filterErrorMsg+				  ]++-- | An arrow for checking picklers+--+-- A value is transformed into an XML document by a given pickler,+-- the associated DTD is extracted from the pickler and checked,+-- the document including the DTD is tranlated into a string,+-- this string is read and validated against the included DTD,+-- and unpickled.+-- The last step is the equality with the input.+--+-- If the check succeeds, the arrow works like this, else it fails.++checkPickler		:: Eq a => PU a -> IOStateArrow s a a+checkPickler xp		= ( ( ( ( xpickleVal xp+				  >>>+				  replaceChildren ( (constA undefined >>> xpickleDTD xp >>> getChildren)+						    <+>+						    getChildren+						  )+				  >>>+				  writeDocumentToString []+				  >>>+				  readFromString [(a_validate, v_1)]+				  >>>+				  ( xunpickleVal xp+				    `orElse`+				    ( issueErr "unpickling the document failed"+				      >>>+				      none+				    )+				  )+				)+				&&& +				this+			      )+			      >>> isA (uncurry (==))+			    )+			    `guards` this+			  )+			  `orElse` issueErr "pickle/unpickle combinators failed"++-- | The arrow version of the pickler function++xpickleVal		:: ArrowXml a => PU b -> a b XmlTree+xpickleVal xp		= arr (pickleDoc xp)++-- | The arrow version of the unpickler function++xunpickleVal		:: ArrowXml a => PU b -> a XmlTree b+xunpickleVal xp		= arrL (maybeToList . unpickleDoc xp)+++-- | Compute the associated DTD of a pickler++thePicklerDTD		:: PU b -> XmlTrees+thePicklerDTD		= dtdDescrToXml . dtdDescr . theSchema++-- ------------------------------------------------------------++
+ src/Yuuko/Text/XML/HXT/Arrow/Pickle/DTD.hs view
@@ -0,0 +1,332 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.Arrow.Pickle.DTD+   Copyright  : Copyright (C) 2005 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable+   Version    : $Id$++Functions for converting a pickler schema+into a DTD++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.Arrow.Pickle.DTD+where++import           Data.Maybe++import qualified Yuuko.Text.XML.HXT.DOM.XmlNode as XN++import           Yuuko.Text.XML.HXT.DOM.Interface+import           Yuuko.Text.XML.HXT.Arrow.Pickle.Schema+import           Yuuko.Text.XML.HXT.RelaxNG.XmlSchema.DataTypeLibW3C++-- ------------------------------------------------------------++data DTDdescr			= DTDdescr Name Schemas [(Name,Schemas)]++instance Show DTDdescr where+    show (DTDdescr n es as)+	= "root element: " ++ n ++ "\n"+	  +++	  "elements:\n"+	  +++	  concatMap ((++ "\n") .show) es+	  +++	  "attributes:\n"+	  +++	  concatMap ((++ "\n") . showAttr) as+	where+	showAttr (n1, sc) = n1 ++ ": " ++ show sc++-- ------------------------------------------------------------++-- | convert a DTD descr into XmlTrees++dtdDescrToXml	:: DTDdescr -> XmlTrees+dtdDescrToXml (DTDdescr rt es as)+    = checkErr (null rt) "no unique root element found in pickler DTD, add an \"xpElem\" pickler"+      +++      concatMap (checkErr True . ("no element decl found in: " ++) . show) (filter (not . isScElem) es)+      +++      concatMap (uncurry checkContentModell . \ (Element n sc) -> (n,sc)) es1+      +++      concatMap (uncurry checkAttrModell) as+      +++      [ XN.mkDTDElem DOCTYPE docAttrs ( concatMap elemDTD es1+					+++					concatMap (uncurry attrDTDs) as+				      ) ]+    where+    es1 		= filter isScElem es+    +    docAttrs		= [(a_name, if null rt then "no-unique-root-element-found" else rt)]++    elemDTD (Element n sc)+	| lookup1 a_type al == "unknown"+	    = cl+	| otherwise+	    = [ XN.mkDTDElem ELEMENT ((a_name, n) : al) cl ]+	where+	(al, cl) = scContToXml sc+    elemDTD _+	= error "illegal case in elemDTD"++    attrDTDs en		= concatMap (attrDTD en)+    attrDTD en (Attribute an sc)+	    		= [ XN.mkDTDElem ATTLIST ((a_name, en) : (a_value, an) : al) cl ]+			  where+			  (al, cl) = scAttrToXml sc+    attrDTD _ _		= error "illegal case in attrDTD"+++checkAttrModell					:: Name -> Schemas -> XmlTrees+checkAttrModell n				= concatMap (checkAM n)++checkAM						:: Name -> Schema -> XmlTrees+checkAM en (Attribute an sc)			= checkAMC en an sc+checkAM _ _					= []++checkAMC					:: Name -> Name -> Schema -> XmlTrees+checkAMC _en _an (CharData _)			= []+checkAMC en an sc+    | isScCharData sc	= []+    | isScList sc+      &&+      (sc_1 sc == scNmtoken)+			= []+    | isScOpt sc	= checkAMC en an (sc_1 sc)+    | otherwise		= foundErr+			  ( "weird attribute type found for attribute "+			    ++ show an+			    ++ " for element "+			    ++ show en+			    ++ "\n\t(internal structure: " ++ show sc ++ ")"+			    ++ "\n\thint: create an element instead of an attribute for "+			    ++ show an+			  )++-- checkContentModell1 n sc = foundErr (n ++ " : " ++ show sc) ++ checkContentModell n sc++checkContentModell				:: Name -> Schema -> XmlTrees++checkContentModell _ Any+    = []++checkContentModell _ (ElemRef _)+    = []++checkContentModell _ (CharData _)+    = []++checkContentModell _ (Seq [])+    = []++checkContentModell n (Seq scs)+    = checkErr pcDataInCM+      ( "PCDATA found in a sequence spec in the content modell for "+	++ show n+	++ "\n\thint: create an element for this data"+      )+      +++      checkErr somethingElseInCM+      ( "something weired found in a sequence spec in the content modell for "+	++ show n+      )+      +++      concatMap (checkContentModell n) scs+    where+    pcDataInCM        = any isScCharData scs+    somethingElseInCM = any (\ sc -> not (isScSARE sc) && not (isScCharData sc)) scs++checkContentModell n (Alt scs)+    = checkErr mixedCM+      ( "PCDATA mixed up with illegal content spec in mixed contents for "+	++ show n+	++ "\n\thint: create an element for this data"+      )+      +++      concatMap (checkContentModell n) scs+    where+    mixedCM+	| any isScCharData scs+	    = any (not . isScElemRef) . filter (not . isScCharData) $ scs+	| otherwise+	    = False++checkContentModell _ (Rep _ _ (ElemRef _))+    = []++checkContentModell n (Rep _ _ sc@(Seq _))+    = checkContentModell n sc++checkContentModell n (Rep _ _ sc@(Alt _))+    = checkContentModell n sc++checkContentModell n (Rep _ _ _)+    = foundErr+      ( "illegal content spec found for "+	++ show n+      )++checkContentModell _ _+    = []+++scContToXml			:: Schema -> (Attributes, XmlTrees)++scContToXml Any			= ( [(a_type, v_any)],    [] )+scContToXml (CharData _)	= ( [(a_type, v_pcdata)], [] )+scContToXml (Seq [])		= ( [(a_type, v_empty)],  [] )+scContToXml sc@(ElemRef _)	= scContToXml (Seq [sc])+scContToXml sc@(Seq _)		= ( [(a_type, v_children)]+				  , scCont [] sc+				  )+scContToXml sc@(Alt sc1)+    | isMixed sc1		= ( [(a_type, v_mixed)]+				  , scCont [ (a_modifier, "*") ] sc+				  )+    | otherwise			= ( [(a_type, v_children)]+				  , scCont [] sc+				  ) +    where+    isMixed			= not . null . filter isScCharData+scContToXml sc@(Rep _ _ _)	= ( [(a_type, v_children)]+				  , scCont [] sc+				  )+scContToXml _sc			= ( [(a_type, v_any)]		-- default: everything is allowed+				  , []+				  )++scWrap				:: Schema -> Schema+scWrap sc@(Alt _)		= sc+scWrap sc@(Seq _)		= sc+scWrap sc@(Rep _ _  _)		= sc+scWrap sc			= Seq [sc]++scCont				:: Attributes -> Schema -> XmlTrees+scCont al (Seq scs)		= scConts ((a_kind, v_seq   ) : al) scs+scCont al (Alt scs)		= scConts ((a_kind, v_choice) : al) scs+scCont al (Rep 0 (-1) sc)	= scCont ((a_modifier, "*")   : al) (scWrap sc)+scCont al (Rep 1 (-1) sc)	= scCont ((a_modifier, "+")   : al) (scWrap sc)+scCont al (Rep 0 1    sc)	= scCont ((a_modifier, "?")   : al) (scWrap sc)+scCont al (ElemRef n)		= [XN.mkDTDElem NAME ((a_name, n) : al) []]+scCont _  (CharData _)		= [XN.mkDTDElem NAME [(a_name, "#PCDATA")] []]+scCont _  _sc			= [XN.mkDTDElem NAME [(a_name, "bad-content-spec")] []]		-- error case++scConts				:: Attributes -> Schemas -> XmlTrees+scConts al scs			= [XN.mkDTDElem CONTENT al (concatMap (scCont []) scs)]++scAttrToXml			:: Schema -> (Attributes, XmlTrees)++scAttrToXml sc+    | isScFixed	sc		= ( [ (a_kind, k_fixed)+				    , (a_type, k_cdata)+				    , (a_default, (xsdParam xsd_enumeration sc))+				    ]+				  , [])+    | isScEnum sc		= ( [ (a_kind, k_required)+				    , (a_type, k_enumeration)+				    ]+				  , map (\ n -> XN.mkDTDElem NAME [(a_name, n)] []) enums+				  )+    | isScCharData sc		= ( [ (a_kind, k_required)+				    , (a_type, d_type)+				    ]+				  , [])+    | isScOpt sc		= (addEntry a_kind k_implied al, cl)+    | isScList sc		= (addEntry a_type k_nmtokens al, cl)+    | otherwise			= ( [ (a_kind, k_fixed)+				    , (a_default, "bad-attribute-type: " ++ show sc)+				    ]+				  , [] )+    where+    (al, cl)			= scAttrToXml (sc_1 sc)+    d_type+	| sc == scNmtoken	= k_nmtoken+	| otherwise		= k_cdata+    enums			= words . xsdParam xsd_enumeration $ sc++checkErr			:: Bool -> String -> XmlTrees+checkErr True s			= [XN.mkError c_err s]+checkErr _    _			= []++foundErr			:: String -> XmlTrees+foundErr			= checkErr True++-- ------------------------------------------------------------++-- | convert a pickler schema into a DTD descr++dtdDescr	:: Schema -> DTDdescr+dtdDescr sc+    = DTDdescr rt es1 as+    where+    es  = elementDeclarations sc+    es1 = map remAttrDec es+    as  = filter (not. null . snd) . concatMap attrDec $ es+    rt  = fromMaybe "" . elemName $ sc++elementDeclarations	:: Schema -> Schemas+elementDeclarations sc	= elemRefs . elementDecs [] $ [sc]++elementDecs		:: Schemas -> Schemas -> Schemas+elementDecs es []+    = es+elementDecs es (s:ss)+    = elementDecs (elemDecs s) ss+    where+    elemDecs (Seq scs)		= elementDecs es scs+    elemDecs (Alt scs)		= elementDecs es scs+    elemDecs (Rep _ _ sc)	= elemDecs sc+    elemDecs e@(Element n sc)+	| n `elem` elemNames es	= es+	| otherwise             = elementDecs (e:es) [sc]+    elemDecs _			= es++elemNames		:: Schemas -> [Name]+elemNames               = concatMap (maybeToList . elemName)++elemName		:: Schema -> Maybe Name+elemName (Element n _)  = Just n+elemName _              = Nothing++elemRefs	:: Schemas -> Schemas+elemRefs	= map elemRef+    where+    elemRef (Element n sc)   = Element n (pruneElem sc)+    elemRef sc               = sc+    pruneElem (Element n _)  = ElemRef n+    pruneElem (Seq scs)      = Seq (map pruneElem scs)+    pruneElem (Alt scs)      = Alt (map pruneElem scs)+    pruneElem (Rep l u sc)   = Rep l u (pruneElem sc)+    pruneElem sc             = sc++attrDec			:: Schema -> [(Name, Schemas)]+attrDec (Element n sc)+    = [(n, attrDecs sc)]+      where+      attrDecs a@(Attribute _ _)	= [a]+      attrDecs (Seq scs)		= concatMap attrDecs scs+      attrDecs _			= []+attrDec _		= []++remAttrDec		:: Schema -> Schema+remAttrDec (Element n sc)+    = Element n (remA sc)+      where+      remA (Attribute _ _) = scEmpty+      remA (Seq scs)       = scSeqs . map remA $ scs+      remA sc1             = sc1+remAttrDec _+    = error "illegal case in remAttrDec"++-- ------------------------------------------------------------+
+ src/Yuuko/Text/XML/HXT/Arrow/Pickle/Schema.hs view
@@ -0,0 +1,221 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.Arrow.Pickle.Schema+   Copyright  : Copyright (C) 2005 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable+   Version    : $Id$++Datatypes and functions for building a content model+for XML picklers. A schema is part of every pickler+and can be used to derive a corrensponding DTD (or Relax NG schema).+This schema further enables checking the picklers.++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.Arrow.Pickle.Schema+where++import Yuuko.Text.XML.HXT.DOM.TypeDefs+import Yuuko.Text.XML.HXT.RelaxNG.XmlSchema.DataTypeLibW3C++import Data.List+    ( sort )++-- ------------------------------------------------------------++-- | The datatype for modelling the structure of an++data Schema			= Any+				| Seq		{ sc_l	:: [Schema]+						}+				| Alt		{ sc_l	:: [Schema]+						}+				| Rep		{ sc_lb	:: Int+						, sc_ub	:: Int+						, sc_1	:: Schema+						}+				| Element	{ sc_n	:: Name+						, sc_1	:: Schema+						}+				| Attribute	{ sc_n	:: Name+						, sc_1	:: Schema+						}+				| ElemRef	{ sc_n	:: Name+						}+				| CharData	{ sc_dt	:: DataTypeDescr+						}+				  deriving (Eq, Show)++type Name			= String+type Schemas			= [Schema]++data DataTypeDescr		= DTDescr { dtLib    :: String+					  , dtName   :: String+					  , dtParams :: Attributes+					  }+				  deriving (Show)++instance Eq DataTypeDescr where+    x1 == x2 = dtLib x1 == dtLib x2+	       &&+	       dtName x1 == dtName x2+	       &&+	       sort (dtParams x1) == sort (dtParams x2)++-- ------------------------------------------------------------++-- | test: is schema a simple XML Schema datatype++isScXsd			:: (String -> Bool) -> Schema -> Bool++isScXsd p (CharData (DTDescr lib n _ps))+			= lib == w3cNS+			  &&+			  p n+isScXsd _ _		= False++-- | test: is type a fixed value attribute type++isScFixed		:: Schema -> Bool+isScFixed sc		= isScXsd (== xsd_string) sc+			  &&+			  ((== 1) . length . words . xsdParam xsd_enumeration) sc++isScEnum		:: Schema -> Bool+isScEnum sc		= isScXsd (== xsd_string) sc+			  &&+			  (not . null . xsdParam xsd_enumeration) sc++isScElem		:: Schema -> Bool+isScElem (Element _ _)	= True+isScElem _		= False++isScAttr		:: Schema -> Bool+isScAttr (Attribute _ _)= True+isScAttr _		= False++isScElemRef		:: Schema -> Bool+isScElemRef (ElemRef _)	= True+isScElemRef _		= False++isScCharData		:: Schema -> Bool+isScCharData (CharData _)= True+isScCharData _		= False++isScSARE		:: Schema -> Bool+isScSARE (Seq _)	= True+isScSARE (Alt _)	= True+isScSARE (Rep _ _ _)	= True+isScSARE (ElemRef _)	= True+isScSARE _		= False++isScList		:: Schema -> Bool+isScList (Rep 0 (-1) _)	= True+isScList _		= False++isScOpt			:: Schema -> Bool+isScOpt (Rep 0 1 _)	= True+isScOpt _		= False++-- | access an attribute of a descr of an atomic type++xsdParam		:: String -> Schema -> String+xsdParam n (CharData dtd)+                        = lookup1 n (dtParams dtd)+xsdParam _ _            = ""++-- ------------------------------------------------------------++-- smart constructors for Schema datatype++-- ------------------------------------------------------------+--+-- predefined xsd data types for representation of DTD types++scDT		:: String -> String -> Attributes -> Schema+scDT l n rl	= CharData $ DTDescr l n rl++scDTxsd		:: String -> Attributes -> Schema+scDTxsd		= scDT w3cNS++scString	:: Schema+scString	= scDTxsd xsd_string []++scString1	:: Schema+scString1	= scDTxsd xsd_string [(xsd_minLength, "1")]++scFixed		:: String -> Schema+scFixed v	= scDTxsd xsd_string [(xsd_enumeration, v)]++scEnum		:: [String] -> Schema+scEnum vs	= scFixed (unwords vs)++scNmtoken	:: Schema+scNmtoken	= scDTxsd xsd_NCName []++scNmtokens	:: Schema+scNmtokens	= scList scNmtoken++-- ------------------------------------------------------------++scEmpty				:: Schema+scEmpty				= Seq []++scSeq				:: Schema -> Schema -> Schema+scSeq (Seq [])   sc2		= sc2+scSeq sc1        (Seq [])	= sc1+scSeq (Seq scs1) (Seq scs2)	= Seq (scs1 ++ scs2)	-- prevent nested Seq expr+scSeq (Seq scs1) sc2		= Seq (scs1 ++ [sc2])+scSeq sc1        (Seq scs2)	= Seq (sc1  :  scs2)+scSeq sc1        sc2		= Seq [sc1,sc2]++scSeqs				:: [Schema] -> Schema+scSeqs				= foldl scSeq scEmpty++scNull				:: Schema+scNull				= Alt []++scAlt				:: Schema -> Schema -> Schema+scAlt (Alt [])   sc2		= sc2+scAlt sc1        (Alt [])	= sc1+scAlt (Alt scs1) (Alt scs2)	= Alt (scs1 ++ scs2)	-- prevent nested Alt expr+scAlt (Alt scs1) sc2		= Alt (scs1 ++ [sc2])+scAlt sc1        (Alt scs2)	= Alt (sc1  :  scs2)+scAlt sc1        sc2		= Alt [sc1,sc2]++scAlts		:: [Schema] -> Schema+scAlts		= foldl scAlt scNull++scOption	:: Schema -> Schema+scOption     (Seq [])		= scEmpty+scOption (Attribute n sc2)	= Attribute n (scOption sc2)+scOption sc1+    | sc1 == scString1		= scString+    | otherwise			= scOpt sc1++scList		:: Schema -> Schema+scList		= scRep 0 (-1)++scList1		:: Schema -> Schema+scList1		= scRep 1 (-1)++scOpt		:: Schema -> Schema+scOpt		= scRep 0 1++scRep		:: Int -> Int -> Schema -> Schema+scRep l u sc1  = Rep l u sc1++scElem		:: String -> Schema -> Schema+scElem n sc1	= Element n sc1++scAttr		:: String -> Schema -> Schema+scAttr n sc1	= Attribute n sc1++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/Arrow/Pickle/Xml.hs view
@@ -0,0 +1,694 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.Arrow.Pickle.Xml+   Copyright  : Copyright (C) 2005-2008 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   Pickler functions for converting between user defined data types+   and XmlTree data. Usefull for persistent storage and retreival+   of arbitray data as XML documents++   This module is an adaptation of the pickler combinators+   developed by Andrew Kennedy+   ( http:\/\/research.microsoft.com\/~akenn\/fun\/picklercombinators.pdf )++   The difference to Kennedys approach is that the target is not+   a list of Chars but a list of XmlTrees. The basic picklers will+   convert data into XML text nodes. New are the picklers for+   creating elements and attributes.++   One extension was neccessary: The unpickling may fail.+   Therefore the unpickler has a Maybe result type.+   Failure is used to unpickle optional elements+   (Maybe data) and lists of arbitray length++   There is an example program demonstrating the use+   of the picklers for a none trivial data structure.+   (see \"examples\/arrows\/pickle\" directory)++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.Arrow.Pickle.Xml+where++import           Data.Maybe+import		 Data.Map (Map)+import qualified Data.Map as M++import           Yuuko.Text.XML.HXT.DOM.Interface+import qualified Yuuko.Text.XML.HXT.DOM.XmlNode as XN++import           Yuuko.Control.Arrow.ListArrows+import           Yuuko.Text.XML.HXT.Arrow.XmlArrow+import           Yuuko.Text.XML.HXT.Arrow.Pickle.Schema+import           Yuuko.Text.XML.HXT.Arrow.ReadDocument  (xread)+import           Yuuko.Text.XML.HXT.Arrow.Edit          (xshowEscapeXml)++-- ------------------------------------------------------------++data St		= St { attributes :: [XmlTree]+		     , contents   :: [XmlTree]+		     }++data PU a	= PU { appPickle   :: (a, St) -> St+		     , appUnPickle :: St -> (Maybe a, St)+		     , theSchema   :: Schema+		     }++emptySt		:: St+emptySt		=  St { attributes = []+		      , contents   = []+		      }++addAtt		:: XmlTree -> St -> St+addAtt x s	= s {attributes = x : attributes s}++addCont		:: XmlTree -> St -> St+addCont x s	= s {contents = x : contents s}++dropCont	:: St -> St+dropCont s	= s { contents = drop 1 (contents s) }++getAtt		:: QName -> St -> Maybe XmlTree+getAtt qn s+    = listToMaybe $+      runLA ( arrL attributes+	      >>>+	      isAttr >>> hasQName qn+	    ) s++getCont		:: St -> Maybe XmlTree+getCont s	= listToMaybe . contents $ s++-- ------------------------------------------------------------++-- | conversion of an arbitrary value into an XML document tree.+--+-- The pickler, first parameter, controls the conversion process.+-- Result is a complete document tree including a root node++pickleDoc	:: PU a -> a -> XmlTree+pickleDoc p v+    = XN.mkRoot (attributes st) (contents st)+    where+    st = appPickle p (v, emptySt)++-- | Conversion of an XML document tree into an arbitrary data type+--+-- The inverse of 'pickleDoc'.+-- This law should hold for all picklers: @ unpickle px . pickle px $ v == Just v @.+-- Not every possible combination of picklers make sense.+-- For reconverting a value from an XML tree, is becomes neccessary,+-- to introduce \"enough\" markup for unpickling the value++unpickleDoc :: PU a -> XmlTree -> Maybe a+unpickleDoc p t+    | XN.isRoot t+	= fst . appUnPickle p $ St { attributes = fromJust . XN.getAttrl $  t+				   , contents   =            XN.getChildren t+				   }+    | otherwise+	= unpickleDoc p (XN.mkRoot [] [t])++-- ------------------------------------------------------------++-- | The zero pickler+--+-- Encodes nothing, fails always during unpickling++xpZero			:: PU a+xpZero			=  PU { appPickle   = snd+			      , appUnPickle = \ s -> (Nothing, s)+			      , theSchema   = scNull+			      }++-- unit pickler++xpUnit			:: PU ()+xpUnit			= xpLift ()++-- | Lift a value to a pickler+--+-- When pickling, nothing is encoded, when unpickling, the given value is inserted.+-- This pickler always succeeds.++xpLift			:: a -> PU a+xpLift x		=  PU { appPickle   = snd+			      , appUnPickle = \ s -> (Just x, s)+			      , theSchema   = scEmpty+			      }++-- | Lift a Maybe value to a pickler.+--+-- @Nothing@ is mapped to the zero pickler, @Just x@ is pickled with @xpLift x@.++xpLiftMaybe		:: Maybe a -> PU a+xpLiftMaybe v		= (xpLiftMaybe' v) { theSchema = scOption scEmpty }+    where+    xpLiftMaybe' Nothing	= xpZero+    xpLiftMaybe' (Just x) 	= xpLift x+++-- | pickle\/unpickle combinator for sequence and choice.+--+-- When the first unpickler fails,+-- the second one is taken, else the third one configured with the result from the first+-- is taken. This pickler is a generalisation for 'xpSeq' and 'xpChoice' .+--+-- The schema must be attached later, e.g. in xpPair or other higher level combinators++xpCondSeq	:: PU b -> (b -> a) -> PU a -> (a -> PU b) -> PU b+xpCondSeq pd f pa k+    = PU { appPickle   = ( \ (b, s) ->+	                   let+			   a  = f b+			   pb = k a+			   in+			   appPickle pa (a, (appPickle pb (b, s)))+			 )+	 , appUnPickle = ( \ s ->+			   let+			   (a, s') = appUnPickle pa s+			   in+			   case a of+			   Nothing -> appUnPickle pd     s+			   Just a' -> appUnPickle (k a') s'+			 )+	 , theSchema   = undefined+	 }+++-- | Combine two picklers sequentially.+--+-- If the first fails during+-- unpickling, the whole unpickler fails++xpSeq	:: (b -> a) -> PU a -> (a -> PU b) -> PU b+xpSeq	= xpCondSeq xpZero+++-- | combine tow picklers with a choice+--+-- Run two picklers in sequence like with xpSeq.+-- When during unpickling the first one fails,+-- an alternative pickler (first argument) is applied.+-- This pickler is only used as combinator for unpickling.+ +xpChoice		:: PU b -> PU a -> (a -> PU b) -> PU b+xpChoice pb	= xpCondSeq pb undefined+++-- | map value into another domain and apply pickler there+--+-- One of the most often used picklers.++xpWrap			:: (a -> b, b -> a) -> PU a -> PU b+xpWrap (i, j) pa	= (xpSeq j pa (xpLift . i)) { theSchema = theSchema pa }++-- | like 'xpWrap', but if the inverse mapping is undefined, the unpickler fails+--+-- Map a value into another domain. If the inverse mapping is+-- undefined (Nothing), the unpickler fails++xpWrapMaybe		:: (a -> Maybe b, b -> a) -> PU a -> PU b+xpWrapMaybe (i, j) pa	= (xpSeq j pa (xpLiftMaybe . i)) { theSchema = theSchema pa }++-- | pickle a pair of values sequentially+--+-- Used for pairs or together with wrap for pickling+-- algebraic data types with two components++xpPair	:: PU a -> PU b -> PU (a, b)+xpPair pa pb+    = ( xpSeq fst pa (\ a ->+        xpSeq snd pb (\ b ->+        xpLift (a,b)))+      ) { theSchema = scSeq (theSchema pa) (theSchema pb) }++-- | Like 'xpPair' but for triples++xpTriple	:: PU a -> PU b -> PU c -> PU (a, b, c)+xpTriple pa pb pc+    = xpWrap (toTriple, fromTriple) (xpPair pa (xpPair pb pc))+    where+    toTriple   ~(a, ~(b, c)) = (a,  b, c )+    fromTriple ~(a,   b, c ) = (a, (b, c))++-- | Like 'xpPair' and 'xpTriple' but for 4-tuples++xp4Tuple	:: PU a -> PU b -> PU c -> PU d -> PU (a, b, c, d)+xp4Tuple pa pb pc pd+    = xpWrap (toQuad, fromQuad) (xpPair pa (xpPair pb (xpPair pc pd)))+    where+    toQuad   ~(a, ~(b, ~(c, d))) = (a,  b,  c, d  )+    fromQuad ~(a,   b,   c, d  ) = (a, (b, (c, d)))++-- | Like 'xpPair' and 'xpTriple' but for 5-tuples++xp5Tuple	:: PU a -> PU b -> PU c -> PU d -> PU e -> PU (a, b, c, d, e)+xp5Tuple pa pb pc pd pe+    = xpWrap (toQuint, fromQuint) (xpPair pa (xpPair pb (xpPair pc (xpPair pd pe))))+    where+    toQuint   ~(a, ~(b, ~(c, ~(d, e)))) = (a,  b,  c,  d, e   )+    fromQuint ~(a,   b,   c,   d, e   ) = (a, (b, (c, (d, e))))++-- | Like 'xpPair' and 'xpTriple' but for 6-tuples++xp6Tuple	:: PU a -> PU b -> PU c -> PU d -> PU e -> PU f -> PU (a, b, c, d, e, f)+xp6Tuple pa pb pc pd pe pf+    = xpWrap (toSix, fromSix) (xpPair pa (xpPair pb (xpPair pc (xpPair pd (xpPair pe pf)))))+    where+    toSix   ~(a, ~(b, ~(c, ~(d, ~(e, f))))) = (a,  b,  c,  d,  e, f    )+    fromSix ~(a,   b,   c,   d,   e, f)     = (a, (b, (c, (d, (e, f)))))++-- | Pickle a string into an XML text node+--+-- One of the most often used primitive picklers. Attention:+-- For pickling empty strings use 'xpText0'. If the text has a more+-- specific datatype than xsd:string, use 'xpTextDT'++xpText	:: PU String+xpText	= xpTextDT scString1++-- | Pickle a string into an XML text node+--+-- Text pickler with a description of the structure of the text+-- by a schema. A schema for a data type can be defined by 'Yuuko.Text.XML.HXT.Arrow.Pickle.Schema.scDT'.+-- In 'Yuuko.Text.XML.HXT.Arrow.Pickle.Schema' there are some more functions for creating+-- simple datatype descriptions.++xpTextDT	:: Schema -> PU String+xpTextDT sc+    = PU { appPickle   = \ (s, st) -> addCont (XN.mkText s) st+	 , appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleString st)+	 , theSchema   = sc+	 }+    where+    unpickleString st+	= do+	  t <- getCont st+	  s <- XN.getText t+	  return (Just s, dropCont st)++-- | Pickle a possibly empty string into an XML node.+--+-- Must be used in all places, where empty strings are legal values.+-- If the content of an element can be an empty string, this string disapears+-- during storing the DOM into a document and reparse the document.+-- So the empty text node becomes nothing, and the pickler must deliver an empty string,+-- if there is no text node in the document.++xpText0	:: PU String+xpText0	= xpText0DT scString1++-- | Pickle a possibly empty string with a datatype description into an XML node.+--+-- Like 'xpText0' but with extra Parameter for datatype description as in 'xpTextDT'.++xpText0DT	:: Schema -> PU String+xpText0DT sc+    = xpWrap (fromMaybe "", emptyToNothing) $ xpOption $ xpTextDT sc+    where+    emptyToNothing "" = Nothing+    emptyToNothing x  = Just x++-- | Pickle an arbitrary value by applyling show during pickling+-- and read during unpickling.+--+-- Real pickling is then done with 'xpText'.+-- One of the most often used pimitive picklers. Applicable for all+-- types which are instances of @Read@ and @Show@++xpPrim	:: (Read a, Show a) => PU a+xpPrim+    = xpWrapMaybe (readMaybe, show) xpText+    where+    readMaybe	:: Read a => String -> Maybe a+    readMaybe str+	= val (reads str)+	where+	val [(x,"")] = Just x+	val _        = Nothing++-- ------------------------------------------------------------++-- | Pickle an XmlTree by just adding it+--+-- Usefull for components of type XmlTree in other data structures++xpTree	:: PU XmlTree+xpTree	= PU { appPickle   = \ (s, st) -> addCont s st+	     , appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleTree st)+	     , theSchema   = Any+	     }+    where+    unpickleTree st+	= do+	  t <- getCont st+	  return (Just t, dropCont st)++-- | Pickle a whole list of XmlTrees by just adding the list, unpickle is done by taking all element contens.+--+-- This pickler should always combined with 'xpElem' for taking the whole contents of an element.++xpTrees	:: PU [XmlTree]+xpTrees	= (xpList xpTree) { theSchema = Any }++-- | Pickle a string representing XML contents by inserting the tree representation into the XML document.+--+-- Unpickling is done by converting the contents with+-- 'Yuuko.Text.XML.HXT.Arrow.Edit.xshowEscapeXml' into a string,+-- this function will escape all XML special chars, such that pickling the value back becomes save.+-- Pickling is done with 'Yuuko.Text.XML.HXT.Arrow.ReadDocument.xread'++xpXmlText	:: PU String+xpXmlText+    = xpWrap ( showXML, readXML ) $ xpTrees+    where+    showXML = concat . runLA ( xshowEscapeXml unlistA )+    readXML = runLA xread++-- ------------------------------------------------------------++-- | Encoding of optional data by ignoring the Nothing case during pickling+-- and relying on failure during unpickling to recompute the Nothing case+--+-- The default pickler for Maybe types++xpOption	:: PU a -> PU (Maybe a)+xpOption pa+    = PU { appPickle   = ( \ (a, st) ->+			   case a of+			   Nothing -> st+			   Just x  -> appPickle pa (x, st)+			 )++	 , appUnPickle = appUnPickle $+	                 xpChoice (xpLift Nothing) pa (xpLift . Just)++         , theSchema   = scOption (theSchema pa)+	 }++-- | Optional conversion with default value+--+-- The default value is not encoded in the XML document,+-- during unpickling the default value is inserted if the pickler fails++xpDefault	:: (Eq a) => a -> PU a -> PU a+xpDefault df+    = xpWrap ( fromMaybe df+	     , \ x -> if x == df then Nothing else Just x+	     ) .+      xpOption++-- ------------------------------------------------------------++-- | Encoding of list values by pickling all list elements sequentially.+--+-- Unpickler relies on failure for detecting the end of the list.+-- The standard pickler for lists. Can also be used in combination with 'xpWrap'+-- for constructing set and map picklers++xpList	:: PU a -> PU [a]+xpList pa+    = PU { appPickle   = ( \ (a, st) ->+			   case a of+			   []  -> st+			   _:_ -> appPickle pc (a, st)+			 )+	 , appUnPickle = appUnPickle $+                         xpChoice (xpLift []) pa+	                   (\ x -> xpSeq id (xpList pa) (\xs -> xpLift (x:xs)))++	 , theSchema   = scList (theSchema pa)+	 }+      where+      pc = xpSeq head  pa       (\ x ->+	   xpSeq tail (xpList pa) (\ xs ->+	   xpLift (x:xs)))++-- | Encoding of a none empty list of values+--+-- Attention: when calling this pickler with an empty list,+-- an internal error \"head of empty list is raised\".++xpList1	:: PU a -> PU [a]+xpList1 pa+    = ( xpWrap (\ (x, xs) -> x : xs+	       ,\ (x : xs) -> (x, xs)+	       ) $+	xpPair pa (xpList pa)+      ) { theSchema = scList1 (theSchema pa) }++-- ------------------------------------------------------------++-- | Standard pickler for maps+--+-- This pickler converts a map into a list of pairs.+-- All key value pairs are mapped to an element with name (1.arg),+-- the key is encoded as an attribute named by the 2. argument,+-- the 3. arg is the pickler for the keys, the last one for the values++xpMap	:: Ord k => String -> String -> PU k -> PU v -> PU (Map k v)+xpMap en an xpk xpv+    = xpWrap ( M.fromList+	     , M.toList+	     ) $+      xpList $+      xpElem en $+      xpPair ( xpAttr an $ xpk ) xpv+++-- ------------------------------------------------------------++-- | Pickler for sum data types.+--+-- Every constructor is mapped to an index into the list of picklers.+-- The index is used only during pickling, not during unpickling, there the 1. match is taken++xpAlt	:: (a -> Int) -> [PU a] -> PU a+xpAlt tag ps+    = PU { appPickle   = ( \ (a, st) ->+			   let+			   pa = ps !! (tag a)+			   in+			   appPickle pa (a, st)+			 )+	 , appUnPickle = appUnPickle $+	                 ( case ps of+			   []     -> xpZero+			   pa:ps1 -> xpChoice (xpAlt tag ps1) pa xpLift+			 )+	 , theSchema   = scAlts (map theSchema ps)+	 }++-- ------------------------------------------------------------++-- | Pickler for wrapping\/unwrapping data into an XML element+--+-- Extra parameter is the element name given as a QName. THE pickler for constructing+-- nested structures+--+-- Example:+--+-- > xpElemQN (mkName "number") $ xpickle+--+-- will map an (42::Int) onto+--+-- > <number>42</number>++xpElemQN	:: QName -> PU a -> PU a+xpElemQN qn pa+    = PU { appPickle   = ( \ (a, st) ->+			   let+	                   st' = appPickle pa (a, emptySt)+			   in+			   addCont (XN.mkElement qn (attributes st') (contents st')) st+			 )+	 , appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleElement st)+	 , theSchema   = scElem (qualifiedName qn) (theSchema pa)+	 }+      where+      unpickleElement st+	  = do+	    t <- getCont st+	    n <- XN.getElemName t+	    if n /= qn+	       then fail ("element name " ++ show n ++ " does not match" ++ show qn)+	       else do+		    let cs = XN.getChildren t+		    al <- XN.getAttrl t+		    res <- fst . appUnPickle pa $ St {attributes = al, contents = cs}+		    return (Just res, dropCont st)++-- | convenient Pickler for xpElemQN+--+-- > xpElem n = xpElemQN (mkName n)++xpElem		:: String -> PU a -> PU a+xpElem		= xpElemQN . mkName++-- ------------------------------------------------------------++-- | Pickler for wrapping\/unwrapping data into an XML element with an attribute with given value+--+-- To make XML structures flexible but limit the number of different elements, it's sometimes+-- useful to use a kind of generic element with a key value structure+--+-- Example:+--+-- > <attr name="key1">value1</attr>+-- > <attr name="key2">value2</attr>+-- > <attr name="key3">value3</attr>+--+-- the Haskell datatype may look like this+--+-- > type T = T { key1 :: Int ; key2 :: String ; key3 :: Double }+--+-- Then the picker for that type looks like this+--+-- > xpT :: PU T+-- > xpT = xpWrap ( uncurry3 T, \ t -> (key1 t, key2 t, key3 t) ) $+-- >       xpTriple (xpElemWithAttrValue "attr" "name" "key1" $ xpickle)+-- >                (xpElemWithAttrValue "attr" "name" "key2" $ xpText0)+-- >                (xpElemWithAttrValue "attr" "name" "key3" $ xpickle)++xpElemWithAttrValue	:: String -> String -> String -> PU a -> PU a+xpElemWithAttrValue name an av pa+    = PU { appPickle   = ( \ (a, st) ->+			   let+	                   st' = appPickle pa' (a, emptySt)+			   in+			   addCont (XN.mkElement (mkName name) (attributes st') (contents st')) st+			 )+	 , appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleElement st)+	 , theSchema   = scElem name (theSchema pa')+	 }+      where+      pa' = xpAddFixedAttr an av $ pa+      noMatch = null . runLA ( isElem+			       >>>+			       hasName name+			       >>>+			       hasAttrValue an (==av)+			     )+      unpickleElement st+	  = do+	    t <- getCont st+	    if noMatch t+	       then fail "element name or attr value does not match"+	       else do+		    let cs = XN.getChildren t+		    al <- XN.getAttrl t+		    res <- fst . appUnPickle pa $ St {attributes = al, contents = cs}+		    return (Just res, dropCont st)++-- ------------------------------------------------------------++-- | Pickler for storing\/retreiving data into\/from an attribute value+--+-- The attribute is inserted in the surrounding element constructed by the 'xpElem' pickler++xpAttrQN	:: QName -> PU a -> PU a+xpAttrQN qn pa+    = PU { appPickle   = ( \ (a, st) ->+			   let+			   st' = appPickle pa (a, emptySt)+			   in+			   addAtt (XN.mkAttr qn (contents st')) st+			 )+	 , appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleAttr st)+	 , theSchema   = scAttr (qualifiedName qn) (theSchema pa)+	 }+      where+      unpickleAttr st+	  = do+	    a <- getAtt qn st+	    let av = XN.getChildren a+	    res <- fst . appUnPickle pa $ St {attributes = [], contents = av}+	    return (Just res, st)	-- attribute is not removed from attribute list,+					-- attributes are selected by name++-- | convenient Pickler for xpAttrQN+--+-- > xpAttr n = xpAttrQN (mkName n)++xpAttr		:: String -> PU a -> PU a+xpAttr		= xpAttrQN . mkName++-- | Add an optional attribute for an optional value (Maybe a).++xpAttrImplied	:: String -> PU a -> PU (Maybe a)+xpAttrImplied name pa+    = xpOption $ xpAttr name pa++xpAttrFixed	:: String -> String -> PU ()+xpAttrFixed name val+    = ( xpWrapMaybe ( \ v -> if v == val then Just () else Nothing+		    , const val+		    ) $+	xpAttr name xpText+      ) { theSchema   = scAttr name (scFixed val) }++-- | Add an attribute with a fixed value.+--+-- Useful e.g. to declare namespaces. Is implemented by 'xpAttrFixed'++xpAddFixedAttr	:: String -> String -> PU a -> PU a+xpAddFixedAttr name val pa+    = xpWrap ( snd+	     , (,) ()+	     ) $+      xpPair (xpAttrFixed name val) pa++-- ------------------------------------------------------------++-- | The class for overloading 'xpickle', the default pickler++class XmlPickler a where+    xpickle :: PU a++instance XmlPickler Int where+    xpickle = xpPrim++instance XmlPickler Integer where+    xpickle = xpPrim++{-+  no instance of XmlPickler Char+  because then every text would be encoded+  char by char, because of the instance for lists++instance XmlPickler Char where+    xpickle = xpPrim+-}++instance XmlPickler () where+    xpickle = xpUnit++instance (XmlPickler a, XmlPickler b) => XmlPickler (a,b) where+    xpickle = xpPair xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c) => XmlPickler (a,b,c) where+    xpickle = xpTriple xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d) => XmlPickler (a,b,c,d) where+    xpickle = xp4Tuple xpickle xpickle xpickle xpickle++instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e) => XmlPickler (a,b,c,d,e) where+    xpickle = xp5Tuple xpickle xpickle xpickle xpickle xpickle++instance XmlPickler a => XmlPickler [a] where+    xpickle = xpList xpickle++instance XmlPickler a => XmlPickler (Maybe a) where+    xpickle = xpOption xpickle++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/Arrow/ProcessDocument.hs view
@@ -0,0 +1,284 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.Arrow.ProcessDocument+   Copyright  : Copyright (C) 2005 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable+   Version    : $Id: ProcessDocument.hs,v 1.3 2006/08/30 16:20:52 hxml Exp $++   Compound arrows for reading, parsing, validating and writing XML documents++   All arrows use IO and a global state for options, errorhandling, ...+-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.Arrow.ProcessDocument+    ( parseXmlDocument+    , parseHtmlDocument+    , validateDocument+    , propagateAndValidateNamespaces+    , getDocumentContents+    )+where++import Control.Arrow				-- arrow classes+import Yuuko.Control.Arrow.ArrowList+import Yuuko.Control.Arrow.ArrowIf+import Yuuko.Control.Arrow.ArrowTree++import Yuuko.Text.XML.HXT.DOM.Interface+import Yuuko.Text.XML.HXT.Arrow.XmlArrow+import Yuuko.Text.XML.HXT.Arrow.XmlIOStateArrow++import Yuuko.Text.XML.HXT.Arrow.ParserInterface+    ( parseXmlDoc+    , parseHtmlDoc+    , parseHtmlTagSoup+    , substHtmlEntityRefs+    , validateDoc+    , transformDoc+    )++import Yuuko.Text.XML.HXT.Arrow.Edit+    ( transfAllCharRef+    )++import Yuuko.Text.XML.HXT.Arrow.GeneralEntitySubstitution+    ( processGeneralEntities+    )++import Yuuko.Text.XML.HXT.Arrow.DTDProcessing+    ( processDTD+    )++import Yuuko.Text.XML.HXT.Arrow.DocumentInput+    ( getXmlContents+    )++import Yuuko.Text.XML.HXT.Arrow.Namespace+    ( propagateNamespaces+    , validateNamespaces+    )++-- ------------------------------------------------------------++{- | +XML parser++Input tree must be a root tree with a text tree as child containing the document to be parsed.+The parser generates from the input string a tree of a wellformed XML document,+processes the DTD (parameter substitution, conditional DTD parts, ...) and+substitutes all general entity references. Next step is character reference substitution.+Last step is the document validation.+Validation can be controlled by an extra parameter.++Example:++> parseXmlDocument True    -- parse and validate document+>+> parseXmlDocument False   -- only parse document, don't validate++This parser is useful for applications processing correct XML documents.+-}++parseXmlDocument	:: Bool -> IOStateArrow s XmlTree XmlTree+parseXmlDocument validate+    = ( replaceChildren ( ( getAttrValue a_source+			    &&&+			    xshow getChildren+			  )+			  >>>+			  parseXmlDoc+			  >>>+			  filterErrorMsg+			)+	>>>+	setDocumentStatusFromSystemState "parse XML document"+	>>>+	processDTD+	>>>+	processGeneralEntities+	>>>+	transfAllCharRef+	>>>+	( if validate+	  then validateDocument+	  else this+	)+      )+      `when` documentStatusOk++-- ------------------------------------------------------------++{- | +HTML parser++Input tree must be a root tree with a text tree as child containing the document to be parsed.+The parser tries to parse everything as HTML, if the HTML document is not wellformed XML or if+errors occur, warnings are generated. The warnings can be issued, or suppressed.++Example: @ parseHtmlDocument True @ : parse document and issue warnings++This parser is useful for applications like web crawlers, where the pages may contain+arbitray errors, but the application is only interested in parts of the document, e.g. the plain text.++-}++parseHtmlDocument	:: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> IOStateArrow s XmlTree XmlTree+parseHtmlDocument withTagSoup withNamespaces warnings preserveCmt removeWhitespace asHtml+    = ( perform ( getAttrValue a_source >>> traceValue 1 (("parseHtmlDoc: parse HTML document " ++) . show) )+	>>>+	replaceChildren ( ( getAttrValue a_source		-- get source name+			    &&&+			    xshow getChildren+			  ) 					-- get string to be parsed+			  >>>+			  parseHtml+			)+	>>>+	removeWarnings+	>>>+	setDocumentStatusFromSystemState "parse HTML document"+	>>>+	traceTree+	>>>+	traceSource+	>>>+	perform ( getAttrValue a_source+		  >>>+		  traceValue 1 (\ src -> "parse HTML document " ++ show src ++ " finished")+		)+      )+      `when` documentStatusOk+    where+    parseHtml+	| withTagSoup	= traceMsg 1 ("parse document with tagsoup " +++				      ( if asHtml then "HT" else "X" ) ++ "ML parser"+				     )+			  >>>+			  parseHtmlTagSoup withNamespaces warnings preserveCmt removeWhitespace asHtml++	| otherwise	= traceMsg 1 ("parse document with parsec HTML parser")+			  >>>+			  parseHtmlDoc				-- run parser+			  >>>+			  substHtmlEntityRefs			-- substitute entity refs+    removeWarnings+	| withTagSoup+	  &&+	  not warnings	= this+	| otherwise	= processTopDownWithAttrl+			  ( if warnings				-- remove warnings inserted by parser and entity subst+			    then filterErrorMsg+			    else ( none+				   `when`+				   isError+				 )+			  )++-- ------------------------------------------------------------++{- | Document validation++Input must be a complete document tree. The document+is validated with respect to the DTD spec.+Only useful for XML documents containing a DTD.++If the document is valid, it is transformed with respect to the DTD,+normalization of attribute values, adding default values, sorting attributes by name,...++If no error was found, result is the normalized tree,+else the error status is set in the list of attributes+of the root node \"\/\" and the document content is removed from the tree.++-}++validateDocument	:: IOStateArrow s XmlTree XmlTree+validateDocument+    = ( traceMsg 1 "validating document"+	>>>+	perform ( validateDoc+		  >>>+		  filterErrorMsg+		)+	>>>+	setDocumentStatusFromSystemState "document validation"+	>>>+	transformDoc+	>>>+	traceMsg 1 "document validated"+	>>>+	traceSource+	>>>+	traceTree+      )+      `when`+      documentStatusOk+      +-- ------------------------------------------------------------++{- | Namespace propagation++Input must be a complete document tree. The namespace declarations+are evaluated and all element and attribute names are processed by+splitting the name into prefix, local part and namespace URI.++Naames are checked with respect to the XML namespace definition++If no error was found, result is the unchanged input tree,+else the error status is set in the list of attributes+of the root node \"\/\" and the document content is removed from the tree.+++-}++propagateAndValidateNamespaces	:: IOStateArrow s XmlTree XmlTree+propagateAndValidateNamespaces+    = ( traceMsg 1 "propagating namespaces"+	>>>+	propagateNamespaces+	>>>+	traceDoc "propagating namespaces done"+	>>>+	traceMsg 1 "validating namespaces"+	>>>+	( setDocumentStatusFromSystemState "namespace propagation"+	  `when`+	  ( validateNamespaces >>> perform filterErrorMsg )+	)+	>>>+	traceMsg 1 "namespace validation finished"+      )+      `when`+      documentStatusOk++-- ------------------------------------------------------------++{- |+   creates a new document root, adds all options+   as attributes to the document root and calls 'getXmlContents'.++   If the document name is the empty string, the document will be read+   from standard input.++   For supported protocols see 'Yuuko.Text.XML.HXT.Arrow.DocumentInput.getXmlContents'+-}++getDocumentContents	:: Attributes -> String -> IOStateArrow s b XmlTree+getDocumentContents options src+    = root [] []+      >>>+      addAttr a_source src+      >>>+      seqA (map (uncurry addAttr) options)					-- add all options to doc root+      >>>									-- e.g. getXmlContents needs some of these+      traceMsg 1 ("readDocument: start processing document " ++ show src)+      >>>+      getXmlContents++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/Arrow/ReadDocument.hs view
@@ -0,0 +1,406 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.Arrow.ReadDocument+   Copyright  : Copyright (C) 2005 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable+   Version    : $Id: ReadDocument.hs,v 1.10 2006/11/24 07:41:37 hxml Exp $++Compound arrows for reading an XML\/HTML document or an XML\/HTML string++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.Arrow.ReadDocument+    ( readDocument+    , readFromDocument+    , readString+    , readFromString+    , hread+    , xread+    )+where++import Yuuko.Control.Arrow.ListArrows++import Yuuko.Text.XML.HXT.DOM.Interface+import Yuuko.Text.XML.HXT.Arrow.XmlArrow+import Yuuko.Text.XML.HXT.Arrow.XmlIOStateArrow++import Yuuko.Text.XML.HXT.Arrow.Edit			( canonicalizeAllNodes+						, canonicalizeForXPath+						, canonicalizeContents+                                                , rememberDTDAttrl+						, removeDocWhiteSpace+						)++import Yuuko.Text.XML.HXT.Arrow.ParserInterface+    +import Yuuko.Text.XML.HXT.Arrow.ProcessDocument	( getDocumentContents+						, parseXmlDocument+						, parseHtmlDocument+						, propagateAndValidateNamespaces+						)++import Yuuko.Text.XML.HXT.RelaxNG.Validator		( validateDocumentWithRelaxSchema )++-- ------------------------------------------------------------++{- |+the main document input filter++this filter can be configured by an option list, a value of type 'Yuuko.Text.XML.HXT.DOM.TypeDefs.Attributes'++available options:++* 'a_parse_html': use HTML parser, else use XML parser (default)++- 'a_tagsoup' : use light weight and lazy parser based on tagsoup lib++- 'a_parse_by_mimetype' : select the parser by the mime type of the document+                          (pulled out of the HTTP header). When the mime type is set to \"text\/html\"+			  the HTML parser (parsec or tagsoup) is taken, when it\'s set to+			  \"text\/xml\" or \"text\/xhtml\" the XML parser (parsec or tagsoup) is taken.+			  If the mime type is something else no further processing is performed,+			  the contents is given back to the application in form of a single text node.+			  If the default document encoding ('a_encoding') is set to isoLatin1, this even enables processing+			  of arbitray binary data.++- 'a_validate' : validate document againsd DTD (default), else skip validation++- 'a_relax_schema' : validate document with Relax NG, the options value is the schema URI+                     this implies using XML parser, no validation against DTD, and canonicalisation++- 'a_check_namespaces' : check namespaces, else skip namespace processing (default)++- 'a_canonicalize' : canonicalize document (default), else skip canonicalization++- 'a_preserve_comment' : preserve comments during canonicalization, else remove comments (default)++- 'a_remove_whitespace' : remove all whitespace, used for document indentation, else skip this step (default)++- 'a_indent' : indent document by inserting whitespace, else skip this step (default)++- 'a_issue_warnings' : issue warnings, when parsing HTML (default), else ignore HTML parser warnings++- 'a_issue_errors' : issue all error messages on stderr (default), or ignore all error messages++- 'a_ignore_encoding_errors': ignore all encoding errors, default is issue all encoding errors++- 'a_ignore_none_xml_contents': ignore document contents of none XML\/HTML documents.+                                This option can be useful for implementing crawler like applications, e.g. an URL checker.+                                In those cases net traffic can be reduced.++- 'a_trace' : trace level: values: 0 - 4++- 'a_proxy' : proxy for http access, e.g. www-cache:3128++- 'a_redirect' : automatically follow redirected URIs, default is yes++- 'a_use_curl' : obsolete and ignored, HTTP acccess is always done with curl bindings for libcurl++- 'a_strict_input' : file input is done strictly using the 'Data.ByteString' input functions. This ensures correct closing of files, especially when working with+                     the tagsoup parser and not processing the whole input data. Default is off. The @ByteString@ input usually is not faster than the buildin @hGetContents@+		     for strings.++- 'a_options_curl' : deprecated but for compatibility reasons still supported.+                     More options passed to the curl binding.+                     Instead of using this option to set a whole bunch of options at once for curl+                     it is recomended to use the @curl-.*@ options syntax described below.++- 'a_encoding' : default document encoding ('utf8', 'isoLatin1', 'usAscii', 'iso8859_2', ... , 'iso8859_16', ...).+                 Only XML, HTML and text documents are decoded,+                 default decoding for XML\/HTML is utf8, for text iso latin1 (no decoding).+		 The whole content is returned in a single text node.++- 'a_mime_types' : set the mime type table for file input with given file. The format of this config file must be in the syntax of a debian linux \"mime.types\" config file++- curl options : the HTTP interface with libcurl can be configured with a lot of options. To support these options in an easy way, there is a naming convetion:+                 Every option, which has the prefix @curl@ and the rest of the name forms an option as described in the curl man page, is passed to the curl binding lib.+                 See 'Yuuko.Text.XML.HXT.IO.GetHTTPLibCurl.getCont' for examples. Currently most of the options concerning HTTP requests are implemented.++All attributes not evaluated by readDocument are stored in the created document root node for easy access of the various+options in e.g. the input\/output modules++If the document name is the empty string or an uri of the form \"stdin:\", the document is read from standard input.++examples:++> readDocument [ ] "test.xml"++reads and validates a document \"test.xml\", no namespace propagation, only canonicalization is performed ++> readDocument [ (a_validate, "0")+>              , (a_encoding, isoLatin1)+>              , (a_parse_by_mimetype, "1")+>              ] "http://localhost/test.php"++reads document \"test.php\", parses it as HTML or XML depending on the mimetype given from the server, but without validation, default encoding 'isoLatin1'.+++> readDocument [ (a_parse_html, "1")+>              , (a_encoding, isoLatin1)+>              ] ""++reads a HTML document from standard input, no validation is done when parsing HTML, default encoding is 'isoLatin1',+parsing is done with tagsoup parser, but input is read strictly++> readDocument [ (a_encoding, isoLatin1)+>              , (a_mime_type,    "/etc/mime.types")+>              , (a_tagsoup,      "1")+>              , (a_strict_input, "1")+>              ] "test.svg"++reads an SVG document from standard input, sets the mime type by looking in the system mimetype config file, default encoding is 'isoLatin1',+parsing is done with the lightweight tagsoup parser, which implies no validation.++> readDocument [ (a_parse_html,     "1")+>              , (a_proxy,          "www-cache:3128")+>              , (a_curl,           "1")+>              , (a_issue_warnings, "0")+>              ] "http://www.haskell.org/"++reads Haskell homepage with HTML parser ignoring any warnings, with http access via external program curl and proxy \"www-cache\" at port 3128++> readDocument [ (a_validate,          "1")+>              , (a_check_namespace,   "1")+>              , (a_remove_whitespace, "1")+>              , (a_trace,             "2")+>              ] "http://www.w3c.org/"++read w3c home page (xhtml), validate and check namespaces, remove whitespace between tags, trace activities with level 2++for minimal complete examples see 'Yuuko.Text.XML.HXT.Arrow.WriteDocument.writeDocument' and 'runX', the main starting point for running an XML arrow.+-}++readDocument	:: Attributes -> String -> IOStateArrow s b XmlTree+readDocument userOptions src+    = traceLevel+      >>>+      addInputOptionsToSystemState+      >>>+      getDocumentContents options src+      >>>+      ( processDoc $< getMimeType )+      >>>+      traceMsg 1 ("readDocument: " ++ show src ++ " processed")+      >>>+      traceSource+      >>>+      traceTree+    where+    options+ 	= addEntries userOptions defaultOptions++    defaultOptions+	= [ ( a_parse_html,		  v_0 )+	  , ( a_tagsoup,		  v_0 )+	  , ( a_strict_input,		  v_0 )+	  , ( a_validate,		  v_1 )+	  , ( a_issue_warnings,		  v_1 )+	  , ( a_check_namespaces,	  v_0 )+	  , ( a_canonicalize,		  v_1 )+	  , ( a_preserve_comment,	  v_0 )+	  , ( a_remove_whitespace,	  v_0 )+	  , ( a_parse_by_mimetype,	  v_0 )+	  , ( a_ignore_encoding_errors,   v_0 )+	  , ( a_ignore_none_xml_contents, v_0 )+	  , ( a_accept_mimetypes,         ""  )+	  ]++    traceLevel+	= maybe this (setTraceLevel . read) . lookup a_trace $ options++    addInputOptionsToSystemState+	= addSysOptions options+	  >>>+	  loadMineTypes (lookup1 a_mime_types userOptions)+	  where+	  addSysOptions+	      = seqA . map (uncurry setParamString)+	  loadMineTypes ""	= this+	  loadMineTypes f	= setMimeTypeTableFromFile f++    getMimeType+	= getAttrValue transferMimeType >>^ stringToLower++    processDoc mimeType+	= traceMsg 1 (unwords [ "readDocument:", show src+			      , "(mime type:", show mimeType, ") will be processed"])+	  >>>+	  ( if isAcceptedMimeType (lookup1 a_accept_mimetypes options) mimeType+	    then ( parse+		   >>>+		   ( if isXmlOrHtml+		     then ( checknamespaces+			    >>>+                            rememberDTDAttrl+                            >>>+			    canonicalize+			    >>>+			    whitespace+			    >>>+			    relax+			  )+		     else this+		   )+		 )+	    else ( traceMsg 1 (unwords [ "readDocument:", show src+				       , "mime type:", show mimeType, "not accepted"])+		   >>>+		   replaceChildren none+		 )								-- remove contents of not accepted mimetype+	  )+	where+	isAcceptedMimeType		:: String -> String -> Bool+	isAcceptedMimeType mts mt+	    | null mts+	      ||+	      null mt			= True+	    | otherwise			= foldr (matchMt mt') False $ mts'+	    where+	    mt'				= parseMt mt+	    mts'			= words+					  >>>+					  map parseMt+					  $+					  mts+	    parseMt			= break (== '/')+					  >>>+					  second (drop 1)+	    matchMt (ma,mi) (mas,mis) r	= ( (ma == mas || mas == "*")+					    &&+					    (mi == mis || mis == "*")+					  )+					  || r+	parse+	    | isHtml+	      || +	      withTagSoup		= parseHtmlDocument			-- parse as HTML or with tagsoup XML+					  withTagSoup+					  withNamespaces+					  issueW+					  (not (hasOption a_canonicalize) && preserveCmt)+					  removeWS+					  isHtml+	    | validateWithRelax		= parseXmlDocument False		-- for Relax NG use XML parser without validation+	    | isXml			= parseXmlDocument validate		-- parse as XML+	    | removeNoneXml		= replaceChildren none			-- don't parse, if mime type is not XML nor HTML+	    | otherwise			= this					-- but remove contents when option is set+	checknamespaces+	    | (withNamespaces && not withTagSoup)+	      ||+	      validateWithRelax		= propagateAndValidateNamespaces+	    | otherwise			= this+	canonicalize+	    | withTagSoup		= this					-- tagsoup already removes redundant struff+	    | validateWithRelax		= canonicalizeAllNodes+	    | hasOption a_canonicalize+	      &&+	      preserveCmt			= canonicalizeForXPath+	    | hasOption a_canonicalize	= canonicalizeAllNodes+	    | otherwise			= this+	relax+	    | validateWithRelax		= validateDocumentWithRelaxSchema options relaxSchema+	    | otherwise			= this+	whitespace+	    | removeWS+	      &&+	      not withTagSoup		= removeDocWhiteSpace			-- tagsoup already removes whitespace+	    | otherwise			= this+	validateWithRelax	= hasEntry a_relax_schema options+	relaxSchema		= lookup1 a_relax_schema options+	parseHtml		= hasOption a_parse_html+	isHtml			= parseHtml					-- force HTML+				  ||+				  ( parseByMimeType && isHtmlMimeType mimeType )+	isXml			= ( not parseByMimeType && not parseHtml )+				  ||+				  ( parseByMimeType+				    &&+				    ( isXmlMimeType mimeType+				      ||+				      null mimeType+				    )						-- mime type is XML or not known+				  )+	isXmlOrHtml	= isHtml || isXml+	parseByMimeType	= hasOption a_parse_by_mimetype+	validate	= hasOption a_validate+	withNamespaces	= hasOption a_check_namespaces+	withTagSoup	= hasOption a_tagsoup+	issueW		= hasOption a_issue_warnings+	removeWS	= hasOption a_remove_whitespace+	preserveCmt	= hasOption a_preserve_comment+	removeNoneXml	= hasOption a_ignore_none_xml_contents+	hasOption n	= optionIsSet n options++-- ------------------------------------------------------------++-- |+-- the arrow version of 'readDocument', the arrow input is the source URI++readFromDocument	:: Attributes -> IOStateArrow s String XmlTree+readFromDocument userOptions+    = applyA ( arr $ readDocument userOptions )++-- ------------------------------------------------------------++-- |+-- read a document that is stored in a normal Haskell String+--+-- the same function as readDocument, but the parameter forms the input.+-- All options available for 'readDocument' are applicable for readString.+--+-- Default encoding: No encoding is done, the String argument is taken as Unicode string++readString	:: Attributes -> String -> IOStateArrow s b XmlTree+readString userOptions content+    = readDocument ( (a_encoding, unicodeString) : userOptions ) (stringProtocol ++ content)++-- ------------------------------------------------------------++-- |+-- the arrow version of 'readString', the arrow input is the source URI++readFromString	:: Attributes -> IOStateArrow s String XmlTree+readFromString userOptions+    = applyA ( arr $ readString userOptions )++-- ------------------------------------------------------------++-- |+-- parse a string as HTML content, substitute all HTML entity refs and canonicalize tree+-- (substitute char refs, ...). Errors are ignored.+-- +-- A simpler version of 'readFromString' but with less functionality.+-- Does not run in the IO monad++hread			:: ArrowXml a => a String XmlTree+hread+    = parseHtmlContent+      >>>+      substHtmlEntityRefs+      >>>+      processTopDown ( none `when` isError )+      >>>+      canonicalizeContents++-- |+-- parse a string as XML content, substitute all predefined XML entity refs and canonicalize tree+-- (substitute char refs, ...)++xread			:: ArrowXml a => a String XmlTree+xread+    = parseXmlContent+      >>>+      substXmlEntityRefs+      >>>+      canonicalizeContents++-- ------------------------------------------------------------+
+ src/Yuuko/Text/XML/HXT/Arrow/WriteDocument.hs view
@@ -0,0 +1,247 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.Arrow.WriteDocument+   Copyright  : Copyright (C) 2005-9 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   Compound arrow for writing XML documents++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.Arrow.WriteDocument+    ( writeDocument+    , writeDocumentToString+    , prepareContents+    )+where++import Control.Arrow				-- arrow classes+import Yuuko.Control.Arrow.ArrowList+import Yuuko.Control.Arrow.ArrowIf+import Yuuko.Control.Arrow.ArrowTree++import Yuuko.Text.XML.HXT.DOM.Interface+import Yuuko.Text.XML.HXT.Arrow.XmlArrow+import Yuuko.Text.XML.HXT.Arrow.XmlIOStateArrow++import Yuuko.Text.XML.HXT.Arrow.Edit			( escapeHtmlDoc+						, escapeXmlDoc+						, haskellRepOfXmlDoc+						, indentDoc+                                                , addDefaultDTDecl+						, preventEmptyElements+						, removeDocWhiteSpace+						, treeRepOfXmlDoc+						)++import Yuuko.Text.XML.HXT.Arrow.DocumentOutput	( putXmlDocument+						, encodeDocument+						, encodeDocument'+						)++-- ------------------------------------------------------------++{- |+the main filter for writing documents++this filter can be configured by an option list like 'Yuuko.Text.XML.HXT.Arrow.ReadDocument.readDocument'++usage: @ writeDocument optionList destination @++if @ destination @ is the empty string or \"-\", stdout is used as output device++available options are++* 'a_indent' : indent document for readability, (default: no indentation)++- 'a_remove_whitespace' : remove all redundant whitespace for shorten text (default: no removal)++- 'a_output_encoding' : encoding of document, default is 'a_encoding' or 'utf8'++- 'a_output_xml' : (default) issue XML: quote special XML chars \>,\<,\",\',& where neccessary+                   add XML processing instruction+                   and encode document with respect to 'a_output_encoding',+                   if explicitly switched of, the plain text is issued, this is useful+                   for non XML output, e.g. generated Haskell code, LaTex, Java, ...++- 'a_output_html' : issue XHTML: quote alle XML chars, use HTML entity refs or char refs for none ASCII chars++- 'a_no_empty_elements' : do not write the short form \<name .../\> for empty elements. When 'a_output_html' is set,+                          the always empty HTML elements are still written in short form, but not the others, as e.g. the script element.+                          Empty script elements, like \<script href=\"...\"/\>, are always a problem for firefox and others.+                          When XML output is generated with this option, all empty elements are written in the long form.++- 'a_no_empty_elem_for' : do not generate empty elements for the element names given in the comma separated list of this option value.+                          This option overwrites the above described 'a_no_empty_elements' option++- 'a_add_default_dtd' : if the document to be written was build by reading another document containing a Document Type Declaration,+                        this DTD is inserted into the output document (default: no insert)++- 'a_no_xml_pi' : suppress generation of \<?xml ... ?\> processing instruction++- 'a_show_tree' : show tree representation of document (for debugging)++- 'a_show_haskell' : show Haskell representaion of document (for debugging)++ a minimal main program for copying a document+ has the following structure:++> module Main+> where+> +> import Yuuko.Text.XML.HXT.Arrow+> +> main        :: IO ()+> main+>     = do+>       runX ( readDocument  [] "hello.xml"+>              >>>+>              writeDocument [] "bye.xml"+>            )+>       return ()++an example for copying a document to standard output with tracing and evaluation of+error code is:++> module Main+> where+> +> import Yuuko.Text.XML.HXT.Arrow+> import System.Exit+> +> main        :: IO ()+> main+>     = do+>       [rc] <- runX ( readDocument  [ (a_trace, "1")+>                                    ] "hello.xml"+>                      >>>+>                      writeDocument [ (a_output_encoding, isoLatin1)+>                                    ] "-"        -- output to stdout+>                      >>>+>                      getErrStatus+>                    )+>       exitWith ( if rc >= c_err+>                  then ExitFailure 1+>                  else ExitSuccess+>                )+-}++writeDocument	:: Attributes -> String -> IOStateArrow s XmlTree XmlTree+writeDocument userOptions dst+    = perform ( traceMsg 1 ("writeDocument: destination is " ++ show dst)+		>>>+		prepareContents userOptions encodeDocument+		>>>+		putXmlDocument textMode dst+		>>>+		traceMsg 1 "writeDocument: finished"+	      )+      `when`+      documentStatusOk+    where+    textMode	= optionIsSet a_text_mode userOptions++-- ------------------------------------------------------------++-- |+-- Convert a document into a string. Formating is done the same way+-- and with the same options as in 'writeDocument'. Default output encoding is+-- no encoding, that means the result is a normal unicode encode haskell string.+-- The default may be overwritten with the 'Yuuko.Text.XML.HXT.XmlKeywords.a_output_encoding' option.+-- The XML PI can be suppressed by the 'Yuuko.Text.XML.HXT.XmlKeywords.a_no_xml_pi' option.+--+-- This arrow fails, when the encoding scheme is not supported.+-- The arrow is pure, it does not run in the IO monad.+-- The XML PI is suppressed, if not explicitly turned on with an+-- option @ (a_no_xml_pi, v_0) @++writeDocumentToString	:: ArrowXml a => Attributes  -> a XmlTree String+writeDocumentToString userOptions+    = prepareContents ( addEntries+                        userOptions+                        [ (a_output_encoding, unicodeString)+                        , (a_no_xml_pi, v_1)+                        ]+                      ) encodeDocument'+      >>>+      xshow getChildren++-- ------------------------------------------------------------++-- |+-- indent and format output++prepareContents	:: ArrowXml a => Attributes -> (Bool -> String -> a XmlTree XmlTree) -> a XmlTree XmlTree+prepareContents userOptions encodeDoc+    = indent+      >>>+      addDtd+      >>>+      format+    where+    formatEmptyElems+        | not (null noEmptyElemFor)     = preventEmptyElements noEmptyElemFor+	| hasOption a_no_empty_elements+          ||+          hasOption a_output_xhtml      = preventEmptyElements []+	| otherwise                     = const this+    addDtd+        | hasOption a_add_default_dtd   = addDefaultDTDecl+        | otherwise                     = this+    indent+	| hasOption a_indent		= indentDoc			-- document indentation+	| hasOption a_remove_whitespace	= removeDocWhiteSpace		-- remove all whitespace between tags+	| otherwise			= this++    format+	| hasOption a_show_tree		= treeRepOfXmlDoc+	| hasOption a_show_haskell	= haskellRepOfXmlDoc+	| hasOption a_output_html	= formatEmptyElems True+					  >>>+					  escapeHtmlDoc			-- escape al XML and HTML chars >= 128+					  >>>+					  encodeDoc			-- convert doc into text with respect to output encoding with ASCII as default+					    suppressXmlPi ( lookupDef usAscii a_output_encoding options )+	| hasOption a_output_xml	= formatEmptyElems (hasOption a_output_xhtml)+					  >>>+					  escapeXmlDoc			-- escape lt, gt, amp, quot, +					  >>>+					  encodeDoc			-- convert doc into text with respect to output encoding+					    suppressXmlPi ( lookupDef "" a_output_encoding options )+	| otherwise			= this++    suppressXmlPi							-- remove <?xml ... ?> when set+	= hasOption a_no_xml_pi++    noEmptyElemFor+        = words+          . map (\ c -> if c == ',' then ' ' else c)+          . lookup1 a_no_empty_elem_for+          $ options++    hasOption n+	= optionIsSet n options++    options = addEntries +              userOptions +	      [ ( a_indent,		v_0 )+	      , ( a_remove_whitespace,	v_0 )+	      , ( a_output_xml,		v_1 )+	      , ( a_show_tree,		v_0 )+	      , ( a_show_haskell,	v_0 )+	      , ( a_output_html,	v_0 )+	      , ( a_output_xhtml,	v_0 )+	      , ( a_no_xml_pi,          v_0 )+	      , ( a_no_empty_elements,  v_0 )+              , ( a_no_empty_elem_for,  ""  )+              , ( a_add_default_dtd,    v_0 )+	      ]++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/Arrow/XPath.hs view
@@ -0,0 +1,287 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.Arrow.XPath+   Copyright  : Copyright (C) 2006 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   Arrows for working with XPath and XmlNodeSets.++   Most of the XPath arrows come in two versions,+   one without dealing with namespaces, element and attribute names+   in XPath expressions are taken as they ar ignoring any prefix:localname structure.++   The second variant uses a namespace environment for associating the right+   namespace for the appropriate prefix. an entry for the empty prefix+   defines the default namespace for the expression.++   The second variant should be used, when in the application namespaces+   are significant, that means when namespace propagation is done for+   the documents to be processed.++   NodeSets are sets of \"pointer\" into an XML tree to reference+   subnodes. These nodesets can be computed by XPath expressions or+   normal arrows. The nodesets can then be used later for selecting+   or modifying subtrees of this tree in an efficient way.++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.Arrow.XPath+    ( getXPathTreesInDoc+    , getXPathTreesInDocWithNsEnv+    , getXPathTrees+    , getXPathTreesWithNsEnv+    , getElemNodeSet+    , getElemAndAttrNodeSet+    , getXPathNodeSet+    , getFromNodeSet+    , processXPathTrees+    , processXPathTreesWithNsEnv+    , processFromNodeSet+    )+where++import qualified Yuuko.Text.XML.HXT.XPath as PT+    ( getXPathSubTreesWithNsEnv+    , getXPathNodeSetWithNsEnv+    )++import Yuuko.Control.Arrow.ListArrows++import Yuuko.Text.XML.HXT.DOM.Interface+import Yuuko.Text.XML.HXT.Arrow.XmlArrow++import Yuuko.Text.XML.HXT.Arrow.Edit+    ( canonicalizeForXPath+    )++-- ------------------------------------------------------------++-- |+-- Select parts of a whole XML document with root node by a XPath expression.+--+-- The main filter for selecting parts of a document via XPath.+--+-- The string argument must be a XPath expression with an absolute location path,+-- the argument tree must be a complete document tree.+--+-- Before evaluating the xpath query, the document is canonicalized+-- with 'Yuuko.Text.XML.HXT.Arrow.Edit.canonicalizeForXPath'+--+-- Result is a possibly empty list of XmlTrees forming the set of selected XPath values.+-- XPath values other than XmlTrees (numbers, attributes, tagnames, ...)+-- are convertet to text nodes.++getXPathTreesInDoc			:: ArrowXml a => String -> a XmlTree XmlTree+getXPathTreesInDoc			= getXPathTreesInDocWithNsEnv []++-- | Same as 'getXPathTreesInDoc' but with namespace environment for the XPath names++getXPathTreesInDocWithNsEnv		:: ArrowXml a => Attributes -> String -> a XmlTree XmlTree+getXPathTreesInDocWithNsEnv env query	= canonicalizeForXPath+					  >>>+					  arrL (PT.getXPathSubTreesWithNsEnv env query)++-- |+-- Select parts of an arbitrary XML tree by a XPath expression.+--+-- The main filter for selecting parts of an arbitrary XML tree via XPath.+-- The string argument must be a XPath expression with an absolute location path,+-- There are no restrictions on the argument tree.+--+-- No canonicalization is performed before evaluating the query+--+-- Result is a possibly empty list of XmlTrees forming the set of selected XPath values.+-- XPath values other than XmlTrees (numbers, attributes, tagnames, ...)+-- are convertet to text nodes.++getXPathTrees				:: ArrowXml a => String -> a XmlTree XmlTree+getXPathTrees				= getXPathTreesWithNsEnv []++-- | Same as 'getXPathTrees' but with namespace environment for the XPath names++getXPathTreesWithNsEnv			:: ArrowXml a => Attributes -> String -> a XmlTree XmlTree+getXPathTreesWithNsEnv env query	= arrL (PT.getXPathSubTreesWithNsEnv env query)++-- | Select a set of nodes via an XPath expression from an arbitray XML tree+--+-- The result is a set of \"pointers\" to nodes. This set can be used to+-- access or modify the values of the subnodes in subsequent calls to 'getFromNodeSet' or 'processFromNodeSet'.+--+-- This function enables for parsing an XPath expressions and traversing the tree for node selection once+-- and reuse this result possibly many times for later selection and modification operations.++getXPathNodeSet				:: ArrowXml a => String -> a XmlTree XmlNodeSet+getXPathNodeSet				= getXPathNodeSetWithNsEnv []++-- | Same as 'getXPathNodeSet' but with namespace environment for the XPath names++getXPathNodeSetWithNsEnv		:: ArrowXml a => Attributes -> String -> a XmlTree XmlNodeSet+getXPathNodeSetWithNsEnv nsEnv query	= arr (PT.getXPathNodeSetWithNsEnv nsEnv query)++-- ------------------------------------------------------------++getNodeSet	:: ArrowXml a => a XmlTree QName -> a XmlTree XmlTree -> a XmlTree XmlNodeSet+getNodeSet af f+    = ( ( listA ( getChildren+		  >>>+		  getNodeSet af f+		)+	  >>>+	  arr filterNodeSet+	)+	&&&+	listA af+	&&&+	listA f+      )+      >>^ (\ ~(cl, (al, n)) -> XNS (not . null $ n) al cl)+    where+    filterNodeSet	:: [XmlNodeSet] -> ChildNodes+    filterNodeSet+	= concat . zipWith filterIx [0..]++    filterIx	:: Int -> XmlNodeSet -> ChildNodes+    filterIx _ix (XNS False [] [])+	= []+    filterIx ix ps+	= [(ix, ps)]++-- |+-- compute a node set from a tree, containing all nodes selected by the predicate arrow+--+-- computation of the set of element nodes with name \"a\" is done with+--+-- > getElemNodeSet (hasName "a")++getElemNodeSet		:: ArrowXml a => a XmlTree XmlTree -> a XmlTree XmlNodeSet+getElemNodeSet f+    = getNodeSet none f++-- |+-- compute a node set from a tree, containing all nodes including attribute nodes+-- elected by the predicate arrow++getElemAndAttrNodeSet	:: ArrowXml a => a XmlTree XmlTree -> a XmlTree XmlNodeSet+getElemAndAttrNodeSet f+    = getNodeSet ( getAttrl+		   >>>+		   ( f `guards` getAttrName )+		 ) f++-- ------------------------------------------------------------++-- |+-- select all subtrees specified by a previously computed node set+--+-- the following law holds:+--+-- > getFromNodeSet $< getElemNodeSet f == multi f++getFromNodeSet		:: ArrowXml a => XmlNodeSet -> a XmlTree XmlTree+getFromNodeSet (XNS t al cl)+    = fromLA $+      ( if t then this else none )+      <+>+      ( getAttrl >>> getFromAttrl al )+      <+>+      ( getFromChildren (0-1) cl $< listA getChildren )+    where++    getFromAttrl	:: [QName] -> LA XmlTree XmlTree+    getFromAttrl l+	= ( catA . map hasQName $ l)+	  `guards`+	  this++    getFromChildren	:: Int -> ChildNodes -> XmlTrees -> LA XmlTree XmlTree+    getFromChildren _ [] _+	= none++    getFromChildren i' ((i, sp) : sps) ts+	= ( arrL (const t') >>> getFromNodeSet sp )+	  <+>+	  getFromChildren i sps ts'+	  where+	  (t', ts') = splitAt 1 . drop (i-i'-1) $ ts++-- ------------------------------------------------------------++-- |+-- process all subtrees selected by an XPath expression+--+-- the following law holds:+--+-- > processXPathTrees p xpathExpr == processFromNodeSet p $< getXPathNodeSet xpathExpr+++processXPathTrees		:: ArrowXml a => a XmlTree XmlTree  -> String -> a XmlTree XmlTree+processXPathTrees f		= processXPathTreesWithNsEnv f []++-- | Same as 'processXPathTrees' but with namespace environment for the XPath names++processXPathTreesWithNsEnv	:: ArrowXml a => a XmlTree XmlTree  -> Attributes -> String -> a XmlTree XmlTree+processXPathTreesWithNsEnv f nsEnv query+    = choiceA+      [ isRoot :-> processChildren pns+      , this   :-> pns+      ]+    where+    pns = processFromNodeSet f $< getXPathNodeSetWithNsEnv nsEnv query++-- |+-- process all subtrees specified by a previously computed node set in bottom up manner+--+-- the follwoing law holds:+--+-- > processFromNodeSet g $< getElemNodeSet f == processBottomUp (g `when` f)+--+-- when attributes are contained in the node set (see 'getElemAndAttrNodeSet'), these are processed+-- after the children and before the node itself+--+-- the advantage of processFromNodeSet is the separation of the selection of set of nodes to be processed (e.g. modified)+-- from the real proccessing. The selection sometimes can be done once, the processing possibly many times.++processFromNodeSet	:: ArrowXml a => a XmlTree XmlTree  -> XmlNodeSet -> a XmlTree XmlTree+processFromNodeSet f (XNS t al cl)+    = ( if null cl+	then this+	else replaceChildren ( processC (0-1) cl $< listA getChildren )+      )+      >>>+      ( if null al+	then this+	else processAttrl (processA al)+      )+      >>>+      ( if not t+	then this+	else f+      )+    where++    -- processA		:: ChildNodes -> a XmlTree XmlTree+    processA l+	= f `when` ( catA . map hasQName $ l)++    -- processC		:: ChildNodes -> XmlTrees -> a XmlTree XmlTree+    processC _ [] ts+	= arrL (const ts)++    processC i' ((i, sp) : sps) ts+	= arrL (const ts1)+	  <+>+	  ( arrL (const ti) >>> processFromNodeSet f sp)+	  <+>+	  processC i sps ts21+	  where+	  (ts1, ts2) = splitAt (i-i'-1) ts+	  (ti, ts21) = splitAt 1 ts2++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/Arrow/XPathSimple.hs view
@@ -0,0 +1,507 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.XPath.GetSimpleXPath+   Copyright  : Copyright (C) 2008 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   XPath selection for simple XPath expressions with list arrows+   instead of navigable trees.++   It is recommended, that this module is imported qualified,+   e.g like @Yuuko.Text.XML.HXT.Arrow.XPathSimple as XS@.++   The arrows defined in this module have the same+   functionality as the functions in 'Yuuko.Text.XML.HXT.Arrow.XPath'.++   The computation model in XPath is a navigable tree,+   that means a tree which can be traversed in arbitrary directions,+   not only from the root to the leafs. Sometimes this model+   leads to inefficient XPath processing for simple queries, which+   only need a top down tree traversal.++   When evaluating an XPath expression with these functions, first an attempt is made+   to map the XPath expression to a pure arrow. If this is possible+   due to the simplicity of the XPath expressions, the result is computed+   directly, else the query is processed by the corresponding+   function in 'Yuuko.Text.XML.HXT.Arrow.XPath'.++   The simple evaluation is possible, when in the XPath expression+   only the top down axes (self, child, descendant, descendant or self) are used,+   when no built-in functions concerning the position of a node are used,+   and no comparison of nodes e.g. in node set union is required.++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.Arrow.XPathSimple+where++-- import qualified Debug.Trace as T++import Control.Monad+import Yuuko.Control.Arrow.ListArrows++import Data.Maybe++import Text.ParserCombinators.Parsec		( runParser )++import Yuuko.Text.XML.HXT.DOM.Interface+import Yuuko.Text.XML.HXT.Arrow.XmlArrow++import qualified Yuuko.Text.XML.HXT.Arrow.XPath as XP	( getXPathTreesWithNsEnv+						)+import Yuuko.Text.XML.HXT.Arrow.Edit			( canonicalizeForXPath+						)++import Yuuko.Text.XML.HXT.XPath.XPathDataTypes	( XPNumber (..)+						, Expr (..)+						, Op (..)+						, XPathNode (..)+						, LocationPath (..)+						, Path (..)+						, XStep (..)+						, AxisSpec (..)+						, NodeTest (..)+						, XPathValue (..)+						)+import Yuuko.Text.XML.HXT.XPath.XPathParser		( parseXPath+						, parseNumber+						)++-- ----------------------------------------++-- |+-- Same Functionality as 'Yuuko.Text.XML.HXT.Arrow.XPath.getXPathTreesInDoc'++getXPathTreesInDoc			:: ArrowXml a => String -> a XmlTree XmlTree+getXPathTreesInDoc			= getXPathTreesInDocWithNsEnv []++-- |+-- Same Functionality as 'Yuuko.Text.XML.HXT.Arrow.XPath.getXPathTreesInDocWithNsEnv'++getXPathTreesInDocWithNsEnv		:: ArrowXml a => Attributes -> String -> a XmlTree XmlTree+getXPathTreesInDocWithNsEnv env query	= canonicalizeForXPath+					  >>>+					  tryGetXPath env query+-- |+-- Same Functionality as 'Yuuko.Text.XML.HXT.Arrow.XPath.getXPathTrees'++getXPathTrees				:: ArrowXml a => String -> a XmlTree XmlTree+getXPathTrees				= getXPathTreesWithNsEnv []++-- |+-- Same Functionality as 'Yuuko.Text.XML.HXT.Arrow.XPath.getXPathTreesWithNsEnv'++getXPathTreesWithNsEnv			:: ArrowXml a => Attributes -> String -> a XmlTree XmlTree+getXPathTreesWithNsEnv			= tryGetXPath+++tryGetXPath				:: ArrowXml a => Attributes -> String -> a XmlTree XmlTree+tryGetXPath env query			= ( listA (getXPathTreesWithNsEnvSimple env query)+					    &&&+					    listA (   XP.getXPathTreesWithNsEnv env query)+					  )+                                          >>>+					  ifA (arr fst >>> (unlistA >>. take 1) >>> isError)+					      (arr snd >>> unlistA)+					      (arr fst >>> unlistA)++-- |+-- The xpath interpreter for simple xpath expressions.+--+-- In case of a too complicated or illegal xpath expression an error+-- node is returned, else the list of selected XML trees++getXPathTreesWithNsEnvSimple		:: ArrowXml a => Attributes -> String -> a XmlTree XmlTree+getXPathTreesWithNsEnvSimple env s	= fromLA $ getXP (toNsEnv env) s++-- ----------------------------------------++getXP				:: NsEnv -> String -> LA XmlTree XmlTree+getXP env s			= either ( err+					   .+					   (("Syntax error in XPath expression " ++ show s ++ ": ") ++)+					   .+					   show . show+					 ) (fromMaybe (err ( "XPath expression " ++ show s +++							     " too complicated for simple arrow evaluation"+							   )+						      ) . compXPath+					   )+				  -- . ( \ e -> T.trace (("getXP: xp = "++) . show $ e) e)+				  .+				  runParser parseXPath env ""+				  $ s++-- ----------------------------------------++type XPArrow b c		= Maybe (LA b c)++mk				:: LA b c -> XPArrow b c+mk				= Just++unwrap				:: XPArrow b b -> LA b b+unwrap				= fromJust . toThis++(>>>>)				:: XPArrow b b -> XPArrow b b -> XPArrow b b+Nothing   >>>> a2		= a2+a1        >>>> Nothing		= a1+(Just f1) >>>> (Just f2)	= return $ f1 >>> f2++(&&&&)				:: XPArrow b b -> XPArrow b b -> XPArrow b (b, b)+Nothing   &&&& a2		= this'' &&&& a2+a1        &&&& Nothing		= a1     &&&& this''+(Just f1) &&&& (Just f2)	= return $ f1 &&& f2++(<+>>)				:: XPArrow b b -> XPArrow b b -> XPArrow b b+Nothing   <+>> _a2		= Nothing+_a1       <+>> Nothing		= Nothing+(Just f1) <+>> (Just f2)	= return $ f1 <+> f2++guards'				:: XPArrow b b -> XPArrow b b -> XPArrow b b+Nothing   `guards'` a2		= a2+a1        `guards'` Nothing	= a1 `guards'` this''+(Just f1) `guards'` (Just f2)	= return $ f1 `guards` f2++this'				:: XPArrow b b+this'				= Nothing++this''				:: XPArrow b b+this''				= mk this++toThis				:: XPArrow b b -> XPArrow b b+toThis Nothing			= this''+toThis a			= a++getChildren'			:: XPArrow XmlTree XmlTree -> XPArrow XmlTree XmlTree+getChildren' a			= mk getChildren >>>> a++getAttrl'			:: XPArrow XmlTree XmlTree -> XPArrow XmlTree XmlTree+getAttrl' a			= mk getAttrl >>>> a++multi'				:: XPArrow XmlTree XmlTree -> XPArrow XmlTree XmlTree+multi' a			= mk $ multi (unwrap a)++deep'				:: XPArrow XmlTree XmlTree -> XPArrow XmlTree XmlTree+deep' a				= mk $ deep (unwrap a)++xIndex				:: Int -> LA [b] b+xIndex i+    | i <= 0			= none+    | otherwise			= arrL (take 1 . drop (i-1))++xString				:: XPArrow XmlTree XmlTree -> LA XmlTree String+xString a			= unwrap a >>> xshow (deep isText)++xNumber'			:: XPArrow XmlTree XmlTree -> LA XmlTree XPNumber+xNumber' a			=  xString a >>> arr toNumber++-- ------------------------------++deadEndStreet			:: Monad m => m a+deadEndStreet			= fail "XPath expression too complicated for XmlArrows"++compXPath			:: MonadPlus m => Expr -> m (LA XmlTree XmlTree)+compXPath e			= do+				  r <- compXP e+				  return $ unwrap r++compXP				:: MonadPlus m => Expr -> m (XPArrow XmlTree XmlTree)+compXP (PathExpr Nothing (Just (LocPath Abs lp)))+				= compLP lp this'+compXP (FilterExpr (e1:el))	= do+				  r <- compXP e1+				  compFP el r+compXP _			= deadEndStreet++compFP				:: MonadPlus m => [Expr] -> XPArrow XmlTree XmlTree -> m (XPArrow XmlTree XmlTree)+compFP []      r		= return r+compFP (e1:es) r		= do+				  r1 <- compPred [e1] r+				  compFP es r1++compLP				:: MonadPlus m => [XStep] -> XPArrow XmlTree XmlTree -> m (XPArrow XmlTree XmlTree)+compLP []     r			= return r+compLP (x:xs) r			= do+				  a1 <- compXS x r+				  as <- compLP xs a1+				  return as++compXS				:: MonadPlus m => XStep -> XPArrow XmlTree XmlTree -> m (XPArrow XmlTree XmlTree)+compXS (Step Child nt ps) s	= do+				  an <- compNTE nt+				  compPred ps (s >>>> mk getChildren >>>> an)++compXS (Step DescendantOrSelf nt ps) s+				= do+				  an <- compNTE nt+				  compPred ps (s >>>> multi' an)++compXS (Step Descendant nt ps) s+				= do+				  an <- compNTE nt+				  compPred ps (s >>>> mk getChildren >>>> multi' an)++compXS (Step Self nt ps) s+				= do+				  an <- compNTE nt+				  compPred ps (s >>>> an)+compXS (Step Attribute nt ps) s+				= do+				  an <- compNTA nt+				  compPred ps (s >>>> getAttrl' an)++compXS _ _			= deadEndStreet++compNTE				:: (Monad m) => NodeTest -> m (XPArrow XmlTree XmlTree)+compNTE (NameTest qn)		= compNameT isElem qn+compNTE nt			= compNT nt++compNTA				:: (Monad m) => NodeTest -> m (XPArrow XmlTree XmlTree)+compNTA (NameTest qn)		= compNameT isAttr qn+compNTA nt			= compNT nt++compNameT			:: Monad m => LA XmlTree XmlTree -> QName -> m (XPArrow XmlTree XmlTree)+compNameT ist qn+    | null (namespaceUri qn)	= return $ mk+				  ( if qualifiedName qn == "*"+				    then ist+				    else ist >>> hasName (qualifiedName qn)+				  )+    | otherwise			= return $ mk+				  ( if localPart qn == "*"+				    then ist >>> hasNamespaceUri (namespaceUri qn)+				    else ist >>> hasQName qn++				  )++compNT				:: Monad m => NodeTest -> m (XPArrow XmlTree XmlTree)+compNT (TypeTest XPNode)       	= return this'+compNT (TypeTest XPCommentNode)	= return $ mk isCmt+compNT (TypeTest XPPINode)      = return $ mk isPi+compNT (TypeTest XPTextNode)    = return $ mk isText++compNT _			= deadEndStreet++compPred			:: MonadPlus m => [Expr] -> XPArrow XmlTree XmlTree -> m (XPArrow XmlTree XmlTree)+compPred []     r		= return r+compPred (e:es)	r		= do+				  r1 <- compPred1 e r+				  compPred es r1++compPred1			:: MonadPlus m => Expr -> XPArrow XmlTree XmlTree -> m (XPArrow XmlTree XmlTree)+compPred1 e r			= ( do+				    ix <- compIntExpr e+				    return . mk $ listA (unwrap r) >>> xIndex ix+				  )+				  `mplus`+				  ( do+				    a1 <- compRelPathExpr e+				    return $ r >>>> (a1 `guards'` this')+				  )+				  `mplus`+				  ( do+				    a1 <- compGenExpr e+				    return $ r >>>> (a1 `guards'` this')+				  )+				  `mplus`+				  ( do+				    b1 <- compBoolExpr e+				    return $ if b1 then r else mk none+				  )++compRelPathExpr			:: MonadPlus m => Expr -> m (XPArrow XmlTree XmlTree)+compRelPathExpr (PathExpr Nothing (Just (LocPath Rel lp)))+				= compLP lp this'+compRelPathExpr _		= deadEndStreet++compStringExpr			:: MonadPlus m => Expr -> m String+compStringExpr (LiteralExpr s)	= return s+compStringExpr _		= deadEndStreet++compNumberExpr			:: MonadPlus m => Expr -> m XPNumber+compNumberExpr (NumberExpr n)	= return n+compNumberExpr (FctExpr "number" [f1])+				= ( do+				    b <- compBoolExpr f1+				    return $ if b then (Float 1) else Pos0+				  )+				  `mplus`+				  ( do+				    s <- compStringExpr f1+				    return $ toNumber s+				  )+compNumberExpr _		= deadEndStreet++compIntExpr			:: MonadPlus m => Expr -> m Int+compIntExpr e			= ( do+				    (Float f) <- compNumberExpr e+				    return (round f)+				  )+				  `mplus`+				  deadEndStreet+++compBoolExpr			:: MonadPlus m => Expr -> m Bool+compBoolExpr (FctExpr f [])+    | f `elem` ["true", "false"]+				= return $ f == "true"+compBoolExpr (FctExpr "not" [f1])+				= do+				  v1 <- compBoolExpr f1+				  return $ not v1+compBoolExpr (LiteralExpr s)	= return $ not (null s)+compBoolExpr (NumberExpr n)	= return $ nz n+				  where+				  nz (Float f) = f /= 0+				  nz NegInf    = True+				  nz PosInf    = True+				  nz _         = False+compBoolExpr _			= deadEndStreet++compGenExpr			:: MonadPlus m => Expr -> m (XPArrow XmlTree XmlTree)+compGenExpr (GenExpr op [e1,e2])+				= compString op e1 e2		-- on arg is a string expr+				  `mplus`+				  compNumber op e1 e2		-- one arg is a number expr+				  `mplus`+				  compBool   op e1 e2		-- and/or+				  `mplus`+				  compPath   op e1 e2		-- nodeset equality++compGenExpr (GenExpr op (e1:el))+    | op `elem` [And, Or]	= compGenExpr (GenExpr op [e1, GenExpr op el])++compGenExpr _			= deadEndStreet++compString			:: MonadPlus m => Op -> Expr -> Expr -> m (XPArrow XmlTree XmlTree)+compString op e1 e2+    | op `elem` [Eq, NEq]	= ( do+				    s <- compStringExpr  e2+				    a <- compRelPathExpr e1+				    return $ mkEq' a s+				  )+				  `mplus`+				  ( do+				    s <- compStringExpr  e1+				    a <- compRelPathExpr e2+				    return $ mkEq' a s+				  )+				  where+				  mkEq' a' s' = mk ( ( xString a'+							>>>+							isA ( if op == Eq+							      then (== s')+							      else (/= s')+							    )+						      )+						      `guards` this	-- just for type match+						    )+compString _ _ _		= deadEndStreet++compNumber			:: MonadPlus m => Op -> Expr -> Expr -> m (XPArrow XmlTree XmlTree)+compNumber op e1 e2+    | op `elem` [Eq, NEq, Less, Greater, LessEq, GreaterEq]+				= ( do+				    n <- compNumberExpr  e2+				    a <- compRelPathExpr e1+				    return $ mkEq' a n+				  )+				  `mplus`+				  ( do+				    n <- compNumberExpr  e1+				    a <- compRelPathExpr e2+				    return $ mkEq' a n+				  )+				  where+				  mkEq' a' n' = mk ( ( xNumber' a'+							>>>+							isA (flip ( case op of+								    Eq        -> (==)+								    NEq       -> (/=)+								    Less      -> (<)+								    Greater   -> (>)+								    LessEq    -> (<=)+								    GreaterEq -> (>=)+								    _         -> error "compNumber: wrong arg"+								  ) n'+							    )+						      )+						      `guards` this+						    )+compNumber _ _ _		= deadEndStreet++compBool			:: MonadPlus m => Op -> Expr -> Expr -> m (XPArrow XmlTree XmlTree)+compBool And e1 e2		= ( do+				    b <- compBoolExpr e1+				    if b+				       then compGenExpr e2+				       else return $ mk none+				  )+				  `mplus`+				  ( do+				    b <- compBoolExpr e2+				    if b+				       then compGenExpr e1+				       else return $ mk none+				  )+				  `mplus`+				  ( do+				    a1 <- compGenExpr e1+				    a2 <- compGenExpr e2+				    return $ a1 `guards'` a2+				  )+compBool Or e1 e2		= ( do+				    b <- compBoolExpr e1+				    if b+                                       then return this'+				       else compGenExpr e2+				  )+				  `mplus`+				  ( do+				    b <- compBoolExpr e2+				    if b+                                       then return this'+				       else compGenExpr e1+				  )+				  `mplus`+				  ( do+				    a1 <- compGenExpr e1+				    a2 <- compGenExpr e2+				    return $ a1 <+>> a2+				  )+compBool _ _ _			= deadEndStreet++compPath			:: MonadPlus m => Op -> Expr -> Expr -> m (XPArrow XmlTree XmlTree)+compPath op e1 e2+    | op `elem` [Eq, NEq]	= ( do+				    a1 <- compRelPathExpr e2+				    a2 <- compRelPathExpr e1+				    return $ mk . cmp op $ ( ( listA (xString a1) &&& listA (xString a2))+							      >>>+							      eqs+							    )+				  )+				  where+				  eqs		= arr2L equalNodeSet+				  cmp Eq  a	= a `guards` this+				  cmp NEq a	= ifA a none this+				  cmp _ _	= error "compPath: wrong agruments"++compPath _ _ _			= deadEndStreet++-- ----------------------------------------++toNumber		:: String -> XPNumber+toNumber s		= let ( XPVNumber v) = parseNumber s in v++equalNodeSet		:: Eq a => [a] -> [a] -> [a]+equalNodeSet s1 s2	= [ x | x <- s1, y <- s2, x == y]++-- ----------------------------------------
+ src/Yuuko/Text/XML/HXT/Arrow/XmlArrow.hs view
@@ -0,0 +1,632 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.Arrow.XmlArrow+   Copyright  : Copyright (C) 2005-9 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   Basic arrows for processing XML documents++   All arrows use IO and a global state for options, errorhandling, ...++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.Arrow.XmlArrow+    ( module Yuuko.Text.XML.HXT.Arrow.XmlArrow )+where++import           Control.Arrow			-- classes+import           Yuuko.Control.Arrow.ArrowList+import           Yuuko.Control.Arrow.ArrowIf+import           Yuuko.Control.Arrow.ArrowTree++import           Yuuko.Control.Arrow.ListArrow		-- arrow types+import           Yuuko.Control.Arrow.StateListArrow+import           Yuuko.Control.Arrow.IOListArrow+import           Yuuko.Control.Arrow.IOStateListArrow++import           Data.Maybe++import           Yuuko.Text.XML.HXT.DOM.Interface+import           Yuuko.Text.XML.HXT.DOM.Unicode	( isXmlSpaceChar+						)+import qualified Yuuko.Text.XML.HXT.DOM.XmlNode as XN+import qualified Yuuko.Text.XML.HXT.DOM.ShowXml as XS++-- ------------------------------------------------------------++{- | Arrows for processing 'Yuuko.Text.XML.HXT.DOM.TypeDefs.XmlTree's++These arrows can be grouped into predicates, selectors, constructors, and transformers.++All predicates (tests) act like 'Yuuko.Control.Arrow.ArrowIf.none' for failure and 'Yuuko.Control.Arrow.ArrowIf.this' for success.+A logical and can be formed by @ a1 >>> a2 @, a locical or by @ a1 \<+\> a2 @.++Selector arrows will fail, when applied to wrong input, e.g. selecting the text of a node with 'getText'+will fail when applied to a none text node.++Edit arrows will remain the input unchanged, when applied to wrong argument, e.g. editing the content of a text node+with 'changeText' applied to an element node will return the unchanged element node.+-}++infixl 7 +=++class (Arrow a, ArrowList a, ArrowTree a) => ArrowXml a where++    -- discriminating predicates++    -- | test for text nodes+    isText		:: a XmlTree XmlTree+    isText		= isA XN.isText++    -- | test for char reference, used during parsing+    isCharRef		:: a XmlTree XmlTree+    isCharRef		= isA XN.isCharRef++    -- | test for entity reference, used during parsing+    isEntityRef		:: a XmlTree XmlTree+    isEntityRef		= isA XN.isEntityRef++    -- | test for comment+    isCmt		:: a XmlTree XmlTree+    isCmt		= isA XN.isCmt++    -- | test for CDATA section, used during parsing+    isCdata		:: a XmlTree XmlTree+    isCdata		= isA XN.isCdata++    -- | test for processing instruction+    isPi		:: a XmlTree XmlTree+    isPi		= isA XN.isPi++    -- | test for processing instruction \<?xml ...\>+    isXmlPi		:: a XmlTree XmlTree+    isXmlPi		= isPi >>> hasName "xml"++    -- | test for element+    isElem		:: a XmlTree XmlTree+    isElem		= isA XN.isElem++    -- | test for DTD part, used during parsing+    isDTD		:: a XmlTree XmlTree+    isDTD		= isA XN.isDTD++    -- | test for attribute tree+    isAttr		:: a XmlTree XmlTree+    isAttr		= isA XN.isAttr++    -- | test for error message+    isError		:: a XmlTree XmlTree+    isError		= isA XN.isError++    -- | test for root node (element with name \"\/\")+    isRoot		:: a XmlTree XmlTree+    isRoot		= isA XN.isRoot++    -- | test for text nodes with text, for which a predicate holds+    --+    -- example: @hasText (all (\`elem\` \" \\t\\n\"))@ check for text nodes with only whitespace content+    +    hasText		:: (String -> Bool) -> a XmlTree XmlTree+    hasText p		= (isText >>> getText >>> isA p) `guards` this++    -- | test for text nodes with only white space+    --+    -- implemented with 'hasTest'++    isWhiteSpace	:: a XmlTree XmlTree+    isWhiteSpace        = hasText (all isXmlSpaceChar)++    -- |+    -- test whether a node (element, attribute, pi) has a name with a special property++    hasNameWith		:: (QName  -> Bool) -> a XmlTree XmlTree+    hasNameWith p	= (getQName        >>> isA p) `guards` this++    -- |+    -- test whether a node (element, attribute, pi) has a specific qualified name+    -- useful only after namespace propagation+    hasQName		:: QName  -> a XmlTree XmlTree+    hasQName n		= (getQName        >>> isA (== n)) `guards` this++    -- |+    -- test whether a node has a specific name (prefix:localPart ore localPart),+    -- generally useful, even without namespace handling+    hasName		:: String -> a XmlTree XmlTree+    hasName n		= (getName         >>> isA (== n)) `guards` this++    -- |+    -- test whether a node has a specific name as local part,+    -- useful only after namespace propagation+    hasLocalPart	:: String -> a XmlTree XmlTree+    hasLocalPart n	= (getLocalPart    >>> isA (== n)) `guards` this++    -- |+    -- test whether a node has a specific name prefix,+    -- useful only after namespace propagation+    hasNamePrefix	:: String -> a XmlTree XmlTree+    hasNamePrefix n	= (getNamePrefix   >>> isA (== n)) `guards` this++    -- |+    -- test whether a node has a specific namespace URI+    -- useful only after namespace propagation+    hasNamespaceUri	:: String -> a XmlTree XmlTree+    hasNamespaceUri n	= (getNamespaceUri >>> isA (== n)) `guards` this++    -- |+    -- test whether an element node has an attribute node with a specific name+    hasAttr		:: String -> a XmlTree XmlTree+    hasAttr n		= (getAttrl        >>> hasName n)  `guards` this++    -- |+    -- test whether an element node has an attribute node with a specific qualified name+    hasQAttr		:: QName -> a XmlTree XmlTree+    hasQAttr n		= (getAttrl        >>> hasQName n)  `guards` this++    -- |+    -- test whether an element node has an attribute with a specific value+    hasAttrValue	:: String -> (String -> Bool) -> a XmlTree XmlTree+    hasAttrValue n p	= (getAttrl >>> hasName n >>> xshow getChildren >>> isA p)  `guards` this++    -- |+    -- test whether an element node has an attribute with a qualified name and a specific value+    hasQAttrValue	:: QName -> (String -> Bool) -> a XmlTree XmlTree+    hasQAttrValue n p	= (getAttrl >>> hasQName n >>> xshow getChildren >>> isA p)  `guards` this++    -- constructor arrows ------------------------------------------------------------++    -- | text node construction arrow+    mkText		:: a String XmlTree+    mkText		= arr  XN.mkText++    -- | char reference construction arrow, useful for document output+    mkCharRef		:: a Int    XmlTree+    mkCharRef		= arr  XN.mkCharRef++    -- | entity reference construction arrow, useful for document output+    mkEntityRef		:: a String XmlTree+    mkEntityRef		= arr  XN.mkEntityRef++    -- | comment node construction, useful for document output+    mkCmt		:: a String XmlTree+    mkCmt		= arr  XN.mkCmt++    -- | CDATA construction, useful for document output+    mkCdata		:: a String XmlTree+    mkCdata		= arr  XN.mkCdata++    -- | error node construction, useful only internally+    mkError		:: Int -> a String XmlTree+    mkError level	= arr (XN.mkError level)++    -- | element construction:+    -- | the attributes and the content of the element are computed by applying arrows+    -- to the input+    mkElement		:: QName -> a n XmlTree -> a n XmlTree -> a n XmlTree+    mkElement n af cf	= (listA af &&& listA cf)+			  >>>+			  arr2 (\ al cl -> XN.mkElement n al cl)+    -- | attribute node construction:+    -- | the attribute value is computed by applying an arrow to the input+    mkAttr		:: QName -> a n XmlTree -> a n XmlTree+    mkAttr qn f		= listA f >>> arr (XN.mkAttr qn)++    -- | processing instruction construction:+    -- | the content of the processing instruction is computed by applying an arrow to the input+    mkPi		:: QName -> a n XmlTree -> a n XmlTree+    mkPi qn f		= listA f >>> arr (XN.mkPi   qn)++    -- convenient arrows for constructors --------------------------------------------------++    -- | convenient arrow for element construction, more comfortable variant of 'mkElement'+    --+    -- example for simplifying 'mkElement' :+    --+    -- > mkElement qn (a1 <+> ... <+> ai) (c1 <+> ... <+> cj)+    --+    -- equals+    --+    -- > mkqelem qn [a1,...,ai] [c1,...,cj]++    mkqelem		:: QName -> [a n XmlTree] -> [a n XmlTree] -> a n XmlTree+    mkqelem  n afs cfs	= mkElement n (catA afs) (catA cfs)++    -- | convenient arrow for element construction with strings instead of qualified names as element names, see also 'mkElement' and 'mkelem'+    mkelem		:: String -> [a n XmlTree] -> [a n XmlTree] -> a n XmlTree+    mkelem  n afs cfs	= mkElement (mkName n) (catA afs) (catA cfs)++    -- | convenient arrow for element constrution with attributes but without content, simple variant of 'mkelem' and 'mkElement'+    aelem		:: String -> [a n XmlTree]                  -> a n XmlTree+    aelem n afs		= catA afs >. \ al -> XN.mkElement (mkName n) al []++    -- | convenient arrow for simple element constrution without attributes, simple variant of 'mkelem' and 'mkElement'+    selem		:: String                  -> [a n XmlTree] -> a n XmlTree+    selem n cfs		= catA cfs >.         XN.mkElement (mkName n) []++    -- | convenient arrow for constrution of empty elements without attributes, simple variant of 'mkelem' and 'mkElement'+    eelem		:: String                                   -> a n XmlTree+    eelem n		= constA      (XN.mkElement (mkName n) [] [])++    -- | construction of an element node with name \"\/\" for document roots+    root		::           [a n XmlTree] -> [a n XmlTree] -> a n XmlTree+    root		= mkelem t_root++    -- | alias for 'mkAttr'+    qattr		:: QName -> a n XmlTree -> a n XmlTree+    qattr		= mkAttr++    -- | convenient arrow for attribute constrution, simple variant of 'mkAttr'+    attr		:: String -> a n XmlTree -> a n XmlTree+    attr		= mkAttr . mkName++    -- constant arrows (ignoring the input) for tree construction ------------------------------++    -- | constant arrow for text nodes+    txt			:: String -> a n XmlTree+    txt			= constA .  XN.mkText++    -- | constant arrow for char reference nodes+    charRef		:: Int    -> a n XmlTree+    charRef		= constA .  XN.mkCharRef++    -- | constant arrow for entity reference nodes+    entityRef		:: String -> a n XmlTree+    entityRef		= constA .  XN.mkEntityRef++    -- | constant arrow for comment+    cmt			:: String -> a n XmlTree+    cmt			= constA .  XN.mkCmt++    -- | constant arrow for warning+    warn		:: String -> a n XmlTree+    warn		= constA . (XN.mkError c_warn)++    -- | constant arrow for errors+    err			:: String -> a n XmlTree+    err			= constA . (XN.mkError c_err)++    -- | constant arrow for fatal errors+    fatal		:: String -> a n XmlTree+    fatal		= constA . (XN.mkError c_fatal)++    -- | constant arrow for simple processing instructions, see 'mkPi'+    spi			:: String -> String -> a n XmlTree+    spi piName piCont	= constA (XN.mkPi   (mkName piName) [XN.mkText piCont])++    -- | constant arrow for attribute nodes, attribute name is a qualified name and value is a text,+    -- | see also 'mkAttr', 'qattr', 'attr'+    sqattr		:: QName -> String -> a n XmlTree+    sqattr an av	= constA (XN.mkAttr an                 [XN.mkText av])++    -- | constant arrow for attribute nodes, attribute name and value are+    -- | given by parameters, see 'mkAttr'+    sattr		:: String -> String -> a n XmlTree+    sattr an av		= constA (XN.mkAttr (mkName an)     [XN.mkText av])++    -- selector arrows --------------------------------------------------++    -- | select the text of a text node+    getText		:: a XmlTree String+    getText		= arrL (maybeToList  . XN.getText)++    -- | select the value of a char reference+    getCharRef		:: a XmlTree Int+    getCharRef		= arrL (maybeToList  . XN.getCharRef)++    -- | select the name of a entity reference node+    getEntityRef	:: a XmlTree String+    getEntityRef	= arrL (maybeToList  . XN.getEntityRef)++    -- | select the comment of a comment node+    getCmt		:: a XmlTree String+    getCmt		= arrL (maybeToList  . XN.getCmt)++    -- | select the content of a CDATA node+    getCdata		:: a XmlTree String+    getCdata		= arrL (maybeToList  . XN.getCdata)++    -- | select the name of a processing instruction+    getPiName		:: a XmlTree QName+    getPiName		= arrL (maybeToList  . XN.getPiName)++    -- | select the content of a processing instruction+    getPiContent	:: a XmlTree XmlTree+    getPiContent	= arrL (fromMaybe [] . XN.getPiContent)++    -- | select the name of an element node+    getElemName		:: a XmlTree QName+    getElemName		= arrL (maybeToList  . XN.getElemName)++    -- | select the attribute list of an element node+    getAttrl		:: a XmlTree XmlTree+    getAttrl		= arrL (fromMaybe [] . XN.getAttrl)++    -- | select the DTD type of a DTD node+    getDTDPart		:: a XmlTree DTDElem+    getDTDPart		= arrL (maybeToList  . XN.getDTDPart)++    -- | select the DTD attributes of a DTD node+    getDTDAttrl		:: a XmlTree Attributes+    getDTDAttrl		= arrL (maybeToList  . XN.getDTDAttrl)++    -- | select the name of an attribute+    getAttrName		:: a XmlTree QName+    getAttrName		= arrL (maybeToList  . XN.getAttrName)++    -- | select the error level (c_warn, c_err, c_fatal) from an error node+    getErrorLevel	:: a XmlTree Int+    getErrorLevel	= arrL (maybeToList  . XN.getErrorLevel)++    -- | select the error message from an error node+    getErrorMsg		:: a XmlTree String+    getErrorMsg		= arrL (maybeToList  . XN.getErrorMsg)++    -- | select the qualified name from an element, attribute or pi+    getQName		:: a XmlTree QName+    getQName		= arrL (maybeToList  . XN.getName)++    -- | select the prefix:localPart or localPart from an element, attribute or pi+    getName		:: a XmlTree String+    getName		= arrL (maybeToList  . XN.getQualifiedName)++    -- | select the univeral name ({namespace URI} ++ localPart)+    getUniversalName	:: a XmlTree String+    getUniversalName	= arrL (maybeToList  . XN.getUniversalName)++    -- | select the univeral name (namespace URI ++ localPart)+    getUniversalUri	:: a XmlTree String+    getUniversalUri	= arrL (maybeToList  . XN.getUniversalUri)++    -- | select the local part+    getLocalPart	:: a XmlTree String+    getLocalPart	= arrL (maybeToList  . XN.getLocalPart)++    -- | select the name prefix+    getNamePrefix	:: a XmlTree String+    getNamePrefix	= arrL (maybeToList  . XN.getNamePrefix)++    -- | select the namespace URI+    getNamespaceUri	:: a XmlTree String+    getNamespaceUri	= arrL (maybeToList  . XN.getNamespaceUri)++    -- | select the value of an attribute of an element node,+    -- always succeeds with empty string as default value \"\"+    getAttrValue	:: String -> a XmlTree String+    getAttrValue n	= xshow (getAttrl >>> hasName n >>> getChildren)++    -- | like 'getAttrValue', but fails if the attribute does not exist+    getAttrValue0	:: String -> a XmlTree String+    getAttrValue0 n	= getAttrl >>> hasName n >>> xshow getChildren++    -- | like 'getAttrValue', but select the value of an attribute given by a qualified name,+    -- always succeeds with empty string as default value \"\"+    getQAttrValue	:: QName -> a XmlTree String+    getQAttrValue n	= xshow (getAttrl >>> hasQName n >>> getChildren)++    -- | like 'getQAttrValue', but fails if attribute does not exist+    getQAttrValue0	:: QName -> a XmlTree String+    getQAttrValue0 n	= getAttrl >>> hasQName n >>> xshow getChildren++    -- edit arrows --------------------------------------------------++    -- | edit the string of a text node+    changeText		:: (String -> String) -> a XmlTree XmlTree+    changeText cf	= arr (XN.changeText     cf) `when` isText++    -- | edit the comment string of a comment node+    changeCmt		:: (String -> String) -> a XmlTree XmlTree+    changeCmt  cf	= arr (XN.changeCmt      cf) `when` isCmt++    -- | edit an element-, attribute- or pi- name+    changeQName		:: (QName  -> QName) -> a XmlTree XmlTree+    changeQName cf	= arr (XN.changeName  cf) `when` getQName++    -- | edit an element name+    changeElemName	:: (QName  -> QName) -> a XmlTree XmlTree+    changeElemName cf	= arr (XN.changeElemName  cf) `when` isElem++    -- | edit an attribute name+    changeAttrName	:: (QName  -> QName) -> a XmlTree XmlTree+    changeAttrName cf	= arr (XN.changeAttrName cf) `when` isAttr++    -- | edit a pi name+    changePiName	:: (QName  -> QName) -> a XmlTree XmlTree+    changePiName cf	= arr (XN.changePiName  cf) `when` isPi++    -- | edit an attribute value+    changeAttrValue	:: (String -> String) -> a XmlTree XmlTree+    changeAttrValue cf	= replaceChildren ( xshow getChildren+					    >>> arr cf+					    >>> mkText+					  )+			  `when` isAttr+++    -- | edit an attribute list of an element node+    changeAttrl		:: (XmlTrees -> XmlTrees -> XmlTrees) -> a XmlTree XmlTree -> a XmlTree XmlTree+    changeAttrl cf f	= ( ( listA f &&& this )+			    >>>+			    arr2 changeAL+			  )+                          `when`+			  ( isElem <+> isPi )+			where+			changeAL as x = XN.changeAttrl (\ xs -> cf xs as) x++    -- | replace an element, attribute or pi name+    setQName		:: QName -> a XmlTree XmlTree+    setQName  n		= changeQName  (const n)++    -- | replace an element name+    setElemName		:: QName -> a XmlTree XmlTree+    setElemName  n	= changeElemName  (const n)++    -- | replace an attribute name+    setAttrName		:: QName -> a XmlTree XmlTree+    setAttrName n	= changeAttrName (const n)++    -- | replace an element name+    setPiName		:: QName -> a XmlTree XmlTree+    setPiName  n	= changePiName  (const n)++    -- | replace an atribute list of an element node+    setAttrl		:: a XmlTree XmlTree -> a XmlTree XmlTree+    setAttrl		= changeAttrl (const id) 		-- (\ x y -> y)++    -- | add a list of attributes to an element+    addAttrl		:: a XmlTree XmlTree -> a XmlTree XmlTree+    addAttrl		= changeAttrl (XN.mergeAttrl)++    -- | add (or replace) an attribute+    addAttr		:: String -> String  -> a XmlTree XmlTree+    addAttr an av	= addAttrl (sattr an av)++    -- | remove an attribute+    removeAttr		:: String  -> a XmlTree XmlTree+    removeAttr an	= processAttrl (none `when` hasName an)++    -- | remove an attribute with a qualified name+    removeQAttr		:: QName  -> a XmlTree XmlTree+    removeQAttr an	= processAttrl (none `when` hasQName an)++    -- | process the attributes of an element node with an arrow+    processAttrl	:: a XmlTree XmlTree -> a XmlTree XmlTree+    processAttrl f	= setAttrl (getAttrl >>> f)++    -- | process a whole tree inclusive attribute list of element nodes+    -- see also: 'Yuuko.Control.Arrow.ArrowTree.processTopDown'++    processTopDownWithAttrl	:: a XmlTree XmlTree -> a XmlTree XmlTree+    processTopDownWithAttrl f	= processTopDown ( f >>> ( processAttrl (processTopDown f) `when` isElem))++    -- | convenient op for adding attributes or children to a node+    --+    -- usage: @ tf += cf @+    --+    -- the @tf@ arrow computes an element node, and all trees computed by @cf@ are+    -- added to this node, if a tree is an attribute, it is inserted in the attribute list+    -- else it is appended to the content list.+    --+    -- attention: do not build long content list this way because '+=' is implemented by +++    --+    -- examples:+    --+    -- > eelem "a"+    -- >   += sattr "href" "page.html"+    -- >   += sattr "name" "here"+    -- >   += txt "look here"+    --+    -- is the same as+    --+    -- > mkelem [ sattr "href" "page.html"+    -- >        , sattr "name" "here"+    -- >        ]+    -- >        [ txt "look here" ]+    --+    -- and results in the XML fragment: \<a href=\"page.html\" name=\"here\"\>look here\<\/a\>+    --+    -- advantage of the '+=' operator is, that attributes and content can be added+    -- any time step by step.+    -- if @tf@ computes a whole list of trees, e.g. a list of \"td\" or \"tr\" elements,+    -- the attributes or content is added to all trees. useful for adding \"class\" or \"style\" attributes+    -- to table elements.++    (+=)		:: a b XmlTree -> a b XmlTree -> a b XmlTree+    tf += cf		= (tf &&& listA cf) >>> arr2 addChildren+	                where+			addChildren	:: XmlTree -> XmlTrees -> XmlTree+			addChildren t cs+			    = foldl addChild t cs+			addChild 	:: XmlTree -> XmlTree -> XmlTree+			addChild t c+			    | not (XN.isElem t)+				= t+			    | XN.isAttr c+				= XN.changeAttrl (XN.addAttr c) t+			    | otherwise+				= XN.changeChildren (++ [c]) t++    -- | apply an arrow to the input and convert the resulting XML trees into a string representation+    xshow		:: a n XmlTree -> a n String+    xshow f		= f >. XS.xshow++{- | Document Type Definition arrows++These are separated, because they are not needed for document processing,+only when processing the DTD, e.g. for generating access funtions for the toolbox+from a DTD (se example DTDtoHaskell in the examples directory)+-}+++class (ArrowXml a) => ArrowDTD a where+    isDTDDoctype	:: a XmlTree XmlTree+    isDTDDoctype	= isA (maybe False (== DOCTYPE ) . XN.getDTDPart)++    isDTDElement	:: a XmlTree XmlTree+    isDTDElement	= isA (maybe False (== ELEMENT ) . XN.getDTDPart)++    isDTDContent	:: a XmlTree XmlTree+    isDTDContent	= isA (maybe False (== CONTENT ) . XN.getDTDPart)++    isDTDAttlist	:: a XmlTree XmlTree+    isDTDAttlist	= isA (maybe False (== ATTLIST ) . XN.getDTDPart)++    isDTDEntity		:: a XmlTree XmlTree+    isDTDEntity		= isA (maybe False (== ENTITY  ) . XN.getDTDPart)++    isDTDPEntity	:: a XmlTree XmlTree+    isDTDPEntity	= isA (maybe False (== PENTITY ) . XN.getDTDPart)++    isDTDNotation	:: a XmlTree XmlTree+    isDTDNotation	= isA (maybe False (== NOTATION) . XN.getDTDPart)++    isDTDCondSect	:: a XmlTree XmlTree+    isDTDCondSect	= isA (maybe False (== CONDSECT) . XN.getDTDPart)++    isDTDName		:: a XmlTree XmlTree+    isDTDName		= isA (maybe False (== NAME    ) . XN.getDTDPart)++    isDTDPERef		:: a XmlTree XmlTree+    isDTDPERef		= isA (maybe False (== PEREF   ) . XN.getDTDPart)++    hasDTDAttr		:: String -> a XmlTree XmlTree+    hasDTDAttr n	= isA (isJust . lookup n . fromMaybe [] . XN.getDTDAttrl)++    getDTDAttrValue	:: String -> a XmlTree String+    getDTDAttrValue n	= arrL (maybeToList . lookup n . fromMaybe [] . XN.getDTDAttrl)++    setDTDAttrValue	:: String -> String -> a XmlTree XmlTree+    setDTDAttrValue n v	= arr (XN.changeDTDAttrl (addEntry n v)) `when` isDTD++    mkDTDElem		:: DTDElem -> Attributes -> a n XmlTree -> a n XmlTree+    mkDTDElem e al cf	= listA cf >>> arr (XN.mkDTDElem e al)++    mkDTDDoctype	:: Attributes -> a n XmlTree -> a n XmlTree+    mkDTDDoctype	= mkDTDElem DOCTYPE++    mkDTDElement	:: Attributes -> a n XmlTree+    mkDTDElement al	= mkDTDElem ELEMENT al none++    mkDTDEntity		:: Attributes -> a n XmlTree+    mkDTDEntity al	= mkDTDElem ENTITY al none++    mkDTDPEntity	:: Attributes -> a n XmlTree+    mkDTDPEntity al	= mkDTDElem PENTITY al none++instance ArrowXml LA+instance ArrowXml (SLA s)+instance ArrowXml IOLA+instance ArrowXml (IOSLA s)++instance ArrowDTD LA+instance ArrowDTD (SLA s)+instance ArrowDTD IOLA+instance ArrowDTD (IOSLA s)++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/Arrow/XmlIOStateArrow.hs view
@@ -0,0 +1,965 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.Arrow.XmlIOStateArrow+   Copyright  : Copyright (C) 2005 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable+   Version    : $Id: XmlIOStateArrow.hs,v 1.39 2006/11/09 20:27:42 hxml Exp $++   the basic state arrows for XML processing++   A state is needed for global processing options,+   like encoding options, document base URI, trace levels+   and error message handling++   The state is separated into a user defined state+   and a system state. The system state contains variables+   for error message handling, for tracing, for the document base+   for accessing XML documents with relative references, e.g. DTDs,+   and a global key value store. This assoc list has strings as keys+   and lists of XmlTrees as values. It is used to store arbitrary+   XML and text values, e.g. user defined global options.++   The user defined part of the store is in the default case empty, defined as ().+   It can be extended with an arbitray data type++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.Arrow.XmlIOStateArrow+    ( -- * Data Types+      XIOState(..),+      XIOSysState(..),+      IOStateArrow,+      IOSArrow,++      -- * Running Arrows+      initialState,+      initialSysState,+      runX,++      -- * User State Manipulation+      getUserState,+      setUserState,+      changeUserState,+      withExtendedUserState,+      withOtherUserState,++      -- * Global System State Access+      getSysParam,+      changeSysParam,++      setParamList,+      setParam,+      unsetParam,+      getParam,+      getAllParams,+      getAllParamsString,+      setParamString,+      getParamString,+      setParamInt,+      getParamInt,+      +      -- * Error Message Handling+      clearErrStatus,+      setErrStatus,+      getErrStatus,+      setErrMsgStatus,+      setErrorMsgHandler,++      errorMsgStderr,+      errorMsgCollect,+      errorMsgStderrAndCollect,+      errorMsgIgnore,++      getErrorMessages,++      filterErrorMsg,+      issueWarn,+      issueErr,+      issueFatal,+      setDocumentStatus,+      setDocumentStatusFromSystemState,+      documentStatusOk,++      -- * Document Base+      setBaseURI,+      getBaseURI,+      changeBaseURI,+      setDefaultBaseURI,+      getDefaultBaseURI,+      runInLocalURIContext,++      -- * Tracing+      setTraceLevel,+      getTraceLevel,+      withTraceLevel,+      trace,+      traceMsg,+      traceValue,+      traceString,+      traceSource,+      traceTree,+      traceDoc,+      traceState,++      -- * URI Manipulation+      expandURIString,+      expandURI,+      mkAbsURI,++      getFragmentFromURI,+      getPathFromURI,+      getPortFromURI,+      getQueryFromURI,+      getRegNameFromURI,+      getSchemeFromURI,+      getUserInfoFromURI,++      -- * Mime Type Handling+      setMimeTypeTable,+      setMimeTypeTableFromFile+      )+where++import Control.Arrow				-- arrow classes+import Yuuko.Control.Arrow.ArrowList+import Yuuko.Control.Arrow.ArrowIf+import Yuuko.Control.Arrow.ArrowTree+import Yuuko.Control.Arrow.ArrowIO+import Yuuko.Control.Arrow.IOStateListArrow++import Control.Monad				( mplus )+import Control.DeepSeq++import Yuuko.Text.XML.HXT.DOM.Interface+import Yuuko.Text.XML.HXT.Arrow.XmlArrow++import Yuuko.Text.XML.HXT.Arrow.Edit+    ( addHeadlineToXmlDoc+    , treeRepOfXmlDoc+    , indentDoc+    )++import Data.Maybe++import Network.URI+    ( URI+    , escapeURIChar+    , isUnescapedInURI+    , nonStrictRelativeTo+    , parseURIReference+    , uriAuthority+    , uriFragment+    , uriPath+    , uriPort+    , uriQuery+    , uriRegName+    , uriScheme+    , uriUserInfo+    )++import System.IO+    ( hPutStrLn+    , hFlush+    , stderr+    )++import System.Directory+    ( getCurrentDirectory+    )++-- ------------------------------------------------------------+{- $datatypes -}+++-- |+-- predefined system state data type with all components for the+-- system functions, like trace, error handling, ...++data XIOSysState	= XIOSys  { xio_trace			:: ! Int+				  , xio_errorStatus		:: ! Int+				  , xio_errorModule		:: ! String+				  , xio_errorMsgHandler		::   String -> IO ()+				  , xio_errorMsgCollect		:: ! Bool+				  , xio_errorMsgList		:: ! XmlTrees+				  , xio_baseURI			:: ! String+				  , xio_defaultBaseURI		:: ! String+				  , xio_attrList		:: ! (AssocList String XmlTrees)+				  , xio_mimeTypes		::   MimeTypeTable+				  }++instance NFData XIOSysState where+    rnf (XIOSys tr es em _emh emc eml bu du al _mt)+	= rnf tr `seq` rnf es `seq` rnf em `seq` rnf emc `seq` rnf eml `seq` rnf bu `seq` rnf du `seq` rnf al++-- |+-- state datatype consists of a system state and a user state+-- the user state is not fixed++data XIOState us	= XIOState { xio_sysState		:: ! XIOSysState+				   , xio_userState		:: ! us+				   }++instance (NFData us) => NFData (XIOState us) where+    rnf (XIOState sys usr)	= rnf sys `seq` rnf usr++-- |+-- The arrow type for stateful arrows++type IOStateArrow s b c	= IOSLA (XIOState s) b c++-- |+-- The arrow for stateful arrows with no user defined state++type IOSArrow b c	= IOStateArrow () b c++-- ------------------------------------------------------------+++-- | the default global state, used as initial state when running an 'IOSArrow' with 'runIOSLA' or+-- 'runX'++initialState	:: us -> XIOState us+initialState s	= XIOState { xio_sysState 	= initialSysState+			   , xio_userState	= s+			   }++initialSysState	:: XIOSysState+initialSysState	= XIOSys { xio_trace		= 0+			 , xio_errorStatus	= c_ok+			 , xio_errorModule	= ""+			 , xio_errorMsgHandler	= hPutStrLn stderr+			 , xio_errorMsgCollect	= False+			 , xio_errorMsgList	= []+			 , xio_baseURI		= ""+			 , xio_defaultBaseURI	= ""+			 , xio_attrList		= []+			 , xio_mimeTypes	= defaultMimeTypeTable+			 }++-- ------------------------------------------------------------++-- |+-- apply an 'IOSArrow' to an empty root node with 'initialState' () as initial state+--+-- the main entry point for running a state arrow with IO+--+-- when running @ runX f@ an empty XML root node is applied to @f@.+-- usually @f@ will start with a constant arrow (ignoring the input), e.g. a 'Yuuko.Text.XML.HXT.Arrow.ReadDocument.readDocument' arrow.+--+-- for usage see examples with 'Yuuko.Text.XML.HXT.Arrow.WriteDocument.writeDocument'+--+-- if input has to be feed into the arrow use 'Yuuko.Control.Arrow.IOStateListArrow.runIOSLA' like in @ runIOSLA f emptyX inputDoc @++runX		:: IOSArrow XmlTree c -> IO [c]+runX		= runXIOState (initialState ())++runXIOState	:: XIOState s -> IOStateArrow s XmlTree c -> IO [c]+runXIOState s0 f+    = do+      (_finalState, res) <- runIOSLA (emptyRoot >>> f) s0 undefined+      return res+    where+    emptyRoot    = root [] []++-- ------------------------------------------------------------++{- user state -}++-- | read the user defined part of the state++getUserState	:: IOStateArrow s b s+getUserState+    = IOSLA $ \ s _ ->+      return (s, [xio_userState s])++-- | change the user defined part of the state++changeUserState		:: (b -> s -> s) -> IOStateArrow s b b+changeUserState cf+    = IOSLA $ \ s v ->+      let s' = s { xio_userState = cf v (xio_userState s) }+      in return (s', [v])++-- | set the user defined part of the state++setUserState		:: IOStateArrow s s s+setUserState+    = changeUserState const++-- | extend user state+--+-- Run an arrow with an extended user state component, The old component+-- is stored together with a new one in a pair, the arrow is executed with this+-- extended state, and the augmented state component is removed form the state+-- when the arrow has finished its execution++withExtendedUserState	:: s1 -> IOStateArrow (s1, s0) b c -> IOStateArrow s0 b c+withExtendedUserState initS1 f+    = IOSLA $ \ s0 x ->+      do+      ~(finalS, res) <- runIOSLA f ( XIOState { xio_sysState  =          xio_sysState  s0+					      , xio_userState = (initS1, xio_userState s0)+					      }+				   ) x+      return ( XIOState { xio_sysState  =      xio_sysState  finalS+			, xio_userState = snd (xio_userState finalS)+			}+	     , res+	     )++-- | change the type of user state+--+-- This conversion is useful, when running a state arrow with another+-- structure of the user state, e.g. with () when executing some IO arrows++withOtherUserState	:: s1 -> IOStateArrow s1 b c -> IOStateArrow s0 b c+withOtherUserState s1 f+    = IOSLA $ \ s x ->+      do+      (s', res) <- runIOSLA f ( XIOState { xio_sysState  = xio_sysState s+					 , xio_userState = s1+					 }+			      ) x+      return ( XIOState { xio_sysState  = xio_sysState  s'+			, xio_userState = xio_userState s+			}+	     , res+	     )++-- ------------------------------------------------------------++{- $system state params -}++getSysParam	:: (XIOSysState -> c) -> IOStateArrow s b c+getSysParam f+    = IOSLA $ \ s _x ->+      return (s, (:[]) . f . xio_sysState $ s)++changeSysParam		:: (b -> XIOSysState -> XIOSysState) -> IOStateArrow s b b+changeSysParam cf+    = ( IOSLA $ \ s v ->+	let s' = changeSysState (cf v) s+	in return (s', [v])+      )+    where+    changeSysState css s = s { xio_sysState = css (xio_sysState s) }++-- | store a single XML tree in global state under a given attribute name++setParam	:: String -> IOStateArrow s XmlTree XmlTree+setParam n+    = (:[]) ^>> setParamList n++-- | store a list of XML trees in global system state under a given attribute name++setParamList	:: String -> IOStateArrow s XmlTrees XmlTree+setParamList n+    = changeSysParam addE+      >>>+      arrL id+    where+    addE x s = s { xio_attrList = addEntry n x (xio_attrList s) }++-- | remove an entry in global state, arrow input remains unchanged++unsetParam	:: String -> IOStateArrow s b b+unsetParam n+    = changeSysParam delE+    where+    delE _ s = s { xio_attrList = delEntry n (xio_attrList s) }++-- | read an attribute value from global state++getParam	:: String -> IOStateArrow s b XmlTree+getParam n+    = getAllParams+      >>>+      arrL (lookup1 n)++-- | read all attributes from global state++getAllParams	:: IOStateArrow s b (AssocList String XmlTrees)+getAllParams+    = getSysParam xio_attrList++-- | read all attributes from global state+-- and convert the values to strings++getAllParamsString	:: IOStateArrow s b (AssocList String String)+getAllParamsString+    = getAllParams+      >>>+      listA ( unlistA+	      >>>+	      second (xshow unlistA)+	    )++setParamString	:: String -> String -> IOStateArrow s b b+setParamString n v+    = perform ( txt v+		>>>+		setParam n+	      )++-- | read a string value from global state,+-- if parameter not set \"\" is returned++getParamString	:: String -> IOStateArrow s b String+getParamString n+    = xshow (getParam n)++-- | store an int value in global state++setParamInt	:: String -> Int -> IOStateArrow s b b+setParamInt n v+    = setParamString n (show v)++-- | read an int value from global state+-- +-- > getParamInt 0 myIntAttr++getParamInt	:: Int -> String -> IOStateArrow s b Int+getParamInt def n+    = getParamString n+      >>^+      (\ x -> if null x then def else read x)++-- ------------------------------------------------------------++-- | reset global error variable++changeErrorStatus	:: (Int -> Int -> Int) -> IOStateArrow s Int Int+changeErrorStatus f+    = changeSysParam (\ l s -> s { xio_errorStatus = f l (xio_errorStatus s) })++clearErrStatus		:: IOStateArrow s b b+clearErrStatus+    = perform (constA 0 >>> changeErrorStatus min)++-- | set global error variable++setErrStatus		:: IOStateArrow s Int Int+setErrStatus+    = changeErrorStatus max++-- | read current global error status++getErrStatus		:: IOStateArrow s XmlTree Int+getErrStatus+    = getSysParam xio_errorStatus++-- | raise the global error status level to that of the input tree++setErrMsgStatus	:: IOStateArrow s XmlTree XmlTree+setErrMsgStatus+    = perform ( getErrorLevel+		>>>+		setErrStatus+	      )++-- | set the error message handler and the flag for collecting the errors++setErrorMsgHandler	:: Bool -> (String -> IO ()) -> IOStateArrow s b b+setErrorMsgHandler c f+    = changeSysParam cf+    where+    cf _ s = s { xio_errorMsgHandler = f+	       , xio_errorMsgCollect = c }++-- | error message handler for output to stderr+		  +sysErrorMsg		:: IOStateArrow s XmlTree XmlTree+sysErrorMsg+    = perform ( getErrorLevel &&& getErrorMsg+		>>>+		arr formatErrorMsg+		>>>+		( IOSLA $ \ s e ->+		  do+		  (xio_errorMsgHandler . xio_sysState $ s) e+		  return (s, undefined)+		)+	      )+    where+    formatErrorMsg (level, msg)	= "\n" ++ errClass level ++ ": " ++ msg+    errClass l+	= fromMaybe "fatal error" . lookup l $ msgList+	  where+	  msgList	= [ (c_ok,	"no error")+			  , (c_warn,	"warning")+			  , (c_err,	"error")+			  , (c_fatal,	"fatal error")+			  ]+++-- | the default error message handler: error output to stderr++errorMsgStderr		:: IOStateArrow s b b+errorMsgStderr		= setErrorMsgHandler False (hPutStrLn stderr)++-- | error message handler for collecting errors++errorMsgCollect		:: IOStateArrow s b b+errorMsgCollect		= setErrorMsgHandler True (const $ return ())++-- | error message handler for output to stderr and collecting++errorMsgStderrAndCollect	:: IOStateArrow s b b+errorMsgStderrAndCollect	= setErrorMsgHandler True (hPutStrLn stderr)++-- | error message handler for ignoring errors++errorMsgIgnore		:: IOStateArrow s b b+errorMsgIgnore		= setErrorMsgHandler False (const $ return ())++-- |+-- if error messages are collected by the error handler for+-- processing these messages by the calling application,+-- this arrow reads the stored messages and clears the error message store++getErrorMessages	:: IOStateArrow s b XmlTree+getErrorMessages+    = getSysParam (reverse . xio_errorMsgList)		-- reverse the list of errors+      >>>+      clearErrorMsgList					-- clear the error list in the system state+      >>>+      arrL id++clearErrorMsgList	:: IOStateArrow s b b+clearErrorMsgList+    = changeSysParam (\ _ s -> s { xio_errorMsgList = [] } )++addToErrorMsgList	:: IOStateArrow s XmlTree XmlTree+addToErrorMsgList+    = changeSysParam cf+    where+    cf t s = if xio_errorMsgCollect s+	     then s { xio_errorMsgList = t : xio_errorMsgList s }+	     else s++-- ------------------------------------------------------------++-- |+-- filter error messages from input trees and issue errors++filterErrorMsg		:: IOStateArrow s XmlTree XmlTree+filterErrorMsg+    = ( setErrMsgStatus+	>>>+	sysErrorMsg+	>>>+	addToErrorMsgList+	>>>+	none+      )+      `when`+      isError++-- | generate a warnig message++issueWarn		:: String -> IOStateArrow s b b+issueWarn msg		= perform (warn msg  >>> filterErrorMsg)++-- | generate an error message+issueErr		:: String -> IOStateArrow s b b+issueErr msg		= perform (err msg   >>> filterErrorMsg)++-- | generate a fatal error message, e.g. document not found++issueFatal		:: String -> IOStateArrow s b b+issueFatal msg		= perform (fatal msg >>> filterErrorMsg)++-- |+-- add the error level and the module where the error occured+-- to the attributes of a document root node and remove the children when level is greater or equal to 'c_err'.+-- called by 'setDocumentStatusFromSystemState' when the system state indicates an error++setDocumentStatus	:: Int -> String -> IOStateArrow s XmlTree XmlTree+setDocumentStatus level msg+    = ( addAttrl ( sattr a_status (show level)+		   <+>+		   sattr a_module msg+		 )+	>>>+	( if level >= c_err+	  then setChildren []+	  else this+	)+      )+      `when`+      isRoot++-- |+-- check whether the error level attribute in the system state+-- is set to error, in this case the children of the document root are+-- removed and the module name where the error occured and the error level are added as attributes with 'setDocumentStatus'+-- else nothing is changed++setDocumentStatusFromSystemState		:: String -> IOStateArrow s XmlTree XmlTree+setDocumentStatusFromSystemState msg+    = setStatus $< getErrStatus+    where+    setStatus level+	| level <= c_warn	= this+	| otherwise		= setDocumentStatus level msg+++-- |+-- check whether tree is a document root and the status attribute has a value less than 'c_err'++documentStatusOk	:: ArrowXml a => a XmlTree XmlTree+documentStatusOk+    = isRoot+      >>>+      ( (getAttrValue a_status+	 >>>+	 isA (\ v -> null v || ((read v)::Int) <= c_warn)+	)+	`guards`+	this+      )++-- ------------------------------------------------------------++-- | set the base URI of a document, used e.g. for reading includes, e.g. external entities,+-- the input must be an absolute URI++setBaseURI		:: IOStateArrow s String String+setBaseURI+    = changeSysParam (\ b s -> s { xio_baseURI = b } )+      >>>+      traceValue 2 (("setBaseURI: new base URI is " ++) . show)++-- | read the base URI from the globale state++getBaseURI		:: IOStateArrow s b String+getBaseURI+    = getSysParam xio_baseURI+      >>>+      ( ( getDefaultBaseURI+	  >>>+	  setBaseURI		+	  >>>+	  getBaseURI+	)+	`when`+	isA null				-- set and get it, if not yet done+      )++-- | change the base URI with a possibly relative URI, can be used for+-- evaluating the xml:base attribute. Returns the new absolute base URI.+-- Fails, if input is not parsable with parseURIReference+--+-- see also: 'setBaseURI', 'mkAbsURI'++changeBaseURI		:: IOStateArrow s String String+changeBaseURI+    = mkAbsURI+      >>>+      setBaseURI++-- | set the default base URI, if parameter is null, the system base (@ file:\/\/\/\<cwd\>\/ @) is used,+-- else the parameter, must be called before any document is read++setDefaultBaseURI	:: String -> IOStateArrow s b String+setDefaultBaseURI base+    = ( if null base+	then arrIO getDir+	else constA base+      )+      >>>+      changeSysParam (\ b s -> s { xio_defaultBaseURI = b } )+      >>>+      traceValue 2 (("setDefaultBaseURI: new default base URI is " ++) . show)+    where+    getDir _ = do+	       cwd <- getCurrentDirectory+	       return ("file://" ++ normalize cwd ++ "/")++    -- under Windows getCurrentDirectory returns something like: "c:\path\to\file"+    -- backslaches are not allowed in URIs and paths must start with a /+    -- so this is transformed into "/c:/path/to/file"++    normalize wd'@(d : ':' : _)+	| d `elem` ['A'..'Z'] || d `elem` ['a'..'z']+	    = '/' : concatMap win32ToUriChar wd'+    normalize wd'+	= concatMap escapeNonUriChar wd'+				 +    win32ToUriChar '\\' = "/"+    win32ToUriChar c    = escapeNonUriChar c++    escapeNonUriChar c  = escapeURIChar isUnescapedInURI c   -- from Network.URI+++-- | get the default base URI++getDefaultBaseURI	:: IOStateArrow s b String+getDefaultBaseURI+    = getSysParam xio_defaultBaseURI		-- read default uri in system  state+      >>>+      ( setDefaultBaseURI ""			-- set the default uri in system state+	>>>+	getDefaultBaseURI ) `when` isA null	-- when uri not yet set++-- ------------------------------------------------------------++-- | remember base uri, run an arrow and restore the base URI, used with external entity substitution++runInLocalURIContext	:: IOStateArrow s b c -> IOStateArrow s b c+runInLocalURIContext f+    = ( getBaseURI &&& this )+      >>>+      ( this *** listA f )+      >>>+      ( setBaseURI *** this )+      >>>+      arrL snd++-- ------------------------------------------------------------++-- | set the global trace level++setTraceLevel	:: Int -> IOStateArrow s b b+setTraceLevel l+    = changeSysParam (\ _ s -> s { xio_trace = l } )++-- | read the global trace level++getTraceLevel	:: IOStateArrow s b Int+getTraceLevel+    = getSysParam xio_trace++-- | run an arrow with a given trace level, the old trace level is restored after the arrow execution++withTraceLevel	:: Int -> IOStateArrow s b c -> IOStateArrow s b c+withTraceLevel level f+    = ( getTraceLevel       &&& this )+      >>>+      ( setTraceLevel level *** listA f )+      >>>+      ( restoreTraceLevel   *** this )+      >>>+      arrL snd+    where+    restoreTraceLevel	:: IOStateArrow s Int Int+    restoreTraceLevel+	= setTraceLevel $< this++-- | apply a trace arrow and issue message to stderr++trace		:: Int -> IOStateArrow s b String -> IOStateArrow s b b+trace level trc+    = perform ( trc+		>>>+		arrIO (\ s -> ( do+				hPutStrLn stderr s+				hFlush stderr+			      )+		      )+	      )+      `when` ( getTraceLevel+	       >>>+	       isA (>= level)+	     )++-- | trace the current value transfered in a sequence of arrows.+--+-- The value is formated by a string conversion function. This is a substitute for+-- the old and less general traceString function++traceValue		:: Int -> (b -> String) -> IOStateArrow s b b+traceValue level trc+    = trace level (arr $ (('-' : "- (" ++ show level ++ ") ") ++) . trc)++-- | an old alias for 'traceValue'++traceString		:: Int -> (b -> String) -> IOStateArrow s b b+traceString		= traceValue++-- | issue a string message as trace++traceMsg	:: Int -> String -> IOStateArrow s b b+traceMsg level msg+    = traceValue level (const msg)++-- | issue the source representation of a document if trace level >= 3+--+-- for better readability the source is formated with indentDoc++traceSource	:: IOStateArrow s XmlTree XmlTree+traceSource +    = trace 3 $+      xshow+      ( choiceA [ isRoot :-> ( indentDoc+			       >>>+			       getChildren+			     )+		, isElem :-> ( root [] [this]+			       >>> indentDoc+			       >>> getChildren+			       >>> isElem+			     )+		, this   :-> this+		]+      )++-- | issue the tree representation of a document if trace level >= 4+traceTree	:: IOStateArrow s XmlTree XmlTree+traceTree+    = trace 4 $+      xshow ( treeRepOfXmlDoc+	      >>>+	      addHeadlineToXmlDoc+	      >>>+	      getChildren+	    )++-- | trace a main computation step+-- issue a message when trace level >= 1, issue document source if level >= 3, issue tree when level is >= 4++traceDoc	:: String -> IOStateArrow s XmlTree XmlTree+traceDoc msg+    = traceMsg 1 msg+      >>>+      traceSource+      >>>+      traceTree++-- | trace the global state++traceState	:: IOStateArrow s b b+traceState+    = perform ( xshow ( (getAllParams >>. concat)+			>>>+			applyA (arr formatParam)+		      )+		>>>+		traceValue 2 ("global state:\n" ++)+	      )+      where+      -- formatParam	:: (String, XmlTrees) -> IOStateArrow s b1 XmlTree+      formatParam (n, v)+	  = mkelem "param" [sattr "name" n] [arrL (const v)] <+> txt "\n"++-- ----------------------------------------------------------++-- | parse a URI reference, in case of a failure try to escape special chars+-- and try parsing again++parseURIReference'	:: String -> Maybe URI+parseURIReference' uri+    = parseURIReference uri+      `mplus`+      parseURIReference uri'+    where+    uri' = concatMap ( escapeURIChar isUnescapedInURI) uri++-- | compute the absolut URI for a given URI and a base URI++expandURIString	:: String -> String -> Maybe String+expandURIString uri base+    = do+      base' <- parseURIReference' base+      uri'  <- parseURIReference' uri+      abs'  <- nonStrictRelativeTo uri' base'+      return $ show abs'++-- | arrow variant of 'expandURIString', fails if 'expandURIString' returns Nothing++expandURI		:: ArrowXml a => a (String, String) String+expandURI+    = arrL (maybeToList . uncurry expandURIString)++-- | arrow for expanding an input URI into an absolute URI using global base URI, fails if input is not a legal URI++mkAbsURI		:: IOStateArrow s String String+mkAbsURI+    = ( this &&& getBaseURI ) >>> expandURI++-- | arrow for selecting the scheme (protocol) of the URI, fails if input is not a legal URI.+--+-- See Network.URI for URI components++getSchemeFromURI	:: ArrowList a => a String String+getSchemeFromURI	= getPartFromURI scheme+    where+    scheme = init . uriScheme++-- | arrow for selecting the registered name (host) of the URI, fails if input is not a legal URI++getRegNameFromURI	:: ArrowList a => a String String+getRegNameFromURI	= getPartFromURI host+    where+    host = maybe "" uriRegName . uriAuthority++-- | arrow for selecting the port number of the URI without leading \':\', fails if input is not a legal URI++getPortFromURI		:: ArrowList a => a String String+getPortFromURI		= getPartFromURI port+    where+    port = dropWhile (==':') . maybe "" uriPort . uriAuthority++-- | arrow for selecting the user info of the URI without trailing \'\@\', fails if input is not a legal URI++getUserInfoFromURI		:: ArrowList a => a String String+getUserInfoFromURI		= getPartFromURI ui+    where+    ui = reverse . dropWhile (=='@') . reverse . maybe "" uriUserInfo . uriAuthority++-- | arrow for computing the path component of an URI, fails if input is not a legal URI++getPathFromURI		:: ArrowList a => a String String+getPathFromURI		= getPartFromURI uriPath++-- | arrow for computing the query component of an URI, fails if input is not a legal URI++getQueryFromURI		:: ArrowList a => a String String+getQueryFromURI		= getPartFromURI uriQuery++-- | arrow for computing the fragment component of an URI, fails if input is not a legal URI++getFragmentFromURI	:: ArrowList a => a String String+getFragmentFromURI	= getPartFromURI uriFragment++-- | arrow for computing the path component of an URI, fails if input is not a legal URI++getPartFromURI		:: ArrowList a => (URI -> String) -> a String String+getPartFromURI sel+    = arrL (maybeToList . getPart)+      where+      getPart s = do+		  uri <- parseURIReference' s+		  return (sel uri)++-- ------------------------------------------------------------++-- | set the table mapping of file extensions to mime types in the system state+--+-- Default table is defined in 'Yuuko.Text.XML.HXT.DOM.MimeTypeDefaults'.+-- This table is used when reading loacl files, (file: protocol) to determine the mime type++setMimeTypeTable	:: MimeTypeTable -> IOStateArrow s b b+setMimeTypeTable mtt+    = changeSysParam (\ _ s -> s {xio_mimeTypes = mtt})++-- | set the table mapping of file extensions to mime types by an external config file+--+-- The config file must follow the conventions of /etc/mime.types on a debian linux system,+-- that means all empty lines and all lines starting with a # are ignored. The other lines+-- must consist of a mime type followed by a possible empty list of extensions.+-- The list of extenstions and mime types overwrites the default list in the system state+-- of the IOStateArrow++setMimeTypeTableFromFile	:: FilePath -> IOStateArrow s b b+setMimeTypeTableFromFile file+    = setMimeTypeTable $< arrIO0 ( readMimeTypeTable file)++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/Arrow/XmlRegex.hs view
@@ -0,0 +1,304 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.Arrow.XmlRegex+   Copyright  : Copyright (C) 2008 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   Regular Expression Matcher working on lists of XmlTrees++   It's intendet to import this module with an explicit+   import declaration for not spoiling the namespace+   with these somewhat special arrows++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.Arrow.XmlRegex+    ( XmlRegex+    , mkZero+    , mkUnit+    , mkPrim+    , mkPrimA+    , mkDot+    , mkStar+    , mkAlt+    , mkSeq+    , mkRep+    , mkRng+    , mkOpt+    , nullable+    , delta+    , matchXmlRegex+    , splitXmlRegex+    , scanXmlRegex+    , matchRegexA+    , splitRegexA+    , scanRegexA+    )+where++import Yuuko.Control.Arrow.ListArrows++import Data.Maybe++import Yuuko.Text.XML.HXT.DOM.Interface++-- ------------------------------------------------------------+-- the exported regex arrows++-- | check whether a sequence of XmlTrees match an Xml regular expression+--+-- The arrow for 'matchXmlRegex'.+--+-- The expession is build up from simple arrows acting as predicate ('mkPrimA') for+-- an XmlTree and of the usual cobinators for sequence ('mkSeq'), repetition+-- ('mkStar', mkRep', 'mkRng') and choice ('mkAlt', 'mkOpt')++matchRegexA		:: XmlRegex -> LA XmlTree XmlTree -> LA XmlTree XmlTrees+matchRegexA re ts	= ts >>. (\ s -> maybe [] (const [s]) . matchXmlRegex re $ s)++-- | split the sequence of trees computed by the filter a into+--+-- The arrow for 'splitXmlRegex'.+--+-- a first part matching the regex and a rest,+-- if a prefix of the input sequence does not match the regex, the arrow fails+-- else the pair containing the result lists is returned++splitRegexA		:: XmlRegex -> LA XmlTree XmlTree -> LA XmlTree (XmlTrees, XmlTrees)+splitRegexA re ts	= ts >>. (maybeToList . splitXmlRegex re)++-- | scan the input sequence with a regex and give the result as a list of lists of trees back+-- the regex must at least match one input tree, so the empty sequence should not match the regex+--+-- The arrow for 'scanXmlRegex'.++scanRegexA		:: XmlRegex -> LA XmlTree XmlTree -> LA XmlTree XmlTrees+scanRegexA re ts	= ts >>. (fromMaybe [] . scanXmlRegex re)++-- ------------------------------------------------------------++data XmlRegex	= Zero String+		| Unit+		| Sym (XmlTree -> Bool)+		| Dot+		| Star XmlRegex+		| Alt XmlRegex XmlRegex+		| Seq XmlRegex XmlRegex+		| Rep Int XmlRegex		-- 1 or more repetitions+		| Rng Int Int XmlRegex	-- n..m repetitions++-- ------------------------------------------------------------++{- just for documentation++class Inv a where+    inv		:: a -> Bool++instance Inv XmlRegex where+    inv (Zero _)	= True+    inv Unit		= True+    inv (Sym p)		= p holds for some XmlTrees+    inv Dot		= True+    inv (Star e)	= inv e+    inv (Alt e1 e2)	= inv e1 &&+			  inv e2+    inv (Seq e1 e2)	= inv e1 &&+			  inv e2+    inv (Rep i e)	= i > 0 && inv e+    inv (Rng i j e)	= (i < j || (i == j && i > 1)) &&+			  inv e+-}+-- ------------------------------------------------------------+--+-- smart constructors++mkZero		:: String -> XmlRegex+mkZero		= Zero++mkUnit		:: XmlRegex+mkUnit		= Unit++mkPrim		:: (XmlTree -> Bool) -> XmlRegex+mkPrim		= Sym++mkPrimA		:: LA XmlTree XmlTree -> XmlRegex+mkPrimA a	= mkPrim (not . null . runLA a)++mkDot	:: XmlRegex+mkDot	= Dot++mkStar			:: XmlRegex -> XmlRegex+mkStar (Zero _)		= mkUnit		-- {}* == ()+mkStar e@Unit		= e			-- ()* == ()+mkStar e@(Star _e1)	= e			-- (r*)* == r*+mkStar (Rep 1 e1)	= mkStar e1		-- (r+)* == r*+mkStar e@(Alt _ _)	= Star (rmStar e)	-- (a*|b)* == (a|b)*+mkStar e		= Star e++rmStar	:: XmlRegex -> XmlRegex+rmStar (Alt e1 e2)	= mkAlt (rmStar e1) (rmStar e2)+rmStar (Star e1)	= rmStar e1+rmStar (Rep 1 e1)	= rmStar e1+rmStar e1		= e1++mkAlt					:: XmlRegex -> XmlRegex -> XmlRegex+mkAlt e1            (Zero _)		= e1				-- e1 u {} = e1+mkAlt (Zero _)      e2			= e2				-- {} u e2 = e2+mkAlt e1@(Star Dot) _e2			= e1				-- A* u e1 = A*+mkAlt _e1           e2@(Star Dot)	= e2				-- e1 u A* = A*+mkAlt (Sym p1)      (Sym p2)		= mkPrim $ \ x -> p1 x || p2 x	-- melting of predicates+mkAlt e1            e2@(Sym _)		= mkAlt e2 e1			-- symmetry: predicates always first+mkAlt e1@(Sym _)    (Alt e2@(Sym _) e3)	= mkAlt (mkAlt e1 e2) e3	-- prepare melting of predicates+mkAlt (Alt e1 e2)   e3			= mkAlt e1 (mkAlt e2 e3)	-- associativity+mkAlt e1 e2				= Alt e1 e2++mkSeq				:: XmlRegex -> XmlRegex -> XmlRegex+mkSeq e1@(Zero _) _e2		= e1+mkSeq _e1         e2@(Zero _)	= e2+mkSeq Unit        e2		= e2+mkSeq e1          Unit		= e1+mkSeq (Seq e1 e2) e3		= mkSeq e1 (mkSeq e2 e3)+mkSeq e1 e2			= Seq e1 e2++mkRep		:: Int -> XmlRegex -> XmlRegex+mkRep 0 e			= mkStar e+mkRep _ e@(Zero _)		= e+mkRep _ e@Unit			= e+mkRep i e			= Rep i e++mkRng	:: Int -> Int -> XmlRegex -> XmlRegex+mkRng 0  0  _e			= mkUnit+mkRng 1  1  e			= e+mkRng lb ub _e+    | lb > ub			= Zero $+				  "illegal range " +++				  show lb ++ ".." ++ show ub+mkRng _l _u e@(Zero _)		= e+mkRng _l _u e@Unit		= e+mkRng lb ub e			= Rng lb ub e++mkOpt	:: XmlRegex -> XmlRegex+mkOpt	= mkRng 0 1++-- ------------------------------------------------------------++instance Show XmlRegex where+    show (Zero s)	= "{err:" ++ s ++ "}"+    show Unit		= "()"+    show (Sym _p)	= "{single tree pred}"+    show Dot		= "."+    show (Star e)	= "(" ++ show e ++ ")*"+    show (Alt e1 e2)	= "(" ++ show e1 ++ "|" ++ show e2 ++ ")"+    show (Seq e1 e2)	= show e1 ++ show e2+    show (Rep 1 e)	= "(" ++ show e ++ ")+"+    show (Rep i e)	= "(" ++ show e ++ "){" ++ show i ++ ",}"+    show (Rng 0 1 e)	= "(" ++ show e ++ ")?"+    show (Rng i j e)	= "(" ++ show e ++ "){" ++ show i ++ "," ++ show j ++ "}"++-- ------------------------------------------------------------++nullable	:: XmlRegex -> Bool+nullable (Zero _)	= False+nullable Unit		= True+nullable (Sym _p)	= False		-- assumption: p holds for at least one tree+nullable Dot		= False+nullable (Star _)	= True+nullable (Alt e1 e2)	= nullable e1 ||+			  nullable e2+nullable (Seq e1 e2)	= nullable e1 &&+			  nullable e2+nullable (Rep _i e)	= nullable e+nullable (Rng i _ e)	= i == 0 ||+			  nullable e++-- ------------------------------------------------------------++delta	:: XmlRegex -> XmlTree -> XmlRegex+delta e@(Zero _)  _	= e+delta Unit        c	= mkZero $+			  "unexpected char " ++ show c+delta (Sym p)     c+    | p c		= mkUnit+    | otherwise		= mkZero $+			  "unexpected tree " ++ show c+delta Dot         _	= mkUnit+delta e@(Star e1) c	= mkSeq (delta e1 c) e+delta (Alt e1 e2) c	= mkAlt (delta e1 c) (delta e2 c)+delta (Seq e1 e2) c+    | nullable e1	= mkAlt (mkSeq (delta e1 c) e2) (delta e2 c)+    | otherwise		= mkSeq (delta e1 c) e2+delta (Rep i e)   c	= mkSeq (delta e c) (mkRep (i-1) e)+delta (Rng i j e) c	= mkSeq (delta e c) (mkRng ((i-1) `max` 0) (j-1) e)++-- ------------------------------------------------------------++delta'		:: XmlRegex -> XmlTrees -> XmlRegex+delta'		= foldl delta++-- | match a sequence of XML trees with a regular expression over trees+--+-- If the input matches, the result is Nothing, else Just an error message is returned++matchXmlRegex		:: XmlRegex -> XmlTrees -> Maybe String+matchXmlRegex e+    = res . delta' e+    where+    res (Zero er)	= Just er+    res re+	| nullable re	= Nothing	-- o.k.+	| otherwise	= Just $ "input does not match " ++ show e++-- ------------------------------------------------------------++-- | split a sequence of XML trees into a pair of a a matching prefix and a rest+--+-- If there is no matching prefix, Nothing is returned++splitXmlRegex		:: XmlRegex -> XmlTrees -> Maybe (XmlTrees, XmlTrees)+splitXmlRegex re	= splitXmlRegex' re []++splitXmlRegex' 		:: XmlRegex -> XmlTrees -> XmlTrees -> Maybe (XmlTrees, XmlTrees)+splitXmlRegex' re res []+    | nullable re	= Just (reverse res, [])+    | otherwise		= Nothing++splitXmlRegex' (Zero _) _ _+			= Nothing++splitXmlRegex' re res xs@(x:xs')+    | isJust res'	= res'+    | nullable re	= Just (reverse res, xs)+    | otherwise		= Nothing+    where+    re'  = delta re x+    res' = splitXmlRegex' re' (x:res) xs'++-- ------------------------------------------------------------++-- | scan a sequence of XML trees and split it into parts matching the given regex+--+-- If the parts cannot be split because of a missing match, or because of the+-- empty sequence as match, Nothing is returned++scanXmlRegex				:: XmlRegex -> XmlTrees -> Maybe [XmlTrees]+scanXmlRegex re ts			= scanXmlRegex' re (splitXmlRegex re ts)++scanXmlRegex'				:: XmlRegex -> Maybe (XmlTrees, XmlTrees) -> Maybe [XmlTrees]+scanXmlRegex' _  Nothing		= Nothing+scanXmlRegex' _  (Just (rs, []))	= Just [rs]+scanXmlRegex' _  (Just ([], _))		= Nothing	-- re is nullable (the empty word matches), nothing split off+							-- would give infinite list of empty lists+scanXmlRegex' re (Just (rs, rest))+    | isNothing res			= Nothing+    | otherwise				= Just (rs : fromJust res)+    where+    res = scanXmlRegex' re (splitXmlRegex re rest)++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/DOM/FormatXmlTree.hs view
@@ -0,0 +1,74 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.DOM.FormatXmlTree+   Copyright  : Copyright (C) 2008 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : stable+   Portability: portable++   Format a xml tree in tree representation++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.DOM.FormatXmlTree+    ( formatXmlTree+    , formatXmlContents+    )+where++import Yuuko.Text.XML.HXT.DOM.Interface+import Yuuko.Text.XML.HXT.DOM.ShowXml+import Yuuko.Text.XML.HXT.DOM.XmlNode++import Data.Maybe++-- ------------------------------------------------------------+++formatXmlContents	:: XmlTree -> XmlTrees+formatXmlContents t+    = [mkText (formatXmlTree t)]++formatXmlTree		:: XmlTree  -> String+formatXmlTree+    = formatTree xnode2String++xnode2String	:: XNode -> String+xnode2String n+    | isElem n+	= "XTag " ++ showName n ++ showAtts n+    | isPi n+	= "XPi "  ++ showName n ++ showAtts n+    | otherwise+	= show n+    where++showName	:: XNode -> String+showName	= maybe "" showQn . getName++showAtts	:: XNode -> String+showAtts	= concatMap showAl . fromMaybe [] . getAttrl++showAl		:: XmlTree -> String+showAl t	-- (NTree (XAttr an) av)+    | isAttr t+	= "\n|   " ++ (maybe "" showQn . getName $ t) ++ "=" ++ show (xshow . getChildren $ t)+    | otherwise+	= show t++showQn		:: QName -> String+showQn n+    | null ns+	= show $ qualifiedName n+    | otherwise+	= show $ "{" ++ ns ++ "}" ++ qualifiedName n+    where+    ns = namespaceUri n++-- ------------------------------------------------------------+
+ src/Yuuko/Text/XML/HXT/DOM/Interface.hs view
@@ -0,0 +1,36 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.DOM.Interface+   Copyright  : Copyright (C) 2008 Uwe Schmidt+   License    : MIT+++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : stable+   Portability: portable++   The interface to the primitive DOM data types and constants+   and utility functions++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.DOM.Interface+    ( module Yuuko.Text.XML.HXT.DOM.XmlKeywords+    , module Yuuko.Text.XML.HXT.DOM.TypeDefs+    , module Yuuko.Text.XML.HXT.DOM.Util+    , module Yuuko.Text.XML.HXT.DOM.XmlOptions+    , module Yuuko.Text.XML.HXT.DOM.MimeTypes+    )+where++import Yuuko.Text.XML.HXT.DOM.XmlKeywords		-- constants+import Yuuko.Text.XML.HXT.DOM.TypeDefs		-- XML Tree types+import Yuuko.Text.XML.HXT.DOM.Util+import Yuuko.Text.XML.HXT.DOM.XmlOptions		-- predefined options+import Yuuko.Text.XML.HXT.DOM.MimeTypes		-- mime types related stuff+++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/DOM/IsoLatinTables.hs view
@@ -0,0 +1,719 @@+module Yuuko.Text.XML.HXT.DOM.IsoLatinTables+where++iso_8859_2	:: [(Char, Char)]+iso_8859_2+    = [ ('\161', '\260' )+      , ('\162', '\728' )+      , ('\163', '\321' )+      , ('\165', '\317' )+      , ('\166', '\346' )+      , ('\169', '\352' )+      , ('\170', '\350' )+      , ('\171', '\356' )+      , ('\172', '\377' )+      , ('\174', '\381' )+      , ('\175', '\379' )+      , ('\177', '\261' )+      , ('\178', '\731' )+      , ('\179', '\322' )+      , ('\181', '\318' )+      , ('\182', '\347' )+      , ('\183', '\711' )+      , ('\185', '\353' )+      , ('\186', '\351' )+      , ('\187', '\357' )+      , ('\188', '\378' )+      , ('\189', '\733' )+      , ('\190', '\382' )+      , ('\191', '\380' )+      , ('\192', '\340' )+      , ('\195', '\258' )+      , ('\197', '\313' )+      , ('\198', '\262' )+      , ('\200', '\268' )+      , ('\202', '\280' )+      , ('\204', '\282' )+      , ('\207', '\270' )+      , ('\208', '\272' )+      , ('\209', '\323' )+      , ('\210', '\327' )+      , ('\213', '\336' )+      , ('\216', '\344' )+      , ('\217', '\366' )+      , ('\219', '\368' )+      , ('\222', '\354' )+      , ('\224', '\341' )+      , ('\227', '\259' )+      , ('\229', '\314' )+      , ('\230', '\263' )+      , ('\232', '\269' )+      , ('\234', '\281' )+      , ('\236', '\283' )+      , ('\239', '\271' )+      , ('\240', '\273' )+      , ('\241', '\324' )+      , ('\242', '\328' )+      , ('\245', '\337' )+      , ('\248', '\345' )+      , ('\249', '\367' )+      , ('\251', '\369' )+      , ('\254', '\355' )+      , ('\255', '\729' )+      ]++iso_8859_3	:: [(Char, Char)]+iso_8859_3+    = [ ('\161', '\294' )+      , ('\162', '\728' )+      , ('\166', '\292' )+      , ('\169', '\304' )+      , ('\170', '\350' )+      , ('\171', '\286' )+      , ('\172', '\308' )+      , ('\175', '\379' )+      , ('\177', '\295' )+      , ('\182', '\293' )+      , ('\185', '\305' )+      , ('\186', '\351' )+      , ('\187', '\287' )+      , ('\188', '\309' )+      , ('\191', '\380' )+      , ('\197', '\266' )+      , ('\198', '\264' )+      , ('\213', '\288' )+      , ('\216', '\284' )+      , ('\221', '\364' )+      , ('\222', '\348' )+      , ('\229', '\267' )+      , ('\230', '\265' )+      , ('\245', '\289' )+      , ('\248', '\285' )+      , ('\253', '\365' )+      , ('\254', '\349' )+      , ('\255', '\729' )+      ]++iso_8859_4	:: [(Char, Char)]+iso_8859_4+    = [ ('\161', '\260' )+      , ('\162', '\312' )+      , ('\163', '\342' )+      , ('\165', '\296' )+      , ('\166', '\315' )+      , ('\169', '\352' )+      , ('\170', '\274' )+      , ('\171', '\290' )+      , ('\172', '\358' )+      , ('\174', '\381' )+      , ('\177', '\261' )+      , ('\178', '\731' )+      , ('\179', '\343' )+      , ('\181', '\297' )+      , ('\182', '\316' )+      , ('\183', '\711' )+      , ('\185', '\353' )+      , ('\186', '\275' )+      , ('\187', '\291' )+      , ('\188', '\359' )+      , ('\189', '\330' )+      , ('\190', '\382' )+      , ('\191', '\331' )+      , ('\192', '\256' )+      , ('\199', '\302' )+      , ('\200', '\268' )+      , ('\202', '\280' )+      , ('\204', '\278' )+      , ('\207', '\298' )+      , ('\208', '\272' )+      , ('\209', '\325' )+      , ('\210', '\332' )+      , ('\211', '\310' )+      , ('\217', '\370' )+      , ('\221', '\360' )+      , ('\222', '\362' )+      , ('\224', '\257' )+      , ('\231', '\303' )+      , ('\232', '\269' )+      , ('\234', '\281' )+      , ('\236', '\279' )+      , ('\239', '\299' )+      , ('\240', '\273' )+      , ('\241', '\326' )+      , ('\242', '\333' )+      , ('\243', '\311' )+      , ('\249', '\371' )+      , ('\253', '\361' )+      , ('\254', '\363' )+      , ('\255', '\729' )+      ]++iso_8859_5	:: [(Char, Char)]+iso_8859_5+    = [ ('\161', '\1025' )+      , ('\162', '\1026' )+      , ('\163', '\1027' )+      , ('\164', '\1028' )+      , ('\165', '\1029' )+      , ('\166', '\1030' )+      , ('\167', '\1031' )+      , ('\168', '\1032' )+      , ('\169', '\1033' )+      , ('\170', '\1034' )+      , ('\171', '\1035' )+      , ('\172', '\1036' )+      , ('\174', '\1038' )+      , ('\175', '\1039' )+      , ('\176', '\1040' )+      , ('\177', '\1041' )+      , ('\178', '\1042' )+      , ('\179', '\1043' )+      , ('\180', '\1044' )+      , ('\181', '\1045' )+      , ('\182', '\1046' )+      , ('\183', '\1047' )+      , ('\184', '\1048' )+      , ('\185', '\1049' )+      , ('\186', '\1050' )+      , ('\187', '\1051' )+      , ('\188', '\1052' )+      , ('\189', '\1053' )+      , ('\190', '\1054' )+      , ('\191', '\1055' )+      , ('\192', '\1056' )+      , ('\193', '\1057' )+      , ('\194', '\1058' )+      , ('\195', '\1059' )+      , ('\196', '\1060' )+      , ('\197', '\1061' )+      , ('\198', '\1062' )+      , ('\199', '\1063' )+      , ('\200', '\1064' )+      , ('\201', '\1065' )+      , ('\202', '\1066' )+      , ('\203', '\1067' )+      , ('\204', '\1068' )+      , ('\205', '\1069' )+      , ('\206', '\1070' )+      , ('\207', '\1071' )+      , ('\208', '\1072' )+      , ('\209', '\1073' )+      , ('\210', '\1074' )+      , ('\211', '\1075' )+      , ('\212', '\1076' )+      , ('\213', '\1077' )+      , ('\214', '\1078' )+      , ('\215', '\1079' )+      , ('\216', '\1080' )+      , ('\217', '\1081' )+      , ('\218', '\1082' )+      , ('\219', '\1083' )+      , ('\220', '\1084' )+      , ('\221', '\1085' )+      , ('\222', '\1086' )+      , ('\223', '\1087' )+      , ('\224', '\1088' )+      , ('\225', '\1089' )+      , ('\226', '\1090' )+      , ('\227', '\1091' )+      , ('\228', '\1092' )+      , ('\229', '\1093' )+      , ('\230', '\1094' )+      , ('\231', '\1095' )+      , ('\232', '\1096' )+      , ('\233', '\1097' )+      , ('\234', '\1098' )+      , ('\235', '\1099' )+      , ('\236', '\1100' )+      , ('\237', '\1101' )+      , ('\238', '\1102' )+      , ('\239', '\1103' )+      , ('\240', '\8470' )+      , ('\241', '\1105' )+      , ('\242', '\1106' )+      , ('\243', '\1107' )+      , ('\244', '\1108' )+      , ('\245', '\1109' )+      , ('\246', '\1110' )+      , ('\247', '\1111' )+      , ('\248', '\1112' )+      , ('\249', '\1113' )+      , ('\250', '\1114' )+      , ('\251', '\1115' )+      , ('\252', '\1116' )+      , ('\253', '\167' )+      , ('\254', '\1118' )+      , ('\255', '\1119' )+      ]++iso_8859_6	:: [(Char, Char)]+iso_8859_6+    = [ ('\172', '\1548' )+      , ('\187', '\1563' )+      , ('\191', '\1567' )+      , ('\193', '\1569' )+      , ('\194', '\1570' )+      , ('\195', '\1571' )+      , ('\196', '\1572' )+      , ('\197', '\1573' )+      , ('\198', '\1574' )+      , ('\199', '\1575' )+      , ('\200', '\1576' )+      , ('\201', '\1577' )+      , ('\202', '\1578' )+      , ('\203', '\1579' )+      , ('\204', '\1580' )+      , ('\205', '\1581' )+      , ('\206', '\1582' )+      , ('\207', '\1583' )+      , ('\208', '\1584' )+      , ('\209', '\1585' )+      , ('\210', '\1586' )+      , ('\211', '\1587' )+      , ('\212', '\1588' )+      , ('\213', '\1589' )+      , ('\214', '\1590' )+      , ('\215', '\1591' )+      , ('\216', '\1592' )+      , ('\217', '\1593' )+      , ('\218', '\1594' )+      , ('\224', '\1600' )+      , ('\225', '\1601' )+      , ('\226', '\1602' )+      , ('\227', '\1603' )+      , ('\228', '\1604' )+      , ('\229', '\1605' )+      , ('\230', '\1606' )+      , ('\231', '\1607' )+      , ('\232', '\1608' )+      , ('\233', '\1609' )+      , ('\234', '\1610' )+      , ('\235', '\1611' )+      , ('\236', '\1612' )+      , ('\237', '\1613' )+      , ('\238', '\1614' )+      , ('\239', '\1615' )+      , ('\240', '\1616' )+      , ('\241', '\1617' )+      , ('\242', '\1618' )+      ]++iso_8859_7	:: [(Char, Char)]+iso_8859_7+    = [ ('\161', '\8216' )+      , ('\162', '\8217' )+      , ('\164', '\8364' )+      , ('\165', '\8367' )+      , ('\170', '\890' )+      , ('\175', '\8213' )+      , ('\180', '\900' )+      , ('\181', '\901' )+      , ('\182', '\902' )+      , ('\184', '\904' )+      , ('\185', '\905' )+      , ('\186', '\906' )+      , ('\188', '\908' )+      , ('\190', '\910' )+      , ('\191', '\911' )+      , ('\192', '\912' )+      , ('\193', '\913' )+      , ('\194', '\914' )+      , ('\195', '\915' )+      , ('\196', '\916' )+      , ('\197', '\917' )+      , ('\198', '\918' )+      , ('\199', '\919' )+      , ('\200', '\920' )+      , ('\201', '\921' )+      , ('\202', '\922' )+      , ('\203', '\923' )+      , ('\204', '\924' )+      , ('\205', '\925' )+      , ('\206', '\926' )+      , ('\207', '\927' )+      , ('\208', '\928' )+      , ('\209', '\929' )+      , ('\211', '\931' )+      , ('\212', '\932' )+      , ('\213', '\933' )+      , ('\214', '\934' )+      , ('\215', '\935' )+      , ('\216', '\936' )+      , ('\217', '\937' )+      , ('\218', '\938' )+      , ('\219', '\939' )+      , ('\220', '\940' )+      , ('\221', '\941' )+      , ('\222', '\942' )+      , ('\223', '\943' )+      , ('\224', '\944' )+      , ('\225', '\945' )+      , ('\226', '\946' )+      , ('\227', '\947' )+      , ('\228', '\948' )+      , ('\229', '\949' )+      , ('\230', '\950' )+      , ('\231', '\951' )+      , ('\232', '\952' )+      , ('\233', '\953' )+      , ('\234', '\954' )+      , ('\235', '\955' )+      , ('\236', '\956' )+      , ('\237', '\957' )+      , ('\238', '\958' )+      , ('\239', '\959' )+      , ('\240', '\960' )+      , ('\241', '\961' )+      , ('\242', '\962' )+      , ('\243', '\963' )+      , ('\244', '\964' )+      , ('\245', '\965' )+      , ('\246', '\966' )+      , ('\247', '\967' )+      , ('\248', '\968' )+      , ('\249', '\969' )+      , ('\250', '\970' )+      , ('\251', '\971' )+      , ('\252', '\972' )+      , ('\253', '\973' )+      , ('\254', '\974' )+      ]++iso_8859_8	:: [(Char, Char)]+iso_8859_8+    = [ ('\170', '\215' )+      , ('\186', '\247' )+      , ('\223', '\8215' )+      , ('\224', '\1488' )+      , ('\225', '\1489' )+      , ('\226', '\1490' )+      , ('\227', '\1491' )+      , ('\228', '\1492' )+      , ('\229', '\1493' )+      , ('\230', '\1494' )+      , ('\231', '\1495' )+      , ('\232', '\1496' )+      , ('\233', '\1497' )+      , ('\234', '\1498' )+      , ('\235', '\1499' )+      , ('\236', '\1500' )+      , ('\237', '\1501' )+      , ('\238', '\1502' )+      , ('\239', '\1503' )+      , ('\240', '\1504' )+      , ('\241', '\1505' )+      , ('\242', '\1506' )+      , ('\243', '\1507' )+      , ('\244', '\1508' )+      , ('\245', '\1509' )+      , ('\246', '\1510' )+      , ('\247', '\1511' )+      , ('\248', '\1512' )+      , ('\249', '\1513' )+      , ('\250', '\1514' )+      , ('\253', '\8206' )+      , ('\254', '\8207' )+      ]++iso_8859_9	:: [(Char, Char)]+iso_8859_9+    = [ ('\208', '\286' )+      , ('\221', '\304' )+      , ('\222', '\350' )+      , ('\240', '\287' )+      , ('\253', '\305' )+      , ('\254', '\351' )+      ]++iso_8859_10	:: [(Char, Char)]+iso_8859_10+    = [ ('\161', '\260' )+      , ('\162', '\274' )+      , ('\163', '\290' )+      , ('\164', '\298' )+      , ('\165', '\296' )+      , ('\166', '\310' )+      , ('\168', '\315' )+      , ('\169', '\272' )+      , ('\170', '\352' )+      , ('\171', '\358' )+      , ('\172', '\381' )+      , ('\174', '\362' )+      , ('\175', '\330' )+      , ('\177', '\261' )+      , ('\178', '\275' )+      , ('\179', '\291' )+      , ('\180', '\299' )+      , ('\181', '\297' )+      , ('\182', '\311' )+      , ('\184', '\316' )+      , ('\185', '\273' )+      , ('\186', '\353' )+      , ('\187', '\359' )+      , ('\188', '\382' )+      , ('\189', '\8213' )+      , ('\190', '\363' )+      , ('\191', '\331' )+      , ('\192', '\256' )+      , ('\199', '\302' )+      , ('\200', '\268' )+      , ('\202', '\280' )+      , ('\204', '\278' )+      , ('\209', '\325' )+      , ('\210', '\332' )+      , ('\215', '\360' )+      , ('\217', '\370' )+      , ('\224', '\257' )+      , ('\231', '\303' )+      , ('\232', '\269' )+      , ('\234', '\281' )+      , ('\236', '\279' )+      , ('\241', '\326' )+      , ('\242', '\333' )+      , ('\247', '\361' )+      , ('\249', '\371' )+      , ('\255', '\312' )+      ]++iso_8859_11	:: [(Char, Char)]+iso_8859_11+    = [ ('\161', '\3585' )+      , ('\162', '\3586' )+      , ('\163', '\3587' )+      , ('\164', '\3588' )+      , ('\165', '\3589' )+      , ('\166', '\3590' )+      , ('\167', '\3591' )+      , ('\168', '\3592' )+      , ('\169', '\3593' )+      , ('\170', '\3594' )+      , ('\171', '\3595' )+      , ('\172', '\3596' )+      , ('\173', '\3597' )+      , ('\174', '\3598' )+      , ('\175', '\3599' )+      , ('\176', '\3600' )+      , ('\177', '\3601' )+      , ('\178', '\3602' )+      , ('\179', '\3603' )+      , ('\180', '\3604' )+      , ('\181', '\3605' )+      , ('\182', '\3606' )+      , ('\183', '\3607' )+      , ('\184', '\3608' )+      , ('\185', '\3609' )+      , ('\186', '\3610' )+      , ('\187', '\3611' )+      , ('\188', '\3612' )+      , ('\189', '\3613' )+      , ('\190', '\3614' )+      , ('\191', '\3615' )+      , ('\192', '\3616' )+      , ('\193', '\3617' )+      , ('\194', '\3618' )+      , ('\195', '\3619' )+      , ('\196', '\3620' )+      , ('\197', '\3621' )+      , ('\198', '\3622' )+      , ('\199', '\3623' )+      , ('\200', '\3624' )+      , ('\201', '\3625' )+      , ('\202', '\3626' )+      , ('\203', '\3627' )+      , ('\204', '\3628' )+      , ('\205', '\3629' )+      , ('\206', '\3630' )+      , ('\207', '\3631' )+      , ('\208', '\3632' )+      , ('\209', '\3633' )+      , ('\210', '\3634' )+      , ('\211', '\3635' )+      , ('\212', '\3636' )+      , ('\213', '\3637' )+      , ('\214', '\3638' )+      , ('\215', '\3639' )+      , ('\216', '\3640' )+      , ('\217', '\3641' )+      , ('\218', '\3642' )+      , ('\223', '\3647' )+      , ('\224', '\3648' )+      , ('\225', '\3649' )+      , ('\226', '\3650' )+      , ('\227', '\3651' )+      , ('\228', '\3652' )+      , ('\229', '\3653' )+      , ('\230', '\3654' )+      , ('\231', '\3655' )+      , ('\232', '\3656' )+      , ('\233', '\3657' )+      , ('\234', '\3658' )+      , ('\235', '\3659' )+      , ('\236', '\3660' )+      , ('\237', '\3661' )+      , ('\238', '\3662' )+      , ('\239', '\3663' )+      , ('\240', '\3664' )+      , ('\241', '\3665' )+      , ('\242', '\3666' )+      , ('\243', '\3667' )+      , ('\244', '\3668' )+      , ('\245', '\3669' )+      , ('\246', '\3670' )+      , ('\247', '\3671' )+      , ('\248', '\3672' )+      , ('\249', '\3673' )+      , ('\250', '\3674' )+      , ('\251', '\3675' )+      ]++iso_8859_13	:: [(Char, Char)]+iso_8859_13+    = [ ('\161', '\8221' )+      , ('\165', '\8222' )+      , ('\168', '\216' )+      , ('\170', '\342' )+      , ('\175', '\198' )+      , ('\180', '\8220' )+      , ('\184', '\248' )+      , ('\186', '\343' )+      , ('\191', '\230' )+      , ('\192', '\260' )+      , ('\193', '\302' )+      , ('\194', '\256' )+      , ('\195', '\262' )+      , ('\198', '\280' )+      , ('\199', '\274' )+      , ('\200', '\268' )+      , ('\202', '\377' )+      , ('\203', '\278' )+      , ('\204', '\290' )+      , ('\205', '\310' )+      , ('\206', '\298' )+      , ('\207', '\315' )+      , ('\208', '\352' )+      , ('\209', '\323' )+      , ('\210', '\325' )+      , ('\212', '\332' )+      , ('\216', '\370' )+      , ('\217', '\321' )+      , ('\218', '\346' )+      , ('\219', '\362' )+      , ('\221', '\379' )+      , ('\222', '\381' )+      , ('\224', '\261' )+      , ('\225', '\303' )+      , ('\226', '\257' )+      , ('\227', '\263' )+      , ('\230', '\281' )+      , ('\231', '\275' )+      , ('\232', '\269' )+      , ('\234', '\378' )+      , ('\235', '\279' )+      , ('\236', '\291' )+      , ('\237', '\311' )+      , ('\238', '\299' )+      , ('\239', '\316' )+      , ('\240', '\353' )+      , ('\241', '\324' )+      , ('\242', '\326' )+      , ('\244', '\333' )+      , ('\248', '\371' )+      , ('\249', '\322' )+      , ('\250', '\347' )+      , ('\251', '\363' )+      , ('\253', '\380' )+      , ('\254', '\382' )+      , ('\255', '\8217' )+      ]++iso_8859_14	:: [(Char, Char)]+iso_8859_14+    = [ ('\161', '\7682' )+      , ('\162', '\7683' )+      , ('\164', '\266' )+      , ('\165', '\267' )+      , ('\166', '\7690' )+      , ('\168', '\7808' )+      , ('\170', '\7810' )+      , ('\171', '\7691' )+      , ('\172', '\7922' )+      , ('\175', '\376' )+      , ('\176', '\7710' )+      , ('\177', '\7711' )+      , ('\178', '\288' )+      , ('\179', '\289' )+      , ('\180', '\7744' )+      , ('\181', '\7745' )+      , ('\183', '\7766' )+      , ('\184', '\7809' )+      , ('\185', '\7767' )+      , ('\186', '\7811' )+      , ('\187', '\7776' )+      , ('\188', '\7923' )+      , ('\189', '\7812' )+      , ('\190', '\7813' )+      , ('\191', '\7777' )+      , ('\208', '\372' )+      , ('\215', '\7786' )+      , ('\222', '\374' )+      , ('\240', '\373' )+      , ('\247', '\7787' )+      , ('\254', '\375' )+      ]++iso_8859_15	:: [(Char, Char)]+iso_8859_15+    = [ ('\164', '\8364' )+      , ('\166', '\352' )+      , ('\168', '\353' )+      , ('\180', '\381' )+      , ('\184', '\382' )+      , ('\188', '\338' )+      , ('\189', '\339' )+      , ('\190', '\376' )+      ]++iso_8859_16	:: [(Char, Char)]+iso_8859_16+    = [ ('\161', '\260' )+      , ('\162', '\261' )+      , ('\163', '\321' )+      , ('\164', '\8364' )+      , ('\165', '\8222' )+      , ('\166', '\352' )+      , ('\168', '\353' )+      , ('\170', '\536' )+      , ('\172', '\377' )+      , ('\174', '\378' )+      , ('\175', '\379' )+      , ('\178', '\268' )+      , ('\179', '\322' )+      , ('\180', '\381' )+      , ('\181', '\8221' )+      , ('\184', '\382' )+      , ('\185', '\269' )+      , ('\186', '\537' )+      , ('\188', '\338' )+      , ('\189', '\339' )+      , ('\190', '\376' )+      , ('\191', '\380' )+      , ('\195', '\258' )+      , ('\197', '\262' )+      , ('\208', '\272' )+      , ('\209', '\323' )+      , ('\213', '\336' )+      , ('\215', '\346' )+      , ('\216', '\368' )+      , ('\221', '\280' )+      , ('\222', '\538' )+      , ('\227', '\259' )+      , ('\229', '\263' )+      , ('\240', '\273' )+      , ('\241', '\324' )+      , ('\245', '\337' )+      , ('\247', '\347' )+      , ('\248', '\369' )+      , ('\253', '\281' )+      , ('\254', '\539' )+      ]+
+ src/Yuuko/Text/XML/HXT/DOM/MimeTypeDefaults.hs view
@@ -0,0 +1,584 @@+-- | default mime type table+-- +-- this file is generated from file /etc/mime.types++module Yuuko.Text.XML.HXT.DOM.MimeTypeDefaults+where++-- | the table with the mapping from file name extensions to mime types++mimeTypeDefaults :: [(String, String)]+mimeTypeDefaults+  = [ ("123",	"application/vnd.lotus-1-2-3")+    , ("3ds",	"image/x-3ds")+    , ("3g2",	"video/x-3gpp2")+    , ("3gp",	"video/3gpp")+    , ("669",	"audio/x-mod")+    , ("BAY",	"image/x-dcraw")+    , ("BLEND",	"application/x-blender")+    , ("BMQ",	"image/x-dcraw")+    , ("C",	"text/x-c++src")+    , ("CR2",	"image/x-dcraw")+    , ("CRW",	"image/x-dcraw")+    , ("CS1",	"image/x-dcraw")+    , ("CSSL",	"text/css")+    , ("DC2",	"image/x-dcraw")+    , ("DCR",	"image/x-dcraw")+    , ("FFF",	"image/x-dcraw")+    , ("K25",	"image/x-dcraw")+    , ("KDC",	"image/x-dcraw")+    , ("MOS",	"image/x-dcraw")+    , ("MRW",	"image/x-dcraw")+    , ("NEF",	"image/x-dcraw")+    , ("NSV",	"video/x-nsv")+    , ("ORF",	"image/x-dcraw")+    , ("PAR2",	"application/x-par2")+    , ("PEF",	"image/x-dcraw")+    , ("RAF",	"image/x-dcraw")+    , ("RDC",	"image/x-dcraw")+    , ("SRF",	"image/x-dcraw")+    , ("TTC",	"application/x-font-ttf")+    , ("X3F",	"image/x-dcraw")+    , ("XM",	"audio/x-mod")+    , ("Z",	"application/x-compress")+    , ("a",	"application/x-archive")+    , ("aac",	"audio/x-aac")+    , ("abw",	"application/x-abiword")+    , ("abw.CRASHED",	"application/x-abiword")+    , ("abw.gz",	"application/x-abiword")+    , ("ac3",	"audio/ac3")+    , ("adb",	"text/x-adasrc")+    , ("ads",	"text/x-adasrc")+    , ("afm",	"application/x-font-afm")+    , ("ag",	"image/x-applix-graphics")+    , ("ai",	"application/illustrator")+    , ("aif",	"audio/x-aiff")+    , ("aif",	"audio/x-aiff")+    , ("aifc",	"audio/x-aiff")+    , ("aiff",	"audio/x-aiff")+    , ("aiff",	"audio/x-aiff")+    , ("al",	"application/x-perl")+    , ("anim[1-9j]",	"video/x-anim")+    , ("aop",	"application/x-frontline")+    , ("arj",	"application/x-arj")+    , ("as",	"application/x-applix-spreadsheet")+    , ("asax",	"application/x-asax")+    , ("asc",	"text/plain")+    , ("ascx",	"application/x-ascx")+    , ("asf",	"video/x-ms-asf")+    , ("ashx",	"application/x-ashx")+    , ("asix",	"application/x-asix")+    , ("asmx",	"application/x-asmx")+    , ("asp",	"application/x-asp")+    , ("aspx",	"application/x-aspx")+    , ("asx",	"video/x-ms-asf")+    , ("au",	"audio/basic")+    , ("avi",	"video/x-msvideo")+    , ("aw",	"application/x-applix-word")+    , ("axd",	"application/x-axd")+    , ("bak",	"application/x-trash")+    , ("bay",	"image/x-dcraw")+    , ("bcpio",	"application/x-bcpio")+    , ("bdf",	"application/x-font-bdf")+    , ("bib",	"text/x-bibtex")+    , ("bin",	"application/octet-stream")+    , ("bin",	"application/x-stuffit")+    , ("blend",	"application/x-blender")+    , ("blender",	"application/x-blender")+    , ("bmp",	"image/bmp")+    , ("bmq",	"image/x-dcraw")+    , ("boo",	"text/x-boo")+    , ("bz",	"application/x-bzip")+    , ("bz",	"application/x-bzip")+    , ("bz2",	"application/x-bzip")+    , ("bz2",	"application/x-bzip")+    , ("c",	"text/x-csrc")+    , ("c++",	"text/x-c++src")+    , ("caves",	"application/x-gnome-stones")+    , ("cc",	"text/x-c++src")+    , ("cdf",	"application/x-netcdf")+    , ("cdr",	"application/vnd.corel-draw")+    , ("cer",	"application/x-x509-ca-cert")+    , ("cert",	"application/x-x509-ca-cert")+    , ("cgi",	"application/x-cgi")+    , ("cgm",	"image/cgm")+    , ("chm",	"application/x-chm")+    , ("chrt",	"application/x-kchart")+    , ("cht",	"application/chemtool")+    , ("class",	"application/x-java")+    , ("cls",	"text/x-tex")+    , ("cmbx",	"application/x-cmbx")+    , ("config",	"application/x-config")+    , ("connection",	"application/x-gnome-db-connection")+    , ("cpio",	"application/x-cpio")+    , ("cpio.gz",	"application/x-cpio-compressed")+    , ("cpp",	"text/x-c++src")+    , ("cr2",	"image/x-dcraw")+    , ("crt",	"application/x-x509-ca-cert")+    , ("crw",	"image/x-dcraw")+    , ("cs",	"text/x-csharp")+    , ("cs1",	"image/x-dcraw")+    , ("csh",	"application/x-csh")+    , ("css",	"text/css")+    , ("csv",	"text/x-comma-separated-values")+    , ("cue",	"application/x-cue")+    , ("cur",	"image/x-win-bitmap")+    , ("cxx",	"text/x-c++src")+    , ("d",	"text/x-dsrc")+    , ("dat",	"video/mpeg")+    , ("database",	"application/x-gnome-db-database")+    , ("dbf",	"application/x-dbase")+    , ("dc",	"application/x-dc-rom")+    , ("dc2",	"image/x-dcraw")+    , ("dcl",	"text/x-dcl")+    , ("dcm",	"application/dicom")+    , ("dcr",	"image/x-dcraw")+    , ("deb",	"application/x-deb")+    , ("der",	"application/x-x509-ca-cert")+    , ("desktop",	"application/x-desktop")+    , ("devhelp",	"application/x-devhelp")+    , ("dia",	"application/x-dia-diagram")+    , ("dif",	"video/dv")+    , ("diff",	"text/x-patch")+    , ("disco",	"application/x-disco")+    , ("display",	"application/x-gdesklets-display")+    , ("djv",	"image/vnd.djvu")+    , ("djvu",	"image/vnd.djvu")+    , ("doc",	"application/msword")+    , ("docbook",	"application/docbook+xml")+    , ("dsl",	"text/x-dsl")+    , ("dtd",	"text/x-dtd")+    , ("dv",	"video/dv")+    , ("dvi",	"application/x-dvi")+    , ("dwg",	"image/vnd.dwg")+    , ("dxf",	"image/vnd.dxf")+    , ("ear",	"application/x-java-archive")+    , ("egon",	"application/x-egon")+    , ("el",	"text/x-emacs-lisp")+    , ("eps",	"image/x-eps")+    , ("epsf",	"image/x-eps")+    , ("epsi",	"image/x-eps")+    , ("etheme",	"application/x-e-theme")+    , ("etx",	"text/x-setext")+    , ("exe",	"application/x-executable")+    , ("exe",	"application/x-ms-dos-executable")+    , ("ez",	"application/andrew-inset")+    , ("f",	"text/x-fortran")+    , ("fff",	"image/x-dcraw")+    , ("fig",	"image/x-xfig")+    , ("fits",	"image/x-fits")+    , ("flac",	"audio/x-flac")+    , ("flc",	"video/x-flic")+    , ("fli",	"video/x-flic")+    , ("flw",	"application/x-kivio")+    , ("fo",	"text/x-xslfo")+    , ("g3",	"image/fax-g3")+    , ("gb",	"application/x-gameboy-rom")+    , ("gcrd",	"text/directory")+    , ("gen",	"application/x-genesis-rom")+    , ("gf",	"application/x-tex-gf")+    , ("gg",	"application/x-sms-rom")+    , ("gif",	"image/gif")+    , ("glabels",	"application/x-glabels")+    , ("glade",	"application/x-glade")+    , ("gmo",	"application/x-gettext-translation")+    , ("gnc",	"application/x-gnucash")+    , ("gnucash",	"application/x-gnucash")+    , ("gnumeric",	"application/x-gnumeric")+    , ("gpg",	"application/pgp-encrypted")+    , ("gra",	"application/x-graphite")+    , ("gsf",	"application/x-font-type1")+    , ("gtar",	"application/x-gtar")+    , ("gz",	"application/x-gzip")+    , ("h",	"text/x-chdr")+    , ("h++",	"text/x-chdr")+    , ("hdf",	"application/x-hdf")+    , ("hh",	"text/x-c++hdr")+    , ("hp",	"text/x-chdr")+    , ("hpgl",	"application/vnd.hp-hpgl")+    , ("hs",	"text/x-haskell")+    , ("htm",	"text/html")+    , ("html",	"text/html")+    , ("ica",	"application/x-ica")+    , ("icb",	"image/x-icb")+    , ("ico",	"image/x-ico")+    , ("ics",	"text/calendar")+    , ("idl",	"text/x-idl")+    , ("ief",	"image/ief")+    , ("iff",	"image/x-iff")+    , ("il",	"text/x-msil")+    , ("ilbm",	"image/x-ilbm")+    , ("iso",	"application/x-cd-image")+    , ("it",	"audio/x-it")+    , ("jam",	"application/x-jamin")+    , ("jar",	"application/x-jar")+    , ("jar",	"application/x-java-archive")+    , ("java",	"text/x-java")+    , ("jng",	"image/x-jng")+    , ("jnlp",	"application/x-java-jnlp-file")+    , ("jp2",	"image/jpeg2000")+    , ("jpe",	"image/jpeg")+    , ("jpeg",	"image/jpeg")+    , ("jpg",	"image/jpeg")+    , ("jpr",	"application/x-jbuilder-project")+    , ("jpx",	"application/x-jbuilder-project")+    , ("js",	"application/x-javascript")+    , ("js",	"text/x-js")+    , ("k",	"application/x-tex-pk")+    , ("k25",	"image/x-dcraw")+    , ("karbon",	"application/x-karbon")+    , ("kdc",	"image/x-dcraw")+    , ("kdelnk",	"application/x-desktop")+    , ("kfo",	"application/x-kformula")+    , ("kil",	"application/x-killustrator")+    , ("kino",	"application/x-smil")+    , ("kon",	"application/x-kontour")+    , ("kpm",	"application/x-kpovmodeler")+    , ("kpr",	"application/x-kpresenter")+    , ("kpt",	"application/x-kpresenter")+    , ("kra",	"application/x-krita")+    , ("ksp",	"application/x-kspread")+    , ("kud",	"application/x-kugar")+    , ("kwd",	"application/x-kword")+    , ("kwt",	"application/x-kword")+    , ("la",	"application/x-shared-library-la")+    , ("lha",	"application/x-lha")+    , ("lhs",	"text/x-literate-haskell")+    , ("lhz",	"application/x-lhz")+    , ("log",	"text/x-log")+    , ("ltx",	"text/x-tex")+    , ("lwo",	"image/x-lwo")+    , ("lwob",	"image/x-lwo")+    , ("lws",	"image/x-lws")+    , ("lyx",	"application/x-lyx")+    , ("lzh",	"application/x-lha")+    , ("lzh",	"application/x-lha")+    , ("lzo",	"application/x-lzop")+    , ("m",	"text/x-objcsrc")+    , ("m15",	"audio/x-mod")+    , ("m3u",	"audio/x-mpegurl")+    , ("m4a",	"audio/x-m4a")+    , ("man",	"application/x-troff-man")+    , ("master",	"application/x-master-page")+    , ("md",	"application/x-genesis-rom")+    , ("mdp",	"application/x-mdp")+    , ("mds",	"application/x-mds")+    , ("mdsx",	"application/x-mdsx")+    , ("me",	"text/x-troff-me")+    , ("mergeant",	"application/x-mergeant")+    , ("mgp",	"application/x-magicpoint")+    , ("mid",	"audio/midi")+    , ("midi",	"audio/midi")+    , ("mif",	"application/x-mif")+    , ("mkv",	"application/x-matroska")+    , ("mm",	"text/x-troff-mm")+    , ("mml",	"text/mathml")+    , ("mng",	"video/x-mng")+    , ("moc",	"text/x-moc")+    , ("mod",	"audio/x-mod")+    , ("moov",	"video/quicktime")+    , ("mos",	"image/x-dcraw")+    , ("mov",	"video/quicktime")+    , ("movie",	"video/x-sgi-movie")+    , ("mp2",	"video/mpeg")+    , ("mp3",	"audio/mpeg")+    , ("mpe",	"video/mpeg")+    , ("mpeg",	"video/mpeg")+    , ("mpg",	"video/mpeg")+    , ("mps",	"application/x-mps")+    , ("mrproject",	"application/x-planner")+    , ("mrw",	"image/x-dcraw")+    , ("ms",	"text/x-troff-ms")+    , ("msod",	"image/x-msod")+    , ("msx",	"application/x-msx-rom")+    , ("mtm",	"audio/x-mod")+    , ("n",	"text/x-nemerle")+    , ("n64",	"application/x-n64-rom")+    , ("nb",	"application/mathematica")+    , ("nc",	"application/x-netcdf")+    , ("nef",	"image/x-dcraw")+    , ("nes",	"application/x-nes-rom")+    , ("nsv",	"video/x-nsv")+    , ("o",	"application/x-object")+    , ("obj",	"application/x-tgif")+    , ("oda",	"application/oda")+    , ("odb",	"application/vnd.oasis.opendocument.database")+    , ("odc",	"application/vnd.oasis.opendocument.chart")+    , ("odf",	"application/vnd.oasis.opendocument.formula")+    , ("odg",	"application/vnd.oasis.opendocument.graphics")+    , ("odi",	"application/vnd.oasis.opendocument.image")+    , ("odm",	"application/vnd.oasis.opendocument.text-master")+    , ("odp",	"application/vnd.oasis.opendocument.presentation")+    , ("ods",	"application/vnd.oasis.opendocument.spreadsheet")+    , ("odt",	"application/vnd.oasis.opendocument.text")+    , ("ogg",	"application/ogg")+    , ("old",	"application/x-trash")+    , ("oleo",	"application/x-oleo")+    , ("orf",	"image/x-dcraw")+    , ("otg",	"application/vnd.oasis.opendocument.graphics-template")+    , ("oth",	"application/vnd.oasis.opendocument.text-web")+    , ("otp",	"application/vnd.oasis.opendocument.presentation-template")+    , ("ots",	"application/vnd.oasis.opendocument.spreadsheet-template")+    , ("ott",	"application/vnd.oasis.opendocument.text-template")+    , ("p",	"text/x-pascal")+    , ("p12",	"application/x-pkcs12")+    , ("p7s",	"application/pkcs7-signature")+    , ("par2",	"application/x-par2")+    , ("pas",	"text/x-pascal")+    , ("patch",	"text/x-patch")+    , ("pbm",	"image/x-portable-bitmap")+    , ("pcd",	"image/x-photo-cd")+    , ("pcf",	"application/x-font-pcf")+    , ("pcf.Z",	"application/x-font-type1")+    , ("pcf.gz",	"application/x-font-pcf")+    , ("pcl",	"application/vnd.hp-pcl")+    , ("pdb",	"application/vnd.palm")+    , ("pdb",	"application/x-palm-database")+    , ("pdf",	"application/pdf")+    , ("pef",	"image/x-dcraw")+    , ("pem",	"application/x-x509-ca-cert")+    , ("perl",	"application/x-perl")+    , ("pfa",	"application/x-font-type1")+    , ("pfb",	"application/x-font-type1")+    , ("pfx",	"application/x-pkcs12")+    , ("pgm",	"image/x-portable-graymap")+    , ("pgn",	"application/x-chess-pgn")+    , ("pgp",	"application/pgp")+    , ("pgp",	"application/pgp-encrypted")+    , ("php",	"application/x-php")+    , ("php3",	"application/x-php")+    , ("php4",	"application/x-php")+    , ("pict",	"image/x-pict")+    , ("pict1",	"image/x-pict")+    , ("pict2",	"image/x-pict")+    , ("pkr",	"application/pgp-keys")+    , ("pl",	"application/x-perl")+    , ("planner",	"application/x-planner")+    , ("pln",	"application/x-planperfect")+    , ("pls",	"audio/x-scpls")+    , ("pls",	"audio/x-scpls")+    , ("pm",	"application/x-perl")+    , ("png",	"image/png")+    , ("pnm",	"image/x-portable-anymap")+    , ("po",	"text/x-gettext-translation")+    , ("pot",	"application/vnd.ms-powerpoint")+    , ("pot",	"text/x-gettext-translation-template")+    , ("ppm",	"image/x-portable-pixmap")+    , ("pps",	"application/vnd.ms-powerpoint")+    , ("ppt",	"application/vnd.ms-powerpoint")+    , ("ppz",	"application/vnd.ms-powerpoint")+    , ("prc",	"application/x-palm-database")+    , ("prj",	"application/x-anjuta-project")+    , ("prjx",	"application/x-prjx")+    , ("ps",	"application/postscript")+    , ("ps.gz",	"application/x-gzpostscript")+    , ("psd",	"image/x-psd")+    , ("psf",	"application/x-font-linux-psf")+    , ("psid",	"audio/prs.sid")+    , ("pto",	"application/x-ptoptimizer-script")+    , ("pw",	"application/x-pw")+    , ("py",	"text/x-python")+    , ("pyc",	"application/x-python-bytecode")+    , ("pyo",	"application/x-python-bytecode")+    , ("qif",	"application/x-qw")+    , ("qt",	"video/quicktime")+    , ("qtvr",	"video/quicktime")+    , ("ra",	"audio/vnd.rn-realaudio")+    , ("ra",	"audio/x-pn-realaudio")+    , ("raf",	"image/x-dcraw")+    , ("ram",	"audio/x-pn-realaudio")+    , ("ram",	"audio/x-pn-realaudio")+    , ("rar",	"application/x-rar")+    , ("rar",	"application/x-rar-compressed")+    , ("ras",	"image/x-cmu-raster")+    , ("rdc",	"image/x-dcraw")+    , ("rdf",	"text/rdf")+    , ("rdp",	"application/x-rdp")+    , ("rej",	"application/x-reject")+    , ("rem",	"application/x-remoting")+    , ("resources",	"application/x-resources")+    , ("resx",	"application/x-resourcesx")+    , ("rgb",	"image/x-rgb")+    , ("rle",	"image/rle")+    , ("rm",	"application/vnd.rn-realmedia")+    , ("rm",	"audio/x-pn-realaudio")+    , ("rmm",	"audio/x-pn-realaudio")+    , ("rms",	"application/vnd.rn-realmedia-secure")+    , ("rmvb",	"application/vnd.rn-realmedia-vbr")+    , ("rng",	"text/x-rng")+    , ("roff",	"application/x-troff")+    , ("rpm",	"application/x-rpm")+    , ("rss",	"text/rss")+    , ("rt",	"text/vnd.rn-realtext")+    , ("rtf",	"application/rtf")+    , ("rtx",	"text/richtext")+    , ("rv",	"video/vnd.rn-realvideo")+    , ("s3m",	"audio/x-s3m")+    , ("sam",	"application/x-amipro")+    , ("sc",	"application/x-sc")+    , ("scd",	"application/x-scribus")+    , ("scd.gz",	"application/x-scribus")+    , ("scm",	"text/x-scheme")+    , ("sda",	"application/vnd.stardivision.draw")+    , ("sdc",	"application/vnd.stardivision.calc")+    , ("sdd",	"application/vnd.stardivision.impress")+    , ("sdp",	"application/sdp")+    , ("sdp",	"application/vnd.stardivision.impress")+    , ("sds",	"application/vnd.stardivision.chart")+    , ("sdw",	"application/vnd.stardivision.writer")+    , ("sgi",	"image/x-sgi")+    , ("sgl",	"application/vnd.stardivision.writer")+    , ("sgm",	"text/sgml")+    , ("sgml",	"text/sgml")+    , ("sh",	"application/x-shellscript")+    , ("shar",	"application/x-shar")+    , ("siag",	"application/x-siag")+    , ("sid",	"audio/prs.sid")+    , ("sig",	"application/pgp-signature")+    , ("sik",	"application/x-trash")+    , ("sit",	"application/stuffit")+    , ("sit",	"application/x-stuffit")+    , ("skr",	"application/pgp-keys")+    , ("sla",	"application/x-scribus")+    , ("sla.gz",	"application/x-scribus")+    , ("slk",	"text/spreadsheet")+    , ("smd",	"application/vnd.stardivision.mail")+    , ("smf",	"application/vnd.stardivision.math")+    , ("smi",	"application/smil")+    , ("smi",	"application/x-smil")+    , ("smil",	"application/smil")+    , ("smil",	"application/x-smil")+    , ("sml",	"application/smil")+    , ("sms",	"application/x-sms-rom")+    , ("snd",	"audio/basic")+    , ("so",	"application/x-sharedlib")+    , ("soap",	"application/x-soap-remoting")+    , ("spd",	"application/x-font-speedo")+    , ("sql",	"text/x-sql")+    , ("src",	"application/x-wais-source")+    , ("srf",	"image/x-dcraw")+    , ("ssm",	"application/x-streamingmedia")+    , ("stc",	"application/vnd.sun.xml.calc.template")+    , ("std",	"application/vnd.sun.xml.draw.template")+    , ("sti",	"application/vnd.sun.xml.impress.template")+    , ("stm",	"audio/x-stm")+    , ("stw",	"application/vnd.sun.xml.writer.template")+    , ("sty",	"text/x-tex")+    , ("sun",	"image/x-sun-raster")+    , ("sv4cpio",	"application/x-sv4cpio")+    , ("sv4crc",	"application/x-sv4crc")+    , ("svg",	"image/svg+xml")+    , ("swf",	"application/x-shockwave-flash")+    , ("sxc",	"application/vnd.sun.xml.calc")+    , ("sxd",	"application/vnd.sun.xml.draw")+    , ("sxg",	"application/vnd.sun.xml.writer.global")+    , ("sxi",	"application/vnd.sun.xml.impress")+    , ("sxm",	"application/vnd.sun.xml.math")+    , ("sxw",	"application/vnd.sun.xml.writer")+    , ("sylk",	"text/spreadsheet")+    , ("t",	"application/x-troff")+    , ("tar",	"application/x-tar")+    , ("tar.Z",	"application/x-compressed-tar")+    , ("tar.Z",	"application/x-tarz")+    , ("tar.bz",	"application/x-bzip-compressed-tar")+    , ("tar.bz",	"application/x-bzip-compressed-tar")+    , ("tar.bz2",	"application/x-bzip-compressed-tar")+    , ("tar.bz2",	"application/x-bzip-compressed-tar")+    , ("tar.gz",	"application/x-compressed-tar")+    , ("tar.gz",	"application/x-compressed-tar")+    , ("tar.lzo",	"application/x-lzop-compressed-tar")+    , ("tar.lzo",	"application/x-tzo")+    , ("taz",	"application/x-compressed-tar")+    , ("tbz",	"application/x-bzip-compressed-tar")+    , ("tbz2",	"application/x-bzip-compressed-tar")+    , ("tcl",	"text/x-tcl")+    , ("tex",	"text/x-tex")+    , ("texi",	"text/x-texinfo")+    , ("texinfo",	"text/x-texinfo")+    , ("tga",	"image/x-tga")+    , ("tgz",	"application/x-compressed-tar")+    , ("tgz",	"application/x-compressed-tar")+    , ("theme",	"application/x-theme")+    , ("tif",	"image/tiff")+    , ("tiff",	"image/tiff")+    , ("tk",	"text/x-tcl")+    , ("tm",	"text/x-texmacs")+    , ("toc",	"application/x-toc")+    , ("torrent",	"application/x-bittorrent")+    , ("tr",	"application/x-troff")+    , ("ts",	"application/x-linguist")+    , ("ts",	"text/x-texmacs")+    , ("tsv",	"text/tab-separated-values")+    , ("ttc",	"application/x-font-ttf")+    , ("ttf",	"application/x-font-ttf")+    , ("txt",	"text/plain")+    , ("tzo",	"application/x-lzop-compressed-tar")+    , ("tzo",	"application/x-tzo")+    , ("ui",	"application/x-designer")+    , ("uil",	"text/x-uil")+    , ("ult",	"audio/x-mod")+    , ("uni",	"audio/x-mod")+    , ("uri",	"text/x-uri")+    , ("url",	"text/x-uri")+    , ("ustar",	"application/x-ustar")+    , ("vb",	"text/x-vb")+    , ("vcf",	"text/directory")+    , ("vcs",	"text/calendar")+    , ("vct",	"text/directory")+    , ("vob",	"video/mpeg")+    , ("voc",	"audio/x-voc")+    , ("vor",	"application/vnd.stardivision.writer")+    , ("war",	"application/x-java-archive")+    , ("wav",	"audio/x-wav")+    , ("wb1",	"application/x-quattro-pro")+    , ("wb1",	"application/x-quattropro")+    , ("wb2",	"application/x-quattro-pro")+    , ("wb2",	"application/x-quattropro")+    , ("wb3",	"application/x-quattro-pro")+    , ("wb3",	"application/x-quattropro")+    , ("wk1",	"application/vnd.lotus-1-2-3")+    , ("wk3",	"application/vnd.lotus-1-2-3")+    , ("wk4",	"application/vnd.lotus-1-2-3")+    , ("wks",	"application/vnd.lotus-1-2-3")+    , ("wmf",	"image/x-wmf")+    , ("wml",	"text/vnd.wap.wml")+    , ("wmv",	"video/x-ms-wmv")+    , ("wpd",	"application/vnd.wordperfect")+    , ("wpg",	"application/x-wpg")+    , ("wri",	"application/x-mswrite")+    , ("wrl",	"model/vrml")+    , ("wsdl",	"application/x-wsdl")+    , ("x3f",	"image/x-dcraw")+    , ("xac",	"application/x-gnucash")+    , ("xbel",	"application/x-xbel")+    , ("xbm",	"image/x-xbitmap")+    , ("xcf",	"image/x-xcf")+    , ("xcf.bz2",	"image/x-compressed-xcf")+    , ("xcf.gz",	"image/x-compressed-xcf")+    , ("xds",	"text/x-xds")+    , ("xhtml",	"application/xhtml+xml")+    , ("xi",	"audio/x-xi")+    , ("xla",	"application/vnd.ms-excel")+    , ("xlc",	"application/vnd.ms-excel")+    , ("xld",	"application/vnd.ms-excel")+    , ("xll",	"application/vnd.ms-excel")+    , ("xlm",	"application/vnd.ms-excel")+    , ("xls",	"application/vnd.ms-excel")+    , ("xlt",	"application/vnd.ms-excel")+    , ("xlw",	"application/vnd.ms-excel")+    , ("xm",	"audio/x-xm")+    , ("xmi",	"text/x-xmi")+    , ("xml",	"text/xml")+    , ("xpl",	"audio/x-scpls")+    , ("xpm",	"image/x-xpixmap")+    , ("xsl",	"text/x-xsl")+    , ("xsl",	"text/x-xslt")+    , ("xslfo",	"text/x-xslfo")+    , ("xslt",	"text/x-xslt")+    , ("xul",	"application/vnd.mozilla.xul+xml")+    , ("xwd",	"image/x-xwindowdump")+    , ("zabw",	"application/x-abiword")+    , ("zip",	"application/zip")+    , ("zoo",	"application/x-zoo")+   ]+
+ src/Yuuko/Text/XML/HXT/DOM/MimeTypes.hs view
@@ -0,0 +1,109 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.DOM.MimeTypes+   Copyright  : Copyright (C) 2008 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   mime type related data and functions++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.DOM.MimeTypes+where++import           Control.Monad		( mplus )++import qualified Data.ByteString	as B+import qualified Data.ByteString.Char8  as C++import           Data.Char+import           Data.List+import qualified Data.Map		as M+import           Data.Maybe++import           Yuuko.Text.XML.HXT.DOM.MimeTypeDefaults++-- ------------------------------------------------------------++type MimeTypeTable	= M.Map String String++-- ------------------------------------------------------------++-- mime types+--+-- see RFC \"http:\/\/www.rfc-editor.org\/rfc\/rfc3023.txt\"++application_xhtml,+ application_xml,+ application_xml_external_parsed_entity,+ application_xml_dtd,+ text_html,+ text_xml,+ text_xml_external_parsed_entity	:: String++application_xhtml			= "application/xhtml+xml"+application_xml				= "application/xml"+application_xml_external_parsed_entity	= "application/xml-external-parsed-entity"+application_xml_dtd			= "application/xml-dtd"++text_html				= "text/html"+text_xml				= "text/xml"+text_xml_external_parsed_entity		= "text/xml-external-parsed-entity"++isTextMimeType				:: String -> Bool+isTextMimeType				= ("text/" `isPrefixOf`)++isHtmlMimeType				:: String -> Bool+isHtmlMimeType t			= t == text_html++isXmlMimeType				:: String -> Bool+isXmlMimeType t				= ( t `elem` [ application_xhtml+						     , application_xml+						     , application_xml_external_parsed_entity+						     , application_xml_dtd+						     , text_xml+						     , text_xml_external_parsed_entity+						     ]+					    ||+					    "+xml" `isSuffixOf` t		-- application/mathml+xml+					  )					-- or image/svg+xml++defaultMimeTypeTable			:: MimeTypeTable+defaultMimeTypeTable			= M.fromList mimeTypeDefaults++extensionToMimeType			:: String -> MimeTypeTable -> String+extensionToMimeType e			= fromMaybe "" . lookupMime +    where+    lookupMime t			= M.lookup e t			-- try exact match+					  `mplus`+					  M.lookup (map toLower e) t	-- else try lowercase match+					  `mplus`+					  M.lookup (map toUpper e) t	-- else try uppercase match++-- ------------------------------------------------------------++readMimeTypeTable			:: FilePath -> IO MimeTypeTable+readMimeTypeTable inp			= do+					  cb <- B.readFile inp+					  return . M.fromList . parseMimeTypeTable . C.unpack $ cb++parseMimeTypeTable			:: String -> [(String, String)]+parseMimeTypeTable			= concat+					  . map buildPairs+					  . map words+					  . filter (not . ("#" `isPrefixOf`))+					  . filter (not . all (isSpace))+					  . lines+    where+    buildPairs				:: [String] -> [(String, String)]+    buildPairs	[] 			= []+    buildPairs	(mt:exts) 		= map (\ x -> (x, mt)) $ exts++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/DOM/QualifiedName.hs view
@@ -0,0 +1,538 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.DOM.QualifiedName+   Copyright  : Copyright (C) 2008 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : stable+   Portability: portable++   The core data types of the HXT DOM.++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.DOM.QualifiedName+    ( QName+    , XName+    , NsEnv++    , mkQName+    , mkName+    , mkNsName+    , mkSNsName+    , mkPrefixLocalPart++    , equivQName+    , equivUri+    , equalQNameBy++    , namePrefix+    , localPart+    , namespaceUri++    , newXName+    , nullXName+    , isNullXName++    , mkQName'+    , namePrefix'+    , localPart'+    , namespaceUri'++    , setNamePrefix'+    , setLocalPart'+    , setNamespaceUri'++    , qualifiedName+    , universalName+    , universalUri+    , buildUniversalName++    , normalizeNsUri++    , setNamespace                      -- namespace related functions+    , isNCName+    , isWellformedQualifiedName+    , isWellformedQName+    , isWellformedNSDecl+    , isWellformedNameSpaceName+    , isNameSpaceName+    , isDeclaredNamespace++    , xmlNamespaceXName+    , xmlXName+    , xmlnsNamespaceXName+    , xmlnsXName+    , xmlnsQN++    , toNsEnv+    )++where++{-+import           Debug.Trace+ -}++import           Control.Arrow                  ( (***) )++import           Control.Concurrent.MVar+import           Control.DeepSeq++import           Yuuko.Data.AssocList+import           Data.Char                      ( toLower )+import           Data.List                      ( isPrefixOf )+import qualified Data.Map               as M+import           Data.Typeable++import           System.IO.Unsafe               ( unsafePerformIO )++import           Yuuko.Text.XML.HXT.DOM.XmlKeywords   ( a_xml+                                                , a_xmlns+                                                , xmlNamespace+                                                , xmlnsNamespace+                                                )++import           Yuuko.Text.XML.HXT.DOM.Unicode       ( isXmlNCNameStartChar+                                                , isXmlNCNameChar+                                                )++-- -----------------------------------------------------------------------------++-- | XML names are represented by Strings, but these strings do not mix up with normal strings.+-- Names are always reduced to normal form, and they are stored internally in a name cache+-- for sharing equal names by the same data structure++type XName      = Atom++-- |+-- Namespace support for element and attribute names.+--+-- A qualified name consists of a name prefix, a local name+-- and a namespace uri.+-- All modules, which are not namespace aware, use only the 'localPart' component.+-- When dealing with namespaces, the document tree must be processed by 'Yuuko.Text.XML.HXT.Arrow.Namespace.propagateNamespaces'+-- to split names of structure \"prefix:localPart\" and label the name with the apropriate namespace uri++data QName      = LP ! XName+                | PX ! XName ! QName+                | NS ! XName ! QName+             deriving (Ord, Show, Read, Typeable)++-- |+-- Type for the namespace association list, used when propagating namespaces by+-- modifying the 'QName' values in a tree++type NsEnv = AssocList XName XName++-- -----------------------------------------------------------------------------++-- | Two QNames are equal if (1. case) namespaces are both empty and the qualified names+-- (prefix:localpart) are the same or (2. case) namespaces are set and namespaces and+-- local parts both are equal+    +instance Eq QName where+    (LP lp1)     == (LP lp2)            = lp1 == lp2+    (PX px1 qn1) == (PX px2 qn2)        = px1 == px2 && qn1== qn2+    (NS ns1 qn1) == (NS ns2 qn2)        = ns1 == ns2 && localPart' qn1 == localPart' qn2+    n1@(PX _ _)  == n2@(LP _)           = qualifiedName n1 == qualifiedName n2+    n1@(LP _)    == n2@(PX _ _)         = qualifiedName n1 == qualifiedName n2+    _            == _                   = False++-- the 4. and 5. rule are only neccessary when someone+-- uses XML names not in a systematical way+-- and does things like "mkName("x:y") == mkPrefixLocalPart("x","y")++instance NFData QName where++-- -----------------------------------------------------------------------------++newXName                :: String -> XName+newXName                = newAtom++isNullXName             :: XName -> Bool+isNullXName             = (== nullXName)++nullXName               :: XName+nullXName               = newXName ""++-- | access name prefix++namePrefix'             :: QName -> XName+namePrefix' (LP _)      = nullXName+namePrefix' (PX px _)   = px+namePrefix' (NS _ n)    = namePrefix' n++-- | access local part++localPart'              :: QName -> XName+localPart' (LP lp)      = lp+localPart' (PX _ n)     = localPart' n+localPart' (NS _ n)     = localPart' n++-- | access namespace uri++namespaceUri'           :: QName -> XName+namespaceUri' (NS ns _) = ns+namespaceUri' _         = nullXName++namePrefix              :: QName -> String+namePrefix              = show . namePrefix'++localPart               :: QName -> String+localPart               = show . localPart'++namespaceUri            :: QName -> String+namespaceUri            = show . namespaceUri'++-- ------------------------------------------------------------++-- | set name prefix++setNamespaceUri'                :: XName -> QName -> QName+setNamespaceUri' ns (NS _ n)    = if isNullXName ns+                                  then n+                                  else NS ns n+setNamespaceUri' ns n           = if isNullXName ns+                                  then n+                                  else NS ns n++-- | set local part++setLocalPart'                   :: XName -> QName -> QName+setLocalPart' lp (LP _)         = LP lp+setLocalPart' lp (PX px n)      = PX px (setLocalPart' lp n)+setLocalPart' lp (NS ns n)      = NS ns (setLocalPart' lp n)++-- | set name prefix++setNamePrefix'                  :: XName -> QName -> QName+setNamePrefix' px (PX _ n)      = if px == nullXName+                                  then n+                                  else PX px n+setNamePrefix' px n@(LP _)      = if px == nullXName+                                  then n+                                  else PX px n+setNamePrefix' px (NS ns n)     = NS ns (setNamePrefix' px n)+++-- ------------------------------------------------------------++-- |+-- builds the full name \"prefix:localPart\", if prefix is not null, else the local part is the result++qualifiedName                   :: QName -> String+qualifiedName (LP lp)           = show lp+qualifiedName (PX px n)         = show px ++ (':' : qualifiedName n)+qualifiedName (NS _ n)          = qualifiedName n++-- |+-- builds the \"universal\" name, that is the namespace uri surrounded with \"{\" and \"}\" followed by the local part+-- (specialisation of 'buildUniversalName')++universalName                   :: QName -> String+universalName                   = buildUniversalName (\ ns lp -> '{' : ns ++ '}' : lp)++-- |+-- builds an \"universal\" uri, that is the namespace uri followed by the local part. This is usefull for RDF applications,+-- where the subject, predicate and object often are concatenated from namespace uri and local part+-- (specialisation of 'buildUniversalName')++universalUri                    :: QName -> String+universalUri                    = buildUniversalName (++)++-- |+-- builds a string from the namespace uri and the local part. If the namespace uri is empty, the local part is returned, else+-- namespace uri and local part are combined with the combining function given by the first parameter++buildUniversalName              :: (String -> String -> String) -> QName -> String+buildUniversalName bf (NS ns n) = show ns `bf` localPart n+buildUniversalName _  n         = localPart n++-- ------------------------------------------------------------+--+-- internal XName functions++mkQName'                        :: XName -> XName -> XName -> QName+mkQName' px lp ns+    | isNullXName ns            =       px_lp+    | otherwise                 = NS ns px_lp+    where+    px_lp+        | isNullXName px        = LP lp+        | otherwise             = PX px (LP lp)++-- ------------------------------------------------------------++-- |+-- constructs a simple name, with prefix and localPart but without a namespace uri.+--+-- see also 'mkQName', 'mkName'++mkPrefixLocalPart               :: String -> String -> QName+mkPrefixLocalPart px lp+    | null px                   =                  n1+    | otherwise                 = PX (newXName px) n1+    where+    n1 = LP (newXName lp)++-- |+-- constructs a simple, namespace unaware name.+-- If the name is in @prefix:localpart@ form and the prefix is not empty+-- the name is split internally into+-- a prefix and a local part.++mkName                          :: String -> QName+mkName n                        +    | (':' `elem` n)+      &&+      not (null px)			-- more restrictive: isWellformedQualifiedName n+                                = mkPrefixLocalPart px lp+    | otherwise                 = mkPrefixLocalPart "" n+    where+    (px, (_:lp)) = span (/= ':') n++-- |+-- constructs a complete qualified name with 'namePrefix', 'localPart' and 'namespaceUri'.+-- This function can be used to build not wellformed prefix:localpart names.+-- The XPath module uses wildcard names like @xxx:*@. These must be build with 'mkQName'+-- and not with mkName.++mkQName                         :: String -> String -> String -> QName+mkQName px lp ns+    | null ns                   =                  n1+    | otherwise                 = NS (newXName ns) n1+    where+    n1 = mkPrefixLocalPart px lp++-- ------------------------------------------------------------++-- |+-- old name for 'mkName'++mkSNsName                       :: String -> QName+mkSNsName                       = mkName++-- |+-- constructs a simple, namespace aware name, with prefix:localPart as first parameter,+-- namspace uri as second.+--+-- see also 'mkName', 'mkPrefixLocalPart'++mkNsName                        :: String -> String -> QName+mkNsName n ns+    | null ns                   =                   mkName n+    | otherwise                 = NS (newXName ns) (mkName n)++-- ------------------------------------------------------------++-- | Equivalent QNames are defined as follows: The URIs are normalized before comparison.+-- Comparison is done with 'equalQNameBy' and 'equivUri'++equivQName                      :: QName -> QName -> Bool+equivQName                      = equalQNameBy equivUri++-- | Comparison of normalized namespace URIs using 'normalizeNsUri'++equivUri                        :: String -> String -> Bool+equivUri x y                    = normalizeNsUri x == normalizeNsUri y++-- | Sometimes a weaker equality relation than 'equalQName' is appropriate, e.g no case significance in names, ...+-- a name normalization function can be applied to the strings before comparing. Called by 'equalQName' and+-- 'equivQName'++equalQNameBy                    :: (String -> String -> Bool) -> QName -> QName -> Bool+equalQNameBy equiv q1 q2        = localPart q1 == localPart q2+                                  &&+                                  (namespaceUri q1 `equiv` namespaceUri q2)++-- |  Normalization of URIs: Normalization is done by conversion into lowercase letters. A trailing \"\/\" is ignored++normalizeNsUri                  :: String -> String+normalizeNsUri                  = map toLower . stripSlash+    where+    stripSlash ""               = ""+    stripSlash s+        | last s == '/'         = init s+        | otherwise             = s++-- -----------------------------------------------------------------------------++-- Namespace predicates++-- |+-- Compute the name prefix and the namespace uri for a qualified name.+--+-- This function does not test whether the name is a wellformed qualified name.+-- see Namespaces in XML Rule [6] to [8]. Error checking is done with separate functions,+-- see 'isWellformedQName' and 'isWellformedQualifiedName' for error checking.++setNamespace                    :: NsEnv -> QName -> QName+setNamespace env n@(PX px _)    = attachNS env px        n              -- none empty prefix found+setNamespace env n@(LP _)       = attachNS env nullXName n              -- use default namespace uri+setNamespace env (NS _ n)       = setNamespace env n++attachNS                        :: NsEnv -> XName -> QName -> QName+attachNS env px n1              = maybe n1 (\ ns -> NS ns n1) . lookup px $ env++xmlnsNamespaceXName             :: XName+xmlnsNamespaceXName             = newXName xmlnsNamespace++xmlnsXName                      :: XName+xmlnsXName                      = newXName a_xmlns++xmlnsQN                         :: QName+xmlnsQN                         = NS xmlnsNamespaceXName (LP xmlnsXName)++xmlNamespaceXName               :: XName+xmlNamespaceXName               = newXName xmlNamespace++xmlXName                        :: XName+xmlXName                        = newXName a_xml++-- -----------------------------------------------------------------------------+--++-- |+-- test for wellformed NCName, rule [4] XML Namespaces++isNCName                        :: String -> Bool+isNCName []                     = False+isNCName n                      = and ( zipWith ($)+                                        (isXmlNCNameStartChar : repeat isXmlNCNameChar)+                                        n+                                      )++-- |+-- test for wellformed QName, rule [6] XML Namespaces+-- predicate is used in filter 'valdateNamespaces'.++isWellformedQualifiedName       :: String -> Bool+isWellformedQualifiedName s+    | null lp                   = isNCName px+    | otherwise                 = isNCName px && isNCName (tail lp)+    where+    (px, lp)                    = span (/= ':') s++-- |+-- test for wellformed QName values.+-- A QName is wellformed, if the local part is a NCName, the namePrefix, if not empty, is also a NCName.+-- predicate is used in filter 'valdateNamespaces'.++isWellformedQName               :: QName -> Bool+isWellformedQName (LP lp)       = isNCName . show $ lp                          -- rule [8] XML Namespaces+isWellformedQName (PX px n)     = (isNCName . show) px                          -- rule [7] XML Namespaces+                                  &&+                                  isWellformedQName n+isWellformedQName (NS _ n)      = isWellformedQName n++-- |+-- test whether an attribute name is a namesapce declaration name.+-- If this is not the case True is the result, else+-- the name must be a well formed namespace name:+-- All namespace prefixes starting with \"xml\" are reserved for XML related definitions.+-- predicate is used in filter 'valdateNamespaces'.++isWellformedNSDecl              :: QName -> Bool+isWellformedNSDecl n            = not (isNameSpaceName n)+                                  ||+                                  isWellformedNameSpaceName n++-- |+-- test for a namespace name to be well formed++isWellformedNameSpaceName               :: QName -> Bool+isWellformedNameSpaceName (LP lp)       = lp == xmlnsXName+isWellformedNameSpaceName (PX px n)     = px == xmlnsXName+                                          &&+                                          not (null lp')+                                          &&+                                          not (a_xml `isPrefixOf` lp')+                                          where+                                          lp' = localPart n+isWellformedNameSpaceName (NS _ n)      = isWellformedNSDecl n++-- |+-- test whether a name is a namespace declaration attribute name++isNameSpaceName                 :: QName -> Bool+isNameSpaceName (LP lp)         = lp == xmlnsXName+isNameSpaceName (PX px _)       = px == xmlnsXName+isNameSpaceName (NS _  n)       = isNameSpaceName n++-- |+-- +-- predicate is used in filter 'valdateNamespaces'.++isDeclaredNamespace             :: QName -> Bool+isDeclaredNamespace (NS ns n)   = isNS ns        n+isDeclaredNamespace        n    = isNS nullXName n++isNS                            :: XName -> QName -> Bool+isNS _  (LP _)                  = True                          -- no namespace used+isNS ns (PX px _)+    | px == xmlnsXName          = ns == xmlnsNamespaceXName     -- "xmlns" has a predefined namespace uri+    | px == xmlXName            = ns == xmlNamespaceXName       -- "xml" has a predefiend namespace"+    | otherwise                 = ns /= nullXName               -- namespace values are not empty+isNS ns (NS _ n)                = isNS ns n                     -- this does not occur, but warning is prevented++-- -----------------------------------------------------------------------------++toNsEnv                         :: AssocList String String -> NsEnv+toNsEnv                         = map (newXName *** newXName)++-- -----------------------------------------------------------------------------++-- the name cache, same implementation strategy as in Yuuko.Data.Atom,+-- but conversion to and from ByteString prevented++type Atoms      = M.Map String String++newtype Atom    = A String+                  deriving (Eq, Ord, Typeable)++-- ------------------------------------------------------------++-- | the internal cache for the strings++theAtoms        :: MVar Atoms+theAtoms        = unsafePerformIO (newMVar M.empty)+{-# NOINLINE theAtoms #-}++-- | insert a bytestring into the atom cache++insertAtom      :: String -> Atoms -> (Atoms, Atom)+insertAtom s m  = maybe (M.insert {- (trace (show s) s) -} s s m, deepseq s (A s))+                        (\ s' -> (m, A s'))+                  .+                  M.lookup s $ m++-- | creation of an @Atom@ from a @String@++newAtom         :: String -> Atom+newAtom         = unsafePerformIO . newAtom'+{-# NOINLINE newAtom #-}++-- | The internal operation running in the IO monad+newAtom'        :: String -> IO Atom+newAtom' s      = do+                  m <- takeMVar theAtoms+                  let (m', a) = insertAtom s m+                  putMVar theAtoms m'+                  return a++instance Read Atom where+    readsPrec p str = [ (newAtom x, y) | (x, y) <- readsPrec p str ]++instance Show Atom where+    show (A s)  = s++instance NFData Atom where++-----------------------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/DOM/ShowXml.hs view
@@ -0,0 +1,405 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.DOM.ShowXml+   Copyright  : Copyright (C) 2008-9 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : stable+   Portability: portable++   XML tree conversion to external string representation++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.DOM.ShowXml+    ( xshow+    , showElemType+    )+where++import Data.Maybe+import Yuuko.Data.Tree.NTree.TypeDefs++import Yuuko.Text.XML.HXT.DOM.TypeDefs		-- XML Tree types+import Yuuko.Text.XML.HXT.DOM.XmlKeywords+import Yuuko.Text.XML.HXT.DOM.XmlNode			( mkDTDElem+						, getDTDAttrl+						)++-- -----------------------------------------------------------------------------+--+-- the toString conversion functions++-- |+-- convert the result of a filter into a string+--+-- see also : 'xmlTreesToText' for filter version, 'Yuuko.Text.XML.HXT.Parser.XmlParsec.xread' for the inverse operation ++xshow	:: XmlTrees -> String+xshow [(NTree (XText s) _)]	= s			-- special case optimisation+xshow ts			= showXmlTrees ts ""++-- ------------------------------------------------------------++showXmlTree		:: XmlTree  -> String -> String++showXmlTree (NTree (XText s) _)+    = showString s++showXmlTree (NTree (XCharRef i) _)+    = showString "&#" . showString (show i) . showChar ';'++showXmlTree (NTree (XEntityRef r) _)+    = showString "&" . showString r . showChar ';'++showXmlTree (NTree (XCmt c) _)+    = showString "<!--" . showString c . showString "-->"++showXmlTree (NTree (XCdata d) _)+    = showString "<![CDATA[" . showString d . showString "]]>"++showXmlTree (NTree (XPi n al) _)+    = showString "<?"+      .+      showQName n+      .+      (foldr (.) id . map showPiAttr) al+      .+      showString "?>"+      where+      showPiAttr	:: XmlTree -> String -> String+      showPiAttr a@(NTree (XAttr an) cs)+	  | qualifiedName an == a_value+	      = showBlank . showXmlTrees cs+	  | otherwise+	      = showXmlTree a+      showPiAttr _+	  = id++showXmlTree (NTree (XTag t al) [])+    = showLt . showQName t . showXmlTrees al . showSlash . showGt++showXmlTree (NTree (XTag t al) cs)+    = showLt . showQName t . showXmlTrees al . showGt+      . showXmlTrees cs+      . showLt . showSlash . showQName t . showGt++showXmlTree (NTree (XDTD de al) cs)+    = showXmlDTD de al cs++showXmlTree (NTree (XAttr an) cs)+    = showBlank . showQName an . showEq . showQuoteString (xshow cs)++showXmlTree (NTree (XError l e) _)+    = showString "<!-- ERROR (" . shows l . showString "):\n" . showString e . showString "\n-->"++-- ------------------------------------------------------------++showXmlTrees		:: XmlTrees -> String -> String+showXmlTrees		= foldr (.) id . map showXmlTree++showXmlTrees'		:: XmlTrees -> String -> String+showXmlTrees'		= foldr (\ x y -> x . showNL . y) id . map showXmlTree++-- ------------------------------------------------------------++showQName		:: QName -> String -> String+showQName+    = showString . qualifiedName++-- ------------------------------------------------------------++showQuoteString		:: String -> String -> String+showQuoteString s+    | '\"' `elem` s+	= showApos . showString s . showApos+    | otherwise+	= showQuot . showString s . showQuot+++-- ------------------------------------------------------------++showAttr	:: String -> Attributes -> String -> String+showAttr k al+    = showString (fromMaybe "" . lookup k $ al)++-- ------------------------------------------------------------++showPEAttr	:: Attributes -> String -> String+showPEAttr al+    = showPE (lookup a_peref al)+      where+      showPE (Just pe) = showChar '%' . showString pe . showChar ';'+      showPE Nothing   = id++-- ------------------------------------------------------------++showExternalId	:: Attributes -> String -> String+showExternalId al+    = id2Str (lookup k_system al) (lookup k_public al)+      where+      id2Str Nothing  Nothing  = id+      id2Str (Just s) Nothing  = showBlank . showString k_system . showBlank . showQuoteString s+      id2Str Nothing  (Just p) = showBlank . showString k_public . showBlank . showQuoteString p+      id2Str (Just s) (Just p) = showBlank . showString k_public . showBlank . showQuoteString p . showBlank . showQuoteString s++-- ------------------------------------------------------------++showNData	:: Attributes -> String -> String+showNData al+    = nd2Str (lookup k_ndata al)+      where+      nd2Str Nothing	= id+      nd2Str (Just v)	= showBlank . showString k_ndata . showBlank . showString v++-- ------------------------------------------------------------++showXmlDTD		:: DTDElem -> Attributes -> XmlTrees -> String -> String++showXmlDTD DOCTYPE al cs+    = showString "<!DOCTYPE "+      .+      showAttr a_name al+      .+      showExternalId al+      .+      showInternalDTD cs+      .+      showString ">"+      where+      showInternalDTD [] = id+      showInternalDTD ds = showString " [\n" . showXmlTrees' ds . showChar ']'++showXmlDTD ELEMENT al cs+    = showString "<!ELEMENT "+      .+      showAttr a_name al+      .+      showBlank+      .+      showElemType (lookup1 a_type al) cs+      .+      showString " >"++showXmlDTD ATTLIST al cs+    = showString "<!ATTLIST "+      .+      ( if isNothing . lookup a_name $ al+	then+	showXmlTrees cs+	else+	showAttr a_name al+	.+	showBlank+	.+	( case lookup a_value al of+	  Nothing -> ( showPEAttr+		       . fromMaybe [] . getDTDAttrl+		       . head+		     ) cs+	  Just a  -> ( showString a+	               .+                       showAttrType (lookup1 a_type al)+                       .+                       showAttrKind (lookup1 a_kind al)+		     )+	)+      )+      .+      showString " >"+      where+      showAttrType t+	  | t == k_peref+	      = showBlank . showPEAttr al+	  | t == k_enumeration+	      = showAttrEnum+	  | t == k_notation+	      = showBlank . showString k_notation . showAttrEnum+	  | otherwise+	      = showBlank . showString t++      showAttrEnum+	  = showString " ("+	    .+	    foldr1 (\ s1 s2 -> s1 . showString " | " .  s2) (map (getEnum . fromMaybe [] . getDTDAttrl) cs)+	    .+	    showString ")"+	    where+	    getEnum	:: Attributes -> String -> String+	    getEnum l = showAttr a_name l . showPEAttr l++      showAttrKind k+	  | k == k_default+	      = showBlank . showQuoteString (lookup1 a_default al)+	  | k == k_fixed+	      = showBlank . showString k_fixed+		.+		showBlank . showQuoteString (lookup1 a_default al)+	  | k == ""+	      = id+	  | otherwise+	      = showBlank . showString k++showXmlDTD NOTATION al _cs+    = showString "<!NOTATION "+      .+      showAttr a_name al+      .+      showExternalId al+      .+      showString " >"++showXmlDTD PENTITY al cs+    = showEntity "% " al cs++showXmlDTD ENTITY al cs+    = showEntity "" al cs++showXmlDTD PEREF al _cs+    = showPEAttr al++showXmlDTD CONDSECT _ (c1 : cs)+    = showString "<![ "+      .+      showXmlTree c1+      .+      showString " [\n"+      .+      showXmlTrees cs+      .+      showString "]]>"++showXmlDTD CONTENT al cs+    = showContent (mkDTDElem CONTENT al cs)++showXmlDTD NAME al _cs+    = showAttr a_name al++showXmlDTD de al _cs+    = showString "NOT YET IMPLEMETED: " . showString (show de) . showBlank . showString (show al) . showString " [...]\n"++-- ------------------------------------------------------------++showElemType	:: String -> XmlTrees -> String -> String+showElemType t cs+    | t == v_pcdata+	= showLpar . showString v_pcdata . showRpar++    | t == v_mixed && (not . null) cs+	= showLpar+	  .+	  showString v_pcdata+	  .+	  ( foldr (.) id . map (mixedContent . selAttrl . getNode) ) cs1+	  .+          showRpar+	  .+	  showAttr a_modifier al1+    | t == v_mixed				-- incorrect tree, e.g. after erronius pe substitution+	= showLpar+	  .+	  showRpar+    | t == v_children && (not . null) cs+	= showContent (head cs)+    | t == v_children+	= showLpar+	  . showRpar+    | t == k_peref+	= foldr (.) id . map showContent $ cs+    | otherwise+	= showString t+    where+    [(NTree (XDTD CONTENT al1) cs1)] = cs++    mixedContent :: Attributes -> String -> String+    mixedContent l+	= showString " | " . showAttr a_name l . showPEAttr l++    selAttrl (XDTD _ as) = as+    selAttrl (XText tex) = [(a_name, tex)]+    selAttrl _           = []++-- ------------------------------------------------------------++showContent	:: XmlTree -> String -> String+showContent (NTree (XDTD de al) cs)+    = cont2String de+      where+      cont2String	:: DTDElem -> String -> String+      cont2String NAME+	  = showAttr a_name al+      cont2String PEREF+	  = showPEAttr al+      cont2String CONTENT+	  = showLpar+	    .+	    foldr1 (combine (lookup1 a_kind al)) (map showContent cs)+            .+            showRpar+            .+            showAttr a_modifier al+      cont2String n+	  = error ("cont2string " ++ show n ++ " is undefined")+      combine k s1 s2+	  = s1+	    .+	    showString ( if k == v_seq+			 then ", "+			 else " | "+		       )+            .+            s2++showContent n+    = showXmlTree n++-- ------------------------------------------------------------++showEntity	:: String -> Attributes -> XmlTrees -> String -> String++showEntity kind al cs+    = showString "<!ENTITY "+      .+      showString kind+      .+      showAttr a_name al+      .+      showExternalId al+      .+      showNData al+      .+      showEntityValue cs+      .+      showString " >"++-- ------------------------------------------------------------++showEntityValue	:: XmlTrees -> String -> String++showEntityValue []+    = id++showEntityValue cs+    = showBlank . showQuoteString (xshow cs)++-- ------------------------------------------------------------++showBlank,+  showEq, showLt, showGt, showSlash, showApos, showQuot, showLpar, showRpar, showNL :: String -> String++showBlank	= showChar ' '+showEq		= showChar '='+showLt		= showChar '<'+showGt		= showChar '>'+showSlash	= showChar '/'+showApos	= showChar '\''+showQuot	= showChar '\"'+showLpar	= showChar '('+showRpar	= showChar ')'+showNL		= showChar '\n'++-- -----------------------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/DOM/TypeDefs.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.DOM.TypeDefs+   Copyright  : Copyright (C) 2008 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : stable+   Portability: portable++   The core data types of the HXT DOM.++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.DOM.TypeDefs+    ( module Yuuko.Data.AssocList+    , module Yuuko.Text.XML.HXT.DOM.TypeDefs+    , module Yuuko.Text.XML.HXT.DOM.QualifiedName+    )++where++import Control.DeepSeq++import Yuuko.Data.AssocList+import Yuuko.Data.Tree.NTree.TypeDefs+import Data.Typeable++import Yuuko.Text.XML.HXT.DOM.QualifiedName++-- -----------------------------------------------------------------------------+--+-- Basic types for xml tree and filters++-- | Node of xml tree representation++type XmlTree	= NTree    XNode++-- | List of nodes of xml tree representation++type XmlTrees	= NTrees   XNode++-- -----------------------------------------------------------------------------+--+-- XNode++-- | Represents elements++data XNode	= XText		  String			-- ^ ordinary text				(leaf)+		| XCharRef	  Int				-- ^ character reference			(leaf)+		| XEntityRef	  String			-- ^ entity reference				(leaf)+		| XCmt		  String			-- ^ comment					(leaf)+		| XCdata	  String			-- ^ CDATA section				(leaf)+		| XPi		  QName XmlTrees		-- ^ Processing Instr with qualified name	(leaf)+								--   with list of attributes.+								--   If tag name is xml, attributs are \"version\", \"encoding\", \"standalone\",+								--   else attribute list is empty, content is a text child node+		| XTag		  QName XmlTrees		-- ^ tag with qualified name and list of attributes (inner node or leaf)+		| XDTD		  DTDElem  Attributes		-- ^ DTD element with assoc list for dtd element features+		| XAttr		  QName				-- ^ attribute with qualified name, the attribute value is stored in children+		| XError	  Int  String			-- ^ error message with level and text+		  deriving (Eq, Ord, Show, Read, Typeable)++instance NFData XNode where+    rnf (XText s)		= rnf s+    rnf (XCharRef i)		= rnf i+    rnf (XEntityRef n)		= rnf n+    rnf (XCmt c)		= rnf c+    rnf (XCdata s)		= rnf s+    rnf (XPi qn ts)		= rnf qn `seq` rnf ts+    rnf (XTag qn cs)		= rnf qn `seq` rnf cs+    rnf (XDTD de al)		= rnf de `seq` rnf al+    rnf (XAttr qn)		= rnf qn+    rnf (XError n e)		= rnf n  `seq` rnf e++-- -----------------------------------------------------------------------------+--+-- DTDElem++-- | Represents a DTD element++data DTDElem	= DOCTYPE	-- ^ attr: name, system, public,	XDTD elems as children+		| ELEMENT	-- ^ attr: name, kind+		                --+				--  name: element name+		                --+				--  kind: \"EMPTY\" | \"ANY\" | \"\#PCDATA\" | children | mixed+		| CONTENT	-- ^ element content+		                --+				--  attr: kind, modifier+		                --+				--  modifier: \"\" | \"?\" | \"*\" | \"+\"+		                --+				--  kind: seq | choice+		| ATTLIST	-- ^ attributes:+		                --  name - name of element+		                --+				--  value - name of attribute+		                --+				--  type: \"CDATA\" | \"ID\" | \"IDREF\" | \"IDREFS\" | \"ENTITY\" | \"ENTITIES\" |+		                --+				--        \"NMTOKEN\" | \"NMTOKENS\" |\"NOTATION\" | \"ENUMTYPE\"+		                --+				--  kind: \"#REQUIRED\" | \"#IMPLIED\" | \"DEFAULT\"+		| ENTITY	-- ^ for entity declarations+		| PENTITY	-- ^ for parameter entity declarations+		| NOTATION	-- ^ for notations+		| CONDSECT	-- ^ for INCLUDEs, IGNOREs and peRefs: attr: type+		                --+				--  type = INCLUDE, IGNORE or %...;+		| NAME		-- ^ attr: name+		                --+				--  for lists of names in notation types or nmtokens in enumeration types+		| PEREF		-- ^ for Parameter Entity References in DTDs+		  deriving (Eq, Ord, Enum, Show, Read, Typeable)++instance NFData DTDElem++-- -----------------------------------------------------------------------------++-- | Attribute list+--+-- used for storing option lists and features of DTD parts++type Attributes	= AssocList String String++-- -----------------------------------------------------------------------------+--+-- Constants for error levels++-- | no error, everything is ok+c_ok	:: Int+c_ok	= 0++-- | Error level for XError, type warning+c_warn  :: Int+c_warn  = c_ok + 1++-- | Error level for XError, type error+c_err   :: Int+c_err   = c_warn + 1++-- | Error level for XError, type fatal error+c_fatal :: Int+c_fatal = c_err + 1++-- -----------------------------------------------------------------------------++-- | data type for representing a set of nodes as a tree structure+--+-- this structure is e.g. used to repesent the result of an XPath query+-- such that the selected nodes can be processed or selected later in+-- processing a document tree++data XmlNodeSet	= XNS { thisNode	:: Bool		-- ^ is this node part of the set ?+		      , attrNodes	:: [QName]	-- ^ the set of attribute nodes+		      , childNodes	:: ChildNodes	-- ^ the set of child nodes, a list of pairs of index and node set +		      }+		  deriving (Eq, Show, Typeable)++type ChildNodes	= [(Int, XmlNodeSet)]++-- -----------------------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/DOM/UTF8Decoding.hs view
@@ -0,0 +1,52 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.DOM.UTF8Decoding+   Copyright  : Copyright (C) 2005 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : stable+   Portability: portable++   Interface for Yuuko.Data.Char.UTF8 funtions++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.DOM.UTF8Decoding (+   decodeUtf8,+   decodeUtf8EmbedErrors,+   decodeUtf8IgnoreErrors,+   )+where++import qualified Yuuko.Data.Char.UTF8 as UTF8+import Data.Word (Word8)++-- | calls 'Yuuko.Data.Char.UTF8.decode' for parsing and decoding UTF-8++decodeUtf8	:: String -> (String, [String])+decodeUtf8 str+    = (res, map (uncurry toErrStr) errs)+    where+    (res, errs) = UTF8.decode . stringToByteString $ str++decodeUtf8IgnoreErrors	:: String -> String+decodeUtf8IgnoreErrors+    = fst . decodeUtf8++decodeUtf8EmbedErrors	:: String -> [Either String Char]+decodeUtf8EmbedErrors str+    = map (either (Left . uncurry toErrStr) Right) $+      UTF8.decodeEmbedErrors $ stringToByteString $ str++stringToByteString :: String -> [Word8]+stringToByteString = map (toEnum . fromEnum)++toErrStr :: UTF8.Error -> Int -> String+toErrStr err pos+	= " at input position " ++ show pos ++ ": " ++ show err++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/DOM/Unicode.hs view
@@ -0,0 +1,1105 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.DOM.Unicode+   Copyright  : Copyright (C) 2005-2008 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   Unicode and UTF-8 Conversion Functions++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.DOM.Unicode+    (+     -- * Unicode Type declarations+     Unicode,+     UString,+     UTF8Char,+     UTF8String,+     UStringWithErrors,+     DecodingFct,+     DecodingFctEmbedErrors,++      -- * XML char predicates++      isXmlChar+    , isXmlLatin1Char+    , isXmlSpaceChar+    , isXml11SpaceChar+    , isXmlNameChar+    , isXmlNameStartChar+    , isXmlNCNameChar+    , isXmlNCNameStartChar+    , isXmlPubidChar+    , isXmlLetter+    , isXmlBaseChar+    , isXmlIdeographicChar+    , isXmlCombiningChar+    , isXmlDigit+    , isXmlExtender+    , isXmlControlOrPermanentlyUndefined++      -- * UTF-8 and Unicode conversion functions+    , utf8ToUnicode+    , utf8ToUnicodeEmbedErrors+    , latin1ToUnicode+    , ucs2ToUnicode+    , ucs2BigEndianToUnicode+    , ucs2LittleEndianToUnicode+    , utf16beToUnicode+    , utf16leToUnicode++    , unicodeCharToUtf8++    , unicodeToUtf8+    , unicodeToXmlEntity+    , unicodeToLatin1+    , unicodeRemoveNoneAscii+    , unicodeRemoveNoneLatin1++    , intToCharRef+    , intToCharRefHex++    , getDecodingFct+    , getDecodingFctEmbedErrors+    , getOutputEncodingFct++    , normalizeNL+    , guessEncoding+    )+where++import Data.Char( toUpper )++import Yuuko.Text.XML.HXT.DOM.Util ( swap, partitionEither )++import Yuuko.Text.XML.HXT.DOM.IsoLatinTables+import Yuuko.Text.XML.HXT.DOM.UTF8Decoding	( decodeUtf8, decodeUtf8EmbedErrors )+import Yuuko.Text.XML.HXT.DOM.Util		( intToHexString )+import Yuuko.Text.XML.HXT.DOM.XmlKeywords++-- ------------------------------------------------------------++-- | Unicode is represented as the Char type+--   Precondition for this is the support of Unicode character range+--   in the compiler (e.g. ghc but not hugs)++type Unicode	= Char++-- | the type for Unicode strings++type UString	= [Unicode]++-- | UTF-8 charachters are represented by the Char type++type UTF8Char	= Char++-- | UTF-8 strings are implemented as Haskell strings++type UTF8String	= String++-- | Decoding function with a pair containing the result string and a list of decoding errors as result++type DecodingFct = String -> (UString, [String])++type UStringWithErrors = [Either String Char]++-- | Decoding function where decoding errors are interleaved with decoded characters++type DecodingFctEmbedErrors = String -> UStringWithErrors++-- ------------------------------------------------------------+--+-- Unicode predicates++-- |+-- test for a legal 1 byte XML char++is1ByteXmlChar		:: Unicode -> Bool+is1ByteXmlChar c+    = c < '\x80'+      && ( c >= ' '+	   ||+	   c == '\n'+	   ||+	   c == '\t'+	   ||+	   c == '\r'+	 )++-- |+-- test for a legal latin1 XML char++isXmlLatin1Char		:: Unicode -> Bool+isXmlLatin1Char i+    = is1ByteXmlChar i+      ||+      (i >= '\x80' && i <= '\xff')++-- ------------------------------------------------------------++-- |+-- conversion from Unicode strings (UString) to UTF8 encoded strings.++unicodeToUtf8		:: UString -> UTF8String+unicodeToUtf8		= concatMap unicodeCharToUtf8++-- |+-- conversion from Unicode (Char) to a UTF8 encoded string.++unicodeCharToUtf8	:: Unicode -> UTF8String+unicodeCharToUtf8 c+    | i >= 0          && i <= 0x0000007F	-- 1 byte UTF8 (7 bits)+	= [ toEnum i ]+    | i >= 0x00000080 && i <= 0x000007FF	-- 2 byte UTF8 (5 + 6 bits)+	= [ toEnum (0xC0 + i `div` 0x40)+	  , toEnum (0x80 + i                  `mod` 0x40)+	  ]+    | i >= 0x00000800 && i <= 0x0000FFFF	-- 3 byte UTF8 (4 + 6 + 6 bits)+	= [ toEnum (0xE0 +  i `div`   0x1000)+	  , toEnum (0x80 + (i `div`     0x40) `mod` 0x40)+	  , toEnum (0x80 +  i                 `mod` 0x40)+	  ]+    | i >= 0x00010000 && i <= 0x001FFFFF	-- 4 byte UTF8 (3 + 6 + 6 + 6 bits)+	= [ toEnum (0xF0 +  i `div`    0x40000)+	  , toEnum (0x80 + (i `div`     0x1000) `mod` 0x40)+	  , toEnum (0x80 + (i `div`       0x40) `mod` 0x40)+	  , toEnum (0x80 +  i                   `mod` 0x40)+	  ]+    | i >= 0x00200000 && i <= 0x03FFFFFF	-- 5 byte UTF8 (2 + 6 + 6 + 6 + 6 bits)+	= [ toEnum (0xF8 +  i `div`  0x1000000)+	  , toEnum (0x80 + (i `div`    0x40000) `mod` 0x40)+	  , toEnum (0x80 + (i `div`     0x1000) `mod` 0x40)+	  , toEnum (0x80 + (i `div`       0x40) `mod` 0x40)+	  , toEnum (0x80 +  i                   `mod` 0x40)+	  ]+    | i >= 0x04000000 && i <= 0x7FFFFFFF	-- 6 byte UTF8 (1 + 6 + 6 + 6 + 6 + 6 bits)+	= [ toEnum (0xFC +  i `div` 0x40000000)+	  , toEnum (0x80 + (i `div`  0x1000000) `mod` 0x40)+	  , toEnum (0x80 + (i `div`    0x40000) `mod` 0x40)+	  , toEnum (0x80 + (i `div`     0x1000) `mod` 0x40)+	  , toEnum (0x80 + (i `div`       0x40) `mod` 0x40)+	  , toEnum (0x80 +  i                   `mod` 0x40)+	  ]+    | otherwise					-- other values not supported+	= error ("unicodeCharToUtf8: illegal integer argument " ++ show i)+    where+    i = fromEnum c++-- ------------------------------------------------------------++-- |+-- checking for valid XML characters++isXmlChar		:: Unicode -> Bool+isXmlChar c+    = isInList c+      [ ('\x0009', '\x000A')+      , ('\x000D', '\x000D')+      , ('\x0020', '\xD7FF')+      , ('\xE000', '\xFFFD')+      , ('\x10000', '\x10FFFF')+      ]++-- |+-- checking for XML space character: \\\n, \\\r, \\\t and \" \"++isXmlSpaceChar		:: Unicode -> Bool+isXmlSpaceChar c+    = c `elem` ['\x20', '\x09', '\x0D', '\x0A']++-- |+-- checking for XML1.1 space character: additional space 0x85 and 0x2028+--+-- see also : 'isXmlSpaceChar'++isXml11SpaceChar		:: Unicode -> Bool+isXml11SpaceChar c+    = c `elem` ['\x20', '\x09', '\x0D', '\x0A', '\x85', '\x2028']++-- |+-- checking for XML name character++isXmlNameChar		:: Unicode -> Bool+isXmlNameChar c+    = isXmlLetter c+      ||+      isXmlDigit c+      ||+      (c == '\x2D' || c == '\x2E')		-- '-' | '.'+      ||+      (c == '\x3A' || c == '\x5F')		-- Letter | ':' | '_'+      ||+      isXmlCombiningChar c+      ||+      isXmlExtender c++-- |+-- checking for XML name start character+--+-- see also : 'isXmlNameChar'++isXmlNameStartChar		:: Unicode -> Bool+isXmlNameStartChar c+    = isXmlLetter c+      ||+      (c == '\x3A' || c == '\x5F')		-- Letter | ':' | '_'++-- |+-- checking for XML NCName character: no \":\" allowed+--+-- see also : 'isXmlNameChar'++isXmlNCNameChar			:: Unicode -> Bool+isXmlNCNameChar c+    = c /= '\x3A'+      &&+      isXmlNameChar c++-- |+-- checking for XML NCName start character: no \":\" allowed+--+-- see also : 'isXmlNameChar', 'isXmlNCNameChar'++isXmlNCNameStartChar		:: Unicode -> Bool+isXmlNCNameStartChar c+    = c /= '\x3A'+      &&+      isXmlNameStartChar c++-- |+-- checking for XML public id character++isXmlPubidChar		:: Unicode -> Bool+isXmlPubidChar c+    = isInList c [ ('0', '9')+		 , ('A', 'Z')+		 , ('a', 'z')+		 ]+      ||+      ( c `elem` " \r\n-'()+,./:=?;!*#@$_%" )++-- |+-- checking for XML letter++isXmlLetter		:: Unicode -> Bool+isXmlLetter c+    = isXmlBaseChar c+      ||+      isXmlIdeographicChar c++-- |+-- checking for XML base charater++isXmlBaseChar		:: Unicode -> Bool+isXmlBaseChar c+    = isInList c+      [ ('\x0041', '\x005A')+      , ('\x0061', '\x007A')+      , ('\x00C0', '\x00D6')+      , ('\x00D8', '\x00F6')+      , ('\x00F8', '\x0131')+      , ('\x0134', '\x013E')+      , ('\x0141', '\x0148')+      , ('\x014A', '\x017E')+      , ('\x0180', '\x01C3')+      , ('\x01CD', '\x01F0')+      , ('\x01F4', '\x01F5')+      , ('\x01FA', '\x0217')+      , ('\x0250', '\x02A8')+      , ('\x02BB', '\x02C1')+      , ('\x0386', '\x0386')+      , ('\x0388', '\x038A')+      , ('\x038C', '\x038C')+      , ('\x038E', '\x03A1')+      , ('\x03A3', '\x03CE')+      , ('\x03D0', '\x03D6')+      , ('\x03DA', '\x03DA')+      , ('\x03DC', '\x03DC')+      , ('\x03DE', '\x03DE')+      , ('\x03E0', '\x03E0')+      , ('\x03E2', '\x03F3')+      , ('\x0401', '\x040C')+      , ('\x040E', '\x044F')+      , ('\x0451', '\x045C')+      , ('\x045E', '\x0481')+      , ('\x0490', '\x04C4')+      , ('\x04C7', '\x04C8')+      , ('\x04CB', '\x04CC')+      , ('\x04D0', '\x04EB')+      , ('\x04EE', '\x04F5')+      , ('\x04F8', '\x04F9')+      , ('\x0531', '\x0556')+      , ('\x0559', '\x0559')+      , ('\x0561', '\x0586')+      , ('\x05D0', '\x05EA')+      , ('\x05F0', '\x05F2')+      , ('\x0621', '\x063A')+      , ('\x0641', '\x064A')+      , ('\x0671', '\x06B7')+      , ('\x06BA', '\x06BE')+      , ('\x06C0', '\x06CE')+      , ('\x06D0', '\x06D3')+      , ('\x06D5', '\x06D5')+      , ('\x06E5', '\x06E6')+      , ('\x0905', '\x0939')+      , ('\x093D', '\x093D')+      , ('\x0958', '\x0961')+      , ('\x0985', '\x098C')+      , ('\x098F', '\x0990')+      , ('\x0993', '\x09A8')+      , ('\x09AA', '\x09B0')+      , ('\x09B2', '\x09B2')+      , ('\x09B6', '\x09B9')+      , ('\x09DC', '\x09DD')+      , ('\x09DF', '\x09E1')+      , ('\x09F0', '\x09F1')+      , ('\x0A05', '\x0A0A')+      , ('\x0A0F', '\x0A10')+      , ('\x0A13', '\x0A28')+      , ('\x0A2A', '\x0A30')+      , ('\x0A32', '\x0A33')+      , ('\x0A35', '\x0A36')+      , ('\x0A38', '\x0A39')+      , ('\x0A59', '\x0A5C')+      , ('\x0A5E', '\x0A5E')+      , ('\x0A72', '\x0A74')+      , ('\x0A85', '\x0A8B')+      , ('\x0A8D', '\x0A8D')+      , ('\x0A8F', '\x0A91')+      , ('\x0A93', '\x0AA8')+      , ('\x0AAA', '\x0AB0')+      , ('\x0AB2', '\x0AB3')+      , ('\x0AB5', '\x0AB9')+      , ('\x0ABD', '\x0ABD')+      , ('\x0AE0', '\x0AE0')+      , ('\x0B05', '\x0B0C')+      , ('\x0B0F', '\x0B10')+      , ('\x0B13', '\x0B28')+      , ('\x0B2A', '\x0B30')+      , ('\x0B32', '\x0B33')+      , ('\x0B36', '\x0B39')+      , ('\x0B3D', '\x0B3D')+      , ('\x0B5C', '\x0B5D')+      , ('\x0B5F', '\x0B61')+      , ('\x0B85', '\x0B8A')+      , ('\x0B8E', '\x0B90')+      , ('\x0B92', '\x0B95')+      , ('\x0B99', '\x0B9A')+      , ('\x0B9C', '\x0B9C')+      , ('\x0B9E', '\x0B9F')+      , ('\x0BA3', '\x0BA4')+      , ('\x0BA8', '\x0BAA')+      , ('\x0BAE', '\x0BB5')+      , ('\x0BB7', '\x0BB9')+      , ('\x0C05', '\x0C0C')+      , ('\x0C0E', '\x0C10')+      , ('\x0C12', '\x0C28')+      , ('\x0C2A', '\x0C33')+      , ('\x0C35', '\x0C39')+      , ('\x0C60', '\x0C61')+      , ('\x0C85', '\x0C8C')+      , ('\x0C8E', '\x0C90')+      , ('\x0C92', '\x0CA8')+      , ('\x0CAA', '\x0CB3')+      , ('\x0CB5', '\x0CB9')+      , ('\x0CDE', '\x0CDE')+      , ('\x0CE0', '\x0CE1')+      , ('\x0D05', '\x0D0C')+      , ('\x0D0E', '\x0D10')+      , ('\x0D12', '\x0D28')+      , ('\x0D2A', '\x0D39')+      , ('\x0D60', '\x0D61')+      , ('\x0E01', '\x0E2E')+      , ('\x0E30', '\x0E30')+      , ('\x0E32', '\x0E33')+      , ('\x0E40', '\x0E45')+      , ('\x0E81', '\x0E82')+      , ('\x0E84', '\x0E84')+      , ('\x0E87', '\x0E88')+      , ('\x0E8A', '\x0E8A')+      , ('\x0E8D', '\x0E8D')+      , ('\x0E94', '\x0E97')+      , ('\x0E99', '\x0E9F')+      , ('\x0EA1', '\x0EA3')+      , ('\x0EA5', '\x0EA5')+      , ('\x0EA7', '\x0EA7')+      , ('\x0EAA', '\x0EAB')+      , ('\x0EAD', '\x0EAE')+      , ('\x0EB0', '\x0EB0')+      , ('\x0EB2', '\x0EB3')+      , ('\x0EBD', '\x0EBD')+      , ('\x0EC0', '\x0EC4')+      , ('\x0F40', '\x0F47')+      , ('\x0F49', '\x0F69')+      , ('\x10A0', '\x10C5')+      , ('\x10D0', '\x10F6')+      , ('\x1100', '\x1100')+      , ('\x1102', '\x1103')+      , ('\x1105', '\x1107')+      , ('\x1109', '\x1109')+      , ('\x110B', '\x110C')+      , ('\x110E', '\x1112')+      , ('\x113C', '\x113C')+      , ('\x113E', '\x113E')+      , ('\x1140', '\x1140')+      , ('\x114C', '\x114C')+      , ('\x114E', '\x114E')+      , ('\x1150', '\x1150')+      , ('\x1154', '\x1155')+      , ('\x1159', '\x1159')+      , ('\x115F', '\x1161')+      , ('\x1163', '\x1163')+      , ('\x1165', '\x1165')+      , ('\x1167', '\x1167')+      , ('\x1169', '\x1169')+      , ('\x116D', '\x116E')+      , ('\x1172', '\x1173')+      , ('\x1175', '\x1175')+      , ('\x119E', '\x119E')+      , ('\x11A8', '\x11A8')+      , ('\x11AB', '\x11AB')+      , ('\x11AE', '\x11AF')+      , ('\x11B7', '\x11B8')+      , ('\x11BA', '\x11BA')+      , ('\x11BC', '\x11C2')+      , ('\x11EB', '\x11EB')+      , ('\x11F0', '\x11F0')+      , ('\x11F9', '\x11F9')+      , ('\x1E00', '\x1E9B')+      , ('\x1EA0', '\x1EF9')+      , ('\x1F00', '\x1F15')+      , ('\x1F18', '\x1F1D')+      , ('\x1F20', '\x1F45')+      , ('\x1F48', '\x1F4D')+      , ('\x1F50', '\x1F57')+      , ('\x1F59', '\x1F59')+      , ('\x1F5B', '\x1F5B')+      , ('\x1F5D', '\x1F5D')+      , ('\x1F5F', '\x1F7D')+      , ('\x1F80', '\x1FB4')+      , ('\x1FB6', '\x1FBC')+      , ('\x1FBE', '\x1FBE')+      , ('\x1FC2', '\x1FC4')+      , ('\x1FC6', '\x1FCC')+      , ('\x1FD0', '\x1FD3')+      , ('\x1FD6', '\x1FDB')+      , ('\x1FE0', '\x1FEC')+      , ('\x1FF2', '\x1FF4')+      , ('\x1FF6', '\x1FFC')+      , ('\x2126', '\x2126')+      , ('\x212A', '\x212B')+      , ('\x212E', '\x212E')+      , ('\x2180', '\x2182')+      , ('\x3041', '\x3094')+      , ('\x30A1', '\x30FA')+      , ('\x3105', '\x312C')+      , ('\xAC00', '\xD7A3')+      ]++-- |+-- checking for XML ideographic charater++isXmlIdeographicChar	:: Unicode -> Bool+isXmlIdeographicChar c+    = isInList c+      [ ('\x3007', '\x3007')+      , ('\x3021', '\x3029')+      , ('\x4E00', '\x9FA5')+      ]++-- |+-- checking for XML combining charater++isXmlCombiningChar	:: Unicode -> Bool+isXmlCombiningChar c+    = isInList c+      [ ('\x0300', '\x0345')+      , ('\x0360', '\x0361')+      , ('\x0483', '\x0486')+      , ('\x0591', '\x05A1')+      , ('\x05A3', '\x05B9')+      , ('\x05BB', '\x05BD')+      , ('\x05BF', '\x05BF')+      , ('\x05C1', '\x05C2')+      , ('\x05C4', '\x05C4')+      , ('\x064B', '\x0652')+      , ('\x0670', '\x0670')+      , ('\x06D6', '\x06DC')+      , ('\x06DD', '\x06DF')+      , ('\x06E0', '\x06E4')+      , ('\x06E7', '\x06E8')+      , ('\x06EA', '\x06ED')+      , ('\x0901', '\x0903')+      , ('\x093C', '\x093C')+      , ('\x093E', '\x094C')+      , ('\x094D', '\x094D')+      , ('\x0951', '\x0954')+      , ('\x0962', '\x0963')+      , ('\x0981', '\x0983')+      , ('\x09BC', '\x09BC')+      , ('\x09BE', '\x09BE')+      , ('\x09BF', '\x09BF')+      , ('\x09C0', '\x09C4')+      , ('\x09C7', '\x09C8')+      , ('\x09CB', '\x09CD')+      , ('\x09D7', '\x09D7')+      , ('\x09E2', '\x09E3')+      , ('\x0A02', '\x0A02')+      , ('\x0A3C', '\x0A3C')+      , ('\x0A3E', '\x0A3E')+      , ('\x0A3F', '\x0A3F')+      , ('\x0A40', '\x0A42')+      , ('\x0A47', '\x0A48')+      , ('\x0A4B', '\x0A4D')+      , ('\x0A70', '\x0A71')+      , ('\x0A81', '\x0A83')+      , ('\x0ABC', '\x0ABC')+      , ('\x0ABE', '\x0AC5')+      , ('\x0AC7', '\x0AC9')+      , ('\x0ACB', '\x0ACD')+      , ('\x0B01', '\x0B03')+      , ('\x0B3C', '\x0B3C')+      , ('\x0B3E', '\x0B43')+      , ('\x0B47', '\x0B48')+      , ('\x0B4B', '\x0B4D')+      , ('\x0B56', '\x0B57')+      , ('\x0B82', '\x0B83')+      , ('\x0BBE', '\x0BC2')+      , ('\x0BC6', '\x0BC8')+      , ('\x0BCA', '\x0BCD')+      , ('\x0BD7', '\x0BD7')+      , ('\x0C01', '\x0C03')+      , ('\x0C3E', '\x0C44')+      , ('\x0C46', '\x0C48')+      , ('\x0C4A', '\x0C4D')+      , ('\x0C55', '\x0C56')+      , ('\x0C82', '\x0C83')+      , ('\x0CBE', '\x0CC4')+      , ('\x0CC6', '\x0CC8')+      , ('\x0CCA', '\x0CCD')+      , ('\x0CD5', '\x0CD6')+      , ('\x0D02', '\x0D03')+      , ('\x0D3E', '\x0D43')+      , ('\x0D46', '\x0D48')+      , ('\x0D4A', '\x0D4D')+      , ('\x0D57', '\x0D57')+      , ('\x0E31', '\x0E31')+      , ('\x0E34', '\x0E3A')+      , ('\x0E47', '\x0E4E')+      , ('\x0EB1', '\x0EB1')+      , ('\x0EB4', '\x0EB9')+      , ('\x0EBB', '\x0EBC')+      , ('\x0EC8', '\x0ECD')+      , ('\x0F18', '\x0F19')+      , ('\x0F35', '\x0F35')+      , ('\x0F37', '\x0F37')+      , ('\x0F39', '\x0F39')+      , ('\x0F3E', '\x0F3E')+      , ('\x0F3F', '\x0F3F')+      , ('\x0F71', '\x0F84')+      , ('\x0F86', '\x0F8B')+      , ('\x0F90', '\x0F95')+      , ('\x0F97', '\x0F97')+      , ('\x0F99', '\x0FAD')+      , ('\x0FB1', '\x0FB7')+      , ('\x0FB9', '\x0FB9')+      , ('\x20D0', '\x20DC')+      , ('\x20E1', '\x20E1')+      , ('\x302A', '\x302F')+      , ('\x3099', '\x3099')+      , ('\x309A', '\x309A')+      ]++-- |+-- checking for XML digit++isXmlDigit		:: Unicode -> Bool+isXmlDigit c+    = isInList c+      [ ('\x0030', '\x0039')+      , ('\x0660', '\x0669')+      , ('\x06F0', '\x06F9')+      , ('\x0966', '\x096F')+      , ('\x09E6', '\x09EF')+      , ('\x0A66', '\x0A6F')+      , ('\x0AE6', '\x0AEF')+      , ('\x0B66', '\x0B6F')+      , ('\x0BE7', '\x0BEF')+      , ('\x0C66', '\x0C6F')+      , ('\x0CE6', '\x0CEF')+      , ('\x0D66', '\x0D6F')+      , ('\x0E50', '\x0E59')+      , ('\x0ED0', '\x0ED9')+      , ('\x0F20', '\x0F29')+      ]++-- |+-- checking for XML extender++isXmlExtender		:: Unicode -> Bool+isXmlExtender c+    = isInList c+      [ ('\x00B7', '\x00B7')+      , ('\x02D0', '\x02D0')+      , ('\x02D1', '\x02D1')+      , ('\x0387', '\x0387')+      , ('\x0640', '\x0640')+      , ('\x0E46', '\x0E46')+      , ('\x0EC6', '\x0EC6')+      , ('\x3005', '\x3005')+      , ('\x3031', '\x3035')+      , ('\x309D', '\x309E')+      , ('\x30FC', '\x30FE')+      ]++-- |+-- checking for XML control or permanently discouraged char+--+-- see Errata to XML1.0 (http:\/\/www.w3.org\/XML\/xml-V10-2e-errata) No 46+--+-- Document authors are encouraged to avoid "compatibility characters",+-- as defined in section 6.8 of [Unicode] (see also D21 in section 3.6 of [Unicode3]).+-- The characters defined in the following ranges are also discouraged.+-- They are either control characters or permanently undefined Unicode characters:+++isXmlControlOrPermanentlyUndefined	:: Unicode -> Bool+isXmlControlOrPermanentlyUndefined c+    = isInList c+      [ ('\x7F', '\x84')+      , ('\x86', '\x9F')+      , ('\xFDD0', '\xFDDF')+      , ('\x1FFFE', '\x1FFFF')+      , ('\x2FFFE', '\x2FFFF')+      , ('\x3FFFE', '\x3FFFF')+      , ('\x4FFFE', '\x4FFFF')+      , ('\x5FFFE', '\x5FFFF')+      , ('\x6FFFE', '\x6FFFF')+      , ('\x7FFFE', '\x7FFFF')+      , ('\x8FFFE', '\x8FFFF')+      , ('\x9FFFE', '\x9FFFF')+      , ('\xAFFFE', '\xAFFFF')+      , ('\xBFFFE', '\xBFFFF')+      , ('\xCFFFE', '\xCFFFF')+      , ('\xDFFFE', '\xDFFFF')+      , ('\xEFFFE', '\xEFFFF')+      , ('\xFFFFE', '\xFFFFF')+      , ('\x10FFFE', '\x10FFFF')+      ]++-- ------------------------------------------------------------++isInList	:: Unicode -> [(Unicode, Unicode)] -> Bool+isInList i =+   foldr (\(lb, ub) b -> i >= lb && (i <= ub || b)) False+   {- The expression (i>=lb && i<=ub) || b would work more generally,+      but in a sorted list, the above one aborts the computation as early as possible. -}++{-+isInList'	:: Unicode -> [(Unicode, Unicode)] -> Bool+isInList' i ((lb, ub) : l)+    | i <  lb	= False+    | i <= ub	= True+    | otherwise = isInList' i l++isInList' _ []+    = False++{- works, but is not so fast -}+isInList''	:: Unicode -> [(Unicode, Unicode)] -> Bool+isInList'' i = any (flip isInRange i)++-- move to an Utility module?+isInRange	:: Ord a => (a,a) -> a -> Bool+isInRange (l,r) x = l<=x && x<=r++propIsInList :: Bool+propIsInList =+   all+     (\c -> let dict = [ ('\x0041', '\x005A'), ('\x0061', '\x007A') ]+                b0 = isInList c dict+                b1 = isInList' c dict+                b2 = isInList'' c dict+            in  b0 == b1 && b0 == b2)+     ['\x00'..'\x100']+-}++-- ------------------------------------------------------------++-- |+-- code conversion from latin1 to Unicode++latin1ToUnicode	:: String -> UString+latin1ToUnicode	= id++latinToUnicode	:: [(Char, Char)] -> String -> UString+latinToUnicode tt+    = map charToUni+    where+    charToUni c =+       foldr (\(src,dst) r ->+          case compare c src of+             EQ -> dst+             LT -> c {- not found in table -}+             GT -> r) c tt++-- | conversion from ASCII to unicode with check for legal ASCII char set+--+-- Structure of decoding function copied from 'Yuuko.Data.Char.UTF8.decode'.++decodeAscii	:: DecodingFct+decodeAscii+    = swap . partitionEither . decodeAsciiEmbedErrors++decodeAsciiEmbedErrors	:: String -> UStringWithErrors+decodeAsciiEmbedErrors str+    = map (\(c,pos) -> if isValid c+                         then Right c+                         else Left (toErrStr c pos)) posStr+    where+    posStr = zip str [(0::Int)..]+    toErrStr errChr pos+	= " at input position " ++ show pos ++ ": none ASCII char " ++ show errChr+    isValid x = x < '\x80'++-- |+-- UCS-2 big endian to Unicode conversion++ucs2BigEndianToUnicode	:: String -> UString++ucs2BigEndianToUnicode (b : l : r)+    = toEnum (fromEnum b * 256 + fromEnum l) : ucs2BigEndianToUnicode r++ucs2BigEndianToUnicode []+    = []++ucs2BigEndianToUnicode _+    = []				-- error "illegal UCS-2 byte input sequence with odd length"+					-- is ignored (garbage in, garbage out)++-- ------------------------------------------------------------++-- |+-- UCS-2 little endian to Unicode conversion++ucs2LittleEndianToUnicode	:: String -> UString++ucs2LittleEndianToUnicode (l : b : r)+    = toEnum (fromEnum b * 256 + fromEnum l) : ucs2LittleEndianToUnicode r++ucs2LittleEndianToUnicode []+    = []++ucs2LittleEndianToUnicode [_]+    = []				-- error "illegal UCS-2 byte input sequence with odd length"+					-- is ignored++-- ------------------------------------------------------------++-- |+-- UCS-2 to UTF-8 conversion with byte order mark analysis++ucs2ToUnicode		:: String -> UString++ucs2ToUnicode ('\xFE':'\xFF':s)		-- 2 byte mark for big endian encoding+    = ucs2BigEndianToUnicode s++ucs2ToUnicode ('\xFF':'\xFE':s)		-- 2 byte mark for little endian encoding+    = ucs2LittleEndianToUnicode s++ucs2ToUnicode s+    = ucs2BigEndianToUnicode s		-- default: big endian++-- ------------------------------------------------------------++-- |+-- UTF-8 to Unicode conversion with deletion of leading byte order mark, as described in XML standard F.1++utf8ToUnicode		:: DecodingFct++utf8ToUnicode ('\xEF':'\xBB':'\xBF':s)	-- remove byte order mark ( XML standard F.1 )+    = decodeUtf8 s++utf8ToUnicode s+    = decodeUtf8 s++utf8ToUnicodeEmbedErrors	:: DecodingFctEmbedErrors++utf8ToUnicodeEmbedErrors ('\xEF':'\xBB':'\xBF':s)	-- remove byte order mark ( XML standard F.1 )+    = decodeUtf8EmbedErrors s++utf8ToUnicodeEmbedErrors s+    = decodeUtf8EmbedErrors s++-- ------------------------------------------------------------++-- |+-- UTF-16 big endian to UTF-8 conversion with removal of byte order mark++utf16beToUnicode		:: String -> UString++utf16beToUnicode ('\xFE':'\xFF':s)		-- remove byte order mark+    = ucs2BigEndianToUnicode s++utf16beToUnicode s+    = ucs2BigEndianToUnicode s++-- ------------------------------------------------------------++-- |+-- UTF-16 little endian to UTF-8 conversion with removal of byte order mark++utf16leToUnicode		:: String -> UString++utf16leToUnicode ('\xFF':'\xFE':s)		-- remove byte order mark+    = ucs2LittleEndianToUnicode s++utf16leToUnicode s+    = ucs2LittleEndianToUnicode s+++-- ------------------------------------------------------------++-- |+-- substitute all Unicode characters, that are not legal 1-byte+-- UTF-8 XML characters by a character reference.+--+-- This function can be used to translate all text nodes and+-- attribute values into pure ascii.+--+-- see also : 'unicodeToLatin1'++unicodeToXmlEntity	:: UString -> String+unicodeToXmlEntity+    = escape is1ByteXmlChar (intToCharRef . fromEnum)++-- |+-- substitute all Unicode characters, that are not legal latin1+-- UTF-8 XML characters by a character reference.+--+-- This function can be used to translate all text nodes and+-- attribute values into ISO latin1.+--+-- see also : 'unicodeToXmlEntity'++unicodeToLatin1	:: UString -> String+unicodeToLatin1+    = escape isXmlLatin1Char (intToCharRef . fromEnum)+++-- |+-- substitute selected characters+-- The @check@ function returns 'True' whenever a character needs to substitution+-- The function @esc@ computes a substitute.+escape :: (Unicode -> Bool) -> (Unicode -> String) -> UString -> String+escape check esc =+    concatMap (\uc -> if check uc then [uc] else esc uc)++-- |+-- removes all non ascii chars, may be used to transform+-- a document into a pure ascii representation by removing+-- all non ascii chars from tag and attibute names+--+-- see also : 'unicodeRemoveNoneLatin1', 'unicodeToXmlEntity'++unicodeRemoveNoneAscii	:: UString -> String+unicodeRemoveNoneAscii+    = filter is1ByteXmlChar++-- |+-- removes all non latin1 chars, may be used to transform+-- a document into a pure ascii representation by removing+-- all non ascii chars from tag and attibute names+--+-- see also : 'unicodeRemoveNoneAscii', 'unicodeToLatin1'++unicodeRemoveNoneLatin1	:: UString -> String+unicodeRemoveNoneLatin1+    = filter isXmlLatin1Char++-- ------------------------------------------------------------++-- |+-- convert an Unicode into a XML character reference.+--+-- see also : 'intToCharRefHex'++intToCharRef		:: Int -> String+intToCharRef i+    = "&#" ++ show i ++ ";"++-- |+-- convert an Unicode into a XML hexadecimal character reference.+--+-- see also: 'intToCharRef'++intToCharRefHex		:: Int -> String+intToCharRefHex i+    = "&#x" ++ h2 ++ ";"+      where+      h1 = intToHexString i+      h2 = if length h1 `mod` 2 == 1+	   then '0': h1+	   else h1++-- ------------------------------------------------------------+--+-- | White Space (XML Standard 2.3) and+-- end of line handling (2.11)+--+-- \#x0D and \#x0D\#x0A are mapped to \#x0A++normalizeNL	:: String -> String+normalizeNL ('\r' : '\n' : rest)	= '\n' : normalizeNL rest+normalizeNL ('\r' : rest)		= '\n' : normalizeNL rest+normalizeNL (c : rest)			= c    : normalizeNL rest+normalizeNL []				= []+++-- ------------------------------------------------------------++-- |+-- the table of supported character encoding schemes and the associated+-- conversion functions into Unicode:q++{-+This table could be derived from decodingTableEither,+but this way it is certainly more efficient.+-}++decodingTable	:: [(String, DecodingFct)]+decodingTable+    = [ (utf8,		utf8ToUnicode				)+      , (isoLatin1,	liftDecFct latin1ToUnicode		)+      , (usAscii,	decodeAscii				)+      , (ucs2,		liftDecFct ucs2ToUnicode		)+      , (utf16,		liftDecFct ucs2ToUnicode		)+      , (utf16be,	liftDecFct utf16beToUnicode		)+      , (utf16le,	liftDecFct utf16leToUnicode		)+      , (iso8859_2,	liftDecFct (latinToUnicode iso_8859_2)	)+      , (iso8859_3,	liftDecFct (latinToUnicode iso_8859_3)	)+      , (iso8859_4,	liftDecFct (latinToUnicode iso_8859_4)	)+      , (iso8859_5,	liftDecFct (latinToUnicode iso_8859_5)	)+      , (iso8859_6,	liftDecFct (latinToUnicode iso_8859_6)	)+      , (iso8859_7,	liftDecFct (latinToUnicode iso_8859_7)	)+      , (iso8859_8,	liftDecFct (latinToUnicode iso_8859_8)	)+      , (iso8859_9,	liftDecFct (latinToUnicode iso_8859_9)	)+      , (iso8859_10,	liftDecFct (latinToUnicode iso_8859_10)	)+      , (iso8859_11,	liftDecFct (latinToUnicode iso_8859_11)	)+      , (iso8859_13,	liftDecFct (latinToUnicode iso_8859_13)	)+      , (iso8859_14,	liftDecFct (latinToUnicode iso_8859_14)	)+      , (iso8859_15,	liftDecFct (latinToUnicode iso_8859_15)	)+      , (iso8859_16,	liftDecFct (latinToUnicode iso_8859_16)	)+      , (unicodeString,	liftDecFct id				)+      , ("",		liftDecFct id				)	-- default+      ]+    where+    liftDecFct df = \ s -> (df s, [])++-- |+-- the lookup function for selecting the decoding function++getDecodingFct		:: String -> Maybe DecodingFct+getDecodingFct enc+    = lookup (map toUpper enc) decodingTable+++-- |+-- Similar to 'decodingTable' but it embeds errors+-- in the string of decoded characters.++decodingTableEmbedErrors	:: [(String, DecodingFctEmbedErrors)]+decodingTableEmbedErrors+    = [ (utf8,		utf8ToUnicodeEmbedErrors		)+      , (isoLatin1,	liftDecFct latin1ToUnicode		)+      , (usAscii,	decodeAsciiEmbedErrors			)+      , (ucs2,		liftDecFct ucs2ToUnicode		)+      , (utf16,		liftDecFct ucs2ToUnicode		)+      , (utf16be,	liftDecFct utf16beToUnicode		)+      , (utf16le,	liftDecFct utf16leToUnicode		)+      , (iso8859_2,	liftDecFct (latinToUnicode iso_8859_2)	)+      , (iso8859_3,	liftDecFct (latinToUnicode iso_8859_3)	)+      , (iso8859_4,	liftDecFct (latinToUnicode iso_8859_4)	)+      , (iso8859_5,	liftDecFct (latinToUnicode iso_8859_5)	)+      , (iso8859_6,	liftDecFct (latinToUnicode iso_8859_6)	)+      , (iso8859_7,	liftDecFct (latinToUnicode iso_8859_7)	)+      , (iso8859_8,	liftDecFct (latinToUnicode iso_8859_8)	)+      , (iso8859_9,	liftDecFct (latinToUnicode iso_8859_9)	)+      , (iso8859_10,	liftDecFct (latinToUnicode iso_8859_10)	)+      , (iso8859_11,	liftDecFct (latinToUnicode iso_8859_11)	)+      , (iso8859_13,	liftDecFct (latinToUnicode iso_8859_13)	)+      , (iso8859_14,	liftDecFct (latinToUnicode iso_8859_14)	)+      , (iso8859_15,	liftDecFct (latinToUnicode iso_8859_15)	)+      , (iso8859_16,	liftDecFct (latinToUnicode iso_8859_16)	)+      , (unicodeString,	liftDecFct id				)+      , ("",		liftDecFct id				)	-- default+      ]+    where+    liftDecFct df = map Right . df++-- |+-- the lookup function for selecting the decoding function++getDecodingFctEmbedErrors	:: String -> Maybe DecodingFctEmbedErrors+getDecodingFctEmbedErrors enc+    = lookup (map toUpper enc) decodingTableEmbedErrors++++-- |+-- the table of supported output encoding schemes and the associated+-- conversion functions from Unicode++outputEncodingTable	:: [(String, (UString -> String))]+outputEncodingTable+    = [ (utf8,		unicodeToUtf8		)+      , (isoLatin1,	unicodeToLatin1		)+      , (usAscii,	unicodeToXmlEntity	)+      , (ucs2,		ucs2ToUnicode		)+      , (unicodeString,	id			)+      , ("",		unicodeToUtf8		)	-- default+      ]++-- |+-- the lookup function for selecting the encoding function++getOutputEncodingFct		:: String -> Maybe (String -> UString)+getOutputEncodingFct enc+    = lookup (map toUpper enc) outputEncodingTable++-- ------------------------------------------------------------+--++guessEncoding		:: String -> String++guessEncoding ('\xFF':'\xFE':'\x00':'\x00':_)	= "UCS-4LE"		-- with byte order mark+guessEncoding ('\xFF':'\xFE':_)			= "UTF-16LE"		-- with byte order mark++guessEncoding ('\xFE':'\xFF':'\x00':'\x00':_)	= "UCS-4-3421"		-- with byte order mark+guessEncoding ('\xFE':'\xFF':_)			= "UTF-16BE"		-- with byte order mark++guessEncoding ('\xEF':'\xBB':'\xBF':_)		= utf8			-- with byte order mark++guessEncoding ('\x00':'\x00':'\xFE':'\xFF':_)	= "UCS-4BE"		-- with byte order mark+guessEncoding ('\x00':'\x00':'\xFF':'\xFE':_)	= "UCS-4-2143"		-- with byte order mark++guessEncoding ('\x00':'\x00':'\x00':'\x3C':_)	= "UCS-4BE"		-- "<" of "<?xml"+guessEncoding ('\x3C':'\x00':'\x00':'\x00':_)	= "UCS-4LE"		-- "<" of "<?xml"+guessEncoding ('\x00':'\x00':'\x3C':'\x00':_)	= "UCS-4-2143"		-- "<" of "<?xml"+guessEncoding ('\x00':'\x3C':'\x00':'\x00':_)	= "UCS-4-3412"		-- "<" of "<?xml"++guessEncoding ('\x00':'\x3C':'\x00':'\x3F':_)	= "UTF-16BE"		-- "<?" of "<?xml"+guessEncoding ('\x3C':'\x00':'\x3F':'\x00':_)	= "UTF-16LE"		-- "<?" of "<?xml"++guessEncoding ('\x4C':'\x6F':'\xA7':'\x94':_)	= "EBCDIC"		-- "<?xm" of "<?xml"++guessEncoding _					= ""			-- no guess++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/DOM/Util.hs view
@@ -0,0 +1,316 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.DOM.Util+   Copyright  : Copyright (C) 2008 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : stable+   Portability: portable++   Little useful things for strings, lists and other values++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.DOM.Util+    ( stringTrim+    , stringToLower+    , stringToUpper+    , stringAll+    , stringFirst+    , stringLast++    , normalizeNumber+    , normalizeWhitespace+    , normalizeBlanks++    , escapeURI+    , textEscapeXml+    , stringEscapeXml+    , attrEscapeXml++    , stringToInt+    , stringToHexString+    , charToHexString+    , intToHexString+    , hexStringToInt+    , decimalStringToInt++    , doubles+    , singles+    , noDoubles++    , swap+    , partitionEither+    , toMaybe++    , uncurry3+    , uncurry4+    )+where++import 		 Data.Char+import 		 Data.List+import		 Data.Maybe++-- ------------------------------------------------------------++-- |+-- remove leading and trailing whitespace with standard Haskell predicate isSpace++stringTrim		:: String -> String+stringTrim		= reverse . dropWhile isSpace . reverse . dropWhile isSpace++-- |+-- convert string to uppercase with standard Haskell toUpper function++stringToUpper		:: String -> String+stringToUpper		= map toUpper++-- |+-- convert string to lowercase with standard Haskell toLower function++stringToLower		:: String -> String+stringToLower		= map toLower+++-- | find all positions where a string occurs within another string++stringAll	:: (Eq a) => [a] -> [a] -> [Int]+stringAll x	= map fst . filter ((x `isPrefixOf`) . snd) . zip [0..] . tails++-- | find the position of the first occurence of a string++stringFirst	:: (Eq a) => [a] -> [a] -> Maybe Int+stringFirst x	= listToMaybe . stringAll x++-- | find the position of the last occurence of a string++stringLast	:: (Eq a) => [a] -> [a] -> Maybe Int+stringLast x	= listToMaybe . reverse . stringAll x++-- ------------------------------------------------------------+-- | Removes leading \/ trailing whitespaces and leading zeros++normalizeNumber		:: String -> String+normalizeNumber+    = reverse . dropWhile (== ' ') . reverse . +      dropWhile (\x -> x == '0' || x == ' ')++-- | Reduce whitespace sequences to a single whitespace++normalizeWhitespace	:: String -> String+normalizeWhitespace	= unwords . words++-- | replace all whitespace chars by blanks++normalizeBlanks		:: String -> String+normalizeBlanks		= map (\ x -> if isSpace x then ' ' else x)++-- ------------------------------------------------------------++-- | Escape all disallowed characters in URI +-- references (see <http://www.w3.org/TR/xlink/#link-locators>)++escapeURI :: String -> String+escapeURI ref+    = concatMap replace ref+      where+      notAllowed	:: Char -> Bool+      notAllowed c+	  = c < '\31'+	    ||+	    c `elem` ['\DEL', ' ', '<', '>', '\"', '{', '}', '|', '\\', '^', '`' ]++      replace :: Char -> String+      replace c+	  | notAllowed c+	      = '%' : charToHexString c+	  | otherwise+	      = [c]++-- ------------------------------------------------------------++escapeXml		:: String -> String -> String+escapeXml escSet+    = concatMap esc+      where+      esc c+	  | c `elem` escSet+	      = "&#" ++ show (fromEnum c) ++ ";"+	  | otherwise+	      = [c]++-- |+-- escape XML chars &lt;, &gt;, &quot;,  and ampercent by transforming them into character references+--+-- see also : 'attrEscapeXml'++stringEscapeXml	:: String -> String+stringEscapeXml	= escapeXml "<>\"\'&"++-- |+-- escape XML chars &lt;  and ampercent by transforming them into character references, used for escaping text nodes+--+-- see also : 'attrEscapeXml'++textEscapeXml		:: String -> String+textEscapeXml		= escapeXml "<&"++-- |+-- escape XML chars in attribute values, same as stringEscapeXml, but none blank whitespace+-- is also escaped+--+-- see also : 'stringEscapeXml'++attrEscapeXml		:: String -> String+attrEscapeXml		= escapeXml "<>\"\'&\n\r\t"++stringToInt		:: Int -> String -> Int+stringToInt base digits+    = sign * (foldl acc 0 $ concatMap digToInt digits1)+      where+      splitSign ('-' : ds) = ((-1), ds)+      splitSign ('+' : ds) = ( 1  , ds)+      splitSign ds         = ( 1  , ds)+      (sign, digits1)      = splitSign digits+      digToInt c+	  | c >= '0' && c <= '9'+	      = [ord c - ord '0']+	  | c >= 'A' && c <= 'Z'+	      =  [ord c - ord 'A' + 10]+	  | c >= 'a' && c <= 'z'+	      =  [ord c - ord 'a' + 10]+	  | otherwise+	      = []+      acc i1 i0+	  = i1 * base + i0+++-- |+-- convert a string of hexadecimal digits into an Int++hexStringToInt		:: String -> Int+hexStringToInt		= stringToInt 16++-- |+-- convert a string of digits into an Int++decimalStringToInt	:: String -> Int+decimalStringToInt	= stringToInt 10++-- |+-- convert a string into a hexadecimal string applying charToHexString+--+-- see also : 'charToHexString'++stringToHexString	:: String -> String+stringToHexString	= concatMap charToHexString++-- |+-- convert a char (byte) into a 2-digit hexadecimal string+--+-- see also : 'stringToHexString', 'intToHexString'++charToHexString		:: Char -> String+charToHexString c+    = [ fourBitsToChar (c' `div` 16)+      , fourBitsToChar (c' `mod` 16)+      ]+    where+    c' = fromEnum c++-- |+-- convert a none negative Int into a hexadecimal string+--+-- see also : 'charToHexString'++intToHexString		:: Int -> String+intToHexString i+    | i == 0+	= "0"+    | i > 0+	= intToStr i+    | otherwise+	= error ("intToHexString: negative argument " ++ show i)+    where+    intToStr 0	= ""+    intToStr i'	= intToStr (i' `div` 16) ++ [fourBitsToChar (i' `mod` 16)]++fourBitsToChar		:: Int -> Char+fourBitsToChar i	= "0123456789ABCDEF" !! i++-- ------------------------------------------------------------++-- |+-- take all elements of a list which occur more than once. The result does not contain doubles.+-- (doubles . doubles == doubles)++doubles	:: Eq a => [a] -> [a]+doubles+    = doubles' []+      where+      doubles' acc []+	  = acc+      doubles' acc (e : s)+	  | e `elem` s+	    &&+	    e `notElem` acc+	      = doubles' (e:acc) s+	  | otherwise+	      = doubles' acc s++-- |+-- drop all elements from a list which occur more than once.++singles	:: Eq a => [a] -> [a]+singles+    = singles' []+      where+      singles' acc []+	  = acc+      singles' acc (e : s)+	  | e `elem` s+	    ||+	    e `elem` acc+	      = singles' acc s+	  | otherwise+	      = singles' (e : acc) s++-- |+-- remove duplicates from list++noDoubles :: Eq a => [a] -> [a]+noDoubles []+    = []+noDoubles (e : s)+    | e `elem` s = noDoubles s+    | otherwise  = e : noDoubles s++-- ------------------------------------------------------------++swap :: (a,b) -> (b,a)+swap (x,y) = (y,x)++partitionEither :: [Either a b] -> ([a], [b])+partitionEither =+   foldr (\x ~(ls,rs) -> either (\l -> (l:ls,rs)) (\r -> (ls,r:rs)) x) ([],[])++toMaybe :: Bool -> a -> Maybe a+toMaybe False _ = Nothing+toMaybe True  x = Just x++-- ------------------------------------------------------------++-- | mothers little helpers for to much curry++uncurry3			:: (a -> b -> c -> d) -> (a, b, c) -> d+uncurry3 f ~(a, b, c)		= f a b c++uncurry4			:: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e+uncurry4 f ~(a, b, c, d)	= f a b c d++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/DOM/XmlKeywords.hs view
@@ -0,0 +1,375 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.DOM.XmlKeywords+   Copyright  : Copyright (C) 2005 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   Constants for XML keywords, for special attribute names+   and special attribute values++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.DOM.XmlKeywords+where++-- ------------------------------------------------------------+--+-- string constants for representing DTD keywords and attributes++t_xml,				-- tag names+ t_root		:: String++a_accept_mimetypes,+ a_add_default_dtd,+ a_canonicalize,+ a_default,			-- attribute names+ a_check_namespaces,+ a_contentLength,+ a_collect_errors,+ a_column,+ a_default_baseuri,+ a_do_not_canonicalize,+ a_do_not_check_namespaces,+ a_do_not_issue_errors,+ a_do_not_issue_warnings,+ a_do_not_preserve_comment,+ a_do_not_remove_whitespace,+ a_do_not_use_curl,+ a_do_not_validate,+ a_encoding,+ a_error,+ a_error_log,+ a_help,+ a_ignore_encoding_errors,+ a_ignore_none_xml_contents,+ a_indent,+ a_issue_errors,+ a_issue_warnings,+ a_kind,+ a_line,+ a_mime_types,+ a_module,+ a_modifier,+ a_name,+ a_no_empty_elements,+ a_no_empty_elem_for,+ a_no_redirect,+ a_no_xml_pi,+ a_options_curl,+ a_output_encoding,+ a_output_file,+ a_output_xml,+ a_output_html,+ a_output_xhtml,+ a_parse_by_mimetype,+ a_parse_html,+ a_parse_xml,+ a_peref,+ a_preserve_comment,+ a_propagate_errors,+ a_proxy,+ a_remove_whitespace,+ a_redirect,+ a_show_haskell,+ a_show_tree,+ a_source,+ a_status,+ a_standalone,+ a_strict_input,+ a_tagsoup,+ a_text_mode,+ a_trace,+ a_type,+ a_use_curl,+ a_url,+ a_validate,+ a_value,+ a_verbose,+ a_version,+ a_xml,+ a_xmlns	:: String++v_0,				-- attribute values+ v_1,+ v_yes,+ v_no,+ v_any,+ v_children,+ v_choice,+ v_empty,+ v_mixed,+ v_seq,+ v_null,+ v_option,+ v_pcdata,+ v_star,+ v_plus		:: String++k_any,				-- DTD keywords+ k_cdata,+ k_empty,+ k_entity,+ k_entities,+ k_id,+ k_idref,+ k_idrefs,+ k_include,+ k_ignore,+ k_nmtoken,+ k_nmtokens,+ k_peref,+ k_public,+ k_system,+ k_enumeration,+ k_fixed,+ k_implied,+ k_ndata,+ k_notation,+ k_pcdata,+ k_required,+ k_default	:: String++-- ------------------------------------------------------------++t_xml		= "xml"+t_root		= "/"		-- name of root node tag++a_accept_mimetypes		= "accept-mimetypes"+a_add_default_dtd               = "add-default-dtd"+a_canonicalize			= "canonicalize"+a_check_namespaces		= "check-namespaces"+a_collect_errors		= "collect-errors"+a_column			= "column"+a_contentLength			= "Content-Length"+a_default			= "default"+a_default_baseuri		= "default-base-URI"+a_do_not_canonicalize		= "do-not-canonicalize"+a_do_not_check_namespaces	= "do-not-check-namespaces"+a_do_not_issue_errors		= "do-not-issue-errors"+a_do_not_issue_warnings		= "do-not-issue-warnings"+a_do_not_preserve_comment	= "do-not-preserve-comment"+a_do_not_remove_whitespace	= "do-not-remove-whitespace"+a_do_not_use_curl		= "do-not-use-curl"+a_do_not_validate		= "do-not-validate"+a_encoding			= "encoding"+a_error				= "error"+a_error_log			= "errorLog"+a_help				= "help"+a_ignore_encoding_errors	= "ignore-encoding-errors"+a_ignore_none_xml_contents	= "ignore-none-xml-contents"+a_indent			= "indent"+a_issue_warnings		= "issue-warnings"+a_issue_errors			= "issue-errors"+a_kind				= "kind"+a_line				= "line"+a_mime_types			= "mimetypes"+a_module			= "module"+a_modifier			= "modifier"+a_name				= "name"+a_no_empty_elements		= "no-empty-elements"+a_no_empty_elem_for             = "no-empty-elem-for"+a_no_redirect	 		= "no-redirect"+a_no_xml_pi                     = "no-xml-pi"+a_options_curl			= "options-curl"+a_output_file			= "output-file"+a_output_encoding		= "output-encoding"+a_output_html			= "output-html"+a_output_xhtml			= "output-xhtml"+a_output_xml			= "output-xml"+a_parse_by_mimetype		= "parse-by-mimetype"+a_parse_html			= "parse-html"+a_parse_xml			= "parse-xml"+a_peref				= k_peref+a_preserve_comment 		= "preserve-comment"+a_propagate_errors		= "propagate-errors"+a_proxy				= "proxy"+a_redirect	 		= "redirect"+a_remove_whitespace 		= "remove-whitespace"+a_show_haskell			= "show-haskell"+a_show_tree			= "show-tree"+a_source			= "source"+a_standalone			= "standalone"+a_status			= "status"+a_strict_input			= "strict-input"+a_tagsoup			= "tagsoup"+a_text_mode			= "text-mode"+a_trace				= "trace"+a_type				= "type"+a_url				= "url"+a_use_curl			= "use-curl"+a_validate			= "validate"+a_value				= "value"+a_verbose			= "verbose"+a_version			= "version"+a_xml				= "xml"+a_xmlns				= "xmlns"++v_yes		= "yes"+v_no		= "no"+v_1		= "1"+v_0		= "0"++v_any		= k_any+v_children	= "children"+v_choice	= "choice"+v_empty		= k_empty+v_pcdata	= k_pcdata+v_mixed		= "mixed"+v_seq		= "seq"++v_null		= ""+v_option	= "?"+v_star		= "*"+v_plus		= "+"++k_any		= "ANY"+k_cdata		= "CDATA"+k_empty		= "EMPTY"+k_entity	= "ENTITY"+k_entities	= "ENTITIES"+k_id		= "ID"+k_idref		= "IDREF"+k_idrefs	= "IDREFS"+k_include	= "INCLUDE"+k_ignore	= "IGNORE"+k_nmtoken	= "NMTOKEN"+k_nmtokens	= "NMTOKENS"+k_peref		= "PERef"+k_public	= "PUBLIC"+k_system	= "SYSTEM"++k_enumeration	= "#ENUMERATION"+k_fixed		= "#FIXED"+k_implied	= "#IMPLIED"+k_ndata		= "NDATA"+k_notation	= "NOTATION"+k_pcdata	= "#PCDATA"+k_required	= "#REQUIRED"+k_default	= "#DEFAULT"+++dtdPrefix	:: String+dtdPrefix	= "doctype-"++-- ------------------------------------------------------------+--++-- attribute names for transfer protocol attributes+-- used in XmlInput for describing header information+-- of http and other requests++transferPrefix+ , transferProtocol+ , transferMimeType+ , transferEncoding+ , transferURI+ , transferDefaultURI+ , transferStatus+ , transferMessage+ , transferVersion :: String++transferPrefix		= "transfer-"++transferProtocol	= transferPrefix ++ "Protocol"+transferVersion		= transferPrefix ++ "Version"+transferMimeType	= transferPrefix ++ "MimeType"+transferEncoding	= transferPrefix ++ "Encoding"+transferDefaultURI	= transferPrefix ++ "DefaultURI"+transferStatus		= transferPrefix ++ "Status"+transferMessage		= transferPrefix ++ "Message"+transferURI		= transferPrefix ++ "URI"++-- ------------------------------------------------------------+--++httpPrefix	:: String+httpPrefix	= "http-"++stringProtocol	:: String+stringProtocol	= "string:"++-- ------------------------------------------------------------+--+-- encoding names++isoLatin1+  , iso8859_1, iso8859_2, iso8859_3, iso8859_4, iso8859_5+  , iso8859_6, iso8859_7, iso8859_8, iso8859_9, iso8859_10+  , iso8859_11, iso8859_13, iso8859_14, iso8859_15, iso8859_16+  , usAscii, ucs2, utf8, utf16, utf16be, utf16le, unicodeString	:: String++isoLatin1	= iso8859_1+iso8859_1	= "ISO-8859-1"+iso8859_2	= "ISO-8859-2"+iso8859_3	= "ISO-8859-3"+iso8859_4	= "ISO-8859-4"+iso8859_5	= "ISO-8859-5"+iso8859_6	= "ISO-8859-6"+iso8859_7	= "ISO-8859-7"+iso8859_8	= "ISO-8859-8"+iso8859_9	= "ISO-8859-9"+iso8859_10	= "ISO-8859-10"+iso8859_11	= "ISO-8859-11"+iso8859_13	= "ISO-8859-13"+iso8859_14	= "ISO-8859-14"+iso8859_15	= "ISO-8859-15"+iso8859_16	= "ISO-8859-16"+usAscii		= "US-ASCII"+ucs2		= "ISO-10646-UCS-2"+utf8		= "UTF-8"+utf16		= "UTF-16"+utf16be		= "UTF-16BE"+utf16le		= "UTF-16LE"+unicodeString	= "UNICODE"++-- ------------------------------------------------------------+--+-- known namespaces++-- |+-- the predefined namespace uri for xml: \"http:\/\/www.w3.org\/XML\/1998\/namespace\"++xmlNamespace	:: String+xmlNamespace	= "http://www.w3.org/XML/1998/namespace"++-- |+-- the predefined namespace uri for xmlns: \"http:\/\/www.w3.org\/2000\/xmlns\/\"++xmlnsNamespace	:: String+xmlnsNamespace	= "http://www.w3.org/2000/xmlns/"++-- | Relax NG namespace+relaxNamespace	:: String+relaxNamespace	= "http://relaxng.org/ns/structure/1.0"++-- ------------------------------------------------------------+-- option for Relax NG++a_relax_schema,+ a_do_not_check_restrictions,  + a_check_restrictions,+ a_do_not_validate_externalRef,+ a_validate_externalRef,+ a_do_not_validate_include,+ a_validate_include,+ a_output_changes, + a_do_not_collect_errors :: String ++a_relax_schema		      = "relax-schema"+a_do_not_check_restrictions   = "do-not-check-restrictions"+a_check_restrictions          = "check-restrictions"+a_do_not_validate_externalRef = "do-not-validate-externalRef"+a_validate_externalRef        = "validate-externalRef" +a_do_not_validate_include     = "do-not-validate-include"+a_validate_include            = "validate-include"+a_output_changes              = "output-pattern-transformations"+a_do_not_collect_errors       = "do-not-collect-errors"++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/DOM/XmlNode.hs view
@@ -0,0 +1,333 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.DOM.XmlNode+   Copyright  : Copyright (C) 2008 Uwe Schmidt+   License    : MIT+++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : stable+   Portability: portable++   Interface for XmlArrow to basic data types NTree and XmlTree++   If this module must be used in code working with arrows,+   it should be imported qualified e.g. @as XN@, to prevent name clashes.++   For code working on the \"node and tree level\" this module+   is the interface for writing code without using the+   constructor functions of 'XNode' and 'NTree' directly++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.DOM.XmlNode+    ( module Yuuko.Text.XML.HXT.DOM.XmlNode+    , module Yuuko.Data.Tree.NTree.TypeDefs+    )+where++import Control.Monad++import Yuuko.Data.Tree.NTree.TypeDefs++import Data.Maybe++import Yuuko.Text.XML.HXT.DOM.Interface++class XmlNode a where+    -- discriminating predicates++    isText		:: a -> Bool+    isCharRef		:: a -> Bool+    isEntityRef		:: a -> Bool+    isCmt		:: a -> Bool+    isCdata		:: a -> Bool+    isPi		:: a -> Bool+    isElem		:: a -> Bool+    isRoot		:: a -> Bool+    isDTD		:: a -> Bool+    isAttr		:: a -> Bool+    isError		:: a -> Bool++    -- constructor functions for leave nodes++    mkText		:: String -> a+    mkCharRef		:: Int    -> a+    mkEntityRef		:: String -> a+    mkCmt		:: String -> a+    mkCdata		:: String -> a+    mkPi		:: QName  -> XmlTrees -> a+    mkError		:: Int    -> String   -> a++    -- selectors++    getText		:: a -> Maybe String+    getCharRef		:: a -> Maybe Int+    getEntityRef	:: a -> Maybe String+    getCmt		:: a -> Maybe String+    getCdata		:: a -> Maybe String+    getPiName		:: a -> Maybe QName+    getPiContent	:: a -> Maybe XmlTrees+    getElemName		:: a -> Maybe QName+    getAttrl		:: a -> Maybe XmlTrees+    getDTDPart		:: a -> Maybe DTDElem+    getDTDAttrl		:: a -> Maybe Attributes+    getAttrName		:: a -> Maybe QName+    getErrorLevel	:: a -> Maybe Int+    getErrorMsg		:: a -> Maybe String++    -- derived selectors++    getName		:: a -> Maybe QName+    getQualifiedName	:: a -> Maybe String+    getUniversalName	:: a -> Maybe String+    getUniversalUri	:: a -> Maybe String+    getLocalPart	:: a -> Maybe String+    getNamePrefix	:: a -> Maybe String+    getNamespaceUri	:: a -> Maybe String++    -- "modifier" functions++    changeText		:: (String   -> String)   -> a -> a+    changeCmt		:: (String   -> String)   -> a -> a+    changeName		:: (QName    -> QName)    -> a -> a+    changeElemName	:: (QName    -> QName)    -> a -> a+    changeAttrl		:: (XmlTrees -> XmlTrees) -> a -> a+    changeAttrName	:: (QName    -> QName)    -> a -> a+    changePiName	:: (QName    -> QName)    -> a -> a+    changeDTDAttrl	:: (Attributes -> Attributes) -> a -> a++    setText		:: String   -> a -> a+    setCmt		:: String   -> a -> a+    setName		:: QName    -> a -> a+    setElemName		:: QName    -> a -> a+    setElemAttrl	:: XmlTrees -> a -> a+    setAttrName		:: QName    -> a -> a+    setPiName		:: QName    -> a -> a+    setDTDAttrl		:: Attributes -> a -> a++    -- default implementations++    getName n		= getElemName n `mplus` getAttrName n `mplus` getPiName n+    getQualifiedName n	= getName n >>= \ n' -> return (qualifiedName n')+    getUniversalName n	= getName n >>= \ n' -> return (universalName n')+    getUniversalUri n	= getName n >>= \ n' -> return (universalUri n')+    getLocalPart n	= getName n >>= \ n' -> return (localPart n')+    getNamePrefix n	= getName n >>= \ n' -> return (namePrefix n')+    getNamespaceUri n	= getName n >>= \ n' -> return (namespaceUri n')++    setText t		= changeText     (const t)+    setCmt c		= changeCmt      (const c)+    setName n		= changeName     (const n)+    setElemName n	= changeElemName (const n)+    setElemAttrl al	= changeAttrl    (const al)+    setAttrName	n	= changeAttrName (const n)+    setPiName	n	= changePiName   (const n)+    setDTDAttrl	al	= changeDTDAttrl (const al)++-- XNode and XmlTree are instances of XmlNode++instance XmlNode XNode where+    isText (XText _)		= True+    isText _			= False++    isCharRef (XCharRef _)	= True+    isCharRef _			= False++    isEntityRef (XEntityRef _)	= True+    isEntityRef _		= False++    isCmt (XCmt _)		= True+    isCmt _			= False++    isCdata (XCdata _)		= True+    isCdata _			= False++    isPi (XPi _ _)		= True+    isPi _			= False++    isElem (XTag _ _)		= True+    isElem _			= False++    isRoot t                    = isElem t+				  &&+				  fromMaybe "" (getQualifiedName t) == t_root++    isDTD (XDTD _ _)		= True+    isDTD _			= False++    isAttr (XAttr _)		= True+    isAttr _			= False++    isError (XError _ _)	= True+    isError _			= False+++    mkText t			= XText t+    mkCharRef c			= XCharRef c+    mkEntityRef e		= XEntityRef e+    mkCmt c			= XCmt c+    mkCdata d			= XCdata d+    mkPi n c			= XPi n (if null c then [] else [mkAttr (mkName a_value) c])+    mkError l msg		= XError l msg+++    getText (XText t)		= Just t+    getText _			= Nothing++    getCharRef (XCharRef c)	= Just c+    getCharRef _		= Nothing++    getEntityRef (XEntityRef e)	= Just e+    getEntityRef _		= Nothing++    getCmt (XCmt c)		= Just c+    getCmt _			= Nothing++    getCdata (XCdata d)		= Just d+    getCdata _			= Nothing++    getPiName (XPi n _)		= Just n+    getPiName _			= Nothing++    getPiContent (XPi _ c)	= Just c+    getPiContent _		= Nothing++    getElemName (XTag n _)	= Just n+    getElemName _		= Nothing++    getAttrl (XTag _ al)	= Just al+    getAttrl (XPi  _ al)	= Just al+    getAttrl _			= Nothing++    getDTDPart (XDTD p _)	= Just p+    getDTDPart _		= Nothing++    getDTDAttrl (XDTD _ al)	= Just al+    getDTDAttrl _		= Nothing++    getAttrName (XAttr n)	= Just n+    getAttrName _		= Nothing++    getErrorLevel (XError l _)	= Just l+    getErrorLevel _		= Nothing++    getErrorMsg (XError _ m)	= Just m+    getErrorMsg _		= Nothing++    changeText cf (XText t)		= XText (cf t)+    changeText _ _			= error "changeText undefined"++    changeCmt cf (XCmt c)		= XCmt (cf c)+    changeCmt _ _			= error "changeCmt undefined"++    changeName cf (XTag n al)		= XTag (cf n) al+    changeName cf (XAttr n)		= XAttr (cf n)+    changeName cf (XPi n al)		= XPi (cf n) al+    changeName _ _			= error "changeName undefined"++    changeElemName cf (XTag n al)	= XTag (cf n) al+    changeElemName _ _			= error "changeElemName undefined"++    changeAttrl cf (XTag n al)		= XTag n (cf al)+    changeAttrl cf (XPi  n al)		= XPi  n (cf al)+    changeAttrl _ _			= error "changeAttrl undefined"++    changeAttrName cf (XAttr n)		= XAttr (cf n)+    changeAttrName _ _			= error "changeAttrName undefined"++    changePiName cf (XPi n al)		= XPi (cf n) al+    changePiName _ _			= error "changeAttrName undefined"++    changeDTDAttrl cf (XDTD p al)	= XDTD p (cf al)+    changeDTDAttrl _ _			= error "changeDTDAttrl undefined"++mkElementNode	:: QName -> XmlTrees -> XNode+mkElementNode	= XTag++mkAttrNode	:: QName -> XNode+mkAttrNode	= XAttr++mkDTDNode	:: DTDElem -> Attributes -> XNode+mkDTDNode	= XDTD++instance XmlNode a => XmlNode (NTree a) where+    isText		= isText      . getNode+    isCharRef		= isCharRef   . getNode+    isEntityRef		= isEntityRef . getNode+    isCmt		= isCmt       . getNode+    isCdata		= isCdata     . getNode+    isPi		= isPi        . getNode+    isElem		= isElem      . getNode+    isRoot		= isRoot      . getNode+    isDTD		= isDTD       . getNode+    isAttr		= isAttr      . getNode+    isError		= isError     . getNode++    mkText		= mkLeaf . mkText+    mkCharRef		= mkLeaf . mkCharRef+    mkEntityRef		= mkLeaf . mkEntityRef+    mkCmt		= mkLeaf . mkCmt+    mkCdata		= mkLeaf . mkCdata+    mkPi n		= mkLeaf . mkPi n+    mkError l		= mkLeaf . mkError l++    getText		= getText       . getNode+    getCharRef		= getCharRef    . getNode+    getEntityRef	= getEntityRef  . getNode+    getCmt		= getCmt        . getNode+    getCdata		= getCdata      . getNode+    getPiName		= getPiName     . getNode+    getPiContent	= getPiContent  . getNode+    getElemName		= getElemName   . getNode+    getAttrl		= getAttrl      . getNode+    getDTDPart		= getDTDPart    . getNode+    getDTDAttrl		= getDTDAttrl   . getNode+    getAttrName		= getAttrName   . getNode+    getErrorLevel	= getErrorLevel . getNode+    getErrorMsg		= getErrorMsg   . getNode++    changeText cf	= changeNode (changeText cf)+    changeCmt cf	= changeNode (changeCmt  cf)+    changeName cf	= changeNode (changeName cf)+    changeElemName cf	= changeNode (changeElemName cf)+    changeAttrl cf	= changeNode (changeAttrl cf)+    changeAttrName cf	= changeNode (changeAttrName cf)+    changePiName cf	= changeNode (changePiName cf)+    changeDTDAttrl cf	= changeNode (changeDTDAttrl cf)++mkElement	:: QName -> XmlTrees -> XmlTrees -> XmlTree+mkElement n al	= mkTree (mkElementNode n al)++mkRoot		:: XmlTrees -> XmlTrees -> XmlTree+mkRoot al	= mkTree (mkElementNode (mkName t_root) al)++mkAttr		:: QName -> XmlTrees -> XmlTree+mkAttr n	= mkTree (mkAttrNode n)++mkDTDElem	:: DTDElem -> Attributes -> XmlTrees -> XmlTree+mkDTDElem e al	= mkTree (mkDTDNode e al)++addAttr		:: XmlTree -> XmlTrees -> XmlTrees+addAttr a al+    | isAttr a	= add al+    | otherwise	= al+    where+    an = (qualifiedName . fromJust . getAttrName) a+    add []+	= [a]+    add (a1:al1)+	| isAttr a1+	  &&+	  (qualifiedName . fromJust . getAttrName) a1 == an+	    = a : al1+	| otherwise+	    = a1 : add al1++mergeAttrl	:: XmlTrees -> XmlTrees -> XmlTrees+mergeAttrl 	= foldr addAttr++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/DOM/XmlOptions.hs view
@@ -0,0 +1,188 @@+-- |+-- Common useful options+--+-- Version : $Id: XmlOptions.hs,v 1.1 2006/11/09 20:27:42 hxml Exp $+--+--++module Yuuko.Text.XML.HXT.DOM.XmlOptions+    ( inputOptions+    , relaxOptions+    , outputOptions+    , generalOptions+    , versionOptions+    , showOptions++    , selectOptions+    , removeOptions+    , optionIsSet+    , isTrueValue+    )+where++import Yuuko.Text.XML.HXT.DOM.XmlKeywords+import Yuuko.Text.XML.HXT.DOM.TypeDefs++import Data.Maybe++import System.Console.GetOpt++-- ------------------------------------------------------------+--++-- |+-- commonly useful options for XML input+--+-- can be used for option definition with haskell getopt+--+-- defines options: 'a_trace', 'a_proxy', 'a_use_curl', 'a_do_not_use_curl', 'a_options_curl', 'a_encoding',+-- 'a_issue_errors', 'a_do_not_issue_errors', 'a_parse_html', 'a_parse_by_mimetype', 'a_tagsoup' 'a_issue_warnings', 'a_do_not_issue_warnings',+-- 'a_parse_xml', 'a_validate', 'a_do_not_validate', 'a_canonicalize', 'a_do_not_canonicalize',+--- 'a_preserve_comment', 'a_do_not_preserve_comment', 'a_check_namespaces', 'a_do_not_check_namespaces',+-- 'a_remove_whitespace', 'a_do_not_remove_whitespace'++inputOptions 	:: [OptDescr (String, String)]+inputOptions+    = [ Option "t"	[a_trace]			(OptArg trc "LEVEL")			"trace level (0-4), default 1"+      , Option "p"	[a_proxy]			(ReqArg (att a_proxy)         "PROXY")	"proxy for http access (e.g. \"www-cache:3128\")"+      , Option ""       [a_redirect]			(NoArg  (att a_redirect          v_1))  "automatically follow redirected URIs"+      , Option ""       [a_no_redirect]			(NoArg  (att a_redirect          v_0))  "switch off following redirected URIs"+      , Option ""	[a_use_curl]			(NoArg  (att a_use_curl          v_1))	"obsolete, since hxt-8.1 HTTP access is always done with curl bindings"+      , Option ""	[a_do_not_use_curl]		(NoArg  (att a_use_curl          v_0))	"obsolete, since hxt-8.1 HTTP access is always done with curl bindings"+      , Option ""	[a_options_curl]		(ReqArg (att a_options_curl)    "STR")	"additional curl options, e.g. for timeout, ..."+      , Option ""	[a_default_baseuri]		(ReqArg (att transferURI) 	"URI")	"default base URI, default: \"file:///<cwd>/\""+      , Option "e"	[a_encoding]			(ReqArg (att a_encoding)    "CHARSET")	( "default document encoding (" ++ utf8 ++ ", " ++ isoLatin1 ++ ", " ++ usAscii ++ ", ...)" )+      , Option ""       [a_mime_types]                  (ReqArg (att a_mime_types)     "FILE")  "set mime type configuration file, e.g. \"/etc/mime.types\""+      , Option ""	[a_issue_errors]		(NoArg	(att a_issue_errors      v_1))	"issue all errorr messages on stderr (default)"+      , Option ""	[a_do_not_issue_errors]		(NoArg	(att a_issue_errors      v_0))	"ignore all error messages"+      , Option ""	[a_ignore_encoding_errors]	(NoArg  (att a_ignore_encoding_errors v_1))   "ignore encoding errors"+      , Option ""	[a_ignore_none_xml_contents]    (NoArg  (att a_ignore_none_xml_contents v_1)) "discards all contents of none XML/HTML documents, only the meta info remains in the doc tree"+      , Option ""	[a_accept_mimetypes]            (ReqArg (att a_accept_mimetypes) "MIMETYPES") "only accept documents matching the given list of mimetype specs"+      , Option "H"	[a_parse_html]			(NoArg	(att a_parse_html        v_1))	"parse input as HTML, try to interprete everything as HTML, no validation"+      , Option "M"	[a_parse_by_mimetype]		(NoArg  (att a_parse_by_mimetype v_1))	"parse dependent on mime type: text/html as HTML, text/xml and text/xhtml and others as XML, else no parse"+      , Option ""	[a_parse_xml]			(NoArg	(att a_parse_html        v_0))	"parse input as XML, (default)"+      , Option ""       [a_strict_input]		(NoArg  (att a_strict_input      v_1))  "read input files strictly, this ensures closing the files correctly even if not read completely"+      , Option "T"	[a_tagsoup]			(NoArg	(att a_tagsoup           v_1))	"lazy tagsoup parser, for HTML and XML, no DTD, no validation, no PIs, only XHTML entityrefs"+      , Option ""	[a_issue_warnings]		(NoArg	(att a_issue_warnings    v_1))	"issue warnings, when parsing HTML (default)"+      , Option "Q"	[a_do_not_issue_warnings]	(NoArg	(att a_issue_warnings    v_0))	"ignore warnings, when parsing HTML"+      , Option ""	[a_validate]			(NoArg  (att a_validate          v_1))	"document validation when parsing XML (default)"+      , Option "w"	[a_do_not_validate]		(NoArg  (att a_validate          v_0))	"only wellformed check, no validation"+      , Option ""	[a_canonicalize]		(NoArg  (att a_canonicalize      v_1))	"canonicalize document, remove DTD, comment, transform CDATA, CharRef's, ... (default)"+      , Option "c"	[a_do_not_canonicalize]		(NoArg  (att a_canonicalize      v_0))	"do not canonicalize document, don't remove DTD, comment, don't transform CDATA, CharRef's, ..."+      , Option "C"	[a_preserve_comment]		(NoArg	(att a_preserve_comment  v_1))	"don't remove comments during canonicalisation"+      , Option ""	[a_do_not_preserve_comment]	(NoArg	(att a_preserve_comment  v_0))	"remove comments during canonicalisation (default)"+      , Option "n"	[a_check_namespaces]		(NoArg  (att a_check_namespaces  v_1))	"tag tree with namespace information and check namespaces"+      , Option ""	[a_do_not_check_namespaces]	(NoArg  (att a_check_namespaces  v_0))	"ignore namespaces (default)"+      , Option "r"	[a_remove_whitespace]		(NoArg  (att a_remove_whitespace v_1))	"remove redundant whitespace, simplifies tree and processing"+      , Option ""	[a_do_not_remove_whitespace]	(NoArg  (att a_remove_whitespace v_0))	"don't remove redundant whitespace (default)"+      ]+    where+    att n v	= (n, v)+    trc = att a_trace . show . max 0 . min 9 . (read :: String -> Int) . ('0':) . filter (`elem` "0123456789") . fromMaybe v_1+++-- | available Relax NG validation options+--+-- defines options+-- 'a_check_restrictions', 'a_validate_externalRef', 'a_validate_include', 'a_do_not_check_restrictions',  +-- 'a_do_not_validate_externalRef', 'a_do_not_validate_include'++relaxOptions :: [OptDescr (String, String)]+relaxOptions    +    = [ Option "X" [a_relax_schema]	        	(ReqArg (att a_relax_schema) "SCHEMA")	"validation with Relax NG, SCHEMA is the URI for the Relax NG schema"+      , Option ""  [a_check_restrictions]	        (NoArg (a_check_restrictions,    v_1))	"check Relax NG schema restrictions during schema simplification (default)"+      , Option ""  [a_do_not_check_restrictions]	(NoArg (a_check_restrictions,    v_0))	"do not check Relax NG schema restrictions"+      , Option ""  [a_validate_externalRef]		(NoArg (a_validate_externalRef,  v_1))	"validate a Relax NG schema referenced by a externalRef-Pattern (default)"+      , Option ""  [a_do_not_validate_externalRef]	(NoArg (a_validate_externalRef,  v_0))	"do not validate a Relax NG schema referenced by an externalRef-Pattern"+      , Option ""  [a_validate_include]			(NoArg (a_validate_include,      v_1))	"validate a Relax NG schema referenced by an include-Pattern (default)"+      , Option ""  [a_do_not_validate_include]		(NoArg (a_validate_include,      v_0))   "do not validate a Relax NG schema referenced by an include-Pattern"+	{-+      , Option ""  [a_output_changes]			(NoArg (a_output_changes,        v_1))	"output Pattern transformations in case of an error"    +      , Option ""  [a_do_not_collect_errors]     	(NoArg (a_do_not_collect_errors, v_1))	"stop Relax NG simplification after the first error has occurred"+	-}+      ]+    where+    att n v	= (n, v)++-- |+-- commonly useful options for XML output+--+-- defines options: 'a_indent', 'a_output_encoding', 'a_output_file', 'a_output_html'++outputOptions 	:: [OptDescr (String, String)]+outputOptions+    = [ Option "i"	[a_indent]		(NoArg  (att a_indent                v_1))	"indent XML output for readability"+      , Option "o"	[a_output_encoding]	(ReqArg (att a_output_encoding) "CHARSET")	( "encoding of output (" ++ utf8 ++ ", " ++ isoLatin1 ++ ", " ++ usAscii ++ ")" )+      , Option "f"	[a_output_file]		(ReqArg (att a_output_file)        "FILE")	"output file for resulting document (default: stdout)"+      , Option ""	[a_output_html]	        (NoArg  (att a_output_html           v_1))	"output of none ASCII chars as HTMl entity references"+      , Option ""       [a_no_xml_pi]	        (NoArg  (att a_no_xml_pi             v_1))      ("output without <?xml ...?> processing instruction, useful in combination with --" ++ show a_output_html)+      , Option ""	[a_output_xhtml]        (NoArg  (att a_output_xhtml          v_1))	"output of HTML elements with empty content (script, ...) done in format <elem...></elem> instead of <elem/>"+      , Option ""       [a_no_empty_elem_for]   (ReqArg (att a_no_empty_elem_for) "NAMES")      "output of empty elements done in format <elem...></elem> only for given list of element names"+      , Option ""       [a_no_empty_elements]   (NoArg  (att a_no_empty_elements     v_1))      "output of empty elements done in format <elem...></elem> instead of <elem/>"+      , Option ""       [a_add_default_dtd]     (NoArg  (att a_add_default_dtd       v_1))      "add the document type declaration given in the input document"+      , Option ""       [a_text_mode]		(NoArg  (att a_text_mode             v_1))	"output in text mode"+      ]+    where+    att n v	= (n, v)++-- |+-- commonly useful options+--+-- defines options: 'a_verbose', 'a_help'++generalOptions 	:: [OptDescr (String, String)]+generalOptions+    = [ Option "v"	[a_verbose]		(NoArg  (a_verbose, v_1))		"verbose output"+      , Option "h?"	[a_help]		(NoArg  (a_help,    v_1))		"this message"+      ]++-- |+-- defines 'a_version' option++versionOptions 	:: [OptDescr (String, String)]+versionOptions+    = [ Option "V"	[a_version]		(NoArg  (a_version, v_1))		"show program version"+      ]++-- |+-- debug output options++showOptions	:: [OptDescr (String, String)]+showOptions+    = [ Option ""	[a_show_tree]		(NoArg  (a_show_tree,    v_1))		"output tree representation instead of document source"+      , Option ""	[a_show_haskell]	(NoArg  (a_show_haskell, v_1))		"output internal Haskell representation instead of document source"+      ]++-- ------------------------------------------------------------++-- |+-- select options from a predefined list of option desciptions++selectOptions	:: [String] -> [OptDescr (String, String)] -> [OptDescr (String, String)]+selectOptions ol os+    = concat . map (\ on -> filter (\ (Option _ ons _ _) -> on `elem` ons) os) $ ol++removeOptions	:: [String] -> [OptDescr (String, String)] -> [OptDescr (String, String)]+removeOptions ol os+    = filter (\ (Option _ ons _ _) -> not . any (`elem` ol) $ ons ) os++-- |+-- check whether an option is set+--+-- reads the value of an attribute, usually applied to a document root node,+-- and checks if the value represents True. The following strings are interpreted+-- as true: \"1\", \"True\", \"true\", \"yes\", \"Yes\".++optionIsSet	:: String -> Attributes -> Bool+optionIsSet n	= isTrueValue . lookupDef "" n++-- | check whether a string represents True+--+-- definition:+--+-- > isTrueValue	= (`elem` ["1", "True", "true", "Yes", "yes"])++isTrueValue	:: String -> Bool+isTrueValue	= (`elem` ["1", "True", "true", "Yes", "yes"])++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/DTDValidation/AttributeValueValidation.hs view
@@ -0,0 +1,342 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.DTDValidation.TypeDefs+   Copyright  : Copyright (C) 2008 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   This module provides functions for validating attributes.++   The main functions are:++    - Check if the attribute value meets the lexical constraints of its type++    - Normalization of an attribute value+-}++-- ------------------------------------------------------------++-- Special namings in source code:+--+--  - nd - XDTD node+--+--  - n  - XTag node+--++module Yuuko.Text.XML.HXT.DTDValidation.AttributeValueValidation+    ( checkAttributeValue+    , normalizeAttributeValue+    )+where++import Yuuko.Text.XML.HXT.Parser.XmlParsec+    ( parseNMToken+    , parseName+    )++import Yuuko.Text.XML.HXT.DTDValidation.TypeDefs++-- ------------------------------------------------------------++-- |+-- Checks if the attribute value meets the lexical constraints of its type.+--+--    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node+--+--    - 2.parameter attrDecl :  the declaration of the attribute from the DTD+--+--    - returns : a function which takes an element (XTag or XDTD ATTLIST),+--                    checks if the attribute value meets the lexical constraints+--                    of its type and returns a list of errors++checkAttributeValue :: XmlTrees -> XmlTree -> XmlArrow+checkAttributeValue dtdPart attrDecl+    | isDTDAttlistNode attrDecl+	= choiceA+	  [ isElem       :-> ( checkAttrVal $< getAttrValue attrName )+	  , isDTDAttlist :-> ( checkAttrVal $< (getDTDAttrl >>^ dtd_default) )+	  , this	     :-> none+	  ]+    | otherwise+	= none+      where+      al	= getDTDAttributes attrDecl+      attrName	= dtd_value al+      attrType  = dtd_type  al+      checkAttrVal attrValue+	  = checkValue attrType dtdPart normalizedVal attrDecl+	    where+	    normalizedVal = normalizeAttributeValue (Just attrDecl) attrValue++-- |+-- Dispatches the attibute check by the attribute type.+--+--    * 1.parameter typ :  the attribute type+--+--    - 2.parameter dtdPart :  the children of the @DOCTYPE@ node+--+--    - 3.parameter attrValue :  the normalized attribute value to be checked+--+--    - 4.parameter attrDecl :  the declaration of the attribute from the DTD+--+--    - returns : a functions which takes an element (XTag or XDTD ATTLIST),+--                        checks if the attribute value meets the lexical constraints+--                        of its type and returns a list of errors++checkValue :: String -> XmlTrees -> String -> XmlTree -> XmlArrow+checkValue typ dtdPart attrValue attrDecl+	| typ == k_cdata	= none+	| typ == k_enumeration	= checkValueEnumeration attrDecl attrValue+	| typ == k_entity	= checkValueEntity dtdPart attrDecl attrValue+	| typ == k_entities	= checkValueEntities dtdPart attrDecl attrValue+	| typ == k_id		= checkValueId attrDecl attrValue+	| typ == k_idref	= checkValueIdref attrDecl attrValue+	| typ == k_idrefs	= checkValueIdrefs attrDecl attrValue+	| typ == k_nmtoken	= checkValueNmtoken attrDecl attrValue+	| typ == k_nmtokens	= checkValueNmtokens attrDecl attrValue+	| typ == k_notation	= checkValueEnumeration attrDecl attrValue+	| otherwise		= error ("Attribute type " ++ show typ ++ " unknown.")++-- |+-- Checks the value of Enumeration attribute types. (3.3.1 \/ p.27 in Spec)+--+--    * 1.parameter attrDecl :  the declaration of the attribute from the DTD+--+--    - 2.parameter attrValue :  the normalized attribute value to be checked++checkValueEnumeration :: XmlTree -> String -> XmlArrow+checkValueEnumeration attrDecl attrValue+    | isDTDAttlistNode attrDecl+      &&+      attrValue `notElem` enumVals+	= err ( "Attribute " ++ show (dtd_value al) ++ " for element " ++ show (dtd_name al) +++                " must have a value from list "++ show enumVals {- ++ " but has value " ++ show attrValue-} ++ ".")+    | otherwise+	= none+      where+      al	= getDTDAttributes attrDecl++      enumVals :: [String]+      enumVals = map (dtd_name . getDTDAttributes) $ (runLA getChildren attrDecl)++-- |+-- Checks the value of ENTITY attribute types. (3.3.1 \/ p.26 in Spec)+--+--    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node, to get the+--                    unparsed entity declarations+--+--    - 2.parameter attrDecl :  the declaration of the attribute from the DTD+--+--    - 3.parameter attrValue :  the normalized attribute value to be checked++checkValueEntity :: XmlTrees -> XmlTree -> String -> XmlArrow+checkValueEntity dtdPart attrDecl attrValue+    | isDTDAttlistNode attrDecl+      &&+      attrValue `notElem` upEntities+	= err ( "Entity " ++ show attrValue ++ " of attribute " ++ show (dtd_value al) +++                " for element " ++ show (dtd_name al) ++ " is not unparsed. " +++                "The following unparsed entities exist: " ++ show upEntities ++ ".")+    | otherwise+	= none+      where+      al	= getDTDAttributes attrDecl++      upEntities :: [String]+      upEntities = map (dtd_name . getDTDAttributes) (isUnparsedEntity $$ dtdPart)++-- |+-- Checks the value of ENTITIES attribute types. (3.3.1 \/ p.26 in Spec)+--+--    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node, to get the+--                    unparsed entity declarations+--+--    - 2.parameter attrDecl :  the declaration of the attribute from the DTD+--+--    - 3.parameter attrValue :  the normalized attribute value to be checked++checkValueEntities ::XmlTrees -> XmlTree -> String -> XmlArrow+checkValueEntities dtdPart attrDecl attrValue+    | isDTDAttlistNode attrDecl+	= if null valueList+	  then err ("Attribute " ++ show (dtd_value al) ++ " of element " +++                    show (dtd_name al) ++ " must be one or more names.")+          else catA . map (checkValueEntity dtdPart attrDecl) $ valueList+    | otherwise+	= none+      where+      al	= getDTDAttributes attrDecl+      valueList = words attrValue++-- |+-- Checks the value of NMTOKEN attribute types. (3.3.1 \/ p.26 in Spec)+--+--    * 1.parameter attrDecl :  the declaration of the attribute from the DTD+--+--    - 2.parameter attrValue :  the normalized attribute value to be checked++checkValueNmtoken :: XmlTree -> String -> XmlArrow+checkValueNmtoken attrDecl attrValue+    | isDTDAttlistNode attrDecl+	= constA attrValue >>> checkNmtoken+    | otherwise+	= none+      where+      al	= getDTDAttributes attrDecl+      checkNmtoken+	  = mkText >>> arrL (parseNMToken "")+	    >>>+	    isError+	    >>>+	    getErrorMsg+	    >>>+	    arr (\ s -> ( "Attribute value " ++ show attrValue ++ " of attribute " ++ show (dtd_value al) +++			  " for element " ++ show (dtd_name al) ++ " must be a name token, "++ (lines s) !! 1 ++".") )+            >>>+	    mkError c_err++-- |+-- Checks the value of NMTOKENS attribute types. (3.3.1 \/ p.26 in Spec)+--+--    * 1.parameter attrDecl :  the declaration of the attribute from the DTD+--+--    - 2.parameter attrValue :  the normalized attribute value to be checked++checkValueNmtokens :: XmlTree -> String -> XmlArrow+checkValueNmtokens attrDecl attrValue+    | isDTDAttlistNode attrDecl+	= if null valueList+	  then err ( "Attribute "++ show (dtd_value al) ++" of element " +++                     show (dtd_name al) ++ " must be one or more name tokens.")+          else catA . map (checkValueNmtoken attrDecl) $ valueList+    | otherwise+	= none+      where+      al	= getDTDAttributes attrDecl+      valueList = words attrValue++-- |+-- Checks the value of ID attribute types. (3.3.1 \/ p.25 in Spec)+--+--    * 1.parameter attrDecl :  the declaration of the attribute from the DTD+--+--    - 2.parameter attrValue :  the normalized attribute value to be checked++checkValueId :: XmlTree -> String -> XmlArrow+checkValueId attrDecl attrValue+    = checkForName "Attribute value" attrDecl attrValue+++-- |+-- Checks the value of IDREF attribute types. (3.3.1 \/ p.26 in Spec)+--+--    * 1.parameter attrDecl :  the declaration of the attribute from the DTD+--+--    - 2.parameter attrValue :  the normalized attribute value to be checked++checkValueIdref :: XmlTree -> String -> XmlArrow+checkValueIdref attrDecl attrValue+    = checkForName "Attribute value" attrDecl attrValue+++-- |+-- Checks the value of IDREFS attribute types. (3.3.1 \/ p.26 in Spec)+--+--    * 1.parameter attrDecl :  the declaration of the attribute from the DTD+--+--    - 2.parameter attrValue :  the normalized attribute value to be checked++checkValueIdrefs :: XmlTree -> String -> XmlArrow+checkValueIdrefs attrDecl attrValue+    = catA . map (checkValueIdref attrDecl) . words $ attrValue++++-- -----------------------------------------------------------------------------+-- General helper functions for checking attribute values+--++-- |+-- Checks if the value of an attribute is a name.+--+--    * 1.parameter msg :  error message, should be "Entity" or "Attribute value"+--+--    - 2.parameter attrDecl :  the declaration of the attribute from the DTD+--+--    - 3.parameter attrValue :  the normalized attribute value to be checked++checkForName ::  String -> XmlTree -> String -> XmlArrow+checkForName msg attrDecl attrValue+    | isDTDAttlistNode attrDecl+	= constA attrValue >>> checkName+    | otherwise+	= none+    where+    al	= getDTDAttributes attrDecl+    checkName+	= mkText >>> arrL (parseName "")+	  >>>+	  isError+	  >>>+	  getErrorMsg+	  >>>+	  arr (\s -> ( msg ++ " " ++ show attrValue ++" of attribute " ++ show (dtd_value al) +++		       " for element "++ show (dtd_name al) ++" must be a name, " ++ (lines s) !! 1 ++ ".") )+          >>>+	  mkError c_err++-- -----------------------------------------------------------------------------++-- |+-- Normalizes an attribute value with respect to its type. (3.3.3 \/ p.29 in Spec)+--+--    * 1.parameter attrDecl :  the declaration of the attribute from the DTD. Expected+--                   is a list. If the list is empty, no declaration exists.+--+--    - 2.parameter value :  the attribute value to be normalized+--+--    - returns : the normalized value+--+normalizeAttributeValue :: Maybe XmlTree -> String -> String+normalizeAttributeValue (Just attrDecl) value+    = normalizeAttribute attrType+      where+      al	     = getDTDAttributes attrDecl+      attrType = dtd_type al++      normalizeAttribute :: String -> String+      normalizeAttribute typ+          | typ == k_cdata	= cdataNormalization value+          | otherwise		= otherNormalization value++-- Attribute not declared in DTD, normalization as CDATA+normalizeAttributeValue Nothing value+    = cdataNormalization value++-- ------------------------------------------------------------+-- Helper functions for normalization++-- |+-- Normalization of CDATA attribute values.+-- is already done when parsing+-- during entity substituion for attribute values++cdataNormalization :: String -> String+cdataNormalization = id++-- | Normalization of attribute values other than CDATA.++otherNormalization :: String -> String+otherNormalization = reduceWSSequences . stringTrim . cdataNormalization++-- | Reduce whitespace sequences to a single whitespace.++reduceWSSequences :: String -> String+reduceWSSequences str = unwords (words str)++-- ------------------------------------------------------------+
+ src/Yuuko/Text/XML/HXT/DTDValidation/DTDValidation.hs view
@@ -0,0 +1,590 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.DTDValidation.TypeDefs+   Copyright  : Copyright (C) 2008 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   This module provides functions for validating the DTD of XML documents+   represented as XmlTree.++   Unlike other popular XML validation tools the validation process returns+   a list of errors instead of aborting after the first error was found.+++   Unlike validation of the document, the DTD branch is traversed four times:++    - Validation of Notations++    - Validation of Unparsed Entities++    - Validation of Element declarations++    - Validation of Attribute declarations++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.DTDValidation.DTDValidation+    ( removeDoublicateDefs+    , validateDTD+    )+where++import Yuuko.Text.XML.HXT.DTDValidation.TypeDefs+import Yuuko.Text.XML.HXT.DTDValidation.AttributeValueValidation++-- |+-- Validate a DTD.+--+--    - returns : a functions which takes the DTD subset of the XmlTree, checks+--                  if the DTD is valid and returns a list of errors++validateDTD :: XmlArrow+validateDTD -- dtdPart+    = isDTDDoctype+      `guards`+      ( listA getChildren+	>>>+	( validateParts $<< (getNotationNames &&& getElemNames) )+      )+    where+    validateParts notationNames elemNames+	= validateNotations+	  <+>+	  validateEntities notationNames+          <+>+	  validateElements elemNames+	  <+>+	  validateAttributes elemNames notationNames++    getNotationNames	:: LA [XmlTree] [String]+    getNotationNames	= listA $ unlistA >>> isDTDNotation >>> getDTDAttrValue a_name++    getElemNames	:: LA [XmlTree] [String]+    getElemNames	= listA $ unlistA >>> isDTDElement  >>> getDTDAttrValue a_name++-- ------------------------------------------------------------++checkName	:: String -> SLA [String] XmlTree XmlTree -> SLA [String] XmlTree XmlTree+checkName name msg+    = ifA ( getState+	    >>>+	    isA (name `elem`)+	  )+      msg+      (nextState (name:) >>> none)++-- ------------------------------------------------------------++-- |+-- Validation of Notations, checks if all notation names are unique.+-- Validity constraint: Unique Notation Name (4.7 \/ p.44 in Spec)+--+--    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node+--+--    - returns : a list of errors++validateNotations :: LA XmlTrees XmlTree+validateNotations+    = fromSLA [] ( unlistA+		   >>>+		   isDTDNotation+		   >>>+		   (checkForUniqueNotation $< getDTDAttrl)+		 )+      where+      checkForUniqueNotation :: Attributes -> SLA [String] XmlTree XmlTree+      checkForUniqueNotation al+	  = checkName name $+	    err ( "Notation "++ show name ++ " was already specified." )+	  where+	  name = dtd_name al++-- |+-- Validation of Entities.+--+-- 1. Issues a warning if entities are declared multiple times.+--+--    Optional warning: (4.2 \/ p.35 in Spec) +--+--+-- 2. Validates that a notation is declared for an unparsed entity.+--+--    Validity constraint: Notation Declared (4.2.2 \/ p.36 in Spec)+--+--    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node+--+--    - 2.parameter notationNames :  list of all notation names declared in the DTD+--+--    - returns : a list of errors++validateEntities	:: [String] -> LA XmlTrees XmlTree+validateEntities notationNames+    = ( fromSLA [] ( unlistA+		     >>>+		     isDTDEntity+		     >>>+		     (checkForUniqueEntity $< getDTDAttrl)+		   )+      )+      <+>+      ( unlistA+	>>>+	isUnparsedEntity+	>>>+	(checkNotationDecl $< getDTDAttrl)+      )+      where++      -- Check if entities are declared multiple times++      checkForUniqueEntity	:: Attributes -> SLA [String] XmlTree XmlTree+      checkForUniqueEntity al+	  = checkName name $+	    warn ( "Entity "++ show name ++ " was already specified. " +++		    "First declaration will be used." )+	  where+	  name = dtd_name al++      -- Find unparsed entities for which no notation is specified++      checkNotationDecl		:: Attributes -> XmlArrow+      checkNotationDecl al+	  | notationName `elem` notationNames+	      = none+	  | otherwise+	      = err ( "The notation " ++ show notationName ++ " must be declared " +++	              "when referenced in the unparsed entity declaration for " +++		      show upEntityName ++ "."+		    )+	  where+	  notationName = lookup1 k_ndata al+	  upEntityName = dtd_name  al++-- |+-- Validation of Element declarations.+--+-- 1. Validates that an element is not declared multiple times.+--+--    Validity constraint: Unique Element Type Declaration (3.2 \/ p.21 in Spec) +--+--+-- 2. Validates that an element name only appears once in a mixed-content declaration.+--+--    Validity constraint: No Duplicate Types (3.2 \/ p.21 in Spec) +--+--+-- 3. Issues a warning if an element mentioned in a content model is not declared in the+--    DTD.+--+--    Optional warning: (3.2 \/ p.21 in Spec)+--+--    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node+--+--    - 2.parameter elemNames :  list of all element names declared in the DTD+--+--    - returns : a list of errors+++validateElements	:: [String] -> LA XmlTrees XmlTree+validateElements elemNames -- dtdPart+    = ( fromSLA [] ( unlistA+		     >>>+		     isDTDElement+		     >>>+		     (checkForUniqueElement $< getDTDAttrl)+		   )+      )+      <+>+      ( unlistA+	>>>+	isMixedContentElement+	>>>+	(checkMixedContent $< getDTDAttrl)+      )+      <+>+      ( unlistA+	>>>+	isDTDElement+	>>>+	(checkContentModel elemNames $< getDTDAttrl)+      )+      where++      -- Validates that an element is not declared multiple times++      checkForUniqueElement :: Attributes -> SLA [String] XmlTree XmlTree+      checkForUniqueElement al+	  = checkName name $+	    err ( "Element type " ++ show name +++		  " must not be declared more than once." )+	  where+	  name = dtd_name al++      -- Validates that an element name only appears once in a mixed-content declaration++      checkMixedContent	:: Attributes -> XmlArrow+      checkMixedContent al+	  = fromSLA [] ( getChildren+			 >>>+			 getChildren+			 >>>+			 isDTDName+			 >>>+			 (check $< getDTDAttrl)+		       )+	    where+	    elemName = dtd_name al+	    check al'+		= checkName name $+		  err ( "The element type " ++ show name +++			 " was already specified in the mixed-content model of the element declaration " +++		         show elemName ++ "." )+		where+		name = dtd_name al'++      -- Issues a warning if an element mentioned in a content model is not+      -- declared in the DTD.+      checkContentModel :: [String] -> Attributes -> XmlArrow+      checkContentModel names al+	  | cm `elem` [v_children, v_mixed]+	      = getChildren >>> checkContent+	  | otherwise+	      = none+	  where+	  elemName = dtd_name al+	  cm       = dtd_type al++	  checkContent :: XmlArrow+	  checkContent+	      = choiceA+		[ isDTDName    :-> ( checkName' $< getDTDAttrl )+		, isDTDContent :-> ( getChildren >>> checkContent )+		, this         :-> none+		]+	      where+	      checkName' al'+		  | childElemName `elem` names+		      = none+		  | otherwise+		      = warn ( "The element type "++ show childElemName +++			       ", used in content model of element "++ show elemName +++			       ", is not declared."+			     )+		  where+		  childElemName = dtd_name al'++-- |+-- Validation of Attribute declarations.+--+-- (1) Issues a warning if an attribute is declared for an element type not itself+--    decared.+--+--    Optinal warning: (3.3 \/ p. 24 in Spec)+--+--+-- 2. Issues a warning if more than one definition is provided for the same+--    attribute of a given element type. Fist declaration is binding, later+--    definitions are ignored.+--+--    Optional warning: (3.3 \/ p.24 in Spec)+--+--+-- 3. Issues a warning if the same Nmtoken occures more than once in enumerated+--    attribute types of a single element type.+--+--    Optional warning: (3.3.1 \/ p.27 in Spec) +--+--+-- 4. Validates that an element type has not more than one ID attribute defined.+--+--    Validity constraint: One ID per Element Type (3.3.1 \/ p.26 in Spec) +--+--+-- 5. Validates that an element type has not more than one NOTATION attribute defined.+--+--    Validity constraint: One Notation per Element Type (3.3.1 \/ p.27 in Spec) +--+--+-- 6. Validates that an ID attributes has the type #IMPLIED or #REQUIRED.+--+--    Validity constraint: ID Attribute Default (3.3.1 \/ p.26 in Spec) +--+--+-- 7. Validates that all referenced notations are declared.+--+--    Validity constraint: Notation Attributes (3.3.1 \/ p.27 in Spec) +--+--+-- 8. Validates that notations are not declared for EMPTY elements.+--+--    Validity constraint: No Notation on Empty Element (3.3.1 \/p.27 in Spec) +--+--+-- 9. Validates that the default value matches the lexical constraints of it's type.+--+--    Validity constraint: Attribute default legal (3.3.2 \/ p.28 in Spec)+--+--+--    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node+--+--    - 2.parameter elemNames :  list of all element names declared in the DTD+--+--    - 3.parameter notationNames :  list of all notation names declared in the DTD+--+--    - returns : a list of errors++validateAttributes :: [String] -> [String] -> LA XmlTrees XmlTree+validateAttributes elemNames notationNames+    = -- 1. Find attributes for which no elements are declared+      ( runCheck this (checkDeclaredElements elemNames) )+      <+>+      -- 2. Find attributes which are declared more than once+      ( runNameCheck this checkForUniqueAttributeDeclaration )+      <+>+      -- 3. Find enumerated attribute types which nmtokens are declared more than once+      ( runCheck (isEnumAttrType `orElse` isNotationAttrType) checkEnumeratedTypes )+      <+>+      -- 4. Validate that there exists only one ID attribute for an element+      ( runNameCheck isIdAttrType checkForUniqueId )+      <+>+      -- 5. Validate that there exists only one NOTATION attribute for an element+      ( runNameCheck isNotationAttrType checkForUniqueNotation )+      <+>+      -- 6. Validate that ID attributes have the type #IMPLIED or #REQUIRED+      ( runCheck isIdAttrType checkIdKindConstraint )+      <+>+      -- 7. Validate that all referenced notations are declared+      ( runCheck isNotationAttrType (checkNotationDeclaration notationNames) )+      <+>+      -- 8. Validate that notations are not declared for EMPTY elements+      ( checkNoNotationForEmptyElements $< listA ( unlistA+						   >>>+						   isEmptyElement+						   >>>+						   getDTDAttrValue a_name+						 )+      )+      <+>+      -- 9. Validate that the default value matches the lexical constraints of it's type+      ( checkDefaultValueTypes $< this )++      where+      -- ------------------------------------------------------------+      -- control structures++      runCheck select check+	  = unlistA >>> isDTDAttlist+	    >>>+	    select+	    >>>+	    (check $< getDTDAttrl)+      +      runNameCheck select check+	  = fromSLA [] $ runCheck select check++      --------------------------------------------------------------------------++      -- 1. Find attributes for which no elements are declared++      checkDeclaredElements :: [String] -> Attributes -> XmlArrow+      checkDeclaredElements elemNames' al+	  | en `elem` elemNames'+	      = none+	  | otherwise+	      = warn ( "The element type \""++ en ++ "\" used in dclaration "+++		       "of attribute \""++ an ++"\" is not declared."+		     )+	  where+	  en = dtd_name al+	  an = dtd_value al++      --------------------------------------------------------------------------++      -- 2. Find attributes which are declared more than once++      checkForUniqueAttributeDeclaration ::  Attributes -> SLA [String] XmlTree XmlTree+      checkForUniqueAttributeDeclaration al+	  = checkName name $+	    warn ( "Attribute \""++ aname ++"\" for element type \""+++		   ename ++"\" is already declared. First "+++		   "declaration will be used." )+	  where+	  ename = dtd_name al+	  aname = dtd_value al+	  name  = ename ++ "|" ++ aname++      --------------------------------------------------------------------------++      -- 3. Find enumerated attribute types which nmtokens are declared more than once++      checkEnumeratedTypes :: Attributes -> XmlArrow+      checkEnumeratedTypes al+          = fromSLA [] ( getChildren+			 >>>+			 isDTDName+			 >>>+			 (checkForUniqueType $< getDTDAttrl)+		       )+	  where+	  checkForUniqueType :: Attributes -> SLA [String] XmlTree XmlTree+          checkForUniqueType al'+	      = checkName nmtoken $+	        warn ( "Nmtoken \""++ nmtoken ++"\" should not "+++		       "occur more than once in attribute \""++ dtd_value al +++		       "\" for element \""++ dtd_name al ++ "\"." )+	      where+	      nmtoken = dtd_name al'++      --------------------------------------------------------------------------++      -- 4. Validate that there exists only one ID attribute for an element++      checkForUniqueId :: Attributes -> SLA [String] XmlTree XmlTree+      checkForUniqueId al+	  = checkName ename $+	    err ( "Element \""++ ename ++ "\" already has attribute of type "+++		  "ID, another attribute \""++ dtd_value al ++ "\" of type ID is "+++		  "not permitted." )+	  where+	  ename = dtd_name al++      --------------------------------------------------------------------------++      -- 5. Validate that there exists only one NOTATION attribute for an element++      checkForUniqueNotation :: Attributes -> SLA [String] XmlTree XmlTree+      checkForUniqueNotation al+	  = checkName ename $+	    err ( "Element \""++ ename ++ "\" already has attribute of type "+++		  "NOTATION, another attribute \""++ dtd_value al ++ "\" of type NOTATION "+++		  "is not permitted." )+	  where+	  ename = dtd_name al++      --------------------------------------------------------------------------++      -- 6. Validate that ID attributes have the type #IMPLIED or #REQUIRED++      checkIdKindConstraint :: Attributes -> XmlArrow+      checkIdKindConstraint al+	  | attKind `elem` [k_implied, k_required]+	      = none+	  | otherwise+	      = err ( "ID attribute \""++ dtd_value al ++"\" must have a declared default "+++	              "of \"#IMPLIED\" or \"REQUIRED\"")+	  where+	  attKind = dtd_kind al+++      --------------------------------------------------------------------------++      -- 7. Validate that all referenced notations are declared++      checkNotationDeclaration :: [String] -> Attributes -> XmlArrow+      checkNotationDeclaration notations al+          = getChildren+	    >>>+	    isDTDName+	    >>>+	    (checkNotations $< getDTDAttrl)+	  where+	  checkNotations :: Attributes -> XmlArrow+	  checkNotations al'+	      | notation `elem` notations+		  = none+	      | otherwise+		  = err ( "The notation \""++ notation ++"\" must be declared when "+++		          "referenced in the notation type list for attribute \""++ dtd_value al +++			  "\" of element \""++ dtd_name al ++"\"."+			)+              where+	      notation = dtd_name al'++      --------------------------------------------------------------------------++      -- 8. Validate that notations are not declared for EMPTY elements++      checkNoNotationForEmptyElements :: [String] -> LA XmlTrees XmlTree+      checkNoNotationForEmptyElements emptyElems+	  = unlistA+	    >>>+	    isDTDAttlist+	    >>>+	    isNotationAttrType+	    >>>+	    (checkNoNotationForEmptyElement $< getDTDAttrl)+	  where+	  checkNoNotationForEmptyElement :: Attributes -> XmlArrow+	  checkNoNotationForEmptyElement al+	      | ename `elem` emptyElems+		  = err ( "Attribute \""++ dtd_value al ++"\" of type NOTATION must not be "+++			  "declared on the element \""++ ename ++"\" declared EMPTY."+			)+              | otherwise+		  = none+	      where+	      ename = dtd_name al++      --------------------------------------------------------------------------++      -- 9. Validate that default values meet the lexical constraints of the attribute types++      checkDefaultValueTypes :: XmlTrees -> LA XmlTrees XmlTree+      checkDefaultValueTypes dtdPart'+	  = unlistA >>> isDTDAttlist+	    >>>+	    isDefaultAttrKind+	    >>>+            (checkAttributeValue dtdPart' $< this)++-- ------------------------------------------------------------++-- |+-- Removes doublicate declarations from the DTD, which first declaration is+-- binding. This is the case for ATTLIST and ENTITY declarations.+--+--    - returns : A function that replaces the children of DOCTYPE nodes by a list+--               where all multiple declarations are removed.++removeDoublicateDefs :: XmlArrow+removeDoublicateDefs+    = replaceChildren+      ( fromSLA [] ( getChildren+		     >>>+		     choiceA [ isDTDAttlist :-> (removeDoubleAttlist $< getDTDAttrl)+			     , isDTDEntity  :-> (removeDoubleEntity  $< getDTDAttrl)+			     , this         :-> this+			     ]+		   )+      )+      `when`+      isDTDDoctype+    where+    checkName' n'+	= ifA ( getState+		>>>+		isA (n' `elem`)+	      )+	  none+	  (this >>> perform (nextState (n':)))++    removeDoubleAttlist :: Attributes -> SLA [String] XmlTree XmlTree+    removeDoubleAttlist al+	= checkName' elemAttr+	where+	elemAttr = elemName ++ "|" ++ attrName+	attrName = dtd_value al+	elemName = dtd_name al++    removeDoubleEntity	:: Attributes -> SLA [String] XmlTree XmlTree+    removeDoubleEntity al+        = checkName' (dtd_name al)++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/DTDValidation/DocTransformation.hs view
@@ -0,0 +1,210 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.DTDValidation.DocTransformation+   Copyright  : Copyright (C) 2008 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   This module provides functions for transforming XML documents represented as+   XmlTree with respect to its DTD.++   Transforming an XML document with respect to its DTD means:++    - add all attributes with default values++    - normalize all attribute values++    - sort all attributes in lexical order++   Note: Transformation should be started after validation.++   Before the document is validated, a lookup-table is build on the basis of+   the DTD which maps element names to their transformation functions.+   After this initialization phase the whole document is traversed in preorder+   and every element is transformed by the XmlFilter from the lookup-table.++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.DTDValidation.DocTransformation+    ( transform+    )+where++import Yuuko.Text.XML.HXT.DTDValidation.TypeDefs+import Yuuko.Text.XML.HXT.DTDValidation.AttributeValueValidation++import Data.Maybe+import Data.List+import Data.Ord++-- ------------------------------------------------------------++-- |+-- Lookup-table which maps element names to their transformation functions. The+-- transformation functions are XmlArrows.++type TransEnvTable	= [TransEnv]+type TransEnv 		= (ElemName, TransFct)+type ElemName		= String+type TransFct		= XmlArrow+++-- ------------------------------------------------------------++-- |+-- filter for transforming the document.+--+--    * 1.parameter dtdPart :  the DTD subset (Node @DOCTYPE@) of the XmlTree+--+--    - 2.parameter doc :  the document subset of the XmlTree+--+--    - returns : a list of errors++transform :: XmlTree -> XmlArrow+transform dtdPart+    = traverseTree transTable+    where+    transTable = buildAllTransformationFunctions (runLA getChildren dtdPart)++-- |+-- Traverse the XmlTree in preorder.+--+--    * 1.parameter transEnv :  lookup-table which maps element names to their transformation functions+--+--    - returns : the whole transformed document++traverseTree :: TransEnvTable -> XmlArrow+traverseTree transEnv+    = processTopDown+      ( ( (transFct $< getName)+	  >>>+	  processChildren (traverseTree transEnv)+	)+       `when`+       isElem+      )+    where+    transFct		:: String -> XmlArrow+    transFct name	= fromMaybe this . lookup name $ transEnv++-- |+-- Build all transformation functions.+--+--    * 1.parameter dtdPart :  the DTD subset, root node should be of type @DOCTYPE@+--+--    - returns : lookup-table which maps element names to their transformation functions++buildAllTransformationFunctions :: XmlTrees -> TransEnvTable+buildAllTransformationFunctions dtdNodes+    = (t_root, this)+      :+      concatMap (buildTransformationFunctions dtdNodes) dtdNodes++-- |+-- Build transformation functions for an element.+--+--    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node+--+--    * 1.parameter nd :  element declaration for which the transformation functions are+--                    created+--+--    - returns : entry for the lookup-table++buildTransformationFunctions :: XmlTrees -> XmlTree -> [TransEnv]++buildTransformationFunctions dtdPart dn+    | isDTDElementNode dn	= [(name, transFct)]+    | otherwise			= []+    where+    al		= getDTDAttributes dn+    name	= dtd_name al+    transFct	= setDefaultAttributeValues dtdPart dn+		  >>>+		  normalizeAttributeValues dtdPart dn+		  >>>+		  lexicographicAttributeOrder++-- ------------------------------------------------------------++-- |+-- Sort the attributes of an element in lexicographic order.+--+--    * returns : a function which takes an element (XTag), sorts its+--                  attributes in lexicographic order and returns the changed element++lexicographicAttributeOrder :: XmlArrow+lexicographicAttributeOrder+    = setAttrl (getAttrl >>. sortAttrl)+      where+      sortAttrl		:: XmlTrees -> XmlTrees+      sortAttrl		= sortBy (comparing nameOfAttr)++-- |+-- Normalize attribute values.+--+--    * returns : a function which takes an element (XTag), normalizes its+--                  attribute values and returns the changed element++normalizeAttributeValues :: XmlTrees -> XmlTree -> XmlArrow+normalizeAttributeValues dtdPart dn+    | isDTDElementNode dn	= processAttrl (normalizeAttr $< getName)+    | otherwise			= this+    where+    al		 = getDTDAttributes dn+    elemName	 = dtd_name al+    declaredAtts = isAttlistOfElement elemName $$ dtdPart++    normalizeAttr :: String -> XmlArrow+    normalizeAttr nameOfAtt+	= normalizeAttrValue ( if null attDescr+			       then Nothing+			       else Just (head attDescr)+			     )+	  where+	  attDescr = filter ((== nameOfAtt) . valueOfDTD a_value) declaredAtts++    normalizeAttrValue :: Maybe XmlTree -> XmlArrow+    normalizeAttrValue descr+	= replaceChildren ((xshow getChildren >>^ normalizeAttributeValue descr) >>> mkText)++-- |+-- Set default attribute values if they are not set.+--+--    * returns : a function which takes an element (XTag), adds missing attribute+--                  defaults and returns the changed element++setDefaultAttributeValues :: XmlTrees -> XmlTree -> XmlArrow+setDefaultAttributeValues dtdPart dn+    | isDTDElementNode dn	= seqA (map setDefault defaultAtts)+    | otherwise			= this+    where+    elemName	= dtd_name . getDTDAttributes $ dn+    defaultAtts	= ( isAttlistOfElement elemName+		    >>>+		    ( isFixedAttrKind		-- select attributes with default values+		      `orElse`+		      isDefaultAttrKind+		    )+		  ) $$ dtdPart++    setDefault	:: XmlTree -> XmlArrow+    setDefault attrDescr			-- add the default attributes+	  = ( addAttr attName defaultValue	-- to tag nodes with missing attributes+	      `whenNot`+	      hasAttr attName+	    )+	    `when`+	    isElem+	where+	al		= getDTDAttributes attrDescr+	attName		= dtd_value   al+	defaultValue	= dtd_default al++-- ------------------------------------------------------------+
+ src/Yuuko/Text/XML/HXT/DTDValidation/DocValidation.hs view
@@ -0,0 +1,521 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.DTDValidation.TypeDefs+   Copyright  : Copyright (C) 2008 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   This module provides functions for validating XML Documents represented as+   XmlTree.++   Unlike other popular XML validation tools the validation process returns+   a list of errors instead of aborting after the first error was found.++   Before the document is validated, a lookup-table is build on the basis of+   the DTD which maps element names to their validation functions.+   After this initialization phase the whole document is traversed in preorder+   and every element is validated by the XmlFilter from the lookup-table.++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.DTDValidation.DocValidation+    ( validateDoc+    )+where++import Yuuko.Text.XML.HXT.DTDValidation.TypeDefs++import Yuuko.Text.XML.HXT.DTDValidation.AttributeValueValidation+import Yuuko.Text.XML.HXT.DTDValidation.XmlRE++-- ------------------------------------------------------------++-- |+-- Lookup-table which maps element names to their validation functions. The+-- validation functions are XmlArrows.++type ValiEnvTable	= [ValiEnv]+type ValiEnv 		= (ElemName, ValFct)+type ElemName		= String+type ValFct		= XmlArrow+++-- ------------------------------------------------------------++-- |+-- Validate a document.+--+--    * 1.parameter dtdPart :  the DTD subset (Node @DOCTYPE@) of the XmlTree+--+--    - 2.parameter doc :  the document subset of the XmlTree+--+--    - returns : a list of errors++validateDoc	:: XmlTree -> XmlArrow+validateDoc dtdPart+    = traverseTree valTable+    where+    valTable = buildAllValidationFunctions dtdPart+++-- |+-- Traverse the XmlTree in preorder.+--+--    * 1.parameter valiEnv :  lookup-table which maps element names to their validation functions+--+--    - returns : list of errors++traverseTree	:: ValiEnvTable -> XmlArrow+traverseTree valiEnv+    = choiceA [ isElem	:-> (valFct $< getQName)+	      , this	:-> none+	      ]+      <+>+      ( getChildren >>> traverseTree valiEnv )+    where+    valFct	:: QName -> XmlArrow+    valFct name	= case (lookup (qualifiedName name) valiEnv) of+		  Nothing -> err ("Element " ++ show (qualifiedName name) ++ " not declared in DTD.")+		  Just f  -> f++-- ------------------------------------------------------------++-- |+-- Build all validation functions.+--+--    * 1.parameter dtdPart :  DTD subset, root node should be of type @DOCTYPE@+--+--    - returns : lookup-table which maps element names to their validation functions++buildAllValidationFunctions :: XmlTree -> ValiEnvTable+buildAllValidationFunctions dtdPart+    = concat $+      buildValidateRoot dtdPart :	      -- construct a list of validation filters for all element declarations+      map (buildValidateFunctions dtdNodes) dtdNodes+      where+      dtdNodes = runLA getChildren dtdPart++-- |+-- Build a validation function for the document root. By root node @\/@+-- is meant, which is the topmost dummy created by the parser.+--+--    * 1.parameter dtdPart :  DTD subset, root node should be of type @DOCTYPE@+--+--    - returns : entry for the lookup-table++buildValidateRoot :: XmlTree -> [ValiEnv]+buildValidateRoot dn+    | isDTDDoctypeNode dn	= [(t_root, valFct)]+    | otherwise			= []+      where+      name	= dtd_name . getDTDAttributes $ dn++      valFct	:: XmlArrow+      valFct	= isElem+		  `guards`+		  ( checkRegex (re_sym name)+		    >>>+		    msgToErr (("Root Element must be " ++ show name ++ ". ") ++)+		  )++checkRegex	:: RE String -> LA XmlTree String+checkRegex re	= listA getChildren+		  >>> arr (\ cs -> checkRE (matches re cs))++-- |+-- Build validation functions for an element.+--+--    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node+--+--    - 2.parameter nd :  element declaration for which the validation functions are+--                   created+--+--    - returns : entry for the lookup-table++buildValidateFunctions :: XmlTrees -> XmlTree -> [ValiEnv]++buildValidateFunctions dtdPart dn+    | isDTDElementNode dn	= [(elemName, valFct)]+    | otherwise			= []+      where+      elemName = dtd_name . getDTDAttributes $ dn++      valFct :: XmlArrow+      valFct = buildContentValidation dn+               <+>+	       buildAttributeValidation dtdPart dn++-- ------------------------------------------------------------+++-- |+-- Build validation functions for the content model of an element.+-- Validity constraint: Element Valid (3 \/ p.18 in Spec)+--+--    * 1.parameter nd :  element declaration for which the content validation functions+--                  are built+--+--    - returns : a function which takes an element (XTag), checks if its+--                  children match its content model and returns a list of errors++buildContentValidation :: XmlTree -> XmlArrow+buildContentValidation nd+    = contentValidation attrType nd+      where+      attrType = dtd_type . getDTDAttributes $ nd+++      -- Delegates construction of the validation function on the basis of the+      -- content model type+      contentValidation :: String -> XmlTree -> XmlArrow+      contentValidation typ dn+          | typ == k_pcdata   = contentValidationPcdata+          | typ == k_empty    = contentValidationEmpty+          | typ == k_any      = contentValidationAny+          | typ == v_children = contentValidationChildren cs+          | typ == v_mixed    = contentValidationMixed cs+          | otherwise         = none+	  where+	  cs = runLA getChildren dn++      -- Checks #PCDATA content models+      contentValidationPcdata :: XmlArrow+      contentValidationPcdata+	  = isElem `guards` (contentVal $< getQName)+	    where+	    contentVal name+		= checkRegex (re_rep (re_sym k_pcdata))+		  >>>+		  msgToErr ( ( "The content of element " +++			       show (qualifiedName name) +++			       " must match (#PCDATA). "+			     ) +++			   )++      -- Checks EMPTY content models+      contentValidationEmpty :: XmlArrow+      contentValidationEmpty+	  = isElem `guards` (contentVal $< getQName)+	    where+	    contentVal name+		= checkRegex re_unit+		  >>>+		  msgToErr ( ( "The content of element " +++				 show (qualifiedName name) +++				 " must match EMPTY. "+			     ) +++			   )++      -- Checks ANY content models+      contentValidationAny :: XmlArrow+      contentValidationAny+	  = isElem `guards` (contentVal $< getName)+	    where+	    contentVal name+		= checkRegex (re_rep (re_dot))+		  >>>+		  msgToErr ( ( "The content of element " +++			       show name +++			       " must match ANY. "+			     ) +++			   )++      -- Checks "children" content models+      contentValidationChildren :: XmlTrees -> XmlArrow+      contentValidationChildren cm+	  = isElem `guards` (contentVal $< getName)+	    where+	    contentVal name+		= checkRegex re+		  >>>+		  msgToErr ( ( "The content of element " +++			       show name +++			       " must match " ++ printRE re ++ ". "+			     ) +++			   )+	    re = createRE (head cm)++      -- Checks "mixed content" content models+      contentValidationMixed :: XmlTrees -> XmlArrow+      contentValidationMixed cm+	  = isElem `guards` (contentVal $< getName)+	    where+	    contentVal name+		= checkRegex re+		  >>>+		  msgToErr ( ( "The content of element " +++			       show name +++			       " must match " ++ printRE re ++ ". "+			     ) +++			   )+	    re = re_rep (re_alt (re_sym k_pcdata) (createRE (head cm)))++-- |+-- Build a regular expression from the content model. The regular expression+-- is provided by the module XmlRE.+--+--    * 1.parameter nd :  node of the content model. Expected: @CONTENT@ or+--              @NAME@+--+--    - returns : regular expression of the content model++createRE	::  XmlTree -> RE String+createRE dn+    | isDTDContentNode dn+	= processModifier modifier+    | isDTDNameNode dn+	= re_sym name+    | otherwise+	= error ("createRE: illegeal parameter:\n" ++ show dn)+    where+    al		= getDTDAttributes dn+    name	= dtd_name     al+    modifier 	= dtd_modifier al+    kind     	= dtd_kind     al+    cs		= runLA getChildren dn++    processModifier :: String -> RE String+    processModifier m+        | m == v_plus	  = re_plus (processKind kind)+	| m == v_star	  = re_rep  (processKind kind)+	| m == v_option	  = re_opt  (processKind kind)+	| m == v_null	  = processKind kind+	| otherwise       = error ("Unknown modifier: " ++ show m)++    processKind :: String -> RE String+    processKind k+        | k == v_seq	  = makeSequence cs+	| k == v_choice	  = makeChoice cs+	| otherwise	  = error ("Unknown kind: " ++ show k)++    makeSequence :: XmlTrees -> RE String+    makeSequence []     = re_unit+    makeSequence (x:xs) = re_seq (createRE x) (makeSequence xs)++    makeChoice :: XmlTrees -> RE String+    makeChoice []       = re_zero ""+    makeChoice (x:xs)   = re_alt (createRE x) (makeChoice xs)++-- ------------------------------------------------------------++-- |+-- Build validation functions for the attributes of an element.+--+--    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node+--+--    - 2.parameter nd :  element declaration for which the attribute validation functions+--                  are created+--+--    - returns : a function which takes an element (XTag), checks if its+--                  attributes are valid and returns a list of errors++buildAttributeValidation :: XmlTrees -> XmlTree -> XmlArrow+buildAttributeValidation dtdPart nd =+    noDoublicateAttributes+    <+>+    checkNotDeclardAttributes attrDecls nd+    <+>+    checkRequiredAttributes attrDecls nd+    <+>+    checkFixedAttributes attrDecls nd+    <+>+    checkValuesOfAttributes attrDecls dtdPart nd+    where+    attrDecls = isDTDAttlist $$ dtdPart+++-- |+-- Validate that all attributes of an element are unique.+-- Well-formdness constraint: Unique AttSpec (3.1 \/ p.19 in Spec)+--+--    - returns : a function which takes an element (XTag), checks if its+--                  attributes are unique and returns a list of errors++noDoublicateAttributes	:: XmlArrow+noDoublicateAttributes+    = isElem+      `guards`+      ( noDoubles' $< getName )+    where+    noDoubles' elemName+	= listA (getAttrl >>> getName)+	  >>> applyA (arr (catA . map toErr . doubles . reverse))+	where+	toErr n1 = err ( "Attribute " ++ show n1 +++			 " was already specified for element " +++			 show elemName ++ "."+		       )++-- |+-- Validate that all \#REQUIRED attributes are provided.+-- Validity constraint: Required Attributes (3.3.2 \/ p.28 in Spec)+--+--    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node+--+--    - 2.parameter nd :  element declaration which attributes have to be checked+--+--    - returns : a function which takes an element (XTag), checks if all+--                  required attributes are provided and returns a list of errors++checkRequiredAttributes	:: XmlTrees -> XmlTree -> XmlArrow+checkRequiredAttributes attrDecls dn+    | isDTDElementNode dn+	= isElem+	  `guards`+	  ( checkRequired $< getName )+    | otherwise+	= none+      where+      elemName     = dtd_name . getDTDAttributes $ dn+      requiredAtts = (isAttlistOfElement elemName >>> isRequiredAttrKind) $$ attrDecls++      checkRequired :: String -> XmlArrow+      checkRequired name+	  = catA . map checkReq $ requiredAtts+	  where+	  checkReq	:: XmlTree -> XmlArrow+	  checkReq attrDecl+	      = neg (hasAttr attName)+		`guards`+		err ( "Attribute " ++ show attName ++ " must be declared for element type " +++		      show name ++ "." )+	      where+	      attName = dtd_value . getDTDAttributes $ attrDecl++-- |+-- Validate that \#FIXED attributes match the default value.+-- Validity constraint: Fixed Attribute Default (3.3.2 \/ p.28 in Spec)+--+--    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node+--+--    - 2.parameter nd :  element declaration which attributes have to be checked+--+--    - returns : a function which takes an element (XTag), checks if all+--                  fixed attributes match the default value and returns a list of errors++checkFixedAttributes :: XmlTrees -> XmlTree -> XmlArrow+checkFixedAttributes attrDecls dn+    | isDTDElementNode dn+	= isElem+	  `guards`+	  ( checkFixed $< getName )+    | otherwise+	= none+      where+      elemName  = dtd_name . getDTDAttributes $ dn+      fixedAtts = (isAttlistOfElement elemName >>> isFixedAttrKind) $$ attrDecls++      checkFixed :: String -> XmlArrow+      checkFixed name+	  = catA . map checkFix $ fixedAtts+	  where+	  checkFix	:: XmlTree -> XmlArrow+	  checkFix an+	      |  isDTDAttlistNode an+		  = checkFixedVal $< getAttrValue attName+	      | otherwise+		  = none+	      where+	      al'	= getDTDAttributes an+	      attName   = dtd_value   al'+	      defa	= dtd_default al'+	      fixedValue = normalizeAttributeValue (Just an) defa++              checkFixedVal	:: String -> XmlArrow+	      checkFixedVal val+		  = ( ( hasAttr attName+			>>>+			isA (const (attValue /= fixedValue))+		      )+		      `guards`+		      err ( "Attribute " ++ show attName ++ " of element " ++ show name +++			    " with value " ++ show attValue ++ " must have a value of " +++			    show fixedValue ++ "." )+		    )+		  where+		  attValue   = normalizeAttributeValue (Just an) val++-- |+-- Validate that an element has no attributes which are not declared.+-- Validity constraint: Attribute Value Type (3.1 \/ p.19 in Spec)+--+--    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node+--+--    - 2.parameter nd :  element declaration which attributes have to be checked+--+--    - returns : a function which takes an element (XTag), checks if all+--                  attributes are declared and returns a list of errors++checkNotDeclardAttributes :: XmlTrees -> XmlTree -> XmlArrow+checkNotDeclardAttributes attrDecls elemDescr+    = checkNotDeclared+      where+      elemName = valueOfDTD a_name elemDescr+      decls    = isAttlistOfElement elemName $$ attrDecls++      checkNotDeclared :: XmlArrow+      checkNotDeclared+	  = isElem+	    `guards`+	    ( getAttrl >>> searchForDeclaredAtt elemName decls )++      searchForDeclaredAtt :: String -> XmlTrees -> XmlArrow+      searchForDeclaredAtt name (dn : xs)+	  | isDTDAttlistNode dn+	      = ( getName >>> isA ( (dtd_value . getDTDAttributes $ dn) /= ) )+		`guards`+		searchForDeclaredAtt name xs+	  | otherwise+	      = searchForDeclaredAtt name xs++      searchForDeclaredAtt name []+	  = mkErr $< getName+	    where+	    mkErr n = err ( "Attribute " ++ show n ++ " of element " +++			    show name ++ " is not declared in DTD." )++-- |+-- Validate that the attribute value meets the lexical constraints of its type.+-- Validity constaint: Attribute Value Type (3.1 \/ p.19 in Spec)+--+--    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node+--+--    - 2.parameter nd :  element declaration which attributes have to be checked+--+--    - returns : a function which takes an element (XTag), checks if all+--                  attributes meet the lexical constraints and returns a list of errors++checkValuesOfAttributes :: XmlTrees -> XmlTrees -> XmlTree -> XmlArrow+checkValuesOfAttributes attrDecls dtdPart elemDescr+    = checkValues+      where+      elemName	= dtd_name . getDTDAttributes $ elemDescr+      decls     = isAttlistOfElement elemName $$ attrDecls++      checkValues :: XmlArrow+      checkValues+	  = isElem+	    `guards`+	    ( checkValue $< getAttrl )++      checkValue att+	  = catA . map checkVal $ decls+	    where+	    checkVal :: XmlTree -> XmlArrow+	    checkVal attrDecl+		| isDTDAttlistNode attrDecl+		  &&+		  nameOfAttr att == dtd_value al'+		      = checkAttributeValue dtdPart attrDecl+		| otherwise+		    = none+		where+		al' = getDTDAttributes attrDecl++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/DTDValidation/IdValidation.hs view
@@ -0,0 +1,266 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.DTDValidation.IdValidation+   Copyright  : Copyright (C) 2008 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   This module provides functions for checking special ID/IDREF/IDREFS constraints.++   Checking special ID\/IDREF\/IDREFS constraints means:++    - checking that all ID values are unique.++    - checking that all IDREF\/IDREFS values match the value of some ID attribute++   ID-Validation should be started before or after validating the document.++   First all nodes with ID attributes are collected from the document, then+   it is validated that values of ID attributes do not occure more than once.+   During a second iteration over the document it is validated that there exists+   an ID attribute value for IDREF\/IDREFS attribute values.++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.DTDValidation.IdValidation+    ( validateIds+    )+where++import Data.Maybe++import Yuuko.Text.XML.HXT.DTDValidation.TypeDefs+import Yuuko.Text.XML.HXT.DTDValidation.AttributeValueValidation++-- ------------------------------------------------------------++-- |+-- Lookup-table which maps element names to their validation functions. The+-- validation functions are XmlFilters.++type IdEnvTable		= [IdEnv]+type IdEnv 		= (ElemName, IdFct)+type ElemName		= String+type IdFct		= XmlArrow++-- ------------------------------------------------------------++-- |+-- Perform the validation of the ID/IDREF/IDREFS constraints.+--+--    * 1.parameter dtdPart :  the DTD subset (Node @DOCTYPE@) of the XmlTree+--+--    - 2.parameter doc :  the document subset of the XmlTree+--+--    - returns : a list of errors++validateIds :: XmlTree -> XmlArrow+validateIds dtdPart+    = validateIds' $< listA (traverseTree idEnv)+      where+      idAttrTypes = runLA (getChildren >>> isIdAttrType) dtdPart+      elements	  = runLA (getChildren >>> isDTDElement) dtdPart+      atts        = runLA (getChildren >>> isDTDAttlist) dtdPart+      idEnv	  = buildIdCollectorFcts idAttrTypes++      validateIds'	:: XmlTrees -> XmlArrow+      validateIds' idNodeList+	  = ( constA idNodeList >>> checkForUniqueIds idAttrTypes )+	    <+>+	    checkIdReferences idRefEnv+	  where+	  idRefEnv   = buildIdrefValidationFcts idAttrTypes elements atts idNodeList++++-- |+-- Traverse the XmlTree in preorder.+--+--    * 1.parameter idEnv :  lookup-table which maps element names to their validation functions+--+--    - returns : list of errors++traverseTree :: IdEnvTable -> XmlArrow+traverseTree idEnv+    = multi (isElem `guards` (idFct $< getName))+      where+      idFct 		:: String -> XmlArrow+      idFct name	= fromMaybe none . lookup name $ idEnv++-- |+-- Returns the value of an element's ID attribute. The attribute name has to be+-- retrieved first from the DTD.+--+--    * 1.parameter dtdPart :  list of ID attribute definitions from the DTD+--+--    - 2.parameter n :  element which ID attribute value should be returned+--+--    - returns : normalized value of the ID attribute++getIdValue	:: XmlTrees -> XmlTree -> String+getIdValue dns+    = concat . runLA (single getIdValue')+    where+    getIdValue'	:: LA XmlTree String+    getIdValue'+	= isElem `guards` catA (map getIdVal dns)+	where+	getIdVal dn+	    | isDTDAttlistNode dn	= hasName elemName+					  `guards`+					  ( getAttrValue0 attrName+					    >>>+					    arr (normalizeAttributeValue (Just dn))+					  )+	    | otherwise			= none+	    where+	    al       = getDTDAttributes dn+	    elemName = dtd_name  al+	    attrName = dtd_value al++-- ------------------------------------------------------------+++-- |+-- Build collector functions which return XTag nodes with ID attributes from+-- a document.+--+--    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node+--+--    - returns : lookup-table which maps element names to their collector function++buildIdCollectorFcts :: XmlTrees -> IdEnvTable+buildIdCollectorFcts idAttrTypes+    = concatMap buildIdCollectorFct idAttrTypes+      where+      buildIdCollectorFct :: XmlTree -> [IdEnv]+      buildIdCollectorFct dn+	  | isDTDAttlistNode dn	= [(elemName, hasAttr attrName)]+	  | otherwise		= []+	  where+	  al       = getDTDAttributes dn+          elemName = dtd_name  al+	  attrName = dtd_value al++-- |+-- Build validation functions for checking if IDREF\/IDREFS values match a value+-- of some ID attributes.+--+--    * 1.parameter dtdPart :  the children of the @DOCTYPE@ node+--+--    - 2.parameter idNodeList :  list of all XTag nodes with ID attributes+--+--    - returns : lookup-table which maps element names to their validation function++buildIdrefValidationFcts :: XmlTrees -> XmlTrees -> XmlTrees -> XmlTrees -> IdEnvTable+buildIdrefValidationFcts idAttrTypes elements atts idNodeList+    = concatMap buildElemValidationFct elements+      where+      idValueList = map (getIdValue idAttrTypes) idNodeList++      buildElemValidationFct :: XmlTree -> [IdEnv]+      buildElemValidationFct dn+	  | isDTDElementNode dn	= [(elemName, buildIdrefValidationFct idRefAttrTypes)]+	  | otherwise		= []+	  where+	  al             = getDTDAttributes dn+	  elemName       = dtd_name al+	  idRefAttrTypes = (isAttlistOfElement elemName >>> isIdRefAttrType) $$ atts++      buildIdrefValidationFct :: XmlTrees -> XmlArrow+      buildIdrefValidationFct+	  = catA . map buildIdref++      buildIdref	:: XmlTree -> XmlArrow+      buildIdref dn+	  | isDTDAttlistNode dn	= isElem >>> (checkIdref $< getName)+	  | otherwise		= none+	  where+	  al             = getDTDAttributes dn+	  attrName = dtd_value al+	  attrType = dtd_type  al++	  checkIdref :: String -> XmlArrow+	  checkIdref name+	      = hasAttr attrName+		`guards`+		( checkIdVal $< getAttrValue attrName )+	      where+	      checkIdVal	:: String -> XmlArrow+	      checkIdVal av+		  | attrType == k_idref+		      = checkValueDeclared attrValue+		  | null valueList+		      = err ( "Attribute " ++ show attrName +++			      " of Element " ++ show name +++			      " must have at least one name."+			    )+		  | otherwise+		      = catA . map checkValueDeclared $ valueList+		  where+		  valueList = words attrValue+		  attrValue = normalizeAttributeValue (Just dn) av++	  checkValueDeclared :: String -> XmlArrow+	  checkValueDeclared  attrValue+	      = if attrValue `elem` idValueList+		then none+		else err ( "An Element with identifier " ++ show attrValue +++		           " must appear in the document."+			 )++-- ------------------------------------------------------------+++-- |+-- Validate that all ID values are unique within a document.+-- Validity constraint: ID (3.3.1 \/p. 25 in Spec)+--+--    * 1.parameter idNodeList :  list of all XTag nodes with ID attributes+--+--    - 2.parameter dtdPart :  the children of the @DOCTYPE@ node+--+--    - returns : a list of errors++checkForUniqueIds :: XmlTrees -> LA XmlTrees XmlTree+checkForUniqueIds idAttrTypes		 -- idNodeList+    = fromSLA [] ( unlistA+		   >>>+		   isElem+		   >>>+		   (checkForUniqueId $<< getName &&& this)+		 )+      where+      checkForUniqueId :: String -> XmlTree -> SLA [String] XmlTree XmlTree+      checkForUniqueId name x+	  = ifA ( getState+		  >>>+		  isA (attrValue `elem`)+		)+	    (err ( "Attribute value " ++ show attrValue ++ " of type ID for element " +++	           show name ++ " must be unique within the document." ))+            (nextState (attrValue:) >>> none)+	  where+	  attrValue = getIdValue (isAttlistOfElement name $$ idAttrTypes) x++-- |+-- Validate that all IDREF\/IDREFS values match the value of some ID attribute.+-- Validity constraint: IDREF (3.3.1 \/ p.26 in Spec)+--+--    * 1.parameter idRefEnv :  lookup-table which maps element names to their validation function+--+--    - 2.parameter doc :  the document to validate+--+--    - returns : a list of errors++checkIdReferences :: IdEnvTable -> LA XmlTree XmlTree+checkIdReferences idRefEnv+    = traverseTree idRefEnv++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/DTDValidation/RE.hs view
@@ -0,0 +1,341 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.DTDValidation.RE+   Copyright  : Copyright (C) 2008 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   A module for regular expression matching based on derivatives of regular expressions.++   The code was taken from Joe English (<http://www.flightlab.com/~joe/sgml/validate.html>).+   Tested and extended by Martin Schmidt.++   Further references for the algorithm:++   Janusz A. Brzozowski.++   	Derivatives of Regular Expressions. Journal of the ACM, Volume 11, Issue 4, 1964. ++   Mark Hopkins.++	Regular Expression Package. Posted to comp.compilers, 1994.+        Available per FTP at <ftp://iecc.com/pub/file/regex.tar.gz>.+-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.DTDValidation.RE+    ( RE(..)++    , re_unit+    , re_zero+    , re_sym+    , re_rep+    , re_plus+    , re_opt+    , re_seq+    , re_alt+    , re_dot++    , checkRE+    , matches+    , nullable+    , printRE+  )+where++-- |+-- Data type for regular expressions.++data RE a =+	RE_ZERO	String		--' L(0)   = {} (empty set)+	| RE_UNIT		--' L(1)   = { [] } (empty sequence)+	| RE_SYM a		--' L(x)   = { [x] }+	| RE_DOT                --' accept any single symbol+	| RE_REP (RE a)		--' L(e*)  = { [] } `union` L(e+)+	| RE_PLUS (RE a)	--' L(e+)  = { x ++ y | x <- L(e), y <- L(e*) }+	| RE_OPT (RE a)		--' L(e?)  = L(e) `union` { [] }+	| RE_SEQ (RE a) (RE a)	--' L(e,f) = { x ++ y | x <- L(e), y <- L(f) }+	| RE_ALT (RE a) (RE a)	--' L(e|f) = L(e) `union` L(f)+	deriving (Show, Eq)++++-- ------------------------------------------------------------+-- Constructor functions to simplify regular expressions when constructing them.++-- |+-- Constructs a regular expression for an empty set.+--+--    * 1.parameter errMsg :  error message+--+--    - returns : regular expression for an empty set++re_zero			:: String -> RE a+re_zero m		= RE_ZERO m+++-- |+-- Constructs a regular expression for an empty sequence.+--+--    - returns : regular expression for an empty sequence++re_unit			:: RE a+re_unit			= RE_UNIT+++-- |+-- Constructs a regular expression for accepting a symbol+--+--    * 1.parameter sym :  the symbol to be accepted+--+--    - returns : regular expression for accepting a symbol++re_sym			:: a -> RE a+re_sym x		= RE_SYM x+++-- |+-- Constructs a regular expression for accepting any singel symbol+--+--    - returns : regular expression for accepting any singel symbol++re_dot			:: RE a+re_dot			= RE_DOT+++-- |+-- Constructs an optional repetition (*) of a regular expression+--+--    * 1.parameter re_a :  regular expression to be repeted+--+--    - returns : new regular expression++re_rep			:: RE a -> RE a+re_rep RE_UNIT		= RE_UNIT+re_rep (RE_ZERO _)	= RE_UNIT+re_rep e@(RE_REP _)	= RE_REP (rem_rep e)		-- remove nested reps+re_rep e@(RE_ALT _ _)	= RE_REP (rem_rep e)		-- remove nested reps in alternatives+re_rep e		= RE_REP e++-- |+-- remove redundant nested *'s in RE+-- theoretically this is unneccessary,+-- but without this simplification the runtime can increase exponentally+-- when computing deltas, e.g. for a** or (a|b*)* which is the same as (a|b)*++rem_rep			:: RE a -> RE a+rem_rep (RE_ALT e1 e2)	= RE_ALT (rem_rep e1) (rem_rep e2)+rem_rep (RE_REP e1)	= rem_rep e1+rem_rep e1		= e1+++-- |+-- Constructs a repetition (+) of a regular expression+--+--    * 1.parameter re_a :  regular expression to be repeted+--+--    - returns : new regular expression++re_plus			:: RE a -> RE a+re_plus RE_UNIT		= RE_UNIT+re_plus (RE_ZERO m) 	= RE_ZERO m+re_plus e		= RE_PLUS e+++-- |+-- Constructs an option (?) of a regular expression+--+--    * 1.parameter re_a :  regular expression to be optional+--+--    - returns : new regular expression++re_opt			:: RE a -> RE a+re_opt RE_UNIT		= RE_UNIT+re_opt (RE_ZERO _)	= RE_UNIT+re_opt e		= RE_OPT e+++-- |+-- Constructs a sequence (,) of two regular expressions+--+--    * 1.parameter re_a :  first regular expression in sequence+--+--    - 2.parameter re_b :  second regular expression in sequence+--+--    - returns : new regular expression++re_seq			:: RE a -> RE a -> RE a+re_seq (RE_ZERO m) _	= RE_ZERO m+re_seq RE_UNIT f	= f+re_seq _ (RE_ZERO m)	= RE_ZERO m+re_seq e RE_UNIT	= e+re_seq e f		= RE_SEQ e f+++-- |+-- Constructs an alternative (|) of two regular expressions+--+--    * 1.parameter re_a :  first regular expression of alternative+--+--    - 2.parameter re_b :  second regular expression of alternative+--+--    - returns : new regular expression++re_alt			:: RE a -> RE a -> RE a+re_alt (RE_ZERO _) f	= f+re_alt e (RE_ZERO _)	= e+re_alt e f		= RE_ALT e f++++-- ------------------------------------------------------------+++-- |+-- Checks if a regular expression matches the empty sequence.+--+-- nullable e == [] `in` L(e)+--+-- This check indicates if a regular expression fits to a sentence or not.+--+--    * 1.parameter re :  regular expression to be checked+--+--    - returns : true if regular expression matches the empty sequence,+--                otherwise false++nullable		::  (Show a) => RE a -> Bool+nullable (RE_ZERO _)	= False+nullable RE_UNIT	= True+nullable (RE_SYM _)	= False+nullable (RE_REP _)	= True+nullable (RE_PLUS e)	= nullable e+nullable (RE_OPT _)	= True+nullable (RE_SEQ e f)	= nullable e && nullable f+nullable (RE_ALT e f)	= nullable e || nullable f+nullable RE_DOT		= False+++-- |+-- Derives a regular expression with respect to one symbol.+--+-- L(delta e x) = x \ L(e)+--+--    * 1.parameter re :  regular expression to be derived+--+--    - 2.parameter sym :  the symbol on which the regular expression is applied+--+--    - returns : the derived regular expression++delta :: (Eq a, Show a) => RE a -> a -> RE a+delta re x = case re of+	RE_ZERO	_		-> re					-- re_zero m+	RE_UNIT			-> re_zero ("Symbol " ++ show x ++ " unexpected.")+	RE_SYM sym+		| x == sym	-> re_unit+		| otherwise	-> re_zero ("Symbol " ++ show sym ++ " expected, but symbol " ++ show x ++ " found.")+	RE_REP  e		-> re_seq (delta e x) re		-- (re_rep e)+	RE_PLUS e		-> re_seq (delta e x) (re_rep e)+	RE_OPT  e		-> delta e x+	RE_SEQ  e f+		| nullable e	-> re_alt (re_seq (delta e x) f) (delta f x)+		| otherwise	-> re_seq (delta e x) f+	RE_ALT  e f		-> re_alt (delta e x) (delta f x)+	RE_DOT			-> re_unit+++-- |+-- Derives a regular expression with respect to a sentence.+--+--    * 1.parameter re :  regular expression+--+--    - 2.parameter s :  sentence to which the regular expression is applied+--+--    - returns : the derived regular expression++matches :: (Eq a, Show a) => RE a -> [a] -> RE a+matches e = foldl delta e+++-- |+-- Checks if an input matched a regular expression. The function should be+-- called after matches.+--+-- Was the sentence used in @matches@ in the language of the regular expression?+-- -> matches e s == s `in` L(e)?+--+--    * 1.parameter re :  the derived regular expression+--+--    - returns : empty String if input matched the regular expression, otherwise+--               an error message is returned++checkRE :: (Show a) => RE a -> String+checkRE (RE_UNIT)	= ""+checkRE (RE_ZERO m)	= m+checkRE re+	| nullable re	= ""+	| otherwise	= "Input must match " ++ printRE re++++-- ------------------------------------------------------------++++-- |+-- Constructs a string representation of a regular expression.+--+--    * 1.parameter re :  a regular expression+--+--    - returns : the string representation of the regular expression++printRE :: (Show a) => RE a -> String+printRE re'+    = "( " ++ printRE1 re' ++ " )"+      where+      printRE1 :: (Show a) => RE a -> String+      printRE1 re = case re of+	  RE_ZERO m				-> "ERROR: " ++ m+	  RE_UNIT				-> ""+	  RE_SYM sym				-> show sym+	  RE_DOT				-> "."+	  RE_REP e+	      | isSingle e			-> printRE1 e ++ "*"+	      | otherwise			-> "(" ++ printRE1 e ++ ")*"+	  RE_PLUS e+	      | isSingle e			-> printRE1 e ++ "+"+	      | otherwise			-> "(" ++ printRE1 e ++ ")+"+	  RE_OPT e+	      | isSingle e			-> printRE1 e ++ "?"+	      | otherwise			-> "(" ++ printRE1 e ++ ")?"+	  RE_SEQ e f+	      | isAlt e  && not (isAlt f)	-> "(" ++ printRE1 e ++ ") , " ++ printRE1 f+	      | not (isAlt e) && isAlt f	-> printRE1 e ++ " , (" ++ printRE1 f ++ ")"+	      | isAlt e  && isAlt f		-> "(" ++ printRE1 e ++ ") , (" ++ printRE1 f ++ ")"+	      | otherwise			-> printRE1 e ++ " , " ++ printRE1 f+	  RE_ALT e f+	      | isSeq e  && not (isSeq f)	-> "(" ++ printRE1 e ++ ") | " ++ printRE1 f+	      | not (isSeq e) && isSeq f	-> printRE1 e ++ " | (" ++ printRE1 f ++ ")"+	      | isSeq e  && isSeq f		-> "(" ++ printRE1 e ++ ") | (" ++ printRE1 f ++ ")"+	      | otherwise			-> printRE1 e ++ " | " ++ printRE1 f+++      isSingle :: RE a -> Bool+      isSingle (RE_ZERO _)    = True+      isSingle RE_UNIT        = True+      isSingle (RE_SYM _)     = True+      isSingle _              = False+++      isSeq :: RE a -> Bool+      isSeq (RE_SEQ _ _)      = True+      isSeq _                 = False+++      isAlt :: RE a -> Bool+      isAlt (RE_ALT _ _)      = True+      isAlt _                 = False
+ src/Yuuko/Text/XML/HXT/DTDValidation/TypeDefs.hs view
@@ -0,0 +1,164 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.DTDValidation.TypeDefs+   Copyright  : Copyright (C) 2008 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   This module provides all datatypes for DTD validation++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.DTDValidation.TypeDefs+    ( module Yuuko.Text.XML.HXT.DTDValidation.TypeDefs+    , module Yuuko.Text.XML.HXT.DOM.Interface+    , module Yuuko.Text.XML.HXT.Arrow.XmlArrow+    , module Control.Arrow+    , module Yuuko.Control.Arrow.ArrowList+    , module Yuuko.Control.Arrow.ArrowIf+    , module Yuuko.Control.Arrow.ArrowState+    , module Yuuko.Control.Arrow.ArrowTree+    , module Yuuko.Control.Arrow.ListArrow+    , module Yuuko.Control.Arrow.StateListArrow+    )+where++import Control.Arrow			-- classes+import Yuuko.Control.Arrow.ArrowList+import Yuuko.Control.Arrow.ArrowIf+import Yuuko.Control.Arrow.ArrowState+import Yuuko.Control.Arrow.ArrowTree++import Yuuko.Control.Arrow.ListArrow		-- arrow types+import Yuuko.Control.Arrow.StateListArrow++import Yuuko.Text.XML.HXT.Arrow.XmlArrow++import           Yuuko.Text.XML.HXT.DOM.Interface++-- ------------------------------------------------------------++infixr 0 $$++type XmlArrow	= LA XmlTree XmlTree+type XmlArrowS	= LA XmlTree XmlTrees++-- ------------------------------------------------------------++dtd_name+ , dtd_value+ , dtd_type+ , dtd_kind+ , dtd_modifier+ , dtd_default	:: Attributes -> String++dtd_name	= lookup1 a_name+dtd_value	= lookup1 a_value+dtd_type	= lookup1 a_type+dtd_kind	= lookup1 a_kind+dtd_modifier	= lookup1 a_modifier+dtd_default	= lookup1 a_default++-- ------------------------------------------------------------++isUnparsedEntity	:: ArrowDTD a => a XmlTree XmlTree+isUnparsedEntity	= filterA $+			  getDTDAttrl >>> isA (hasEntry k_ndata)++hasDTDAttrValue		:: ArrowDTD a => String -> (String -> Bool) -> a XmlTree XmlTree+hasDTDAttrValue	an p	= filterA $+			  getDTDAttrl >>> isA (p . lookup1 an)++isRequiredAttrKind	:: ArrowDTD a => a XmlTree XmlTree+isRequiredAttrKind	= hasDTDAttrValue a_kind (== k_required)++isDefaultAttrKind	:: ArrowDTD a => a XmlTree XmlTree+isDefaultAttrKind	= hasDTDAttrValue a_kind (== k_default)++isFixedAttrKind		:: ArrowDTD a => a XmlTree XmlTree+isFixedAttrKind		= hasDTDAttrValue a_kind (== k_fixed)++isMixedContentElement	:: ArrowDTD a => a XmlTree XmlTree+isMixedContentElement	= hasDTDAttrValue a_type (== v_mixed)++isEmptyElement		:: ArrowDTD a => a XmlTree XmlTree+isEmptyElement		= hasDTDAttrValue a_type (== k_empty)++isEnumAttrType		:: ArrowDTD a => a XmlTree XmlTree+isEnumAttrType		= hasDTDAttrValue a_type (== k_enumeration)++isIdAttrType		:: ArrowDTD a => a XmlTree XmlTree+isIdAttrType		= hasDTDAttrValue a_type (== k_id)++isIdRefAttrType		:: ArrowDTD a => a XmlTree XmlTree+isIdRefAttrType		= hasDTDAttrValue a_type (`elem` [k_idref, k_idrefs])++isNotationAttrType	:: ArrowDTD a => a XmlTree XmlTree+isNotationAttrType	= hasDTDAttrValue a_type (== k_notation)++isAttlistOfElement	:: ArrowDTD a => String -> a XmlTree XmlTree+isAttlistOfElement el	= isDTDAttlist+			  >>>+			  hasDTDAttrValue a_name (== el)++valueOfDTD		:: String -> XmlTree -> String+valueOfDTD n		= concat . runLA ( getDTDAttrl >>^ lookup1 n )++valueOf			:: String -> XmlTree -> String+valueOf n		= concat . runLA ( getAttrValue n )++getDTDAttributes	:: XmlTree -> Attributes+getDTDAttributes	= concat . runLA getDTDAttrl++isDTDDoctypeNode	:: XmlTree -> Bool+isDTDDoctypeNode	= not . null . runLA isDTDDoctype++isDTDElementNode	:: XmlTree -> Bool+isDTDElementNode	= not . null . runLA isDTDElement++isDTDAttlistNode	:: XmlTree -> Bool+isDTDAttlistNode	= not . null . runLA isDTDAttlist++isDTDContentNode	:: XmlTree -> Bool+isDTDContentNode	= not . null . runLA isDTDContent++isDTDNameNode		:: XmlTree -> Bool+isDTDNameNode		= not . null . runLA isDTDName++isElemNode		:: XmlTree -> Bool+isElemNode		= not . null . runLA isElem++nameOfAttr		:: XmlTree -> String+nameOfAttr		= concat . runLA (getAttrName >>^ qualifiedName)++nameOfElem		:: XmlTree -> String+nameOfElem		= concat . runLA (getElemName >>^ qualifiedName)++-- |+-- infix operator for applying an arrow to a list of trees+--+--    * 1.parameter f :  the arrow+--+--    - 2.parameter ts :  the list of trees+--+--    - returns : list of results++($$)		:: XmlArrow -> XmlTrees -> XmlTrees+f $$ l		= runLA (unlistA >>> f) l++-- | create an error message++msgToErr	:: (String -> String) -> LA String XmlTree+msgToErr f	= mkErr $< this+		  where+		  mkErr "" = none+		  mkErr s  = err (f s)+++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/DTDValidation/Validation.hs view
@@ -0,0 +1,130 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.DTDValidation.Validation+   Copyright  : Copyright (C) 2008 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   This module provides functions for validating XML documents represented as+   XmlTree.++   Unlike other popular XML validation tools the validation functions return+   a list of errors instead of aborting after the first error was found.++   Note: The validation process has been split into validation and transformation!+   If @validate@ did not report any errors, @transform@+   should be called, to change the document the way a validating parser+   is expected to do.++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.DTDValidation.Validation+    ( getDTDSubset+    , validate+    , validateDTD+    , validateDoc+    , removeDoublicateDefs+    , transform+    )++where++import Yuuko.Text.XML.HXT.DTDValidation.TypeDefs++import qualified Yuuko.Text.XML.HXT.DTDValidation.DTDValidation     as DTDValidation+import qualified Yuuko.Text.XML.HXT.DTDValidation.DocValidation     as DocValidation+import qualified Yuuko.Text.XML.HXT.DTDValidation.IdValidation      as IdValidation+import qualified Yuuko.Text.XML.HXT.DTDValidation.DocTransformation as DocTransformation++-- |+-- Main validation filter. Check if the DTD and the document are valid.+--+--+--    - returns : a function which expects a complete document as XmlTree input+--                     and returns a list of all errors found.++validate 	:: XmlArrow+validate	= validateDTD <+> validateDoc++-- |+-- Check if the DTD is valid.+--+--+--    - returns : a function which expects an XmlTree from the parser as input+--                     and returns a list of all errors found in the DTD.++validateDTD	:: XmlArrow+validateDTD	= choiceA+		  [ getDTDSubset	:-> DTDValidation.validateDTD+		  , this		:-> err "Can't validate DTD: There is no DOCTYPE declaration in the document."+		  ]+-- |+-- Check if the document corresponds to the given DTD.+--+--+--    - returns : a function which expects a complete document as XmlTree input+--                     and returns a list of all errors found in the content part.++validateDoc	:: XmlArrow+validateDoc+    = validateDoc' $< getDTD+    where+    validateDoc' []		= err "Can't validate document: There is no DOCTYPE declaration in the document."+    validateDoc' (dtdPart:_)	= DocValidation.validateDoc dtdPart+				  <+>+				  IdValidation.validateIds  dtdPart++getDTD		:: XmlArrowS+getDTD		= listA ( getDTDSubset+			  >>>+			  removeDoublicateDefs+			)++-- |+-- filter for transforming a document with respect to the given DTD.+--+-- Validating parsers+-- are expected to  normalize attribute values and add default values.+-- This function should be called after a successful validation.+--+--+--    - returns : a function which expects a complete XML document tree+--                and returns the transformed XmlTree++transform	:: XmlArrow+transform	= choiceA+		  [ isRoot	:-> (transformDoc $< getDTD)+		  , this	:-> fatal "Can't transform document: No document root given"+		  ]+                  where+		  transformDoc []	= this+		  transformDoc dtd	= DocTransformation.transform (head dtd)++-- |+-- Removes doublicate declarations from the DTD which first declaration is+-- binding. This is the case for ATTLIST and ENTITY declarations.+--+--+--    - returns : A function that replaces the children of DOCTYPE nodes by a list+--               where all multiple declarations are removed.++removeDoublicateDefs	:: XmlArrow+removeDoublicateDefs	= DTDValidation.removeDoublicateDefs++--+-- selects the DTD part of a document+-- but only, if there is more than the internal part for the 4 predefined XML entities++getDTDSubset		:: XmlArrow+getDTDSubset		= getChildren+			  >>>+			  ( filterA $ isDTDDoctype >>> getDTDAttrl >>> isA (hasEntry a_name) )+++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/DTDValidation/XmlRE.hs view
@@ -0,0 +1,116 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.DTDValidation.XmlRE+   Copyright  : Copyright (C) 2008 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   A module for regular expression matching, adapted for XML DTDs.++   This module is based on the module RE.++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.DTDValidation.XmlRE+    ( RE++    , checkRE+    , matches+    , printRE++    , re_unit+    , re_zero+    , re_sym+    , re_rep+    , re_plus+    , re_opt+    , re_seq+    , re_alt+    , re_dot+    )+where++-- import Debug.Trace(trace)++import Yuuko.Text.XML.HXT.DTDValidation.RE hiding (matches)++import Yuuko.Text.XML.HXT.DTDValidation.TypeDefs+import Yuuko.Text.XML.HXT.Arrow.Edit+    ( removeComment+    , removeWhiteSpace+    )+import qualified Yuuko.Text.XML.HXT.DOM.XmlNode as XN++-- |+-- Derives a regular expression with respect to a list of elements.+--+--    * 1.parameter re :  regular expression+--+--    - 2.parameter list :  list of elements to which the regular expression is applied+--+--    - returns : the derived regular expression++matches :: RE String -> XmlTrees -> RE String+matches re list+    = foldl delta re (removeUnimportantStuff $$ list)+      where+      removeUnimportantStuff :: XmlArrow+      removeUnimportantStuff = processBottomUp (removeWhiteSpace >>> removeComment)++      -- trace of growth of REs+      -- delta' re el = delta (trace (("RE : " ++) . (++ "\n" ) . show $ re) re) el+++-- |+-- Derives a regular expression with respect to one element.+--+-- L(delta e x) = x \ L(e)+--+--    * 1.parameter re :  regular expression to be derived+--+--    - 2.parameter el :  the element on which the regular expression is applied+--+--    - returns : the derived regular expression++delta :: RE String -> XmlTree -> RE String+delta re el+    | not (allowed el) = re+    | otherwise        = case re of+        RE_ZERO m		 -> re_zero m+        RE_UNIT			 -> re_zero (elemName el ++" unexpected.")+        RE_SYM sym+    	    | sym == k_pcdata	 -> if ((XN.isText el) || (XN.isCdata el))+				    then re_unit+				    else re_zero ("Character data expected, but "++ elemName el ++" found.")+       	    | expectedNode el sym -> re_unit+	    | otherwise           -> re_zero ("Element "++ show sym ++" expected, but "++ elemName el ++" found.")+        RE_REP e                  -> re_seq (delta e el) (re_rep e)+        RE_PLUS e                 -> re_seq (delta e el) (re_rep e)+        RE_OPT e                  -> delta e el+        RE_SEQ e f+       	    | nullable e          -> re_alt (re_seq (delta e el) f) (delta f el)+       	    | otherwise           -> re_seq (delta e el) f+        RE_ALT e f                -> re_alt (delta e el) (delta f el)+        RE_DOT                    -> re_unit++    where+    expectedNode	:: XmlTree -> String -> Bool+    expectedNode n sym+	| XN.isElem n	= nameOfElem n == sym+	| otherwise	= False++    elemName		:: XmlTree -> String+    elemName n+	| XN.isElem n	= "element "++ show (nameOfElem n)+	| otherwise	= "character data"++    allowed	:: XmlTree -> Bool+    allowed n	= XN.isElem n || XN.isText n || XN.isCdata n++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/IO/GetFILE.hs view
@@ -0,0 +1,131 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.IO.GetFILE+   Copyright  : Copyright (C) 2008 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : stable+   Portability: portable++   The GET method for file protocol++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.IO.GetFILE+    ( getStdinCont+    , getCont+    )++where++import qualified Data.ByteString        as B+import qualified Data.ByteString.Char8  as C++import		 Network.URI		( unEscapeString+					)++import           System.IO		( IOMode(..)+					, openBinaryFile+					  -- , getContents  is defined in the prelude+					, hGetContents+					)++import           System.IO.Error	( ioeGetErrorString+					, try+					)++import           System.Directory	( doesFileExist+					, getPermissions+					, readable+					)+import 		 Yuuko.Text.XML.HXT.DOM.XmlKeywords++-- ------------------------------------------------------------++getStdinCont		:: Bool -> IO (Either ([(String, String)], String)+				              String)+getStdinCont strictInput+    = do+      c <- try ( if strictInput+		 then do+		      cb <- B.getContents+		      return  (C.unpack cb)+		 else getContents+	       )+      return (either readErr Right c)+    where+    readErr e+	= Left ( [ (transferStatus,  "999")+		 , (transferMessage, msg)+		 ]+	       , msg+	       )+	  where+	  msg = "stdin read error: " ++ es+	  es  = ioeGetErrorString e++getCont		:: Bool -> String -> IO (Either ([(String, String)], String)+					        String)+getCont strictInput source+    = do			-- preliminary+      source'' <- checkFile source'+      case source'' of+           Nothing -> return $ fileErr "file not found"+	   Just fn -> do+		      perm <- getPermissions fn+		      if not (readable perm)+			 then return $ fileErr "file not readable"+			 else do+			      c <- try $+				   if strictInput+				      then do+					   cb <- B.readFile fn+					   return (C.unpack cb)+				      else do+					   h <- openBinaryFile fn ReadMode+					   hGetContents h+			      return (either readErr Right c)+    where+    source' = drivePath $ source+    readErr e+	= fileErr (ioeGetErrorString e)+    fileErr msg0+	= Left ( [ (transferStatus,  "999")+		 , (transferMessage, msg)+		 ]+	       , msg+	       )+	  where+	  msg = "file read error: " ++ show msg0 ++ " when accessing " ++ show source'++    -- remove leading / if file starts with windows drive letter, e.g. /c:/windows -> c:/windows+    drivePath ('/' : file@(d : ':' : _more))+	| d `elem` ['A'..'Z'] || d `elem` ['a'..'z']+	    = file+    drivePath file+	= file++-- | check whether file exists, if not+-- try to unescape filename and check again+-- return the existing filename++checkFile	:: String -> IO (Maybe String)+checkFile fn+    = do+      exists <- doesFileExist fn+      if exists+	 then return (Just fn)+	 else do+	      exists' <- doesFileExist fn'+	      return ( if exists'+		       then Just fn'+		       else Nothing+		     )+    where+    fn' = unEscapeString fn++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/IO/GetHTTPLibCurl.hs view
@@ -0,0 +1,275 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.IO.GetHTTPLibCurl+   Copyright  : Copyright (C) 2008 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : stable+   Portability: portable++   GET for http access with libcurl++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.IO.GetHTTPLibCurl+    ( getCont+    )++where++import Control.Arrow			( first+					, (>>>)+					)+import Control.Concurrent.MVar+import Control.Monad			( when )++import Data.Char			( isDigit+					, isSpace+					)+import Data.List			( isPrefixOf )++import Network.Curl++import System.IO+import System.IO.Unsafe			( unsafePerformIO )++import Text.ParserCombinators.Parsec	( parse )++import Yuuko.Text.XML.HXT.DOM.Util		( stringToLower )+import Yuuko.Text.XML.HXT.DOM.XmlKeywords+import Yuuko.Text.XML.HXT.DOM.XmlOptions	( isTrueValue )++import Yuuko.Text.XML.HXT.Parser.ProtocolHandlerUtil+					( parseContentType )+import Yuuko.Text.XML.HXT.Version++-- ------------------------------------------------------------+--+-- the global flag for initializing curl in the 1. call++isInitCurl	:: MVar Bool+isInitCurl	= unsafePerformIO $ newMVar False++initCurl	:: IO ()+initCurl+    = do+      i <- takeMVar isInitCurl+      when (not i) ( do+		     _ <- curl_global_init 3+		     return ()+		   )+      putMVar isInitCurl True++-- ------------------------------------------------------------++--+-- the http protocol handler implemented by calling libcurl+-- (<http://curl.haxx.se/>)+-- via the curl binding+-- <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/curl>+-- This function tries to support mostly all curl options concerning HTTP requests.+-- The naming convetion is as follows: A curl option must be prefixed by the string+-- \"curl\" and then written exactly as described in the curl man page+-- (<http://curl.haxx.se/docs/manpage.html>).+--+-- Example:+--+-- > getCont [("curl--user-agent","My first HXT app"),("curl-e","http://the.referer.url/")] "http://..."+--+-- will set the user agent and the referer URL for this request.++getCont		:: [(String, String)] -> String -> IO (Either ([(String, String)], String)+						              ([(String, String)], String))+getCont options uri+    = do+      initCurl+      resp <- curlGetResponse_ uri curlOptions+      -- dumpResponse+      return $ evalResponse resp+    where+    _dumpResponse r+	= do+	  hPutStrLn stderr $ show $ respCurlCode   r+	  hPutStrLn stderr $ show $ respStatus     r+	  hPutStrLn stderr $        respStatusLine r+	  hPutStrLn stderr $ show $ respHeaders    r+	  hPutStrLn stderr $        respBody       r++    curlOptions+	= defaultOptions ++ concatMap (uncurry copt) options ++ standardOptions++    defaultOptions						-- these options may be overwritten+	= [ CurlUserAgent ("hxt/" ++ hxt_version ++ " via libcurl")+	  , CurlFollowLocation True+	  ]++    standardOptions						-- these options can't be overwritten+	= [ CurlFailOnError    False+	  , CurlHeader         False+	  , CurlNoProgress     True+	  ]+    evalResponse r+	| rc /= CurlOK+	    = Left ( [ mkH transferStatus    "999"+		     , mkH transferMessage $ "curl library rc: " ++ show rc+		     ]+		   , "curl library error when requesting URI "+		     ++ show uri+		     ++ ": (curl return code=" ++ show rc ++ ") "+		   )+	| rs < 200 && rs >= 300+	    = Left ( contentT rsh ++ headers+		   , "http error when accessing URI "+		     ++ show uri+		     ++ ": "+		     ++ show rsl+		   )+	| otherwise+	    = Right ( contentT rsh ++ headers, respBody r+		    )+	where+	mkH x y	= (x, dropWhile isSpace y)++	headers+	    = map (\ (k, v) -> mkH (httpPrefix ++ stringToLower k) v) rsh+	      +++              statusLine (words rsl)++	contentT+	    = map (first stringToLower)			-- all header names to lowercase+	      >>>+	      filter ((== "content-type") . fst)	-- select content-type header+	      >>>+	      reverse					-- when libcurl is called with automatic redirects, there are more than one content-type headers+	      >>>+	      take 1					-- take the last one, (if at leat one is found)+	      >>>+	      map snd					-- select content-type value+	      >>>+	      map ( either (const []) id+		    . parse parseContentType ""		-- parse the content-type for mimetype and charset+		  )+	      >>>+	      concat++	statusLine (vers : _code : msg)			-- the status line of the curl response can be an old one, e.g. in the case of a redirect,+	    = [ mkH transferVersion   vers		-- so the return code is taken from the status field, which is contains the last status+	      , mkH transferMessage $ unwords msg+	      , mkH transferStatus  $ show rs+	      ]+        statusLine _+	    = []++	rc  = respCurlCode    r+	rs  = respStatus      r+	rsl = respStatusLine  r+	rsh = respHeaders     r++-- ------------------------------------------------------------++copt	:: String -> String -> [CurlOption]+copt k v+    | "curl" `isPrefixOf` k+	= opt2copt (drop 4 k) v++    | k `elem` [a_proxy, a_redirect]+	= opt2copt k v++    | k == a_options_curl+	= curlOptionString v++    | otherwise+	= []++opt2copt	:: String -> String -> [CurlOption]+opt2copt k v+    | k `elem` ["-A", "--user-agent"]	= [CurlUserAgent v]+    | k `elem` ["-b", "--cookie"]	= [CurlCookie v]+    | k == "--connect-timeout"+      &&+      isIntArg v			= [CurlConnectTimeout      $ read    v]+    | k == "--crlf"			= [CurlCRLF                $ isTrue  v]+    | k `elem` ["-d", "--data"]		= [CurlPostFields          $ lines   v]+    | k `elem` ["-e", "--referer"]	= [CurlReferer                       v]+    | k `elem` ["-H", "--header"]	= [CurlHttpHeaders         $ lines   v]+    | k == "--ignore-content-length"	= [CurlIgnoreContentLength $ isTrue  v]+    | k `elem` ["-I", "--head"]		= [CurlNoBody              $ isTrue  v]+    | k `elem` ["-L", "--location", a_redirect]+					= [CurlFollowLocation      $ isTrue  v]+    | k == "--max-filesize"+      &&+      isIntArg v			= [CurlMaxFileSizeLarge    $ read    v]+    | k `elem` ["-m", "--max-time"]+      &&+      isIntArg v			= [CurlTimeoutMS           $ read    v]+    | k `elem` ["-n", "--netrc"]	= [CurlNetrcFile                     v]+    | k `elem` ["--ssl-verify-peer"]	= [CurlSSLVerifyPeer $ read v]+    | k `elem` ["-R", "--remote-time"]  = [CurlFiletime            $ isTrue  v]+    | k `elem` ["-u", "--user"]		= [CurlUserPwd                       v]+    | k `elem` ["-U", "--proxy-user"]	= [CurlProxyUserPwd                  v]+    | k `elem` ["-x", "--proxy"]        =  proxyOptions+    | k `elem` ["-X", "--request"]      = [CurlCustomRequest                 v]+    | k `elem` ["-y", "--speed-time"]+      &&+      isIntArg v                        = [CurlLowSpeedTime        $ read    v]+    | k `elem` ["-Y", "--speed-limit"]+      &&+      isIntArg v			= [CurlLowSpeed            $ read    v]+    | k `elem` ["-z", "--time-cond"]	=  ifModifiedOptions+    | k == "--max-redirs"+      &&+      isIntArg v			= [CurlMaxRedirs           $ read    v]+    | k `elem` ["-0", "--http1.0"]	= [CurlHttpVersion       HttpVersion10]+    | otherwise				= []+    where+    ifModifiedOptions+	| "-" `isPrefixOf` v+	  &&+	  isIntArg v'			= [CurlTimeCondition TimeCondIfUnmodSince+					  ,CurlTimeValue           $ read   v'+					  ]+	| isIntArg v			= [CurlTimeCondition TimeCondIfModSince+					  ,CurlTimeValue           $ read   v'+					  ]+	| otherwise			= []+	where+	v' = tail v++    proxyOptions+	= [ CurlProxyPort pport+	  , CurlProxy     phost+	  ]+	where+	pport+	    | isIntArg ppp	= read v+	    | otherwise		= 1080+	(phost, pp) 		= span (/=':') v+	ppp      		= drop 1 pp++++isTrue		:: String -> Bool+isTrue s  	= null s || isTrueValue s++isIntArg	:: String -> Bool+isIntArg s 	= not (null s) && all isDigit s++curlOptionString	:: String -> [CurlOption]+curlOptionString+    = concatMap (uncurry copt) . opts . words+    where+    opts l+	| null l			= []+	| not ("-" `isPrefixOf` k)	= opts l1		-- k not an option: ignore+	| null l1			= opts (k:"":l1)	-- last option+	| "-" `isPrefixOf` v		= (k, "") : opts (v:l)	-- k option without arg+	| otherwise			= (k, v) : opts l2	-- k with value+	where+	(k:l1) = l+	(v:l2) = l1++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/Parser/HtmlParsec.hs view
@@ -0,0 +1,537 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.Parser.HtmlParsec+   Copyright  : Copyright (C) 2005 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : stable+   Portability: portable++   This parser tries to interprete everything as HTML+   no errors are emitted during parsing. If something looks+   weired, warning messages are inserted in the document tree.+  +   All filter are pure XmlFilter,+   errror handling and IO is done in 'Yuuko.Text.XML.HXT.Parser.HtmlParser'+   or other modules++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.Parser.HtmlParsec+    ( parseHtmlText+    , parseHtmlDocument+    , parseHtmlContent+    , isEmptyHtmlTag+    , isInnerHtmlTagOf+    , closesHtmlTag+    , emptyHtmlTags+    )++where++import Yuuko.Text.XML.HXT.DOM.Interface++import Yuuko.Text.XML.HXT.DOM.XmlNode+    ( mkText+    , mkError+    , mkCmt+    , mkElement+    , mkAttr+    , mkDTDElem+    )++import Text.ParserCombinators.Parsec+    ( Parser+    , SourcePos+    , anyChar+    , between+    , char+    , eof+    , getPosition+    , many+    , noneOf+    , option+    , parse+    , satisfy+    , string+    , try+    , (<|>)+    )++import Yuuko.Text.XML.HXT.Parser.XmlTokenParser+    ( allBut+    , dq+    , eq+    , gt+    , name+    , pubidLiteral+    , skipS+    , skipS0+    , sq+    , systemLiteral++    , singleCharsT+    , referenceT+    )++import Yuuko.Text.XML.HXT.Parser.XmlParsec+    ( cDSect+    , charData'+    , misc+    , parseXmlText+    , pI+    , xMLDecl'+    )++import Yuuko.Text.XML.HXT.Parser.XmlCharParser+    ( xmlChar+    )++import Data.Maybe+    ( fromMaybe+    )++import Data.Char+    ( toLower+    , toUpper+    )++-- ------------------------------------------------------------++parseHtmlText	:: String -> XmlTree -> XmlTrees+parseHtmlText loc t+    = parseXmlText htmlDocument loc $ t++-- ------------------------------------------------------------++parseHtmlFromString	:: Parser XmlTrees -> String -> String -> XmlTrees+parseHtmlFromString parser loc+    = either ((:[]) . mkError c_err . (++ "\n") . show) id . parse parser loc++parseHtmlDocument	:: String -> String -> XmlTrees+parseHtmlDocument	= parseHtmlFromString htmlDocument++parseHtmlContent	:: String -> XmlTrees+parseHtmlContent	= parseHtmlFromString htmlContent "text"++-- ------------------------------------------------------------++htmlDocument	:: Parser XmlTrees+htmlDocument+    = do+      pl <- htmlProlog+      el <- htmlContent+      eof+      return (pl ++ el)++htmlProlog	:: Parser XmlTrees+htmlProlog+    = do+      xml <- option []+	     ( try xMLDecl'+	       <|>+	       ( do+		 pos <- getPosition+		 _ <- try (string "<?")+		 return $ [mkError c_warn (show pos ++ " wrong XML declaration")]+	       )+	     )+      misc1   <- many misc+      dtdPart <- option []+		 ( try doctypedecl+		   <|>+		   ( do+		     pos <- getPosition+		     _ <- try (upperCaseString "<!DOCTYPE")+		     return $ [mkError c_warn (show pos ++ " HTML DOCTYPE declaration ignored")]+		   )+		 )+      return (xml ++ misc1 ++ dtdPart)++doctypedecl	:: Parser XmlTrees+doctypedecl+    = between (try $ upperCaseString "<!DOCTYPE") (char '>')+      ( do+	skipS+	n <- name+	exId <- ( do+	          skipS+		  option [] externalID+		)+	skipS0+	return [mkDTDElem DOCTYPE ((a_name, n) : exId) []]+      )++externalID	:: Parser Attributes+externalID+    = do+      _ <- try (upperCaseString k_public)+      skipS+      pl <- pubidLiteral+      sl <- option "" $ try ( do+			      skipS+			      systemLiteral+			    )+      return $ (k_public, pl) : if null sl then [] else [(k_system, sl)]++htmlContent	:: Parser XmlTrees+htmlContent+    = option []+      ( do+	context <- hContent ([], [])+	pos     <- getPosition+	return $ closeTags pos context+      )+      where+      closeTags _ (body, [])+	  = reverse body+      closeTags pos' (body, ((tn, al, body1) : restOpen))+	  = closeTags pos' (addHtmlWarn (show pos' ++ ": no closing tag found for \"<" ++ tn ++ " ...>\"")+			    .+			    addHtmlTag tn al body+			    $+			    (body1, restOpen)+			   )++type OpenTags	= [(String, XmlTrees, XmlTrees)]+type Context	= (XmlTrees, OpenTags)++hElement	:: Context -> Parser Context+hElement context+    = ( do+	t <- hSimpleData+	return (addHtmlElems [t] context)+      )+      <|>+      hOpenTag context+      <|>+      hCloseTag context+      <|>+      ( do			-- wrong tag, take it as text+	pos <- getPosition+	c   <- xmlChar+	return ( addHtmlWarn (show pos ++ " markup char " ++ show c ++ " not allowed in this context")+		 .+		 addHtmlElems [mkText [c]]+		 $+		 context+	       )+      )+      <|>+      ( do+	pos <- getPosition+	c <- anyChar+	return ( addHtmlWarn ( show pos+			       ++ " illegal data in input or illegal XML char "+			       ++ show c+			       ++ " found and ignored, possibly wrong encoding scheme used")+		 $+		 context+	       )+      )+++hSimpleData	:: Parser XmlTree+hSimpleData+    = charData'+      <|>+      try referenceT+      <|>+      try hComment+      <|>+      try pI+      <|>+      try cDSect++hCloseTag	:: Context -> Parser Context+hCloseTag context+    = do+      n <- try ( do+		 _ <- string "</"+		 lowerCaseName+	       )+      skipS0+      pos <- getPosition+      checkSymbol gt ("closing > in tag \"</" ++ n ++ "\" expected") (closeTag pos n context)++hOpenTag	:: Context -> Parser Context+hOpenTag context+    = ( do+	pos <- getPosition+	e   <- hOpenTagStart+	hOpenTagRest pos e context+      )++hOpenTagStart	:: Parser (String, XmlTrees)+hOpenTagStart+    = do+      n <- try ( do+		 _ <- char '<'+		 n <- lowerCaseName+		 return n+	       )+      skipS0+      as <- hAttrList+      return (n, as)++hOpenTagRest	:: SourcePos -> (String, XmlTrees) -> Context -> Parser Context+hOpenTagRest pos (tn, al) context+    = ( do+	_ <- try $ string "/>"+	return (addHtmlTag tn al [] context)+      )+      <|>+      ( do+	context1 <- checkSymbol gt ("closing > in tag \"<" ++ tn ++ "...\" expected") context+	return ( let context2 = closePrevTag pos tn context1+		 in+		 ( if isEmptyHtmlTag tn+		   then addHtmlTag tn al []+		   else openTag tn al+		 ) context2+	       )+      )++hAttrList	:: Parser XmlTrees+hAttrList+    = many (try hAttribute)+      where+      hAttribute+	  = do+	    n <- lowerCaseName+	    v <- hAttrValue+	    skipS0+	    return $ mkAttr (mkName n) v++hAttrValue	:: Parser XmlTrees+hAttrValue+    = option []+      ( try ( do+	      eq+	      hAttrValue'+	    )+      )++hAttrValue'	:: Parser XmlTrees+hAttrValue'+    = try ( between dq dq (hAttrValue'' "&\"") )+      <|>+      try ( between sq sq (hAttrValue'' "&\'") )+      <|>+      ( do			-- HTML allows unquoted attribute values+	cs <- many (noneOf " \r\t\n>\"\'")+	return [mkText cs]+      )++hAttrValue''	:: String -> Parser XmlTrees+hAttrValue'' notAllowed+    = many ( hReference' <|> singleCharsT notAllowed)++hReference'	:: Parser XmlTree+hReference'+    = try referenceT+      <|>+      ( do+	_ <- char '&'+	return (mkText "&")+      )++hContent	:: Context -> Parser Context+hContent context+    = option context+      ( do+	context1 <- hElement context+	hContent context1+      )++-- hComment allows "--" in comments+-- comment from XML spec does not++hComment		:: Parser XmlTree+hComment+    = do+      c <- between (try $ string "<!--") (string "-->") (allBut many "-->")+      return (mkCmt c)++checkSymbol	:: Parser a -> String -> Context -> Parser Context+checkSymbol p msg context+    = do+      pos <- getPosition+      option (addHtmlWarn (show pos ++ " " ++ msg) context)+       ( do +	 _ <- try p+	 return context+       )++lowerCaseName	:: Parser String+lowerCaseName+    = do+      n <- name+      return (map toLower n)++upperCaseString	:: String -> Parser String+upperCaseString+    = sequence . map (\ c -> satisfy (( == c) . toUpper))++-- ------------------------------------------------------------++addHtmlTag	:: String -> XmlTrees -> XmlTrees -> Context -> Context+addHtmlTag tn al body (body1, openTags)+    = ([mkElement (mkName tn) al (reverse body)] ++ body1, openTags)++addHtmlWarn	:: String -> Context -> Context+addHtmlWarn msg+    = addHtmlElems [mkError c_warn msg]++addHtmlElems	:: XmlTrees -> Context -> Context+addHtmlElems elems (body, openTags)+    = (reverse elems ++ body, openTags)++openTag		:: String -> XmlTrees -> Context -> Context+openTag tn al (body, openTags)+    = ([], (tn, al, body) : openTags)++closeTag	:: SourcePos -> String -> Context -> Context+closeTag pos n context+    | n `elem` (map ( \ (n1, _, _) -> n1) $ snd context)+	= closeTag' n context+    | otherwise+	= addHtmlWarn (show pos ++ " no opening tag found for </" ++ n ++ ">")+	  .+	  addHtmlTag n [] []+          $+	  context+    where+    closeTag' n' (body', (n1, al1, body1) : restOpen)+	= close context1+	  where+	  context1+	      = addHtmlTag n1 al1 body' (body1, restOpen)+	  close+	      | n' == n1+		= id+	      | n1 `isInnerHtmlTagOf` n'+		  = closeTag pos n'+	      | otherwise+		= addHtmlWarn (show pos ++ " no closing tag found for \"<" ++ n1 ++ " ...>\"")+		  .+		  closeTag' n'+    closeTag' _ _+	= error "illegal argument for closeTag'"++closePrevTag	:: SourcePos -> String -> Context -> Context+closePrevTag _pos _n context@(_body, [])+    = context+closePrevTag pos n context@(body, (n1, al1, body1) : restOpen)+    | n `closes` n1+	= closePrevTag pos n+	  ( addHtmlWarn (show pos ++ " tag \"<" ++ n1 ++ " ...>\" implicitly closed by opening tag \"<" ++ n ++ " ...>\"")+	    .+	    addHtmlTag n1 al1 body+	    $+	    (body1, restOpen)+	  )+    | otherwise+	= context++-- ------------------------------------------------------------+--+-- taken from HaXml and extended++isEmptyHtmlTag	:: String -> Bool+isEmptyHtmlTag n+    = n `elem`+      emptyHtmlTags++emptyHtmlTags	:: [String]+emptyHtmlTags+    = [ "area"+      , "base"+      , "br"+      , "col"+      , "frame"+      , "hr"+      , "img"+      , "input"+      , "link"+      , "meta"+      , "param"+      ]++isInnerHtmlTagOf	:: String -> String -> Bool+n `isInnerHtmlTagOf` tn+    = n `elem`+      ( fromMaybe [] . lookup tn+      $ [ ("body",    ["p"])+	, ("caption", ["p"])+	, ("dd",      ["p"])+	, ("div",     ["p"])+	, ("dl",      ["dt","dd"])+	, ("dt",      ["p"])+	, ("li",      ["p"])+	, ("map",     ["p"])+	, ("object",  ["p"])+	, ("ol",      ["li"])+	, ("table",   ["th","tr","td","thead","tfoot","tbody"])+	, ("tbody",   ["th","tr","td"])+	, ("td",      ["p"])+	, ("tfoot",   ["th","tr","td"])+	, ("th",      ["p"])+	, ("thead",   ["th","tr","td"])+	, ("tr",      ["th","td"])+	, ("ul",      ["li"])+	]+      )++closesHtmlTag+  , closes :: String -> String -> Bool++closesHtmlTag	= closes++"a"	`closes` "a"					= True+"li"	`closes` "li"					= True+"th"	`closes`  t    | t `elem` ["th","td"]		= True+"td"	`closes`  t    | t `elem` ["th","td"]		= True+"tr"	`closes`  t    | t `elem` ["th","td","tr"]	= True+"dt"	`closes`  t    | t `elem` ["dt","dd"]		= True+"dd"	`closes`  t    | t `elem` ["dt","dd"]		= True+"hr"	`closes`  "p"                                   = True+"colgroup" +	`closes` "colgroup"				= True+"form"	`closes` "form"					= True+"label"	`closes` "label"				= True+"map"	`closes` "map"					= True+"object"+	`closes` "object"				= True+_	`closes` t  | t `elem` ["option"+			       ,"script"+			       ,"style"+			       ,"textarea"+			       ,"title"+			       ]			= True+t	`closes` "select" | t /= "option"		= True+"thead"	`closes` t  | t `elem` ["colgroup"]		= True+"tfoot"	`closes` t  | t `elem` ["thead"+			       ,"colgroup"]		= True+"tbody"	`closes` t  | t `elem` ["tbody"+			       ,"tfoot"+			       ,"thead"+			       ,"colgroup"]		= True+t	`closes` t2 | t `elem` ["h1","h2","h3"+			       ,"h4","h5","h6"+			       ,"dl","ol","ul"+			       ,"table"+			       ,"div","p"+			       ]+		      &&+                      t2 `elem` ["h1","h2","h3"+				,"h4","h5","h6"+				,"p"			-- not "div"+				]			= True+_	`closes` _					= False++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/Parser/ProtocolHandlerUtil.hs view
@@ -0,0 +1,67 @@+-- ------------------------------------------------------------++{- +   Module     : Yuuko.Text.XML.HXT.Parser.ProtocolHandlerUtil+   Copyright  : Copyright (C) 2008 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : stable+   Portability: portable++   Protocol handler utility functions++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.Parser.ProtocolHandlerUtil+    ( parseContentType+    )++where++import Yuuko.Text.XML.HXT.DOM.XmlKeywords++import Yuuko.Text.XML.HXT.DOM.Util	( stringToUpper+				, stringTrim+				)++import qualified Text.ParserCombinators.Parsec as P++-- ------------------------------------------------------------++-- |+-- Try to extract charset spec from Content-Type header+-- e.g. \"text\/html; charset=ISO-8859-1\"+--+-- Sometimes the server deliver the charset spec in quotes+-- these are removed++parseContentType	:: P.Parser [(String, String)]+parseContentType+    = P.try ( do+	      mimeType <- ( do+			    mt <- P.many (P.noneOf ";")+			    rtMT mt+			  )+	      charset  <- ( do+			    _ <- P.char ';'+			    _ <- P.many  (P.oneOf " \t'")+			    _ <- P.string "charset="+			    _ <- P.option '"' (P.oneOf "\"'")+			    cs <- P.many1 (P.noneOf "\"'")+			    return [ (transferEncoding, stringToUpper cs) ]+			  )+	      return (mimeType ++ charset)+	    )+      P.<|>+      ( do+	mt <- P.many (P.noneOf ";")+	rtMT mt+      )+    where+    rtMT mt = return [ (transferMimeType, stringTrim mt) ]++-- ------------------------------------------------------------+
+ src/Yuuko/Text/XML/HXT/Parser/TagSoup.hs view
@@ -0,0 +1,480 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.Parser.TagSoup+   Copyright  : Copyright (C) 2005-2008 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   lazy HTML and simpe XML parser implemented with tagsoup+   parsing is done with a very simple monadic top down parser++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.Parser.TagSoup+    ( parseHtmlTagSoup+    )+where++-- ------------------------------------------------------------++import Data.Char (toLower)+import Data.Maybe++import Text.HTML.TagSoup+import Text.HTML.TagSoup.Entity		( lookupNumericEntity+					)+import Yuuko.Text.XML.HXT.DOM.Unicode		( isXmlSpaceChar+					)+import Yuuko.Text.XML.HXT.Parser.HtmlParsec	( isEmptyHtmlTag+					, isInnerHtmlTagOf+					, closesHtmlTag+					)+import Yuuko.Text.XML.HXT.Parser.XhtmlEntities+import Yuuko.Text.XML.HXT.DOM.Interface	( XmlTrees+					, QName+					, NsEnv+					, toNsEnv+					, newXName+					, nullXName+					, mkQName'+					, mkName+					, isWellformedQualifiedName+					, c_warn+					, a_xml+					, a_xmlns+					, xmlNamespace+					, xmlnsNamespace+					)+import Yuuko.Text.XML.HXT.DOM.XmlNode		( isElem+					, mkError+					, mkCmt+					, mkText+					, mkElement+					, mkAttr+					)++-- ---------------------------------------- ++-- The name table contains the id map. All element and attribute names are stored+-- the first time they are ecountered, and later always this name is used,+-- not a string built by the parser.++type STag		= Tag String++type Tags		= [STag]++type Context		= ([String], NsEnv)++type State		= Tags++newtype Parser a 	= P { parse :: State -> (a, State)}++instance Monad Parser where+    return x	= P $ \ ts -> (x, ts)+    p >>= f	= P $ \ ts -> let+			      (res, ts') = parse p ts+                              in+			      parse (f res) ts'++runParser	:: Parser a -> Tags -> a+runParser p ts	= fst . parse p $ ts++-- ----------------------------------------++cond		:: Parser Bool -> Parser a -> Parser a -> Parser a+cond c t e	= do+		  p <- c+		  if p then t else e++lookAhead	:: (STag -> Bool) -> Parser Bool+lookAhead p	= P $ \ s -> (not (null s) && p (head s), s)++-- ----------------------------------------+-- primitive look ahead tests++isEof		:: Parser Bool+isEof		= P $ \ s -> (null s, s)++isText		:: Parser Bool+isText		= lookAhead is+		  where+		  is (TagText _) = True+		  is _		 = False++isCmt		:: Parser Bool+isCmt		= lookAhead is+		  where+		  is (TagComment _) = True+		  is _		    = False++isWarn		:: Parser Bool+isWarn		= lookAhead is+		  where+		  is (TagWarning _) = True+		  is _		    = False++isPos		:: Parser Bool+isPos		= lookAhead is+		  where+		  is (TagPosition _ _) = True+		  is _		 = False++isCls		:: Parser Bool+isCls		= lookAhead is+		  where+		  is (TagClose _) = True+		  is _		  = False++isOpn		:: Parser Bool+isOpn		= lookAhead is+		  where+		  is (TagOpen _ _) = True+		  is _		   = False++-- ----------------------------------------+-- primitive symbol parsers++getTag		:: Parser STag+getTag		= P $ \ (t1:ts1) -> (t1, ts1)++getSym		:: (STag -> a) -> Parser a+getSym f	= do+		  t <- getTag+		  return (f t)++getText		:: Parser String+getText		= getSym sym+    		  where+		  sym (TagText t)	= t+		  sym _			= undefined++getCmt		:: Parser String+getCmt		= getSym sym+		  where+		  sym (TagComment c)	= c+	  	  sym _			= undefined++getWarn		:: Parser String+getWarn		= getSym sym+	  	  where+		  sym (TagWarning w)	= w+		  sym _			= undefined++getPos		:: Parser (Int, Int)+getPos		= getSym sym+		  where+		  sym (TagPosition l c)	= (l, c)+		  sym _			= undefined++getCls		:: Parser String+getCls		= getSym sym+		  where+		  sym (TagClose n)	= n+		  sym _			= undefined++getOpn		:: Parser (String, [(String,String)])+getOpn		= getSym sym+		  where+		  sym (TagOpen n al)	= (n, al)+		  sym _			= undefined++-- ----------------------------------------+-- pushback parsers for inserting missing tags++pushBack	:: STag -> Parser ()+pushBack t	= P $ \ ts -> ((), t:ts)++insCls		:: String -> Parser ()+insCls n	= pushBack (TagClose n)++insOpn		:: String -> [(String, String)] -> Parser ()+insOpn n al	= pushBack (TagOpen n al)++-- ----------------------------------------++mkQN		:: Bool -> Bool -> NsEnv -> String -> Parser QName+mkQN withNamespaces isAttr env s+    | withNamespaces+	= return qn1+    | otherwise+	= return qn0+    where+    qn1+	| isAttr && isSimpleName	= s'+	| isSimpleName			= mkQName' nullXName (newXName s) (nsUri nullXName)+	| isWellformedQualifiedName s	= mkQName' px'        lp'         (nsUri px')+	| otherwise			= s'+    qn0					= s'++    nsUri x				= fromMaybe nullXName . lookup x $ env+    isSimpleName			= all (/= ':') s+    (px, (_ : lp))			= span(/= ':') s+    px'                 		= newXName px+    lp'                 		= newXName lp+    s'                                  = mkName   s++extendNsEnv	:: Bool -> [(String, String)] -> NsEnv -> NsEnv+extendNsEnv withNamespaces al1 env+    | withNamespaces+	= toNsEnv (concatMap (uncurry addNs) al1) ++ env+    | otherwise+	= env+    where+    addNs n v+	| px == a_xmlns+	  &&+	  (null lp || (not . null . tail $ lp))+	    = [(drop 1 lp, v)]+	| otherwise+	    = []+	where+	(px, lp) = span (/= ':') n++-- ----------------------------------------++-- own entity lookup to prevent problems with &amp; and tagsoup hack for IE++lookupEntity	:: Bool -> Bool -> String -> Tags+lookupEntity withWarnings _asHtml e0@('#':e)+    = case lookupNumericEntity e of+      Just c  -> [ TagText [c] ]+      Nothing -> ( TagText $ "&" ++ e0 ++ ";") :+		 if withWarnings+		 then [TagWarning $ "illegal char reference: &" ++ e ++ ";"]+		 else []++lookupEntity withWarnings asHtml e+    = case (lookup e entities) of+      Just x  -> [TagText [toEnum x]]+      Nothing -> (TagText $ "&" ++ e ++ ";") :+		 if withWarnings+		 then [TagWarning $ "Unknown entity reference: &" ++ e ++ ";"]+		 else []+    where+    entities+	| asHtml    = xhtmlEntities+	| otherwise = xhtmlEntities -- xmlEntities (TODO: xhtml is xml and html)++lookupEntityAttr	:: Bool -> Bool -> (String, Bool) -> (String, Tags)+lookupEntityAttr withWarnings asHtml (e, b)+    | null r	= (s,                   r)+    | otherwise	= ("&" ++ s ++ [';'|b], r)+    where+    (TagText s) : r = lookupEntity withWarnings asHtml e++-- ----------------------------------------+{-+        entityData x = case lookupEntity y of+            Just y -> [TagText $ fromChar y]+            Nothing -> [TagText $ fromString $ "&" ++ y ++ ";"+                       ,TagWarning $ fromString $ "Unknown entity: " ++ y]+            where y = toString x++        entityAttrib (x,b) = case lookupEntity y of+            Just y -> (fromChar y, [])+            Nothing -> (fromString $ "&" ++ y ++ [';'|b], [TagWarning $ fromString $ "Unknown entity: " ++ y])+            where y = toString x+-}+-- ----------------------------------------++-- |+-- Turns all element and attribute names to lower case+-- even !DOCTYPE stuff. But this is discarded when parsing the tagsoup++lowerCaseNames :: Tags -> Tags+lowerCaseNames+    = map f+    where+    f (TagOpen name attrs)+        = TagOpen (nameToLower name) (map attrToLower attrs)+    f (TagClose name)+	= TagClose (nameToLower name)+    f a = a+    nameToLower          = map toLower+    attrToLower (an, av) = (nameToLower an, av)++-- ----------------------------------------+-- the main parser++parseHtmlTagSoup	:: Bool -> Bool -> Bool -> Bool -> Bool -> String -> String -> XmlTrees+parseHtmlTagSoup withNamespaces withWarnings withComment removeWhiteSpace asHtml doc+    = ( docRootElem+	. runParser (buildCont initContext)+	. ( if asHtml+	    then lowerCaseNames+	    else id+	  )+	. tagsoupParse+      )+    where+    tagsoupParse	:: String -> Tags+    tagsoupParse	= parseTagsOptions tagsoupOptions++    tagsoupOptions	:: ParseOptions String+    tagsoupOptions	= parseOptions' { optTagWarning     = withWarnings+					, optEntityData   = lookupEntity     withWarnings asHtml+					, optEntityAttrib = lookupEntityAttr withWarnings asHtml+					}+			  where+			  parseOptions' :: ParseOptions String+			  parseOptions' = parseOptions++    -- This is essential for lazy parsing:+    -- the call of "take 1" stops parsing, when the first element is detected+    -- no check on end of input sequence is required to build this (0- or 1-element list)+    -- so eof is never checked unneccessarily++    docRootElem+	= take 1 . filter isElem++    initContext		= ( []+			  , toNsEnv $+			    [ (a_xml,   xmlNamespace)+			    , (a_xmlns, xmlnsNamespace)+			    ]+			  )++    wrap		= (:[])++    warn+	| withWarnings	= wrap . mkError c_warn . show . (doc ++) . (" " ++)+	| otherwise	= const []+    cmt+	| withComment	= wrap . mkCmt+	| otherwise	= const []+    txt+	| removeWhiteSpace+			= \ t ->+			  if all isXmlSpaceChar t+			  then []+			  else wrap . mkText $ t+	| otherwise	= wrap . mkText++    isEmptyElem+	| asHtml	= isEmptyHtmlTag+	| otherwise	= const False++    isInnerElem+	| asHtml	= isInnerHtmlTagOf+	| otherwise	= const (const False)++    closesElem+	| asHtml	= \ ns n1 ->+			  not (null ns)+			  &&+			  n1 `closesHtmlTag` (head ns)+	| otherwise	= const (const False)++    buildCont	:: Context -> Parser XmlTrees+    buildCont ns+	= cond isText ( do+			t <- getText+			rl <- buildCont ns+			return (txt t ++ rl)+		      )+	  ( cond isOpn ( do+			 (n,al) <- getOpn+			 openTag ns n al+		       )+	    ( cond isCls ( do+			   n <- getCls+			   closeTag ns n+			 )+	      ( cond isCmt ( do+			     c <- getCmt+			     rl <- buildCont ns+			     return (cmt c ++ rl)+			   )+		( cond isWarn ( do+				w <- getWarn+				rl <- buildCont ns+				return (warn w ++ rl)+			      )+		  ( cond isPos ( do+				 _ <- getPos+				 buildCont ns+			       )+		    ( cond isEof ( do+				   _ <- isEof+				   closeAll ns+				 )+		      ( return (warn "parse error in tagsoup tree construction")+		      )+		    )+		  )+		)+	      )+	    )+	  )+	where+	closeTag		:: Context -> String -> Parser XmlTrees+	closeTag ((n':_), _) n1+	    | n' == n1		= return []			-- a normal closing tag+								-- all other cases try to repair wrong html+	closeTag ns'@((n':_), _) n1				-- n1 closes n implicitly+	    | n' `isInnerElem` n1				-- e.g. <td>...</tr>+				= do+				  insCls n1			-- pushback </n1>+				  insCls n'			-- insert a </n'>+				  buildCont ns'			-- try again+	closeTag ns' n1+	    | isEmptyElem n1	= buildCont ns'			-- ignore a redundant closing tag for empty element+	closeTag ns'@((n':ns1'), _) n1				-- insert a missing closing tag+	    | n1 `elem` ns1'	= do+				  insCls n1+				  insCls n'+				  rl <- buildCont ns'+				  return ( warn ("closing tag " ++ show n' +++						 " expected, but " ++ show n1 ++ " found")+					   ++ rl+					 )+	closeTag ns' n1						-- ignore a wrong closing tag+				= do+				  rl <- buildCont ns'+				  return ( warn ("no opening tag for closing tag " ++ show n1)+					   ++ rl+					 )++	openTag			:: Context -> String -> [(String, String)] -> Parser XmlTrees+	openTag cx'@(ns',env') n1 al1+	    | isPiDT n1		= buildCont cx'+	    | isEmptyElem n1+				= do+				  qn <- mkElemQN nenv n1+				  al <- mkAttrs al1+				  rl <- buildCont cx'+				  return (mkElement qn al [] : rl)+	    | closesElem ns' n1	= do+				  insOpn n1 al1+				  insCls (head ns')+				  buildCont cx'+	    | otherwise		= do+				  qn <- mkElemQN nenv n1+				  al <- mkAttrs al1+				  cs <- buildCont ((n1 : ns'), nenv)+				  rl <- buildCont cx'+				  return (mkElement qn al cs : rl)+	    where+	    nenv		= extendNsEnv withNamespaces al1 env'+	    mkElemQN		= mkQN withNamespaces False+	    mkAttrQN		= mkQN withNamespaces True+	    isPiDT ('?':_)	= True+	    isPiDT ('!':_)	= True+	    isPiDT _		= False+	    mkAttrs		= mapM (uncurry mkA)+	    mkA an av		= do+				  qan <- mkAttrQN nenv an+				  return (mkAttr qan (wrap . mkText $ av))++	closeAll		:: ([String], NsEnv) -> Parser XmlTrees+	closeAll (ns',_)	= return (concatMap wrn ns')+				  where+				  wrn = warn . ("insert missing closing tag " ++) . show++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/Parser/XhtmlEntities.hs view
@@ -0,0 +1,278 @@+-- |+-- XHTML Entity References+--+-- This module defines a table of all+-- predefined XHTML entity references+-- for special or none ASCII chars including the+-- predefined XML entity refs++module Yuuko.Text.XML.HXT.Parser.XhtmlEntities+    ( xhtmlEntities+    )++where++import Yuuko.Text.XML.HXT.Parser.XmlEntities+    ( xmlEntities )++-- ------------------------------------------------------------++-- | table with all XHTML entity refs and corresponding unicode values++xhtmlEntities	:: [(String, Int)]+xhtmlEntities	= xmlEntities+		  +++		  [ ("nbsp",	160)+		  , ("iexcl",	161)+		  , ("cent",	162)+		  , ("pound",	163)+		  , ("curren",	164)+		  , ("yen",	165)+		  , ("brvbar",	166)+		  , ("sect",	167)+		  , ("uml",	168)+		  , ("copy",	169)+		  , ("ordf",	170)+		  , ("laquo",	171)+		  , ("not",	172)+		  , ("shy",	173)+		  , ("reg",	174)+		  , ("macr",	175)+		  , ("deg",	176)+		  , ("plusmn",	177)+		  , ("sup2",	178)+		  , ("sup3",	179)+		  , ("acute",	180)+		  , ("micro",	181)+		  , ("para",	182)+		  , ("middot",	183)+		  , ("cedil",	184)+		  , ("sup1",	185)+		  , ("ordm",	186)+		  , ("raquo",	187)+		  , ("frac14",	188)+		  , ("frac12",	189)+		  , ("frac34",	190)+		  , ("iquest",	191)+		  , ("Agrave",	192)+		  , ("Aacute",	193)+		  , ("Acirc",	194)+		  , ("Atilde",	195)+		  , ("Auml",	196)+		  , ("Aring",	197)+		  , ("AElig",	198)+		  , ("Ccedil",	199)+		  , ("Egrave",	200)+		  , ("Eacute",	201)+		  , ("Ecirc",	202)+		  , ("Euml",	203)+		  , ("Igrave",	204)+		  , ("Iacute",	205)+		  , ("Icirc",	206)+		  , ("Iuml",	207)+		  , ("ETH",	208)+		  , ("Ntilde",	209)+		  , ("Ograve",	210)+		  , ("Oacute",	211)+		  , ("Ocirc",	212)+		  , ("Otilde",	213)+		  , ("Ouml",	214)+		  , ("times",	215)+		  , ("Oslash",	216)+		  , ("Ugrave",	217)+		  , ("Uacute",	218)+		  , ("Ucirc",	219)+		  , ("Uuml",	220)+		  , ("Yacute",	221)+		  , ("THORN",	222)+		  , ("szlig",	223)+		  , ("agrave",	224)+		  , ("aacute",	225)+		  , ("acirc",	226)+		  , ("atilde",	227)+		  , ("auml",	228)+		  , ("aring",	229)+		  , ("aelig",	230)+		  , ("ccedil",	231)+		  , ("egrave",	232)+		  , ("eacute",	233)+		  , ("ecirc",	234)+		  , ("euml",	235)+		  , ("igrave",	236)+		  , ("iacute",	237)+		  , ("icirc",	238)+		  , ("iuml",	239)+		  , ("eth",	240)+		  , ("ntilde",	241)+		  , ("ograve",	242)+		  , ("oacute",	243)+		  , ("ocirc",	244)+		  , ("otilde",	245)+		  , ("ouml",	246)+		  , ("divide",	247)+		  , ("oslash",	248)+		  , ("ugrave",	249)+		  , ("uacute",	250)+		  , ("ucirc",	251)+		  , ("uuml",	252)+		  , ("yacute",	253)+		  , ("thorn",	254)+		  , ("yuml",	255)++		  , ("OElig",	338)+		  , ("oelig",	339)+		  , ("Scaron",	352)+		  , ("scaron",	353)+		  , ("Yuml",	376)+		  , ("circ",	710)+		  , ("tilde",	732)++		  , ("ensp",	8194)+		  , ("emsp",	8195)+		  , ("thinsp",	8201)+		  , ("zwnj",	8204)+		  , ("zwj",	8205)+		  , ("lrm",	8206)+		  , ("rlm",	8207)+		  , ("ndash",	8211)+		  , ("mdash",	8212)+		  , ("lsquo",	8216)+		  , ("rsquo",	8217)+		  , ("sbquo",	8218)+		  , ("ldquo",	8220)+		  , ("rdquo",	8221)+		  , ("bdquo",	8222)+		  , ("dagger",	8224)+		  , ("Dagger",	8225)+		  , ("permil",	8240)+		  , ("lsaquo",	8249)+		  , ("rsaquo",	8250)+		  , ("euro",	8364)++		  , ("fnof",	402)+		  , ("Alpha",	913)+		  , ("Beta",	914)+		  , ("Gamma",	915)+		  , ("Delta",	916)+		  , ("Epsilon",	917)+		  , ("Zeta",	918)+		  , ("Eta",	919)+		  , ("Theta",	920)+		  , ("Iota",	921)+		  , ("Kappa",	922)+		  , ("Lambda",	923)+		  , ("Mu",	924)+		  , ("Nu",	925)+		  , ("Xi",	926)+		  , ("Omicron",	927)+		  , ("Pi",	928)+		  , ("Rho",	929)+		  , ("Sigma",	931)+		  , ("Tau",	932)+		  , ("Upsilon",	933)+		  , ("Phi",	934)+		  , ("Chi",	935)+		  , ("Psi",	936)+		  , ("Omega",	937)+		  , ("alpha",	945)+		  , ("beta",	946)+		  , ("gamma",	947)+		  , ("delta",	948)+		  , ("epsilon",	949)+		  , ("zeta",	950)+		  , ("eta",	951)+		  , ("theta",	952)+		  , ("iota",	953)+		  , ("kappa",	954)+		  , ("lambda",	955)+		  , ("mu",	956)+		  , ("nu",	957)+		  , ("xi",	958)+		  , ("omicron",	959)+		  , ("pi",	960)+		  , ("rho",	961)+		  , ("sigmaf",	962)+		  , ("sigma",	963)+		  , ("tau",	964)+		  , ("upsilon",	965)+		  , ("phi",	966)+		  , ("chi",	967)+		  , ("psi",	968)+		  , ("omega",	969)+		  , ("thetasym",	977)+		  , ("upsih",	978)+		  , ("piv",	982)+		  , ("bull",	8226)+		  , ("hellip",	8230)+		  , ("prime",	8242)+		  , ("Prime",	8243)+		  , ("oline",	8254)+		  , ("frasl",	8260)+		  , ("weierp",	8472)+		  , ("image",	8465)+		  , ("real",	8476)+		  , ("trade",	8482)+		  , ("alefsym",	8501)+		  , ("larr",	8592)+		  , ("uarr",	8593)+		  , ("rarr",	8594)+		  , ("darr",	8595)+		  , ("harr",	8596)+		  , ("crarr",	8629)+		  , ("lArr",	8656)+		  , ("uArr",	8657)+		  , ("rArr",	8658)+		  , ("dArr",	8659)+		  , ("hArr",	8660)+		  , ("forall",	8704)+		  , ("part",	8706)+		  , ("exist",	8707)+		  , ("empty",	8709)+		  , ("nabla",	8711)+		  , ("isin",	8712)+		  , ("notin",	8713)+		  , ("ni",	8715)+		  , ("prod",	8719)+		  , ("sum",	8721)+		  , ("minus",	8722)+		  , ("lowast",	8727)+		  , ("radic",	8730)+		  , ("prop",	8733)+		  , ("infin",	8734)+		  , ("ang",	8736)+		  , ("and",	8743)+		  , ("or",	8744)+		  , ("cap",	8745)+		  , ("cup",	8746)+		  , ("int",	8747)+		  , ("there4",	8756)+		  , ("sim",	8764)+		  , ("cong",	8773)+		  , ("asymp",	8776)+		  , ("ne",	8800)+		  , ("equiv",	8801)+		  , ("le",	8804)+		  , ("ge",	8805)+		  , ("sub",	8834)+		  , ("sup",	8835)+		  , ("nsub",	8836)+		  , ("sube",	8838)+		  , ("supe",	8839)+		  , ("oplus",	8853)+		  , ("otimes",	8855)+		  , ("perp",	8869)+		  , ("sdot",	8901)+		  , ("lceil",	8968)+		  , ("rceil",	8969)+		  , ("lfloor",	8970)+		  , ("rfloor",	8971)+		  , ("lang",	9001)+		  , ("rang",	9002)+		  , ("loz",	9674)+		  , ("spades",	9824)+		  , ("clubs",	9827)+		  , ("hearts",	9829)+		  , ("diams",	9830)+		  ]++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/Parser/XmlCharParser.hs view
@@ -0,0 +1,74 @@+-- |+-- UTF-8 character parser and simple XML token parsers+--+-- Version : $Id: XmlCharParser.hs,v 1.2 2005/05/31 16:01:12 hxml Exp $++module Yuuko.Text.XML.HXT.Parser.XmlCharParser+    ( xmlChar			-- xml char parsers+    , xmlNameChar+    , xmlNameStartChar+    , xmlNCNameChar+    , xmlNCNameStartChar+    , xmlLetter+    , xmlSpaceChar+    )+where++import Yuuko.Text.XML.HXT.DOM.Unicode+import Text.ParserCombinators.Parsec++-- ------------------------------------------------------------+--+-- Char (2.2)+--++-- |+-- parse a single Unicode character++xmlChar			:: GenParser Char state Unicode+xmlChar			= satisfy isXmlChar <?> "legal XML character"++-- |+-- parse a XML name character++xmlNameChar		:: GenParser Char state Unicode+xmlNameChar		= satisfy isXmlNameChar <?> "legal XML name character"+ +-- |+-- parse a XML name start character++xmlNameStartChar	:: GenParser Char state Unicode+xmlNameStartChar	= satisfy isXmlNameStartChar <?> "legal XML name start character"+ +-- |+-- parse a XML NCName character++xmlNCNameChar		:: GenParser Char state Unicode+xmlNCNameChar		= satisfy isXmlNCNameChar <?> "legal XML NCName character"+ +-- |+-- parse a XML NCName start character++xmlNCNameStartChar	:: GenParser Char state Unicode+xmlNCNameStartChar	= satisfy isXmlNCNameStartChar <?> "legal XML NCName start character"+ +-- |+-- parse a XML letter character++xmlLetter		:: GenParser Char state Unicode+xmlLetter		= satisfy isXmlLetter <?> "legal XML letter"++-- |+-- White Space (2.3)+--+-- end of line handling (2.11)+-- \#x0D and \#x0D\#x0A are mapped to \#x0A+-- is done in XmlInput before parsing+-- otherwise \#x0D in internal parsing, e.g. for entities would normalize,+-- would be transformed++xmlSpaceChar		:: GenParser Char state Char+xmlSpaceChar		= satisfy isXmlSpaceChar <?> "white space"++-- ------------------------------------------------------------+
+ src/Yuuko/Text/XML/HXT/Parser/XmlDTDParser.hs view
@@ -0,0 +1,715 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.Parser.XmlDTDParser+   Copyright  : Copyright (C) 2005 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   Parsec parser for DTD declarations for ELEMENT, ATTLIST, ENTITY and NOTATION declarations++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.Parser.XmlDTDParser+    ( parseXmlDTDdecl+    , parseXmlDTDdeclPart+    , parseXmlDTDEntityValue+    , elementDecl+    , attlistDecl+    , entityDecl+    , notationDecl+    )+where++import Data.Maybe++import Text.ParserCombinators.Parsec+import Text.ParserCombinators.Parsec.Pos++import Yuuko.Text.XML.HXT.DOM.Interface++++import Yuuko.Text.XML.HXT.DOM.ShowXml+    ( xshow+    )+import Yuuko.Text.XML.HXT.DOM.XmlNode+    ( mkDTDElem+    , mkText+    , mkError+    , isText+    , isDTD+    , getText+    , getDTDPart+    , getDTDAttrl+    , getChildren+    , setChildren+    )+import qualified Yuuko.Text.XML.HXT.Parser.XmlTokenParser    as XT+import qualified Yuuko.Text.XML.HXT.Parser.XmlCharParser     as XC ( xmlSpaceChar )+import qualified Yuuko.Text.XML.HXT.Parser.XmlDTDTokenParser as XD ( dtdToken )++-----------------------------------------------------------+--+-- all parsers dealing with whitespace will be redefined+-- to handle parameter entity substitution++type LocalState	= (Int, [(Int, String, SourcePos)])++type SParser a	= GenParser Char LocalState a++initialLocalState	:: SourcePos -> LocalState+initialLocalState p	= (0, [(0, sourceName p, p)])++pushPar		:: String -> SParser ()+pushPar	n	= do+		  p <- getPosition+		  updateState (\ (i, s)	-> (i+1, (i+1, n, p) : s))+		  setPosition ( newPos (sourceName p ++ " (line " ++ show (sourceLine p) ++ ", column " ++ show (sourceColumn p) ++ ") in content of parameter entity ref %" ++ n ++ ";") 1 1)++popPar		:: SParser ()+popPar		= do+		  oldPos <- getPos+		  updateState pop+		  setPosition oldPos+		where+		pop (i, [(_, s, p)]) = (i+1, [(i+1, s, p)])	-- if param entity substitution is correctly implemented, this case does not occur+		pop (i, _t:s)        = (i, s)+                pop (_i, [])         = undefined		-- stack is never empty++getParNo	:: SParser Int+getParNo	= do+		  (_i, (top, _n, _p) : _s) <- getState+		  return top++getPos		:: SParser SourcePos+getPos		= do+		  (_i, (_top, _n, p) : _s) <- getState+		  return p++delPE	:: SParser ()+delPE	= do+	  _ <- char '\0'+	  return ()++startPE	:: SParser ()+startPE+    = do+      try ( do+	    delPE+	    n <- many1 (satisfy (/= '\0'))+	    delPE+	    pushPar n+	  )++endPE	:: SParser ()+endPE+    = do+      try (do+	   delPE+	   delPE+	   popPar+	  )++inSamePE	:: SParser a -> SParser a+inSamePE p+    = do+      i <- getParNo+      r <- p+      j <- getParNo+      if (i == j)+	 then return r+	 else fail $ "parameter entity contents does not fit into the structure of a DTD declarations"++-- ------------------------------------------------------------++xmlSpaceChar	:: SParser ()+xmlSpaceChar	= ( do+		    _ <- XC.xmlSpaceChar+		    return ()+		  )+		  <|>+		  startPE+		  <|>+		  endPE+		  <?> "white space"++skipS		:: SParser ()+skipS+    = do+      skipMany1 xmlSpaceChar+      return ()++skipS0		:: SParser ()+skipS0+    = do+      skipMany xmlSpaceChar+      return ()++name		:: SParser XmlTree+name+    = do+      n <- XT.name+      return (mkDTDElem NAME [(a_name, n)] [])++nmtoken		:: SParser XmlTree+nmtoken+    = do+      n <- XT.nmtoken+      return (mkDTDElem NAME [(a_name, n)] [])++-- ------------------------------------------------------------+--+-- Element Type Declarations (3.2)++elementDecl	:: SParser XmlTrees+elementDecl+    = between (try $ string "<!ELEMENT") (char '>') elementDeclBody++elementDeclBody	:: SParser XmlTrees+elementDeclBody+    = do+      skipS+      n <- XT.name+      skipS+      (al, cl) <- contentspec+      skipS0+      return [mkDTDElem ELEMENT ((a_name, n) : al) cl]++contentspec	:: SParser (Attributes, XmlTrees)+contentspec+    = simplespec k_empty v_empty+      <|>+      simplespec k_any v_any+      <|>+      inSamePE mixed+      <|>+      inSamePE children+      <?> "content specification"+    where+    simplespec kw v+	= do+	  _ <- XT.keyword kw+	  return ([(a_type, v)], [])++-- ------------------------------------------------------------+--+-- Element Content (3.2.1)++children	:: SParser (Attributes, XmlTrees)+children+    = ( do+	(al, cl) <- choiceOrSeq+	modifier <- optOrRep+	return ([(a_type, v_children)], [mkDTDElem CONTENT (modifier ++ al) cl])+      )+      <?> "element content"++optOrRep	:: SParser Attributes+optOrRep+    = do+      m <- option "" (XT.mkList (oneOf "?*+"))+      return [(a_modifier, m)]++choiceOrSeq	:: SParser (Attributes, XmlTrees)+choiceOrSeq+    = inSamePE $+      do+      cl <- try ( do+		  lpar+		  choiceOrSeqBody+		)+      rpar+      return cl++choiceOrSeqBody	:: SParser (Attributes, XmlTrees)+choiceOrSeqBody+    = do+      cp1 <- cp+      choiceOrSeq1 cp1+    where+    choiceOrSeq1	:: XmlTree -> SParser (Attributes, XmlTrees)+    choiceOrSeq1 c1+	= ( do+	    bar+	    c2 <- cp+	    cl <- many ( do+			 bar+			 cp+		       )+	    return ([(a_kind, v_choice)], (c1 : c2 : cl))+	  )+	  <|>+	  ( do+	    cl <- many ( do+			 comma+			 cp+		       )+	    return ([(a_kind, v_seq)], (c1 : cl))+	  )+          <?> "sequence or choice"++cp		:: SParser XmlTree+cp+    = ( do+	n <- name+	m <- optOrRep+	return ( case m of+		 [(_, "")] -> n+		 _         -> mkDTDElem CONTENT (m ++ [(a_kind, v_seq)]) [n]+	       )+      )+      <|>+      ( do+	(al, cl) <- choiceOrSeq+	m <- optOrRep+	return (mkDTDElem CONTENT (m ++ al) cl)+      )++-- ------------------------------------------------------------+--+-- Mixed Content (3.2.2)++mixed		:: SParser (Attributes, XmlTrees)+mixed+    = ( do+	_ <- try ( do+		   lpar+		   string k_pcdata+		 )+	nl <- many ( do+		     bar+		     name+		   )+	rpar+	if null nl+          then do+	       _ <- option ' ' (char '*')		-- (#PCDATA) or (#PCDATA)* , both are legal+	       return ( [ (a_type, v_pcdata) ]+		      , []+		      )+	  else do+	       _ <- char '*' <?> "closing parent for mixed content (\")*\")"+	       return ( [ (a_type, v_mixed) ]+		      , [ mkDTDElem CONTENT [ (a_modifier, "*")+					     , (a_kind, v_choice)+					     ] nl+			]+		      )+      )+      <?> "mixed content"++-- ------------------------------------------------------------+--+-- Attribute-List Declarations (3.3)++attlistDecl		:: SParser XmlTrees+attlistDecl+    = between (try $ string "<!ATTLIST") (char '>') attlistDeclBody++attlistDeclBody		:: SParser XmlTrees+attlistDeclBody+    = do+      skipS+      n <- XT.name+      al <- many attDef+      skipS0+      return (map (mkDTree n) al)+    where+    mkDTree n' (al, cl)+	= mkDTDElem ATTLIST ((a_name, n') : al) cl+    +attDef		:: SParser (Attributes, XmlTrees)+attDef+    = do+      n <- try ( do+		 skipS+		 XT.name+	       ) <?> "attribute name"+      skipS+      (t, cl) <- attType+      skipS+      d <- defaultDecl+      return (((a_value, n) : d) ++ t, cl)++attType	:: SParser (Attributes, XmlTrees)+attType+    = tokenizedOrStringType+      <|>+      enumeration+      <|>+      notationType+      <?> "attribute type"++tokenizedOrStringType	:: SParser (Attributes, XmlTrees)+tokenizedOrStringType+    = do+      n <- choice $ map XT.keyword typl+      return ([(a_type, n)], [])+      where+      typl	= [ k_cdata+		  , k_idrefs+		  , k_idref+		  , k_id+		  , k_entity+		  , k_entities+		  , k_nmtokens+		  , k_nmtoken+		  ]++enumeration	:: SParser (Attributes, XmlTrees)+enumeration+    = do+      nl <- inSamePE (between lpar rpar (sepBy1 nmtoken bar))+      return ([(a_type, k_enumeration)], nl)++notationType	:: SParser (Attributes, XmlTrees)+notationType+    = do+      _ <- XT.keyword k_notation+      skipS+      nl <- inSamePE (between lpar rpar ( sepBy1 name bar ))+      return ([(a_type, k_notation)], nl)++defaultDecl	:: SParser Attributes+defaultDecl+    = ( do+	str <- try $ string k_required+	return [(a_kind, str)]+      )+      <|>+      ( do+	str <- try $ string k_implied+	return [(a_kind, str)]+      )+      <|>+      ( do+        l <- fixed+	v <- XT.attrValueT+	return ((a_default, xshow v) : l)+      )+      <?> "default declaration"+    where+    fixed = option [(a_kind, k_default)]+	    ( do+	      _ <- try $ string k_fixed+	      skipS+	      return [(a_kind, k_fixed)]+	    )++-- ------------------------------------------------------------+--+-- Entity Declarations (4.2)++entityDecl		:: SParser XmlTrees+entityDecl+    = between ( try $ string "<!ENTITY" ) (char '>') entityDeclBody++entityDeclBody		:: SParser XmlTrees+entityDeclBody+    = do+      skipS+      ( peDecl+	<|>+	geDecl+	<?> "entity declaration" )	-- don't move the ) to the next line++geDecl			:: SParser XmlTrees+geDecl+    = do+      n <- XT.name+      skipS+      (al, cl) <- entityDef+      skipS0+      return [mkDTDElem ENTITY ((a_name, n) : al) cl]++entityDef		:: SParser (Attributes, XmlTrees)+entityDef+    = entityValue+      <|>+      externalEntitySpec++externalEntitySpec	:: SParser (Attributes, XmlTrees)+externalEntitySpec+    = do+      al <- externalID+      nd <- option [] nDataDecl+      return ((al ++ nd), [])++peDecl			:: SParser XmlTrees+peDecl+    = do+      _ <- char '%'+      skipS+      n <- XT.name+      skipS+      (al, cs) <- peDef+      skipS0+      return [mkDTDElem PENTITY ((a_name, n) : al) cs]++peDef			:: SParser (Attributes, XmlTrees)+peDef+    = entityValue+      <|>+      do+      al <- externalID+      return (al, [])++entityValue	:: GenParser Char state (Attributes, XmlTrees)+entityValue+    = do+      v <- XT.entityValueT+      return ([], v)++-- ------------------------------------------------------------+--+-- External Entities (4.2.2)++externalID	:: SParser Attributes+externalID+    = ( do+	_ <- XT.keyword k_system+	skipS+	lit <- XT.systemLiteral+	return [(k_system, lit)]+      )+      <|>+      ( do+	_ <- XT.keyword k_public+	skipS+	pl <- XT.pubidLiteral+	skipS+	sl <- XT.systemLiteral+	return [ (k_system, sl)+	       , (k_public, pl) ]+      )+      <?> "SYSTEM or PUBLIC declaration"++nDataDecl	:: SParser Attributes+nDataDecl+    = do+      _ <- try ( do+		 skipS+		 XT.keyword k_ndata+	       )+      skipS+      n <- XT.name+      return [(k_ndata, n)]++-- ------------------------------------------------------------+--+-- Notation Declarations (4.7)++notationDecl		:: SParser XmlTrees+notationDecl+    = between (try $ string "<!NOTATION") (char '>' <?> "notation declaration") notationDeclBody++notationDeclBody	:: SParser XmlTrees+notationDeclBody+    = do+      skipS+      n <- XT.name+      skipS+      eid <- ( try externalID+	       <|>+	       publicID+	     )+      skipS0+      return [mkDTDElem NOTATION ((a_name, n) : eid) []]++publicID		:: SParser Attributes+publicID+    = do+      _ <- XT.keyword k_public+      skipS+      l <- XT.pubidLiteral+      return [(k_public, l)]++-- ------------------------------------------------------------++condSectCondBody	:: SParser XmlTrees+condSectCondBody+    = do+      skipS0+      n <- XT.name+      skipS0+      let n' = stringToUpper n+      if n' `elem` [k_include, k_ignore]+	 then return [mkText  n']+	 else fail $ "INCLUDE or IGNORE expected in conditional section"++-- ------------------------------------------------------------++separator	:: Char -> SParser ()+separator c+    = do+      _ <- try ( do+		 skipS0+		 char c+	       )+      skipS0+      <?> [c]+++bar, comma, lpar, rpar	:: SParser ()++bar	= separator '|'+comma	= separator ','++lpar+    = do+      _ <- char '('+      skipS0++rpar+    = do+      skipS0+      _ <- char ')'+      return ()+++-- ------------------------------------------------------------++parseXmlDTDEntityValue	:: XmlTree -> XmlTrees+parseXmlDTDEntityValue t	-- (NTree (XDTD PEREF al) cl)+    | isDTDPEref t+	= ( either+	    ( (:[]) . mkError c_err . (++ "\n") . show )+	    ( \cl' -> if null cl'+                         then [mkText ""]+                         else cl'+	    )+	    .+	    parse parser source+	  ) input+    | otherwise+	= []+    where+    al     = fromMaybe [] . getDTDAttrl $ t+    cl     = getChildren t+    parser = XT.entityTokensT "%&"+    source = "value of parameter entity " ++ lookupDef "" a_peref al+    input  = xshow cl++{-+parseXmlDTDEntityValue n+    = error ("parseXmlDTDEntityValue: illegal argument: " ++ show n)+-}+-- ------------------------------------------------------------++parseXmlDTDdeclPart	:: XmlTree -> XmlTrees+parseXmlDTDdeclPart t		-- @(NTree (XDTD PEREF al) cl)+    | isDTDPEref t+	= ( (:[])+	    .+	    either+	       ( mkError c_err . (++ "\n") . show )+	       ( flip setChildren $ t ) -- \ cl' -> setChildren cl' t)+	    .+	    parse parser source+	  ) input+    | otherwise+	= []+    where+    al     = fromMaybe [] . getDTDAttrl $ t+    cl     = getChildren t+    parser = many XD.dtdToken+    source = "value of parameter entity " ++ lookupDef "" a_peref al+    input  = xshow cl++{-+parseXmlDTDdeclPart n+    = error ("parseXmlDTDdeclPart: illegal argument: " ++ show n)+-}+-- ------------------------------------------------------------+--+-- the main entry point++-- | parse a tokenized DTD declaration represented by a DTD tree.+-- The content is represented by the children containing text and parameter entity reference nodes.+-- The parameter entity reference nodes contain their value in the children list, consisting of text+-- and possibly again parameter entity reference nodes. This structure is build by the parameter entity+-- substitution.+-- Output is again a DTD declaration node, but this time completely parsed and ready for further DTD processing++parseXmlDTDdecl	:: XmlTree -> XmlTrees+parseXmlDTDdecl t	-- (NTree (XDTD dtdElem al) cl)+    | isDTD t+	= ( either ((:[]) . mkError c_err . (++ "\n") . show) id+	    .+	    runParser parser (initialLocalState pos) source+	  ) input+    | otherwise+	= []+    where+    dtdElem = fromJust     . getDTDPart  $ t+    al      = fromMaybe [] . getDTDAttrl $ t+    cl      = getChildren t+    dtdParsers+	= [ (ELEMENT,  elementDeclBody)+	  , (ATTLIST,  attlistDeclBody)+	  , (ENTITY,   entityDeclBody)+	  , (NOTATION, notationDeclBody)+	  , (CONDSECT, condSectCondBody)+	  ]+    source = lookupDef "DTD declaration" a_source al+    line   = lookupDef "1" a_line al+    column = lookupDef "1" a_column al+    pos    = newPos source (read line) (read column)+    parser = do+	     setPosition pos+	     res <- fromJust . lookup dtdElem $ dtdParsers+	     eof+	     return res+    input  = concatMap collectText cl+{-+parseXmlDTDdecl _+    = []+-}++-- | collect the tokens of a DTD declaration body and build+-- a string ready for parsing. The structure of the parameter entity values+-- is stll stored in this string for checking the scope of the parameter values++collectText	:: XmlTree -> String++collectText t+    | isText t+	= fromMaybe "" . getText $ t+    | isDTDPEref t+	= prefixPe ++ concatMap collectText (getChildren t) ++ suffixPe+    | otherwise+	= ""+    where+    al       = fromMaybe [] . getDTDAttrl $ t+    delPe    = "\0"+    prefixPe = delPe ++ lookupDef "???" a_peref al ++ delPe+    suffixPe = delPe ++ delPe++{-++collectText (NTree n _)+    | isXTextNode n+	= textOfXNode n++collectText (NTree (XDTD PEREF al) cl)+    = prefixPe ++ concatMap collectText cl ++ suffixPe+      where+      delPe    = "\0"+      prefixPe = delPe ++ lookupDef "???" a_peref al ++ delPe+      suffixPe = delPe ++ delPe++collectText _+    = ""+-}++isDTDPEref	:: XmlTree -> Bool+isDTDPEref+    = maybe False (== PEREF) . getDTDPart++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/Parser/XmlDTDTokenParser.hs view
@@ -0,0 +1,105 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.Parser.XmlDTDTokenParser+   Copyright  : Copyright (C) 2005 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable+   Version    : $Id: XmlDTDTokenParser.hs,v 1.4 2005/09/02 17:09:39 hxml Exp $++   Parsec parser for tokenizing DTD declarations for ELEMENT, ATTLIST, ENTITY and NOTATION++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.Parser.XmlDTDTokenParser where++import           Text.ParserCombinators.Parsec++import           Yuuko.Text.XML.HXT.DOM.Interface+import           Yuuko.Text.XML.HXT.DOM.XmlNode		( mkDTDElem+							, mkText+							)+import qualified Yuuko.Text.XML.HXT.Parser.XmlTokenParser	as XT++-- ------------------------------------------------------------+--+-- DTD declaration tokenizer++dtdDeclTokenizer	:: GenParser Char state XmlTree+dtdDeclTokenizer+    = do+      (dcl, al) <- dtdDeclStart+      content <- many1 dtdToken+      dtdDeclEnd+      return $! mkDTDElem dcl al content++dtdDeclStart :: GenParser Char state (DTDElem, Attributes)+dtdDeclStart+    = foldr1 (<|>) $+      map (uncurry dtdStart) $+	      [ ("ELEMENT",  ELEMENT )+	      , ("ATTLIST",  ATTLIST )+	      , ("ENTITY",   ENTITY  )+	      , ("NOTATION", NOTATION)+	      ]+    where+    dtdStart	:: String -> DTDElem -> GenParser Char state (DTDElem, Attributes)+    dtdStart dcl element+	= try ( do+		_ <- string "<!"+		_ <- string dcl+		pos <- getPosition+		return (element, [ (a_source, sourceName pos)+				 , (a_line,   show (sourceLine pos))+				 , (a_column, show (sourceColumn pos))+				 ]+		       )+	      )++dtdDeclEnd	:: GenParser Char state ()+dtdDeclEnd+    = do+      _ <- XT.gt+      return ()++dtdToken	:: GenParser Char state XmlTree+dtdToken+    = dtdChars+      <|>+      attrValue+      <|>+      try peReference		-- first try parameter entity ref %xxx;+      <|>+      percent			-- else % may be indicator for parameter entity declaration+      <?> "DTD token"++peReference	:: GenParser Char state XmlTree+peReference+    = do+      r <- XT.peReference+      return $! (mkDTDElem PEREF [(a_peref, r)] [])++attrValue	:: GenParser Char state XmlTree+attrValue+    = do+      v <- XT.attrValue+      return $! mkText v++dtdChars	:: GenParser Char state XmlTree+dtdChars+    = do+      v <- many1 (XT.singleChar "%\"'<>[]")		-- everything except string constants, < and >, [ and ] (for cond sections)+      return $! mkText v				-- all illegal chars will be detected later during declaration parsing++percent		:: GenParser Char state XmlTree+percent+    = do+      c <- char '%'+      return $! mkText [c]++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/Parser/XmlEntities.hs view
@@ -0,0 +1,26 @@+-- |+-- Predefined XML Entity References+--+-- This module defines a table of all+-- predefined XML entity references++module Yuuko.Text.XML.HXT.Parser.XmlEntities+    ( xmlEntities+    )++where++-- ------------------------------------------------------------++-- |+-- list of predefined XML entity names and their unicode values++xmlEntities	:: [(String, Int)]+xmlEntities	= [ ("quot",	34)+		  , ("amp",	38)+		  , ("lt",	60)+		  , ("gt",	62)+		  , ("apos",	39)+		  ]++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/Parser/XmlParsec.hs view
@@ -0,0 +1,691 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.Parser.XmlParsec+   Copyright  : Copyright (C) 2005 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable+   Version    : $Id: XmlParsec.hs,v 1.14 2005/09/02 17:09:39 hxml Exp $++   Xml Parsec parser with pure filter interface++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.Parser.XmlParsec+    ( charData+    , charData'+    , comment+    , pI+    , cDSect+    , document+    , document'+    , prolog+    , xMLDecl+    , xMLDecl'+    , versionInfo+    , misc+    , doctypedecl+    , markupdecl+    , sDDecl+    , element+    , content+    , contentWithTextDecl+    , textDecl+    , encodingDecl+    , xread++    , parseXmlAttrValue+    , parseXmlContent+    , parseXmlDocEncodingSpec+    , parseXmlDocument+    , parseXmlDTDPart+    , parseXmlEncodingSpec+    , parseXmlEntityEncodingSpec+    , parseXmlGeneralEntityValue+    , parseXmlPart+    , parseXmlText++    , parseNMToken+    , parseName++    , removeEncodingSpec+    )+where++import Text.ParserCombinators.Parsec+    ( GenParser+    , Parser+    , parse+    , (<?>), (<|>)+    , char+    , string+    , eof +    , between+    , many, many1+    , option+    , try+    , unexpected+    , getPosition+    , getInput+    , sourceName+    )++import Yuuko.Text.XML.HXT.DOM.ShowXml+    ( xshow+    )++import Yuuko.Text.XML.HXT.DOM.Interface++import Yuuko.Text.XML.HXT.DOM.XmlNode+    ( mkElement+    , mkAttr+    , mkRoot+    , mkDTDElem+    , mkText+    , mkCmt+    , mkCdata+    , mkError+    , mkPi+    , isText+    , isRoot+    , getText+    , getChildren+    , getAttrl+    , getAttrName+    , changeAttrl+    , mergeAttrl+    )++import Yuuko.Text.XML.HXT.Parser.XmlCharParser+    ( xmlChar+    )+import qualified Yuuko.Text.XML.HXT.Parser.XmlTokenParser	as XT+import qualified Yuuko.Text.XML.HXT.Parser.XmlDTDTokenParser	as XD++import Data.Char	(toLower)+import Data.Maybe++-- ------------------------------------------------------------+--+-- Character Data (2.4)++charData		:: GenParser Char state XmlTrees+charData+    = many (charData' <|> XT.referenceT)++charData'		:: GenParser Char state XmlTree+charData'+    = try ( do+	    t <- XT.allBut1 many1 (\ c -> not (c `elem` "<&")) "]]>"+	    return (mkText $! t)+	  )++-- ------------------------------------------------------------+--+-- Comments (2.5)++comment		:: GenParser Char state XmlTree++comment+    = ( do+	c <- between (try $ string "<!--") (string "-->") (XT.allBut many "--")+	return (mkCmt $! c)+      ) <?> "comment"++-- ------------------------------------------------------------+--+-- Processing Instructions++pI		:: GenParser Char state XmlTree+pI+    = between (try $ string "<?") (string "?>")+      ( do+	n <- pITarget+	p <- option "" (do+			_ <- XT.sPace+			XT.allBut many "?>"+		       )+	return $ mkPi (mkName n) [mkAttr (mkName a_value) [mkText p]]+      ) <?> "processing instruction"+      where+      pITarget	:: GenParser Char state String+      pITarget = ( do+		   n <- XT.name+		   if map toLower n == t_xml+		      then unexpected n+		      else return n+		 )++-- ------------------------------------------------------------+--+-- CDATA Sections (2.7)++cDSect		:: GenParser Char state XmlTree++cDSect+    = do+      t <- between ( try $ string "<![CDATA[") (string "]]>") (XT.allBut many "]]>")+      return (mkCdata $! t)+      <?> "CDATA section"++-- ------------------------------------------------------------+--+-- Document (2.1) and Prolog (2.8)++document	:: GenParser Char state XmlTree+document+    = do+      pos <- getPosition+      dl <- document'+      return $ mkRoot [ mkAttr (mkName a_source) [mkText (sourceName pos)]+		      , mkAttr (mkName a_status) [mkText (show c_ok)]+		      ] dl++document'	:: GenParser Char state XmlTrees+document'+    = do+      pl <- prolog+      el <- element+      ml <- many misc+      eof+      return (pl ++ [el] ++ ml)++prolog		:: GenParser Char state XmlTrees+prolog+    = do+      xml     <- option [] xMLDecl'+      misc1   <- many misc+      dtdPart <- option [] doctypedecl+      misc2   <- many misc+      return (xml ++ misc1 ++ dtdPart ++ misc2)++xMLDecl		:: GenParser Char state XmlTrees+xMLDecl+    = between (try $ string "<?xml") (string "?>")+      ( do+	vi <- versionInfo+	ed <- option [] encodingDecl+	sd <- option [] sDDecl+	XT.skipS0+	return (vi ++ ed ++ sd)+      )+      <?> "xml declaration"++xMLDecl'	:: GenParser Char state XmlTrees+xMLDecl'+    = do+      al <- xMLDecl+      return [mkPi (mkName t_xml) al]++xMLDecl''	:: GenParser Char state XmlTree+xMLDecl''+    = do+      al     <- option [] (try xMLDecl)+      return (mkRoot al [])++versionInfo	:: GenParser Char state XmlTrees+versionInfo+    = ( do+	_ <- try ( do+		   XT.skipS+		   XT.keyword a_version+		 )+	XT.eq+	vi <- XT.quoted XT.versionNum+	return [mkAttr (mkName a_version) [mkText vi]]+      )+      <?> "version info (with quoted version number)"++misc		:: GenParser Char state XmlTree+misc+    = comment+      <|>+      pI+      <|>+      ( ( do+	  ws <- XT.sPace+	  return (mkText ws)+	) <?> ""+      )++-- ------------------------------------------------------------+--+-- Document Type definition (2.8)++doctypedecl	:: GenParser Char state XmlTrees+doctypedecl+    = between (try $ string "<!DOCTYPE") (char '>')+      ( do+	XT.skipS+	n <- XT.name+	exId <- option [] ( try ( do+				  XT.skipS+				  externalID+				)+			  )+	XT.skipS0+	markup <- option []+	          ( do+		    m <- between (char '[' ) (char ']') markupOrDeclSep+		    XT.skipS0+		    return m+		  )+	return [mkDTDElem DOCTYPE ((a_name, n) : exId) markup]+      )++markupOrDeclSep	:: GenParser Char state XmlTrees+markupOrDeclSep+    = ( do+	ll <- many ( markupdecl+		     <|>+		     declSep+		     <|>+		     XT.mkList conditionalSect+		   )+	return (concat ll)+      )++declSep		:: GenParser Char state XmlTrees+declSep+    = XT.mkList XT.peReferenceT+      <|>+      ( do+	XT.skipS+	return []+      )++markupdecl	:: GenParser Char state XmlTrees+markupdecl+    = XT.mkList+      ( pI+	<|>+	comment+	<|>+	XD.dtdDeclTokenizer+      )++-- ------------------------------------------------------------+--+-- Standalone Document Declaration (2.9)++sDDecl		:: GenParser Char state XmlTrees+sDDecl+    = do+      _ <- try (do+		XT.skipS+		XT.keyword a_standalone+	       )+      XT.eq+      sd <- XT.quoted (XT.keywords [v_yes, v_no])+      return [mkAttr (mkName a_standalone) [mkText sd]]++-- ------------------------------------------------------------+--+-- element, tags and content (3, 3.1)++element		:: GenParser Char state XmlTree+element+    = ( do+	e <- elementStart+	elementRest e+      ) <?> "element"++elementStart		:: GenParser Char state (String, [(String, XmlTrees)])+elementStart+    = do+      n <- ( try ( do+		   _ <- char '<'+		   n <- XT.name+		   return n+		 )+	     <?> "start tag"+	   )+      ass <- attrList+      XT.skipS0+      return (n, ass)+      where+      attrList+	  = option [] ( do+			XT.skipS+			attrList'+		      )+      attrList'+	  = option [] ( do+			a1 <- attribute+			al <- attrList+			let (n, _v) = a1+			if isJust . lookup n $ al+			  then unexpected ("attribute name " ++ show n ++ " occurs twice in attribute list")+			  else return (a1 : al)+		      )++elementRest	:: (String, [(String, XmlTrees)]) -> GenParser Char state XmlTree+elementRest (n, al)+    = ( do+	_ <- try $ string "/>"+	return $! (mkElement (mkName n) (map (mkA $!) al) [])+      )+      <|>+      ( do+	_ <- XT.gt+	c <- content+	eTag n+	return $! (mkElement (mkName n) (map (mkA $!) al) $! c)+      )+      <?> "proper attribute list followed by \"/>\" or \">\""+    where+    mkA (n', ts') = mkAttr (mkName n') ts'++eTag		:: String -> GenParser Char state ()+eTag n'+    = do+      _ <- try ( string "</" ) <?> ""+      n <- XT.name+      XT.skipS0+      _ <- XT.gt+      if n == n'+	 then return ()+	 else unexpected ("illegal end tag </" ++ n ++ "> found, </" ++ n' ++ "> expected")++attribute	:: GenParser Char state (String, XmlTrees)+attribute+    = do+      n <- XT.name+      XT.eq+      v <- XT.attrValueT+      return (n, v)++content		:: GenParser Char state XmlTrees+content+    = do+      c1 <- charData+      cl <- many+	    ( do+	      l <- ( element+		     <|>+		     cDSect+		     <|>+		     pI+		     <|>+		     comment+		   )+	      c <- charData+	      return (l : c)+	    )+      return (c1 ++ concat cl)++contentWithTextDecl	:: GenParser Char state XmlTrees+contentWithTextDecl+    = do+      _ <- option [] textDecl+      content++-- ------------------------------------------------------------+--+-- Conditional Sections (3.4)+--+-- conditional sections are parsed in two steps,+-- first the whole content is detected,+-- and then, after PE substitution include sections are parsed again++conditionalSect		:: GenParser Char state XmlTree+conditionalSect+    = do+      _ <- try $ string "<!["+      cs <- many XD.dtdToken+      _ <- char '['+      sect <- condSectCont+      return (mkDTDElem CONDSECT [(a_value, sect)] cs)+    where++    condSectCont	:: GenParser Char state String+    condSectCont+	= ( do+	    _ <- try $ string "]]>"+	    return ""+	  )+          <|>+	  ( do+	    _ <- try $ string "<!["+	    cs1 <- condSectCont+	    cs2 <- condSectCont+	    return ("<![" ++ cs1 ++ "]]>" ++ cs2)+	  )+	  <|>+	  ( do+	    c  <- xmlChar+	    cs <- condSectCont+	    return (c : cs)+	  )++-- ------------------------------------------------------------+--+-- External Entities (4.2.2)++externalID	:: GenParser Char state Attributes+externalID+    = ( do+	_ <- XT.keyword k_system+	XT.skipS+	lit <- XT.systemLiteral+	return [(k_system, lit)]+      )+      <|>+      ( do+	_ <- XT.keyword k_public+	XT.skipS+	pl <- XT.pubidLiteral+	XT.skipS+	sl <- XT.systemLiteral+	return [ (k_system, sl)+	       , (k_public, pl) ]+      )+      <?> "SYSTEM or PUBLIC declaration"++-- ------------------------------------------------------------+--+-- Text Declaration (4.3.1)++textDecl	:: GenParser Char state XmlTrees+textDecl+    = between (try $ string "<?xml") (string "?>")+      ( do+	vi <- option [] versionInfo+	ed <- encodingDecl+	XT.skipS0+	return (vi ++ ed)+      )+      <?> "text declaration"+++textDecl''	:: GenParser Char state XmlTree+textDecl''+    = do+      al    <- option [] (try textDecl)+      return (mkRoot al [])++-- ------------------------------------------------------------+--+-- Encoding Declaration (4.3.3)++encodingDecl	:: GenParser Char state XmlTrees+encodingDecl+    = do+      _ <- try ( do+		 XT.skipS+		 XT.keyword a_encoding+	       )+      XT.eq+      ed <- XT.quoted XT.encName+      return [mkAttr (mkName a_encoding) [mkText ed]]++-- ------------------------------------------------------------+--+-- the main entry points:+--	parsing the content of a text node+--	or parsing the text children from a tag node++-- |+-- the inverse function to 'xshow', (for XML content).+--+-- the string parameter is parsed with the XML content parser.+-- result is the list of trees or in case of an error a single element list with the+-- error message as node. No entity or character subtitution is done.+--+-- see also: 'parseXmlContent'++xread			:: String -> XmlTrees+xread str+    = parseXmlFromString parser loc str+    where+    loc = "string: " ++ show (if length str > 40 then take 40 str ++ "..." else str)+    parser = do+	     res <- content		-- take the content parser for parsing the string+	     eof			-- and test on everything consumed+	     return res++-- |+-- the filter version of 'xread'++parseXmlContent		:: XmlTree -> XmlTrees+parseXmlContent+    = xread . xshow . (:[])++-- |+-- a more general version of 'parseXmlContent'.+-- The parser to be used and the context are extra parameter++parseXmlText		:: Parser XmlTrees -> String -> XmlTree -> XmlTrees+parseXmlText p loc	= parseXmlFromString p loc . xshow . (:[])++parseXmlDocument	:: String -> String -> XmlTrees+parseXmlDocument	= parseXmlFromString document'+++parseXmlFromString	:: Parser XmlTrees -> String -> String -> XmlTrees+parseXmlFromString parser loc+    = either ((:[]) . mkError c_err . (++ "\n") . show) id . parse parser loc++-- ------------------------------------------------------------+--++removeEncodingSpec	:: XmlTree -> XmlTrees+removeEncodingSpec t+    | isText t+	= ( either ((:[]) . mkError c_err . (++ "\n") . show) ((:[]) . mkText)+	    . parse parser "remove encoding spec"+	    . fromMaybe ""+	    . getText+	  ) t+    | otherwise+	= [t]+    where+    parser :: Parser String+    parser = do+	     _ <- option [] textDecl+	     getInput++-- ------------------------------------------------------------++-- |+-- general parser for parsing arbitray parts of a XML document++parseXmlPart	:: Parser XmlTrees -> String -> String -> XmlTree -> XmlTrees+parseXmlPart parser expected context t+    = parseXmlText ( do+		     res <- parser+		     eof <?> expected+		     return res+		   ) context+      $ t++-- ------------------------------------------------------------++-- |+-- Parser for parts of a DTD++parseXmlDTDPart	:: String -> XmlTree -> XmlTrees+parseXmlDTDPart+    = parseXmlPart markupOrDeclSep "markup declaration"++-- ------------------------------------------------------------++-- |+-- Parser for general entites++parseXmlGeneralEntityValue	:: String -> XmlTree -> XmlTrees+parseXmlGeneralEntityValue+    = parseXmlPart content "general entity value"++-- ------------------------------------------------------------++-- |+-- Parser for attribute values++parseXmlAttrValue	:: String -> XmlTree -> XmlTrees+parseXmlAttrValue+    = parseXmlPart (XT.attrValueT' "<&") "attribute value"++-- ------------------------------------------------------------++-- |+-- Parser for NMTOKENs++parseNMToken		:: String -> XmlTree -> XmlTrees+parseNMToken+    = parseXmlPart (many1 XT.nmtokenT) "nmtoken"++-- ------------------------------------------------------------++-- |+-- Parser for XML names++parseName		:: String -> XmlTree -> XmlTrees+parseName+    = parseXmlPart (many1 XT.nameT) "name"++-- ------------------------------------------------------------++-- |+-- try to parse a xml encoding spec.+--+--+--    * 1.parameter encParse :  the parser for the encoding decl+--+--    - 2.parameter root :  a document root+--+--    - returns : the same tree, but with an additional+--			  attribute \"encoding\" in the root node+--			  in case of a valid encoding spec+--			  else the unchanged tree++parseXmlEncodingSpec	:: Parser XmlTree -> XmlTree -> XmlTrees+parseXmlEncodingSpec encDecl x+    = (:[]) .+      ( if isRoot x+	then parseEncSpec+	else id+      ) $ x+    where+    parseEncSpec r+	= case ( parse encDecl source . xshow . getChildren $ r ) of+	  Right t+	      -> changeAttrl (mergeAttrl . fromMaybe [] . getAttrl $ t) r+	  Left _+	      -> r+	where+	-- arrow \"getAttrValue a_source\" programmed on the tree level (oops!)+	source = xshow . concat . map getChildren . filter ((== a_source) . maybe "" qualifiedName . getAttrName) . fromMaybe [] . getAttrl $ r++parseXmlEntityEncodingSpec	:: XmlTree -> XmlTrees+parseXmlEntityEncodingSpec	= parseXmlEncodingSpec textDecl''++parseXmlDocEncodingSpec		:: XmlTree -> XmlTrees+parseXmlDocEncodingSpec		= parseXmlEncodingSpec xMLDecl''++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/Parser/XmlTokenParser.hs view
@@ -0,0 +1,545 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.Parser.XmlTokenParser+   Copyright  : Copyright (C) 2005 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable+   Version    : $Id: XmlTokenParser.hs,v 1.3 2005/09/02 17:09:39 hxml Exp $++   Parsec parser for XML tokens++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.Parser.XmlTokenParser+    ( allBut+    , allBut1+    , asciiLetter+    , attrValue+    , bar+    , charRef+    , comma+    , dq+    , encName+    , entityRef+    , entityValue+    , eq+    , gt+    , keyword+    , keywords+    , lpar+    , lt+    , name+    , names+    , ncName+    , nmtoken+    , nmtokens+    , peReference+    , pubidLiteral+    , qName+    , quoted+    , reference+    , rpar+    , semi+    , separator+    , singleChar+    , singleChars+    , skipS+    , skipS0+    , sPace+    , sPace0+    , sq+    , systemLiteral+    , versionNum++    , concRes+    , mkList++    , nameT+    , nmtokenT++    , entityValueT+    , entityTokensT+    , entityCharT++    , attrValueT+    , attrValueT'++    , referenceT+    , charRefT+    , entityRefT+    , peReferenceT++    , singleCharsT+    )+where++import Text.ParserCombinators.Parsec++import Yuuko.Text.XML.HXT.DOM.Interface++import Yuuko.Text.XML.HXT.DOM.XmlNode+    ( mkDTDElem+    , mkText+    , mkCharRef+    , mkEntityRef+    )++import Yuuko.Text.XML.HXT.DOM.Unicode+    ( isXmlChar+    , intToCharRef+    , intToCharRefHex+    )++import Yuuko.Text.XML.HXT.Parser.XmlCharParser+    ( xmlNameChar+    , xmlNameStartChar+    , xmlNCNameChar+    , xmlNCNameStartChar+    , xmlSpaceChar+    )++-- ------------------------------------------------------------+--+-- Character (2.2) and White Space (2.3)+--+-- Unicode parsers in module XmlCharParser++-- ------------------------------------------------------------++sPace		:: GenParser Char state String+sPace+    = many1 xmlSpaceChar++sPace0		:: GenParser Char state String+sPace0+    = many xmlSpaceChar++skipS		:: GenParser Char state ()+skipS+    = skipMany1 xmlSpaceChar++skipS0		:: GenParser Char state ()+skipS0+    = skipMany xmlSpaceChar++-- ------------------------------------------------------------+--+-- Names and Tokens (2.3)++asciiLetter		:: GenParser Char state Char+asciiLetter+    = satisfy (\ c -> ( c >= 'A' && c <= 'Z' ||+			c >= 'a' && c <= 'z' )+	      )+      <?> "ASCII letter"++name		:: GenParser Char state String+name+    = try ( do+	    s1 <- xmlNameStartChar+	    sl <- many xmlNameChar+	    return (s1 : sl)+	  )+      <?> "Name"++-- Namespaces in XML: Rules [4-5] NCName:++ncName		:: GenParser Char state String+ncName+    = try ( do+	    s1 <- xmlNCNameStartChar+	    sl <- many xmlNCNameChar+	    return (s1 : sl)+	  )+      <?> "NCName"++-- Namespaces in XML: Rules [6-8] QName:++qName		:: GenParser Char state (String, String)+qName+    = do+      s1 <- ncName+      s2 <- option "" ( do+			_ <- char ':'+			ncName+		      )+      return ( if null s2 then (s2, s1) else (s1, s2) )++nmtoken		:: GenParser Char state String+nmtoken+    = try (many1 xmlNameChar)+      <?> "Nmtoken"++names		:: GenParser Char state [String]+names+    = sepBy1 name sPace++nmtokens	:: GenParser Char state [String]+nmtokens+    = sepBy1 nmtoken sPace++-- ------------------------------------------------------------+--+-- Literals (2.3)++singleChar		:: String -> GenParser Char state Char+singleChar notAllowed+    = satisfy (\ c -> isXmlChar c && not (c `elem` notAllowed))++singleChars		:: String -> GenParser Char state String+singleChars notAllowed+    = many1 (singleChar notAllowed)++entityValue	:: GenParser Char state String+entityValue+    = attrValue++attrValueDQ	:: GenParser Char state String+attrValueDQ+    = between dq dq (concRes $ many $ attrChar "<&\"")++attrValueSQ	:: GenParser Char state String+attrValueSQ+    = between sq sq (concRes $ many $ attrChar "<&\'")++attrValue	:: GenParser Char state String+attrValue+    = ( do+	v <- attrValueDQ+	return ("\"" ++ v ++ "\"")+      )+      <|>+      ( do+	v <- attrValueSQ+	return ("'" ++ v ++ "'")+      )+      <?> "attribute value (in quotes)"++attrChar	:: String -> GenParser Char state String+attrChar notAllowed+    = reference+      <|>+      mkList (singleChar notAllowed)+      <?> "legal attribute character or reference"+++systemLiteral		:: GenParser Char state String+systemLiteral+    = between dq dq (many $ noneOf "\"")+      <|>+      between sq sq (many $ noneOf "\'")+      <?> "system literal (in quotes)"++pubidLiteral		:: GenParser Char state String+pubidLiteral+    = between dq dq (many $ pubidChar "\'")+      <|>+      between sq sq (many $ pubidChar "")+      <?> "pubid literal (in quotes)"+      where+      pubidChar		:: String -> GenParser Char state Char+      pubidChar quoteChars+	  = asciiLetter+	    <|>+	    digit+	    <|>+	    oneOf " \r\n"		-- no "\t" allowed, so xmlSpaceChar parser not used+	    <|>+	    oneOf "-()+,./:=?;!*#@$_%"+            <|>+	    oneOf quoteChars++-- ------------------------------------------------------------+--+-- Character and Entity References (4.1)++reference	:: GenParser Char state String+reference+    = ( do+	i <- charRef+	return ("&#" ++ show i ++ ";")+      )+      <|>+      ( do+        n <- entityRef+        return ("&" ++ n ++ ";")+      )+      ++checkCharRef	:: Int -> GenParser Char state Int+checkCharRef i+    = if ( i <= fromEnum (maxBound::Char)+	   && isXmlChar (toEnum i)+	 )+        then return i+	else unexpected ("illegal value in character reference: " ++ intToCharRef i ++ " , in hex: " ++ intToCharRefHex i)++charRef		:: GenParser Char state Int+charRef+    = do+      _ <- try (string "&#x")+      d <- many1 hexDigit+      _ <- semi+      checkCharRef (hexStringToInt d)+      <|>+      do+      _ <- try (string "&#")+      d <- many1 digit+      _ <- semi+      checkCharRef (decimalStringToInt d)+      <?> "character reference"+++entityRef	:: GenParser Char state String+entityRef+    = do+      _ <- char '&'+      n <- name+      _ <- semi+      return n+      <?> "entity reference"++peReference	:: GenParser Char state String+peReference+    = try ( do+	    _ <- char '%'+	    n <- name+	    _ <- semi+	    return n+	  )+      <?> "parameter-entity reference"++-- ------------------------------------------------------------+--+-- 4.3++encName		:: GenParser Char state String+encName+    = do+      c <- asciiLetter+      r <- many (asciiLetter <|> digit <|> oneOf "._-")+      return (c:r)++versionNum	:: GenParser Char state String+versionNum+    = many1 xmlNameChar+++-- ------------------------------------------------------------+--+-- keywords++keyword		:: String -> GenParser Char state String+keyword kw+    = try ( do+	    n <- name+	    if n == kw+	      then return n+	      else unexpected n+	  )+      <?> kw++keywords	:: [String] -> GenParser Char state String+keywords+    = foldr1 (<|>) . map keyword++-- ------------------------------------------------------------+--+-- parser for quoted attribute values++quoted		:: GenParser Char state a -> GenParser Char state a+quoted p+    = between dq dq p+      <|>+      between sq sq p++-- ------------------------------------------------------------+--+-- simple char parsers++dq, sq, lt, gt, semi	:: GenParser Char state Char++dq	= char '\"'+sq	= char '\''+lt	= char '<'+gt	= char '>'+semi	= char ';'++separator	:: Char -> GenParser Char state ()+separator c+    = do+      _ <- try ( do+		 skipS0+		 char c+	       )+      skipS0+      <?> [c]++bar, comma, eq, lpar, rpar	:: GenParser Char state ()++bar	= separator '|'+comma	= separator ','+eq	= separator '='++lpar+    = do+      _ <- char '('+      skipS0++rpar+    = do+      skipS0+      _ <- char ')'+      return ()+++-- ------------------------------------------------------------+--+-- all chars but not a special substring++allBut		:: (GenParser Char state Char -> GenParser Char state String) -> String -> GenParser Char state String+allBut p str+    = allBut1 p (const True) str++allBut1		:: (GenParser Char state Char -> GenParser Char state String) -> (Char -> Bool) -> String -> GenParser Char state String+allBut1 p prd (c:rest)+    = p ( satisfy (\ x -> isXmlChar x && prd x && not (x == c) )+	  <|>+	  try ( do+		_ <- char c+		notFollowedBy ( do+				_ <- try (string rest)+				return c+			      )+		return c+	      )+	)++allBut1 _p _prd str+    = error ("allBut1 _ _ " ++ show str ++ " is undefined")++-- ------------------------------------------------------------+--+-- concatenate parse results++concRes		:: GenParser Char state [[a]] -> GenParser Char state [a]+concRes p+    = do+      sl <- p+      return (concat sl)++mkList		:: GenParser Char state a -> GenParser Char state [a]+mkList p+    = do+      r <- p+      return [r]++-- ------------------------------------------------------------+--+-- token parsers returning XmlTrees+--+-- ------------------------------------------------------------+--+-- Literals (2.3)++nameT		:: GenParser Char state XmlTree+nameT+    = do+      n <- name+      return (mkDTDElem NAME [(a_name, n)] [])++nmtokenT	:: GenParser Char state XmlTree+nmtokenT+    = do+      n <- nmtoken+      return (mkDTDElem NAME [(a_name, n)] [])+++entityValueT	:: GenParser Char state XmlTrees+entityValueT+    =  do+       sl <- between dq dq (entityTokensT "%&\"")+       return sl+       <|>+       do+       sl <- between sq sq (entityTokensT "%&\'")+       return sl+       <?> "entity value (in quotes)"++entityTokensT	:: String -> GenParser Char state XmlTrees+entityTokensT notAllowed+    = many (entityCharT notAllowed)++entityCharT	:: String -> GenParser Char state XmlTree+entityCharT notAllowed+    = peReferenceT+      <|>+      charRefT+      <|>+      bypassedEntityRefT+      <|>+      ( do+	cs <- many1 (singleChar notAllowed)+	return (mkText cs)+      )++attrValueT	:: GenParser Char state XmlTrees+attrValueT+    = between dq dq (attrValueT' "<&\"")+      <|>+      between sq sq (attrValueT' "<&\'")+      <?> "attribute value (in quotes)"++attrValueT'	:: String -> GenParser Char state XmlTrees+attrValueT' notAllowed+    = many ( referenceT <|> singleCharsT notAllowed)++singleCharsT	:: String -> GenParser Char state XmlTree+singleCharsT notAllowed+    = do+      cs <- singleChars notAllowed+      return (mkText cs)++-- ------------------------------------------------------------+--+-- Character and Entity References (4.1)++referenceT	:: GenParser Char state XmlTree+referenceT+    = charRefT+      <|>+      entityRefT++charRefT	:: GenParser Char state XmlTree+charRefT+    = do+      i <- charRef+      return $! (mkCharRef $! i)++entityRefT	:: GenParser Char state XmlTree+entityRefT+    = do+      n <- entityRef+      return $! (mkEntityRef $! n)++bypassedEntityRefT	:: GenParser Char state XmlTree+bypassedEntityRefT+    = do+      n <- entityRef+      return $! (mkText ("&" ++ n ++ ";"))++peReferenceT	:: GenParser Char state XmlTree+peReferenceT+    = do+      r <- peReference+      return $! (mkDTDElem PEREF [(a_peref, r)] [])++-- ------------------------------------------------------------++
+ src/Yuuko/Text/XML/HXT/RelaxNG.hs view
@@ -0,0 +1,24 @@+-- |+-- This helper module exports elements from the basic Relax NG libraries:+-- Validator, CreatePattern, PatternToString and DataTypes.+-- It is the main entry point to the Relax NG schema validator of the Haskell+-- XML Toolbox.+--+-- Author : Torben Kuseler+--+-- Version : $Id: RelaxNG.hs,v 1.1 2005/09/02 17:09:39 hxml Exp $++module Yuuko.Text.XML.HXT.RelaxNG+  ( module Yuuko.Text.XML.HXT.RelaxNG.PatternToString+  , module Yuuko.Text.XML.HXT.RelaxNG.Validator+  , module Yuuko.Text.XML.HXT.RelaxNG.DataTypes+  , module Yuuko.Text.XML.HXT.RelaxNG.CreatePattern+  , module Yuuko.Text.XML.HXT.RelaxNG.XmlSchema.RegexMatch+  )+where++import Yuuko.Text.XML.HXT.RelaxNG.PatternToString+import Yuuko.Text.XML.HXT.RelaxNG.Validator+import Yuuko.Text.XML.HXT.RelaxNG.DataTypes+import Yuuko.Text.XML.HXT.RelaxNG.CreatePattern+import Yuuko.Text.XML.HXT.RelaxNG.XmlSchema.RegexMatch
+ src/Yuuko/Text/XML/HXT/RelaxNG/BasicArrows.hs view
@@ -0,0 +1,326 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.RelaxNG.BasicArrows+   Copyright  : Copyright (C) 2005 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable+   Version    : $Id$++   Constants and basic arrows for Relax NG++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.RelaxNG.BasicArrows+where++import Yuuko.Control.Arrow.ListArrows++import Yuuko.Text.XML.HXT.DOM.Interface+import Yuuko.Text.XML.HXT.Arrow.XmlArrow+    hiding+    ( mkText+    , mkError+    )++hasRngName 	:: ArrowXml a => String -> a XmlTree XmlTree+hasRngName s+    = hasName s +      `orElse`+      ( hasLocalPart s >>> hasNamespaceUri relaxNamespace )++checkRngName :: ArrowXml a => [String] -> a XmlTree XmlTree+checkRngName l+    = ( isElem+	>>>+	catA (map hasRngName l)+      )+      `guards` this++noOfChildren	:: ArrowXml a => (Int -> Bool) -> a XmlTree XmlTree+noOfChildren p+    = getChildren+      >>.+      (\ l -> if p (length l) then l else [])++-- ------------------------------------------------------------++isAttributeRef	:: ArrowXml a => a XmlTree XmlTree+isAttributeRef+    = checkRngName ["attribute", "ref"]++isAttributeRefTextListGroupInterleaveOneOrMoreEmpty	:: ArrowXml a => a XmlTree XmlTree+isAttributeRefTextListGroupInterleaveOneOrMoreEmpty+    = checkRngName ["attribute", "ref", "text", "list", "group", "interleave", "oneOrMore", "empty"]++isAttributeRefTextListInterleave	:: ArrowXml a => a XmlTree XmlTree+isAttributeRefTextListInterleave+    = checkRngName ["attribute", "ref", "text", "list", "interleave"]++isAttributeListGroupInterleaveOneOrMore	:: ArrowXml a => a XmlTree XmlTree+isAttributeListGroupInterleaveOneOrMore+    = checkRngName ["attribute", "list", "group", "interleave", "oneOrMore"]++isExternalRefInclude	:: ArrowXml a => a XmlTree XmlTree+isExternalRefInclude+    = checkRngName ["externalRef", "include"]++isNameNsNameValue	:: ArrowXml a => a XmlTree XmlTree+isNameNsNameValue+    = checkRngName ["name", "nsName", "value"]++isNameNsName	:: ArrowXml a => a XmlTree XmlTree+isNameNsName+    = checkRngName ["name", "nsName"]++isNameAnyNameNsName	:: ArrowXml a => a XmlTree XmlTree+isNameAnyNameNsName+    = checkRngName ["name", "anyName", "nsName"]++isDefineOneOrMoreZeroOrMoreOptionalListMixed	:: ArrowXml a => a XmlTree XmlTree+isDefineOneOrMoreZeroOrMoreOptionalListMixed+    = checkRngName ["define", "oneOrMore", "zeroOrMore", "optional", "list", "mixed"]++isChoiceGroupInterleave	:: ArrowXml a => a XmlTree XmlTree+isChoiceGroupInterleave+    = checkRngName ["choice", "group", "interleave"]++isChoiceGroupInterleaveOneOrMore	:: ArrowXml a => a XmlTree XmlTree+isChoiceGroupInterleaveOneOrMore+    = checkRngName ["choice", "group", "interleave", "oneOrMore"]++isGroupInterleave	:: ArrowXml a => a XmlTree XmlTree+isGroupInterleave+    = checkRngName ["group", "interleave"]++-- ------------------------------------------------------------++isRngAnyName		:: ArrowXml a => a XmlTree XmlTree+isRngAnyName		= isElem >>> hasRngName "anyName"++isRngAttribute		:: ArrowXml a => a XmlTree XmlTree+isRngAttribute		= isElem >>> hasRngName "attribute"++isRngChoice		:: ArrowXml a => a XmlTree XmlTree+isRngChoice		= isElem >>> hasRngName "choice"++isRngCombine		:: ArrowXml a => a XmlTree XmlTree+isRngCombine		= isElem >>> hasRngName "combine"++isRngData		:: ArrowXml a => a XmlTree XmlTree+isRngData		= isElem >>> hasRngName "data"++isRngDefine		:: ArrowXml a => a XmlTree XmlTree+isRngDefine		= isElem >>> hasRngName "define"++isRngDiv		:: ArrowXml a => a XmlTree XmlTree+isRngDiv		= isElem >>> hasRngName "div"++isRngElement		:: ArrowXml a => a XmlTree XmlTree+isRngElement		= isElem >>> hasRngName "element"++isRngEmpty		:: ArrowXml a => a XmlTree XmlTree+isRngEmpty		= isElem >>> hasRngName "empty"++isRngExcept		:: ArrowXml a => a XmlTree XmlTree+isRngExcept		= isElem >>> hasRngName "except"++isRngExternalRef	:: ArrowXml a => a XmlTree XmlTree+isRngExternalRef	= isElem >>> hasRngName "externalRef"++isRngGrammar		:: ArrowXml a => a XmlTree XmlTree+isRngGrammar		= isElem >>> hasRngName "grammar"++isRngGroup		:: ArrowXml a => a XmlTree XmlTree+isRngGroup		= isElem >>> hasRngName "group"++isRngInclude		:: ArrowXml a => a XmlTree XmlTree+isRngInclude		= isElem >>> hasRngName "include"++isRngInterleave		:: ArrowXml a => a XmlTree XmlTree+isRngInterleave		= isElem >>> hasRngName "interleave"++isRngList		:: ArrowXml a => a XmlTree XmlTree+isRngList		= isElem >>> hasRngName "list"++isRngMixed		:: ArrowXml a => a XmlTree XmlTree+isRngMixed		= isElem >>> hasRngName "mixed"++isRngName		:: ArrowXml a => a XmlTree XmlTree+isRngName		= isElem >>> hasRngName "name"++isRngNotAllowed		:: ArrowXml a => a XmlTree XmlTree+isRngNotAllowed		= isElem >>> hasRngName "notAllowed"++isRngNsName		:: ArrowXml a => a XmlTree XmlTree+isRngNsName		= isElem >>> hasRngName "nsName"++isRngOneOrMore		:: ArrowXml a => a XmlTree XmlTree+isRngOneOrMore		= isElem >>> hasRngName "oneOrMore"++isRngOptional		:: ArrowXml a => a XmlTree XmlTree+isRngOptional		= isElem >>> hasRngName "optional"++isRngParam		:: ArrowXml a => a XmlTree XmlTree+isRngParam		= isElem >>> hasRngName "param"++isRngParentRef		:: ArrowXml a => a XmlTree XmlTree+isRngParentRef		= isElem >>> hasRngName "parentRef"++isRngRef		:: ArrowXml a => a XmlTree XmlTree+isRngRef		= isElem >>> hasRngName "ref"++isRngRelaxError		:: ArrowXml a => a XmlTree XmlTree+isRngRelaxError		= isElem >>> hasRngName "relaxError"++isRngStart		:: ArrowXml a => a XmlTree XmlTree+isRngStart		= isElem >>> hasRngName "start"++isRngText		:: ArrowXml a => a XmlTree XmlTree+isRngText		= isElem >>> hasRngName "text"++isRngType		:: ArrowXml a => a XmlTree XmlTree+isRngType		= isElem >>> hasRngName "type"++isRngValue		:: ArrowXml a => a XmlTree XmlTree+isRngValue		= isElem >>> hasRngName "value"++isRngZeroOrMore		:: ArrowXml a => a XmlTree XmlTree+isRngZeroOrMore		= isElem >>> hasRngName "zeroOrMore"++-- ------------------------------------------------------------++mkRngElement		:: ArrowXml a => String -> a n XmlTree -> a n XmlTree -> a n XmlTree+mkRngElement n		= mkElement (mkQName "" n relaxNamespace)++mkRngChoice		:: ArrowXml a => a n XmlTree -> a n XmlTree -> a n XmlTree+mkRngChoice		= mkRngElement "choice"++mkRngDefine		:: ArrowXml a => a n XmlTree -> a n XmlTree -> a n XmlTree+mkRngDefine		= mkRngElement "define"++mkRngEmpty		:: ArrowXml a => a n XmlTree -> a n XmlTree+mkRngEmpty a		= mkRngElement "empty" a none++mkRngGrammar		:: ArrowXml a => a n XmlTree -> a n XmlTree -> a n XmlTree+mkRngGrammar		= mkRngElement "grammar"++mkRngGroup		:: ArrowXml a => a n XmlTree -> a n XmlTree -> a n XmlTree+mkRngGroup		= mkRngElement "group"++mkRngInterleave		:: ArrowXml a => a n XmlTree -> a n XmlTree -> a n XmlTree+mkRngInterleave		= mkRngElement "interleave"++mkRngName		:: ArrowXml a => a n XmlTree -> a n XmlTree -> a n XmlTree+mkRngName		= mkRngElement "name"++mkRngNotAllowed		:: ArrowXml a => a n XmlTree -> a n XmlTree -> a n XmlTree+mkRngNotAllowed		= mkRngElement "notAllowed"++mkRngOneOrMore		:: ArrowXml a => a n XmlTree -> a n XmlTree -> a n XmlTree+mkRngOneOrMore		= mkRngElement "oneOrMore"++mkRngRef		:: ArrowXml a => a n XmlTree -> a n XmlTree -> a n XmlTree+mkRngRef		= mkRngElement "ref"++mkRngRelaxError		:: ArrowXml a => a n XmlTree -> a n XmlTree -> a n XmlTree+mkRngRelaxError		= mkRngElement "relaxError"++mkRngStart		:: ArrowXml a => a n XmlTree -> a n XmlTree -> a n XmlTree+mkRngStart		= mkRngElement "start"++mkRngText		:: ArrowXml a => a n XmlTree -> a n XmlTree+mkRngText a		= mkRngElement "text" a none++-- ------------------------------------------------------------++setRngName		:: ArrowXml a => String -> a XmlTree XmlTree+setRngName n		= setElemName (mkQName "" n relaxNamespace)++setRngNameDiv		:: ArrowXml a => a XmlTree XmlTree+setRngNameDiv		= setRngName "div"++setRngNameRef		:: ArrowXml a => a XmlTree XmlTree+setRngNameRef		= setRngName "ref"++-- ------------------------------------------------------------++-- Attributes++isRngAttrAttribute		:: ArrowXml a => a XmlTree XmlTree+isRngAttrAttribute		= isAttr >>> hasRngName "attribute"++isRngAttrCombine		:: ArrowXml a => a XmlTree XmlTree+isRngAttrCombine		= isAttr >>> hasRngName "combine"++isRngAttrDatatypeLibrary	:: ArrowXml a => a XmlTree XmlTree+isRngAttrDatatypeLibrary	= isAttr >>> hasRngName "datatypeLibrary"++isRngAttrHref			:: ArrowXml a => a XmlTree XmlTree+isRngAttrHref			= isAttr >>> hasRngName "href"++isRngAttrName			:: ArrowXml a => a XmlTree XmlTree+isRngAttrName			= isAttr >>> hasRngName "name"++isRngAttrNs			:: ArrowXml a => a XmlTree XmlTree+isRngAttrNs			= isAttr >>> hasRngName "ns"++isRngAttrType			:: ArrowXml a => a XmlTree XmlTree+isRngAttrType			= isAttr >>> hasRngName "type"++-- ------------------------------------------------------------++hasRngAttrAttribute		:: ArrowXml a => a XmlTree XmlTree+hasRngAttrAttribute		= hasAttr "attribute"++hasRngAttrCombine		:: ArrowXml a => a XmlTree XmlTree+hasRngAttrCombine		= hasAttr "combine"++hasRngAttrDatatypeLibrary	:: ArrowXml a => a XmlTree XmlTree+hasRngAttrDatatypeLibrary	= hasAttr "datatypeLibrary"++hasRngAttrHref			:: ArrowXml a => a XmlTree XmlTree+hasRngAttrHref			= hasAttr "href"++hasRngAttrName			:: ArrowXml a => a XmlTree XmlTree+hasRngAttrName			= hasAttr "name"++hasRngAttrNs			:: ArrowXml a => a XmlTree XmlTree+hasRngAttrNs			= hasAttr "ns"++hasRngAttrType			:: ArrowXml a => a XmlTree XmlTree+hasRngAttrType			= hasAttr "type"++-- ------------------------------------------------------------++getRngAttrAttribute		:: ArrowXml a => a XmlTree String+getRngAttrAttribute		= getAttrValue "attribute"++getRngAttrCombine		:: ArrowXml a => a XmlTree String+getRngAttrCombine		= getAttrValue "combine"++getRngAttrDatatypeLibrary	:: ArrowXml a => a XmlTree String+getRngAttrDatatypeLibrary	= getAttrValue "datatypeLibrary"++getRngAttrDescr			:: ArrowXml a => a XmlTree String+getRngAttrDescr			= getAttrValue "descr"++getRngAttrHref			:: ArrowXml a => a XmlTree String+getRngAttrHref			= getAttrValue "href"++getRngAttrName			:: ArrowXml a => a XmlTree String+getRngAttrName			= getAttrValue "name"++getRngAttrNs			:: ArrowXml a => a XmlTree String+getRngAttrNs			= getAttrValue "ns"++getRngAttrType			:: ArrowXml a => a XmlTree String+getRngAttrType			= getAttrValue "type"++-- ------------------------------------------------------------+
+ src/Yuuko/Text/XML/HXT/RelaxNG/CreatePattern.hs view
@@ -0,0 +1,349 @@+-- |+-- +-- Creates the 'Pattern' datastructure from a simplified Relax NG schema. +-- The created datastructure is used in the validation algorithm+-- (see also: "Yuuko.Text.XML.HXT.RelaxNG.Validation")++module Yuuko.Text.XML.HXT.RelaxNG.CreatePattern+  ( createPatternFromXmlTree+  , createNameClass+  , firstChild+  , lastChild+  , module Yuuko.Text.XML.HXT.RelaxNG.PatternFunctions+  )+where++import Yuuko.Control.Arrow.ListArrows++import Yuuko.Text.XML.HXT.DOM.Interface++import Yuuko.Text.XML.HXT.Arrow.XmlArrow++import Yuuko.Text.XML.HXT.RelaxNG.DataTypes+import Yuuko.Text.XML.HXT.RelaxNG.BasicArrows+import Yuuko.Text.XML.HXT.RelaxNG.PatternFunctions++import Data.Maybe+    ( fromMaybe )++import Data.List+    ( isPrefixOf )++-- ------------------------------------------------------------++-- | Creates the 'Pattern' datastructure from a simplified Relax NG schema.++createPatternFromXmlTree :: LA XmlTree Pattern+createPatternFromXmlTree = createPatternFromXml $< createEnv+ where+ -- | Selects all define-pattern and creates an environment list.+ -- Each list entry maps the define name to the children of the define-pattern.+ -- The map is used to replace a ref-pattern with the referenced define-pattern.+ createEnv :: LA XmlTree Env+ createEnv = listA $ deep isRngDefine +                     >>> +                     (getRngAttrName &&& getChildren)+++-- | Transforms each XML-element to the corresponding pattern++createPatternFromXml :: Env -> LA XmlTree Pattern+createPatternFromXml env+ = choiceA [+     isRoot                            :-> processRoot env,+     isRngEmpty      :-> constA Empty,+     isRngNotAllowed :-> mkNotAllowed,+     isRngText       :-> constA Text,+     isRngChoice     :-> mkRelaxChoice env,+     isRngInterleave :-> mkRelaxInterleave env,+     isRngGroup      :-> mkRelaxGroup env,+     isRngOneOrMore  :-> mkRelaxOneOrMore env,+     isRngList       :-> mkRelaxList env,+     isRngData       :-> mkRelaxData env,+     isRngValue      :-> mkRelaxValue,+     isRngAttribute  :-> mkRelaxAttribute env,+     isRngElement    :-> mkRelaxElement env,+     isRngRef        :-> mkRelaxRef env,+     this                              :-> mkRelaxError ""+   ]++              +processRoot :: Env -> LA XmlTree Pattern+processRoot env+  = getChildren+    >>> +    choiceA [+      isRngRelaxError :-> (mkRelaxError $< getRngAttrDescr),+      isRngGrammar    :-> (processGrammar env),+      this                              :-> (mkRelaxError "no grammar-pattern in schema")+    ]+++processGrammar :: Env -> LA XmlTree Pattern+processGrammar env+  = getChildren+    >>> +    choiceA [+      isRngDefine     :-> none,+      isRngRelaxError :-> (mkRelaxError $< getAttrValue "desc"),+      isRngStart      :-> (getChildren >>> createPatternFromXml env),+      this            :-> (mkRelaxError "no start-pattern in schema")+    ]+++{- |+  Transforms a ref-element.+  The value of the name-attribute is looked up in the environment list+  to find the corresponding define-pattern. +  Haskells lazy-evaluation is used to transform circular structures.+-}+mkRelaxRef :: Env -> LA XmlTree Pattern+mkRelaxRef e+ = getRngAttrName+   >>>+   arr (\n -> fromMaybe (notAllowed $ "define-pattern with name " ++ n ++ " not found")+              . lookup n $ transformEnv e+       )+ where+ transformEnv :: [(String, XmlTree)] -> [(String, Pattern)]+ transformEnv env = [ (treeName, (transformEnvElem tree env)) | (treeName, tree) <- env]+ transformEnvElem :: XmlTree -> [(String, XmlTree)] -> Pattern+ transformEnvElem tree env = head $ runLA (createPatternFromXml env) tree +++-- | Transforms a notAllowed-element.+mkNotAllowed :: LA XmlTree Pattern+mkNotAllowed = constA $ notAllowed "notAllowed-pattern in Relax NG schema definition"+++-- | Creates an error message.+mkRelaxError :: String -> LA XmlTree Pattern+mkRelaxError errStr+ = choiceA [+     isRngRelaxError :-> (getRngAttrDescr >>> arr notAllowed),+     isElem  :-> ( getName+                   >>>+                   arr (\n -> notAllowed $ "Pattern " ++ n ++ +                                           " is not allowed in Relax NG schema"+                       )+                 ),+     isAttr  :-> ( getName+                   >>>+                   arr (\n -> notAllowed $ "Attribute " ++ n ++ +                                           " is not allowed in Relax NG schema"+                       )+                 ),+     isError :-> (getErrorMsg >>> arr notAllowed),                          +     this    :-> (arr (\e -> notAllowed $ if errStr /= ""+                                          then errStr+                                          else "Can't create pattern from " ++ show e)+                 )+   ]+++-- | Transforms a choice-element.+mkRelaxChoice :: Env -> LA XmlTree Pattern+mkRelaxChoice env+    = ifA ( getChildren >>.+	    ( \ l -> if length l == 1 then l else [] )+	  )+      ( createPatternFromXml env )+      ( getTwoChildrenPattern env >>> arr2 Choice )++-- | Transforms a interleave-element.+mkRelaxInterleave :: Env -> LA XmlTree Pattern+mkRelaxInterleave env+    = getTwoChildrenPattern env+      >>> +      arr2 Interleave+++-- | Transforms a group-element.+mkRelaxGroup :: Env -> LA XmlTree Pattern+mkRelaxGroup env+    = getTwoChildrenPattern env+      >>>+      arr2 Group+++-- | Transforms a oneOrMore-element.+mkRelaxOneOrMore :: Env -> LA XmlTree Pattern+mkRelaxOneOrMore env+    = getOneChildPattern env+      >>> +      arr OneOrMore+++-- | Transforms a list-element.+mkRelaxList :: Env -> LA XmlTree Pattern+mkRelaxList env+    = getOneChildPattern env+      >>>+      arr List+++-- | Transforms a data- or dataExcept-element.+mkRelaxData :: Env -> LA XmlTree Pattern+mkRelaxData env +  = ifA (getChildren >>> isRngExcept)+     (processDataExcept >>> arr3 DataExcept)+     (processData >>> arr2 Data)+  where+  processDataExcept :: LA XmlTree (Datatype, (ParamList, Pattern))+  processDataExcept = getDatatype &&& getParamList &&& +                      ( getChildren+                        >>> +                        isRngExcept+                        >>> +                        getChildren+                        >>>+                        createPatternFromXml env+                      )+  processData :: LA XmlTree (Datatype, ParamList)+  processData = getDatatype &&& getParamList+  getParamList :: LA XmlTree ParamList+  getParamList = listA $ getChildren+                         >>>+                         isRngParam+                         >>> +                         (getRngAttrName &&& (getChildren >>> getText))+         ++-- | Transforms a value-element.+mkRelaxValue :: LA XmlTree Pattern         +mkRelaxValue = getDatatype &&& getValue &&& getContext+               >>>+               arr3 Value +  where+  getContext :: LA XmlTree Context+  getContext = getAttrValue contextBaseAttr &&& getMapping+  getMapping :: LA XmlTree [(Prefix, Uri)]+  getMapping = listA $ getAttrl >>> +                       ( (getName >>> isA (contextAttributes `isPrefixOf`))+                         `guards`+                         ( (getName >>> arr (drop $ length contextAttributes)) +                           &&&+                           (getChildren >>> getText)+                         )+                       )+  getValue :: LA XmlTree String+  getValue = (getChildren >>> getText) `orElse` (constA "")+++getDatatype :: LA XmlTree Datatype+getDatatype = getRngAttrDatatypeLibrary+              &&&+              getRngAttrType+++-- | Transforms a attribute-element.+-- The first child is a 'NameClass', the second (the last) one a pattern.++mkRelaxAttribute :: Env -> LA XmlTree Pattern+mkRelaxAttribute env+    = ( ( firstChild >>> createNameClass )+	&&&+	( lastChild >>> createPatternFromXml env )+      )+      >>>+      arr2 Attribute++-- | Transforms a element-element.+-- The first child is a 'NameClass', the second (the last) one a pattern.+mkRelaxElement :: Env -> LA XmlTree Pattern+mkRelaxElement env+    = ( ( firstChild >>> createNameClass )+	&&&+	( lastChild >>> createPatternFromXml env )+      )+      >>>+      arr2 Element+++-- | Creates a 'NameClass' from an \"anyName\"-, \"nsName\"- or  \"name\"-Pattern, +createNameClass :: LA XmlTree NameClass+createNameClass+    = choiceA+      [ isRngAnyName :-> processAnyName+      , isRngNsName  :-> processNsName+      , isRngName    :-> processName+      , isRngChoice  :-> processChoice+      , this         :-> mkNameClassError+      ]+    where+    processAnyName :: LA XmlTree NameClass+    processAnyName+	= ifA (getChildren >>> isRngExcept)+          ( getChildren+	    >>> getChildren+	    >>> createNameClass+	    >>> arr AnyNameExcept+          )+         ( constA AnyName )++    processNsName :: LA XmlTree NameClass+    processNsName+	= ifA (getChildren >>> isRngExcept)+          ( ( getRngAttrNs +              &&&+              ( getChildren >>> getChildren >>> createNameClass )+            )+            >>> +            arr2 NsNameExcept+          )+          ( getRngAttrNs >>> arr NsName ) ++    processName :: LA XmlTree NameClass+    processName+	= (getRngAttrNs &&& (getChildren >>> getText)) >>> arr2 Name++    processChoice :: LA XmlTree NameClass+    processChoice+	= ( ( firstChild >>> createNameClass )+	    &&&+	    ( lastChild  >>> createNameClass )+	  )+          >>>+	  arr2 NameClassChoice+                        +mkNameClassError :: LA XmlTree NameClass+mkNameClassError +    = choiceA [ isRngRelaxError+                        :-> ( getRngAttrDescr+			      >>>+			      arr NCError+			 )+	      , isElem  :-> ( getName+			      >>>+			      arr (\n -> NCError ("Can't create name class from element " ++ n))+			    )+	      , isAttr  :-> ( getName+			      >>>+			      arr (\n -> NCError ("Can't create name class from attribute: " ++ n))+			    )+	      , isError :-> ( getErrorMsg+			      >>>+			      arr NCError+			    )+	      , this    :-> ( arr (\e ->  NCError $ "Can't create name class from " ++ show e) )      +	      ]+++getOneChildPattern :: Env -> LA XmlTree Pattern+getOneChildPattern env+    = firstChild >>> createPatternFromXml env+++getTwoChildrenPattern :: Env -> LA XmlTree (Pattern, Pattern)+getTwoChildrenPattern env+    = ( getOneChildPattern env )+	&&&+	( lastChild  >>> createPatternFromXml env )++-- | Simple access arrows++firstChild	:: (ArrowTree a, Tree t) => a (t b) (t b)+firstChild	= single getChildren++lastChild	:: (ArrowTree a, Tree t) => a (t b) (t b)+lastChild	= getChildren >>. (take 1 . reverse)
+ src/Yuuko/Text/XML/HXT/RelaxNG/DataTypeLibMysql.hs view
@@ -0,0 +1,169 @@+-- |+-- Datatype library for the MySQL datatypes+--+-- $Id: DataTypeLibMysql.hs,v 1.1 2005/09/02 17:09:39 hxml Exp $++module Yuuko.Text.XML.HXT.RelaxNG.DataTypeLibMysql+  ( mysqlNS+  , mysqlDatatypeLib+  )+where++import Yuuko.Text.XML.HXT.RelaxNG.DataTypeLibUtils  ++import Data.Maybe++-- ------------------------------------------------------------++-- | Namespace of the MySQL datatype library++mysqlNS :: String+mysqlNS = "http://www.mysql.com"+++-- | The main entry point to the MySQL datatype library.+--+-- The 'DTC' constructor exports the list of supported datatypes and params.+-- It also exports the specialized functions to validate a XML instance value with+-- respect to a datatype.++mysqlDatatypeLib :: DatatypeLibrary+mysqlDatatypeLib = (mysqlNS, DTC datatypeAllowsMysql datatypeEqualMysql mysqlDatatypes)+++-- | All supported datatypes of the library+mysqlDatatypes :: AllowedDatatypes+mysqlDatatypes = [ -- numeric types+                   ("SIGNED-TINYINT", numericParams)+                 , ("UNSIGNED-TINYINT", numericParams)+                 , ("SIGNED-SMALLINT", numericParams)+                 , ("UNSIGNED-SMALLINT", numericParams)+                 , ("SIGNED-MEDIUMINT", numericParams)+                 , ("UNSIGNED-MEDIUMINT", numericParams)+                 , ("SIGNED-INT", numericParams)+                 , ("UNSIGNED-INT", numericParams)+                 , ("SIGNED-BIGINT", numericParams)+                 , ("UNSIGNED-BIGINT", numericParams)+                 +                 -- string types+                 , ("CHAR", stringParams)+                 , ("VARCHAR", stringParams)                 +                 , ("BINARY", stringParams)+                 , ("VARBINARY", stringParams)                 +                 , ("TINYTEXT", stringParams)+                 , ("TINYBLOB", stringParams)                 +                 , ("TEXT", stringParams)+                 , ("BLOB", stringParams)                 +                 , ("MEDIUMTEXT", stringParams)+                 , ("MEDIUMBLOB", stringParams)                 +                 , ("LONGTEXT", stringParams)+                 , ("LONGBLOB", stringParams)                 +                 ]+++-- | List of supported string datatypes+stringTypes :: [String]+stringTypes = [ "CHAR"+	      , "VARCHAR"+	      , "BINARY"+	      , "VARBINARY"+              , "TINYTEXT"+	      , "TINYBLOB"+	      , "TEXT"+	      , "BLOB"+              , "MEDIUMTEXT"+	      , "MEDIUMBLOB"+	      , "LONGTEXT"+              , "LONGBLOB"+              ]+++-- | List of supported numeric datatypes+numericTypes :: [String]+numericTypes = [ "SIGNED-TINYINT"+	       , "UNSIGNED-TINYINT"+	       , "SIGNED-SMALLINT"+               , "UNSIGNED-SMALLINT"+	       , "SIGNED-MEDIUMINT"+               , "UNSIGNED-MEDIUMINT"+	       , "SIGNED-INT"+	       , "UNSIGNED-INT"+               , "SIGNED-BIGINT"+	       , "UNSIGNED-BIGINT"+               ]+++-- | List of allowed params for the numeric datatypes+numericParams :: AllowedParams+numericParams = [ rng_maxExclusive+		, rng_minExclusive+                , rng_maxInclusive+		, rng_minInclusive+                ]+                ++-- | List of allowed params for the string datatypes+stringParams :: AllowedParams+stringParams = [ rng_length+	       , rng_maxLength+	       , rng_minLength+	       ]++-- ------------------------------------------------------------+--+-- | Tests whether a XML instance value matches a data-pattern.+                +datatypeAllowsMysql :: DatatypeAllows+datatypeAllowsMysql d params value _+    = performCheck check value+    where+    check+	| isJust ndt	= checkNum (fromJust ndt)+	| isJust sdt	= checkStr (fromJust sdt)+	| otherwise	= failure $ errorMsgDataTypeNotAllowed mysqlNS d params+    checkNum r	= uncurry (numberValid d) r params+    checkStr r	= uncurry (stringValid d) r params+    ndt = lookup d $+	  [ ("SIGNED-TINYINT", ((-128), 127))+	  , ("UNSIGNED-TINYINT", (0, 255))+	  , ("SIGNED-SMALLINT", ((-32768), 32767))+	  , ("UNSIGNED-SMALLINT", (0, 65535))+	  , ("SIGNED-MEDIUMINT", ((-8388608), 8388607))+	  , ("UNSIGNED-MEDIUMINT", (0, 16777215))+	  , ("SIGNED-INT", ((-2147483648), 2147483647))+	  , ("UNSIGNED-INT", (0, 4294967295))+	  , ("SIGNED-BIGINT", ((-9223372036854775808), 9223372036854775807))+	  , ("UNSIGNED-BIGINT", (0, 18446744073709551615))+	  ]+    sdt = lookup d $+	  [ ("CHAR", (0, 255))+	  , ("VARCHAR", (0, 65535))+	  , ("BINARY", (0, 255))    +	  , ("VARBINARY", (0, 65535))+	  , ("TINYTEXT", (0, 256))+	  , ("TINYBLOB", (0, 256))    +	  , ("TEXT", (0, 65536))+	  , ("BLOB", (0, 65536))+	  , ("MEDIUMTEXT", (0, 16777216))+	  , ("MEDIUMBLOB", (0, 16777216))+	  , ("LONGTEXT", (0, 4294967296))+	  , ("LONGBLOB", (0, 4294967296))+	  ]++-- ------------------------------------------------------------++-- | Tests whether a XML instance value matches a value-pattern.++datatypeEqualMysql :: DatatypeEqual+datatypeEqualMysql d s1 _ s2 _+    = performCheck check (s1, s2)+      where+      cmp nf	= arr (\ (x1, x2) -> (nf x1, nf x2))+		  >>>+		  assert (uncurry (==)) (uncurry $ errorMsgEqual d)+      check+	  | d `elem` stringTypes	= cmp id+	  | d `elem` numericTypes	= cmp normalizeNumber+	  | otherwise			= failure $ const (errorMsgDataTypeNotAllowed0 mysqlNS d)++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/RelaxNG/DataTypeLibUtils.hs view
@@ -0,0 +1,407 @@+-- |+-- exports helper functions for the integration of new datatype-libraries++module Yuuko.Text.XML.HXT.RelaxNG.DataTypeLibUtils+  ( errorMsgEqual+  , errorMsgDataTypeNotAllowed+  , errorMsgDataTypeNotAllowed0+  , errorMsgDataTypeNotAllowed2+  , errorMsgDataLibQName+  , errorMsgParam++  , rng_length+  , rng_maxLength+  , rng_minLength+   ,rng_maxExclusive+  , rng_minExclusive+  , rng_maxInclusive+  , rng_minInclusive++  , module Control.Arrow+  , module Yuuko.Text.XML.HXT.DOM.Util+  , module Yuuko.Text.XML.HXT.RelaxNG.Utils+  , module Yuuko.Text.XML.HXT.RelaxNG.DataTypes  ++  , FunctionTable++  , stringValidFT	-- generalized checkString+  , fctTableString	-- minLength, maxLenght, length+  , fctTableList	-- minLength, maxLenght, length++  , stringValid		-- checkString+  , numberValid		-- checkNumeric++  , numParamValid++  , CheckA		-- Check datatype+  , CheckString		-- CheckA String String+  , CheckInteger	-- CheckA Integer Integer++  , performCheck	-- run a CheckA+  , ok			-- always true+  , failure		-- create an error meesage+  , assert		-- create a primitive check from a predicate+  , assertMaybe		-- create a primitive check from a maybe+  , checkWith		-- convert value before checking+  )++where+import Prelude hiding (id, (.))++import Control.Category+import Control.Arrow++import Data.Maybe++import Yuuko.Text.XML.HXT.DOM.Util++import Yuuko.Text.XML.HXT.RelaxNG.DataTypes+import Yuuko.Text.XML.HXT.RelaxNG.Utils++-- ------------------------------------------------------------++newtype CheckA a b	= C { runCheck :: a -> Either String b }++instance Category CheckA where+    id          = C $ Right++    f2 . f1	= C $				-- logical and: f1 and f2 must hold+		  \ x -> case runCheck f1 x of+			 Right y	-> runCheck f2 y+			 Left  e	-> Left e++instance Arrow CheckA where+    arr f	= C ( Right . f )		-- unit: no check, always o.k., just a conversion++    first f1	= C $				-- check 1. component of a pair+		  \ ~(x1, x2) -> case runCheck f1 x1 of+				 Right y1	-> Right (y1, x2)+				 Left  e	-> Left  e++    second f2	= C $				-- check 2. component of a pair+		  \ ~(x1, x2) -> case runCheck f2 x2 of+				 Right y2	-> Right (x1, y2)+				 Left  e	-> Left  e++++instance ArrowZero CheckA where+    zeroArrow	= C $ const (Left "")		-- always false: zero++instance ArrowPlus CheckA where+    f1 <+> f2	= C $				-- logical or+		  \ x -> case runCheck f1 x of+			 Right y1	-> Right y1+			 Left  e1	-> case runCheck f2 x of+					   Right y2	-> Right y2+					   Left  e2	-> Left ( if null e1+								  then e2+								  else+								  if null e2+								  then e1+								  else e1 ++ " or " ++ e2+								)++type CheckString	= CheckA String String+type CheckInteger	= CheckA Integer Integer++-- | run a check and deliver Just an error message or Nothing++performCheck	:: CheckA a b -> a -> Maybe String+performCheck c	= either Just (const Nothing) . runCheck c++-- | always failure++failure		:: (a -> String) -> CheckA a b+failure	msg	= C (Left . msg)++-- | every thing is fine++ok		:: CheckA a a+ok		= arr id++-- | perform a simple check with a predicate p,+--   when the predicate holds, assert acts as identity,+--   else an error message is generated++assert	:: (a -> Bool) -> (a -> String) -> CheckA a a+assert p msg	= C $ \ x -> if p x then Right x else Left (msg x)++-- | perform a simple check with a Maybe function, Nothing indicates error++assertMaybe	:: (a -> Maybe b) -> (a -> String) -> CheckA a b+assertMaybe f msg+    = C $ \ x -> case f x of+                 Nothing	-> Left (msg x)+		 Just y		-> Right y++-- | perform a check, but convert the value before checking++checkWith	:: (a -> b) -> CheckA b c -> CheckA a a+checkWith f c	= C $+		  \ x -> case runCheck c (f x) of+			 Right _	-> Right x+			 Left  e	-> Left  e++-- ------------------------------------------------------------++-- RelaxNG attribute names++rng_length, rng_maxLength, rng_minLength+ ,rng_maxExclusive, rng_minExclusive, rng_maxInclusive, rng_minInclusive :: String++rng_length		= "length"+rng_maxLength		= "maxLength"+rng_minLength		= "minLength"++rng_maxExclusive	= "maxExclusive"+rng_minExclusive	= "minExclusive"+rng_maxInclusive	= "maxInclusive"+rng_minInclusive	= "minInclusive"++-- ------------------------------------------------------------++-- | Function table type++type FunctionTable	= [(String, String -> String -> Bool)]++-- | Function table for numeric tests,+-- XML document value is first operand, schema value second++fctTableNum :: (Ord a, Num a) => [(String, a -> a -> Bool)]+fctTableNum+    = [ (rng_maxExclusive, (<))+      , (rng_minExclusive, (>))+      , (rng_maxInclusive, (<=))+      , (rng_minInclusive, (>=))+      ]++-- | Function table for string tests,+-- XML document value is first operand, schema value second+fctTableString :: FunctionTable+fctTableString+    = [ (rng_length,    (numParamValid (==)))+      , (rng_maxLength, (numParamValid (<=)))+      , (rng_minLength, (numParamValid (>=)))+      ]++-- | Function table for list tests,+-- XML document value is first operand, schema value second++fctTableList :: FunctionTable+fctTableList+    = [ (rng_length,    (listParamValid (==)))+      , (rng_maxLength, (listParamValid (<=)))+      , (rng_minLength, (listParamValid (>=)))+      ]++{- | +tests whether a string value matches a numeric param++valid example:++> <data type="CHAR"> <param name="maxLength">5</param> </data>++invalid example:++> <data type="CHAR"> <param name="minLength">foo</param> </data>++-}++numParamValid :: (Integer -> Integer -> Bool) -> String -> String -> Bool+numParamValid fct a b+  = isNumber b+    &&+    ( toInteger (length a) `fct` (read b) )++{- | +tests whether a list value matches a length constraint++valid example:++> <data type="IDREFS"> <param name="maxLength">5</param> </data>++invalid example:++> <data type="IDREFS"> <param name="minLength">foo</param> </data>++-}++listParamValid :: (Integer -> Integer -> Bool) -> String -> String -> Bool+listParamValid fct a b+  = isNumber b+    &&+    ( toInteger (length . words $ a) `fct` (read b) )++-- ------------------------------------------------------------+-- new check functions++{- | +Tests whether a \"string\" datatype value is between the lower and +upper bound of the datatype and matches all parameters.++All tests are performed on the string value.+   +   * 1.parameter  :  datatype+   +   - 2.parameter  :  lower bound of the datatype range+   +   - 3.parameter  :  upper bound of the datatype range (-1 = no upper bound) +   +   - 4.parameter  :  list of parameters+   +   - 5.parameter  :  datatype value to be checked++   - return : Just \"Errormessage\" in case of an error, else Nothing+   +-}++stringValid 	:: DatatypeName -> Integer -> Integer -> ParamList -> CheckString+stringValid	= stringValidFT fctTableString++stringValidFT :: FunctionTable -> DatatypeName -> Integer -> Integer -> ParamList -> CheckString+stringValidFT ft datatype lowerBound upperBound params+    = assert boundsOK boundsErr+      >>>+      paramsStringValid params+    where+    boundsOK v+	= ( (lowerBound == 0)+	    ||+	    (toInteger (length v) >= lowerBound)+	  )+	  &&+	  ( (upperBound == (-1))+	    ||+	    (toInteger (length v) <= upperBound)+	  )++    boundsErr v+	= "Length of " ++ v+          ++ " (" ++ (show $ length v) ++ " chars) out of range: "+          ++ show lowerBound ++ " .. " ++ show upperBound+          ++ " for datatype " ++ datatype++    paramStringValid :: (LocalName, String) -> CheckString+    paramStringValid (pn, pv)+	= assert paramOK (errorMsgParam pn pv)+	  where+	  paramOK v  = paramFct pn v pv+	  paramFct n = fromMaybe (const . const $ True) $ lookup n ft++    paramsStringValid :: ParamList -> CheckString+    paramsStringValid+	= foldr (>>>) ok . map paramStringValid++-- ------------------------------------------------------------++{- | +Tests whether a \"numeric\" datatype value is between the lower and upper +bound of the datatype and matches all parameters.++First, the string value is parsed into a numeric representation.+If no error occur, all following tests are performed on the numeric value.++   * 1.parameter  :  datatype+   +   - 2.parameter  :  lower bound of the datatype range+   +   - 3.parameter  :  upper bound of the datatype range (-1 = no upper bound) +   +   - 4.parameter  :  list of parameters+   +   - 5.parameter  :  datatype value to be checked++   - return : Just \"Errormessage\" in case of an error, else Nothing+   +-}++numberValid :: DatatypeName -> Integer -> Integer -> ParamList -> CheckString+numberValid datatype lowerBound upperBound params+    = assert isNumber numErr+      >>>+      checkWith read ( assert inRange rangeErr+		       >>>+		       paramsNumValid params+		     )+    where+    inRange	:: Integer -> Bool+    inRange x	= x >= lowerBound+		  &&+		  x <= upperBound++    rangeErr v	= ( "Value = " ++ show v ++ " out of range: "+		    ++ show lowerBound ++ " .. " ++ show upperBound+		    ++ " for datatype " ++ datatype+		  )+    numErr v+	= "Value = " ++ v ++ " is not a number"++paramsNumValid	:: ParamList -> CheckInteger+paramsNumValid+    = foldr (>>>) ok . map paramNumValid++paramNumValid	:: (LocalName, String) -> CheckInteger+paramNumValid (pn, pv)+    = assert paramOK (errorMsgParam pn pv . show)+    where+    paramOK  v = isNumber pv+		 &&+		 paramFct pn v (read pv)+    paramFct n = fromJust $ lookup n fctTableNum++-- ------------------------------------------------------------+    +{- | +Error Message for the equality test of two datatype values+   +   * 1.parameter  :  datatype+   +   - 2.parameter  :  datatype value++   - 3.parameter  :  datatype value+   +example:++> errorMsgEqual "Int" "21" "42" -> "Datatype Int with value = 21 expected, but value = 42 found"++-}++errorMsgParam	:: LocalName -> String -> String -> String+errorMsgParam pn pv v+    = ( "Parameter restriction: \""+	++ pn ++ " = " ++ pv+	++ "\" does not hold for value = \"" ++ v ++ "\""+      )++errorMsgEqual :: DatatypeName -> String -> String -> String+errorMsgEqual d s1 s2+    = ( "Datatype" ++ show d +++	" with value = " ++ show s1 +++	" expected, but value = " ++ show s2 ++ " found" +      )+errorMsgDataTypeNotAllowed :: String -> String -> [(String, String)] -> String -> String+errorMsgDataTypeNotAllowed l t p v+    = ( "Datatype " ++ show t ++ " with parameter(s) " +++        formatStringListPairs p ++ " and value = " ++ show v +++        " not allowed for DatatypeLibrary " ++ show l+      )++errorMsgDataTypeNotAllowed0 :: String -> String -> String+errorMsgDataTypeNotAllowed0 l t+    = ( "Datatype " ++ show t +++        " not allowed for DatatypeLibrary " ++ show l+      )+errorMsgDataTypeNotAllowed2 :: String -> String -> String -> String -> String+errorMsgDataTypeNotAllowed2 l t v1 v2+    = ( "Datatype " ++ show t +++	" with values = " ++ show v1 +++	" and " ++ show v2 ++ +        " not allowed for DatatypeLibrary " ++ show l+      )++errorMsgDataLibQName :: String -> String -> String -> String+errorMsgDataLibQName l n v+    = show v ++ " is not a valid " ++ n ++ " for DatatypeLibrary " ++ l++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/RelaxNG/DataTypeLibraries.hs view
@@ -0,0 +1,140 @@+-- | This modul exports the list of supported datatype libraries.+-- It also exports the main functions to validate an XML instance value+-- with respect to a datatype.++module Yuuko.Text.XML.HXT.RelaxNG.DataTypeLibraries+  ( datatypeLibraries+  , datatypeEqual+  , datatypeAllows+  )+where++import Yuuko.Text.XML.HXT.DOM.Interface+    ( relaxNamespace+    )++import Yuuko.Text.XML.HXT.RelaxNG.DataTypeLibUtils  ++import Yuuko.Text.XML.HXT.RelaxNG.DataTypeLibMysql+    ( mysqlDatatypeLib )++import Yuuko.Text.XML.HXT.RelaxNG.XmlSchema.DataTypeLibW3C+    ( w3cDatatypeLib )++import Data.Maybe+    ( fromJust )++-- ------------------------------------------------------------+    ++-- | List of all supported datatype libraries which can be +-- used within the Relax NG validator modul.++datatypeLibraries :: DatatypeLibraries +datatypeLibraries+    = [ relaxDatatypeLib+      , relaxDatatypeLib'+      , mysqlDatatypeLib+      , w3cDatatypeLib+      ]+++{- |+Tests whether a XML instance value matches a value-pattern.++The following tests are performed:+   +   * 1. :  does the uri exist in the list of supported datatype libraries++   - 2. :  does the library support the datatype+   +   - 3. :  does the XML instance value match the value-pattern+   +The hard work is done by the specialized 'DatatypeEqual' function +(see also: 'DatatypeCheck') of the datatype library.+-}++datatypeEqual :: Uri -> DatatypeEqual  +datatypeEqual uri d s1 c1 s2 c2 +    = if elem uri (map fst datatypeLibraries)  +      then dtEqFct d s1 c1 s2 c2 +      else Just ( "Unknown DatatypeLibrary " ++ show uri )+    where+    DTC _ dtEqFct _ = fromJust $ lookup uri datatypeLibraries++{- |+Tests whether a XML instance value matches a data-pattern.++The following tests are performed:+   +   * 1. :  does the uri exist in the list of supported datatype libraries++   - 2. :  does the library support the datatype+   +   - 3. :  does the XML instance value match the data-pattern+   +   - 4. :  does the XML instance value match all params+   +The hard work is done by the specialized 'DatatypeAllows' function +(see also: 'DatatypeCheck') of the datatype library.+   +-}++datatypeAllows :: Uri -> DatatypeAllows+datatypeAllows uri d params s1 c1 +    = if elem uri (map fst datatypeLibraries)+      then dtAllowFct d params s1 c1 +      else Just ( "Unknown DatatypeLibrary " ++ show uri )+    where+    DTC dtAllowFct _ _ = fromJust $ lookup uri datatypeLibraries+++-- --------------------------------------------------------------------------------------                    +-- Relax NG build in datatype library++relaxDatatypeLib 	:: DatatypeLibrary+relaxDatatypeLib	= (relaxNamespace, DTC datatypeAllowsRelax datatypeEqualRelax relaxDatatypes)++-- | if there is no datatype uri, the built in datatype library is used+relaxDatatypeLib'	:: DatatypeLibrary+relaxDatatypeLib'	= ("",             DTC datatypeAllowsRelax datatypeEqualRelax relaxDatatypes)++-- | The build in Relax NG datatype lib supportes only the token and string datatype,+-- without any params.++relaxDatatypes :: AllowedDatatypes+relaxDatatypes+    = map ( (\ x -> (x, [])) . fst ) relaxDatatypeTable++datatypeAllowsRelax :: DatatypeAllows+datatypeAllowsRelax d p v _ +    = maybe notAllowed' allowed . lookup d $ relaxDatatypeTable+    where+    notAllowed'+	= Just $ errorMsgDataTypeNotAllowed relaxNamespace d p v+    allowed _+	= Nothing++-- | If the token datatype is used, the values have to be normalized+-- (trailing and leading whitespaces are removed).+-- token does not perform any changes to the values.++datatypeEqualRelax :: DatatypeEqual+datatypeEqualRelax d s1 _ s2 _+    = maybe notAllowed' checkValues . lookup d $ relaxDatatypeTable+      where+      notAllowed'+	  = Just $ errorMsgDataTypeNotAllowed2 relaxNamespace d s1 s2+      checkValues predicate+	  = if predicate s1 s2+	    then Nothing+	    else Just $ errorMsgEqual d s1 s2++relaxDatatypeTable :: [(String, String -> String -> Bool)]+relaxDatatypeTable+    = [ ("string", (==))+      , ("token",  \ s1 s2 -> normalizeWhitespace s1 == normalizeWhitespace s2 )+      ]+++-- --------------------------------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/RelaxNG/DataTypes.hs view
@@ -0,0 +1,296 @@+module Yuuko.Text.XML.HXT.RelaxNG.DataTypes+where ++import Yuuko.Text.XML.HXT.DOM.TypeDefs++-- ------------------------------------------------------------++relaxSchemaFile	:: String+relaxSchemaFile = "Text/XML/HXT/RelaxNG/SpecificationSchema.rng"+++relaxSchemaGrammarFile :: String+relaxSchemaGrammarFile = "Text/XML/HXT/RelaxNG/SpecificationSchemaGrammar.rng"++-- ------------------------------------------------------------+-- datatypes for the simplification process++a_numberOfErrors,+ a_relaxSimplificationChanges,+ defineOrigName :: String++a_numberOfErrors             = "numberOfErrors"+a_relaxSimplificationChanges = "relaxSimplificationChanges"+defineOrigName               = "RelaxDefineOriginalName"+++type Env = [(String, XmlTree)]++-- | Start of a context attribute value +-- (see also: 'Yuuko.Text.XML.HXT.RelaxNG.Simplification.simplificationStep1')+--+-- The value is always followed by the original attribute name and value++contextAttributes :: String+contextAttributes = "RelaxContext:"+++-- | Start of base uri attribute value +-- (see also: 'simplificationStep1' in "Yuuko.Text.XML.HXT.RelaxNG.Simplification")++contextBaseAttr :: String+contextBaseAttr = "RelaxContextBaseURI"+++-- see simplificationStep5 in Yuuko.Text.XML.HXT.RelaxNG.Simplification++type OldName = String+type NewName = String+type NamePair = (OldName, NewName)+type RefList = [NamePair]+++-- ------------------------------------------------------------+-- datatype library handling++-- | Type of all datatype libraries functions that tests whether +-- a XML instance value matches a value-pattern.+--+-- Returns Just \"errorMessage\" in case of an error else Nothing.++type DatatypeEqual  = DatatypeName -> String -> Context -> String -> Context -> Maybe String+++-- | Type of all datatype libraries functions that tests whether +-- a XML instance value matches a data-pattern.+--+-- Returns Just \"errorMessage\" in case of an error else Nothing.++type DatatypeAllows = DatatypeName -> ParamList -> String -> Context -> Maybe String+++-- | List of all supported datatype libraries++type DatatypeLibraries = [DatatypeLibrary]+++-- | Each datatype library is identified by a URI.++type DatatypeLibrary   = (Uri, DatatypeCheck)++type DatatypeName      = String++type ParamName         = String+++-- | List of all supported params for a datatype++type AllowedParams     = [ParamName]+++-- | List of all supported datatypes and there allowed params++type AllowedDatatypes  = [(DatatypeName, AllowedParams)]+++-- | The Constructor exports the list of supported datatypes for a library.+-- It also exports the specialized datatype library functions to validate +-- a XML instance value with respect to a datatype.++data DatatypeCheck +  = DTC { dtAllowsFct    :: DatatypeAllows -- ^ function to test whether a value matches a data-pattern+        , dtEqualFct     :: DatatypeEqual -- ^ function to test whether a value matches a value-pattern+        , dtAllowedTypes :: AllowedDatatypes -- ^ list of all supported params for a datatype+        }++-- ------------------------------------------------------------+-- datatypes for the validation process++type Uri = String++type LocalName = String+++-- | List of parameters; each parameter is a pair consisting of a local name and a value.++type ParamList = [(LocalName, String)]++type Prefix = String+++-- | A Context represents the context of an XML element. +-- It consists of a base URI and a mapping from prefixes to namespace URIs.++type Context = (Uri, [(Prefix, Uri)])++-- | A Datatype identifies a datatype by a datatype library name and a local name.++type Datatype = (Uri, LocalName)++showDatatype	:: Datatype -> String+showDatatype (u, ln)+	 | null u	= ln+	 | otherwise	= "{" ++ u ++ "}" ++ ln++-- | Represents a name class++data NameClass = AnyName+               | AnyNameExcept NameClass+               | Name Uri LocalName+               | NsName Uri+               | NsNameExcept Uri NameClass+               | NameClassChoice NameClass NameClass+               | NCError String+               deriving Eq++instance Show NameClass+    where+    show AnyName	= "AnyName"+    show (AnyNameExcept nameClass) +        		= "AnyNameExcept: " ++ show nameClass+    show (Name uri localName)+	| null uri	= localName+	| otherwise	= "{" ++ uri ++ "}" ++ localName+    show (NsName uri)	= "{" ++ uri ++ "}AnyName"+    show (NsNameExcept uri nameClass) +          		= "NsNameExcept: {" ++ uri ++ "}" ++ show nameClass+    show (NameClassChoice nameClass1 nameClass2)+         		= "NameClassChoice: " ++ show nameClass1 ++ "|" ++ show nameClass2+    show (NCError string)+			 = "NCError: " ++ string+++-- | Represents a pattern after simplification++data Pattern = Empty+             | NotAllowed ErrMessage+             | Text+             | Choice Pattern Pattern+             | Interleave Pattern Pattern+             | Group Pattern Pattern+             | OneOrMore Pattern+             | List Pattern+             | Data Datatype ParamList+             | DataExcept Datatype ParamList Pattern+             | Value Datatype String Context+             | Attribute NameClass Pattern+             | Element NameClass Pattern+             | After Pattern Pattern++instance Show Pattern where+    show Empty			= "empty"+    show (NotAllowed e) 	= show e+    show Text			= "text"+    show (Choice p1 p2)		= "( " ++ show p1 ++ " | " ++ show p2 ++ " )"+    show (Interleave p1 p2)	= "( " ++ show p1 ++ " & " ++ show p2 ++ " )"+    show (Group p1 p2)		= "( " ++ show p1 ++ " , " ++ show p2 ++ " )"+    show (OneOrMore p)		= show p ++ "+"+    show (List p)		= "list { " ++ show p ++ " }"+    show (Data dt pl)		= showDatatype dt ++ showPL pl+				  where+				  showPL []	= ""+				  showPL l	= " {" ++ concatMap showP l ++ " }"+				  showP (ln, v) = " " ++ ln ++ " = " ++ show v+    show (DataExcept dt pl p)	= show (Data dt pl) ++ " - (" ++ show p ++ " )"+    show (Value dt v _cx)	= showDatatype dt ++ " " ++ show v+    show (Attribute nc p)	= "attribute " ++ show nc ++ " { " ++ show p ++ " }"+    show (Element nc p)		= "element "   ++ show nc ++ " { " ++ show p ++ " }"+    show (After p1 p2)		=  "( " ++ show p1 ++ " ; " ++ show p2 ++ " )"++data ErrMessage	= ErrMsg ErrLevel [String]+		  -- deriving Show++instance Show ErrMessage where+    show (ErrMsg _lev es) = foldr1 (\ x y -> x ++ "\n" ++ y) es++type ErrLevel	= Int++-- ------------------------------------------------------------++-- smart constructor funtions for Pattern++-- | smart constructor for NotAllowed++notAllowed	:: String -> Pattern+notAllowed	= notAllowedN 0++notAllowed1	:: String -> Pattern+notAllowed1	= notAllowedN 1++notAllowed2	:: String -> Pattern+notAllowed2	= notAllowedN 2++notAllowedN	:: ErrLevel -> String -> Pattern+notAllowedN l s	= NotAllowed (ErrMsg l [s])++-- | merge error messages+--+-- If error levels are different, the more important is taken,+-- if level is 2 (max level) both error messages are taken+-- else the 1. error mesage is taken++mergeNotAllowed	:: Pattern -> Pattern -> Pattern+mergeNotAllowed p1@(NotAllowed (ErrMsg l1 s1)) p2@(NotAllowed (ErrMsg l2 s2))+    | l1 < l2	= p2+    | l1 > l2	= p1+    | l1 == 2	= NotAllowed $ ErrMsg 2 (s1 ++ s2)+    | otherwise	= p1++-- TODO : weird error when collecting error messages errors are duplicated++mergeNotAllowed _p1 _p2+    = notAllowed2 "mergeNotAllowed with wrong patterns"++-- | smart constructor for Choice++choice :: Pattern -> Pattern -> Pattern+choice p1@(NotAllowed _) p2@(NotAllowed _)	= mergeNotAllowed p1 p2+choice p1                   (NotAllowed _)	= p1+choice (NotAllowed _)    p2              	= p2+choice p1                p2	    		= Choice p1 p2++-- | smart constructor for Group++group :: Pattern -> Pattern -> Pattern+group p1@(NotAllowed _)  p2@(NotAllowed _)	= mergeNotAllowed p1 p2+group _                   n@(NotAllowed _)	= n+group   n@(NotAllowed _)  _			= n+group p                  Empty			= p+group Empty              p			= p+group p1                 p2			= Group p1 p2++-- | smart constructor for OneOrMore++oneOrMore :: Pattern -> Pattern+oneOrMore n@(NotAllowed _) = n+oneOrMore p                = OneOrMore p++-- | smart constructor for Interleave++interleave :: Pattern -> Pattern -> Pattern+interleave p1@(NotAllowed _) p2@(NotAllowed _)	= mergeNotAllowed p1 p2+interleave _                 p2@(NotAllowed _)	= p2+interleave p1@(NotAllowed _) _			= p1+interleave p1                Empty		= p1+interleave Empty             p2			= p2+interleave p1		     p2			= Interleave p1 p2++-- | smart constructor for After++after :: Pattern -> Pattern -> Pattern+after p1@(NotAllowed _) p2@(NotAllowed _)	= mergeNotAllowed p1 p2+after _                 p2@(NotAllowed _)	= p2+after p1@(NotAllowed _) _			= p1+after p1                p2			= After p1 p2+++-- | Possible content types of a Relax NG pattern.+-- (see also chapter 7.2 in Relax NG specification)++data ContentType = CTEmpty+                 | CTComplex+                 | CTSimple+                 | CTNone+     deriving (Show, Eq, Ord)++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/RelaxNG/PatternFunctions.hs view
@@ -0,0 +1,108 @@+-- | basic 'Pattern' functions+--++module Yuuko.Text.XML.HXT.RelaxNG.PatternFunctions++where++import Yuuko.Text.XML.HXT.RelaxNG.DataTypes+++-- ------------------------------------------------------------++isRelaxEmpty :: Pattern -> Bool+isRelaxEmpty Empty = True          +isRelaxEmpty _     = False++isRelaxNotAllowed :: Pattern -> Bool+isRelaxNotAllowed (NotAllowed _) = True          +isRelaxNotAllowed _              = False++isRelaxText :: Pattern -> Bool+isRelaxText Text = True          +isRelaxText _    = False++isRelaxChoice :: Pattern -> Bool+isRelaxChoice (Choice _ _) = True          +isRelaxChoice _            = False++isRelaxInterleave :: Pattern -> Bool+isRelaxInterleave (Interleave _ _) = True          +isRelaxInterleave _                = False++isRelaxGroup :: Pattern -> Bool+isRelaxGroup (Group _ _) = True          +isRelaxGroup _           = False++isRelaxOneOrMore :: Pattern -> Bool+isRelaxOneOrMore (OneOrMore _) = True          +isRelaxOneOrMore _             = False++isRelaxList :: Pattern -> Bool+isRelaxList (List _) = True          +isRelaxList _        = False++isRelaxData :: Pattern -> Bool+isRelaxData (Data _ _) = True          +isRelaxData _          = False++isRelaxDataExcept :: Pattern -> Bool+isRelaxDataExcept (DataExcept _ _ _) = True          +isRelaxDataExcept _                  = False++isRelaxValue :: Pattern -> Bool+isRelaxValue (Value _ _ _) = True          +isRelaxValue _             = False++isRelaxAttribute :: Pattern -> Bool+isRelaxAttribute (Attribute _ _) = True          +isRelaxAttribute _               = False++isRelaxElement :: Pattern -> Bool+isRelaxElement (Element _ _) = True          +isRelaxElement _             = False+             +isRelaxAfter :: Pattern -> Bool+isRelaxAfter (After _ _) = True          +isRelaxAfter _           = False+++-- | Returns a list of children pattern for each pattern, +-- e.g. (Choice p1 p2) = [p1, p2]+getChildrenPattern :: Pattern -> [Pattern]+getChildrenPattern (Choice p1 p2) = [p1, p2]+getChildrenPattern (Interleave p1 p2) = [p1, p2]+getChildrenPattern (Group p1 p2) = [p1, p2]+getChildrenPattern (OneOrMore p) = [p]+getChildrenPattern (List p) = [p]+getChildrenPattern (Element _ p) = [p]+getChildrenPattern (DataExcept _ _ p) = [p]+getChildrenPattern (Attribute _ p) = [p]+getChildrenPattern (After p1 p2) = [p1, p2]+getChildrenPattern _ = []+++-- | Returns the nameclass of a element- or attribute pattern.+-- Otherwise 'NCError' is returned.+getNameClassFromPattern :: Pattern -> NameClass+getNameClassFromPattern (Element nc _) = nc+getNameClassFromPattern (Attribute nc _) = nc+getNameClassFromPattern _ = NCError "Pattern without a NameClass"+++-- | Returns a string representation of the pattern name+getPatternName :: Pattern -> String+getPatternName (Empty) = "Empty"+getPatternName (NotAllowed _) = "NotAllowed"+getPatternName (Text) = "Text"+getPatternName (Choice _ _) = "Choice"+getPatternName (Interleave _ _) = "Interleave"+getPatternName (Group _ _) = "Group"+getPatternName (OneOrMore _) = "OneOrMore"+getPatternName (List _) = "List"+getPatternName (Data _ _ ) = "Data"+getPatternName (DataExcept _ _ _) = "DataExcept"+getPatternName (Value _ _ _) = "Value"+getPatternName (Attribute _ _) = "Attribute"+getPatternName (Element _ _) = "Element"+getPatternName (After _ _) = "After"
+ src/Yuuko/Text/XML/HXT/RelaxNG/PatternToString.hs view
@@ -0,0 +1,360 @@+module Yuuko.Text.XML.HXT.RelaxNG.PatternToString+  ( patternToStringTree+  , patternToFormatedString+  , xmlTreeToPatternStringTree+  , xmlTreeToPatternFormatedString+  , xmlTreeToPatternString+  , nameClassToString+  )+where++import Yuuko.Control.Arrow.ListArrows++import Yuuko.Data.Tree.NTree.TypeDefs++import Yuuko.Text.XML.HXT.DOM.Interface++import Yuuko.Text.XML.HXT.RelaxNG.DataTypes+import Yuuko.Text.XML.HXT.RelaxNG.CreatePattern+import Yuuko.Text.XML.HXT.RelaxNG.Utils++-- ------------------------------------------------------------++type PatternTree = NTree String+++{- |+Returns a string representation of the pattern structure.+(see also: 'createPatternFromXmlTree')++Example:++> Element {}foo (Choice (Choice (Value ("","token") "abc"+> ("foo","www.bar.baz")]))(Data ("http://www.mysql.com","VARCHAR")+> [("length","2"),("maxLength","5")])) (Element {}bar (Group (Element {}baz++The function can @not@ be used to display circular ref-pattern structures.+-}++xmlTreeToPatternString :: LA XmlTree String+xmlTreeToPatternString+    = createPatternFromXmlTree+      >>^+      show+++-- | Returns a string representation of a nameclass.++nameClassToString :: NameClass -> String+nameClassToString AnyName+    = "AnyName"++nameClassToString (AnyNameExcept nc) +    = "AnyNameExcept " ++ nameClassToString nc++nameClassToString (Name uri local) +    = "{" ++ uri ++ "}" ++ local++nameClassToString (NsName uri)+    = "{" ++ uri ++ "}"++nameClassToString (NsNameExcept uri nc)+    = uri ++ "except (NsName) " ++ nameClassToString nc++nameClassToString (NameClassChoice nc1 nc2)+    = nameClassToString nc1 ++ " " ++ nameClassToString nc2++nameClassToString (NCError e)+    = "NameClass Error: " ++ e+++-- ------------------------------------------------------------++{- |+Returns a tree representation of the pattern structure.+The hard work is done by 'formatTree'.++Example:++> +---element {}bar+>     |+>     +---group+>         |+>         +---oneOrMore+>         |   |+>         |   +---attribute AnyName+>         |       |+>         |       +---text+>         |+>         +---text+               +The function can be used to display circular ref-pattern structures.++Example:++> <define name="baz">+>   <element name="baz">+>     ... <ref name="baz"/> ...+>   </element>+> </define>++-}++patternToStringTree :: LA Pattern String+patternToStringTree+    = fromSLA [] pattern2PatternTree+      >>^+      (\p -> formatTree id p ++ "\n")+++-- | Returns a tree representation of the pattern structure.+-- (see also: 'createPatternFromXmlTree' and 'patternToStringTree')++xmlTreeToPatternStringTree :: LA XmlTree String+xmlTreeToPatternStringTree+    = createPatternFromXmlTree +      >>>+      patternToStringTree+++pattern2PatternTree :: SLA [NameClass] Pattern PatternTree+pattern2PatternTree+    = choiceA+      [ isA isRelaxEmpty      :-> (constA $ NTree "empty" [])+      , isA isRelaxNotAllowed :-> notAllowed2PatternTree+      , isA isRelaxText       :-> (constA $ NTree "text" [])+      , isA isRelaxChoice     :-> choice2PatternTree          +      , isA isRelaxInterleave :-> children2PatternTree "interleave"+      , isA isRelaxGroup      :-> children2PatternTree "group"+      , isA isRelaxOneOrMore  :-> children2PatternTree "oneOrMore"+      , isA isRelaxList       :-> children2PatternTree "list"+      , isA isRelaxData       :-> data2PatternTree+      , isA isRelaxDataExcept :-> dataExcept2PatternTree+      , isA isRelaxValue      :-> value2PatternTree+      , isA isRelaxAttribute  :-> createPatternTreeFromElement "attribute"          +      , isA isRelaxElement    :-> element2PatternTree+      , isA isRelaxAfter      :-> children2PatternTree "after"+      ]++notAllowed2PatternTree :: SLA [NameClass] Pattern PatternTree+notAllowed2PatternTree+    = arr $ \(NotAllowed (ErrMsg _l sl)) -> NTree "notAllowed" $ map (\ s -> NTree s []) sl+++data2PatternTree :: SLA [NameClass] Pattern PatternTree+data2PatternTree +    = arr $ \ (Data d p) -> NTree "data" [ datatype2PatternTree d+					 , mapping2PatternTree "parameter" p+					 ]+ +dataExcept2PatternTree :: SLA [NameClass] Pattern PatternTree+dataExcept2PatternTree +    = this &&& (listA $ arrL getChildrenPattern >>> pattern2PatternTree)+      >>>+      arr2 ( \ (DataExcept d param _) pattern ->+             NTree "dataExcept" ([ datatype2PatternTree d+				 , mapping2PatternTree "parameter" param+				 ] ++ pattern)+           )++value2PatternTree :: SLA [NameClass] Pattern PatternTree +value2PatternTree+    = arr $ \ (Value d v c) -> NTree ("value = " ++ v) [ datatype2PatternTree d+                                                       , context2PatternTree c+                                                       ]+++createPatternTreeFromElement :: String -> SLA [NameClass] Pattern PatternTree+createPatternTreeFromElement name+    = ( arr getNameClassFromPattern+	&&&+	listA (arrL getChildrenPattern >>> pattern2PatternTree)+      )+      >>>+      arr2 (\nc rl -> NTree (name ++ " " ++ show nc) rl)++children2PatternTree :: String -> SLA [NameClass] Pattern PatternTree+children2PatternTree name +    = listA (arrL getChildrenPattern >>> pattern2PatternTree) +      >>^+      (NTree name)++choice2PatternTree :: SLA [NameClass] Pattern PatternTree+choice2PatternTree +    = ifA ( -- wenn das zweite kind ein noch nicht ausgegebenes element ist, +            -- muss dieses anders behandelt werden+            -- nur fuer bessere formatierung des outputs+            arr (last . getChildrenPattern) >>> isA (isRelaxElement) >>>+            (arr getNameClassFromPattern &&& getState) >>> +            isA(\ (nc, liste) -> not $ elem nc liste)+          )+      ( -- element in status aufnehmen, wird dann nicht mehr vom erste kind ausgegeben+        arr getChildrenPattern+	>>>+        changeState (\s p -> (getNameClassFromPattern (last p)) : s)+	>>>+        ( ( head ^>> pattern2PatternTree )		-- erstes kind normal verarbeiten+          &&&						-- zweites kind, das element, verarbeiten+          ( last ^>> createPatternTreeFromElement "element" )+        )+        >>>+        arr2 ( \ l1 l2 -> NTree "choice" [l1, l2] )+      )+      ( children2PatternTree "choice" )++                            +element2PatternTree :: SLA [NameClass] Pattern PatternTree+element2PatternTree +    = ifA ( (arr getNameClassFromPattern &&& getState)+            >>> +            isA (\ (nc, liste) -> elem nc liste)+          )+      ( arr getNameClassFromPattern+        >>> +        arr (\nc -> NTree ("reference to element " ++ show nc) [])+      )+      ( changeState (\ s p -> (getNameClassFromPattern p) : s)+        >>>+        createPatternTreeFromElement "element"+      )+++mapping2PatternTree :: String -> [(Prefix, Uri)] -> PatternTree+mapping2PatternTree name mapping+    = NTree name (map (\(a, b) -> NTree (a ++ " = " ++ b) []) mapping)+++datatype2PatternTree :: Datatype -> PatternTree+datatype2PatternTree dt+    = NTree (datatype2String dt) []+++context2PatternTree :: Context -> PatternTree+context2PatternTree (base, mapping)+    = NTree "context" [ NTree ("base-uri = " ++ base) []+                      , mapping2PatternTree "namespace environment" mapping+                      ]++-- ------------------------------------------------------------++-- | Returns a formated string representation of the pattern structure.+-- (see also: 'createPatternFromXmlTree' and 'patternToFormatedString')+xmlTreeToPatternFormatedString :: LA XmlTree String+xmlTreeToPatternFormatedString+    = createPatternFromXmlTree +      >>>+      fromSLA [] patternToFormatedString+++{- |+Returns a formated string representation of the pattern structure.++Example:++> Element {}foo (Choice (Choice ( Value = abc, +> datatypelibrary = http://relaxng.org/ns/structure/1.0, type = token, +> context (base-uri =file://test.rng, +> parameter: xml = http://www.w3.org/XML/1998/namespaces, foo = www.bar.baz), ++The function can be used to display circular ref-pattern structures.+-}++patternToFormatedString :: SLA [NameClass] Pattern String+patternToFormatedString+    = choiceA+      [ isA isRelaxEmpty      :-> (constA " empty ")+      , isA isRelaxNotAllowed :-> (arr $ \ (NotAllowed errorEnv) -> show errorEnv)+      , isA isRelaxText       :-> (constA " text ")+      , isA isRelaxChoice     :-> children2FormatedString "choice"+      , isA isRelaxInterleave :-> children2FormatedString "interleave"+      , isA isRelaxGroup      :-> children2FormatedString "group"+      , isA isRelaxOneOrMore  :-> children2FormatedString "oneOrMore"+      , isA isRelaxList       :-> children2FormatedString "list"+      , isA isRelaxData       :-> data2FormatedString+      , isA isRelaxDataExcept :-> dataExcept2FormatedString+      , isA isRelaxValue      :-> value2FormatedString+      , isA isRelaxAttribute  :-> createFormatedStringFromElement "attribute"+      , isA isRelaxElement    :-> element2FormatedString+      , isA isRelaxAfter      :-> children2FormatedString "after"+      ]++children2FormatedString :: String -> SLA [NameClass] Pattern String+children2FormatedString name+    = listA (arrL getChildrenPattern >>> patternToFormatedString) +      >>^+      (\ l -> name ++ " (" ++ formatStringListPatt l ++ ") " )++data2FormatedString :: SLA [NameClass] Pattern String+data2FormatedString+    = arr ( \ (Data datatype paramList) ->+	    "Data " ++ datatype2String datatype ++ "\n " ++ +            mapping2String "parameter" paramList ++ "\n"+	  )++dataExcept2FormatedString :: SLA [NameClass] Pattern String+dataExcept2FormatedString + = arr ( \ (DataExcept datatype paramList _) ->+         "DataExcept " ++ show datatype ++ "\n " ++ +         mapping2String "parameter" paramList ++ "\n "+       )+   &&&+   ( arr (\ (DataExcept _ _ p) -> p) >>> patternToFormatedString )+   >>>+   arr2 (++)+++value2FormatedString :: SLA [NameClass] Pattern String+value2FormatedString + = arr $ \(Value datatype val context) ->+           "Value = " ++ val ++ ", " ++ datatype2String datatype ++ +           "\n " ++ context2String context ++ "\n"+++element2FormatedString :: SLA [NameClass] Pattern String+element2FormatedString+    = ifA ( (arr getNameClassFromPattern &&& getState)+            >>>+            isA (\ (nc, liste) -> elem nc liste)+	  )+      ( arr getNameClassFromPattern+	>>^ +	( \nc -> "reference to element " ++ nameClassToString nc ++ " " )+      )+      ( changeState (\ s p -> (getNameClassFromPattern p) : s)+	>>>+	createFormatedStringFromElement "element"+      )+++createFormatedStringFromElement :: String -> SLA [NameClass] Pattern String+createFormatedStringFromElement name+    = ( arr getNameClassFromPattern+	&&&+	( listA (arrL getChildrenPattern >>> patternToFormatedString)+	  >>^+	  formatStringListId+	)+      )+      >>>+      arr2 (\ nc rl -> name ++ " " ++ nameClassToString nc ++ " (" ++ rl ++ ")")+++-- ------------------------------------------------------------++mapping2String :: String -> [(Prefix, Uri)] -> String+mapping2String name mapping+    = name ++ ": " ++ +      formatStringList id ", " (map (\(a, b) -> a ++ " = " ++ b) mapping)++datatype2String :: Datatype -> String+datatype2String (lib, localName)+    = "datatypelibrary = " ++ getLib ++ ", type = " ++ localName+    where+    getLib = if lib == "" then relaxNamespace else lib+  +context2String :: Context -> String+context2String (base, mapping)+    = "context (base-uri = " ++ base ++ ", " +++      mapping2String "namespace environment" mapping ++ ")"+  +-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/RelaxNG/Schema.hs view
@@ -0,0 +1,3921 @@+{- |+   Module     : Text.HXT.RelaxNG.Schema++   Don't edit this module, it's generated by RelaxSchemaToXmlTree++-}++module Yuuko.Text.XML.HXT.RelaxNG.Schema+    ( relaxSchemaTree, relaxSchemaArrow )+where++import Yuuko.Text.XML.HXT.DOM.TypeDefs+import Yuuko.Text.XML.HXT.DOM.XmlNode (mkRoot, mkElement, mkAttr, mkText)++import Yuuko.Control.Arrow.ListArrows++relaxSchemaArrow :: ArrowList a => a b XmlTree+relaxSchemaArrow = constA relaxSchemaTree++relaxSchemaTree :: XmlTree+relaxSchemaTree =+  let+  ns1	= "http://relaxng.org/ns/structure/1.0"+  qn1	= mkSNsName "RelaxContext:xml"+  qn2	= mkSNsName "RelaxContextBaseURI"+  qn3	= mkSNsName "RelaxContextDefault"+  qn4	= mkNsName "anyName" ns1+  qn5	= mkNsName "attribute" ns1+  qn6	= mkNsName "choice" ns1+  qn7	= mkNsName "data" ns1+  qn8	= mkSNsName "datatypeLibrary"+  qn9	= mkNsName "define" ns1+  qn10	= mkNsName "element" ns1+  qn11	= mkNsName "empty" ns1+  qn12	= mkNsName "except" ns1+  qn13	= mkNsName "grammar" ns1+  qn14	= mkNsName "group" ns1+  qn15	= mkNsName "interleave" ns1+  qn16	= mkSNsName "name"+  qn17	= mkNsName "name" ns1+  qn18	= mkSNsName "ns"+  qn19	= mkNsName "nsName" ns1+  qn20	= mkNsName "oneOrMore" ns1+  qn21	= mkNsName "ref" ns1+  qn22	= mkNsName "start" ns1+  qn23	= mkNsName "text" ns1+  qn24	= mkSNsName "type"+  qn25	= mkNsName "value" ns1+  in+  mkRoot []+    [ mkElement qn13 []+      [ mkElement qn22 []+        [ mkElement qn6 []+          [ mkElement qn6 []+            [ mkElement qn6 []+              [ mkElement qn6 []+                [ mkElement qn6 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn6 []+                          [ mkElement qn6 []+                            [ mkElement qn6 []+                              [ mkElement qn6 []+                                [ mkElement qn6 []+                                  [ mkElement qn6 []+                                    [ mkElement qn6 []+                                      [ mkElement qn6 []+                                        [ mkElement qn6 []+                                          [ mkElement qn6 []+                                            [ mkElement qn21+                                              [ mkAttr qn16 [ mkText "24" ]+                                              ] []+                                            , mkElement qn21+                                              [ mkAttr qn16 [ mkText "25" ]+                                              ] []+                                            ]+                                          , mkElement qn21+                                            [ mkAttr qn16 [ mkText "26" ]+                                            ] []+                                          ]+                                        , mkElement qn21+                                          [ mkAttr qn16 [ mkText "27" ]+                                          ] []+                                        ]+                                      , mkElement qn21+                                        [ mkAttr qn16 [ mkText "28" ]+                                        ] []+                                      ]+                                    , mkElement qn21+                                      [ mkAttr qn16 [ mkText "29" ]+                                      ] []+                                    ]+                                  , mkElement qn21+                                    [ mkAttr qn16 [ mkText "30" ]+                                    ] []+                                  ]+                                , mkElement qn21+                                  [ mkAttr qn16 [ mkText "31" ]+                                  ] []+                                ]+                              , mkElement qn21+                                [ mkAttr qn16 [ mkText "32" ]+                                ] []+                              ]+                            , mkElement qn21+                              [ mkAttr qn16 [ mkText "33" ]+                              ] []+                            ]+                          , mkElement qn21+                            [ mkAttr qn16 [ mkText "34" ]+                            ] []+                          ]+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "35" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "36" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "37" ]+                      ] []+                    ]+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "38" ]+                    ] []+                  ]+                , mkElement qn21+                  [ mkAttr qn16 [ mkText "39" ]+                  ] []+                ]+              , mkElement qn21+                [ mkAttr qn16 [ mkText "42" ]+                ] []+              ]+            , mkElement qn21+              [ mkAttr qn16 [ mkText "43" ]+              ] []+            ]+          , mkElement qn21+            [ mkAttr qn16 [ mkText "44" ]+            ] []+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "44" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "grammar"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "15" ]+                    ] []+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn21+                          [ mkAttr qn16 [ mkText "11" ]+                          ] []+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "10" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "22" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "23" ]+                      ] []+                    ]+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "43" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "externalRef"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn5 []+                [ mkElement qn17+                  [ mkAttr qn18 [ mkText "" ]+                  ]+                  [ mkText "href"+                  ]+                , mkElement qn7+                  [ mkAttr qn24 [ mkText "anyURI" ]+                  , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                  ] []+                ]+              , mkElement qn14 []+                [ mkElement qn14 []+                  [ mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn5 []+                      [ mkElement qn17+                        [ mkAttr qn18 [ mkText "" ]+                        ]+                        [ mkText "ns"+                        ]+                      , mkElement qn23 [] []+                      ]+                    ]+                  , mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn5 []+                      [ mkElement qn17+                        [ mkAttr qn18 [ mkText "" ]+                        ]+                        [ mkText "datatypeLibrary"+                        ]+                      , mkElement qn7+                        [ mkAttr qn24 [ mkText "anyURI" ]+                        , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                        ] []+                      ]+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn20 []+                    [ mkElement qn5 []+                      [ mkElement qn4 []+                        [ mkElement qn12 []+                          [ mkElement qn6 []+                            [ mkElement qn19+                              [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                              ] []+                            , mkElement qn19+                              [ mkAttr qn18 [ mkText "" ]+                              ] []+                            ]+                          ]+                        ]+                      , mkElement qn23 [] []+                      ]+                    ]+                  ]+                ]+              ]+            , mkElement qn6 []+              [ mkElement qn11 [] []+              , mkElement qn20 []+                [ mkElement qn21+                  [ mkAttr qn16 [ mkText "15" ]+                  ] []+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "42" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "notAllowed"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn6 []+              [ mkElement qn11 [] []+              , mkElement qn20 []+                [ mkElement qn21+                  [ mkAttr qn16 [ mkText "15" ]+                  ] []+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "39" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "data"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn5 []+                [ mkElement qn17+                  [ mkAttr qn18 [ mkText "" ]+                  ]+                  [ mkText "type"+                  ]+                , mkElement qn7+                  [ mkAttr qn24 [ mkText "NCName" ]+                  , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                  ] []+                ]+              , mkElement qn14 []+                [ mkElement qn14 []+                  [ mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn5 []+                      [ mkElement qn17+                        [ mkAttr qn18 [ mkText "" ]+                        ]+                        [ mkText "ns"+                        ]+                      , mkElement qn23 [] []+                      ]+                    ]+                  , mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn5 []+                      [ mkElement qn17+                        [ mkAttr qn18 [ mkText "" ]+                        ]+                        [ mkText "datatypeLibrary"+                        ]+                      , mkElement qn7+                        [ mkAttr qn24 [ mkText "anyURI" ]+                        , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                        ] []+                      ]+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn20 []+                    [ mkElement qn5 []+                      [ mkElement qn4 []+                        [ mkElement qn12 []+                          [ mkElement qn6 []+                            [ mkElement qn19+                              [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                              ] []+                            , mkElement qn19+                              [ mkAttr qn18 [ mkText "" ]+                              ] []+                            ]+                          ]+                        ]+                      , mkElement qn23 [] []+                      ]+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "15" ]+                    ] []+                  ]+                ]+              , mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn20 []+                    [ mkElement qn21+                      [ mkAttr qn16 [ mkText "40" ]+                      ] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "41" ]+                    ] []+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "41" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "except"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "15" ]+                    ] []+                  ]+                ]+              , mkElement qn20 []+                [ mkElement qn6 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn6 []+                          [ mkElement qn6 []+                            [ mkElement qn6 []+                              [ mkElement qn6 []+                                [ mkElement qn6 []+                                  [ mkElement qn6 []+                                    [ mkElement qn6 []+                                      [ mkElement qn6 []+                                        [ mkElement qn6 []+                                          [ mkElement qn6 []+                                            [ mkElement qn6 []+                                              [ mkElement qn6 []+                                                [ mkElement qn6 []+                                                  [ mkElement qn6 []+                                                    [ mkElement qn21+                                                      [ mkAttr qn16 [ mkText "24" ]+                                                      ] []+                                                    , mkElement qn21+                                                      [ mkAttr qn16 [ mkText "25" ]+                                                      ] []+                                                    ]+                                                  , mkElement qn21+                                                    [ mkAttr qn16 [ mkText "26" ]+                                                    ] []+                                                  ]+                                                , mkElement qn21+                                                  [ mkAttr qn16 [ mkText "27" ]+                                                  ] []+                                                ]+                                              , mkElement qn21+                                                [ mkAttr qn16 [ mkText "28" ]+                                                ] []+                                              ]+                                            , mkElement qn21+                                              [ mkAttr qn16 [ mkText "29" ]+                                              ] []+                                            ]+                                          , mkElement qn21+                                            [ mkAttr qn16 [ mkText "30" ]+                                            ] []+                                          ]+                                        , mkElement qn21+                                          [ mkAttr qn16 [ mkText "31" ]+                                          ] []+                                        ]+                                      , mkElement qn21+                                        [ mkAttr qn16 [ mkText "32" ]+                                        ] []+                                      ]+                                    , mkElement qn21+                                      [ mkAttr qn16 [ mkText "33" ]+                                      ] []+                                    ]+                                  , mkElement qn21+                                    [ mkAttr qn16 [ mkText "34" ]+                                    ] []+                                  ]+                                , mkElement qn21+                                  [ mkAttr qn16 [ mkText "35" ]+                                  ] []+                                ]+                              , mkElement qn21+                                [ mkAttr qn16 [ mkText "36" ]+                                ] []+                              ]+                            , mkElement qn21+                              [ mkAttr qn16 [ mkText "37" ]+                              ] []+                            ]+                          , mkElement qn21+                            [ mkAttr qn16 [ mkText "38" ]+                            ] []+                          ]+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "39" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "42" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "43" ]+                      ] []+                    ]+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "44" ]+                    ] []+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "40" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "param"+            ]+          , mkElement qn14 []+            [ mkElement qn5 []+              [ mkElement qn17+                [ mkAttr qn18 [ mkText "" ]+                ]+                [ mkText "name"+                ]+              , mkElement qn7+                [ mkAttr qn24 [ mkText "NCName" ]+                , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                ] []+              ]+            , mkElement qn23 [] []+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "38" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "value"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn5 []+                  [ mkElement qn17+                    [ mkAttr qn18 [ mkText "" ]+                    ]+                    [ mkText "type"+                    ]+                  , mkElement qn7+                    [ mkAttr qn24 [ mkText "NCName" ]+                    , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                    ] []+                  ]+                ]+              , mkElement qn14 []+                [ mkElement qn14 []+                  [ mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn5 []+                      [ mkElement qn17+                        [ mkAttr qn18 [ mkText "" ]+                        ]+                        [ mkText "ns"+                        ]+                      , mkElement qn23 [] []+                      ]+                    ]+                  , mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn5 []+                      [ mkElement qn17+                        [ mkAttr qn18 [ mkText "" ]+                        ]+                        [ mkText "datatypeLibrary"+                        ]+                      , mkElement qn7+                        [ mkAttr qn24 [ mkText "anyURI" ]+                        , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                        ] []+                      ]+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn20 []+                    [ mkElement qn5 []+                      [ mkElement qn4 []+                        [ mkElement qn12 []+                          [ mkElement qn6 []+                            [ mkElement qn19+                              [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                              ] []+                            , mkElement qn19+                              [ mkAttr qn18 [ mkText "" ]+                              ] []+                            ]+                          ]+                        ]+                      , mkElement qn23 [] []+                      ]+                    ]+                  ]+                ]+              ]+            , mkElement qn23 [] []+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "37" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "text"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn6 []+              [ mkElement qn11 [] []+              , mkElement qn20 []+                [ mkElement qn21+                  [ mkAttr qn16 [ mkText "15" ]+                  ] []+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "36" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "empty"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn6 []+              [ mkElement qn11 [] []+              , mkElement qn20 []+                [ mkElement qn21+                  [ mkAttr qn16 [ mkText "15" ]+                  ] []+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "35" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "parentRef"+            ]+          , mkElement qn14 []+            [ mkElement qn5 []+              [ mkElement qn17+                [ mkAttr qn18 [ mkText "" ]+                ]+                [ mkText "name"+                ]+              , mkElement qn7+                [ mkAttr qn24 [ mkText "NCName" ]+                , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                ] []+              ]+            , mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "34" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "ref"+            ]+          , mkElement qn14 []+            [ mkElement qn5 []+              [ mkElement qn17+                [ mkAttr qn18 [ mkText "" ]+                ]+                [ mkText "name"+                ]+              , mkElement qn7+                [ mkAttr qn24 [ mkText "NCName" ]+                , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                ] []+              ]+            , mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "33" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "mixed"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "15" ]+                    ] []+                  ]+                ]+              , mkElement qn20 []+                [ mkElement qn6 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn6 []+                          [ mkElement qn6 []+                            [ mkElement qn6 []+                              [ mkElement qn6 []+                                [ mkElement qn6 []+                                  [ mkElement qn6 []+                                    [ mkElement qn6 []+                                      [ mkElement qn6 []+                                        [ mkElement qn6 []+                                          [ mkElement qn6 []+                                            [ mkElement qn6 []+                                              [ mkElement qn6 []+                                                [ mkElement qn6 []+                                                  [ mkElement qn6 []+                                                    [ mkElement qn21+                                                      [ mkAttr qn16 [ mkText "24" ]+                                                      ] []+                                                    , mkElement qn21+                                                      [ mkAttr qn16 [ mkText "25" ]+                                                      ] []+                                                    ]+                                                  , mkElement qn21+                                                    [ mkAttr qn16 [ mkText "26" ]+                                                    ] []+                                                  ]+                                                , mkElement qn21+                                                  [ mkAttr qn16 [ mkText "27" ]+                                                  ] []+                                                ]+                                              , mkElement qn21+                                                [ mkAttr qn16 [ mkText "28" ]+                                                ] []+                                              ]+                                            , mkElement qn21+                                              [ mkAttr qn16 [ mkText "29" ]+                                              ] []+                                            ]+                                          , mkElement qn21+                                            [ mkAttr qn16 [ mkText "30" ]+                                            ] []+                                          ]+                                        , mkElement qn21+                                          [ mkAttr qn16 [ mkText "31" ]+                                          ] []+                                        ]+                                      , mkElement qn21+                                        [ mkAttr qn16 [ mkText "32" ]+                                        ] []+                                      ]+                                    , mkElement qn21+                                      [ mkAttr qn16 [ mkText "33" ]+                                      ] []+                                    ]+                                  , mkElement qn21+                                    [ mkAttr qn16 [ mkText "34" ]+                                    ] []+                                  ]+                                , mkElement qn21+                                  [ mkAttr qn16 [ mkText "35" ]+                                  ] []+                                ]+                              , mkElement qn21+                                [ mkAttr qn16 [ mkText "36" ]+                                ] []+                              ]+                            , mkElement qn21+                              [ mkAttr qn16 [ mkText "37" ]+                              ] []+                            ]+                          , mkElement qn21+                            [ mkAttr qn16 [ mkText "38" ]+                            ] []+                          ]+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "39" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "42" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "43" ]+                      ] []+                    ]+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "44" ]+                    ] []+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "32" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "list"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "15" ]+                    ] []+                  ]+                ]+              , mkElement qn20 []+                [ mkElement qn6 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn6 []+                          [ mkElement qn6 []+                            [ mkElement qn6 []+                              [ mkElement qn6 []+                                [ mkElement qn6 []+                                  [ mkElement qn6 []+                                    [ mkElement qn6 []+                                      [ mkElement qn6 []+                                        [ mkElement qn6 []+                                          [ mkElement qn6 []+                                            [ mkElement qn6 []+                                              [ mkElement qn6 []+                                                [ mkElement qn6 []+                                                  [ mkElement qn6 []+                                                    [ mkElement qn21+                                                      [ mkAttr qn16 [ mkText "24" ]+                                                      ] []+                                                    , mkElement qn21+                                                      [ mkAttr qn16 [ mkText "25" ]+                                                      ] []+                                                    ]+                                                  , mkElement qn21+                                                    [ mkAttr qn16 [ mkText "26" ]+                                                    ] []+                                                  ]+                                                , mkElement qn21+                                                  [ mkAttr qn16 [ mkText "27" ]+                                                  ] []+                                                ]+                                              , mkElement qn21+                                                [ mkAttr qn16 [ mkText "28" ]+                                                ] []+                                              ]+                                            , mkElement qn21+                                              [ mkAttr qn16 [ mkText "29" ]+                                              ] []+                                            ]+                                          , mkElement qn21+                                            [ mkAttr qn16 [ mkText "30" ]+                                            ] []+                                          ]+                                        , mkElement qn21+                                          [ mkAttr qn16 [ mkText "31" ]+                                          ] []+                                        ]+                                      , mkElement qn21+                                        [ mkAttr qn16 [ mkText "32" ]+                                        ] []+                                      ]+                                    , mkElement qn21+                                      [ mkAttr qn16 [ mkText "33" ]+                                      ] []+                                    ]+                                  , mkElement qn21+                                    [ mkAttr qn16 [ mkText "34" ]+                                    ] []+                                  ]+                                , mkElement qn21+                                  [ mkAttr qn16 [ mkText "35" ]+                                  ] []+                                ]+                              , mkElement qn21+                                [ mkAttr qn16 [ mkText "36" ]+                                ] []+                              ]+                            , mkElement qn21+                              [ mkAttr qn16 [ mkText "37" ]+                              ] []+                            ]+                          , mkElement qn21+                            [ mkAttr qn16 [ mkText "38" ]+                            ] []+                          ]+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "39" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "42" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "43" ]+                      ] []+                    ]+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "44" ]+                    ] []+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "31" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "oneOrMore"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "15" ]+                    ] []+                  ]+                ]+              , mkElement qn20 []+                [ mkElement qn6 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn6 []+                          [ mkElement qn6 []+                            [ mkElement qn6 []+                              [ mkElement qn6 []+                                [ mkElement qn6 []+                                  [ mkElement qn6 []+                                    [ mkElement qn6 []+                                      [ mkElement qn6 []+                                        [ mkElement qn6 []+                                          [ mkElement qn6 []+                                            [ mkElement qn6 []+                                              [ mkElement qn6 []+                                                [ mkElement qn6 []+                                                  [ mkElement qn6 []+                                                    [ mkElement qn21+                                                      [ mkAttr qn16 [ mkText "24" ]+                                                      ] []+                                                    , mkElement qn21+                                                      [ mkAttr qn16 [ mkText "25" ]+                                                      ] []+                                                    ]+                                                  , mkElement qn21+                                                    [ mkAttr qn16 [ mkText "26" ]+                                                    ] []+                                                  ]+                                                , mkElement qn21+                                                  [ mkAttr qn16 [ mkText "27" ]+                                                  ] []+                                                ]+                                              , mkElement qn21+                                                [ mkAttr qn16 [ mkText "28" ]+                                                ] []+                                              ]+                                            , mkElement qn21+                                              [ mkAttr qn16 [ mkText "29" ]+                                              ] []+                                            ]+                                          , mkElement qn21+                                            [ mkAttr qn16 [ mkText "30" ]+                                            ] []+                                          ]+                                        , mkElement qn21+                                          [ mkAttr qn16 [ mkText "31" ]+                                          ] []+                                        ]+                                      , mkElement qn21+                                        [ mkAttr qn16 [ mkText "32" ]+                                        ] []+                                      ]+                                    , mkElement qn21+                                      [ mkAttr qn16 [ mkText "33" ]+                                      ] []+                                    ]+                                  , mkElement qn21+                                    [ mkAttr qn16 [ mkText "34" ]+                                    ] []+                                  ]+                                , mkElement qn21+                                  [ mkAttr qn16 [ mkText "35" ]+                                  ] []+                                ]+                              , mkElement qn21+                                [ mkAttr qn16 [ mkText "36" ]+                                ] []+                              ]+                            , mkElement qn21+                              [ mkAttr qn16 [ mkText "37" ]+                              ] []+                            ]+                          , mkElement qn21+                            [ mkAttr qn16 [ mkText "38" ]+                            ] []+                          ]+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "39" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "42" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "43" ]+                      ] []+                    ]+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "44" ]+                    ] []+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "30" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "zeroOrMore"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "15" ]+                    ] []+                  ]+                ]+              , mkElement qn20 []+                [ mkElement qn6 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn6 []+                          [ mkElement qn6 []+                            [ mkElement qn6 []+                              [ mkElement qn6 []+                                [ mkElement qn6 []+                                  [ mkElement qn6 []+                                    [ mkElement qn6 []+                                      [ mkElement qn6 []+                                        [ mkElement qn6 []+                                          [ mkElement qn6 []+                                            [ mkElement qn6 []+                                              [ mkElement qn6 []+                                                [ mkElement qn6 []+                                                  [ mkElement qn6 []+                                                    [ mkElement qn21+                                                      [ mkAttr qn16 [ mkText "24" ]+                                                      ] []+                                                    , mkElement qn21+                                                      [ mkAttr qn16 [ mkText "25" ]+                                                      ] []+                                                    ]+                                                  , mkElement qn21+                                                    [ mkAttr qn16 [ mkText "26" ]+                                                    ] []+                                                  ]+                                                , mkElement qn21+                                                  [ mkAttr qn16 [ mkText "27" ]+                                                  ] []+                                                ]+                                              , mkElement qn21+                                                [ mkAttr qn16 [ mkText "28" ]+                                                ] []+                                              ]+                                            , mkElement qn21+                                              [ mkAttr qn16 [ mkText "29" ]+                                              ] []+                                            ]+                                          , mkElement qn21+                                            [ mkAttr qn16 [ mkText "30" ]+                                            ] []+                                          ]+                                        , mkElement qn21+                                          [ mkAttr qn16 [ mkText "31" ]+                                          ] []+                                        ]+                                      , mkElement qn21+                                        [ mkAttr qn16 [ mkText "32" ]+                                        ] []+                                      ]+                                    , mkElement qn21+                                      [ mkAttr qn16 [ mkText "33" ]+                                      ] []+                                    ]+                                  , mkElement qn21+                                    [ mkAttr qn16 [ mkText "34" ]+                                    ] []+                                  ]+                                , mkElement qn21+                                  [ mkAttr qn16 [ mkText "35" ]+                                  ] []+                                ]+                              , mkElement qn21+                                [ mkAttr qn16 [ mkText "36" ]+                                ] []+                              ]+                            , mkElement qn21+                              [ mkAttr qn16 [ mkText "37" ]+                              ] []+                            ]+                          , mkElement qn21+                            [ mkAttr qn16 [ mkText "38" ]+                            ] []+                          ]+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "39" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "42" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "43" ]+                      ] []+                    ]+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "44" ]+                    ] []+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "29" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "optional"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "15" ]+                    ] []+                  ]+                ]+              , mkElement qn20 []+                [ mkElement qn6 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn6 []+                          [ mkElement qn6 []+                            [ mkElement qn6 []+                              [ mkElement qn6 []+                                [ mkElement qn6 []+                                  [ mkElement qn6 []+                                    [ mkElement qn6 []+                                      [ mkElement qn6 []+                                        [ mkElement qn6 []+                                          [ mkElement qn6 []+                                            [ mkElement qn6 []+                                              [ mkElement qn6 []+                                                [ mkElement qn6 []+                                                  [ mkElement qn6 []+                                                    [ mkElement qn21+                                                      [ mkAttr qn16 [ mkText "24" ]+                                                      ] []+                                                    , mkElement qn21+                                                      [ mkAttr qn16 [ mkText "25" ]+                                                      ] []+                                                    ]+                                                  , mkElement qn21+                                                    [ mkAttr qn16 [ mkText "26" ]+                                                    ] []+                                                  ]+                                                , mkElement qn21+                                                  [ mkAttr qn16 [ mkText "27" ]+                                                  ] []+                                                ]+                                              , mkElement qn21+                                                [ mkAttr qn16 [ mkText "28" ]+                                                ] []+                                              ]+                                            , mkElement qn21+                                              [ mkAttr qn16 [ mkText "29" ]+                                              ] []+                                            ]+                                          , mkElement qn21+                                            [ mkAttr qn16 [ mkText "30" ]+                                            ] []+                                          ]+                                        , mkElement qn21+                                          [ mkAttr qn16 [ mkText "31" ]+                                          ] []+                                        ]+                                      , mkElement qn21+                                        [ mkAttr qn16 [ mkText "32" ]+                                        ] []+                                      ]+                                    , mkElement qn21+                                      [ mkAttr qn16 [ mkText "33" ]+                                      ] []+                                    ]+                                  , mkElement qn21+                                    [ mkAttr qn16 [ mkText "34" ]+                                    ] []+                                  ]+                                , mkElement qn21+                                  [ mkAttr qn16 [ mkText "35" ]+                                  ] []+                                ]+                              , mkElement qn21+                                [ mkAttr qn16 [ mkText "36" ]+                                ] []+                              ]+                            , mkElement qn21+                              [ mkAttr qn16 [ mkText "37" ]+                              ] []+                            ]+                          , mkElement qn21+                            [ mkAttr qn16 [ mkText "38" ]+                            ] []+                          ]+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "39" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "42" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "43" ]+                      ] []+                    ]+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "44" ]+                    ] []+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "28" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "choice"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "15" ]+                    ] []+                  ]+                ]+              , mkElement qn20 []+                [ mkElement qn6 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn6 []+                          [ mkElement qn6 []+                            [ mkElement qn6 []+                              [ mkElement qn6 []+                                [ mkElement qn6 []+                                  [ mkElement qn6 []+                                    [ mkElement qn6 []+                                      [ mkElement qn6 []+                                        [ mkElement qn6 []+                                          [ mkElement qn6 []+                                            [ mkElement qn6 []+                                              [ mkElement qn6 []+                                                [ mkElement qn6 []+                                                  [ mkElement qn6 []+                                                    [ mkElement qn21+                                                      [ mkAttr qn16 [ mkText "24" ]+                                                      ] []+                                                    , mkElement qn21+                                                      [ mkAttr qn16 [ mkText "25" ]+                                                      ] []+                                                    ]+                                                  , mkElement qn21+                                                    [ mkAttr qn16 [ mkText "26" ]+                                                    ] []+                                                  ]+                                                , mkElement qn21+                                                  [ mkAttr qn16 [ mkText "27" ]+                                                  ] []+                                                ]+                                              , mkElement qn21+                                                [ mkAttr qn16 [ mkText "28" ]+                                                ] []+                                              ]+                                            , mkElement qn21+                                              [ mkAttr qn16 [ mkText "29" ]+                                              ] []+                                            ]+                                          , mkElement qn21+                                            [ mkAttr qn16 [ mkText "30" ]+                                            ] []+                                          ]+                                        , mkElement qn21+                                          [ mkAttr qn16 [ mkText "31" ]+                                          ] []+                                        ]+                                      , mkElement qn21+                                        [ mkAttr qn16 [ mkText "32" ]+                                        ] []+                                      ]+                                    , mkElement qn21+                                      [ mkAttr qn16 [ mkText "33" ]+                                      ] []+                                    ]+                                  , mkElement qn21+                                    [ mkAttr qn16 [ mkText "34" ]+                                    ] []+                                  ]+                                , mkElement qn21+                                  [ mkAttr qn16 [ mkText "35" ]+                                  ] []+                                ]+                              , mkElement qn21+                                [ mkAttr qn16 [ mkText "36" ]+                                ] []+                              ]+                            , mkElement qn21+                              [ mkAttr qn16 [ mkText "37" ]+                              ] []+                            ]+                          , mkElement qn21+                            [ mkAttr qn16 [ mkText "38" ]+                            ] []+                          ]+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "39" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "42" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "43" ]+                      ] []+                    ]+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "44" ]+                    ] []+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "27" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "interleave"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "15" ]+                    ] []+                  ]+                ]+              , mkElement qn20 []+                [ mkElement qn6 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn6 []+                          [ mkElement qn6 []+                            [ mkElement qn6 []+                              [ mkElement qn6 []+                                [ mkElement qn6 []+                                  [ mkElement qn6 []+                                    [ mkElement qn6 []+                                      [ mkElement qn6 []+                                        [ mkElement qn6 []+                                          [ mkElement qn6 []+                                            [ mkElement qn6 []+                                              [ mkElement qn6 []+                                                [ mkElement qn6 []+                                                  [ mkElement qn6 []+                                                    [ mkElement qn21+                                                      [ mkAttr qn16 [ mkText "24" ]+                                                      ] []+                                                    , mkElement qn21+                                                      [ mkAttr qn16 [ mkText "25" ]+                                                      ] []+                                                    ]+                                                  , mkElement qn21+                                                    [ mkAttr qn16 [ mkText "26" ]+                                                    ] []+                                                  ]+                                                , mkElement qn21+                                                  [ mkAttr qn16 [ mkText "27" ]+                                                  ] []+                                                ]+                                              , mkElement qn21+                                                [ mkAttr qn16 [ mkText "28" ]+                                                ] []+                                              ]+                                            , mkElement qn21+                                              [ mkAttr qn16 [ mkText "29" ]+                                              ] []+                                            ]+                                          , mkElement qn21+                                            [ mkAttr qn16 [ mkText "30" ]+                                            ] []+                                          ]+                                        , mkElement qn21+                                          [ mkAttr qn16 [ mkText "31" ]+                                          ] []+                                        ]+                                      , mkElement qn21+                                        [ mkAttr qn16 [ mkText "32" ]+                                        ] []+                                      ]+                                    , mkElement qn21+                                      [ mkAttr qn16 [ mkText "33" ]+                                      ] []+                                    ]+                                  , mkElement qn21+                                    [ mkAttr qn16 [ mkText "34" ]+                                    ] []+                                  ]+                                , mkElement qn21+                                  [ mkAttr qn16 [ mkText "35" ]+                                  ] []+                                ]+                              , mkElement qn21+                                [ mkAttr qn16 [ mkText "36" ]+                                ] []+                              ]+                            , mkElement qn21+                              [ mkAttr qn16 [ mkText "37" ]+                              ] []+                            ]+                          , mkElement qn21+                            [ mkAttr qn16 [ mkText "38" ]+                            ] []+                          ]+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "39" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "42" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "43" ]+                      ] []+                    ]+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "44" ]+                    ] []+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "26" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "group"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "15" ]+                    ] []+                  ]+                ]+              , mkElement qn20 []+                [ mkElement qn6 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn6 []+                          [ mkElement qn6 []+                            [ mkElement qn6 []+                              [ mkElement qn6 []+                                [ mkElement qn6 []+                                  [ mkElement qn6 []+                                    [ mkElement qn6 []+                                      [ mkElement qn6 []+                                        [ mkElement qn6 []+                                          [ mkElement qn6 []+                                            [ mkElement qn6 []+                                              [ mkElement qn6 []+                                                [ mkElement qn6 []+                                                  [ mkElement qn6 []+                                                    [ mkElement qn21+                                                      [ mkAttr qn16 [ mkText "24" ]+                                                      ] []+                                                    , mkElement qn21+                                                      [ mkAttr qn16 [ mkText "25" ]+                                                      ] []+                                                    ]+                                                  , mkElement qn21+                                                    [ mkAttr qn16 [ mkText "26" ]+                                                    ] []+                                                  ]+                                                , mkElement qn21+                                                  [ mkAttr qn16 [ mkText "27" ]+                                                  ] []+                                                ]+                                              , mkElement qn21+                                                [ mkAttr qn16 [ mkText "28" ]+                                                ] []+                                              ]+                                            , mkElement qn21+                                              [ mkAttr qn16 [ mkText "29" ]+                                              ] []+                                            ]+                                          , mkElement qn21+                                            [ mkAttr qn16 [ mkText "30" ]+                                            ] []+                                          ]+                                        , mkElement qn21+                                          [ mkAttr qn16 [ mkText "31" ]+                                          ] []+                                        ]+                                      , mkElement qn21+                                        [ mkAttr qn16 [ mkText "32" ]+                                        ] []+                                      ]+                                    , mkElement qn21+                                      [ mkAttr qn16 [ mkText "33" ]+                                      ] []+                                    ]+                                  , mkElement qn21+                                    [ mkAttr qn16 [ mkText "34" ]+                                    ] []+                                  ]+                                , mkElement qn21+                                  [ mkAttr qn16 [ mkText "35" ]+                                  ] []+                                ]+                              , mkElement qn21+                                [ mkAttr qn16 [ mkText "36" ]+                                ] []+                              ]+                            , mkElement qn21+                              [ mkAttr qn16 [ mkText "37" ]+                              ] []+                            ]+                          , mkElement qn21+                            [ mkAttr qn16 [ mkText "38" ]+                            ] []+                          ]+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "39" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "42" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "43" ]+                      ] []+                    ]+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "44" ]+                    ] []+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "25" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "attribute"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn14 []+                  [ mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn5 []+                      [ mkElement qn17+                        [ mkAttr qn18 [ mkText "" ]+                        ]+                        [ mkText "ns"+                        ]+                      , mkElement qn23 [] []+                      ]+                    ]+                  , mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn5 []+                      [ mkElement qn17+                        [ mkAttr qn18 [ mkText "" ]+                        ]+                        [ mkText "datatypeLibrary"+                        ]+                      , mkElement qn7+                        [ mkAttr qn24 [ mkText "anyURI" ]+                        , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                        ] []+                      ]+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn20 []+                    [ mkElement qn5 []+                      [ mkElement qn4 []+                        [ mkElement qn12 []+                          [ mkElement qn6 []+                            [ mkElement qn19+                              [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                              ] []+                            , mkElement qn19+                              [ mkAttr qn18 [ mkText "" ]+                              ] []+                            ]+                          ]+                        ]+                      , mkElement qn23 [] []+                      ]+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn5 []+                  [ mkElement qn17+                    [ mkAttr qn18 [ mkText "" ]+                    ]+                    [ mkText "name"+                    ]+                  , mkElement qn7+                    [ mkAttr qn24 [ mkText "QName" ]+                    , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                    ] []+                  ]+                , mkElement qn15 []+                  [ mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn20 []+                      [ mkElement qn21+                        [ mkAttr qn16 [ mkText "15" ]+                        ] []+                      ]+                    ]+                  , mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn21+                          [ mkAttr qn16 [ mkText "17" ]+                          ] []+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "18" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "19" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "20" ]+                      ] []+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "15" ]+                    ] []+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn6 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn6 []+                          [ mkElement qn6 []+                            [ mkElement qn6 []+                              [ mkElement qn6 []+                                [ mkElement qn6 []+                                  [ mkElement qn6 []+                                    [ mkElement qn6 []+                                      [ mkElement qn6 []+                                        [ mkElement qn6 []+                                          [ mkElement qn6 []+                                            [ mkElement qn6 []+                                              [ mkElement qn6 []+                                                [ mkElement qn6 []+                                                  [ mkElement qn6 []+                                                    [ mkElement qn21+                                                      [ mkAttr qn16 [ mkText "24" ]+                                                      ] []+                                                    , mkElement qn21+                                                      [ mkAttr qn16 [ mkText "25" ]+                                                      ] []+                                                    ]+                                                  , mkElement qn21+                                                    [ mkAttr qn16 [ mkText "26" ]+                                                    ] []+                                                  ]+                                                , mkElement qn21+                                                  [ mkAttr qn16 [ mkText "27" ]+                                                  ] []+                                                ]+                                              , mkElement qn21+                                                [ mkAttr qn16 [ mkText "28" ]+                                                ] []+                                              ]+                                            , mkElement qn21+                                              [ mkAttr qn16 [ mkText "29" ]+                                              ] []+                                            ]+                                          , mkElement qn21+                                            [ mkAttr qn16 [ mkText "30" ]+                                            ] []+                                          ]+                                        , mkElement qn21+                                          [ mkAttr qn16 [ mkText "31" ]+                                          ] []+                                        ]+                                      , mkElement qn21+                                        [ mkAttr qn16 [ mkText "32" ]+                                        ] []+                                      ]+                                    , mkElement qn21+                                      [ mkAttr qn16 [ mkText "33" ]+                                      ] []+                                    ]+                                  , mkElement qn21+                                    [ mkAttr qn16 [ mkText "34" ]+                                    ] []+                                  ]+                                , mkElement qn21+                                  [ mkAttr qn16 [ mkText "35" ]+                                  ] []+                                ]+                              , mkElement qn21+                                [ mkAttr qn16 [ mkText "36" ]+                                ] []+                              ]+                            , mkElement qn21+                              [ mkAttr qn16 [ mkText "37" ]+                              ] []+                            ]+                          , mkElement qn21+                            [ mkAttr qn16 [ mkText "38" ]+                            ] []+                          ]+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "39" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "42" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "43" ]+                      ] []+                    ]+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "44" ]+                    ] []+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "24" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "element"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn6 []+                [ mkElement qn5 []+                  [ mkElement qn17+                    [ mkAttr qn18 [ mkText "" ]+                    ]+                    [ mkText "name"+                    ]+                  , mkElement qn7+                    [ mkAttr qn24 [ mkText "QName" ]+                    , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                    ] []+                  ]+                , mkElement qn15 []+                  [ mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn20 []+                      [ mkElement qn21+                        [ mkAttr qn16 [ mkText "15" ]+                        ] []+                      ]+                    ]+                  , mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn21+                          [ mkAttr qn16 [ mkText "17" ]+                          ] []+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "18" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "19" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "20" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn14 []+                [ mkElement qn14 []+                  [ mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn5 []+                      [ mkElement qn17+                        [ mkAttr qn18 [ mkText "" ]+                        ]+                        [ mkText "ns"+                        ]+                      , mkElement qn23 [] []+                      ]+                    ]+                  , mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn5 []+                      [ mkElement qn17+                        [ mkAttr qn18 [ mkText "" ]+                        ]+                        [ mkText "datatypeLibrary"+                        ]+                      , mkElement qn7+                        [ mkAttr qn24 [ mkText "anyURI" ]+                        , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                        ] []+                      ]+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn20 []+                    [ mkElement qn5 []+                      [ mkElement qn4 []+                        [ mkElement qn12 []+                          [ mkElement qn6 []+                            [ mkElement qn19+                              [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                              ] []+                            , mkElement qn19+                              [ mkAttr qn18 [ mkText "" ]+                              ] []+                            ]+                          ]+                        ]+                      , mkElement qn23 [] []+                      ]+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "15" ]+                    ] []+                  ]+                ]+              , mkElement qn20 []+                [ mkElement qn6 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn6 []+                          [ mkElement qn6 []+                            [ mkElement qn6 []+                              [ mkElement qn6 []+                                [ mkElement qn6 []+                                  [ mkElement qn6 []+                                    [ mkElement qn6 []+                                      [ mkElement qn6 []+                                        [ mkElement qn6 []+                                          [ mkElement qn6 []+                                            [ mkElement qn6 []+                                              [ mkElement qn6 []+                                                [ mkElement qn6 []+                                                  [ mkElement qn6 []+                                                    [ mkElement qn21+                                                      [ mkAttr qn16 [ mkText "24" ]+                                                      ] []+                                                    , mkElement qn21+                                                      [ mkAttr qn16 [ mkText "25" ]+                                                      ] []+                                                    ]+                                                  , mkElement qn21+                                                    [ mkAttr qn16 [ mkText "26" ]+                                                    ] []+                                                  ]+                                                , mkElement qn21+                                                  [ mkAttr qn16 [ mkText "27" ]+                                                  ] []+                                                ]+                                              , mkElement qn21+                                                [ mkAttr qn16 [ mkText "28" ]+                                                ] []+                                              ]+                                            , mkElement qn21+                                              [ mkAttr qn16 [ mkText "29" ]+                                              ] []+                                            ]+                                          , mkElement qn21+                                            [ mkAttr qn16 [ mkText "30" ]+                                            ] []+                                          ]+                                        , mkElement qn21+                                          [ mkAttr qn16 [ mkText "31" ]+                                          ] []+                                        ]+                                      , mkElement qn21+                                        [ mkAttr qn16 [ mkText "32" ]+                                        ] []+                                      ]+                                    , mkElement qn21+                                      [ mkAttr qn16 [ mkText "33" ]+                                      ] []+                                    ]+                                  , mkElement qn21+                                    [ mkAttr qn16 [ mkText "34" ]+                                    ] []+                                  ]+                                , mkElement qn21+                                  [ mkAttr qn16 [ mkText "35" ]+                                  ] []+                                ]+                              , mkElement qn21+                                [ mkAttr qn16 [ mkText "36" ]+                                ] []+                              ]+                            , mkElement qn21+                              [ mkAttr qn16 [ mkText "37" ]+                              ] []+                            ]+                          , mkElement qn21+                            [ mkAttr qn16 [ mkText "38" ]+                            ] []+                          ]+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "39" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "42" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "43" ]+                      ] []+                    ]+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "44" ]+                    ] []+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "23" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "include"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn5 []+                [ mkElement qn17+                  [ mkAttr qn18 [ mkText "" ]+                  ]+                  [ mkText "href"+                  ]+                , mkElement qn7+                  [ mkAttr qn24 [ mkText "anyURI" ]+                  , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                  ] []+                ]+              , mkElement qn14 []+                [ mkElement qn14 []+                  [ mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn5 []+                      [ mkElement qn17+                        [ mkAttr qn18 [ mkText "" ]+                        ]+                        [ mkText "ns"+                        ]+                      , mkElement qn23 [] []+                      ]+                    ]+                  , mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn5 []+                      [ mkElement qn17+                        [ mkAttr qn18 [ mkText "" ]+                        ]+                        [ mkText "datatypeLibrary"+                        ]+                      , mkElement qn7+                        [ mkAttr qn24 [ mkText "anyURI" ]+                        , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                        ] []+                      ]+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn20 []+                    [ mkElement qn5 []+                      [ mkElement qn4 []+                        [ mkElement qn12 []+                          [ mkElement qn6 []+                            [ mkElement qn19+                              [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                              ] []+                            , mkElement qn19+                              [ mkAttr qn18 [ mkText "" ]+                              ] []+                            ]+                          ]+                        ]+                      , mkElement qn23 [] []+                      ]+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "15" ]+                    ] []+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn21+                        [ mkAttr qn16 [ mkText "11" ]+                        ] []+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "10" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "21" ]+                      ] []+                    ]+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "22" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "div"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "15" ]+                    ] []+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn21+                          [ mkAttr qn16 [ mkText "11" ]+                          ] []+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "10" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "22" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "23" ]+                      ] []+                    ]+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "21" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "div"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "15" ]+                    ] []+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn21+                        [ mkAttr qn16 [ mkText "11" ]+                        ] []+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "10" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "21" ]+                      ] []+                    ]+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "20" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "choice"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "15" ]+                    ] []+                  ]+                ]+              , mkElement qn20 []+                [ mkElement qn6 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn21+                        [ mkAttr qn16 [ mkText "17" ]+                        ] []+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "18" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "19" ]+                      ] []+                    ]+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "20" ]+                    ] []+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "19" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "nsName"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "15" ]+                    ] []+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn21+                  [ mkAttr qn16 [ mkText "16" ]+                  ] []+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "18" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "anyName"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "15" ]+                    ] []+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn21+                  [ mkAttr qn16 [ mkText "16" ]+                  ] []+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "17" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "name"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn7+              [ mkAttr qn24 [ mkText "QName" ]+              , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+              ] []+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "16" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "except"+            ]+          , mkElement qn15 []+            [ mkElement qn6 []+              [ mkElement qn11 [] []+              , mkElement qn20 []+                [ mkElement qn21+                  [ mkAttr qn16 [ mkText "15" ]+                  ] []+                ]+              ]+            , mkElement qn20 []+              [ mkElement qn6 []+                [ mkElement qn6 []+                  [ mkElement qn6 []+                    [ mkElement qn21+                      [ mkAttr qn16 [ mkText "17" ]+                      ] []+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "18" ]+                      ] []+                    ]+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "19" ]+                    ] []+                  ]+                , mkElement qn21+                  [ mkAttr qn16 [ mkText "20" ]+                  ] []+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "15" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn4 []+            [ mkElement qn12 []+              [ mkElement qn19+                [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                ] []+              ]+            ]+          , mkElement qn6 []+            [ mkElement qn11 [] []+            , mkElement qn20 []+              [ mkElement qn6 []+                [ mkElement qn6 []+                  [ mkElement qn5 []+                    [ mkElement qn4 [] []+                    , mkElement qn23 [] []+                    ]+                  , mkElement qn23 [] []+                  ]+                , mkElement qn21+                  [ mkAttr qn16 [ mkText "0" ]+                  ] []+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "0" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn4 [] []+          , mkElement qn6 []+            [ mkElement qn11 [] []+            , mkElement qn20 []+              [ mkElement qn6 []+                [ mkElement qn6 []+                  [ mkElement qn5 []+                    [ mkElement qn4 [] []+                    , mkElement qn23 [] []+                    ]+                  , mkElement qn23 [] []+                  ]+                , mkElement qn21+                  [ mkAttr qn16 [ mkText "0" ]+                  ] []+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "10" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "define"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn5 []+                  [ mkElement qn17+                    [ mkAttr qn18 [ mkText "" ]+                    ]+                    [ mkText "name"+                    ]+                  , mkElement qn7+                    [ mkAttr qn24 [ mkText "NCName" ]+                    , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                    ] []+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "combine"+                      ]+                    , mkElement qn6 []+                      [ mkElement qn25+                        [ mkAttr qn1 [ mkText "http://www.w3.org/XML/1998/namespace" ]+                        , mkAttr qn3 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                        , mkAttr qn2 [ mkText "file:///home/uwe/haskell/hxt/curr/src/Text/XML/HXT/RelaxNG/schema2hs/Schema.rng" ]+                        , mkAttr qn8 [ mkText "" ]+                        , mkAttr qn24 [ mkText "token" ]+                        , mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                        ]+                        [ mkText "choice"+                        ]+                      , mkElement qn25+                        [ mkAttr qn1 [ mkText "http://www.w3.org/XML/1998/namespace" ]+                        , mkAttr qn3 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                        , mkAttr qn2 [ mkText "file:///home/uwe/haskell/hxt/curr/src/Text/XML/HXT/RelaxNG/schema2hs/Schema.rng" ]+                        , mkAttr qn8 [ mkText "" ]+                        , mkAttr qn24 [ mkText "token" ]+                        , mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                        ]+                        [ mkText "interleave"+                        ]+                      ]+                    ]+                  ]+                ]+              , mkElement qn14 []+                [ mkElement qn14 []+                  [ mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn5 []+                      [ mkElement qn17+                        [ mkAttr qn18 [ mkText "" ]+                        ]+                        [ mkText "ns"+                        ]+                      , mkElement qn23 [] []+                      ]+                    ]+                  , mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn5 []+                      [ mkElement qn17+                        [ mkAttr qn18 [ mkText "" ]+                        ]+                        [ mkText "datatypeLibrary"+                        ]+                      , mkElement qn7+                        [ mkAttr qn24 [ mkText "anyURI" ]+                        , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                        ] []+                      ]+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn20 []+                    [ mkElement qn5 []+                      [ mkElement qn4 []+                        [ mkElement qn12 []+                          [ mkElement qn6 []+                            [ mkElement qn19+                              [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                              ] []+                            , mkElement qn19+                              [ mkAttr qn18 [ mkText "" ]+                              ] []+                            ]+                          ]+                        ]+                      , mkElement qn23 [] []+                      ]+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "15" ]+                    ] []+                  ]+                ]+              , mkElement qn20 []+                [ mkElement qn6 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn6 []+                          [ mkElement qn6 []+                            [ mkElement qn6 []+                              [ mkElement qn6 []+                                [ mkElement qn6 []+                                  [ mkElement qn6 []+                                    [ mkElement qn6 []+                                      [ mkElement qn6 []+                                        [ mkElement qn6 []+                                          [ mkElement qn6 []+                                            [ mkElement qn6 []+                                              [ mkElement qn6 []+                                                [ mkElement qn6 []+                                                  [ mkElement qn6 []+                                                    [ mkElement qn21+                                                      [ mkAttr qn16 [ mkText "24" ]+                                                      ] []+                                                    , mkElement qn21+                                                      [ mkAttr qn16 [ mkText "25" ]+                                                      ] []+                                                    ]+                                                  , mkElement qn21+                                                    [ mkAttr qn16 [ mkText "26" ]+                                                    ] []+                                                  ]+                                                , mkElement qn21+                                                  [ mkAttr qn16 [ mkText "27" ]+                                                  ] []+                                                ]+                                              , mkElement qn21+                                                [ mkAttr qn16 [ mkText "28" ]+                                                ] []+                                              ]+                                            , mkElement qn21+                                              [ mkAttr qn16 [ mkText "29" ]+                                              ] []+                                            ]+                                          , mkElement qn21+                                            [ mkAttr qn16 [ mkText "30" ]+                                            ] []+                                          ]+                                        , mkElement qn21+                                          [ mkAttr qn16 [ mkText "31" ]+                                          ] []+                                        ]+                                      , mkElement qn21+                                        [ mkAttr qn16 [ mkText "32" ]+                                        ] []+                                      ]+                                    , mkElement qn21+                                      [ mkAttr qn16 [ mkText "33" ]+                                      ] []+                                    ]+                                  , mkElement qn21+                                    [ mkAttr qn16 [ mkText "34" ]+                                    ] []+                                  ]+                                , mkElement qn21+                                  [ mkAttr qn16 [ mkText "35" ]+                                  ] []+                                ]+                              , mkElement qn21+                                [ mkAttr qn16 [ mkText "36" ]+                                ] []+                              ]+                            , mkElement qn21+                              [ mkAttr qn16 [ mkText "37" ]+                              ] []+                            ]+                          , mkElement qn21+                            [ mkAttr qn16 [ mkText "38" ]+                            ] []+                          ]+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "39" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "42" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "43" ]+                      ] []+                    ]+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "44" ]+                    ] []+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "11" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "start"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn5 []+                  [ mkElement qn17+                    [ mkAttr qn18 [ mkText "" ]+                    ]+                    [ mkText "combine"+                    ]+                  , mkElement qn6 []+                    [ mkElement qn25+                      [ mkAttr qn1 [ mkText "http://www.w3.org/XML/1998/namespace" ]+                      , mkAttr qn3 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                      , mkAttr qn2 [ mkText "file:///home/uwe/haskell/hxt/curr/src/Text/XML/HXT/RelaxNG/schema2hs/Schema.rng" ]+                      , mkAttr qn8 [ mkText "" ]+                      , mkAttr qn24 [ mkText "token" ]+                      , mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                      ]+                      [ mkText "choice"+                      ]+                    , mkElement qn25+                      [ mkAttr qn1 [ mkText "http://www.w3.org/XML/1998/namespace" ]+                      , mkAttr qn3 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                      , mkAttr qn2 [ mkText "file:///home/uwe/haskell/hxt/curr/src/Text/XML/HXT/RelaxNG/schema2hs/Schema.rng" ]+                      , mkAttr qn8 [ mkText "" ]+                      , mkAttr qn24 [ mkText "token" ]+                      , mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                      ]+                      [ mkText "interleave"+                      ]+                    ]+                  ]+                ]+              , mkElement qn14 []+                [ mkElement qn14 []+                  [ mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn5 []+                      [ mkElement qn17+                        [ mkAttr qn18 [ mkText "" ]+                        ]+                        [ mkText "ns"+                        ]+                      , mkElement qn23 [] []+                      ]+                    ]+                  , mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn5 []+                      [ mkElement qn17+                        [ mkAttr qn18 [ mkText "" ]+                        ]+                        [ mkText "datatypeLibrary"+                        ]+                      , mkElement qn7+                        [ mkAttr qn24 [ mkText "anyURI" ]+                        , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                        ] []+                      ]+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn20 []+                    [ mkElement qn5 []+                      [ mkElement qn4 []+                        [ mkElement qn12 []+                          [ mkElement qn6 []+                            [ mkElement qn19+                              [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                              ] []+                            , mkElement qn19+                              [ mkAttr qn18 [ mkText "" ]+                              ] []+                            ]+                          ]+                        ]+                      , mkElement qn23 [] []+                      ]+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "15" ]+                    ] []+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn6 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn6 []+                          [ mkElement qn6 []+                            [ mkElement qn6 []+                              [ mkElement qn6 []+                                [ mkElement qn6 []+                                  [ mkElement qn6 []+                                    [ mkElement qn6 []+                                      [ mkElement qn6 []+                                        [ mkElement qn6 []+                                          [ mkElement qn6 []+                                            [ mkElement qn6 []+                                              [ mkElement qn6 []+                                                [ mkElement qn6 []+                                                  [ mkElement qn21+                                                    [ mkAttr qn16 [ mkText "24" ]+                                                    ] []+                                                  , mkElement qn21+                                                    [ mkAttr qn16 [ mkText "25" ]+                                                    ] []+                                                  ]+                                                , mkElement qn21+                                                  [ mkAttr qn16 [ mkText "26" ]+                                                  ] []+                                                ]+                                              , mkElement qn21+                                                [ mkAttr qn16 [ mkText "27" ]+                                                ] []+                                              ]+                                            , mkElement qn21+                                              [ mkAttr qn16 [ mkText "28" ]+                                              ] []+                                            ]+                                          , mkElement qn21+                                            [ mkAttr qn16 [ mkText "29" ]+                                            ] []+                                          ]+                                        , mkElement qn21+                                          [ mkAttr qn16 [ mkText "30" ]+                                          ] []+                                        ]+                                      , mkElement qn21+                                        [ mkAttr qn16 [ mkText "31" ]+                                        ] []+                                      ]+                                    , mkElement qn21+                                      [ mkAttr qn16 [ mkText "32" ]+                                      ] []+                                    ]+                                  , mkElement qn21+                                    [ mkAttr qn16 [ mkText "33" ]+                                    ] []+                                  ]+                                , mkElement qn21+                                  [ mkAttr qn16 [ mkText "34" ]+                                  ] []+                                ]+                              , mkElement qn21+                                [ mkAttr qn16 [ mkText "35" ]+                                ] []+                              ]+                            , mkElement qn21+                              [ mkAttr qn16 [ mkText "36" ]+                              ] []+                            ]+                          , mkElement qn21+                            [ mkAttr qn16 [ mkText "37" ]+                            ] []+                          ]+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "38" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "39" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "42" ]+                      ] []+                    ]+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "43" ]+                    ] []+                  ]+                , mkElement qn21+                  [ mkAttr qn16 [ mkText "44" ]+                  ] []+                ]+              ]+            ]+          ]+        ]+      ]+    ]
+ src/Yuuko/Text/XML/HXT/RelaxNG/SchemaGrammar.hs view
@@ -0,0 +1,3831 @@+{- |+   Module     : Text.HXT.RelaxNG.SchemaGrammar++   Don't edit this module, it's generated by RelaxSchemaToXmlTree++-}++module Yuuko.Text.XML.HXT.RelaxNG.SchemaGrammar+    ( relaxSchemaTree, relaxSchemaArrow )+where++import Yuuko.Text.XML.HXT.DOM.TypeDefs+import Yuuko.Text.XML.HXT.DOM.XmlNode (mkRoot, mkElement, mkAttr, mkText)++import Yuuko.Control.Arrow.ListArrows++relaxSchemaArrow :: ArrowList a => a b XmlTree+relaxSchemaArrow = constA relaxSchemaTree++relaxSchemaTree :: XmlTree+relaxSchemaTree =+  let+  ns1	= "http://relaxng.org/ns/structure/1.0"+  qn1	= mkSNsName "RelaxContext:xml"+  qn2	= mkSNsName "RelaxContextBaseURI"+  qn3	= mkSNsName "RelaxContextDefault"+  qn4	= mkNsName "anyName" ns1+  qn5	= mkNsName "attribute" ns1+  qn6	= mkNsName "choice" ns1+  qn7	= mkNsName "data" ns1+  qn8	= mkSNsName "datatypeLibrary"+  qn9	= mkNsName "define" ns1+  qn10	= mkNsName "element" ns1+  qn11	= mkNsName "empty" ns1+  qn12	= mkNsName "except" ns1+  qn13	= mkNsName "grammar" ns1+  qn14	= mkNsName "group" ns1+  qn15	= mkNsName "interleave" ns1+  qn16	= mkSNsName "name"+  qn17	= mkNsName "name" ns1+  qn18	= mkSNsName "ns"+  qn19	= mkNsName "nsName" ns1+  qn20	= mkNsName "oneOrMore" ns1+  qn21	= mkNsName "ref" ns1+  qn22	= mkNsName "start" ns1+  qn23	= mkNsName "text" ns1+  qn24	= mkSNsName "type"+  qn25	= mkNsName "value" ns1+  in+  mkRoot []+    [ mkElement qn13 []+      [ mkElement qn22 []+        [ mkElement qn21+          [ mkAttr qn16 [ mkText "14" ]+          ] []+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "44" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "externalRef"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn5 []+                [ mkElement qn17+                  [ mkAttr qn18 [ mkText "" ]+                  ]+                  [ mkText "href"+                  ]+                , mkElement qn7+                  [ mkAttr qn24 [ mkText "anyURI" ]+                  , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                  ] []+                ]+              , mkElement qn14 []+                [ mkElement qn14 []+                  [ mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn5 []+                      [ mkElement qn17+                        [ mkAttr qn18 [ mkText "" ]+                        ]+                        [ mkText "ns"+                        ]+                      , mkElement qn23 [] []+                      ]+                    ]+                  , mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn5 []+                      [ mkElement qn17+                        [ mkAttr qn18 [ mkText "" ]+                        ]+                        [ mkText "datatypeLibrary"+                        ]+                      , mkElement qn7+                        [ mkAttr qn24 [ mkText "anyURI" ]+                        , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                        ] []+                      ]+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn20 []+                    [ mkElement qn5 []+                      [ mkElement qn4 []+                        [ mkElement qn12 []+                          [ mkElement qn6 []+                            [ mkElement qn19+                              [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                              ] []+                            , mkElement qn19+                              [ mkAttr qn18 [ mkText "" ]+                              ] []+                            ]+                          ]+                        ]+                      , mkElement qn23 [] []+                      ]+                    ]+                  ]+                ]+              ]+            , mkElement qn6 []+              [ mkElement qn11 [] []+              , mkElement qn20 []+                [ mkElement qn21+                  [ mkAttr qn16 [ mkText "16" ]+                  ] []+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "43" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "notAllowed"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn6 []+              [ mkElement qn11 [] []+              , mkElement qn20 []+                [ mkElement qn21+                  [ mkAttr qn16 [ mkText "16" ]+                  ] []+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "40" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "data"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn5 []+                [ mkElement qn17+                  [ mkAttr qn18 [ mkText "" ]+                  ]+                  [ mkText "type"+                  ]+                , mkElement qn7+                  [ mkAttr qn24 [ mkText "NCName" ]+                  , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                  ] []+                ]+              , mkElement qn14 []+                [ mkElement qn14 []+                  [ mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn5 []+                      [ mkElement qn17+                        [ mkAttr qn18 [ mkText "" ]+                        ]+                        [ mkText "ns"+                        ]+                      , mkElement qn23 [] []+                      ]+                    ]+                  , mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn5 []+                      [ mkElement qn17+                        [ mkAttr qn18 [ mkText "" ]+                        ]+                        [ mkText "datatypeLibrary"+                        ]+                      , mkElement qn7+                        [ mkAttr qn24 [ mkText "anyURI" ]+                        , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                        ] []+                      ]+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn20 []+                    [ mkElement qn5 []+                      [ mkElement qn4 []+                        [ mkElement qn12 []+                          [ mkElement qn6 []+                            [ mkElement qn19+                              [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                              ] []+                            , mkElement qn19+                              [ mkAttr qn18 [ mkText "" ]+                              ] []+                            ]+                          ]+                        ]+                      , mkElement qn23 [] []+                      ]+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "16" ]+                    ] []+                  ]+                ]+              , mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn20 []+                    [ mkElement qn21+                      [ mkAttr qn16 [ mkText "41" ]+                      ] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "42" ]+                    ] []+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "42" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "except"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "16" ]+                    ] []+                  ]+                ]+              , mkElement qn20 []+                [ mkElement qn6 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn6 []+                          [ mkElement qn6 []+                            [ mkElement qn6 []+                              [ mkElement qn6 []+                                [ mkElement qn6 []+                                  [ mkElement qn6 []+                                    [ mkElement qn6 []+                                      [ mkElement qn6 []+                                        [ mkElement qn6 []+                                          [ mkElement qn6 []+                                            [ mkElement qn6 []+                                              [ mkElement qn6 []+                                                [ mkElement qn6 []+                                                  [ mkElement qn6 []+                                                    [ mkElement qn21+                                                      [ mkAttr qn16 [ mkText "25" ]+                                                      ] []+                                                    , mkElement qn21+                                                      [ mkAttr qn16 [ mkText "26" ]+                                                      ] []+                                                    ]+                                                  , mkElement qn21+                                                    [ mkAttr qn16 [ mkText "27" ]+                                                    ] []+                                                  ]+                                                , mkElement qn21+                                                  [ mkAttr qn16 [ mkText "28" ]+                                                  ] []+                                                ]+                                              , mkElement qn21+                                                [ mkAttr qn16 [ mkText "29" ]+                                                ] []+                                              ]+                                            , mkElement qn21+                                              [ mkAttr qn16 [ mkText "30" ]+                                              ] []+                                            ]+                                          , mkElement qn21+                                            [ mkAttr qn16 [ mkText "31" ]+                                            ] []+                                          ]+                                        , mkElement qn21+                                          [ mkAttr qn16 [ mkText "32" ]+                                          ] []+                                        ]+                                      , mkElement qn21+                                        [ mkAttr qn16 [ mkText "33" ]+                                        ] []+                                      ]+                                    , mkElement qn21+                                      [ mkAttr qn16 [ mkText "34" ]+                                      ] []+                                    ]+                                  , mkElement qn21+                                    [ mkAttr qn16 [ mkText "35" ]+                                    ] []+                                  ]+                                , mkElement qn21+                                  [ mkAttr qn16 [ mkText "36" ]+                                  ] []+                                ]+                              , mkElement qn21+                                [ mkAttr qn16 [ mkText "37" ]+                                ] []+                              ]+                            , mkElement qn21+                              [ mkAttr qn16 [ mkText "38" ]+                              ] []+                            ]+                          , mkElement qn21+                            [ mkAttr qn16 [ mkText "39" ]+                            ] []+                          ]+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "40" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "43" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "44" ]+                      ] []+                    ]+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "14" ]+                    ] []+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "41" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "param"+            ]+          , mkElement qn14 []+            [ mkElement qn5 []+              [ mkElement qn17+                [ mkAttr qn18 [ mkText "" ]+                ]+                [ mkText "name"+                ]+              , mkElement qn7+                [ mkAttr qn24 [ mkText "NCName" ]+                , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                ] []+              ]+            , mkElement qn23 [] []+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "39" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "value"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn5 []+                  [ mkElement qn17+                    [ mkAttr qn18 [ mkText "" ]+                    ]+                    [ mkText "type"+                    ]+                  , mkElement qn7+                    [ mkAttr qn24 [ mkText "NCName" ]+                    , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                    ] []+                  ]+                ]+              , mkElement qn14 []+                [ mkElement qn14 []+                  [ mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn5 []+                      [ mkElement qn17+                        [ mkAttr qn18 [ mkText "" ]+                        ]+                        [ mkText "ns"+                        ]+                      , mkElement qn23 [] []+                      ]+                    ]+                  , mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn5 []+                      [ mkElement qn17+                        [ mkAttr qn18 [ mkText "" ]+                        ]+                        [ mkText "datatypeLibrary"+                        ]+                      , mkElement qn7+                        [ mkAttr qn24 [ mkText "anyURI" ]+                        , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                        ] []+                      ]+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn20 []+                    [ mkElement qn5 []+                      [ mkElement qn4 []+                        [ mkElement qn12 []+                          [ mkElement qn6 []+                            [ mkElement qn19+                              [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                              ] []+                            , mkElement qn19+                              [ mkAttr qn18 [ mkText "" ]+                              ] []+                            ]+                          ]+                        ]+                      , mkElement qn23 [] []+                      ]+                    ]+                  ]+                ]+              ]+            , mkElement qn23 [] []+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "38" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "text"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn6 []+              [ mkElement qn11 [] []+              , mkElement qn20 []+                [ mkElement qn21+                  [ mkAttr qn16 [ mkText "16" ]+                  ] []+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "37" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "empty"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn6 []+              [ mkElement qn11 [] []+              , mkElement qn20 []+                [ mkElement qn21+                  [ mkAttr qn16 [ mkText "16" ]+                  ] []+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "36" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "parentRef"+            ]+          , mkElement qn14 []+            [ mkElement qn5 []+              [ mkElement qn17+                [ mkAttr qn18 [ mkText "" ]+                ]+                [ mkText "name"+                ]+              , mkElement qn7+                [ mkAttr qn24 [ mkText "NCName" ]+                , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                ] []+              ]+            , mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "35" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "ref"+            ]+          , mkElement qn14 []+            [ mkElement qn5 []+              [ mkElement qn17+                [ mkAttr qn18 [ mkText "" ]+                ]+                [ mkText "name"+                ]+              , mkElement qn7+                [ mkAttr qn24 [ mkText "NCName" ]+                , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                ] []+              ]+            , mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "34" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "mixed"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "16" ]+                    ] []+                  ]+                ]+              , mkElement qn20 []+                [ mkElement qn6 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn6 []+                          [ mkElement qn6 []+                            [ mkElement qn6 []+                              [ mkElement qn6 []+                                [ mkElement qn6 []+                                  [ mkElement qn6 []+                                    [ mkElement qn6 []+                                      [ mkElement qn6 []+                                        [ mkElement qn6 []+                                          [ mkElement qn6 []+                                            [ mkElement qn6 []+                                              [ mkElement qn6 []+                                                [ mkElement qn6 []+                                                  [ mkElement qn6 []+                                                    [ mkElement qn21+                                                      [ mkAttr qn16 [ mkText "25" ]+                                                      ] []+                                                    , mkElement qn21+                                                      [ mkAttr qn16 [ mkText "26" ]+                                                      ] []+                                                    ]+                                                  , mkElement qn21+                                                    [ mkAttr qn16 [ mkText "27" ]+                                                    ] []+                                                  ]+                                                , mkElement qn21+                                                  [ mkAttr qn16 [ mkText "28" ]+                                                  ] []+                                                ]+                                              , mkElement qn21+                                                [ mkAttr qn16 [ mkText "29" ]+                                                ] []+                                              ]+                                            , mkElement qn21+                                              [ mkAttr qn16 [ mkText "30" ]+                                              ] []+                                            ]+                                          , mkElement qn21+                                            [ mkAttr qn16 [ mkText "31" ]+                                            ] []+                                          ]+                                        , mkElement qn21+                                          [ mkAttr qn16 [ mkText "32" ]+                                          ] []+                                        ]+                                      , mkElement qn21+                                        [ mkAttr qn16 [ mkText "33" ]+                                        ] []+                                      ]+                                    , mkElement qn21+                                      [ mkAttr qn16 [ mkText "34" ]+                                      ] []+                                    ]+                                  , mkElement qn21+                                    [ mkAttr qn16 [ mkText "35" ]+                                    ] []+                                  ]+                                , mkElement qn21+                                  [ mkAttr qn16 [ mkText "36" ]+                                  ] []+                                ]+                              , mkElement qn21+                                [ mkAttr qn16 [ mkText "37" ]+                                ] []+                              ]+                            , mkElement qn21+                              [ mkAttr qn16 [ mkText "38" ]+                              ] []+                            ]+                          , mkElement qn21+                            [ mkAttr qn16 [ mkText "39" ]+                            ] []+                          ]+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "40" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "43" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "44" ]+                      ] []+                    ]+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "14" ]+                    ] []+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "33" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "list"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "16" ]+                    ] []+                  ]+                ]+              , mkElement qn20 []+                [ mkElement qn6 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn6 []+                          [ mkElement qn6 []+                            [ mkElement qn6 []+                              [ mkElement qn6 []+                                [ mkElement qn6 []+                                  [ mkElement qn6 []+                                    [ mkElement qn6 []+                                      [ mkElement qn6 []+                                        [ mkElement qn6 []+                                          [ mkElement qn6 []+                                            [ mkElement qn6 []+                                              [ mkElement qn6 []+                                                [ mkElement qn6 []+                                                  [ mkElement qn6 []+                                                    [ mkElement qn21+                                                      [ mkAttr qn16 [ mkText "25" ]+                                                      ] []+                                                    , mkElement qn21+                                                      [ mkAttr qn16 [ mkText "26" ]+                                                      ] []+                                                    ]+                                                  , mkElement qn21+                                                    [ mkAttr qn16 [ mkText "27" ]+                                                    ] []+                                                  ]+                                                , mkElement qn21+                                                  [ mkAttr qn16 [ mkText "28" ]+                                                  ] []+                                                ]+                                              , mkElement qn21+                                                [ mkAttr qn16 [ mkText "29" ]+                                                ] []+                                              ]+                                            , mkElement qn21+                                              [ mkAttr qn16 [ mkText "30" ]+                                              ] []+                                            ]+                                          , mkElement qn21+                                            [ mkAttr qn16 [ mkText "31" ]+                                            ] []+                                          ]+                                        , mkElement qn21+                                          [ mkAttr qn16 [ mkText "32" ]+                                          ] []+                                        ]+                                      , mkElement qn21+                                        [ mkAttr qn16 [ mkText "33" ]+                                        ] []+                                      ]+                                    , mkElement qn21+                                      [ mkAttr qn16 [ mkText "34" ]+                                      ] []+                                    ]+                                  , mkElement qn21+                                    [ mkAttr qn16 [ mkText "35" ]+                                    ] []+                                  ]+                                , mkElement qn21+                                  [ mkAttr qn16 [ mkText "36" ]+                                  ] []+                                ]+                              , mkElement qn21+                                [ mkAttr qn16 [ mkText "37" ]+                                ] []+                              ]+                            , mkElement qn21+                              [ mkAttr qn16 [ mkText "38" ]+                              ] []+                            ]+                          , mkElement qn21+                            [ mkAttr qn16 [ mkText "39" ]+                            ] []+                          ]+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "40" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "43" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "44" ]+                      ] []+                    ]+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "14" ]+                    ] []+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "32" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "oneOrMore"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "16" ]+                    ] []+                  ]+                ]+              , mkElement qn20 []+                [ mkElement qn6 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn6 []+                          [ mkElement qn6 []+                            [ mkElement qn6 []+                              [ mkElement qn6 []+                                [ mkElement qn6 []+                                  [ mkElement qn6 []+                                    [ mkElement qn6 []+                                      [ mkElement qn6 []+                                        [ mkElement qn6 []+                                          [ mkElement qn6 []+                                            [ mkElement qn6 []+                                              [ mkElement qn6 []+                                                [ mkElement qn6 []+                                                  [ mkElement qn6 []+                                                    [ mkElement qn21+                                                      [ mkAttr qn16 [ mkText "25" ]+                                                      ] []+                                                    , mkElement qn21+                                                      [ mkAttr qn16 [ mkText "26" ]+                                                      ] []+                                                    ]+                                                  , mkElement qn21+                                                    [ mkAttr qn16 [ mkText "27" ]+                                                    ] []+                                                  ]+                                                , mkElement qn21+                                                  [ mkAttr qn16 [ mkText "28" ]+                                                  ] []+                                                ]+                                              , mkElement qn21+                                                [ mkAttr qn16 [ mkText "29" ]+                                                ] []+                                              ]+                                            , mkElement qn21+                                              [ mkAttr qn16 [ mkText "30" ]+                                              ] []+                                            ]+                                          , mkElement qn21+                                            [ mkAttr qn16 [ mkText "31" ]+                                            ] []+                                          ]+                                        , mkElement qn21+                                          [ mkAttr qn16 [ mkText "32" ]+                                          ] []+                                        ]+                                      , mkElement qn21+                                        [ mkAttr qn16 [ mkText "33" ]+                                        ] []+                                      ]+                                    , mkElement qn21+                                      [ mkAttr qn16 [ mkText "34" ]+                                      ] []+                                    ]+                                  , mkElement qn21+                                    [ mkAttr qn16 [ mkText "35" ]+                                    ] []+                                  ]+                                , mkElement qn21+                                  [ mkAttr qn16 [ mkText "36" ]+                                  ] []+                                ]+                              , mkElement qn21+                                [ mkAttr qn16 [ mkText "37" ]+                                ] []+                              ]+                            , mkElement qn21+                              [ mkAttr qn16 [ mkText "38" ]+                              ] []+                            ]+                          , mkElement qn21+                            [ mkAttr qn16 [ mkText "39" ]+                            ] []+                          ]+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "40" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "43" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "44" ]+                      ] []+                    ]+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "14" ]+                    ] []+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "31" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "zeroOrMore"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "16" ]+                    ] []+                  ]+                ]+              , mkElement qn20 []+                [ mkElement qn6 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn6 []+                          [ mkElement qn6 []+                            [ mkElement qn6 []+                              [ mkElement qn6 []+                                [ mkElement qn6 []+                                  [ mkElement qn6 []+                                    [ mkElement qn6 []+                                      [ mkElement qn6 []+                                        [ mkElement qn6 []+                                          [ mkElement qn6 []+                                            [ mkElement qn6 []+                                              [ mkElement qn6 []+                                                [ mkElement qn6 []+                                                  [ mkElement qn6 []+                                                    [ mkElement qn21+                                                      [ mkAttr qn16 [ mkText "25" ]+                                                      ] []+                                                    , mkElement qn21+                                                      [ mkAttr qn16 [ mkText "26" ]+                                                      ] []+                                                    ]+                                                  , mkElement qn21+                                                    [ mkAttr qn16 [ mkText "27" ]+                                                    ] []+                                                  ]+                                                , mkElement qn21+                                                  [ mkAttr qn16 [ mkText "28" ]+                                                  ] []+                                                ]+                                              , mkElement qn21+                                                [ mkAttr qn16 [ mkText "29" ]+                                                ] []+                                              ]+                                            , mkElement qn21+                                              [ mkAttr qn16 [ mkText "30" ]+                                              ] []+                                            ]+                                          , mkElement qn21+                                            [ mkAttr qn16 [ mkText "31" ]+                                            ] []+                                          ]+                                        , mkElement qn21+                                          [ mkAttr qn16 [ mkText "32" ]+                                          ] []+                                        ]+                                      , mkElement qn21+                                        [ mkAttr qn16 [ mkText "33" ]+                                        ] []+                                      ]+                                    , mkElement qn21+                                      [ mkAttr qn16 [ mkText "34" ]+                                      ] []+                                    ]+                                  , mkElement qn21+                                    [ mkAttr qn16 [ mkText "35" ]+                                    ] []+                                  ]+                                , mkElement qn21+                                  [ mkAttr qn16 [ mkText "36" ]+                                  ] []+                                ]+                              , mkElement qn21+                                [ mkAttr qn16 [ mkText "37" ]+                                ] []+                              ]+                            , mkElement qn21+                              [ mkAttr qn16 [ mkText "38" ]+                              ] []+                            ]+                          , mkElement qn21+                            [ mkAttr qn16 [ mkText "39" ]+                            ] []+                          ]+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "40" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "43" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "44" ]+                      ] []+                    ]+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "14" ]+                    ] []+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "30" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "optional"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "16" ]+                    ] []+                  ]+                ]+              , mkElement qn20 []+                [ mkElement qn6 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn6 []+                          [ mkElement qn6 []+                            [ mkElement qn6 []+                              [ mkElement qn6 []+                                [ mkElement qn6 []+                                  [ mkElement qn6 []+                                    [ mkElement qn6 []+                                      [ mkElement qn6 []+                                        [ mkElement qn6 []+                                          [ mkElement qn6 []+                                            [ mkElement qn6 []+                                              [ mkElement qn6 []+                                                [ mkElement qn6 []+                                                  [ mkElement qn6 []+                                                    [ mkElement qn21+                                                      [ mkAttr qn16 [ mkText "25" ]+                                                      ] []+                                                    , mkElement qn21+                                                      [ mkAttr qn16 [ mkText "26" ]+                                                      ] []+                                                    ]+                                                  , mkElement qn21+                                                    [ mkAttr qn16 [ mkText "27" ]+                                                    ] []+                                                  ]+                                                , mkElement qn21+                                                  [ mkAttr qn16 [ mkText "28" ]+                                                  ] []+                                                ]+                                              , mkElement qn21+                                                [ mkAttr qn16 [ mkText "29" ]+                                                ] []+                                              ]+                                            , mkElement qn21+                                              [ mkAttr qn16 [ mkText "30" ]+                                              ] []+                                            ]+                                          , mkElement qn21+                                            [ mkAttr qn16 [ mkText "31" ]+                                            ] []+                                          ]+                                        , mkElement qn21+                                          [ mkAttr qn16 [ mkText "32" ]+                                          ] []+                                        ]+                                      , mkElement qn21+                                        [ mkAttr qn16 [ mkText "33" ]+                                        ] []+                                      ]+                                    , mkElement qn21+                                      [ mkAttr qn16 [ mkText "34" ]+                                      ] []+                                    ]+                                  , mkElement qn21+                                    [ mkAttr qn16 [ mkText "35" ]+                                    ] []+                                  ]+                                , mkElement qn21+                                  [ mkAttr qn16 [ mkText "36" ]+                                  ] []+                                ]+                              , mkElement qn21+                                [ mkAttr qn16 [ mkText "37" ]+                                ] []+                              ]+                            , mkElement qn21+                              [ mkAttr qn16 [ mkText "38" ]+                              ] []+                            ]+                          , mkElement qn21+                            [ mkAttr qn16 [ mkText "39" ]+                            ] []+                          ]+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "40" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "43" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "44" ]+                      ] []+                    ]+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "14" ]+                    ] []+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "29" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "choice"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "16" ]+                    ] []+                  ]+                ]+              , mkElement qn20 []+                [ mkElement qn6 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn6 []+                          [ mkElement qn6 []+                            [ mkElement qn6 []+                              [ mkElement qn6 []+                                [ mkElement qn6 []+                                  [ mkElement qn6 []+                                    [ mkElement qn6 []+                                      [ mkElement qn6 []+                                        [ mkElement qn6 []+                                          [ mkElement qn6 []+                                            [ mkElement qn6 []+                                              [ mkElement qn6 []+                                                [ mkElement qn6 []+                                                  [ mkElement qn6 []+                                                    [ mkElement qn21+                                                      [ mkAttr qn16 [ mkText "25" ]+                                                      ] []+                                                    , mkElement qn21+                                                      [ mkAttr qn16 [ mkText "26" ]+                                                      ] []+                                                    ]+                                                  , mkElement qn21+                                                    [ mkAttr qn16 [ mkText "27" ]+                                                    ] []+                                                  ]+                                                , mkElement qn21+                                                  [ mkAttr qn16 [ mkText "28" ]+                                                  ] []+                                                ]+                                              , mkElement qn21+                                                [ mkAttr qn16 [ mkText "29" ]+                                                ] []+                                              ]+                                            , mkElement qn21+                                              [ mkAttr qn16 [ mkText "30" ]+                                              ] []+                                            ]+                                          , mkElement qn21+                                            [ mkAttr qn16 [ mkText "31" ]+                                            ] []+                                          ]+                                        , mkElement qn21+                                          [ mkAttr qn16 [ mkText "32" ]+                                          ] []+                                        ]+                                      , mkElement qn21+                                        [ mkAttr qn16 [ mkText "33" ]+                                        ] []+                                      ]+                                    , mkElement qn21+                                      [ mkAttr qn16 [ mkText "34" ]+                                      ] []+                                    ]+                                  , mkElement qn21+                                    [ mkAttr qn16 [ mkText "35" ]+                                    ] []+                                  ]+                                , mkElement qn21+                                  [ mkAttr qn16 [ mkText "36" ]+                                  ] []+                                ]+                              , mkElement qn21+                                [ mkAttr qn16 [ mkText "37" ]+                                ] []+                              ]+                            , mkElement qn21+                              [ mkAttr qn16 [ mkText "38" ]+                              ] []+                            ]+                          , mkElement qn21+                            [ mkAttr qn16 [ mkText "39" ]+                            ] []+                          ]+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "40" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "43" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "44" ]+                      ] []+                    ]+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "14" ]+                    ] []+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "28" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "interleave"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "16" ]+                    ] []+                  ]+                ]+              , mkElement qn20 []+                [ mkElement qn6 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn6 []+                          [ mkElement qn6 []+                            [ mkElement qn6 []+                              [ mkElement qn6 []+                                [ mkElement qn6 []+                                  [ mkElement qn6 []+                                    [ mkElement qn6 []+                                      [ mkElement qn6 []+                                        [ mkElement qn6 []+                                          [ mkElement qn6 []+                                            [ mkElement qn6 []+                                              [ mkElement qn6 []+                                                [ mkElement qn6 []+                                                  [ mkElement qn6 []+                                                    [ mkElement qn21+                                                      [ mkAttr qn16 [ mkText "25" ]+                                                      ] []+                                                    , mkElement qn21+                                                      [ mkAttr qn16 [ mkText "26" ]+                                                      ] []+                                                    ]+                                                  , mkElement qn21+                                                    [ mkAttr qn16 [ mkText "27" ]+                                                    ] []+                                                  ]+                                                , mkElement qn21+                                                  [ mkAttr qn16 [ mkText "28" ]+                                                  ] []+                                                ]+                                              , mkElement qn21+                                                [ mkAttr qn16 [ mkText "29" ]+                                                ] []+                                              ]+                                            , mkElement qn21+                                              [ mkAttr qn16 [ mkText "30" ]+                                              ] []+                                            ]+                                          , mkElement qn21+                                            [ mkAttr qn16 [ mkText "31" ]+                                            ] []+                                          ]+                                        , mkElement qn21+                                          [ mkAttr qn16 [ mkText "32" ]+                                          ] []+                                        ]+                                      , mkElement qn21+                                        [ mkAttr qn16 [ mkText "33" ]+                                        ] []+                                      ]+                                    , mkElement qn21+                                      [ mkAttr qn16 [ mkText "34" ]+                                      ] []+                                    ]+                                  , mkElement qn21+                                    [ mkAttr qn16 [ mkText "35" ]+                                    ] []+                                  ]+                                , mkElement qn21+                                  [ mkAttr qn16 [ mkText "36" ]+                                  ] []+                                ]+                              , mkElement qn21+                                [ mkAttr qn16 [ mkText "37" ]+                                ] []+                              ]+                            , mkElement qn21+                              [ mkAttr qn16 [ mkText "38" ]+                              ] []+                            ]+                          , mkElement qn21+                            [ mkAttr qn16 [ mkText "39" ]+                            ] []+                          ]+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "40" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "43" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "44" ]+                      ] []+                    ]+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "14" ]+                    ] []+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "27" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "group"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "16" ]+                    ] []+                  ]+                ]+              , mkElement qn20 []+                [ mkElement qn6 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn6 []+                          [ mkElement qn6 []+                            [ mkElement qn6 []+                              [ mkElement qn6 []+                                [ mkElement qn6 []+                                  [ mkElement qn6 []+                                    [ mkElement qn6 []+                                      [ mkElement qn6 []+                                        [ mkElement qn6 []+                                          [ mkElement qn6 []+                                            [ mkElement qn6 []+                                              [ mkElement qn6 []+                                                [ mkElement qn6 []+                                                  [ mkElement qn6 []+                                                    [ mkElement qn21+                                                      [ mkAttr qn16 [ mkText "25" ]+                                                      ] []+                                                    , mkElement qn21+                                                      [ mkAttr qn16 [ mkText "26" ]+                                                      ] []+                                                    ]+                                                  , mkElement qn21+                                                    [ mkAttr qn16 [ mkText "27" ]+                                                    ] []+                                                  ]+                                                , mkElement qn21+                                                  [ mkAttr qn16 [ mkText "28" ]+                                                  ] []+                                                ]+                                              , mkElement qn21+                                                [ mkAttr qn16 [ mkText "29" ]+                                                ] []+                                              ]+                                            , mkElement qn21+                                              [ mkAttr qn16 [ mkText "30" ]+                                              ] []+                                            ]+                                          , mkElement qn21+                                            [ mkAttr qn16 [ mkText "31" ]+                                            ] []+                                          ]+                                        , mkElement qn21+                                          [ mkAttr qn16 [ mkText "32" ]+                                          ] []+                                        ]+                                      , mkElement qn21+                                        [ mkAttr qn16 [ mkText "33" ]+                                        ] []+                                      ]+                                    , mkElement qn21+                                      [ mkAttr qn16 [ mkText "34" ]+                                      ] []+                                    ]+                                  , mkElement qn21+                                    [ mkAttr qn16 [ mkText "35" ]+                                    ] []+                                  ]+                                , mkElement qn21+                                  [ mkAttr qn16 [ mkText "36" ]+                                  ] []+                                ]+                              , mkElement qn21+                                [ mkAttr qn16 [ mkText "37" ]+                                ] []+                              ]+                            , mkElement qn21+                              [ mkAttr qn16 [ mkText "38" ]+                              ] []+                            ]+                          , mkElement qn21+                            [ mkAttr qn16 [ mkText "39" ]+                            ] []+                          ]+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "40" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "43" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "44" ]+                      ] []+                    ]+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "14" ]+                    ] []+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "26" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "attribute"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn14 []+                  [ mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn5 []+                      [ mkElement qn17+                        [ mkAttr qn18 [ mkText "" ]+                        ]+                        [ mkText "ns"+                        ]+                      , mkElement qn23 [] []+                      ]+                    ]+                  , mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn5 []+                      [ mkElement qn17+                        [ mkAttr qn18 [ mkText "" ]+                        ]+                        [ mkText "datatypeLibrary"+                        ]+                      , mkElement qn7+                        [ mkAttr qn24 [ mkText "anyURI" ]+                        , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                        ] []+                      ]+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn20 []+                    [ mkElement qn5 []+                      [ mkElement qn4 []+                        [ mkElement qn12 []+                          [ mkElement qn6 []+                            [ mkElement qn19+                              [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                              ] []+                            , mkElement qn19+                              [ mkAttr qn18 [ mkText "" ]+                              ] []+                            ]+                          ]+                        ]+                      , mkElement qn23 [] []+                      ]+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn5 []+                  [ mkElement qn17+                    [ mkAttr qn18 [ mkText "" ]+                    ]+                    [ mkText "name"+                    ]+                  , mkElement qn7+                    [ mkAttr qn24 [ mkText "QName" ]+                    , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                    ] []+                  ]+                , mkElement qn15 []+                  [ mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn20 []+                      [ mkElement qn21+                        [ mkAttr qn16 [ mkText "16" ]+                        ] []+                      ]+                    ]+                  , mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn21+                          [ mkAttr qn16 [ mkText "18" ]+                          ] []+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "19" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "20" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "21" ]+                      ] []+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "16" ]+                    ] []+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn6 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn6 []+                          [ mkElement qn6 []+                            [ mkElement qn6 []+                              [ mkElement qn6 []+                                [ mkElement qn6 []+                                  [ mkElement qn6 []+                                    [ mkElement qn6 []+                                      [ mkElement qn6 []+                                        [ mkElement qn6 []+                                          [ mkElement qn6 []+                                            [ mkElement qn6 []+                                              [ mkElement qn6 []+                                                [ mkElement qn6 []+                                                  [ mkElement qn6 []+                                                    [ mkElement qn21+                                                      [ mkAttr qn16 [ mkText "25" ]+                                                      ] []+                                                    , mkElement qn21+                                                      [ mkAttr qn16 [ mkText "26" ]+                                                      ] []+                                                    ]+                                                  , mkElement qn21+                                                    [ mkAttr qn16 [ mkText "27" ]+                                                    ] []+                                                  ]+                                                , mkElement qn21+                                                  [ mkAttr qn16 [ mkText "28" ]+                                                  ] []+                                                ]+                                              , mkElement qn21+                                                [ mkAttr qn16 [ mkText "29" ]+                                                ] []+                                              ]+                                            , mkElement qn21+                                              [ mkAttr qn16 [ mkText "30" ]+                                              ] []+                                            ]+                                          , mkElement qn21+                                            [ mkAttr qn16 [ mkText "31" ]+                                            ] []+                                          ]+                                        , mkElement qn21+                                          [ mkAttr qn16 [ mkText "32" ]+                                          ] []+                                        ]+                                      , mkElement qn21+                                        [ mkAttr qn16 [ mkText "33" ]+                                        ] []+                                      ]+                                    , mkElement qn21+                                      [ mkAttr qn16 [ mkText "34" ]+                                      ] []+                                    ]+                                  , mkElement qn21+                                    [ mkAttr qn16 [ mkText "35" ]+                                    ] []+                                  ]+                                , mkElement qn21+                                  [ mkAttr qn16 [ mkText "36" ]+                                  ] []+                                ]+                              , mkElement qn21+                                [ mkAttr qn16 [ mkText "37" ]+                                ] []+                              ]+                            , mkElement qn21+                              [ mkAttr qn16 [ mkText "38" ]+                              ] []+                            ]+                          , mkElement qn21+                            [ mkAttr qn16 [ mkText "39" ]+                            ] []+                          ]+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "40" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "43" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "44" ]+                      ] []+                    ]+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "14" ]+                    ] []+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "25" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "element"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn6 []+                [ mkElement qn5 []+                  [ mkElement qn17+                    [ mkAttr qn18 [ mkText "" ]+                    ]+                    [ mkText "name"+                    ]+                  , mkElement qn7+                    [ mkAttr qn24 [ mkText "QName" ]+                    , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                    ] []+                  ]+                , mkElement qn15 []+                  [ mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn20 []+                      [ mkElement qn21+                        [ mkAttr qn16 [ mkText "16" ]+                        ] []+                      ]+                    ]+                  , mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn21+                          [ mkAttr qn16 [ mkText "18" ]+                          ] []+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "19" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "20" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "21" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn14 []+                [ mkElement qn14 []+                  [ mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn5 []+                      [ mkElement qn17+                        [ mkAttr qn18 [ mkText "" ]+                        ]+                        [ mkText "ns"+                        ]+                      , mkElement qn23 [] []+                      ]+                    ]+                  , mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn5 []+                      [ mkElement qn17+                        [ mkAttr qn18 [ mkText "" ]+                        ]+                        [ mkText "datatypeLibrary"+                        ]+                      , mkElement qn7+                        [ mkAttr qn24 [ mkText "anyURI" ]+                        , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                        ] []+                      ]+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn20 []+                    [ mkElement qn5 []+                      [ mkElement qn4 []+                        [ mkElement qn12 []+                          [ mkElement qn6 []+                            [ mkElement qn19+                              [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                              ] []+                            , mkElement qn19+                              [ mkAttr qn18 [ mkText "" ]+                              ] []+                            ]+                          ]+                        ]+                      , mkElement qn23 [] []+                      ]+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "16" ]+                    ] []+                  ]+                ]+              , mkElement qn20 []+                [ mkElement qn6 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn6 []+                          [ mkElement qn6 []+                            [ mkElement qn6 []+                              [ mkElement qn6 []+                                [ mkElement qn6 []+                                  [ mkElement qn6 []+                                    [ mkElement qn6 []+                                      [ mkElement qn6 []+                                        [ mkElement qn6 []+                                          [ mkElement qn6 []+                                            [ mkElement qn6 []+                                              [ mkElement qn6 []+                                                [ mkElement qn6 []+                                                  [ mkElement qn6 []+                                                    [ mkElement qn21+                                                      [ mkAttr qn16 [ mkText "25" ]+                                                      ] []+                                                    , mkElement qn21+                                                      [ mkAttr qn16 [ mkText "26" ]+                                                      ] []+                                                    ]+                                                  , mkElement qn21+                                                    [ mkAttr qn16 [ mkText "27" ]+                                                    ] []+                                                  ]+                                                , mkElement qn21+                                                  [ mkAttr qn16 [ mkText "28" ]+                                                  ] []+                                                ]+                                              , mkElement qn21+                                                [ mkAttr qn16 [ mkText "29" ]+                                                ] []+                                              ]+                                            , mkElement qn21+                                              [ mkAttr qn16 [ mkText "30" ]+                                              ] []+                                            ]+                                          , mkElement qn21+                                            [ mkAttr qn16 [ mkText "31" ]+                                            ] []+                                          ]+                                        , mkElement qn21+                                          [ mkAttr qn16 [ mkText "32" ]+                                          ] []+                                        ]+                                      , mkElement qn21+                                        [ mkAttr qn16 [ mkText "33" ]+                                        ] []+                                      ]+                                    , mkElement qn21+                                      [ mkAttr qn16 [ mkText "34" ]+                                      ] []+                                    ]+                                  , mkElement qn21+                                    [ mkAttr qn16 [ mkText "35" ]+                                    ] []+                                  ]+                                , mkElement qn21+                                  [ mkAttr qn16 [ mkText "36" ]+                                  ] []+                                ]+                              , mkElement qn21+                                [ mkAttr qn16 [ mkText "37" ]+                                ] []+                              ]+                            , mkElement qn21+                              [ mkAttr qn16 [ mkText "38" ]+                              ] []+                            ]+                          , mkElement qn21+                            [ mkAttr qn16 [ mkText "39" ]+                            ] []+                          ]+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "40" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "43" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "44" ]+                      ] []+                    ]+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "14" ]+                    ] []+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "24" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "include"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn5 []+                [ mkElement qn17+                  [ mkAttr qn18 [ mkText "" ]+                  ]+                  [ mkText "href"+                  ]+                , mkElement qn7+                  [ mkAttr qn24 [ mkText "anyURI" ]+                  , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                  ] []+                ]+              , mkElement qn14 []+                [ mkElement qn14 []+                  [ mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn5 []+                      [ mkElement qn17+                        [ mkAttr qn18 [ mkText "" ]+                        ]+                        [ mkText "ns"+                        ]+                      , mkElement qn23 [] []+                      ]+                    ]+                  , mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn5 []+                      [ mkElement qn17+                        [ mkAttr qn18 [ mkText "" ]+                        ]+                        [ mkText "datatypeLibrary"+                        ]+                      , mkElement qn7+                        [ mkAttr qn24 [ mkText "anyURI" ]+                        , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                        ] []+                      ]+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn20 []+                    [ mkElement qn5 []+                      [ mkElement qn4 []+                        [ mkElement qn12 []+                          [ mkElement qn6 []+                            [ mkElement qn19+                              [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                              ] []+                            , mkElement qn19+                              [ mkAttr qn18 [ mkText "" ]+                              ] []+                            ]+                          ]+                        ]+                      , mkElement qn23 [] []+                      ]+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "16" ]+                    ] []+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn21+                        [ mkAttr qn16 [ mkText "11" ]+                        ] []+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "10" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "22" ]+                      ] []+                    ]+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "23" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "div"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "16" ]+                    ] []+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn21+                          [ mkAttr qn16 [ mkText "11" ]+                          ] []+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "10" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "23" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "24" ]+                      ] []+                    ]+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "22" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "div"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "16" ]+                    ] []+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn21+                        [ mkAttr qn16 [ mkText "11" ]+                        ] []+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "10" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "22" ]+                      ] []+                    ]+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "21" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "choice"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "16" ]+                    ] []+                  ]+                ]+              , mkElement qn20 []+                [ mkElement qn6 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn21+                        [ mkAttr qn16 [ mkText "18" ]+                        ] []+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "19" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "20" ]+                      ] []+                    ]+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "21" ]+                    ] []+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "20" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "nsName"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "16" ]+                    ] []+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn21+                  [ mkAttr qn16 [ mkText "17" ]+                  ] []+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "19" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "anyName"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "16" ]+                    ] []+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn21+                  [ mkAttr qn16 [ mkText "17" ]+                  ] []+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "18" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "name"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn7+              [ mkAttr qn24 [ mkText "QName" ]+              , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+              ] []+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "17" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "except"+            ]+          , mkElement qn15 []+            [ mkElement qn6 []+              [ mkElement qn11 [] []+              , mkElement qn20 []+                [ mkElement qn21+                  [ mkAttr qn16 [ mkText "16" ]+                  ] []+                ]+              ]+            , mkElement qn20 []+              [ mkElement qn6 []+                [ mkElement qn6 []+                  [ mkElement qn6 []+                    [ mkElement qn21+                      [ mkAttr qn16 [ mkText "18" ]+                      ] []+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "19" ]+                      ] []+                    ]+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "20" ]+                    ] []+                  ]+                , mkElement qn21+                  [ mkAttr qn16 [ mkText "21" ]+                  ] []+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "16" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn4 []+            [ mkElement qn12 []+              [ mkElement qn19+                [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                ] []+              ]+            ]+          , mkElement qn6 []+            [ mkElement qn11 [] []+            , mkElement qn20 []+              [ mkElement qn6 []+                [ mkElement qn6 []+                  [ mkElement qn5 []+                    [ mkElement qn4 [] []+                    , mkElement qn23 [] []+                    ]+                  , mkElement qn23 [] []+                  ]+                , mkElement qn21+                  [ mkAttr qn16 [ mkText "0" ]+                  ] []+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "0" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn4 [] []+          , mkElement qn6 []+            [ mkElement qn11 [] []+            , mkElement qn20 []+              [ mkElement qn6 []+                [ mkElement qn6 []+                  [ mkElement qn5 []+                    [ mkElement qn4 [] []+                    , mkElement qn23 [] []+                    ]+                  , mkElement qn23 [] []+                  ]+                , mkElement qn21+                  [ mkAttr qn16 [ mkText "0" ]+                  ] []+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "10" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "define"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn5 []+                  [ mkElement qn17+                    [ mkAttr qn18 [ mkText "" ]+                    ]+                    [ mkText "name"+                    ]+                  , mkElement qn7+                    [ mkAttr qn24 [ mkText "NCName" ]+                    , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                    ] []+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "combine"+                      ]+                    , mkElement qn6 []+                      [ mkElement qn25+                        [ mkAttr qn1 [ mkText "http://www.w3.org/XML/1998/namespace" ]+                        , mkAttr qn3 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                        , mkAttr qn2 [ mkText "file:///home/uwe/haskell/hxt/curr/src/Text/XML/HXT/RelaxNG/schema2hs/SchemaGrammar.rng" ]+                        , mkAttr qn8 [ mkText "" ]+                        , mkAttr qn24 [ mkText "token" ]+                        , mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                        ]+                        [ mkText "choice"+                        ]+                      , mkElement qn25+                        [ mkAttr qn1 [ mkText "http://www.w3.org/XML/1998/namespace" ]+                        , mkAttr qn3 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                        , mkAttr qn2 [ mkText "file:///home/uwe/haskell/hxt/curr/src/Text/XML/HXT/RelaxNG/schema2hs/SchemaGrammar.rng" ]+                        , mkAttr qn8 [ mkText "" ]+                        , mkAttr qn24 [ mkText "token" ]+                        , mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                        ]+                        [ mkText "interleave"+                        ]+                      ]+                    ]+                  ]+                ]+              , mkElement qn14 []+                [ mkElement qn14 []+                  [ mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn5 []+                      [ mkElement qn17+                        [ mkAttr qn18 [ mkText "" ]+                        ]+                        [ mkText "ns"+                        ]+                      , mkElement qn23 [] []+                      ]+                    ]+                  , mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn5 []+                      [ mkElement qn17+                        [ mkAttr qn18 [ mkText "" ]+                        ]+                        [ mkText "datatypeLibrary"+                        ]+                      , mkElement qn7+                        [ mkAttr qn24 [ mkText "anyURI" ]+                        , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                        ] []+                      ]+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn20 []+                    [ mkElement qn5 []+                      [ mkElement qn4 []+                        [ mkElement qn12 []+                          [ mkElement qn6 []+                            [ mkElement qn19+                              [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                              ] []+                            , mkElement qn19+                              [ mkAttr qn18 [ mkText "" ]+                              ] []+                            ]+                          ]+                        ]+                      , mkElement qn23 [] []+                      ]+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "16" ]+                    ] []+                  ]+                ]+              , mkElement qn20 []+                [ mkElement qn6 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn6 []+                          [ mkElement qn6 []+                            [ mkElement qn6 []+                              [ mkElement qn6 []+                                [ mkElement qn6 []+                                  [ mkElement qn6 []+                                    [ mkElement qn6 []+                                      [ mkElement qn6 []+                                        [ mkElement qn6 []+                                          [ mkElement qn6 []+                                            [ mkElement qn6 []+                                              [ mkElement qn6 []+                                                [ mkElement qn6 []+                                                  [ mkElement qn6 []+                                                    [ mkElement qn21+                                                      [ mkAttr qn16 [ mkText "25" ]+                                                      ] []+                                                    , mkElement qn21+                                                      [ mkAttr qn16 [ mkText "26" ]+                                                      ] []+                                                    ]+                                                  , mkElement qn21+                                                    [ mkAttr qn16 [ mkText "27" ]+                                                    ] []+                                                  ]+                                                , mkElement qn21+                                                  [ mkAttr qn16 [ mkText "28" ]+                                                  ] []+                                                ]+                                              , mkElement qn21+                                                [ mkAttr qn16 [ mkText "29" ]+                                                ] []+                                              ]+                                            , mkElement qn21+                                              [ mkAttr qn16 [ mkText "30" ]+                                              ] []+                                            ]+                                          , mkElement qn21+                                            [ mkAttr qn16 [ mkText "31" ]+                                            ] []+                                          ]+                                        , mkElement qn21+                                          [ mkAttr qn16 [ mkText "32" ]+                                          ] []+                                        ]+                                      , mkElement qn21+                                        [ mkAttr qn16 [ mkText "33" ]+                                        ] []+                                      ]+                                    , mkElement qn21+                                      [ mkAttr qn16 [ mkText "34" ]+                                      ] []+                                    ]+                                  , mkElement qn21+                                    [ mkAttr qn16 [ mkText "35" ]+                                    ] []+                                  ]+                                , mkElement qn21+                                  [ mkAttr qn16 [ mkText "36" ]+                                  ] []+                                ]+                              , mkElement qn21+                                [ mkAttr qn16 [ mkText "37" ]+                                ] []+                              ]+                            , mkElement qn21+                              [ mkAttr qn16 [ mkText "38" ]+                              ] []+                            ]+                          , mkElement qn21+                            [ mkAttr qn16 [ mkText "39" ]+                            ] []+                          ]+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "40" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "43" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "44" ]+                      ] []+                    ]+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "14" ]+                    ] []+                  ]+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "11" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "start"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn5 []+                  [ mkElement qn17+                    [ mkAttr qn18 [ mkText "" ]+                    ]+                    [ mkText "combine"+                    ]+                  , mkElement qn6 []+                    [ mkElement qn25+                      [ mkAttr qn1 [ mkText "http://www.w3.org/XML/1998/namespace" ]+                      , mkAttr qn3 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                      , mkAttr qn2 [ mkText "file:///home/uwe/haskell/hxt/curr/src/Text/XML/HXT/RelaxNG/schema2hs/SchemaGrammar.rng" ]+                      , mkAttr qn8 [ mkText "" ]+                      , mkAttr qn24 [ mkText "token" ]+                      , mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                      ]+                      [ mkText "choice"+                      ]+                    , mkElement qn25+                      [ mkAttr qn1 [ mkText "http://www.w3.org/XML/1998/namespace" ]+                      , mkAttr qn3 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                      , mkAttr qn2 [ mkText "file:///home/uwe/haskell/hxt/curr/src/Text/XML/HXT/RelaxNG/schema2hs/SchemaGrammar.rng" ]+                      , mkAttr qn8 [ mkText "" ]+                      , mkAttr qn24 [ mkText "token" ]+                      , mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                      ]+                      [ mkText "interleave"+                      ]+                    ]+                  ]+                ]+              , mkElement qn14 []+                [ mkElement qn14 []+                  [ mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn5 []+                      [ mkElement qn17+                        [ mkAttr qn18 [ mkText "" ]+                        ]+                        [ mkText "ns"+                        ]+                      , mkElement qn23 [] []+                      ]+                    ]+                  , mkElement qn6 []+                    [ mkElement qn11 [] []+                    , mkElement qn5 []+                      [ mkElement qn17+                        [ mkAttr qn18 [ mkText "" ]+                        ]+                        [ mkText "datatypeLibrary"+                        ]+                      , mkElement qn7+                        [ mkAttr qn24 [ mkText "anyURI" ]+                        , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                        ] []+                      ]+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn20 []+                    [ mkElement qn5 []+                      [ mkElement qn4 []+                        [ mkElement qn12 []+                          [ mkElement qn6 []+                            [ mkElement qn19+                              [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                              ] []+                            , mkElement qn19+                              [ mkAttr qn18 [ mkText "" ]+                              ] []+                            ]+                          ]+                        ]+                      , mkElement qn23 [] []+                      ]+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "16" ]+                    ] []+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn6 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn6 []+                          [ mkElement qn6 []+                            [ mkElement qn6 []+                              [ mkElement qn6 []+                                [ mkElement qn6 []+                                  [ mkElement qn6 []+                                    [ mkElement qn6 []+                                      [ mkElement qn6 []+                                        [ mkElement qn6 []+                                          [ mkElement qn6 []+                                            [ mkElement qn6 []+                                              [ mkElement qn6 []+                                                [ mkElement qn6 []+                                                  [ mkElement qn21+                                                    [ mkAttr qn16 [ mkText "25" ]+                                                    ] []+                                                  , mkElement qn21+                                                    [ mkAttr qn16 [ mkText "26" ]+                                                    ] []+                                                  ]+                                                , mkElement qn21+                                                  [ mkAttr qn16 [ mkText "27" ]+                                                  ] []+                                                ]+                                              , mkElement qn21+                                                [ mkAttr qn16 [ mkText "28" ]+                                                ] []+                                              ]+                                            , mkElement qn21+                                              [ mkAttr qn16 [ mkText "29" ]+                                              ] []+                                            ]+                                          , mkElement qn21+                                            [ mkAttr qn16 [ mkText "30" ]+                                            ] []+                                          ]+                                        , mkElement qn21+                                          [ mkAttr qn16 [ mkText "31" ]+                                          ] []+                                        ]+                                      , mkElement qn21+                                        [ mkAttr qn16 [ mkText "32" ]+                                        ] []+                                      ]+                                    , mkElement qn21+                                      [ mkAttr qn16 [ mkText "33" ]+                                      ] []+                                    ]+                                  , mkElement qn21+                                    [ mkAttr qn16 [ mkText "34" ]+                                    ] []+                                  ]+                                , mkElement qn21+                                  [ mkAttr qn16 [ mkText "35" ]+                                  ] []+                                ]+                              , mkElement qn21+                                [ mkAttr qn16 [ mkText "36" ]+                                ] []+                              ]+                            , mkElement qn21+                              [ mkAttr qn16 [ mkText "37" ]+                              ] []+                            ]+                          , mkElement qn21+                            [ mkAttr qn16 [ mkText "38" ]+                            ] []+                          ]+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "39" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "40" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "43" ]+                      ] []+                    ]+                  , mkElement qn21+                    [ mkAttr qn16 [ mkText "44" ]+                    ] []+                  ]+                , mkElement qn21+                  [ mkAttr qn16 [ mkText "14" ]+                  ] []+                ]+              ]+            ]+          ]+        ]+      , mkElement qn9+        [ mkAttr qn16 [ mkText "14" ]+        ]+        [ mkElement qn10 []+          [ mkElement qn17+            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+            ]+            [ mkText "grammar"+            ]+          , mkElement qn14 []+            [ mkElement qn14 []+              [ mkElement qn14 []+                [ mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "ns"+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                , mkElement qn6 []+                  [ mkElement qn11 [] []+                  , mkElement qn5 []+                    [ mkElement qn17+                      [ mkAttr qn18 [ mkText "" ]+                      ]+                      [ mkText "datatypeLibrary"+                      ]+                    , mkElement qn7+                      [ mkAttr qn24 [ mkText "anyURI" ]+                      , mkAttr qn8 [ mkText "http://www.w3.org/2001/XMLSchema-datatypes" ]+                      ] []+                    ]+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn5 []+                    [ mkElement qn4 []+                      [ mkElement qn12 []+                        [ mkElement qn6 []+                          [ mkElement qn19+                            [ mkAttr qn18 [ mkText "http://relaxng.org/ns/structure/1.0" ]+                            ] []+                          , mkElement qn19+                            [ mkAttr qn18 [ mkText "" ]+                            ] []+                          ]+                        ]+                      ]+                    , mkElement qn23 [] []+                    ]+                  ]+                ]+              ]+            , mkElement qn15 []+              [ mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn21+                    [ mkAttr qn16 [ mkText "16" ]+                    ] []+                  ]+                ]+              , mkElement qn6 []+                [ mkElement qn11 [] []+                , mkElement qn20 []+                  [ mkElement qn6 []+                    [ mkElement qn6 []+                      [ mkElement qn6 []+                        [ mkElement qn21+                          [ mkAttr qn16 [ mkText "11" ]+                          ] []+                        , mkElement qn21+                          [ mkAttr qn16 [ mkText "10" ]+                          ] []+                        ]+                      , mkElement qn21+                        [ mkAttr qn16 [ mkText "23" ]+                        ] []+                      ]+                    , mkElement qn21+                      [ mkAttr qn16 [ mkText "24" ]+                      ] []+                    ]+                  ]+                ]+              ]+            ]+          ]+        ]+      ]+    ]
+ src/Yuuko/Text/XML/HXT/RelaxNG/Simplification.hs view
@@ -0,0 +1,2321 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.RelaxNG.Simplification+   Copyright  : Copyright (C) 2008 Torben Kuseler, Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : stable+   Portability: portable++   The modul creates the simplified form of a Relax NG schema.+   See also chapter 4 of the Relax NG specification.++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.RelaxNG.Simplification+  ( createSimpleForm+  , getErrors+  )++where+++import Yuuko.Control.Arrow.ListArrows++import           Yuuko.Text.XML.HXT.DOM.Interface+import qualified Yuuko.Text.XML.HXT.DOM.XmlNode as XN+    ( mkAttr+    , mkText+    )++import Yuuko.Text.XML.HXT.Arrow.XmlArrow+import Yuuko.Text.XML.HXT.Arrow.XmlIOStateArrow++import Yuuko.Text.XML.HXT.Arrow.Namespace+    ( processWithNsEnv+    , propagateNamespaces+    )++import Yuuko.Text.XML.HXT.Arrow.Edit+    ( removeWhiteSpace+    )++import Yuuko.Text.XML.HXT.RelaxNG.DataTypes+import Yuuko.Text.XML.HXT.RelaxNG.BasicArrows+import Yuuko.Text.XML.HXT.RelaxNG.CreatePattern+import Yuuko.Text.XML.HXT.RelaxNG.DataTypeLibraries+import Yuuko.Text.XML.HXT.RelaxNG.Utils+import Yuuko.Text.XML.HXT.RelaxNG.Validation+import Yuuko.Text.XML.HXT.RelaxNG.Schema        as S+import Yuuko.Text.XML.HXT.RelaxNG.SchemaGrammar as SG++import Data.Maybe+    ( fromJust+    , fromMaybe+    , isNothing+    )+import Data.List+    ( elemIndices+    , isPrefixOf+    , nub+    , deleteBy+    , find+    , (\\)+    )++import System.Directory+  ( doesFileExist )++  +-- ------------------------------------------------------------++{- +- 4.1. Annotations: Foreign attributes and elements are removed.+- 4.2. Whitespace:+    - For each element other than value and param, each child that is a string +      containing only whitespace characters is removed. -> fertig+    - Leading and trailing whitespace characters are removed from the value of each name,+      type and combine attribute and from the content of each name element. -> fertig+- 4.3. datatypeLibrary attribute:+    - The value of each datatypeLibary attribute is transformed by escaping disallowed characters+    - For any data or value element that does not have a datatypeLibrary attribute, +      a datatypeLibrary attribute is added.+    - Any datatypeLibrary attribute that is on an element other than data or value is removed.+- 4.4. type attribute of value element+-}+simplificationStep1 :: IOSArrow XmlTree XmlTree+simplificationStep1+    = ( {- +	- 4.5. href attribute+        - The value of the href attribute on an externalRef or include element is first +        - transformed by escaping disallowed characters+        - The URI reference is then resolved into an absolute form+        - The value of the href attribute will be used to construct an element.+	-}+	( processHref $< getBaseURI )+	>>>+	-- 4.10 QNames+	processWithNsEnv processEnvNames (toNsEnv [("xml",xmlNamespace)])+	>>>+	-- 4.4 For any data or value element that does not have a datatypeLibrary attribute,+	-- a datatypeLibrary attribute is added.+	-- Wird vorgezogen, da danach der Rest in einem Baumdurchlauf erledigt werden kann+	processdatatypeLib ""+	>>>+	processTopDownWithAttrl+	(+	 ( -- 4.1 Foreign attributes and elements are removed+           none+           `when` +           ( ( isElem >>> neg isRoot +               >>> +               getNamespaceUri+               >>>+               isA (\ uri -> (not $ compareURI uri relaxNamespace))+             )+             `orElse`+             ( isAttr+               >>>+               getNamespaceUri+               >>>+               isA (\ uri -> (uri /= "" && (not $ compareURI uri relaxNamespace)))+             )+           )+	 )+	 >>>+	 ( -- 4.2 For each element other than value and param, each child that +           -- is a string containing only whitespace characters is removed.+           ( processChildren removeWhiteSpace+             `whenNot` +             (isRngParam `orElse` isRngValue)+           )+           `when` isElem +	 )+	 >>>       +	 ( -- 4.2 Leading and trailing whitespace characters are removed from the value +           -- of each name, type and combine attribute ...+           changeAttrValue normalizeWhitespace+           `when`+           ( isRngAttrName `orElse` isRngAttrType `orElse` isRngAttrCombine)+	 )+	 >>>+	 ( -- 4.2 ... and from the content of each name element.+           processChildren (changeText normalizeWhitespace)+           `when`+           isRngName+	 )+	 >>>+	 ( -- 4.3 The value of each datatypeLibary attribute is transformed+           -- by escaping disallowed characters+           changeAttrValue escapeURI+           `when`+           isRngAttrDatatypeLibrary+	 )+	 >>>+	 ( -- The value of the datatypeLibary attribute has to be a valid URI+           ( mkRelaxError "" $< ( getRngAttrDatatypeLibrary+				  >>> +				  arr (\ a -> ( "datatypeLibrary attribute: " ++ +						a ++ " is not a valid URI"+					      )+                                      )+				)+           )+           `when`+           ( isElem+	     >>>+	     hasRngAttrDatatypeLibrary+             >>> +             getRngAttrDatatypeLibrary >>> isA (not . isRelaxAnyURI)+           )+	 )+	 >>>       +	 ( -- 4.3 Any datatypeLibrary attribute that is on an element +           -- other than data or value is removed.+           removeAttr "datatypeLibrary"+           `when`+           ( isElem+	     >>>+	     neg (isRngData `orElse` isRngValue) +             >>> +             hasRngAttrDatatypeLibrary+           )+	 )+	 >>>       +	 ( -- 4.4 For any value element that does not have a type attribute,+           -- a type attribute is added with value token and the value of +           -- the datatypeLibrary attribute is changed to the empty string.+           ( addAttr "type" "token"+	     >>>+	     addAttr "datatypeLibrary" ""+	   )+           `when`+           ( isRngValue >>> neg hasRngAttrType )+	 ) +	)    +      ) `when` collectErrors+    where+    processHref :: String -> IOSArrow XmlTree XmlTree+    processHref uri+	= processChildren+	  ( choiceA+	    [ ( isElem >>> hasAttr "xml:base" )+              :-> ( ifA ( isExternalRefInclude >>> hasRngAttrHref )+                    ( -- The value of the href attribute is transformed by+                      -- escaping disallowed characters+                      (processAttrl (changeAttrValue escapeURI `when` isRngAttrHref))+                      >>> -- compute the new base uri from the old uri and the href attribute+                      (addAttr "href" $< (absURI "href" $< (absURI "xml:base" uri)))+                      >>> +                      (processHref $< absURI "xml:base" uri)+                    ) -- element without a href attribute, just compute the new base uri+                    (processHref $< absURI "xml:base" uri)+                  )+	    , ( isExternalRefInclude >>> hasRngAttrHref )+              :-> ( -- The value of the href attribute is transformed by +                    -- escaping disallowed characters+                    (processAttrl (changeAttrValue escapeURI `when` isRngAttrHref))+                    >>>+                    (addAttr "href" $< absURI "href" uri)+                  )+	    , this+	      :-> processHref uri+            ]+	  )+	where+	absURI :: String -> String -> IOSArrow XmlTree String+	absURI attrName u+	    = ( getAttrValue attrName+		>>> +                arr (\ a -> fromMaybe "" (expandURIString a u))+                >>> -- the uri should not have a fragment-identifier (4.5)+                ( arr ("illegal URI, fragment identifier not allowed: " ++)+                  `whenNot`+                  (getFragmentFromURI >>> isA null)+                )+	      )++    processEnvNames :: NsEnv -> IOSArrow XmlTree XmlTree+    processEnvNames env+	= ( ( (replaceQNames env $< getAttrValue "name")+              `when`+              ( (isRngElement `orElse` isRngAttribute)+		>>>+		getRngAttrName+		>>>+		isA (elem ':')+              )+	    )+	    >>>+	    ( (addAttrl (getBaseURI >>> createAttrL))      +              `when`+              isRngValue+	    )+	  )+	where+	createAttrL :: IOSArrow String XmlTree+	createAttrL+	    = setBaseUri &&& constA (map createAttr env) >>> arr2L (:)+	    where++	    createAttr :: (XName, XName) -> XmlTree+	    createAttr (pre, uri)+		= XN.mkAttr (mkName nm) [XN.mkText (show uri)]+		where+		nm  | isNullXName pre	= "RelaxContextDefault"+		    | otherwise		= contextAttributes ++ show pre++	    setBaseUri :: IOSArrow String XmlTree+	    setBaseUri = mkAttr (mkName contextBaseAttr) (txt $< this)++	replaceQNames :: NsEnv -> String -> IOSArrow XmlTree XmlTree                        +	replaceQNames e name+	    | isNothing uri+		= mkRelaxError "" ( "No Namespace-Mapping for the prefix " ++ show pre ++ +				    " in the Context of Element: " ++ show name+				  )+	    | otherwise+		= addAttr "name" ( "{" ++ (show . fromJust $ uri) ++ "}" ++ local )+	    where+	    (pre, local') = span (/= ':') name+	    local         = tail local'+	    uri 	:: Maybe XName+	    uri           = lookup (newXName pre) e++    -- The value of the added datatypeLibrary attribute is the value of the +    -- datatypeLibrary attribute of the nearest ancestor element that +    -- has a datatypeLibrary attribute, or the empty string +    -- if there is no such ancestor.+    processdatatypeLib :: (ArrowXml a) => String -> a XmlTree XmlTree+    processdatatypeLib lib +	= processChildren $+          choiceA+	  [ ( isElem >>> hasRngAttrDatatypeLibrary+            -- set the new datatypeLibrary value+            )+	    :->+	    ( processdatatypeLib $< getRngAttrDatatypeLibrary )+	  , ( (isRngData `orElse` isRngValue)+              >>> +              neg hasRngAttrDatatypeLibrary+              -- add a datatypeLibrary attribute+	    )+	    :->+	    ( addAttr "datatypeLibrary" lib >>> processdatatypeLib lib )+	  , this+	    :->+	    processdatatypeLib lib+          ]++-- ------------------------------------------------------------+++{- +- 4.5. href attribute+    - see simplificationStep1+- 4.6. externalRef element+    - An element is constructed using the URI reference +      that is the value of href attribute+    - This element must match the syntax for pattern.+    - The element is transformed by recursively applying the rules from +      this subsection and from previous subsections of this section.+    - This must not result in a loop.+    - Any ns attribute on the externalRef element is transferred +      to the referenced element if the referenced element does+      not already have an ns attribute.+    - The externalRef element is then replaced by the referenced element.+- 4.7. include element+    - An element is constructed using the URI reference that is the+      value of href attribute+    - This element must be a grammar element, matching the syntax for grammar.+    - This grammar element is transformed by recursively applying the rules +      from this subsection and from previous subsections of this section.+    - This must not result in a loop.+    +    - If the include element has a start component, then the grammar element+      must have a start component.+    - If the include element has a start component, then all start components+      are removed from the grammar element.+    - If the include element has a define component, then the grammar element+      must have a define component with the same name.+    - For every define component of the include element, all define components+      with the same name are removed from the grammar element.+    +    - The include element is transformed into a div element.+    - The attributes of the div element are the attributes of the +      include element other than the href attribute.+    - The children of the div element are the grammar element+    - The grammar element is then renamed to div.+-}++simplificationStep2 :: Attributes -> Bool -> Bool -> [Uri] -> [Uri] -> IOSArrow XmlTree XmlTree+simplificationStep2 readOptions validateExternalRef validateInclude extHRefs includeHRefs =+  ( processTopDown (+      ( (importExternalRef $<< (getRngAttrNs &&& getRngAttrHref))+        `when`+        isRngExternalRef+      )+      >>>+      ( (importInclude $< getAttrValue "href")+        `when`+        isRngInclude+      )+    )+  ) `when` collectErrors+  where+  importExternalRef :: String -> String -> IOSArrow XmlTree XmlTree+  importExternalRef ns href+    = ifA ( neg $ constA href+                  >>> getPathFromURI+                  >>> ( isA (not . ("illegal URI" `isPrefixOf`))+                        `guards`+                        isIOA doesFileExist+                      )+          )+        ( mkRelaxError ""+	  ( show href +++	    ": can't read URI, referenced in externalRef-Pattern"+	  )+	)+        ( ifP (const $ elem href extHRefs)+           -- if the referenced name already exists in the list of processed ref attributes+           -- we have found a loop+            ( mkRelaxError ""+	      (  "loop in externalRef-Pattern, " ++ +                 formatStringListArr (reverse $ href:extHRefs)+	      )+            )+            ( ifA ( if validateExternalRef 					-- if validation parameters are set+		    then validateDocWithRelax S.relaxSchemaArrow [] href	-- the referenced schema is validated with respect to+		    else none							-- the Relax NG specification+                  )+                ( mkRelaxError ""+		  ( "The content of the schema " ++ show href ++ +		    ", referenced in externalRef does not " +++		    "match the syntax for pattern"+		  )+                )+                ( readForRelax readOptions href+                  >>>+                  simplificationStep1						-- perform the transformations from previous steps+                  >>>+                  simplificationStep2 readOptions validateExternalRef validateInclude (href:extHRefs) includeHRefs+                  >>>+                  getChildren -- remove the root node+                  >>>+                  ( -- Any ns attribute on the externalRef element+                    -- is transferred to the referenced element+                    addAttr "ns" ns+                    `when`+                    (getRngAttrNs >>> isA (\a -> a == "" && ns /= ""))+                  )+                )+            )+        )+  +  importInclude :: String -> IOSArrow XmlTree XmlTree+  importInclude href+    = ifA ( -- test whether the referenced schema exists+            neg $ constA href >>> getPathFromURI >>> isIOA doesFileExist+          )+        ( mkRelaxError ""+	  ( "Can't read " ++ show href +++            ", referenced in include-Pattern"+	  )+        )+        ( ifP (const $ elem href includeHRefs)+           -- if the referenced name still exists in the list of processed+           -- ref attributes we have found a loop+            ( mkRelaxError ""+	      ( "loop in include-Pattern, " ++ +                formatStringListArr (reverse $ href:includeHRefs)+	      )+            )+            ( ifA ( if validateInclude						-- if the parameter is set+		    then validateDocWithRelax SG.relaxSchemaArrow [] href	-- the referenced schema is validated with respect to+                    else none							-- the Relax NG grammar element+                  )+                ( mkRelaxError ""+		  ( "The content of the schema " ++ show href ++ +                    ", referenced in include does not match " +++                    "the syntax for grammar"+		  )+                )+                ( processInclude href $< ( readForRelax readOptions href+                                           >>>+                                           simplificationStep1				-- perform the transformations from previous steps+                                           >>> +                                           simplificationStep2 readOptions validateExternalRef validateInclude extHRefs (href:includeHRefs)+                                           >>>+                                           getChildren					-- remove the root node+                                         )+                )+            )+        )+  +  processInclude :: String -> XmlTree -> IOSArrow XmlTree XmlTree+  processInclude href newDoc+    = -- The include element is transformed into a div element.+      setRngNameDiv+      >>>+      -- The attributes of the div element are the attributes of +      -- the include element other than the href attribute.+      removeAttr "href"+      >>> +      checkInclude href newDoc+  +  +  insertNewDoc :: XmlTree -> Bool -> [String] -> IOSArrow XmlTree XmlTree+  insertNewDoc newDoc hasStart defNames+    = insertChildrenAt 0 $+        constA newDoc+        >>>+        -- If the include element has a start component, then all start components+        -- are removed from the grammar element.        +        (removeStartComponent `whenP` (const hasStart))+        >>>+        -- For every define component of the include element, all define components+        -- with the same name are removed from the grammar element.+        ((removeDefineComponent defNames) `whenP` (const $ defNames /= []))+        >>>+        -- The grammar element is then renamed to div.+        setRngNameDiv++  +  checkInclude :: String -> XmlTree -> IOSArrow XmlTree XmlTree+  checkInclude href newDoc+    = ifA ( -- If the include element has a start component, then the grammar element+            -- must have a start component.+            hasStartComponent &&& (constA newDoc >>> hasStartComponent)+            >>> +            isA (\ (a, b) -> if a then b else True)+          )+        ( ifA ( -- If the include element has a define component, then the grammar element+                -- must have a define component with the same name.+                getDefineComponents &&& (constA newDoc >>> getDefineComponents)+                >>> +                isA (\ (a, b) -> (diff a b) == [])+              )+            (insertNewDoc newDoc $<< hasStartComponent &&& getDefineComponents)+            ( mkRelaxError ""+	      ( "Define-pattern missing in schema " ++ show href ++ +                ", referenced in include-pattern"+	      )+            )+	)+        ( mkRelaxError ""+	  ( "Grammar-element without a start-pattern in schema " +++            show href ++ ", referenced in include-pattern"+	  )+        )+    where+    diff a b = (noDoubles a) \\ (noDoubles b)++  removeStartComponent :: IOSArrow XmlTree XmlTree+  removeStartComponent+    = processChildren $+        choiceA [+          isRngStart :-> none,+          isRngDiv   :-> removeStartComponent,+          this       :-> this+        ]++  removeDefineComponent :: [String] -> IOSArrow XmlTree XmlTree+  removeDefineComponent defNames+    = processChildren $+        choiceA [+          ( isRngDefine+            >>>+            getRngAttrName+            >>> +            isA (\n -> elem n defNames))          :-> none,+          (isElem >>> getName >>> isA (== "div")) :-> (removeDefineComponent defNames),+          (constA "foo" >>> isA (== "foo"))       :-> this+        ]+  +  hasStartComponent :: IOSArrow XmlTree Bool+  hasStartComponent = listA hasStartComponent' >>> arr (any id)+    where+    hasStartComponent' :: IOSArrow XmlTree Bool+    hasStartComponent'+      = getChildren+        >>>+        choiceA [+          isRngStart :-> (constA True),+          isRngDiv   :-> hasStartComponent',+          this       :-> (constA False)+        ]++  getDefineComponents :: IOSArrow XmlTree [String]+  getDefineComponents = listA getDefineComponents'+                        >>> +                        arr (\xs -> [x | x <- xs, x /= ""])+    where+    getDefineComponents' :: IOSArrow XmlTree String+    getDefineComponents'+      = getChildren+        >>>+        choiceA+	[ isRngDefine :-> getRngAttrName+	, isRngDiv    :-> getDefineComponents'+	, this        :-> constA ""+        ]+  ++-- ------------------------------------------------------------+++{-+- 4.8. name attribute of element and attribute elements+    - The name attribute on an element or attribute element+      is transformed into a name child element.+    - If an attribute element has a name attribute but no ns attribute,+      then an ns="" attribute is added to the name child element.+- 4.9. ns attribute+    - For any name, nsName or value element that does not have+      an ns attribute, an ns attribute is added.+    - any ns attribute that is on an element other than name,+      nsName or value is removed.+- 4.10. QNames+    - For any name element containing a prefix, the prefix is removed+      and an ns attribute is added replacing any existing ns attribute.+    - The value of the added ns attribute is the value to which the+      namespace map of the context of the name element maps the prefix.+    - The context must have a mapping for the prefix.+-}+simplificationStep3 :: IOSArrow XmlTree XmlTree+simplificationStep3 =+  ( processTopDown ( +      ( -- 4.8 The name attribute on an element or attribute+        -- element is transformed into a name child element+        ( insertChildrenAt 0 (mkRngName none (txt $< getRngAttrName))+        )+        >>>+        ( -- 4.8 If an attribute element has a name attribute but no ns attribute,+          --  then an ns="" attribute is added to the name child element+           (processChildren (addAttr "ns" "" `when` isRngName))+           `when` +           (isRngAttribute >>> hasRngAttrName >>> neg hasRngAttrNs)+        )+        >>>+        removeAttr "name"      +      )+      `when`+      ( (isRngElement `orElse` isRngAttribute) >>> hasRngAttrName )+    )+    >>>+    -- 4.9 For any name, nsName or value element that does not have +    -- an ns attribute, an ns attribute is added.+    processnsAttribute ""+    >>>+    processTopDown (        +      ( -- 4.9 any ns attribute that is on an element other than name, +        -- nsName or value is removed.+        (removeAttr "ns")+        `when`+        (isElem >>> neg (isRngName `orElse` isRngNsName `orElse` isRngValue))+      )+      >>>+      ( -- 4.10 For any name element containing a prefix, the prefix is removed and an ns attribute +        -- is added replacing any existing ns attribute.+        (replaceNameAttr $< (getChildren >>> isText >>> getText))+        `when`+        isRngName+      )+    )+  ) `when` collectErrors+  where+  replaceNameAttr :: (ArrowXml a) => String -> a XmlTree XmlTree+  replaceNameAttr name +    = (addAttr "ns" pre >>> processChildren (changeText $ const local))+      `whenP`+      (const $ elem '}' name)+    where +    (pre', local') = span (/= '}') name+    pre            = tail pre'+    local          = tail local'+          +  processnsAttribute :: String -> IOSArrow XmlTree XmlTree        +  processnsAttribute name +    = processChildren $+        choiceA [+          -- set the new ns attribute value+          (isElem >>> hasRngAttrNs) +               :-> (processnsAttribute $< getRngAttrNs),+          -- For any name, nsName or value element that does not have+          -- an ns attribute, an ns attribute is added.               +          ( isNameNsNameValue >>> neg hasRngAttrNs)+               :-> (addAttr "ns" name >>> processnsAttribute name),+          this :-> (processnsAttribute name)+        ]+++-- ------------------------------------------------------------    +++{-+- 4.11 Each div element is replaced by its children+- 4.12 Number of child elements+    - A define, oneOrMore, zeroOrMore, optional, list or mixed element +      is transformed so that it has exactly one child element+    - An element element is transformed so that it has exactly two child elements+    - A except element is transformed so that it has exactly one child element+    - If an attribute element has only one child element (a name class), then a text element is added.+    - A choice, group or interleave element is transformed so that it has exactly two child elements.+- 4.13 A mixed element is transformed into an interleaving with a text element+- 4.14 An optional element is transformed into a choice with empty+- 4.15 A zeroOrMore element is transformed into a choice between oneOrMore and empty+- 4.16. Constraints: no transformation is performed, but various constraints are checked.+    - An except element that is a child of an anyName element must not have any anyName descendant elements.+    - An except element that is a child of an nsName element must not have any nsName or anyName+      descendant elements.+    - A name element that occurs as the first child of an attribute element or as the descendant of the +      first child of an attribute element and that has an ns attribute with value equal to the empty +      string must not have content equal to xmlns.+    - A name or nsName element that occurs as the first child of an attribute element or as the +      descendant of the first child of an attribute element must not have an ns attribute with +      value http://www.w3.org/2000/xmlns.+    - A data or value element must be correct in its use of datatypes.+-}+simplificationStep4 :: IOSArrow XmlTree XmlTree+simplificationStep4 =+  ( processTopDown ( +      ( -- Each div element is replaced by its children.+        (getChildren >>> simplificationStep4)+        `when`+        isRngDiv+      )+      >>>+      ( -- A define, oneOrMore, zeroOrMore, optional, list or mixed element+        -- is transformed so that it has exactly one child element+        ( replaceChildren+	  ( mkRngGroup+            (setChangesAttr $< (getName >>> arr ("group-Pattern: " ++)))  +            getChildren+	  )+        )+        `when`+        (  isDefineOneOrMoreZeroOrMoreOptionalListMixed+           >>>+	   noOfChildren (> 1)+        )+      )+      >>>+      ( -- An element element is transformed so that it has exactly two child elements       +        ( replaceChildren+	  ( ( getChildren >>> isNameAnyNameNsName )+            <+> +            ( mkRngGroup none +              ( getChildren+                >>>+                neg isNameAnyNameNsName+              )+            )+	  )+        )+        `when`+        ( isRngElement >>> noOfChildren (> 2) )+      )+      >>>+      ( -- A except element is transformed so that it has exactly one child element.+        replaceChildren ( mkRngChoice none getChildren )+        `when`+        ( isRngExcept >>> noOfChildren (> 1) )+      )+      >>>+      ( -- If an attribute element has only one child element +        -- (a name class), then a text element is added.+        insertChildrenAt 1 (mkRngText none)+        `when`+        ( isRngAttribute >>> noOfChildren (== 1) )+      )+      >>>+      ( -- A choice, group or interleave element is transformed so+        -- that it has exactly two child elements.+        ((wrapPattern2Two $< getName) >>> simplificationStep4)+        `when` +        (  isChoiceGroupInterleave+           >>>+           noOfChildren (\ i -> i > 2 || i == 1)+        )+      )+      >>>+      ( -- A mixed element is transformed into an interleaving with a text element     +        ( mkRngInterleave +          ( setChangesAttr "mixed is transformed into an interleave" )+          ( getChildren+            <+>+            mkRngText +            ( setChangesAttr ( "new text-Pattern: mixed is transformed into " +++                                  " an interleave with text"+			     )+            )+          )+        )+        `when`+        isRngMixed+      )+      >>>  +      ( -- An optional element is transformed into a choice with empty     +        ( mkRngChoice +          ( setChangesAttr "optional is transformed into a choice" )+          ( getChildren+            <+>+            mkRngEmpty +            ( setChangesAttr ( "new empty-Pattern: optional is transformed " +++                               " into a choice with empty"+			     )+            )+          )+        )+        `when`+        isRngOptional+      )+      >>>+      ( -- A zeroOrMore element is transformed into a choice between oneOrMore and empty+        ( mkRngChoice +          ( setChangesAttr "zeroOrMore is transformed into a choice" )+          ( ( mkRngOneOrMore +              ( setChangesAttr ( "zeroOrMore is transformed into a " +++                                   "choice between oneOrMore and empty"+			       )+              )+              getChildren+            )+            <+>+            ( mkRngEmpty +              ( setChangesAttr ( "new empty-Pattern: zeroOrMore is transformed " +++                                   "into a choice between oneOrMore and empty"+			       )+              )+            )+          )+        )+        `when`+        isRngZeroOrMore+      )+    )+  ) `when` collectErrors+++-- ------------------------------------------------------------+++restrictionsStep1 :: IOSArrow XmlTree XmlTree+restrictionsStep1 =+  ( processTopDown (+      ( ( mkRelaxError ""+	  ( "An except element that is a child of an anyName " +++            "element must not have any anyName descendant elements"+	  )+	)+        `when` +        ( isRngAnyName+          >>>+	  getChildren+          >>>+          isRngExcept+          >>>+          deep isRngAnyName+        )+      )+      >>>+      ( ( mkRelaxError ""+	  ( "An except element that is a child of an nsName element " +++            "must not have any nsName or anyName descendant elements."+	  )+        )+        `when` +        ( isRngNsName+          >>>+          getChildren+          >>> +          isRngExcept+          >>> +          deep (isRngAnyName `orElse` isRngNsName)+        )+      )+      >>>+      ( ( mkRelaxError ""+	  ( "A name element that occurs as the first child or descendant of " +++            "an attribute and has an ns attribute with an empty value must " +++            "not have content equal to \"xmlns\""+	  )+        )+        `when` +        ( isRngAttribute+          >>>+          firstChild+          >>>+          ( multi (isRngName >>> hasRngAttrNs) )+          >>>+          ( ( getRngAttrNs >>> isA null)+            `guards`+            (getChildren >>> getText >>> isA (== "xmlns"))+          )+        )+      ) +      >>>+      ( ( mkRelaxError ""+	  ( "A name or nsName element that occurs as the first child or " +++            "descendant of an attribute must not have an ns attribute " +++            "with value http://www.w3.org/2000/xmlns"+	  )+        )+        `when` +        ( isRngAttribute+          >>>+          firstChild+          >>>+          ( multi (isNameNsName >>> hasRngAttrNs) )+          >>>+          getRngAttrNs+          >>>+          isA (compareURI xmlnsNamespace)+        )+      ) +      >>> -- A data or value element must be correct in its use of datatypes.+      ( ( checkDatatype $<< getRngAttrDatatypeLibrary &&& getRngAttrType )+        `when`+        ( isRngData `orElse` isRngValue )+      )+    )+  ) `when` collectErrors+  where ++  -- the datatypeLibrary attribute must identify a valid datatype library++  checkDatatype :: Uri -> DatatypeName -> IOSArrow XmlTree XmlTree+  checkDatatype libName typeName +      = ifP (const $ elem libName $ map fst datatypeLibraries)    +        ( checkType libName typeName allowedDataTypes )+        ( mkRelaxError ""+	  ( "DatatypeLibrary " ++ show libName ++ " not found" )+	)+    where+    DTC _ _ allowedDataTypes = fromJust $ lookup libName datatypeLibraries+            +  -- the type attribute must identify a datatype within the datatype library identified+  -- by the value of the datatypeLibrary attribute.++  checkType :: Uri -> DatatypeName -> AllowedDatatypes -> IOSArrow XmlTree XmlTree+  checkType libName typeName allowedTypes+      = ifP (const $ elem typeName $ map fst allowedTypes)+        ( checkParams typeName libName getParams $< +          ( listA (getChildren >>> isRngParam >>> getRngAttrName) )+        )+       ( mkRelaxError ""+	 ( "Datatype " ++ show typeName ++ +           " not declared for DatatypeLibrary " ++ show libName+	 )+       )+    where+    getParams = fromJust $ lookup typeName allowedTypes+            +  -- For a data element, the parameter list must be one that is allowed by the datatype++  checkParams :: DatatypeName -> Uri -> AllowedParams -> [ParamName] -> IOSArrow XmlTree XmlTree+  checkParams typeName libName allowedParams paramNames+      = ( mkRelaxError ""+	  ( "Param(s): " ++ formatStringListQuot diff ++ +            " not allowed for Datatype " ++ show typeName ++ +            " in Library " +++	    show ( if null libName+		   then relaxNamespace+		   else libName+		 )+	  )+	)+        `when`+	( isRngData >>> isA (const $ diff /= []) ) +      where+      diff = filter (\param -> not $ elem param allowedParams) paramNames++          +-- ------------------------------------------------------------+++{-+- 4.17. combine attribute+    - For each grammar element, all define elements with the same name are combined together.+    - Similarly, for each grammar element all start elements are combined together.+- 4.18. grammar element+    - A grammar must have a start child element.+    - Transform the top-level pattern p into <grammar><start>p</start></grammar>.+    - Rename define elements so that no two define elements anywhere in the schema +      have the same name. To rename a define element, change the value of its name+      attribute and change the value of the name attribute of all ref and parentRef+      elements that refer to that define element.+    - Move all define elements to be children of the top-level grammar element+    - Replace each nested grammar element by the child of its start element+    - Rename each parentRef element to ref.+-}+simplificationStep5 :: IOSArrow XmlTree XmlTree+simplificationStep5+    = ( processTopDown+	( ( ( ( (deep isRngRelaxError)               +		<+>+		( mkRelaxError "" "A grammar must have a start child element" )+              )+              `when`+              (neg (getChildren >>> isRngStart))+            )+            >>>+            -- For each grammar element, all define elements with the same +            -- name are combined together.+            ( combinePatternList "define" $< (getPatternNamesInGrammar "define" >>> arr nub) )+            >>>+            -- Similarly, for each grammar element all start elements +            -- are combined together.+            ( combinePatternList "start" $< (getPatternNamesInGrammar "start" >>> arr nub) )+	  )  +	  `when`+	  isRngGrammar+	)+	>>>+	( -- transform the top-level pattern p into <grammar><start>p</start></grammar>.+	  ( replaceChildren+	    ( mkRngGrammar none +              ( mkRngStart none getChildren )+            )+	  )+	  `when`+	  neg (getChildren >>> isRngGrammar)+	)+	>>>+	( renameDefines $<<+	  ( getPatternNamesInGrammar "define"+            >>>+            (createUniqueNames $< (getAndSetCounter "define_id" >>> arr read))+            &&&+            constA []+          )+	)+	>>>+	-- Move all define elements to be children of the top-level grammar element+	( processChildren+	  ( -- root node+            processChildren+	    ( -- the first grammar pattern remains unchanged+	      ( deleteAllDefines+		<+>+		( getAllDefines >>> processChildren deleteAllDefines )+              )+              >>>+              processTopDown+	      ( ( -- Replace each nested grammar element by the child of its start element+		  ( getChildren >>> isRngStart >>> getChildren )+		  `when`+		  isRngGrammar+		)+		>>> +		( -- Rename each parentRef element to ref.+		  ( setRngNameRef+		    `when`+		    isRngParentRef+		  )+		)+              )  +	    )+	  )+	)+      ) `when` collectErrors+    where+    getPatternNamesInGrammar :: (ArrowXml a) => String -> a XmlTree [String]+    getPatternNamesInGrammar pattern+	= processChildren+	  ( processTopDown ( none `when` isRngGrammar ) )+	  >>>+	  listA ( (multi (isElem >>> hasRngName pattern))+		  >>> +		  getRngAttrName+		)++    createUniqueNames :: Int -> IOSArrow [String] RefList+    createUniqueNames num+	= arr (\ l -> unique l num)+	  >>>+	  perform (setParamInt "define_id" $< arr (max num . getNextValue))+	where+	unique :: [String] -> Int -> RefList+	unique []     _    = []+	unique (x:xs) num' = (x, (show num')):(unique xs (num'+1))+	getNextValue :: RefList -> Int+	getNextValue [] = 0+	getNextValue rl = maximum (map (read . snd) rl) + 1    ++    renameDefines :: RefList -> RefList -> IOSArrow XmlTree XmlTree+    renameDefines ref parentRef+	= processChildren+	  ( choiceA+	    [ isRngDefine+              :-> ( -- the original name is needed for error messages+                    addAttr defineOrigName $< getRngAttrName+                    >>>+                    -- rename the define-pattern+                    -- the new name is looked up in the ref table+                    addAttr "name" $< ( getRngAttrName+					>>>+					arr (\n -> fromJust $ lookup n ref)+                                      )+                    >>>+                    renameDefines ref parentRef+		  )+	    , isRngGrammar +              :-> ( renameDefines $<< ( ( -- compute all define names in the grammar+					  getPatternNamesInGrammar "define"+					  >>>+					  -- create a new (unique) name for all define names+					  (createUniqueNames $< (getParamInt 0 "define_id"))+					)+					&&&+					-- set the old ref list to be the new parentRef list+					constA ref+				      )+		  )+	    , isRngRef+              :-> ( ifA ( getRngAttrName+			  >>>+			  isA (\name -> (elem name (map fst ref)))+			)+                    ( -- the original name is needed for error messages+                      addAttr defineOrigName $< getRngAttrName+                      >>>+                      -- rename the ref-pattern+                      -- the new name is looked up in the ref table+                      addAttr "name" $< ( getRngAttrName+					  >>>+					  arr (\n -> fromJust $ lookup n ref)+					)+                    )+                    ( -- the referenced pattern does not exist in the schema+                      mkRelaxError "" $< ( getRngAttrName+					   >>>+					   arr (\ n -> ( "Define-Pattern with name " ++ show n ++ +							 " referenced in ref-Pattern not " +++							 "found in schema"+						       )+                                               )+					 )+                    )+		  )+	    , isRngParentRef -- same as ref, but the parentRef list is used+              :-> ( ifA ( getRngAttrName+			  >>>+			  isA (\name -> (elem name (map fst parentRef)))+			)+                    ( addAttr defineOrigName $< getRngAttrName+                      >>>+                      addAttr "name" $< ( getRngAttrName+					  >>>+					  arr (\n -> fromJust $ lookup n parentRef)+					)+                    )+                    ( mkRelaxError "" $<+		      ( getRngAttrName+			>>> +			arr (\ n -> ( "Define-Pattern with name " ++ show n ++ +                                      " referenced in parentRef-Pattern " +++                                      "not found in schema"+                                    )+			    )+                      )+                    )+		  )+	    , this+	      :-> renameDefines ref parentRef+            ]+	  )+++    getAllDefines :: IOSArrow XmlTree XmlTree+    getAllDefines = multi isRngDefine++    deleteAllDefines :: IOSArrow XmlTree XmlTree      +    deleteAllDefines = processTopDown $ none `when` isRngDefine++    combinePatternList :: String -> [String] -> IOSArrow XmlTree XmlTree+    combinePatternList _ [] = this+    combinePatternList pattern (x:xs)+	= (replaceChildren $ combinePattern pattern x)+	  >>>+	  combinePatternList pattern xs+        +    -- combine a define- or start-pattern (first parameter) with a+    -- specific name (second parameter)+    combinePattern :: String -> String -> IOSArrow XmlTree XmlTree +    combinePattern pattern name+	= createPatternElems pattern name+	  <+>+	  (getChildren >>> deletePatternElems pattern name)           ++    createPatternElems :: String -> String -> IOSArrow XmlTree XmlTree +    createPatternElems pattern name +	= ( ( (listA (getElems pattern name >>> getRngAttrCombine))+              >>>+              checkPatternCombine pattern name+            ) +            -- After determining this unique value, the combine attributes are removed.+            &&&+            (listA (getElems pattern name >>> removeAttr "combine")))                      +          >>> -- ((errorCode::Int,errorMessage::String), result::XmlTrees)+          choiceA+	  [ isA (\ ((code,_) , _)   -> code == 0)+            :->+	    (mkRelaxError "" $< arr (snd . fst))+	  , isA (\ ((code,str) , _) -> code == 1 && str == "")+            :->+	    arrL snd+	  , isA (\ ((code,str) , _) -> code == 1 && str /= "")+            :->+	    ( createPatternElem pattern name $<< +              ( arr (snd . fst) &&& (arr snd) )+            )+	  , this+	    :->+	    ( mkRelaxError ""+	      ( "Can't create Pattern: " ++ show pattern ++ +                " with name " ++ show name ++ " in createPatternElems"+	      )+            )+          ]++    createPatternElem :: (ArrowXml a) => String -> String -> String -> XmlTrees -> a n XmlTree  +    createPatternElem pattern name combine trees+	= mkRngElement pattern (mkAttr (mkName "name") (txt name)) +	  ( ( mkRngElement combine none +              (arrL (const trees) >>> getChildren)+            )+            >>>+            wrapPattern2Two combine+	  )+                                         +    checkPatternCombine :: (ArrowXml a) => String -> String -> a [String] (Int, String)+    checkPatternCombine pattern name +	= choiceA+	  [ -- just one pattern with that name -> ok, no combine is needed+            (isA (\ cl -> length cl == 1))+	    :->+	    constA (1, "")+	  , (isA (\ cl -> (length $ elemIndices "" cl) > 1)) +            :->+	    constA ( 0+		   , "More than one " ++ pattern ++ "-Pattern: " ++ show name ++ +                     " without an combine-attribute in the same grammar"+		   )+	  , (isA (\ cl -> (length $ nub $ deleteBy (==) "" cl) > 1)) +            :->+	    arr (\ cl -> ( 0+			 , "Different combine-Attributes: " ++ +                           (formatStringListQuot $ noDoubles cl) +++                           " for the " ++ pattern ++ "-Pattern " +++                           show name ++ " in the same grammar"+			 )+                )+	  , -- ok -> combine value is returned+            this+	    :->+	    arr (\ cl -> (1, fromJust $ find (/= "") cl))+	  ]++    isElemWithNameValue	:: (ArrowXml a) => String -> String -> a XmlTree XmlTree+    isElemWithNameValue ename nvalue+	= ( isElem+	    >>>+	    hasRngName ename+	    >>>+	    getRngAttrName+	    >>>+	    isA (== nvalue)+	  )+          `guards` this++    getElems :: (ArrowXml a) => String -> String -> a XmlTree XmlTree+    getElems pattern name+	= getChildren+	  >>> +	  choiceA+	  [ isElemWithNameValue pattern name+	    :->+	    (this <+> getElems pattern name)+	  , isRngGrammar+	    :-> none+	  , this+            :->+	    getElems pattern name+	  ]++    deletePatternElems :: (ArrowXml a) => String -> String -> a XmlTree XmlTree+    deletePatternElems pattern name+	= choiceA+	  [ isElemWithNameValue pattern name+            :->+	    none+	  , isRngGrammar+            :-> this+	  , this+	    :->+	    processChildren ( deletePatternElems pattern name )+	  ]+++-- ------------------------------------------------------------+++{-+- 4.19. define and ref elements+    - Remove any define element that is not reachable.+    - Now, for each element element that is not the child of a define element,+      add a define element to the grammar element, +      and replace the element element by a ref element referring+      to the added define element.+    - For each ref element that is expandable and is a descendant+      of a start element or an element element, expand it by replacing+      the ref element by the child of the define element to which it refers+    - This must not result in a loop.+    - Remove any define element whose child is not an element element.+-}+simplificationStep6 :: IOSArrow XmlTree XmlTree+simplificationStep6 =+  ( -- Remove any define element that is not reachable.+    (removeUnreachableDefines $<<< getAllDeepDefines +                                   &&& +                                   constA []+                                   &&&+                                   getRefsFromStartPattern+    )+    >>>+    -- for each element element that is not the child of a define element,+    -- add a define element to the grammar element, +    ( processElements False+      >>>+      processChildren (insertChildrenAt 1 (getParam "elementTable"))+    )+    >>>+    -- For each ref element that is expandable... +    -- Remove any define element whose child is not an element element      +    (replaceExpandableRefs [] $< getExpandableDefines >>> deleteExpandableDefines)+  ) `when` collectErrors+  where+  replaceExpandableRefs :: RefList -> Env -> IOSArrow XmlTree XmlTree+  replaceExpandableRefs foundNames defTable+    = choiceA [+        isRngRef+             :-> (ifA ( getRngAttrName+                        >>>+                        isA (\name -> elem name (map fst foundNames))+                      )+                    -- we have found a loop if the name is in the list+                    (mkRelaxError "" $< ( getAttrValue defineOrigName+                                          >>>+                                          arr (\ n -> ( "Recursion in ref-Pattern: " ++ +							formatStringListArr (reverse $ (n:) $ map snd foundNames)+						      )+                                              )+                                        )+                    )+                    (replaceRef $<< getRngAttrName &&& getAttrValue defineOrigName)+                 ),+        this :-> (processChildren $ replaceExpandableRefs foundNames defTable)+      ]+    where                                               +    replaceRef :: NewName -> OldName -> IOSArrow XmlTree XmlTree+    replaceRef name oldname+      = ( constA (fromJust $ lookup name defTable)+          >>>+          getChildren+          >>>+          replaceExpandableRefs ((name,oldname):foundNames) defTable+        )+        `whenP`+        (const $ elem name $ map fst defTable)+++  processElements :: Bool -> IOSArrow XmlTree XmlTree+  processElements parentIsDefine+    = processChildren+      ( choiceA+	[ isRngElement+          :-> ( ifP (const parentIsDefine)+                (processElements False)+                ( processElements' $<< ( getAndSetCounter "define_id" +					 &&&+					 getDefineName+				       )+                )+              )+	, isRngDefine+	  :-> processElements True+        , this+          :-> processElements False+        ])+    where+    getDefineName :: IOSArrow XmlTree String+    getDefineName+	= firstChild+          >>>+          fromLA createNameClass+          >>>+          arr show+    +    processElements' :: NewName -> OldName -> IOSArrow XmlTree XmlTree+    processElements' name oldname+      = storeElement name oldname+        >>> +        mkRngRef (createAttr name oldname) none++    storeElement :: NewName -> OldName -> IOSArrow XmlTree XmlTree+    storeElement name oldname+      = perform $ +          ( mkRngDefine+             (createAttr name oldname) (processElements False)+          )+          &&&+          (listA $ getParam "elementTable")+          >>>+          arr2 (:)+          >>>+          setParamList "elementTable"++    createAttr :: NewName -> OldName -> IOSArrow XmlTree XmlTree+    createAttr name oldname+      = mkAttr (mkName "name") (txt name) +        <+>+        mkAttr (mkName defineOrigName) (txt $ "created for element " ++ oldname)+       +  getExpandableDefines :: (ArrowXml a) => a XmlTree Env +  getExpandableDefines +    = listA $ (multi ( ( isRngDefine+                         >>>+                         getChildren+                         >>>+                         neg isRngElement+                       )+                       `guards`+                       this+                     )+              )+              >>> +              (getRngAttrName &&& this)+  +  deleteExpandableDefines :: (ArrowXml a) => a XmlTree XmlTree+  deleteExpandableDefines +    = processTopDown $ none+                       `when` +                       ( isRngDefine+                         >>> +                         getChildren+                         >>>+                         neg isRngElement+                       )+++-- ------------------------------------------------------------+++{-+- 4.20. notAllowed element+    - An attribute, list, group, interleave, or oneOrMore element that has+      a notAllowed child element is transformed into a notAllowed element.+    - A choice element that has two notAllowed child elements +      is transformed into a notAllowed element+    - A choice element that has one notAllowed child element+      is transformed into its other child element.+    - An except element that has a notAllowed child element is removed.+    - The preceding transformations are applied repeatedly+      until none of them is applicable any more.+    - Any define element that is no longer reachable is removed.+- 4.21. empty element+    - A group, interleave or choice element that has two empty child+      elements is transformed into an empty element.+    - A group or interleave element that has one empty child element+      is transformed into its other child element.+    - A choice element whose second child element is an empty element+      is transformed by interchanging its two child elements.+    - A oneOrMore element that has an empty child element+      is transformed into an empty element.+    - The preceding transformations are applied repeatedly+      until none of them is applicable any more.+-}++simplificationStep7 :: IOSArrow XmlTree XmlTree+simplificationStep7+    = ( markTreeChanged 0			 	-- 0 = no changes, 1 = changes performed+	>>>+	processTopDownWithAttrl+	( ( -- An attribute, list, group, interleave, or oneOrMore element that has a +            -- notAllowed child element is transformed into a notAllowed element.       +            ( ( mkRngNotAllowed none none+		>>>+		markTreeChanged 1+              )+              `whenNot` 				-- keep all errors+              (deep isRngRelaxError)+            )+            `when`+            ( isAttributeListGroupInterleaveOneOrMore+              >>>+              getChildren+              >>>+              isRngNotAllowed+            )+	  )+	  >>>                                   +	  ( -- A choice element that has two notAllowed child elements is +            -- transformed into a notAllowed element+            ( mkRngNotAllowed none none+              >>>+              markTreeChanged 1+            )+            `when`+            ( isRngChoice+              >>>+              listA (getChildren >>> isRngNotAllowed)+              >>> +              isA (\s -> length s == 2)+            )+	  )+	  >>>+	  ( -- A choice element that has one notAllowed child element is +            -- transformed into its other child element.        +            ( getChildren >>> neg isRngNotAllowed+              >>>+              markTreeChanged 1+            )+            `when`+            ( isRngChoice >>> getChildren >>> isRngNotAllowed )+	  )+	  >>>       +	  ( -- An except element that has a notAllowed child element is removed.+            ( ( markTreeChanged 1+		>>>+		none+	      ) +              `whenNot`			 -- keep all errors+              deep isRngRelaxError+            )+            `when`+            ( isRngExcept >>> getChildren >>> isRngNotAllowed )+	  )+	  >>> -- transforming the empty pattern (4.21)+	  ( -- A group, interleave or choice element that has two empty child elements+            -- is transformed into an empty element.+            ( mkRngEmpty none+              >>>+              markTreeChanged 1+            )+            `when`+            ( isChoiceGroupInterleave+              >>>+              listA (getChildren >>> isRngEmpty)+              >>>+              isA (\s -> length s == 2)+            )+	  )+	  >>>+	  ( -- A group or interleave element that has one empty child element +            -- is transformed into its other child element.+            ( getChildren+	      >>>+	      neg isRngEmpty+	      >>>+	      markTreeChanged 1+	    )+            `when`+            ( isGroupInterleave >>> getChildren >>> isRngEmpty )+	  )+	  >>>+	  ( -- A choice element whose second child element is an empty element is transformed +            -- by interchanging its two child elements.+            changeChoiceChildren+            `when`+            ( isRngChoice >>> getChildren >>> isRngEmpty )+	  )+	  >>>+	  ( -- A oneOrMore element that has an empty child element+            -- is transformed into an empty element.+            ( mkRngEmpty none+              >>>+              markTreeChanged 1+            )+            `when`+            ( isRngOneOrMore >>> getChildren >>> isRngEmpty )+	  )+	)+	>>>+	-- The preceding transformations are applied repeatedly+	-- until none of them is applicable any more.+	( simplificationStep7+	  `when`+	  hasTreeChanged+	)+      ) `when` collectErrors+    where+    changeChoiceChildren :: IOSArrow XmlTree XmlTree+    changeChoiceChildren+	= ( ( replaceChildren+	      ( mkRngEmpty none+		<+> +		(getChildren >>> neg isRngEmpty)+              ) +              >>>+              markTreeChanged 1+	    )+	    `when`+	    ( single (getChildren >>> isElem)		-- first child not "empty" elem+              >>>+              neg isRngEmpty+	    )+	  )++hasTreeChanged	:: IOSArrow b Int+hasTreeChanged+    = getParamInt 0 "rng:changeTree"+      >>>+      isA (== 1)++markTreeChanged :: Int -> IOSArrow b b+markTreeChanged i+    = perform (setParamInt "rng:changeTree" i)++-- ------------------------------------------------------------+++simplificationStep8 :: IOSArrow XmlTree XmlTree+simplificationStep8			-- Remove any define element that is not reachable.+    = ( ( removeUnreachableDefines $<<<+	  ( getAllDeepDefines+            &&&+            constA []+            &&&+            getRefsFromStartPattern+	  )+	)+	`when` collectErrors+      )+               ++-- ------------------------------------------------------------+++restrictionsStep2 :: IOSArrow XmlTree XmlTree+restrictionsStep2 =+  processTopDown (+    choiceA [+-- 7.1.1. attribute pattern, the following paths are prohibited:+--        attribute//(ref | attribute)+      isRngAttribute :-> +        ( ( deep isRngRelaxError+            <+>+            ( mkRelaxError $<< (getChangesAttr+                                &&&+                                ( listA ( getChildren+                                          >>> +                                          deep isAttributeRef+                                          >>>+                                          (getName &&& getChangesAttr >>> arr2 (++))+                                        )+                                  >>>+                                  arr (\n -> formatStringListPatt n ++ +                                             "Pattern not allowed as descendent(s)" +++                                             " of a attribute-Pattern"+                                      )+                                )+                               )+            ) +          )+          `when` +          ( getChildren >>> deep isAttributeRef )+        ),++-- 7.1.2. oneOrMore pattern, the following paths are prohibited:+--        oneOrMore//(group | interleave)//attribute+      isRngOneOrMore :->+        ( ( deep isRngRelaxError+            <+>+            ( mkRelaxError $<< (getChangesAttr+                                &&&+                                ( listA ( getChildren+                                          >>> +                                          deep isGroupInterleave+                                          >>>+                                          (getName &&& getChangesAttr >>> arr2 (++))+                                        )+                                  &&&+                                  getChangesAttr+                                  >>>+                                  arr2 (\ n c -> ( formatStringListPatt n ++ +                                                   "Pattern not allowed as descendent(s) " +++                                                   "of a oneOrMore-Pattern" +++						   (if null c then "" else " " ++ show c) ++ +                                                   " followed by an attribute descendent"+						 )+                                       )+                                )+                               )+            ) +          )+          `when` +          ( getChildren >>> deep isGroupInterleave+            >>> +            getChildren >>> deep isRngAttribute+          )+        ),++-- 7.1.3. list pattern, the following paths are prohibited:+--        list//( list | ref | attribute | text | interleave)+      isRngList :-> +        ( ( deep isRngRelaxError+            <+>+            ( mkRelaxError $<< (getChangesAttr+                                &&&+                                ( listA ( getChildren+                                          >>> +                                          deep isAttributeRefTextListInterleave+                                          >>>+                                          (getName &&& getChangesAttr >>> arr2 (++))+                                        )+                                  >>> +                                  arr (\n -> formatStringListPatt n ++ +                                             "Pattern not allowed as descendent(s) of a list-Pattern")+                                )+                               )+            ) +          )+          `when` +          ( getChildren+            >>>+            deep isAttributeRefTextListInterleave+          )+        ), ++-- 7.1.4. except in data pattern, the following paths are prohibited:+--        data/except//(attribute | ref | text | list | group | interleave | oneOrMore | empty)+      isRngData :-> +        ( ( deep isRngRelaxError              +            <+>+            ( mkRelaxError $<< (getChangesAttr+                                &&&+                                ( listA (getChildren+                                         >>> +                                         deep isAttributeRefTextListGroupInterleaveOneOrMoreEmpty+                                         >>>+                                         (getName &&& getChangesAttr >>> arr2 (++))+                                        )+                                  >>>+                                  arr (\n -> formatStringListPatt n ++ +                                             "Pattern not allowed as descendent(s) of a data/except-Pattern")+                                )+                               )+            ) +          )+          `when` +          ( getChildren+	    >>>+	    isRngExcept+	    >>> +            deep isAttributeRefTextListGroupInterleaveOneOrMoreEmpty+          )+        ),++-- 7.1.5. start element, the following paths are prohibited:+--        start//(attribute | data | value | text | list | group | interleave | oneOrMore | empty)+      isRngStart :-> +        ( ( deep isRngRelaxError+            <+>+            ( mkRelaxError $<< (getChangesAttr+                                &&&+                                ( listA (getChildren+                                         >>>+                                         deep (checkElemName [ "attribute", "data", "value", "text", "list", +                                                               "group", "interleave", "oneOrMore", "empty"])+                                         >>>+                                         (getName &&& getChangesAttr >>> arr2 (++))+                                        )+                                  >>> +                                  arr (\n -> formatStringListPatt n ++ +                                             "Pattern not allowed as descendent(s) of a start-Pattern")+                                )+                               )+            ) +          )+          `when` +          ( getChildren+            >>>+            deep (checkElemName [ "attribute", "data", "value", "text", "list", +                                  "group", "interleave", "oneOrMore", "empty"])+          )  +        ),+            +        this :-> this+      ]+  ) `when` collectErrors++     +-- ------------------------------------------------------------+++restrictionsStep3 :: IOSArrow XmlTree XmlTree+restrictionsStep3+    = processTopDown+      ( ( deep isRngRelaxError+          <+>+          ( mkRelaxError "" $< +            ( -- getRngAttrName+              ( getChildren >>> isRngName >>> getChildren >>> getText )+              >>> +              arr (\ n -> ( "Content of element " ++ show n ++ " contains a pattern that can match " +++                            "a child and a pattern that matches a single string"+			  )+		  )+            )+          )+	)+	`when`+	( isRngElement+          >>>+          ( getChildren >>. (take 1 . reverse) )+          >>>+          getContentType >>> isA (== CTNone)+	)+      ) `when` collectErrors++    +    +getContentType :: IOSArrow XmlTree ContentType+getContentType+    = choiceA+      [ isRngValue      :-> (constA CTSimple)+      , isRngData       :-> processData+      , isRngList       :-> (constA CTSimple)+      , isRngText       :-> (constA CTComplex)+      , isRngRef        :-> (constA CTComplex)+      , isRngEmpty      :-> (constA CTEmpty)+      , isRngAttribute  :-> processAttribute+      , isRngGroup      :-> processGroup+      , isRngInterleave :-> processInterleave+      , isRngOneOrMore  :-> processOneOrMore+      , isRngChoice     :-> processChoice+      ]+    where+    processData :: IOSArrow XmlTree ContentType+    processData+	= ifA (neg (getChildren >>> isRngExcept))+          (constA CTSimple)+          ( getChildren+            >>>+            isRngExcept+            >>>+            getChildren+            >>>+            getContentType+            >>>+            ifP (/= CTNone) (constA CTSimple) (constA CTNone)+          )+    processAttribute :: IOSArrow XmlTree ContentType+    processAttribute+	= ifA ( lastChild+		>>>+		getContentType+		>>>+		isA (/= CTNone)+              )+          (constA CTEmpty)+          (constA CTNone)+  +    processGroup :: IOSArrow XmlTree ContentType+    processGroup+	= get2ContentTypes+	  >>>+	  arr2 (\a b -> if isGroupable a b then max a b else CTNone)+  +    processInterleave :: IOSArrow XmlTree ContentType+    processInterleave+	= get2ContentTypes+	  >>>+	  arr2 (\a b -> if isGroupable a b then max a b else CTNone)+  +    processOneOrMore :: IOSArrow XmlTree ContentType+    processOneOrMore+	= ifA ( getChildren+		>>>+		getContentType >>> isA (/= CTNone)+		>>>+		isA (\t -> isGroupable t t)+              )+          ( getChildren >>> getContentType )+          ( constA CTNone )+  +    processChoice :: IOSArrow XmlTree ContentType+    processChoice+	= get2ContentTypes+	  >>> +	  arr2 max++    isGroupable :: ContentType -> ContentType -> Bool+    isGroupable CTEmpty   _         = True+    isGroupable _         CTEmpty   = True+    isGroupable CTComplex CTComplex = True+    isGroupable _         _         = False   +++checkPattern :: IOSArrow (XmlTree, ([NameClass], [NameClass])) XmlTree+checkPattern+    = (\ (_, (a, b)) -> isIn a b) `guardsP` (arr fst)+    where+    isIn :: [NameClass] -> [NameClass] -> Bool+    isIn _ []      = False+    isIn [] _      = False+    isIn (x:xs) ys = (any (overlap x) ys) || isIn xs ys+++occur :: String -> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree+occur name fct+    = choiceA+      [ ( isElem >>> hasRngName name )+	:->+	fct+      , isChoiceGroupInterleaveOneOrMore+	:->+	(getChildren >>> occur name fct)+      ]++get2ContentTypes :: IOSArrow XmlTree (ContentType, ContentType)+get2ContentTypes+    = ( ( firstChild >>> getContentType )+	&&&+	( lastChild  >>> getContentType )+      )++-- ------------------------------------------------------------            +++-- Duplicate attributes are not allowed. -> fertig+-- Attributes using infinite name classes must be repeated; an attribute element that +-- has an anyName or nsName descendant element must have a oneOrMore ancestor element. -> fertig++-- berechnet alle define-Namen (fuer ref-Pattern) und Nameclasses der element-Pattern++restrictionsStep4 :: IOSArrow XmlTree XmlTree          +restrictionsStep4+    = ( restrictionsStep4' $<+	listA ( deep isRngDefine				-- get all defines+		>>>+		( getRngAttrName				-- get define name+		  &&& +		  ( single ( getChildren+			     >>>+			     getChildren+			     >>> +			     fromLA createNameClass		-- compute the name class from 1. grandchild+			   )+		    `orElse`+		    (constA AnyName)+		  )+		)+              )+      ) `when` collectErrors++restrictionsStep4' :: [(String, NameClass)] -> IOSArrow XmlTree XmlTree          +restrictionsStep4' nc =+  processTopDown (+    ( +      ( deep isRngRelaxError+        <+>+        ( mkRelaxError "" $< +          ( getRngAttrName+            >>>+            arr (\ n -> ( "Both attribute-pattern occuring in an " ++ +			  show n ++ " belong to the same name-class"+			)+		)+          )+        )+      )    +      `when` +      ( (isRngGroup `orElse` isRngInterleave)+        >>>+        ( getChildren+          &&& +          ( firstChild+            >>> +            listA ( occur "attribute" (single getChildren)+                    >>> +                    fromLA createNameClass+                  )+          ) +          &&&+          ( lastChild+            >>> +            listA ( occur "attribute" (single getChildren)+                    >>> +                    fromLA createNameClass+                  )+          )+        ) +        >>> checkPattern+      )           +    )     +    >>>+    (  +      ( deep isRngRelaxError+        <+>+        ( mkRelaxError ""+	  ( "An attribute that has an anyName or nsName descendant element " +++            "must have a oneOrMore ancestor element"+	  )+	)+      )+      `when`+      (isRngElement >>> checkInfiniteAttribute)+    )+    >>>+    ( ( deep isRngRelaxError+        <+>+        ( mkRelaxError ""+	  ( "Both element-pattern occuring in an interleave " +++            "belong to the same name-class"+	  )+        )+      )+      `when` +      ( isRngInterleave+        >>> +        ( getChildren+          &&&+          (firstChild >>> listA (occur "ref" this >>> getRngAttrName)) +          &&&+          (lastChild  >>> listA (occur "ref" this >>> getRngAttrName))+        )+        >>>+        checkNames+      )+    )+    >>>     +    ( ( deep isRngRelaxError+        <+> +        ( mkRelaxError "" "A text pattern must not occur in both children of an interleave" )+      )+      `when` +      (isRngInterleave >>> checkText)+    )+  )+  where+  checkInfiniteAttribute :: IOSArrow XmlTree XmlTree+  checkInfiniteAttribute+    = getChildren+      >>>+      choiceA+      [ isRngOneOrMore :-> none+      , ( isRngAttribute+          >>>+          deep (isRngAnyName `orElse` isRngNsName)+        ) :-> this+      , this :-> checkInfiniteAttribute+      ]++  checkNames :: IOSArrow (XmlTree, ([String], [String])) XmlTree+  checkNames = (arr fst)+               &&&+               (arr (\(_, (a, _)) -> getNameClasses nc a)) +               &&&+               (arr (\(_, (_, b)) -> getNameClasses nc b))+               >>>+               checkPattern+    where+    getNameClasses :: [(String, NameClass)] -> [String] -> [NameClass]+    getNameClasses nc' l = map (\x -> fromJust $ lookup x nc') l+    +  checkText :: IOSArrow XmlTree XmlTree+  checkText+      = ( firstChild >>> occur "text" this )+        `guards` +        ( lastChild  >>> occur "text" this )+       +-- ------------------------------------------------------------+++overlap		:: NameClass -> NameClass -> Bool+overlap nc1 nc2+    = any (bothContain nc1 nc2) (representatives nc1 ++ representatives nc2)++bothContain	:: NameClass -> NameClass -> QName -> Bool+bothContain nc1 nc2 qn+    = contains nc1 qn && contains nc2 qn++illegalLocalName	:: LocalName+illegalLocalName	= ""++illegalUri		:: Uri+illegalUri		= "\x1"++representatives		:: NameClass -> [QName]+representatives AnyName+    = [mkQName "" illegalLocalName illegalUri]++representatives (AnyNameExcept nc)+    = (mkQName "" illegalLocalName illegalUri) : (representatives nc)++representatives (NsName ns)+    = [mkQName "" illegalLocalName ns]++representatives (NsNameExcept ns nc)+    = (mkQName "" illegalLocalName ns) : (representatives nc)++representatives (Name ns ln)+    = [mkQName "" ln ns]++representatives (NameClassChoice nc1 nc2)+    = (representatives nc1) ++ (representatives nc2)++representatives _+    = []++-- -------------------------------------------------------------------------------------------------------            +resetStates :: IOSArrow XmlTree XmlTree+resetStates+    = ( perform (constA $ setParamInt "define_id" 0)+	>>>+	perform (constA [] >>> setParamList "elementTable" )+	>>>+	perform (constA $ setParamInt a_numberOfErrors 0)+      )+++getAllDeepDefines :: IOSArrow XmlTree Env+getAllDeepDefines+    = listA $ deep isRngDefine+      >>> +      ( getRngAttrName &&& this )+++-- | Return all reachable defines from the start pattern++getRefsFromStartPattern :: IOSArrow XmlTree [String]+getRefsFromStartPattern+  = listA+    ( getChildren+      >>>+      isRngGrammar+      >>>+      getChildren+      >>>+      isRngStart+      >>> +      deep isRngRef+      >>>+      getRngAttrName+    )++removeUnreachableDefines :: Env -> [String] -> [String] -> IOSArrow XmlTree XmlTree+removeUnreachableDefines allDefs processedDefs reachableDefs+    = ifP (const $ unprocessedDefs /= [])+      ( removeUnreachableDefines allDefs (nextTreeName : processedDefs) $< newReachableDefs )+      ( processChildren $ -- root node+        processChildren $ -- first grammar+        ( none +          `when`+          ( isRngDefine+            >>>+            getRngAttrName+            >>> +            isA (\n -> not $ elem n reachableDefs)+          )+	)+      )+    where+    unprocessedDefs :: [String]+    unprocessedDefs+	= reachableDefs \\ processedDefs++    newReachableDefs :: IOSArrow n [String]+    newReachableDefs+	= constA getTree+          >>> +          listA ( deep isRngRef+                  >>>+                  getRngAttrName+                )+          >>>+          arr (noDoubles . (reachableDefs ++))++    getTree :: XmlTree+    getTree+	= fromJust $ lookup nextTreeName allDefs++    nextTreeName :: String+    nextTreeName+	= head unprocessedDefs+++-- -------------------------------------------------------------------------------------------------------    +    ++checkElemName :: [String] -> IOSArrow XmlTree XmlTree+checkElemName l+    = ( isElem >>> getLocalPart >>> isA (\s -> elem s l) )+      `guards`+      this++wrapPattern2Two :: (ArrowXml a) => String -> a XmlTree XmlTree+wrapPattern2Two name +  = choiceA+    [ noOfChildren (> 2)+      :-> ( replaceChildren ( (mkRngElement name none +                               (getChildren >>. take 2)+                              ) +                              <+> +                              (getChildren >>. drop 2)+                            )+            >>>+            wrapPattern2Two name+          )+    , noOfChildren (== 1)+      :-> getChildren+    , this+      :-> this+    ]++mkRelaxError :: String -> String -> IOSArrow n XmlTree+mkRelaxError changesStr errStr+  = perform (getAndSetCounter a_numberOfErrors)+    >>>+    mkRngRelaxError none none+    >>>+    addAttr "desc" errStr+    >>>+    ( addAttr "changes" changesStr+      `whenP`+      (const $ changesStr /= "")+    )++collectErrors :: IOSArrow XmlTree XmlTree+collectErrors+  = none+    `when`+    ( stopAfterFirstError+      >>>+      getParamInt 0 a_numberOfErrors >>> isA (>0)+    )+  where+  stopAfterFirstError = getParamString a_do_not_collect_errors+                        >>>+                        isA (== "1")+ ++-- | Returns the list of simplification errors or 'none'+getErrors :: IOSArrow XmlTree XmlTree+getErrors = (getParamInt 0 a_numberOfErrors >>> isA (>0))+            `guards`+            (root [] [multi isRngRelaxError])++setChangesAttr :: String -> IOSArrow XmlTree XmlTree+setChangesAttr str+  = ifA (hasAttr a_relaxSimplificationChanges)+      ( processAttrl $+          changeAttrValue (++ (", " ++ str))+          `when`+          (hasRngName a_relaxSimplificationChanges)+      )+      (mkAttr (mkName a_relaxSimplificationChanges) (txt str))+++getChangesAttr :: IOSArrow XmlTree String+getChangesAttr+  = getAttrValue a_relaxSimplificationChanges +    &&& +    getParamString a_output_changes+    >>>+    ifP (\(changes, param) -> changes /= "" && param == "1")+      (arr2 $ \l _ -> " (" ++ l ++ ")")+      (constA "")+      ++getAndSetCounter :: String -> IOSArrow b String+getAndSetCounter name   +  = genNewId $< getParamInt 0 name+  where+  genNewId :: Int -> IOSArrow b String+  genNewId i = setParamInt name (i+1) >>> constA (show i)++     +-- -------------------------------------------------------------------------------------------------------            ++-- | Creates the simple form of a Relax NG schema+-- (see also: 'relaxOptions')++createSimpleForm :: Attributes -> Bool -> Bool -> Bool -> IOSArrow XmlTree XmlTree+createSimpleForm remainingOptions checkRestrictions validateExternalRef validateInclude+    = traceMsg 2 ("createSimpleForm: " ++ show (remainingOptions, checkRestrictions,validateExternalRef, validateInclude))+      >>>+      ( if checkRestrictions+	then createSimpleWithRest+	else createSimpleWithoutRest+      )+    where++    createSimpleWithRest :: IOSArrow XmlTree XmlTree+    createSimpleWithRest+	= seqA $ concat [ simplificationPart1+			, return $ traceDoc "relax NG: simplificationPart1 done"+			, restrictionsPart1+			, return $ traceDoc "relax NG: restrictionsPart1 done"+			, simplificationPart2+			, return $ traceDoc "relax NG simplificationPart2 done"+			, restrictionsPart2+			, return $ traceDoc "relax NG: restrictionsPart2 done"+			, finalCleanUp+			, return $ traceDoc "relax NG: finalCleanUp done"+			]++    createSimpleWithoutRest :: IOSArrow XmlTree XmlTree+    createSimpleWithoutRest+	= seqA $ concat [ simplificationPart1+			, simplificationPart2+			, finalCleanUp+			]+    simplificationPart1 :: [IOSArrow XmlTree XmlTree]+    simplificationPart1+	= [ propagateNamespaces+	  , simplificationStep1+	  , simplificationStep2 remainingOptions validateExternalRef validateInclude [] []+	  , simplificationStep3+	  , simplificationStep4+	  ]++    simplificationPart2 :: [IOSArrow XmlTree XmlTree]+    simplificationPart2+	= [ simplificationStep5+	  , simplificationStep6+	  , simplificationStep7+	  , simplificationStep8+	  ]++    restrictionsPart1 :: [IOSArrow XmlTree XmlTree]+    restrictionsPart1+	= [ restrictionsStep1 ]++    restrictionsPart2 :: [IOSArrow XmlTree XmlTree]+    restrictionsPart2+	= [ restrictionsStep2+	  , restrictionsStep3+	  , restrictionsStep4                    +	  ]++    finalCleanUp :: [IOSArrow XmlTree XmlTree]                    +    finalCleanUp+	= [ cleanUp+	  , resetStates+	  ]++    cleanUp :: IOSArrow XmlTree XmlTree+    cleanUp = processTopDown $ +              removeAttr a_relaxSimplificationChanges+	      >>>+              removeAttr defineOrigName++-- -------------------------------------------------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/RelaxNG/Unicode/Blocks.hs view
@@ -0,0 +1,229 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.RelaxNG.Unicode.Blocks+   Copyright  : Copyright (C) 2005 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable+   Version    : $Id$++   Unicode Code Blocks++   don't edit this module+   it's generated from 'http:\/\/www.unicode.org\/Public\/UNIDATA\/Blocks.txt'+-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.RelaxNG.Unicode.Blocks+  ( codeBlocks )+where++-- ------------------------------------------------------------++codeBlocks        :: [(String, (Char, Char))]+codeBlocks =+    [ ( "BasicLatin",	( '\x0000', '\x007F') )+    , ( "Latin-1Supplement",	( '\x0080', '\x00FF') )+    , ( "LatinExtended-A",	( '\x0100', '\x017F') )+    , ( "LatinExtended-B",	( '\x0180', '\x024F') )+    , ( "IPAExtensions",	( '\x0250', '\x02AF') )+    , ( "SpacingModifierLetters",	( '\x02B0', '\x02FF') )+    , ( "CombiningDiacriticalMarks",	( '\x0300', '\x036F') )+    , ( "GreekandCoptic",	( '\x0370', '\x03FF') )+    , ( "Cyrillic",	( '\x0400', '\x04FF') )+    , ( "CyrillicSupplement",	( '\x0500', '\x052F') )+    , ( "Armenian",	( '\x0530', '\x058F') )+    , ( "Hebrew",	( '\x0590', '\x05FF') )+    , ( "Arabic",	( '\x0600', '\x06FF') )+    , ( "Syriac",	( '\x0700', '\x074F') )+    , ( "ArabicSupplement",	( '\x0750', '\x077F') )+    , ( "Thaana",	( '\x0780', '\x07BF') )+    , ( "NKo",	( '\x07C0', '\x07FF') )+    , ( "Samaritan",	( '\x0800', '\x083F') )+    , ( "Devanagari",	( '\x0900', '\x097F') )+    , ( "Bengali",	( '\x0980', '\x09FF') )+    , ( "Gurmukhi",	( '\x0A00', '\x0A7F') )+    , ( "Gujarati",	( '\x0A80', '\x0AFF') )+    , ( "Oriya",	( '\x0B00', '\x0B7F') )+    , ( "Tamil",	( '\x0B80', '\x0BFF') )+    , ( "Telugu",	( '\x0C00', '\x0C7F') )+    , ( "Kannada",	( '\x0C80', '\x0CFF') )+    , ( "Malayalam",	( '\x0D00', '\x0D7F') )+    , ( "Sinhala",	( '\x0D80', '\x0DFF') )+    , ( "Thai",	( '\x0E00', '\x0E7F') )+    , ( "Lao",	( '\x0E80', '\x0EFF') )+    , ( "Tibetan",	( '\x0F00', '\x0FFF') )+    , ( "Myanmar",	( '\x1000', '\x109F') )+    , ( "Georgian",	( '\x10A0', '\x10FF') )+    , ( "HangulJamo",	( '\x1100', '\x11FF') )+    , ( "Ethiopic",	( '\x1200', '\x137F') )+    , ( "EthiopicSupplement",	( '\x1380', '\x139F') )+    , ( "Cherokee",	( '\x13A0', '\x13FF') )+    , ( "UnifiedCanadianAboriginalSyllabics",	( '\x1400', '\x167F') )+    , ( "Ogham",	( '\x1680', '\x169F') )+    , ( "Runic",	( '\x16A0', '\x16FF') )+    , ( "Tagalog",	( '\x1700', '\x171F') )+    , ( "Hanunoo",	( '\x1720', '\x173F') )+    , ( "Buhid",	( '\x1740', '\x175F') )+    , ( "Tagbanwa",	( '\x1760', '\x177F') )+    , ( "Khmer",	( '\x1780', '\x17FF') )+    , ( "Mongolian",	( '\x1800', '\x18AF') )+    , ( "UnifiedCanadianAboriginalSyllabicsExtended",	( '\x18B0', '\x18FF') )+    , ( "Limbu",	( '\x1900', '\x194F') )+    , ( "TaiLe",	( '\x1950', '\x197F') )+    , ( "NewTaiLue",	( '\x1980', '\x19DF') )+    , ( "KhmerSymbols",	( '\x19E0', '\x19FF') )+    , ( "Buginese",	( '\x1A00', '\x1A1F') )+    , ( "TaiTham",	( '\x1A20', '\x1AAF') )+    , ( "Balinese",	( '\x1B00', '\x1B7F') )+    , ( "Sundanese",	( '\x1B80', '\x1BBF') )+    , ( "Lepcha",	( '\x1C00', '\x1C4F') )+    , ( "OlChiki",	( '\x1C50', '\x1C7F') )+    , ( "VedicExtensions",	( '\x1CD0', '\x1CFF') )+    , ( "PhoneticExtensions",	( '\x1D00', '\x1D7F') )+    , ( "PhoneticExtensionsSupplement",	( '\x1D80', '\x1DBF') )+    , ( "CombiningDiacriticalMarksSupplement",	( '\x1DC0', '\x1DFF') )+    , ( "LatinExtendedAdditional",	( '\x1E00', '\x1EFF') )+    , ( "GreekExtended",	( '\x1F00', '\x1FFF') )+    , ( "GeneralPunctuation",	( '\x2000', '\x206F') )+    , ( "SuperscriptsandSubscripts",	( '\x2070', '\x209F') )+    , ( "CurrencySymbols",	( '\x20A0', '\x20CF') )+    , ( "CombiningDiacriticalMarksforSymbols",	( '\x20D0', '\x20FF') )+    , ( "LetterlikeSymbols",	( '\x2100', '\x214F') )+    , ( "NumberForms",	( '\x2150', '\x218F') )+    , ( "Arrows",	( '\x2190', '\x21FF') )+    , ( "MathematicalOperators",	( '\x2200', '\x22FF') )+    , ( "MiscellaneousTechnical",	( '\x2300', '\x23FF') )+    , ( "ControlPictures",	( '\x2400', '\x243F') )+    , ( "OpticalCharacterRecognition",	( '\x2440', '\x245F') )+    , ( "EnclosedAlphanumerics",	( '\x2460', '\x24FF') )+    , ( "BoxDrawing",	( '\x2500', '\x257F') )+    , ( "BlockElements",	( '\x2580', '\x259F') )+    , ( "GeometricShapes",	( '\x25A0', '\x25FF') )+    , ( "MiscellaneousSymbols",	( '\x2600', '\x26FF') )+    , ( "Dingbats",	( '\x2700', '\x27BF') )+    , ( "MiscellaneousMathematicalSymbols-A",	( '\x27C0', '\x27EF') )+    , ( "SupplementalArrows-A",	( '\x27F0', '\x27FF') )+    , ( "BraillePatterns",	( '\x2800', '\x28FF') )+    , ( "SupplementalArrows-B",	( '\x2900', '\x297F') )+    , ( "MiscellaneousMathematicalSymbols-B",	( '\x2980', '\x29FF') )+    , ( "SupplementalMathematicalOperators",	( '\x2A00', '\x2AFF') )+    , ( "MiscellaneousSymbolsandArrows",	( '\x2B00', '\x2BFF') )+    , ( "Glagolitic",	( '\x2C00', '\x2C5F') )+    , ( "LatinExtended-C",	( '\x2C60', '\x2C7F') )+    , ( "Coptic",	( '\x2C80', '\x2CFF') )+    , ( "GeorgianSupplement",	( '\x2D00', '\x2D2F') )+    , ( "Tifinagh",	( '\x2D30', '\x2D7F') )+    , ( "EthiopicExtended",	( '\x2D80', '\x2DDF') )+    , ( "CyrillicExtended-A",	( '\x2DE0', '\x2DFF') )+    , ( "SupplementalPunctuation",	( '\x2E00', '\x2E7F') )+    , ( "CJKRadicalsSupplement",	( '\x2E80', '\x2EFF') )+    , ( "KangxiRadicals",	( '\x2F00', '\x2FDF') )+    , ( "IdeographicDescriptionCharacters",	( '\x2FF0', '\x2FFF') )+    , ( "CJKSymbolsandPunctuation",	( '\x3000', '\x303F') )+    , ( "Hiragana",	( '\x3040', '\x309F') )+    , ( "Katakana",	( '\x30A0', '\x30FF') )+    , ( "Bopomofo",	( '\x3100', '\x312F') )+    , ( "HangulCompatibilityJamo",	( '\x3130', '\x318F') )+    , ( "Kanbun",	( '\x3190', '\x319F') )+    , ( "BopomofoExtended",	( '\x31A0', '\x31BF') )+    , ( "CJKStrokes",	( '\x31C0', '\x31EF') )+    , ( "KatakanaPhoneticExtensions",	( '\x31F0', '\x31FF') )+    , ( "EnclosedCJKLettersandMonths",	( '\x3200', '\x32FF') )+    , ( "CJKCompatibility",	( '\x3300', '\x33FF') )+    , ( "CJKUnifiedIdeographsExtensionA",	( '\x3400', '\x4DBF') )+    , ( "YijingHexagramSymbols",	( '\x4DC0', '\x4DFF') )+    , ( "CJKUnifiedIdeographs",	( '\x4E00', '\x9FFF') )+    , ( "YiSyllables",	( '\xA000', '\xA48F') )+    , ( "YiRadicals",	( '\xA490', '\xA4CF') )+    , ( "Lisu",	( '\xA4D0', '\xA4FF') )+    , ( "Vai",	( '\xA500', '\xA63F') )+    , ( "CyrillicExtended-B",	( '\xA640', '\xA69F') )+    , ( "Bamum",	( '\xA6A0', '\xA6FF') )+    , ( "ModifierToneLetters",	( '\xA700', '\xA71F') )+    , ( "LatinExtended-D",	( '\xA720', '\xA7FF') )+    , ( "SylotiNagri",	( '\xA800', '\xA82F') )+    , ( "CommonIndicNumberForms",	( '\xA830', '\xA83F') )+    , ( "Phags-pa",	( '\xA840', '\xA87F') )+    , ( "Saurashtra",	( '\xA880', '\xA8DF') )+    , ( "DevanagariExtended",	( '\xA8E0', '\xA8FF') )+    , ( "KayahLi",	( '\xA900', '\xA92F') )+    , ( "Rejang",	( '\xA930', '\xA95F') )+    , ( "HangulJamoExtended-A",	( '\xA960', '\xA97F') )+    , ( "Javanese",	( '\xA980', '\xA9DF') )+    , ( "Cham",	( '\xAA00', '\xAA5F') )+    , ( "MyanmarExtended-A",	( '\xAA60', '\xAA7F') )+    , ( "TaiViet",	( '\xAA80', '\xAADF') )+    , ( "MeeteiMayek",	( '\xABC0', '\xABFF') )+    , ( "HangulSyllables",	( '\xAC00', '\xD7AF') )+    , ( "HangulJamoExtended-B",	( '\xD7B0', '\xD7FF') )+    , ( "HighSurrogates",	( '\xD800', '\xDB7F') )+    , ( "HighPrivateUseSurrogates",	( '\xDB80', '\xDBFF') )+    , ( "LowSurrogates",	( '\xDC00', '\xDFFF') )+    , ( "PrivateUseArea",	( '\xE000', '\xF8FF') )+    , ( "CJKCompatibilityIdeographs",	( '\xF900', '\xFAFF') )+    , ( "AlphabeticPresentationForms",	( '\xFB00', '\xFB4F') )+    , ( "ArabicPresentationForms-A",	( '\xFB50', '\xFDFF') )+    , ( "VariationSelectors",	( '\xFE00', '\xFE0F') )+    , ( "VerticalForms",	( '\xFE10', '\xFE1F') )+    , ( "CombiningHalfMarks",	( '\xFE20', '\xFE2F') )+    , ( "CJKCompatibilityForms",	( '\xFE30', '\xFE4F') )+    , ( "SmallFormVariants",	( '\xFE50', '\xFE6F') )+    , ( "ArabicPresentationForms-B",	( '\xFE70', '\xFEFF') )+    , ( "HalfwidthandFullwidthForms",	( '\xFF00', '\xFFEF') )+    , ( "Specials",	( '\xFFF0', '\xFFFF') )+    , ( "LinearBSyllabary",	( '\x10000', '\x1007F') )+    , ( "LinearBIdeograms",	( '\x10080', '\x100FF') )+    , ( "AegeanNumbers",	( '\x10100', '\x1013F') )+    , ( "AncientGreekNumbers",	( '\x10140', '\x1018F') )+    , ( "AncientSymbols",	( '\x10190', '\x101CF') )+    , ( "PhaistosDisc",	( '\x101D0', '\x101FF') )+    , ( "Lycian",	( '\x10280', '\x1029F') )+    , ( "Carian",	( '\x102A0', '\x102DF') )+    , ( "OldItalic",	( '\x10300', '\x1032F') )+    , ( "Gothic",	( '\x10330', '\x1034F') )+    , ( "Ugaritic",	( '\x10380', '\x1039F') )+    , ( "OldPersian",	( '\x103A0', '\x103DF') )+    , ( "Deseret",	( '\x10400', '\x1044F') )+    , ( "Shavian",	( '\x10450', '\x1047F') )+    , ( "Osmanya",	( '\x10480', '\x104AF') )+    , ( "CypriotSyllabary",	( '\x10800', '\x1083F') )+    , ( "ImperialAramaic",	( '\x10840', '\x1085F') )+    , ( "Phoenician",	( '\x10900', '\x1091F') )+    , ( "Lydian",	( '\x10920', '\x1093F') )+    , ( "Kharoshthi",	( '\x10A00', '\x10A5F') )+    , ( "OldSouthArabian",	( '\x10A60', '\x10A7F') )+    , ( "Avestan",	( '\x10B00', '\x10B3F') )+    , ( "InscriptionalParthian",	( '\x10B40', '\x10B5F') )+    , ( "InscriptionalPahlavi",	( '\x10B60', '\x10B7F') )+    , ( "OldTurkic",	( '\x10C00', '\x10C4F') )+    , ( "RumiNumeralSymbols",	( '\x10E60', '\x10E7F') )+    , ( "Kaithi",	( '\x11080', '\x110CF') )+    , ( "Cuneiform",	( '\x12000', '\x123FF') )+    , ( "CuneiformNumbersandPunctuation",	( '\x12400', '\x1247F') )+    , ( "EgyptianHieroglyphs",	( '\x13000', '\x1342F') )+    , ( "ByzantineMusicalSymbols",	( '\x1D000', '\x1D0FF') )+    , ( "MusicalSymbols",	( '\x1D100', '\x1D1FF') )+    , ( "AncientGreekMusicalNotation",	( '\x1D200', '\x1D24F') )+    , ( "TaiXuanJingSymbols",	( '\x1D300', '\x1D35F') )+    , ( "CountingRodNumerals",	( '\x1D360', '\x1D37F') )+    , ( "MathematicalAlphanumericSymbols",	( '\x1D400', '\x1D7FF') )+    , ( "MahjongTiles",	( '\x1F000', '\x1F02F') )+    , ( "DominoTiles",	( '\x1F030', '\x1F09F') )+    , ( "EnclosedAlphanumericSupplement",	( '\x1F100', '\x1F1FF') )+    , ( "EnclosedIdeographicSupplement",	( '\x1F200', '\x1F2FF') )+    , ( "CJKUnifiedIdeographsExtensionB",	( '\x20000', '\x2A6DF') )+    , ( "CJKUnifiedIdeographsExtensionC",	( '\x2A700', '\x2B73F') )+    , ( "CJKCompatibilityIdeographsSupplement",	( '\x2F800', '\x2FA1F') )+    , ( "Tags",	( '\xE0000', '\xE007F') )+    , ( "VariationSelectorsSupplement",	( '\xE0100', '\xE01EF') )+    , ( "SupplementaryPrivateUseArea-A",	( '\xF0000', '\xFFFFF') )+    , ( "SupplementaryPrivateUseArea-B",	( '\x100000', '\x10FFFF') )+    ]++-- ------------------------------------------------------------+
+ src/Yuuko/Text/XML/HXT/RelaxNG/Unicode/CharProps.hs view
@@ -0,0 +1,3945 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.RelaxNG.Unicode.CharProps+   Copyright  : Copyright (C) 2005 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable+   Version    : $Id$++   Unicode character properties++   don't edit this module+   it's generated from 'http:\/\/www.unicode.org\/Public\/UNIDATA\/UnicodeData.txt'++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.RelaxNG.Unicode.CharProps+  ( isUnicodeC+  , isUnicodeCc+  , isUnicodeCf+  , isUnicodeCo+  , isUnicodeCs+  , isUnicodeL+  , isUnicodeLl+  , isUnicodeLm+  , isUnicodeLo+  , isUnicodeLt+  , isUnicodeLu+  , isUnicodeM+  , isUnicodeMc+  , isUnicodeMe+  , isUnicodeMn+  , isUnicodeN+  , isUnicodeNd+  , isUnicodeNl+  , isUnicodeNo+  , isUnicodeP+  , isUnicodePc+  , isUnicodePd+  , isUnicodePe+  , isUnicodePf+  , isUnicodePi+  , isUnicodePo+  , isUnicodePs+  , isUnicodeS+  , isUnicodeSc+  , isUnicodeSk+  , isUnicodeSm+  , isUnicodeSo+  , isUnicodeZ+  , isUnicodeZl+  , isUnicodeZp+  , isUnicodeZs+  )+where++-- ------------------------------------------------------------++isInList        :: Char -> [(Char, Char)] -> Bool+isInList i      =+   foldr (\(lb, ub) b -> i >= lb && (i <= ub || b)) False++-- ------------------------------------------------------------++isUnicodeC	:: Char -> Bool+isUnicodeC c+  = isInList c+    [ ('\NUL','\US')+    , ('\DEL','\159')+    , ('\173','\173')+    , ('\1536','\1539')+    , ('\1757','\1757')+    , ('\1807','\1807')+    , ('\6068','\6069')+    , ('\8203','\8207')+    , ('\8234','\8238')+    , ('\8288','\8292')+    , ('\8298','\8303')+    , ('\55296','\55296')+    , ('\56191','\56192')+    , ('\56319','\56320')+    , ('\57343','\57344')+    , ('\63743','\63743')+    , ('\65279','\65279')+    , ('\65529','\65531')+    , ('\69821','\69821')+    , ('\119155','\119162')+    , ('\917505','\917505')+    , ('\917536','\917631')+    , ('\983040','\983040')+    , ('\1048573','\1048573')+    , ('\1048576','\1048576')+    , ('\1114109','\1114109')+    ]++-- ------------------------------------------------------------++isUnicodeCc	:: Char -> Bool+isUnicodeCc c+  = isInList c+    [ ('\NUL','\US')+    , ('\DEL','\159')+    ]++-- ------------------------------------------------------------++isUnicodeCf	:: Char -> Bool+isUnicodeCf c+  = isInList c+    [ ('\173','\173')+    , ('\1536','\1539')+    , ('\1757','\1757')+    , ('\1807','\1807')+    , ('\6068','\6069')+    , ('\8203','\8207')+    , ('\8234','\8238')+    , ('\8288','\8292')+    , ('\8298','\8303')+    , ('\65279','\65279')+    , ('\65529','\65531')+    , ('\69821','\69821')+    , ('\119155','\119162')+    , ('\917505','\917505')+    , ('\917536','\917631')+    ]++-- ------------------------------------------------------------++isUnicodeCo	:: Char -> Bool+isUnicodeCo c+  = isInList c+    [ ('\57344','\57344')+    , ('\63743','\63743')+    , ('\983040','\983040')+    , ('\1048573','\1048573')+    , ('\1048576','\1048576')+    , ('\1114109','\1114109')+    ]++-- ------------------------------------------------------------++isUnicodeCs	:: Char -> Bool+isUnicodeCs c+  = isInList c+    [ ('\55296','\55296')+    , ('\56191','\56192')+    , ('\56319','\56320')+    , ('\57343','\57343')+    ]++-- ------------------------------------------------------------++isUnicodeL	:: Char -> Bool+isUnicodeL c+  = isInList c+    [ ('A','Z')+    , ('a','z')+    , ('\170','\170')+    , ('\181','\181')+    , ('\186','\186')+    , ('\192','\214')+    , ('\216','\246')+    , ('\248','\705')+    , ('\710','\721')+    , ('\736','\740')+    , ('\748','\748')+    , ('\750','\750')+    , ('\880','\884')+    , ('\886','\887')+    , ('\890','\893')+    , ('\902','\902')+    , ('\904','\906')+    , ('\908','\908')+    , ('\910','\929')+    , ('\931','\1013')+    , ('\1015','\1153')+    , ('\1162','\1317')+    , ('\1329','\1366')+    , ('\1369','\1369')+    , ('\1377','\1415')+    , ('\1488','\1514')+    , ('\1520','\1522')+    , ('\1569','\1610')+    , ('\1646','\1647')+    , ('\1649','\1747')+    , ('\1749','\1749')+    , ('\1765','\1766')+    , ('\1774','\1775')+    , ('\1786','\1788')+    , ('\1791','\1791')+    , ('\1808','\1808')+    , ('\1810','\1839')+    , ('\1869','\1957')+    , ('\1969','\1969')+    , ('\1994','\2026')+    , ('\2036','\2037')+    , ('\2042','\2042')+    , ('\2048','\2069')+    , ('\2074','\2074')+    , ('\2084','\2084')+    , ('\2088','\2088')+    , ('\2308','\2361')+    , ('\2365','\2365')+    , ('\2384','\2384')+    , ('\2392','\2401')+    , ('\2417','\2418')+    , ('\2425','\2431')+    , ('\2437','\2444')+    , ('\2447','\2448')+    , ('\2451','\2472')+    , ('\2474','\2480')+    , ('\2482','\2482')+    , ('\2486','\2489')+    , ('\2493','\2493')+    , ('\2510','\2510')+    , ('\2524','\2525')+    , ('\2527','\2529')+    , ('\2544','\2545')+    , ('\2565','\2570')+    , ('\2575','\2576')+    , ('\2579','\2600')+    , ('\2602','\2608')+    , ('\2610','\2611')+    , ('\2613','\2614')+    , ('\2616','\2617')+    , ('\2649','\2652')+    , ('\2654','\2654')+    , ('\2674','\2676')+    , ('\2693','\2701')+    , ('\2703','\2705')+    , ('\2707','\2728')+    , ('\2730','\2736')+    , ('\2738','\2739')+    , ('\2741','\2745')+    , ('\2749','\2749')+    , ('\2768','\2768')+    , ('\2784','\2785')+    , ('\2821','\2828')+    , ('\2831','\2832')+    , ('\2835','\2856')+    , ('\2858','\2864')+    , ('\2866','\2867')+    , ('\2869','\2873')+    , ('\2877','\2877')+    , ('\2908','\2909')+    , ('\2911','\2913')+    , ('\2929','\2929')+    , ('\2947','\2947')+    , ('\2949','\2954')+    , ('\2958','\2960')+    , ('\2962','\2965')+    , ('\2969','\2970')+    , ('\2972','\2972')+    , ('\2974','\2975')+    , ('\2979','\2980')+    , ('\2984','\2986')+    , ('\2990','\3001')+    , ('\3024','\3024')+    , ('\3077','\3084')+    , ('\3086','\3088')+    , ('\3090','\3112')+    , ('\3114','\3123')+    , ('\3125','\3129')+    , ('\3133','\3133')+    , ('\3160','\3161')+    , ('\3168','\3169')+    , ('\3205','\3212')+    , ('\3214','\3216')+    , ('\3218','\3240')+    , ('\3242','\3251')+    , ('\3253','\3257')+    , ('\3261','\3261')+    , ('\3294','\3294')+    , ('\3296','\3297')+    , ('\3333','\3340')+    , ('\3342','\3344')+    , ('\3346','\3368')+    , ('\3370','\3385')+    , ('\3389','\3389')+    , ('\3424','\3425')+    , ('\3450','\3455')+    , ('\3461','\3478')+    , ('\3482','\3505')+    , ('\3507','\3515')+    , ('\3517','\3517')+    , ('\3520','\3526')+    , ('\3585','\3632')+    , ('\3634','\3635')+    , ('\3648','\3654')+    , ('\3713','\3714')+    , ('\3716','\3716')+    , ('\3719','\3720')+    , ('\3722','\3722')+    , ('\3725','\3725')+    , ('\3732','\3735')+    , ('\3737','\3743')+    , ('\3745','\3747')+    , ('\3749','\3749')+    , ('\3751','\3751')+    , ('\3754','\3755')+    , ('\3757','\3760')+    , ('\3762','\3763')+    , ('\3773','\3773')+    , ('\3776','\3780')+    , ('\3782','\3782')+    , ('\3804','\3805')+    , ('\3840','\3840')+    , ('\3904','\3911')+    , ('\3913','\3948')+    , ('\3976','\3979')+    , ('\4096','\4138')+    , ('\4159','\4159')+    , ('\4176','\4181')+    , ('\4186','\4189')+    , ('\4193','\4193')+    , ('\4197','\4198')+    , ('\4206','\4208')+    , ('\4213','\4225')+    , ('\4238','\4238')+    , ('\4256','\4293')+    , ('\4304','\4346')+    , ('\4348','\4348')+    , ('\4352','\4680')+    , ('\4682','\4685')+    , ('\4688','\4694')+    , ('\4696','\4696')+    , ('\4698','\4701')+    , ('\4704','\4744')+    , ('\4746','\4749')+    , ('\4752','\4784')+    , ('\4786','\4789')+    , ('\4792','\4798')+    , ('\4800','\4800')+    , ('\4802','\4805')+    , ('\4808','\4822')+    , ('\4824','\4880')+    , ('\4882','\4885')+    , ('\4888','\4954')+    , ('\4992','\5007')+    , ('\5024','\5108')+    , ('\5121','\5740')+    , ('\5743','\5759')+    , ('\5761','\5786')+    , ('\5792','\5866')+    , ('\5888','\5900')+    , ('\5902','\5905')+    , ('\5920','\5937')+    , ('\5952','\5969')+    , ('\5984','\5996')+    , ('\5998','\6000')+    , ('\6016','\6067')+    , ('\6103','\6103')+    , ('\6108','\6108')+    , ('\6176','\6263')+    , ('\6272','\6312')+    , ('\6314','\6314')+    , ('\6320','\6389')+    , ('\6400','\6428')+    , ('\6480','\6509')+    , ('\6512','\6516')+    , ('\6528','\6571')+    , ('\6593','\6599')+    , ('\6656','\6678')+    , ('\6688','\6740')+    , ('\6823','\6823')+    , ('\6917','\6963')+    , ('\6981','\6987')+    , ('\7043','\7072')+    , ('\7086','\7087')+    , ('\7168','\7203')+    , ('\7245','\7247')+    , ('\7258','\7293')+    , ('\7401','\7404')+    , ('\7406','\7409')+    , ('\7424','\7615')+    , ('\7680','\7957')+    , ('\7960','\7965')+    , ('\7968','\8005')+    , ('\8008','\8013')+    , ('\8016','\8023')+    , ('\8025','\8025')+    , ('\8027','\8027')+    , ('\8029','\8029')+    , ('\8031','\8061')+    , ('\8064','\8116')+    , ('\8118','\8124')+    , ('\8126','\8126')+    , ('\8130','\8132')+    , ('\8134','\8140')+    , ('\8144','\8147')+    , ('\8150','\8155')+    , ('\8160','\8172')+    , ('\8178','\8180')+    , ('\8182','\8188')+    , ('\8305','\8305')+    , ('\8319','\8319')+    , ('\8336','\8340')+    , ('\8450','\8450')+    , ('\8455','\8455')+    , ('\8458','\8467')+    , ('\8469','\8469')+    , ('\8473','\8477')+    , ('\8484','\8484')+    , ('\8486','\8486')+    , ('\8488','\8488')+    , ('\8490','\8493')+    , ('\8495','\8505')+    , ('\8508','\8511')+    , ('\8517','\8521')+    , ('\8526','\8526')+    , ('\8579','\8580')+    , ('\11264','\11310')+    , ('\11312','\11358')+    , ('\11360','\11492')+    , ('\11499','\11502')+    , ('\11520','\11557')+    , ('\11568','\11621')+    , ('\11631','\11631')+    , ('\11648','\11670')+    , ('\11680','\11686')+    , ('\11688','\11694')+    , ('\11696','\11702')+    , ('\11704','\11710')+    , ('\11712','\11718')+    , ('\11720','\11726')+    , ('\11728','\11734')+    , ('\11736','\11742')+    , ('\11823','\11823')+    , ('\12293','\12294')+    , ('\12337','\12341')+    , ('\12347','\12348')+    , ('\12353','\12438')+    , ('\12445','\12447')+    , ('\12449','\12538')+    , ('\12540','\12543')+    , ('\12549','\12589')+    , ('\12593','\12686')+    , ('\12704','\12727')+    , ('\12784','\12799')+    , ('\13312','\13312')+    , ('\19893','\19893')+    , ('\19968','\19968')+    , ('\40907','\40907')+    , ('\40960','\42124')+    , ('\42192','\42237')+    , ('\42240','\42508')+    , ('\42512','\42527')+    , ('\42538','\42539')+    , ('\42560','\42591')+    , ('\42594','\42606')+    , ('\42623','\42647')+    , ('\42656','\42725')+    , ('\42775','\42783')+    , ('\42786','\42888')+    , ('\42891','\42892')+    , ('\43003','\43009')+    , ('\43011','\43013')+    , ('\43015','\43018')+    , ('\43020','\43042')+    , ('\43072','\43123')+    , ('\43138','\43187')+    , ('\43250','\43255')+    , ('\43259','\43259')+    , ('\43274','\43301')+    , ('\43312','\43334')+    , ('\43360','\43388')+    , ('\43396','\43442')+    , ('\43471','\43471')+    , ('\43520','\43560')+    , ('\43584','\43586')+    , ('\43588','\43595')+    , ('\43616','\43638')+    , ('\43642','\43642')+    , ('\43648','\43695')+    , ('\43697','\43697')+    , ('\43701','\43702')+    , ('\43705','\43709')+    , ('\43712','\43712')+    , ('\43714','\43714')+    , ('\43739','\43741')+    , ('\43968','\44002')+    , ('\44032','\44032')+    , ('\55203','\55203')+    , ('\55216','\55238')+    , ('\55243','\55291')+    , ('\63744','\64045')+    , ('\64048','\64109')+    , ('\64112','\64217')+    , ('\64256','\64262')+    , ('\64275','\64279')+    , ('\64285','\64285')+    , ('\64287','\64296')+    , ('\64298','\64310')+    , ('\64312','\64316')+    , ('\64318','\64318')+    , ('\64320','\64321')+    , ('\64323','\64324')+    , ('\64326','\64433')+    , ('\64467','\64829')+    , ('\64848','\64911')+    , ('\64914','\64967')+    , ('\65008','\65019')+    , ('\65136','\65140')+    , ('\65142','\65276')+    , ('\65313','\65338')+    , ('\65345','\65370')+    , ('\65382','\65470')+    , ('\65474','\65479')+    , ('\65482','\65487')+    , ('\65490','\65495')+    , ('\65498','\65500')+    , ('\65536','\65547')+    , ('\65549','\65574')+    , ('\65576','\65594')+    , ('\65596','\65597')+    , ('\65599','\65613')+    , ('\65616','\65629')+    , ('\65664','\65786')+    , ('\66176','\66204')+    , ('\66208','\66256')+    , ('\66304','\66334')+    , ('\66352','\66368')+    , ('\66370','\66377')+    , ('\66432','\66461')+    , ('\66464','\66499')+    , ('\66504','\66511')+    , ('\66560','\66717')+    , ('\67584','\67589')+    , ('\67592','\67592')+    , ('\67594','\67637')+    , ('\67639','\67640')+    , ('\67644','\67644')+    , ('\67647','\67669')+    , ('\67840','\67861')+    , ('\67872','\67897')+    , ('\68096','\68096')+    , ('\68112','\68115')+    , ('\68117','\68119')+    , ('\68121','\68147')+    , ('\68192','\68220')+    , ('\68352','\68405')+    , ('\68416','\68437')+    , ('\68448','\68466')+    , ('\68608','\68680')+    , ('\69763','\69807')+    , ('\73728','\74606')+    , ('\77824','\78894')+    , ('\119808','\119892')+    , ('\119894','\119964')+    , ('\119966','\119967')+    , ('\119970','\119970')+    , ('\119973','\119974')+    , ('\119977','\119980')+    , ('\119982','\119993')+    , ('\119995','\119995')+    , ('\119997','\120003')+    , ('\120005','\120069')+    , ('\120071','\120074')+    , ('\120077','\120084')+    , ('\120086','\120092')+    , ('\120094','\120121')+    , ('\120123','\120126')+    , ('\120128','\120132')+    , ('\120134','\120134')+    , ('\120138','\120144')+    , ('\120146','\120485')+    , ('\120488','\120512')+    , ('\120514','\120538')+    , ('\120540','\120570')+    , ('\120572','\120596')+    , ('\120598','\120628')+    , ('\120630','\120654')+    , ('\120656','\120686')+    , ('\120688','\120712')+    , ('\120714','\120744')+    , ('\120746','\120770')+    , ('\120772','\120779')+    , ('\131072','\131072')+    , ('\173782','\173782')+    , ('\173824','\173824')+    , ('\177972','\177972')+    , ('\194560','\195101')+    ]++-- ------------------------------------------------------------++isUnicodeLl	:: Char -> Bool+isUnicodeLl c+  = isInList c+    [ ('a','z')+    , ('\170','\170')+    , ('\181','\181')+    , ('\186','\186')+    , ('\223','\246')+    , ('\248','\255')+    , ('\257','\257')+    , ('\259','\259')+    , ('\261','\261')+    , ('\263','\263')+    , ('\265','\265')+    , ('\267','\267')+    , ('\269','\269')+    , ('\271','\271')+    , ('\273','\273')+    , ('\275','\275')+    , ('\277','\277')+    , ('\279','\279')+    , ('\281','\281')+    , ('\283','\283')+    , ('\285','\285')+    , ('\287','\287')+    , ('\289','\289')+    , ('\291','\291')+    , ('\293','\293')+    , ('\295','\295')+    , ('\297','\297')+    , ('\299','\299')+    , ('\301','\301')+    , ('\303','\303')+    , ('\305','\305')+    , ('\307','\307')+    , ('\309','\309')+    , ('\311','\312')+    , ('\314','\314')+    , ('\316','\316')+    , ('\318','\318')+    , ('\320','\320')+    , ('\322','\322')+    , ('\324','\324')+    , ('\326','\326')+    , ('\328','\329')+    , ('\331','\331')+    , ('\333','\333')+    , ('\335','\335')+    , ('\337','\337')+    , ('\339','\339')+    , ('\341','\341')+    , ('\343','\343')+    , ('\345','\345')+    , ('\347','\347')+    , ('\349','\349')+    , ('\351','\351')+    , ('\353','\353')+    , ('\355','\355')+    , ('\357','\357')+    , ('\359','\359')+    , ('\361','\361')+    , ('\363','\363')+    , ('\365','\365')+    , ('\367','\367')+    , ('\369','\369')+    , ('\371','\371')+    , ('\373','\373')+    , ('\375','\375')+    , ('\378','\378')+    , ('\380','\380')+    , ('\382','\384')+    , ('\387','\387')+    , ('\389','\389')+    , ('\392','\392')+    , ('\396','\397')+    , ('\402','\402')+    , ('\405','\405')+    , ('\409','\411')+    , ('\414','\414')+    , ('\417','\417')+    , ('\419','\419')+    , ('\421','\421')+    , ('\424','\424')+    , ('\426','\427')+    , ('\429','\429')+    , ('\432','\432')+    , ('\436','\436')+    , ('\438','\438')+    , ('\441','\442')+    , ('\445','\447')+    , ('\454','\454')+    , ('\457','\457')+    , ('\460','\460')+    , ('\462','\462')+    , ('\464','\464')+    , ('\466','\466')+    , ('\468','\468')+    , ('\470','\470')+    , ('\472','\472')+    , ('\474','\474')+    , ('\476','\477')+    , ('\479','\479')+    , ('\481','\481')+    , ('\483','\483')+    , ('\485','\485')+    , ('\487','\487')+    , ('\489','\489')+    , ('\491','\491')+    , ('\493','\493')+    , ('\495','\496')+    , ('\499','\499')+    , ('\501','\501')+    , ('\505','\505')+    , ('\507','\507')+    , ('\509','\509')+    , ('\511','\511')+    , ('\513','\513')+    , ('\515','\515')+    , ('\517','\517')+    , ('\519','\519')+    , ('\521','\521')+    , ('\523','\523')+    , ('\525','\525')+    , ('\527','\527')+    , ('\529','\529')+    , ('\531','\531')+    , ('\533','\533')+    , ('\535','\535')+    , ('\537','\537')+    , ('\539','\539')+    , ('\541','\541')+    , ('\543','\543')+    , ('\545','\545')+    , ('\547','\547')+    , ('\549','\549')+    , ('\551','\551')+    , ('\553','\553')+    , ('\555','\555')+    , ('\557','\557')+    , ('\559','\559')+    , ('\561','\561')+    , ('\563','\569')+    , ('\572','\572')+    , ('\575','\576')+    , ('\578','\578')+    , ('\583','\583')+    , ('\585','\585')+    , ('\587','\587')+    , ('\589','\589')+    , ('\591','\659')+    , ('\661','\687')+    , ('\881','\881')+    , ('\883','\883')+    , ('\887','\887')+    , ('\891','\893')+    , ('\912','\912')+    , ('\940','\974')+    , ('\976','\977')+    , ('\981','\983')+    , ('\985','\985')+    , ('\987','\987')+    , ('\989','\989')+    , ('\991','\991')+    , ('\993','\993')+    , ('\995','\995')+    , ('\997','\997')+    , ('\999','\999')+    , ('\1001','\1001')+    , ('\1003','\1003')+    , ('\1005','\1005')+    , ('\1007','\1011')+    , ('\1013','\1013')+    , ('\1016','\1016')+    , ('\1019','\1020')+    , ('\1072','\1119')+    , ('\1121','\1121')+    , ('\1123','\1123')+    , ('\1125','\1125')+    , ('\1127','\1127')+    , ('\1129','\1129')+    , ('\1131','\1131')+    , ('\1133','\1133')+    , ('\1135','\1135')+    , ('\1137','\1137')+    , ('\1139','\1139')+    , ('\1141','\1141')+    , ('\1143','\1143')+    , ('\1145','\1145')+    , ('\1147','\1147')+    , ('\1149','\1149')+    , ('\1151','\1151')+    , ('\1153','\1153')+    , ('\1163','\1163')+    , ('\1165','\1165')+    , ('\1167','\1167')+    , ('\1169','\1169')+    , ('\1171','\1171')+    , ('\1173','\1173')+    , ('\1175','\1175')+    , ('\1177','\1177')+    , ('\1179','\1179')+    , ('\1181','\1181')+    , ('\1183','\1183')+    , ('\1185','\1185')+    , ('\1187','\1187')+    , ('\1189','\1189')+    , ('\1191','\1191')+    , ('\1193','\1193')+    , ('\1195','\1195')+    , ('\1197','\1197')+    , ('\1199','\1199')+    , ('\1201','\1201')+    , ('\1203','\1203')+    , ('\1205','\1205')+    , ('\1207','\1207')+    , ('\1209','\1209')+    , ('\1211','\1211')+    , ('\1213','\1213')+    , ('\1215','\1215')+    , ('\1218','\1218')+    , ('\1220','\1220')+    , ('\1222','\1222')+    , ('\1224','\1224')+    , ('\1226','\1226')+    , ('\1228','\1228')+    , ('\1230','\1231')+    , ('\1233','\1233')+    , ('\1235','\1235')+    , ('\1237','\1237')+    , ('\1239','\1239')+    , ('\1241','\1241')+    , ('\1243','\1243')+    , ('\1245','\1245')+    , ('\1247','\1247')+    , ('\1249','\1249')+    , ('\1251','\1251')+    , ('\1253','\1253')+    , ('\1255','\1255')+    , ('\1257','\1257')+    , ('\1259','\1259')+    , ('\1261','\1261')+    , ('\1263','\1263')+    , ('\1265','\1265')+    , ('\1267','\1267')+    , ('\1269','\1269')+    , ('\1271','\1271')+    , ('\1273','\1273')+    , ('\1275','\1275')+    , ('\1277','\1277')+    , ('\1279','\1279')+    , ('\1281','\1281')+    , ('\1283','\1283')+    , ('\1285','\1285')+    , ('\1287','\1287')+    , ('\1289','\1289')+    , ('\1291','\1291')+    , ('\1293','\1293')+    , ('\1295','\1295')+    , ('\1297','\1297')+    , ('\1299','\1299')+    , ('\1301','\1301')+    , ('\1303','\1303')+    , ('\1305','\1305')+    , ('\1307','\1307')+    , ('\1309','\1309')+    , ('\1311','\1311')+    , ('\1313','\1313')+    , ('\1315','\1315')+    , ('\1317','\1317')+    , ('\1377','\1415')+    , ('\7424','\7467')+    , ('\7522','\7543')+    , ('\7545','\7578')+    , ('\7681','\7681')+    , ('\7683','\7683')+    , ('\7685','\7685')+    , ('\7687','\7687')+    , ('\7689','\7689')+    , ('\7691','\7691')+    , ('\7693','\7693')+    , ('\7695','\7695')+    , ('\7697','\7697')+    , ('\7699','\7699')+    , ('\7701','\7701')+    , ('\7703','\7703')+    , ('\7705','\7705')+    , ('\7707','\7707')+    , ('\7709','\7709')+    , ('\7711','\7711')+    , ('\7713','\7713')+    , ('\7715','\7715')+    , ('\7717','\7717')+    , ('\7719','\7719')+    , ('\7721','\7721')+    , ('\7723','\7723')+    , ('\7725','\7725')+    , ('\7727','\7727')+    , ('\7729','\7729')+    , ('\7731','\7731')+    , ('\7733','\7733')+    , ('\7735','\7735')+    , ('\7737','\7737')+    , ('\7739','\7739')+    , ('\7741','\7741')+    , ('\7743','\7743')+    , ('\7745','\7745')+    , ('\7747','\7747')+    , ('\7749','\7749')+    , ('\7751','\7751')+    , ('\7753','\7753')+    , ('\7755','\7755')+    , ('\7757','\7757')+    , ('\7759','\7759')+    , ('\7761','\7761')+    , ('\7763','\7763')+    , ('\7765','\7765')+    , ('\7767','\7767')+    , ('\7769','\7769')+    , ('\7771','\7771')+    , ('\7773','\7773')+    , ('\7775','\7775')+    , ('\7777','\7777')+    , ('\7779','\7779')+    , ('\7781','\7781')+    , ('\7783','\7783')+    , ('\7785','\7785')+    , ('\7787','\7787')+    , ('\7789','\7789')+    , ('\7791','\7791')+    , ('\7793','\7793')+    , ('\7795','\7795')+    , ('\7797','\7797')+    , ('\7799','\7799')+    , ('\7801','\7801')+    , ('\7803','\7803')+    , ('\7805','\7805')+    , ('\7807','\7807')+    , ('\7809','\7809')+    , ('\7811','\7811')+    , ('\7813','\7813')+    , ('\7815','\7815')+    , ('\7817','\7817')+    , ('\7819','\7819')+    , ('\7821','\7821')+    , ('\7823','\7823')+    , ('\7825','\7825')+    , ('\7827','\7827')+    , ('\7829','\7837')+    , ('\7839','\7839')+    , ('\7841','\7841')+    , ('\7843','\7843')+    , ('\7845','\7845')+    , ('\7847','\7847')+    , ('\7849','\7849')+    , ('\7851','\7851')+    , ('\7853','\7853')+    , ('\7855','\7855')+    , ('\7857','\7857')+    , ('\7859','\7859')+    , ('\7861','\7861')+    , ('\7863','\7863')+    , ('\7865','\7865')+    , ('\7867','\7867')+    , ('\7869','\7869')+    , ('\7871','\7871')+    , ('\7873','\7873')+    , ('\7875','\7875')+    , ('\7877','\7877')+    , ('\7879','\7879')+    , ('\7881','\7881')+    , ('\7883','\7883')+    , ('\7885','\7885')+    , ('\7887','\7887')+    , ('\7889','\7889')+    , ('\7891','\7891')+    , ('\7893','\7893')+    , ('\7895','\7895')+    , ('\7897','\7897')+    , ('\7899','\7899')+    , ('\7901','\7901')+    , ('\7903','\7903')+    , ('\7905','\7905')+    , ('\7907','\7907')+    , ('\7909','\7909')+    , ('\7911','\7911')+    , ('\7913','\7913')+    , ('\7915','\7915')+    , ('\7917','\7917')+    , ('\7919','\7919')+    , ('\7921','\7921')+    , ('\7923','\7923')+    , ('\7925','\7925')+    , ('\7927','\7927')+    , ('\7929','\7929')+    , ('\7931','\7931')+    , ('\7933','\7933')+    , ('\7935','\7943')+    , ('\7952','\7957')+    , ('\7968','\7975')+    , ('\7984','\7991')+    , ('\8000','\8005')+    , ('\8016','\8023')+    , ('\8032','\8039')+    , ('\8048','\8061')+    , ('\8064','\8071')+    , ('\8080','\8087')+    , ('\8096','\8103')+    , ('\8112','\8116')+    , ('\8118','\8119')+    , ('\8126','\8126')+    , ('\8130','\8132')+    , ('\8134','\8135')+    , ('\8144','\8147')+    , ('\8150','\8151')+    , ('\8160','\8167')+    , ('\8178','\8180')+    , ('\8182','\8183')+    , ('\8458','\8458')+    , ('\8462','\8463')+    , ('\8467','\8467')+    , ('\8495','\8495')+    , ('\8500','\8500')+    , ('\8505','\8505')+    , ('\8508','\8509')+    , ('\8518','\8521')+    , ('\8526','\8526')+    , ('\8580','\8580')+    , ('\11312','\11358')+    , ('\11361','\11361')+    , ('\11365','\11366')+    , ('\11368','\11368')+    , ('\11370','\11370')+    , ('\11372','\11372')+    , ('\11377','\11377')+    , ('\11379','\11380')+    , ('\11382','\11388')+    , ('\11393','\11393')+    , ('\11395','\11395')+    , ('\11397','\11397')+    , ('\11399','\11399')+    , ('\11401','\11401')+    , ('\11403','\11403')+    , ('\11405','\11405')+    , ('\11407','\11407')+    , ('\11409','\11409')+    , ('\11411','\11411')+    , ('\11413','\11413')+    , ('\11415','\11415')+    , ('\11417','\11417')+    , ('\11419','\11419')+    , ('\11421','\11421')+    , ('\11423','\11423')+    , ('\11425','\11425')+    , ('\11427','\11427')+    , ('\11429','\11429')+    , ('\11431','\11431')+    , ('\11433','\11433')+    , ('\11435','\11435')+    , ('\11437','\11437')+    , ('\11439','\11439')+    , ('\11441','\11441')+    , ('\11443','\11443')+    , ('\11445','\11445')+    , ('\11447','\11447')+    , ('\11449','\11449')+    , ('\11451','\11451')+    , ('\11453','\11453')+    , ('\11455','\11455')+    , ('\11457','\11457')+    , ('\11459','\11459')+    , ('\11461','\11461')+    , ('\11463','\11463')+    , ('\11465','\11465')+    , ('\11467','\11467')+    , ('\11469','\11469')+    , ('\11471','\11471')+    , ('\11473','\11473')+    , ('\11475','\11475')+    , ('\11477','\11477')+    , ('\11479','\11479')+    , ('\11481','\11481')+    , ('\11483','\11483')+    , ('\11485','\11485')+    , ('\11487','\11487')+    , ('\11489','\11489')+    , ('\11491','\11492')+    , ('\11500','\11500')+    , ('\11502','\11502')+    , ('\11520','\11557')+    , ('\42561','\42561')+    , ('\42563','\42563')+    , ('\42565','\42565')+    , ('\42567','\42567')+    , ('\42569','\42569')+    , ('\42571','\42571')+    , ('\42573','\42573')+    , ('\42575','\42575')+    , ('\42577','\42577')+    , ('\42579','\42579')+    , ('\42581','\42581')+    , ('\42583','\42583')+    , ('\42585','\42585')+    , ('\42587','\42587')+    , ('\42589','\42589')+    , ('\42591','\42591')+    , ('\42595','\42595')+    , ('\42597','\42597')+    , ('\42599','\42599')+    , ('\42601','\42601')+    , ('\42603','\42603')+    , ('\42605','\42605')+    , ('\42625','\42625')+    , ('\42627','\42627')+    , ('\42629','\42629')+    , ('\42631','\42631')+    , ('\42633','\42633')+    , ('\42635','\42635')+    , ('\42637','\42637')+    , ('\42639','\42639')+    , ('\42641','\42641')+    , ('\42643','\42643')+    , ('\42645','\42645')+    , ('\42647','\42647')+    , ('\42787','\42787')+    , ('\42789','\42789')+    , ('\42791','\42791')+    , ('\42793','\42793')+    , ('\42795','\42795')+    , ('\42797','\42797')+    , ('\42799','\42801')+    , ('\42803','\42803')+    , ('\42805','\42805')+    , ('\42807','\42807')+    , ('\42809','\42809')+    , ('\42811','\42811')+    , ('\42813','\42813')+    , ('\42815','\42815')+    , ('\42817','\42817')+    , ('\42819','\42819')+    , ('\42821','\42821')+    , ('\42823','\42823')+    , ('\42825','\42825')+    , ('\42827','\42827')+    , ('\42829','\42829')+    , ('\42831','\42831')+    , ('\42833','\42833')+    , ('\42835','\42835')+    , ('\42837','\42837')+    , ('\42839','\42839')+    , ('\42841','\42841')+    , ('\42843','\42843')+    , ('\42845','\42845')+    , ('\42847','\42847')+    , ('\42849','\42849')+    , ('\42851','\42851')+    , ('\42853','\42853')+    , ('\42855','\42855')+    , ('\42857','\42857')+    , ('\42859','\42859')+    , ('\42861','\42861')+    , ('\42863','\42863')+    , ('\42865','\42872')+    , ('\42874','\42874')+    , ('\42876','\42876')+    , ('\42879','\42879')+    , ('\42881','\42881')+    , ('\42883','\42883')+    , ('\42885','\42885')+    , ('\42887','\42887')+    , ('\42892','\42892')+    , ('\64256','\64262')+    , ('\64275','\64279')+    , ('\65345','\65370')+    , ('\66600','\66639')+    , ('\119834','\119859')+    , ('\119886','\119892')+    , ('\119894','\119911')+    , ('\119938','\119963')+    , ('\119990','\119993')+    , ('\119995','\119995')+    , ('\119997','\120003')+    , ('\120005','\120015')+    , ('\120042','\120067')+    , ('\120094','\120119')+    , ('\120146','\120171')+    , ('\120198','\120223')+    , ('\120250','\120275')+    , ('\120302','\120327')+    , ('\120354','\120379')+    , ('\120406','\120431')+    , ('\120458','\120485')+    , ('\120514','\120538')+    , ('\120540','\120545')+    , ('\120572','\120596')+    , ('\120598','\120603')+    , ('\120630','\120654')+    , ('\120656','\120661')+    , ('\120688','\120712')+    , ('\120714','\120719')+    , ('\120746','\120770')+    , ('\120772','\120777')+    , ('\120779','\120779')+    ]++-- ------------------------------------------------------------++isUnicodeLm	:: Char -> Bool+isUnicodeLm c+  = isInList c+    [ ('\688','\705')+    , ('\710','\721')+    , ('\736','\740')+    , ('\748','\748')+    , ('\750','\750')+    , ('\884','\884')+    , ('\890','\890')+    , ('\1369','\1369')+    , ('\1600','\1600')+    , ('\1765','\1766')+    , ('\2036','\2037')+    , ('\2042','\2042')+    , ('\2074','\2074')+    , ('\2084','\2084')+    , ('\2088','\2088')+    , ('\2417','\2417')+    , ('\3654','\3654')+    , ('\3782','\3782')+    , ('\4348','\4348')+    , ('\6103','\6103')+    , ('\6211','\6211')+    , ('\6823','\6823')+    , ('\7288','\7293')+    , ('\7468','\7521')+    , ('\7544','\7544')+    , ('\7579','\7615')+    , ('\8305','\8305')+    , ('\8319','\8319')+    , ('\8336','\8340')+    , ('\11389','\11389')+    , ('\11631','\11631')+    , ('\11823','\11823')+    , ('\12293','\12293')+    , ('\12337','\12341')+    , ('\12347','\12347')+    , ('\12445','\12446')+    , ('\12540','\12542')+    , ('\40981','\40981')+    , ('\42232','\42237')+    , ('\42508','\42508')+    , ('\42623','\42623')+    , ('\42775','\42783')+    , ('\42864','\42864')+    , ('\42888','\42888')+    , ('\43471','\43471')+    , ('\43632','\43632')+    , ('\43741','\43741')+    , ('\65392','\65392')+    , ('\65438','\65439')+    ]++-- ------------------------------------------------------------++isUnicodeLo	:: Char -> Bool+isUnicodeLo c+  = isInList c+    [ ('\443','\443')+    , ('\448','\451')+    , ('\660','\660')+    , ('\1488','\1514')+    , ('\1520','\1522')+    , ('\1569','\1599')+    , ('\1601','\1610')+    , ('\1646','\1647')+    , ('\1649','\1747')+    , ('\1749','\1749')+    , ('\1774','\1775')+    , ('\1786','\1788')+    , ('\1791','\1791')+    , ('\1808','\1808')+    , ('\1810','\1839')+    , ('\1869','\1957')+    , ('\1969','\1969')+    , ('\1994','\2026')+    , ('\2048','\2069')+    , ('\2308','\2361')+    , ('\2365','\2365')+    , ('\2384','\2384')+    , ('\2392','\2401')+    , ('\2418','\2418')+    , ('\2425','\2431')+    , ('\2437','\2444')+    , ('\2447','\2448')+    , ('\2451','\2472')+    , ('\2474','\2480')+    , ('\2482','\2482')+    , ('\2486','\2489')+    , ('\2493','\2493')+    , ('\2510','\2510')+    , ('\2524','\2525')+    , ('\2527','\2529')+    , ('\2544','\2545')+    , ('\2565','\2570')+    , ('\2575','\2576')+    , ('\2579','\2600')+    , ('\2602','\2608')+    , ('\2610','\2611')+    , ('\2613','\2614')+    , ('\2616','\2617')+    , ('\2649','\2652')+    , ('\2654','\2654')+    , ('\2674','\2676')+    , ('\2693','\2701')+    , ('\2703','\2705')+    , ('\2707','\2728')+    , ('\2730','\2736')+    , ('\2738','\2739')+    , ('\2741','\2745')+    , ('\2749','\2749')+    , ('\2768','\2768')+    , ('\2784','\2785')+    , ('\2821','\2828')+    , ('\2831','\2832')+    , ('\2835','\2856')+    , ('\2858','\2864')+    , ('\2866','\2867')+    , ('\2869','\2873')+    , ('\2877','\2877')+    , ('\2908','\2909')+    , ('\2911','\2913')+    , ('\2929','\2929')+    , ('\2947','\2947')+    , ('\2949','\2954')+    , ('\2958','\2960')+    , ('\2962','\2965')+    , ('\2969','\2970')+    , ('\2972','\2972')+    , ('\2974','\2975')+    , ('\2979','\2980')+    , ('\2984','\2986')+    , ('\2990','\3001')+    , ('\3024','\3024')+    , ('\3077','\3084')+    , ('\3086','\3088')+    , ('\3090','\3112')+    , ('\3114','\3123')+    , ('\3125','\3129')+    , ('\3133','\3133')+    , ('\3160','\3161')+    , ('\3168','\3169')+    , ('\3205','\3212')+    , ('\3214','\3216')+    , ('\3218','\3240')+    , ('\3242','\3251')+    , ('\3253','\3257')+    , ('\3261','\3261')+    , ('\3294','\3294')+    , ('\3296','\3297')+    , ('\3333','\3340')+    , ('\3342','\3344')+    , ('\3346','\3368')+    , ('\3370','\3385')+    , ('\3389','\3389')+    , ('\3424','\3425')+    , ('\3450','\3455')+    , ('\3461','\3478')+    , ('\3482','\3505')+    , ('\3507','\3515')+    , ('\3517','\3517')+    , ('\3520','\3526')+    , ('\3585','\3632')+    , ('\3634','\3635')+    , ('\3648','\3653')+    , ('\3713','\3714')+    , ('\3716','\3716')+    , ('\3719','\3720')+    , ('\3722','\3722')+    , ('\3725','\3725')+    , ('\3732','\3735')+    , ('\3737','\3743')+    , ('\3745','\3747')+    , ('\3749','\3749')+    , ('\3751','\3751')+    , ('\3754','\3755')+    , ('\3757','\3760')+    , ('\3762','\3763')+    , ('\3773','\3773')+    , ('\3776','\3780')+    , ('\3804','\3805')+    , ('\3840','\3840')+    , ('\3904','\3911')+    , ('\3913','\3948')+    , ('\3976','\3979')+    , ('\4096','\4138')+    , ('\4159','\4159')+    , ('\4176','\4181')+    , ('\4186','\4189')+    , ('\4193','\4193')+    , ('\4197','\4198')+    , ('\4206','\4208')+    , ('\4213','\4225')+    , ('\4238','\4238')+    , ('\4304','\4346')+    , ('\4352','\4680')+    , ('\4682','\4685')+    , ('\4688','\4694')+    , ('\4696','\4696')+    , ('\4698','\4701')+    , ('\4704','\4744')+    , ('\4746','\4749')+    , ('\4752','\4784')+    , ('\4786','\4789')+    , ('\4792','\4798')+    , ('\4800','\4800')+    , ('\4802','\4805')+    , ('\4808','\4822')+    , ('\4824','\4880')+    , ('\4882','\4885')+    , ('\4888','\4954')+    , ('\4992','\5007')+    , ('\5024','\5108')+    , ('\5121','\5740')+    , ('\5743','\5759')+    , ('\5761','\5786')+    , ('\5792','\5866')+    , ('\5888','\5900')+    , ('\5902','\5905')+    , ('\5920','\5937')+    , ('\5952','\5969')+    , ('\5984','\5996')+    , ('\5998','\6000')+    , ('\6016','\6067')+    , ('\6108','\6108')+    , ('\6176','\6210')+    , ('\6212','\6263')+    , ('\6272','\6312')+    , ('\6314','\6314')+    , ('\6320','\6389')+    , ('\6400','\6428')+    , ('\6480','\6509')+    , ('\6512','\6516')+    , ('\6528','\6571')+    , ('\6593','\6599')+    , ('\6656','\6678')+    , ('\6688','\6740')+    , ('\6917','\6963')+    , ('\6981','\6987')+    , ('\7043','\7072')+    , ('\7086','\7087')+    , ('\7168','\7203')+    , ('\7245','\7247')+    , ('\7258','\7287')+    , ('\7401','\7404')+    , ('\7406','\7409')+    , ('\8501','\8504')+    , ('\11568','\11621')+    , ('\11648','\11670')+    , ('\11680','\11686')+    , ('\11688','\11694')+    , ('\11696','\11702')+    , ('\11704','\11710')+    , ('\11712','\11718')+    , ('\11720','\11726')+    , ('\11728','\11734')+    , ('\11736','\11742')+    , ('\12294','\12294')+    , ('\12348','\12348')+    , ('\12353','\12438')+    , ('\12447','\12447')+    , ('\12449','\12538')+    , ('\12543','\12543')+    , ('\12549','\12589')+    , ('\12593','\12686')+    , ('\12704','\12727')+    , ('\12784','\12799')+    , ('\13312','\13312')+    , ('\19893','\19893')+    , ('\19968','\19968')+    , ('\40907','\40907')+    , ('\40960','\40980')+    , ('\40982','\42124')+    , ('\42192','\42231')+    , ('\42240','\42507')+    , ('\42512','\42527')+    , ('\42538','\42539')+    , ('\42606','\42606')+    , ('\42656','\42725')+    , ('\43003','\43009')+    , ('\43011','\43013')+    , ('\43015','\43018')+    , ('\43020','\43042')+    , ('\43072','\43123')+    , ('\43138','\43187')+    , ('\43250','\43255')+    , ('\43259','\43259')+    , ('\43274','\43301')+    , ('\43312','\43334')+    , ('\43360','\43388')+    , ('\43396','\43442')+    , ('\43520','\43560')+    , ('\43584','\43586')+    , ('\43588','\43595')+    , ('\43616','\43631')+    , ('\43633','\43638')+    , ('\43642','\43642')+    , ('\43648','\43695')+    , ('\43697','\43697')+    , ('\43701','\43702')+    , ('\43705','\43709')+    , ('\43712','\43712')+    , ('\43714','\43714')+    , ('\43739','\43740')+    , ('\43968','\44002')+    , ('\44032','\44032')+    , ('\55203','\55203')+    , ('\55216','\55238')+    , ('\55243','\55291')+    , ('\63744','\64045')+    , ('\64048','\64109')+    , ('\64112','\64217')+    , ('\64285','\64285')+    , ('\64287','\64296')+    , ('\64298','\64310')+    , ('\64312','\64316')+    , ('\64318','\64318')+    , ('\64320','\64321')+    , ('\64323','\64324')+    , ('\64326','\64433')+    , ('\64467','\64829')+    , ('\64848','\64911')+    , ('\64914','\64967')+    , ('\65008','\65019')+    , ('\65136','\65140')+    , ('\65142','\65276')+    , ('\65382','\65391')+    , ('\65393','\65437')+    , ('\65440','\65470')+    , ('\65474','\65479')+    , ('\65482','\65487')+    , ('\65490','\65495')+    , ('\65498','\65500')+    , ('\65536','\65547')+    , ('\65549','\65574')+    , ('\65576','\65594')+    , ('\65596','\65597')+    , ('\65599','\65613')+    , ('\65616','\65629')+    , ('\65664','\65786')+    , ('\66176','\66204')+    , ('\66208','\66256')+    , ('\66304','\66334')+    , ('\66352','\66368')+    , ('\66370','\66377')+    , ('\66432','\66461')+    , ('\66464','\66499')+    , ('\66504','\66511')+    , ('\66640','\66717')+    , ('\67584','\67589')+    , ('\67592','\67592')+    , ('\67594','\67637')+    , ('\67639','\67640')+    , ('\67644','\67644')+    , ('\67647','\67669')+    , ('\67840','\67861')+    , ('\67872','\67897')+    , ('\68096','\68096')+    , ('\68112','\68115')+    , ('\68117','\68119')+    , ('\68121','\68147')+    , ('\68192','\68220')+    , ('\68352','\68405')+    , ('\68416','\68437')+    , ('\68448','\68466')+    , ('\68608','\68680')+    , ('\69763','\69807')+    , ('\73728','\74606')+    , ('\77824','\78894')+    , ('\131072','\131072')+    , ('\173782','\173782')+    , ('\173824','\173824')+    , ('\177972','\177972')+    , ('\194560','\195101')+    ]++-- ------------------------------------------------------------++isUnicodeLt	:: Char -> Bool+isUnicodeLt c+  = isInList c+    [ ('\453','\453')+    , ('\456','\456')+    , ('\459','\459')+    , ('\498','\498')+    , ('\8072','\8079')+    , ('\8088','\8095')+    , ('\8104','\8111')+    , ('\8124','\8124')+    , ('\8140','\8140')+    , ('\8188','\8188')+    ]++-- ------------------------------------------------------------++isUnicodeLu	:: Char -> Bool+isUnicodeLu c+  = isInList c+    [ ('A','Z')+    , ('\192','\214')+    , ('\216','\222')+    , ('\256','\256')+    , ('\258','\258')+    , ('\260','\260')+    , ('\262','\262')+    , ('\264','\264')+    , ('\266','\266')+    , ('\268','\268')+    , ('\270','\270')+    , ('\272','\272')+    , ('\274','\274')+    , ('\276','\276')+    , ('\278','\278')+    , ('\280','\280')+    , ('\282','\282')+    , ('\284','\284')+    , ('\286','\286')+    , ('\288','\288')+    , ('\290','\290')+    , ('\292','\292')+    , ('\294','\294')+    , ('\296','\296')+    , ('\298','\298')+    , ('\300','\300')+    , ('\302','\302')+    , ('\304','\304')+    , ('\306','\306')+    , ('\308','\308')+    , ('\310','\310')+    , ('\313','\313')+    , ('\315','\315')+    , ('\317','\317')+    , ('\319','\319')+    , ('\321','\321')+    , ('\323','\323')+    , ('\325','\325')+    , ('\327','\327')+    , ('\330','\330')+    , ('\332','\332')+    , ('\334','\334')+    , ('\336','\336')+    , ('\338','\338')+    , ('\340','\340')+    , ('\342','\342')+    , ('\344','\344')+    , ('\346','\346')+    , ('\348','\348')+    , ('\350','\350')+    , ('\352','\352')+    , ('\354','\354')+    , ('\356','\356')+    , ('\358','\358')+    , ('\360','\360')+    , ('\362','\362')+    , ('\364','\364')+    , ('\366','\366')+    , ('\368','\368')+    , ('\370','\370')+    , ('\372','\372')+    , ('\374','\374')+    , ('\376','\377')+    , ('\379','\379')+    , ('\381','\381')+    , ('\385','\386')+    , ('\388','\388')+    , ('\390','\391')+    , ('\393','\395')+    , ('\398','\401')+    , ('\403','\404')+    , ('\406','\408')+    , ('\412','\413')+    , ('\415','\416')+    , ('\418','\418')+    , ('\420','\420')+    , ('\422','\423')+    , ('\425','\425')+    , ('\428','\428')+    , ('\430','\431')+    , ('\433','\435')+    , ('\437','\437')+    , ('\439','\440')+    , ('\444','\444')+    , ('\452','\452')+    , ('\455','\455')+    , ('\458','\458')+    , ('\461','\461')+    , ('\463','\463')+    , ('\465','\465')+    , ('\467','\467')+    , ('\469','\469')+    , ('\471','\471')+    , ('\473','\473')+    , ('\475','\475')+    , ('\478','\478')+    , ('\480','\480')+    , ('\482','\482')+    , ('\484','\484')+    , ('\486','\486')+    , ('\488','\488')+    , ('\490','\490')+    , ('\492','\492')+    , ('\494','\494')+    , ('\497','\497')+    , ('\500','\500')+    , ('\502','\504')+    , ('\506','\506')+    , ('\508','\508')+    , ('\510','\510')+    , ('\512','\512')+    , ('\514','\514')+    , ('\516','\516')+    , ('\518','\518')+    , ('\520','\520')+    , ('\522','\522')+    , ('\524','\524')+    , ('\526','\526')+    , ('\528','\528')+    , ('\530','\530')+    , ('\532','\532')+    , ('\534','\534')+    , ('\536','\536')+    , ('\538','\538')+    , ('\540','\540')+    , ('\542','\542')+    , ('\544','\544')+    , ('\546','\546')+    , ('\548','\548')+    , ('\550','\550')+    , ('\552','\552')+    , ('\554','\554')+    , ('\556','\556')+    , ('\558','\558')+    , ('\560','\560')+    , ('\562','\562')+    , ('\570','\571')+    , ('\573','\574')+    , ('\577','\577')+    , ('\579','\582')+    , ('\584','\584')+    , ('\586','\586')+    , ('\588','\588')+    , ('\590','\590')+    , ('\880','\880')+    , ('\882','\882')+    , ('\886','\886')+    , ('\902','\902')+    , ('\904','\906')+    , ('\908','\908')+    , ('\910','\911')+    , ('\913','\929')+    , ('\931','\939')+    , ('\975','\975')+    , ('\978','\980')+    , ('\984','\984')+    , ('\986','\986')+    , ('\988','\988')+    , ('\990','\990')+    , ('\992','\992')+    , ('\994','\994')+    , ('\996','\996')+    , ('\998','\998')+    , ('\1000','\1000')+    , ('\1002','\1002')+    , ('\1004','\1004')+    , ('\1006','\1006')+    , ('\1012','\1012')+    , ('\1015','\1015')+    , ('\1017','\1018')+    , ('\1021','\1071')+    , ('\1120','\1120')+    , ('\1122','\1122')+    , ('\1124','\1124')+    , ('\1126','\1126')+    , ('\1128','\1128')+    , ('\1130','\1130')+    , ('\1132','\1132')+    , ('\1134','\1134')+    , ('\1136','\1136')+    , ('\1138','\1138')+    , ('\1140','\1140')+    , ('\1142','\1142')+    , ('\1144','\1144')+    , ('\1146','\1146')+    , ('\1148','\1148')+    , ('\1150','\1150')+    , ('\1152','\1152')+    , ('\1162','\1162')+    , ('\1164','\1164')+    , ('\1166','\1166')+    , ('\1168','\1168')+    , ('\1170','\1170')+    , ('\1172','\1172')+    , ('\1174','\1174')+    , ('\1176','\1176')+    , ('\1178','\1178')+    , ('\1180','\1180')+    , ('\1182','\1182')+    , ('\1184','\1184')+    , ('\1186','\1186')+    , ('\1188','\1188')+    , ('\1190','\1190')+    , ('\1192','\1192')+    , ('\1194','\1194')+    , ('\1196','\1196')+    , ('\1198','\1198')+    , ('\1200','\1200')+    , ('\1202','\1202')+    , ('\1204','\1204')+    , ('\1206','\1206')+    , ('\1208','\1208')+    , ('\1210','\1210')+    , ('\1212','\1212')+    , ('\1214','\1214')+    , ('\1216','\1217')+    , ('\1219','\1219')+    , ('\1221','\1221')+    , ('\1223','\1223')+    , ('\1225','\1225')+    , ('\1227','\1227')+    , ('\1229','\1229')+    , ('\1232','\1232')+    , ('\1234','\1234')+    , ('\1236','\1236')+    , ('\1238','\1238')+    , ('\1240','\1240')+    , ('\1242','\1242')+    , ('\1244','\1244')+    , ('\1246','\1246')+    , ('\1248','\1248')+    , ('\1250','\1250')+    , ('\1252','\1252')+    , ('\1254','\1254')+    , ('\1256','\1256')+    , ('\1258','\1258')+    , ('\1260','\1260')+    , ('\1262','\1262')+    , ('\1264','\1264')+    , ('\1266','\1266')+    , ('\1268','\1268')+    , ('\1270','\1270')+    , ('\1272','\1272')+    , ('\1274','\1274')+    , ('\1276','\1276')+    , ('\1278','\1278')+    , ('\1280','\1280')+    , ('\1282','\1282')+    , ('\1284','\1284')+    , ('\1286','\1286')+    , ('\1288','\1288')+    , ('\1290','\1290')+    , ('\1292','\1292')+    , ('\1294','\1294')+    , ('\1296','\1296')+    , ('\1298','\1298')+    , ('\1300','\1300')+    , ('\1302','\1302')+    , ('\1304','\1304')+    , ('\1306','\1306')+    , ('\1308','\1308')+    , ('\1310','\1310')+    , ('\1312','\1312')+    , ('\1314','\1314')+    , ('\1316','\1316')+    , ('\1329','\1366')+    , ('\4256','\4293')+    , ('\7680','\7680')+    , ('\7682','\7682')+    , ('\7684','\7684')+    , ('\7686','\7686')+    , ('\7688','\7688')+    , ('\7690','\7690')+    , ('\7692','\7692')+    , ('\7694','\7694')+    , ('\7696','\7696')+    , ('\7698','\7698')+    , ('\7700','\7700')+    , ('\7702','\7702')+    , ('\7704','\7704')+    , ('\7706','\7706')+    , ('\7708','\7708')+    , ('\7710','\7710')+    , ('\7712','\7712')+    , ('\7714','\7714')+    , ('\7716','\7716')+    , ('\7718','\7718')+    , ('\7720','\7720')+    , ('\7722','\7722')+    , ('\7724','\7724')+    , ('\7726','\7726')+    , ('\7728','\7728')+    , ('\7730','\7730')+    , ('\7732','\7732')+    , ('\7734','\7734')+    , ('\7736','\7736')+    , ('\7738','\7738')+    , ('\7740','\7740')+    , ('\7742','\7742')+    , ('\7744','\7744')+    , ('\7746','\7746')+    , ('\7748','\7748')+    , ('\7750','\7750')+    , ('\7752','\7752')+    , ('\7754','\7754')+    , ('\7756','\7756')+    , ('\7758','\7758')+    , ('\7760','\7760')+    , ('\7762','\7762')+    , ('\7764','\7764')+    , ('\7766','\7766')+    , ('\7768','\7768')+    , ('\7770','\7770')+    , ('\7772','\7772')+    , ('\7774','\7774')+    , ('\7776','\7776')+    , ('\7778','\7778')+    , ('\7780','\7780')+    , ('\7782','\7782')+    , ('\7784','\7784')+    , ('\7786','\7786')+    , ('\7788','\7788')+    , ('\7790','\7790')+    , ('\7792','\7792')+    , ('\7794','\7794')+    , ('\7796','\7796')+    , ('\7798','\7798')+    , ('\7800','\7800')+    , ('\7802','\7802')+    , ('\7804','\7804')+    , ('\7806','\7806')+    , ('\7808','\7808')+    , ('\7810','\7810')+    , ('\7812','\7812')+    , ('\7814','\7814')+    , ('\7816','\7816')+    , ('\7818','\7818')+    , ('\7820','\7820')+    , ('\7822','\7822')+    , ('\7824','\7824')+    , ('\7826','\7826')+    , ('\7828','\7828')+    , ('\7838','\7838')+    , ('\7840','\7840')+    , ('\7842','\7842')+    , ('\7844','\7844')+    , ('\7846','\7846')+    , ('\7848','\7848')+    , ('\7850','\7850')+    , ('\7852','\7852')+    , ('\7854','\7854')+    , ('\7856','\7856')+    , ('\7858','\7858')+    , ('\7860','\7860')+    , ('\7862','\7862')+    , ('\7864','\7864')+    , ('\7866','\7866')+    , ('\7868','\7868')+    , ('\7870','\7870')+    , ('\7872','\7872')+    , ('\7874','\7874')+    , ('\7876','\7876')+    , ('\7878','\7878')+    , ('\7880','\7880')+    , ('\7882','\7882')+    , ('\7884','\7884')+    , ('\7886','\7886')+    , ('\7888','\7888')+    , ('\7890','\7890')+    , ('\7892','\7892')+    , ('\7894','\7894')+    , ('\7896','\7896')+    , ('\7898','\7898')+    , ('\7900','\7900')+    , ('\7902','\7902')+    , ('\7904','\7904')+    , ('\7906','\7906')+    , ('\7908','\7908')+    , ('\7910','\7910')+    , ('\7912','\7912')+    , ('\7914','\7914')+    , ('\7916','\7916')+    , ('\7918','\7918')+    , ('\7920','\7920')+    , ('\7922','\7922')+    , ('\7924','\7924')+    , ('\7926','\7926')+    , ('\7928','\7928')+    , ('\7930','\7930')+    , ('\7932','\7932')+    , ('\7934','\7934')+    , ('\7944','\7951')+    , ('\7960','\7965')+    , ('\7976','\7983')+    , ('\7992','\7999')+    , ('\8008','\8013')+    , ('\8025','\8025')+    , ('\8027','\8027')+    , ('\8029','\8029')+    , ('\8031','\8031')+    , ('\8040','\8047')+    , ('\8120','\8123')+    , ('\8136','\8139')+    , ('\8152','\8155')+    , ('\8168','\8172')+    , ('\8184','\8187')+    , ('\8450','\8450')+    , ('\8455','\8455')+    , ('\8459','\8461')+    , ('\8464','\8466')+    , ('\8469','\8469')+    , ('\8473','\8477')+    , ('\8484','\8484')+    , ('\8486','\8486')+    , ('\8488','\8488')+    , ('\8490','\8493')+    , ('\8496','\8499')+    , ('\8510','\8511')+    , ('\8517','\8517')+    , ('\8579','\8579')+    , ('\11264','\11310')+    , ('\11360','\11360')+    , ('\11362','\11364')+    , ('\11367','\11367')+    , ('\11369','\11369')+    , ('\11371','\11371')+    , ('\11373','\11376')+    , ('\11378','\11378')+    , ('\11381','\11381')+    , ('\11390','\11392')+    , ('\11394','\11394')+    , ('\11396','\11396')+    , ('\11398','\11398')+    , ('\11400','\11400')+    , ('\11402','\11402')+    , ('\11404','\11404')+    , ('\11406','\11406')+    , ('\11408','\11408')+    , ('\11410','\11410')+    , ('\11412','\11412')+    , ('\11414','\11414')+    , ('\11416','\11416')+    , ('\11418','\11418')+    , ('\11420','\11420')+    , ('\11422','\11422')+    , ('\11424','\11424')+    , ('\11426','\11426')+    , ('\11428','\11428')+    , ('\11430','\11430')+    , ('\11432','\11432')+    , ('\11434','\11434')+    , ('\11436','\11436')+    , ('\11438','\11438')+    , ('\11440','\11440')+    , ('\11442','\11442')+    , ('\11444','\11444')+    , ('\11446','\11446')+    , ('\11448','\11448')+    , ('\11450','\11450')+    , ('\11452','\11452')+    , ('\11454','\11454')+    , ('\11456','\11456')+    , ('\11458','\11458')+    , ('\11460','\11460')+    , ('\11462','\11462')+    , ('\11464','\11464')+    , ('\11466','\11466')+    , ('\11468','\11468')+    , ('\11470','\11470')+    , ('\11472','\11472')+    , ('\11474','\11474')+    , ('\11476','\11476')+    , ('\11478','\11478')+    , ('\11480','\11480')+    , ('\11482','\11482')+    , ('\11484','\11484')+    , ('\11486','\11486')+    , ('\11488','\11488')+    , ('\11490','\11490')+    , ('\11499','\11499')+    , ('\11501','\11501')+    , ('\42560','\42560')+    , ('\42562','\42562')+    , ('\42564','\42564')+    , ('\42566','\42566')+    , ('\42568','\42568')+    , ('\42570','\42570')+    , ('\42572','\42572')+    , ('\42574','\42574')+    , ('\42576','\42576')+    , ('\42578','\42578')+    , ('\42580','\42580')+    , ('\42582','\42582')+    , ('\42584','\42584')+    , ('\42586','\42586')+    , ('\42588','\42588')+    , ('\42590','\42590')+    , ('\42594','\42594')+    , ('\42596','\42596')+    , ('\42598','\42598')+    , ('\42600','\42600')+    , ('\42602','\42602')+    , ('\42604','\42604')+    , ('\42624','\42624')+    , ('\42626','\42626')+    , ('\42628','\42628')+    , ('\42630','\42630')+    , ('\42632','\42632')+    , ('\42634','\42634')+    , ('\42636','\42636')+    , ('\42638','\42638')+    , ('\42640','\42640')+    , ('\42642','\42642')+    , ('\42644','\42644')+    , ('\42646','\42646')+    , ('\42786','\42786')+    , ('\42788','\42788')+    , ('\42790','\42790')+    , ('\42792','\42792')+    , ('\42794','\42794')+    , ('\42796','\42796')+    , ('\42798','\42798')+    , ('\42802','\42802')+    , ('\42804','\42804')+    , ('\42806','\42806')+    , ('\42808','\42808')+    , ('\42810','\42810')+    , ('\42812','\42812')+    , ('\42814','\42814')+    , ('\42816','\42816')+    , ('\42818','\42818')+    , ('\42820','\42820')+    , ('\42822','\42822')+    , ('\42824','\42824')+    , ('\42826','\42826')+    , ('\42828','\42828')+    , ('\42830','\42830')+    , ('\42832','\42832')+    , ('\42834','\42834')+    , ('\42836','\42836')+    , ('\42838','\42838')+    , ('\42840','\42840')+    , ('\42842','\42842')+    , ('\42844','\42844')+    , ('\42846','\42846')+    , ('\42848','\42848')+    , ('\42850','\42850')+    , ('\42852','\42852')+    , ('\42854','\42854')+    , ('\42856','\42856')+    , ('\42858','\42858')+    , ('\42860','\42860')+    , ('\42862','\42862')+    , ('\42873','\42873')+    , ('\42875','\42875')+    , ('\42877','\42878')+    , ('\42880','\42880')+    , ('\42882','\42882')+    , ('\42884','\42884')+    , ('\42886','\42886')+    , ('\42891','\42891')+    , ('\65313','\65338')+    , ('\66560','\66599')+    , ('\119808','\119833')+    , ('\119860','\119885')+    , ('\119912','\119937')+    , ('\119964','\119964')+    , ('\119966','\119967')+    , ('\119970','\119970')+    , ('\119973','\119974')+    , ('\119977','\119980')+    , ('\119982','\119989')+    , ('\120016','\120041')+    , ('\120068','\120069')+    , ('\120071','\120074')+    , ('\120077','\120084')+    , ('\120086','\120092')+    , ('\120120','\120121')+    , ('\120123','\120126')+    , ('\120128','\120132')+    , ('\120134','\120134')+    , ('\120138','\120144')+    , ('\120172','\120197')+    , ('\120224','\120249')+    , ('\120276','\120301')+    , ('\120328','\120353')+    , ('\120380','\120405')+    , ('\120432','\120457')+    , ('\120488','\120512')+    , ('\120546','\120570')+    , ('\120604','\120628')+    , ('\120662','\120686')+    , ('\120720','\120744')+    , ('\120778','\120778')+    ]++-- ------------------------------------------------------------++isUnicodeM	:: Char -> Bool+isUnicodeM c+  = isInList c+    [ ('\768','\879')+    , ('\1155','\1161')+    , ('\1425','\1469')+    , ('\1471','\1471')+    , ('\1473','\1474')+    , ('\1476','\1477')+    , ('\1479','\1479')+    , ('\1552','\1562')+    , ('\1611','\1630')+    , ('\1648','\1648')+    , ('\1750','\1756')+    , ('\1758','\1764')+    , ('\1767','\1768')+    , ('\1770','\1773')+    , ('\1809','\1809')+    , ('\1840','\1866')+    , ('\1958','\1968')+    , ('\2027','\2035')+    , ('\2070','\2073')+    , ('\2075','\2083')+    , ('\2085','\2087')+    , ('\2089','\2093')+    , ('\2304','\2307')+    , ('\2364','\2364')+    , ('\2366','\2382')+    , ('\2385','\2389')+    , ('\2402','\2403')+    , ('\2433','\2435')+    , ('\2492','\2492')+    , ('\2494','\2500')+    , ('\2503','\2504')+    , ('\2507','\2509')+    , ('\2519','\2519')+    , ('\2530','\2531')+    , ('\2561','\2563')+    , ('\2620','\2620')+    , ('\2622','\2626')+    , ('\2631','\2632')+    , ('\2635','\2637')+    , ('\2641','\2641')+    , ('\2672','\2673')+    , ('\2677','\2677')+    , ('\2689','\2691')+    , ('\2748','\2748')+    , ('\2750','\2757')+    , ('\2759','\2761')+    , ('\2763','\2765')+    , ('\2786','\2787')+    , ('\2817','\2819')+    , ('\2876','\2876')+    , ('\2878','\2884')+    , ('\2887','\2888')+    , ('\2891','\2893')+    , ('\2902','\2903')+    , ('\2914','\2915')+    , ('\2946','\2946')+    , ('\3006','\3010')+    , ('\3014','\3016')+    , ('\3018','\3021')+    , ('\3031','\3031')+    , ('\3073','\3075')+    , ('\3134','\3140')+    , ('\3142','\3144')+    , ('\3146','\3149')+    , ('\3157','\3158')+    , ('\3170','\3171')+    , ('\3202','\3203')+    , ('\3260','\3260')+    , ('\3262','\3268')+    , ('\3270','\3272')+    , ('\3274','\3277')+    , ('\3285','\3286')+    , ('\3298','\3299')+    , ('\3330','\3331')+    , ('\3390','\3396')+    , ('\3398','\3400')+    , ('\3402','\3405')+    , ('\3415','\3415')+    , ('\3426','\3427')+    , ('\3458','\3459')+    , ('\3530','\3530')+    , ('\3535','\3540')+    , ('\3542','\3542')+    , ('\3544','\3551')+    , ('\3570','\3571')+    , ('\3633','\3633')+    , ('\3636','\3642')+    , ('\3655','\3662')+    , ('\3761','\3761')+    , ('\3764','\3769')+    , ('\3771','\3772')+    , ('\3784','\3789')+    , ('\3864','\3865')+    , ('\3893','\3893')+    , ('\3895','\3895')+    , ('\3897','\3897')+    , ('\3902','\3903')+    , ('\3953','\3972')+    , ('\3974','\3975')+    , ('\3984','\3991')+    , ('\3993','\4028')+    , ('\4038','\4038')+    , ('\4139','\4158')+    , ('\4182','\4185')+    , ('\4190','\4192')+    , ('\4194','\4196')+    , ('\4199','\4205')+    , ('\4209','\4212')+    , ('\4226','\4237')+    , ('\4239','\4239')+    , ('\4250','\4253')+    , ('\4959','\4959')+    , ('\5906','\5908')+    , ('\5938','\5940')+    , ('\5970','\5971')+    , ('\6002','\6003')+    , ('\6070','\6099')+    , ('\6109','\6109')+    , ('\6155','\6157')+    , ('\6313','\6313')+    , ('\6432','\6443')+    , ('\6448','\6459')+    , ('\6576','\6592')+    , ('\6600','\6601')+    , ('\6679','\6683')+    , ('\6741','\6750')+    , ('\6752','\6780')+    , ('\6783','\6783')+    , ('\6912','\6916')+    , ('\6964','\6980')+    , ('\7019','\7027')+    , ('\7040','\7042')+    , ('\7073','\7082')+    , ('\7204','\7223')+    , ('\7376','\7378')+    , ('\7380','\7400')+    , ('\7405','\7405')+    , ('\7410','\7410')+    , ('\7616','\7654')+    , ('\7677','\7679')+    , ('\8400','\8432')+    , ('\11503','\11505')+    , ('\11744','\11775')+    , ('\12330','\12335')+    , ('\12441','\12442')+    , ('\42607','\42610')+    , ('\42620','\42621')+    , ('\42736','\42737')+    , ('\43010','\43010')+    , ('\43014','\43014')+    , ('\43019','\43019')+    , ('\43043','\43047')+    , ('\43136','\43137')+    , ('\43188','\43204')+    , ('\43232','\43249')+    , ('\43302','\43309')+    , ('\43335','\43347')+    , ('\43392','\43395')+    , ('\43443','\43456')+    , ('\43561','\43574')+    , ('\43587','\43587')+    , ('\43596','\43597')+    , ('\43643','\43643')+    , ('\43696','\43696')+    , ('\43698','\43700')+    , ('\43703','\43704')+    , ('\43710','\43711')+    , ('\43713','\43713')+    , ('\44003','\44010')+    , ('\44012','\44013')+    , ('\64286','\64286')+    , ('\65024','\65039')+    , ('\65056','\65062')+    , ('\66045','\66045')+    , ('\68097','\68099')+    , ('\68101','\68102')+    , ('\68108','\68111')+    , ('\68152','\68154')+    , ('\68159','\68159')+    , ('\69760','\69762')+    , ('\69808','\69818')+    , ('\119141','\119145')+    , ('\119149','\119154')+    , ('\119163','\119170')+    , ('\119173','\119179')+    , ('\119210','\119213')+    , ('\119362','\119364')+    , ('\917760','\917999')+    ]++-- ------------------------------------------------------------++isUnicodeMc	:: Char -> Bool+isUnicodeMc c+  = isInList c+    [ ('\2307','\2307')+    , ('\2366','\2368')+    , ('\2377','\2380')+    , ('\2382','\2382')+    , ('\2434','\2435')+    , ('\2494','\2496')+    , ('\2503','\2504')+    , ('\2507','\2508')+    , ('\2519','\2519')+    , ('\2563','\2563')+    , ('\2622','\2624')+    , ('\2691','\2691')+    , ('\2750','\2752')+    , ('\2761','\2761')+    , ('\2763','\2764')+    , ('\2818','\2819')+    , ('\2878','\2878')+    , ('\2880','\2880')+    , ('\2887','\2888')+    , ('\2891','\2892')+    , ('\2903','\2903')+    , ('\3006','\3007')+    , ('\3009','\3010')+    , ('\3014','\3016')+    , ('\3018','\3020')+    , ('\3031','\3031')+    , ('\3073','\3075')+    , ('\3137','\3140')+    , ('\3202','\3203')+    , ('\3262','\3262')+    , ('\3264','\3268')+    , ('\3271','\3272')+    , ('\3274','\3275')+    , ('\3285','\3286')+    , ('\3330','\3331')+    , ('\3390','\3392')+    , ('\3398','\3400')+    , ('\3402','\3404')+    , ('\3415','\3415')+    , ('\3458','\3459')+    , ('\3535','\3537')+    , ('\3544','\3551')+    , ('\3570','\3571')+    , ('\3902','\3903')+    , ('\3967','\3967')+    , ('\4139','\4140')+    , ('\4145','\4145')+    , ('\4152','\4152')+    , ('\4155','\4156')+    , ('\4182','\4183')+    , ('\4194','\4196')+    , ('\4199','\4205')+    , ('\4227','\4228')+    , ('\4231','\4236')+    , ('\4239','\4239')+    , ('\4250','\4252')+    , ('\6070','\6070')+    , ('\6078','\6085')+    , ('\6087','\6088')+    , ('\6435','\6438')+    , ('\6441','\6443')+    , ('\6448','\6449')+    , ('\6451','\6456')+    , ('\6576','\6592')+    , ('\6600','\6601')+    , ('\6681','\6683')+    , ('\6741','\6741')+    , ('\6743','\6743')+    , ('\6753','\6753')+    , ('\6755','\6756')+    , ('\6765','\6770')+    , ('\6916','\6916')+    , ('\6965','\6965')+    , ('\6971','\6971')+    , ('\6973','\6977')+    , ('\6979','\6980')+    , ('\7042','\7042')+    , ('\7073','\7073')+    , ('\7078','\7079')+    , ('\7082','\7082')+    , ('\7204','\7211')+    , ('\7220','\7221')+    , ('\7393','\7393')+    , ('\7410','\7410')+    , ('\43043','\43044')+    , ('\43047','\43047')+    , ('\43136','\43137')+    , ('\43188','\43203')+    , ('\43346','\43347')+    , ('\43395','\43395')+    , ('\43444','\43445')+    , ('\43450','\43451')+    , ('\43453','\43456')+    , ('\43567','\43568')+    , ('\43571','\43572')+    , ('\43597','\43597')+    , ('\43643','\43643')+    , ('\44003','\44004')+    , ('\44006','\44007')+    , ('\44009','\44010')+    , ('\44012','\44012')+    , ('\69762','\69762')+    , ('\69808','\69810')+    , ('\69815','\69816')+    , ('\119141','\119142')+    , ('\119149','\119154')+    ]++-- ------------------------------------------------------------++isUnicodeMe	:: Char -> Bool+isUnicodeMe c+  = isInList c+    [ ('\1160','\1161')+    , ('\1758','\1758')+    , ('\8413','\8416')+    , ('\8418','\8420')+    , ('\42608','\42610')+    ]++-- ------------------------------------------------------------++isUnicodeMn	:: Char -> Bool+isUnicodeMn c+  = isInList c+    [ ('\768','\879')+    , ('\1155','\1159')+    , ('\1425','\1469')+    , ('\1471','\1471')+    , ('\1473','\1474')+    , ('\1476','\1477')+    , ('\1479','\1479')+    , ('\1552','\1562')+    , ('\1611','\1630')+    , ('\1648','\1648')+    , ('\1750','\1756')+    , ('\1759','\1764')+    , ('\1767','\1768')+    , ('\1770','\1773')+    , ('\1809','\1809')+    , ('\1840','\1866')+    , ('\1958','\1968')+    , ('\2027','\2035')+    , ('\2070','\2073')+    , ('\2075','\2083')+    , ('\2085','\2087')+    , ('\2089','\2093')+    , ('\2304','\2306')+    , ('\2364','\2364')+    , ('\2369','\2376')+    , ('\2381','\2381')+    , ('\2385','\2389')+    , ('\2402','\2403')+    , ('\2433','\2433')+    , ('\2492','\2492')+    , ('\2497','\2500')+    , ('\2509','\2509')+    , ('\2530','\2531')+    , ('\2561','\2562')+    , ('\2620','\2620')+    , ('\2625','\2626')+    , ('\2631','\2632')+    , ('\2635','\2637')+    , ('\2641','\2641')+    , ('\2672','\2673')+    , ('\2677','\2677')+    , ('\2689','\2690')+    , ('\2748','\2748')+    , ('\2753','\2757')+    , ('\2759','\2760')+    , ('\2765','\2765')+    , ('\2786','\2787')+    , ('\2817','\2817')+    , ('\2876','\2876')+    , ('\2879','\2879')+    , ('\2881','\2884')+    , ('\2893','\2893')+    , ('\2902','\2902')+    , ('\2914','\2915')+    , ('\2946','\2946')+    , ('\3008','\3008')+    , ('\3021','\3021')+    , ('\3134','\3136')+    , ('\3142','\3144')+    , ('\3146','\3149')+    , ('\3157','\3158')+    , ('\3170','\3171')+    , ('\3260','\3260')+    , ('\3263','\3263')+    , ('\3270','\3270')+    , ('\3276','\3277')+    , ('\3298','\3299')+    , ('\3393','\3396')+    , ('\3405','\3405')+    , ('\3426','\3427')+    , ('\3530','\3530')+    , ('\3538','\3540')+    , ('\3542','\3542')+    , ('\3633','\3633')+    , ('\3636','\3642')+    , ('\3655','\3662')+    , ('\3761','\3761')+    , ('\3764','\3769')+    , ('\3771','\3772')+    , ('\3784','\3789')+    , ('\3864','\3865')+    , ('\3893','\3893')+    , ('\3895','\3895')+    , ('\3897','\3897')+    , ('\3953','\3966')+    , ('\3968','\3972')+    , ('\3974','\3975')+    , ('\3984','\3991')+    , ('\3993','\4028')+    , ('\4038','\4038')+    , ('\4141','\4144')+    , ('\4146','\4151')+    , ('\4153','\4154')+    , ('\4157','\4158')+    , ('\4184','\4185')+    , ('\4190','\4192')+    , ('\4209','\4212')+    , ('\4226','\4226')+    , ('\4229','\4230')+    , ('\4237','\4237')+    , ('\4253','\4253')+    , ('\4959','\4959')+    , ('\5906','\5908')+    , ('\5938','\5940')+    , ('\5970','\5971')+    , ('\6002','\6003')+    , ('\6071','\6077')+    , ('\6086','\6086')+    , ('\6089','\6099')+    , ('\6109','\6109')+    , ('\6155','\6157')+    , ('\6313','\6313')+    , ('\6432','\6434')+    , ('\6439','\6440')+    , ('\6450','\6450')+    , ('\6457','\6459')+    , ('\6679','\6680')+    , ('\6742','\6742')+    , ('\6744','\6750')+    , ('\6752','\6752')+    , ('\6754','\6754')+    , ('\6757','\6764')+    , ('\6771','\6780')+    , ('\6783','\6783')+    , ('\6912','\6915')+    , ('\6964','\6964')+    , ('\6966','\6970')+    , ('\6972','\6972')+    , ('\6978','\6978')+    , ('\7019','\7027')+    , ('\7040','\7041')+    , ('\7074','\7077')+    , ('\7080','\7081')+    , ('\7212','\7219')+    , ('\7222','\7223')+    , ('\7376','\7378')+    , ('\7380','\7392')+    , ('\7394','\7400')+    , ('\7405','\7405')+    , ('\7616','\7654')+    , ('\7677','\7679')+    , ('\8400','\8412')+    , ('\8417','\8417')+    , ('\8421','\8432')+    , ('\11503','\11505')+    , ('\11744','\11775')+    , ('\12330','\12335')+    , ('\12441','\12442')+    , ('\42607','\42607')+    , ('\42620','\42621')+    , ('\42736','\42737')+    , ('\43010','\43010')+    , ('\43014','\43014')+    , ('\43019','\43019')+    , ('\43045','\43046')+    , ('\43204','\43204')+    , ('\43232','\43249')+    , ('\43302','\43309')+    , ('\43335','\43345')+    , ('\43392','\43394')+    , ('\43443','\43443')+    , ('\43446','\43449')+    , ('\43452','\43452')+    , ('\43561','\43566')+    , ('\43569','\43570')+    , ('\43573','\43574')+    , ('\43587','\43587')+    , ('\43596','\43596')+    , ('\43696','\43696')+    , ('\43698','\43700')+    , ('\43703','\43704')+    , ('\43710','\43711')+    , ('\43713','\43713')+    , ('\44005','\44005')+    , ('\44008','\44008')+    , ('\44013','\44013')+    , ('\64286','\64286')+    , ('\65024','\65039')+    , ('\65056','\65062')+    , ('\66045','\66045')+    , ('\68097','\68099')+    , ('\68101','\68102')+    , ('\68108','\68111')+    , ('\68152','\68154')+    , ('\68159','\68159')+    , ('\69760','\69761')+    , ('\69811','\69814')+    , ('\69817','\69818')+    , ('\119143','\119145')+    , ('\119163','\119170')+    , ('\119173','\119179')+    , ('\119210','\119213')+    , ('\119362','\119364')+    , ('\917760','\917999')+    ]++-- ------------------------------------------------------------++isUnicodeN	:: Char -> Bool+isUnicodeN c+  = isInList c+    [ ('0','9')+    , ('\178','\179')+    , ('\185','\185')+    , ('\188','\190')+    , ('\1632','\1641')+    , ('\1776','\1785')+    , ('\1984','\1993')+    , ('\2406','\2415')+    , ('\2534','\2543')+    , ('\2548','\2553')+    , ('\2662','\2671')+    , ('\2790','\2799')+    , ('\2918','\2927')+    , ('\3046','\3058')+    , ('\3174','\3183')+    , ('\3192','\3198')+    , ('\3302','\3311')+    , ('\3430','\3445')+    , ('\3664','\3673')+    , ('\3792','\3801')+    , ('\3872','\3891')+    , ('\4160','\4169')+    , ('\4240','\4249')+    , ('\4969','\4988')+    , ('\5870','\5872')+    , ('\6112','\6121')+    , ('\6128','\6137')+    , ('\6160','\6169')+    , ('\6470','\6479')+    , ('\6608','\6618')+    , ('\6784','\6793')+    , ('\6800','\6809')+    , ('\6992','\7001')+    , ('\7088','\7097')+    , ('\7232','\7241')+    , ('\7248','\7257')+    , ('\8304','\8304')+    , ('\8308','\8313')+    , ('\8320','\8329')+    , ('\8528','\8578')+    , ('\8581','\8585')+    , ('\9312','\9371')+    , ('\9450','\9471')+    , ('\10102','\10131')+    , ('\11517','\11517')+    , ('\12295','\12295')+    , ('\12321','\12329')+    , ('\12344','\12346')+    , ('\12690','\12693')+    , ('\12832','\12841')+    , ('\12881','\12895')+    , ('\12928','\12937')+    , ('\12977','\12991')+    , ('\42528','\42537')+    , ('\42726','\42735')+    , ('\43056','\43061')+    , ('\43216','\43225')+    , ('\43264','\43273')+    , ('\43472','\43481')+    , ('\43600','\43609')+    , ('\44016','\44025')+    , ('\65296','\65305')+    , ('\65799','\65843')+    , ('\65856','\65912')+    , ('\65930','\65930')+    , ('\66336','\66339')+    , ('\66369','\66369')+    , ('\66378','\66378')+    , ('\66513','\66517')+    , ('\66720','\66729')+    , ('\67672','\67679')+    , ('\67862','\67867')+    , ('\68160','\68167')+    , ('\68221','\68222')+    , ('\68440','\68447')+    , ('\68472','\68479')+    , ('\69216','\69246')+    , ('\74752','\74850')+    , ('\119648','\119665')+    , ('\120782','\120831')+    , ('\127232','\127242')+    ]++-- ------------------------------------------------------------++isUnicodeNd	:: Char -> Bool+isUnicodeNd c+  = isInList c+    [ ('0','9')+    , ('\1632','\1641')+    , ('\1776','\1785')+    , ('\1984','\1993')+    , ('\2406','\2415')+    , ('\2534','\2543')+    , ('\2662','\2671')+    , ('\2790','\2799')+    , ('\2918','\2927')+    , ('\3046','\3055')+    , ('\3174','\3183')+    , ('\3302','\3311')+    , ('\3430','\3439')+    , ('\3664','\3673')+    , ('\3792','\3801')+    , ('\3872','\3881')+    , ('\4160','\4169')+    , ('\4240','\4249')+    , ('\6112','\6121')+    , ('\6160','\6169')+    , ('\6470','\6479')+    , ('\6608','\6618')+    , ('\6784','\6793')+    , ('\6800','\6809')+    , ('\6992','\7001')+    , ('\7088','\7097')+    , ('\7232','\7241')+    , ('\7248','\7257')+    , ('\42528','\42537')+    , ('\43216','\43225')+    , ('\43264','\43273')+    , ('\43472','\43481')+    , ('\43600','\43609')+    , ('\44016','\44025')+    , ('\65296','\65305')+    , ('\66720','\66729')+    , ('\120782','\120831')+    ]++-- ------------------------------------------------------------++isUnicodeNl	:: Char -> Bool+isUnicodeNl c+  = isInList c+    [ ('\5870','\5872')+    , ('\8544','\8578')+    , ('\8581','\8584')+    , ('\12295','\12295')+    , ('\12321','\12329')+    , ('\12344','\12346')+    , ('\42726','\42735')+    , ('\65856','\65908')+    , ('\66369','\66369')+    , ('\66378','\66378')+    , ('\66513','\66517')+    , ('\74752','\74850')+    ]++-- ------------------------------------------------------------++isUnicodeNo	:: Char -> Bool+isUnicodeNo c+  = isInList c+    [ ('\178','\179')+    , ('\185','\185')+    , ('\188','\190')+    , ('\2548','\2553')+    , ('\3056','\3058')+    , ('\3192','\3198')+    , ('\3440','\3445')+    , ('\3882','\3891')+    , ('\4969','\4988')+    , ('\6128','\6137')+    , ('\8304','\8304')+    , ('\8308','\8313')+    , ('\8320','\8329')+    , ('\8528','\8543')+    , ('\8585','\8585')+    , ('\9312','\9371')+    , ('\9450','\9471')+    , ('\10102','\10131')+    , ('\11517','\11517')+    , ('\12690','\12693')+    , ('\12832','\12841')+    , ('\12881','\12895')+    , ('\12928','\12937')+    , ('\12977','\12991')+    , ('\43056','\43061')+    , ('\65799','\65843')+    , ('\65909','\65912')+    , ('\65930','\65930')+    , ('\66336','\66339')+    , ('\67672','\67679')+    , ('\67862','\67867')+    , ('\68160','\68167')+    , ('\68221','\68222')+    , ('\68440','\68447')+    , ('\68472','\68479')+    , ('\69216','\69246')+    , ('\119648','\119665')+    , ('\127232','\127242')+    ]++-- ------------------------------------------------------------++isUnicodeP	:: Char -> Bool+isUnicodeP c+  = isInList c+    [ ('!','#')+    , ('%','*')+    , (',','/')+    , (':',';')+    , ('?','@')+    , ('[',']')+    , ('_','_')+    , ('{','{')+    , ('}','}')+    , ('\161','\161')+    , ('\171','\171')+    , ('\183','\183')+    , ('\187','\187')+    , ('\191','\191')+    , ('\894','\894')+    , ('\903','\903')+    , ('\1370','\1375')+    , ('\1417','\1418')+    , ('\1470','\1470')+    , ('\1472','\1472')+    , ('\1475','\1475')+    , ('\1478','\1478')+    , ('\1523','\1524')+    , ('\1545','\1546')+    , ('\1548','\1549')+    , ('\1563','\1563')+    , ('\1566','\1567')+    , ('\1642','\1645')+    , ('\1748','\1748')+    , ('\1792','\1805')+    , ('\2039','\2041')+    , ('\2096','\2110')+    , ('\2404','\2405')+    , ('\2416','\2416')+    , ('\3572','\3572')+    , ('\3663','\3663')+    , ('\3674','\3675')+    , ('\3844','\3858')+    , ('\3898','\3901')+    , ('\3973','\3973')+    , ('\4048','\4052')+    , ('\4170','\4175')+    , ('\4347','\4347')+    , ('\4961','\4968')+    , ('\5120','\5120')+    , ('\5741','\5742')+    , ('\5787','\5788')+    , ('\5867','\5869')+    , ('\5941','\5942')+    , ('\6100','\6102')+    , ('\6104','\6106')+    , ('\6144','\6154')+    , ('\6468','\6469')+    , ('\6622','\6623')+    , ('\6686','\6687')+    , ('\6816','\6822')+    , ('\6824','\6829')+    , ('\7002','\7008')+    , ('\7227','\7231')+    , ('\7294','\7295')+    , ('\7379','\7379')+    , ('\8208','\8231')+    , ('\8240','\8259')+    , ('\8261','\8273')+    , ('\8275','\8286')+    , ('\8317','\8318')+    , ('\8333','\8334')+    , ('\9001','\9002')+    , ('\10088','\10101')+    , ('\10181','\10182')+    , ('\10214','\10223')+    , ('\10627','\10648')+    , ('\10712','\10715')+    , ('\10748','\10749')+    , ('\11513','\11516')+    , ('\11518','\11519')+    , ('\11776','\11822')+    , ('\11824','\11825')+    , ('\12289','\12291')+    , ('\12296','\12305')+    , ('\12308','\12319')+    , ('\12336','\12336')+    , ('\12349','\12349')+    , ('\12448','\12448')+    , ('\12539','\12539')+    , ('\42238','\42239')+    , ('\42509','\42511')+    , ('\42611','\42611')+    , ('\42622','\42622')+    , ('\42738','\42743')+    , ('\43124','\43127')+    , ('\43214','\43215')+    , ('\43256','\43258')+    , ('\43310','\43311')+    , ('\43359','\43359')+    , ('\43457','\43469')+    , ('\43486','\43487')+    , ('\43612','\43615')+    , ('\43742','\43743')+    , ('\44011','\44011')+    , ('\64830','\64831')+    , ('\65040','\65049')+    , ('\65072','\65106')+    , ('\65108','\65121')+    , ('\65123','\65123')+    , ('\65128','\65128')+    , ('\65130','\65131')+    , ('\65281','\65283')+    , ('\65285','\65290')+    , ('\65292','\65295')+    , ('\65306','\65307')+    , ('\65311','\65312')+    , ('\65339','\65341')+    , ('\65343','\65343')+    , ('\65371','\65371')+    , ('\65373','\65373')+    , ('\65375','\65381')+    , ('\65792','\65793')+    , ('\66463','\66463')+    , ('\66512','\66512')+    , ('\67671','\67671')+    , ('\67871','\67871')+    , ('\67903','\67903')+    , ('\68176','\68184')+    , ('\68223','\68223')+    , ('\68409','\68415')+    , ('\69819','\69820')+    , ('\69822','\69825')+    , ('\74864','\74867')+    ]++-- ------------------------------------------------------------++isUnicodePc	:: Char -> Bool+isUnicodePc c+  = isInList c+    [ ('_','_')+    , ('\8255','\8256')+    , ('\8276','\8276')+    , ('\65075','\65076')+    , ('\65101','\65103')+    , ('\65343','\65343')+    ]++-- ------------------------------------------------------------++isUnicodePd	:: Char -> Bool+isUnicodePd c+  = isInList c+    [ ('-','-')+    , ('\1418','\1418')+    , ('\1470','\1470')+    , ('\5120','\5120')+    , ('\6150','\6150')+    , ('\8208','\8213')+    , ('\11799','\11799')+    , ('\11802','\11802')+    , ('\12316','\12316')+    , ('\12336','\12336')+    , ('\12448','\12448')+    , ('\65073','\65074')+    , ('\65112','\65112')+    , ('\65123','\65123')+    , ('\65293','\65293')+    ]++-- ------------------------------------------------------------++isUnicodePe	:: Char -> Bool+isUnicodePe c+  = isInList c+    [ (')',')')+    , (']',']')+    , ('}','}')+    , ('\3899','\3899')+    , ('\3901','\3901')+    , ('\5788','\5788')+    , ('\8262','\8262')+    , ('\8318','\8318')+    , ('\8334','\8334')+    , ('\9002','\9002')+    , ('\10089','\10089')+    , ('\10091','\10091')+    , ('\10093','\10093')+    , ('\10095','\10095')+    , ('\10097','\10097')+    , ('\10099','\10099')+    , ('\10101','\10101')+    , ('\10182','\10182')+    , ('\10215','\10215')+    , ('\10217','\10217')+    , ('\10219','\10219')+    , ('\10221','\10221')+    , ('\10223','\10223')+    , ('\10628','\10628')+    , ('\10630','\10630')+    , ('\10632','\10632')+    , ('\10634','\10634')+    , ('\10636','\10636')+    , ('\10638','\10638')+    , ('\10640','\10640')+    , ('\10642','\10642')+    , ('\10644','\10644')+    , ('\10646','\10646')+    , ('\10648','\10648')+    , ('\10713','\10713')+    , ('\10715','\10715')+    , ('\10749','\10749')+    , ('\11811','\11811')+    , ('\11813','\11813')+    , ('\11815','\11815')+    , ('\11817','\11817')+    , ('\12297','\12297')+    , ('\12299','\12299')+    , ('\12301','\12301')+    , ('\12303','\12303')+    , ('\12305','\12305')+    , ('\12309','\12309')+    , ('\12311','\12311')+    , ('\12313','\12313')+    , ('\12315','\12315')+    , ('\12318','\12319')+    , ('\64831','\64831')+    , ('\65048','\65048')+    , ('\65078','\65078')+    , ('\65080','\65080')+    , ('\65082','\65082')+    , ('\65084','\65084')+    , ('\65086','\65086')+    , ('\65088','\65088')+    , ('\65090','\65090')+    , ('\65092','\65092')+    , ('\65096','\65096')+    , ('\65114','\65114')+    , ('\65116','\65116')+    , ('\65118','\65118')+    , ('\65289','\65289')+    , ('\65341','\65341')+    , ('\65373','\65373')+    , ('\65376','\65376')+    , ('\65379','\65379')+    ]++-- ------------------------------------------------------------++isUnicodePf	:: Char -> Bool+isUnicodePf c+  = isInList c+    [ ('\187','\187')+    , ('\8217','\8217')+    , ('\8221','\8221')+    , ('\8250','\8250')+    , ('\11779','\11779')+    , ('\11781','\11781')+    , ('\11786','\11786')+    , ('\11789','\11789')+    , ('\11805','\11805')+    , ('\11809','\11809')+    ]++-- ------------------------------------------------------------++isUnicodePi	:: Char -> Bool+isUnicodePi c+  = isInList c+    [ ('\171','\171')+    , ('\8216','\8216')+    , ('\8219','\8220')+    , ('\8223','\8223')+    , ('\8249','\8249')+    , ('\11778','\11778')+    , ('\11780','\11780')+    , ('\11785','\11785')+    , ('\11788','\11788')+    , ('\11804','\11804')+    , ('\11808','\11808')+    ]++-- ------------------------------------------------------------++isUnicodePo	:: Char -> Bool+isUnicodePo c+  = isInList c+    [ ('!','#')+    , ('%','\'')+    , ('*','*')+    , (',',',')+    , ('.','/')+    , (':',';')+    , ('?','@')+    , ('\\','\\')+    , ('\161','\161')+    , ('\183','\183')+    , ('\191','\191')+    , ('\894','\894')+    , ('\903','\903')+    , ('\1370','\1375')+    , ('\1417','\1417')+    , ('\1472','\1472')+    , ('\1475','\1475')+    , ('\1478','\1478')+    , ('\1523','\1524')+    , ('\1545','\1546')+    , ('\1548','\1549')+    , ('\1563','\1563')+    , ('\1566','\1567')+    , ('\1642','\1645')+    , ('\1748','\1748')+    , ('\1792','\1805')+    , ('\2039','\2041')+    , ('\2096','\2110')+    , ('\2404','\2405')+    , ('\2416','\2416')+    , ('\3572','\3572')+    , ('\3663','\3663')+    , ('\3674','\3675')+    , ('\3844','\3858')+    , ('\3973','\3973')+    , ('\4048','\4052')+    , ('\4170','\4175')+    , ('\4347','\4347')+    , ('\4961','\4968')+    , ('\5741','\5742')+    , ('\5867','\5869')+    , ('\5941','\5942')+    , ('\6100','\6102')+    , ('\6104','\6106')+    , ('\6144','\6149')+    , ('\6151','\6154')+    , ('\6468','\6469')+    , ('\6622','\6623')+    , ('\6686','\6687')+    , ('\6816','\6822')+    , ('\6824','\6829')+    , ('\7002','\7008')+    , ('\7227','\7231')+    , ('\7294','\7295')+    , ('\7379','\7379')+    , ('\8214','\8215')+    , ('\8224','\8231')+    , ('\8240','\8248')+    , ('\8251','\8254')+    , ('\8257','\8259')+    , ('\8263','\8273')+    , ('\8275','\8275')+    , ('\8277','\8286')+    , ('\11513','\11516')+    , ('\11518','\11519')+    , ('\11776','\11777')+    , ('\11782','\11784')+    , ('\11787','\11787')+    , ('\11790','\11798')+    , ('\11800','\11801')+    , ('\11803','\11803')+    , ('\11806','\11807')+    , ('\11818','\11822')+    , ('\11824','\11825')+    , ('\12289','\12291')+    , ('\12349','\12349')+    , ('\12539','\12539')+    , ('\42238','\42239')+    , ('\42509','\42511')+    , ('\42611','\42611')+    , ('\42622','\42622')+    , ('\42738','\42743')+    , ('\43124','\43127')+    , ('\43214','\43215')+    , ('\43256','\43258')+    , ('\43310','\43311')+    , ('\43359','\43359')+    , ('\43457','\43469')+    , ('\43486','\43487')+    , ('\43612','\43615')+    , ('\43742','\43743')+    , ('\44011','\44011')+    , ('\65040','\65046')+    , ('\65049','\65049')+    , ('\65072','\65072')+    , ('\65093','\65094')+    , ('\65097','\65100')+    , ('\65104','\65106')+    , ('\65108','\65111')+    , ('\65119','\65121')+    , ('\65128','\65128')+    , ('\65130','\65131')+    , ('\65281','\65283')+    , ('\65285','\65287')+    , ('\65290','\65290')+    , ('\65292','\65292')+    , ('\65294','\65295')+    , ('\65306','\65307')+    , ('\65311','\65312')+    , ('\65340','\65340')+    , ('\65377','\65377')+    , ('\65380','\65381')+    , ('\65792','\65793')+    , ('\66463','\66463')+    , ('\66512','\66512')+    , ('\67671','\67671')+    , ('\67871','\67871')+    , ('\67903','\67903')+    , ('\68176','\68184')+    , ('\68223','\68223')+    , ('\68409','\68415')+    , ('\69819','\69820')+    , ('\69822','\69825')+    , ('\74864','\74867')+    ]++-- ------------------------------------------------------------++isUnicodePs	:: Char -> Bool+isUnicodePs c+  = isInList c+    [ ('(','(')+    , ('[','[')+    , ('{','{')+    , ('\3898','\3898')+    , ('\3900','\3900')+    , ('\5787','\5787')+    , ('\8218','\8218')+    , ('\8222','\8222')+    , ('\8261','\8261')+    , ('\8317','\8317')+    , ('\8333','\8333')+    , ('\9001','\9001')+    , ('\10088','\10088')+    , ('\10090','\10090')+    , ('\10092','\10092')+    , ('\10094','\10094')+    , ('\10096','\10096')+    , ('\10098','\10098')+    , ('\10100','\10100')+    , ('\10181','\10181')+    , ('\10214','\10214')+    , ('\10216','\10216')+    , ('\10218','\10218')+    , ('\10220','\10220')+    , ('\10222','\10222')+    , ('\10627','\10627')+    , ('\10629','\10629')+    , ('\10631','\10631')+    , ('\10633','\10633')+    , ('\10635','\10635')+    , ('\10637','\10637')+    , ('\10639','\10639')+    , ('\10641','\10641')+    , ('\10643','\10643')+    , ('\10645','\10645')+    , ('\10647','\10647')+    , ('\10712','\10712')+    , ('\10714','\10714')+    , ('\10748','\10748')+    , ('\11810','\11810')+    , ('\11812','\11812')+    , ('\11814','\11814')+    , ('\11816','\11816')+    , ('\12296','\12296')+    , ('\12298','\12298')+    , ('\12300','\12300')+    , ('\12302','\12302')+    , ('\12304','\12304')+    , ('\12308','\12308')+    , ('\12310','\12310')+    , ('\12312','\12312')+    , ('\12314','\12314')+    , ('\12317','\12317')+    , ('\64830','\64830')+    , ('\65047','\65047')+    , ('\65077','\65077')+    , ('\65079','\65079')+    , ('\65081','\65081')+    , ('\65083','\65083')+    , ('\65085','\65085')+    , ('\65087','\65087')+    , ('\65089','\65089')+    , ('\65091','\65091')+    , ('\65095','\65095')+    , ('\65113','\65113')+    , ('\65115','\65115')+    , ('\65117','\65117')+    , ('\65288','\65288')+    , ('\65339','\65339')+    , ('\65371','\65371')+    , ('\65375','\65375')+    , ('\65378','\65378')+    ]++-- ------------------------------------------------------------++isUnicodeS	:: Char -> Bool+isUnicodeS c+  = isInList c+    [ ('$','$')+    , ('+','+')+    , ('<','>')+    , ('^','^')+    , ('`','`')+    , ('|','|')+    , ('~','~')+    , ('\162','\169')+    , ('\172','\172')+    , ('\174','\177')+    , ('\180','\180')+    , ('\182','\182')+    , ('\184','\184')+    , ('\215','\215')+    , ('\247','\247')+    , ('\706','\709')+    , ('\722','\735')+    , ('\741','\747')+    , ('\749','\749')+    , ('\751','\767')+    , ('\885','\885')+    , ('\900','\901')+    , ('\1014','\1014')+    , ('\1154','\1154')+    , ('\1542','\1544')+    , ('\1547','\1547')+    , ('\1550','\1551')+    , ('\1769','\1769')+    , ('\1789','\1790')+    , ('\2038','\2038')+    , ('\2546','\2547')+    , ('\2554','\2555')+    , ('\2801','\2801')+    , ('\2928','\2928')+    , ('\3059','\3066')+    , ('\3199','\3199')+    , ('\3313','\3314')+    , ('\3449','\3449')+    , ('\3647','\3647')+    , ('\3841','\3843')+    , ('\3859','\3863')+    , ('\3866','\3871')+    , ('\3892','\3892')+    , ('\3894','\3894')+    , ('\3896','\3896')+    , ('\4030','\4037')+    , ('\4039','\4044')+    , ('\4046','\4047')+    , ('\4053','\4056')+    , ('\4254','\4255')+    , ('\4960','\4960')+    , ('\5008','\5017')+    , ('\6107','\6107')+    , ('\6464','\6464')+    , ('\6624','\6655')+    , ('\7009','\7018')+    , ('\7028','\7036')+    , ('\8125','\8125')+    , ('\8127','\8129')+    , ('\8141','\8143')+    , ('\8157','\8159')+    , ('\8173','\8175')+    , ('\8189','\8190')+    , ('\8260','\8260')+    , ('\8274','\8274')+    , ('\8314','\8316')+    , ('\8330','\8332')+    , ('\8352','\8376')+    , ('\8448','\8449')+    , ('\8451','\8454')+    , ('\8456','\8457')+    , ('\8468','\8468')+    , ('\8470','\8472')+    , ('\8478','\8483')+    , ('\8485','\8485')+    , ('\8487','\8487')+    , ('\8489','\8489')+    , ('\8494','\8494')+    , ('\8506','\8507')+    , ('\8512','\8516')+    , ('\8522','\8525')+    , ('\8527','\8527')+    , ('\8592','\9000')+    , ('\9003','\9192')+    , ('\9216','\9254')+    , ('\9280','\9290')+    , ('\9372','\9449')+    , ('\9472','\9933')+    , ('\9935','\9953')+    , ('\9955','\9955')+    , ('\9960','\9983')+    , ('\9985','\9988')+    , ('\9990','\9993')+    , ('\9996','\10023')+    , ('\10025','\10059')+    , ('\10061','\10061')+    , ('\10063','\10066')+    , ('\10070','\10078')+    , ('\10081','\10087')+    , ('\10132','\10132')+    , ('\10136','\10159')+    , ('\10161','\10174')+    , ('\10176','\10180')+    , ('\10183','\10186')+    , ('\10188','\10188')+    , ('\10192','\10213')+    , ('\10224','\10626')+    , ('\10649','\10711')+    , ('\10716','\10747')+    , ('\10750','\11084')+    , ('\11088','\11097')+    , ('\11493','\11498')+    , ('\11904','\11929')+    , ('\11931','\12019')+    , ('\12032','\12245')+    , ('\12272','\12283')+    , ('\12292','\12292')+    , ('\12306','\12307')+    , ('\12320','\12320')+    , ('\12342','\12343')+    , ('\12350','\12351')+    , ('\12443','\12444')+    , ('\12688','\12689')+    , ('\12694','\12703')+    , ('\12736','\12771')+    , ('\12800','\12830')+    , ('\12842','\12880')+    , ('\12896','\12927')+    , ('\12938','\12976')+    , ('\12992','\13054')+    , ('\13056','\13311')+    , ('\19904','\19967')+    , ('\42128','\42182')+    , ('\42752','\42774')+    , ('\42784','\42785')+    , ('\42889','\42890')+    , ('\43048','\43051')+    , ('\43062','\43065')+    , ('\43639','\43641')+    , ('\64297','\64297')+    , ('\65020','\65021')+    , ('\65122','\65122')+    , ('\65124','\65126')+    , ('\65129','\65129')+    , ('\65284','\65284')+    , ('\65291','\65291')+    , ('\65308','\65310')+    , ('\65342','\65342')+    , ('\65344','\65344')+    , ('\65372','\65372')+    , ('\65374','\65374')+    , ('\65504','\65510')+    , ('\65512','\65518')+    , ('\65532','\65533')+    , ('\65794','\65794')+    , ('\65847','\65855')+    , ('\65913','\65929')+    , ('\65936','\65947')+    , ('\66000','\66044')+    , ('\118784','\119029')+    , ('\119040','\119078')+    , ('\119081','\119140')+    , ('\119146','\119148')+    , ('\119171','\119172')+    , ('\119180','\119209')+    , ('\119214','\119261')+    , ('\119296','\119361')+    , ('\119365','\119365')+    , ('\119552','\119638')+    , ('\120513','\120513')+    , ('\120539','\120539')+    , ('\120571','\120571')+    , ('\120597','\120597')+    , ('\120629','\120629')+    , ('\120655','\120655')+    , ('\120687','\120687')+    , ('\120713','\120713')+    , ('\120745','\120745')+    , ('\120771','\120771')+    , ('\126976','\127019')+    , ('\127024','\127123')+    , ('\127248','\127278')+    , ('\127281','\127281')+    , ('\127293','\127293')+    , ('\127295','\127295')+    , ('\127298','\127298')+    , ('\127302','\127302')+    , ('\127306','\127310')+    , ('\127319','\127319')+    , ('\127327','\127327')+    , ('\127353','\127353')+    , ('\127355','\127356')+    , ('\127359','\127359')+    , ('\127370','\127373')+    , ('\127376','\127376')+    , ('\127488','\127488')+    , ('\127504','\127537')+    , ('\127552','\127560')+    ]++-- ------------------------------------------------------------++isUnicodeSc	:: Char -> Bool+isUnicodeSc c+  = isInList c+    [ ('$','$')+    , ('\162','\165')+    , ('\1547','\1547')+    , ('\2546','\2547')+    , ('\2555','\2555')+    , ('\2801','\2801')+    , ('\3065','\3065')+    , ('\3647','\3647')+    , ('\6107','\6107')+    , ('\8352','\8376')+    , ('\43064','\43064')+    , ('\65020','\65020')+    , ('\65129','\65129')+    , ('\65284','\65284')+    , ('\65504','\65505')+    , ('\65509','\65510')+    ]++-- ------------------------------------------------------------++isUnicodeSk	:: Char -> Bool+isUnicodeSk c+  = isInList c+    [ ('^','^')+    , ('`','`')+    , ('\168','\168')+    , ('\175','\175')+    , ('\180','\180')+    , ('\184','\184')+    , ('\706','\709')+    , ('\722','\735')+    , ('\741','\747')+    , ('\749','\749')+    , ('\751','\767')+    , ('\885','\885')+    , ('\900','\901')+    , ('\8125','\8125')+    , ('\8127','\8129')+    , ('\8141','\8143')+    , ('\8157','\8159')+    , ('\8173','\8175')+    , ('\8189','\8190')+    , ('\12443','\12444')+    , ('\42752','\42774')+    , ('\42784','\42785')+    , ('\42889','\42890')+    , ('\65342','\65342')+    , ('\65344','\65344')+    , ('\65507','\65507')+    ]++-- ------------------------------------------------------------++isUnicodeSm	:: Char -> Bool+isUnicodeSm c+  = isInList c+    [ ('+','+')+    , ('<','>')+    , ('|','|')+    , ('~','~')+    , ('\172','\172')+    , ('\177','\177')+    , ('\215','\215')+    , ('\247','\247')+    , ('\1014','\1014')+    , ('\1542','\1544')+    , ('\8260','\8260')+    , ('\8274','\8274')+    , ('\8314','\8316')+    , ('\8330','\8332')+    , ('\8512','\8516')+    , ('\8523','\8523')+    , ('\8592','\8596')+    , ('\8602','\8603')+    , ('\8608','\8608')+    , ('\8611','\8611')+    , ('\8614','\8614')+    , ('\8622','\8622')+    , ('\8654','\8655')+    , ('\8658','\8658')+    , ('\8660','\8660')+    , ('\8692','\8959')+    , ('\8968','\8971')+    , ('\8992','\8993')+    , ('\9084','\9084')+    , ('\9115','\9139')+    , ('\9180','\9185')+    , ('\9655','\9655')+    , ('\9665','\9665')+    , ('\9720','\9727')+    , ('\9839','\9839')+    , ('\10176','\10180')+    , ('\10183','\10186')+    , ('\10188','\10188')+    , ('\10192','\10213')+    , ('\10224','\10239')+    , ('\10496','\10626')+    , ('\10649','\10711')+    , ('\10716','\10747')+    , ('\10750','\11007')+    , ('\11056','\11076')+    , ('\11079','\11084')+    , ('\64297','\64297')+    , ('\65122','\65122')+    , ('\65124','\65126')+    , ('\65291','\65291')+    , ('\65308','\65310')+    , ('\65372','\65372')+    , ('\65374','\65374')+    , ('\65506','\65506')+    , ('\65513','\65516')+    , ('\120513','\120513')+    , ('\120539','\120539')+    , ('\120571','\120571')+    , ('\120597','\120597')+    , ('\120629','\120629')+    , ('\120655','\120655')+    , ('\120687','\120687')+    , ('\120713','\120713')+    , ('\120745','\120745')+    , ('\120771','\120771')+    ]++-- ------------------------------------------------------------++isUnicodeSo	:: Char -> Bool+isUnicodeSo c+  = isInList c+    [ ('\166','\167')+    , ('\169','\169')+    , ('\174','\174')+    , ('\176','\176')+    , ('\182','\182')+    , ('\1154','\1154')+    , ('\1550','\1551')+    , ('\1769','\1769')+    , ('\1789','\1790')+    , ('\2038','\2038')+    , ('\2554','\2554')+    , ('\2928','\2928')+    , ('\3059','\3064')+    , ('\3066','\3066')+    , ('\3199','\3199')+    , ('\3313','\3314')+    , ('\3449','\3449')+    , ('\3841','\3843')+    , ('\3859','\3863')+    , ('\3866','\3871')+    , ('\3892','\3892')+    , ('\3894','\3894')+    , ('\3896','\3896')+    , ('\4030','\4037')+    , ('\4039','\4044')+    , ('\4046','\4047')+    , ('\4053','\4056')+    , ('\4254','\4255')+    , ('\4960','\4960')+    , ('\5008','\5017')+    , ('\6464','\6464')+    , ('\6624','\6655')+    , ('\7009','\7018')+    , ('\7028','\7036')+    , ('\8448','\8449')+    , ('\8451','\8454')+    , ('\8456','\8457')+    , ('\8468','\8468')+    , ('\8470','\8472')+    , ('\8478','\8483')+    , ('\8485','\8485')+    , ('\8487','\8487')+    , ('\8489','\8489')+    , ('\8494','\8494')+    , ('\8506','\8507')+    , ('\8522','\8522')+    , ('\8524','\8525')+    , ('\8527','\8527')+    , ('\8597','\8601')+    , ('\8604','\8607')+    , ('\8609','\8610')+    , ('\8612','\8613')+    , ('\8615','\8621')+    , ('\8623','\8653')+    , ('\8656','\8657')+    , ('\8659','\8659')+    , ('\8661','\8691')+    , ('\8960','\8967')+    , ('\8972','\8991')+    , ('\8994','\9000')+    , ('\9003','\9083')+    , ('\9085','\9114')+    , ('\9140','\9179')+    , ('\9186','\9192')+    , ('\9216','\9254')+    , ('\9280','\9290')+    , ('\9372','\9449')+    , ('\9472','\9654')+    , ('\9656','\9664')+    , ('\9666','\9719')+    , ('\9728','\9838')+    , ('\9840','\9933')+    , ('\9935','\9953')+    , ('\9955','\9955')+    , ('\9960','\9983')+    , ('\9985','\9988')+    , ('\9990','\9993')+    , ('\9996','\10023')+    , ('\10025','\10059')+    , ('\10061','\10061')+    , ('\10063','\10066')+    , ('\10070','\10078')+    , ('\10081','\10087')+    , ('\10132','\10132')+    , ('\10136','\10159')+    , ('\10161','\10174')+    , ('\10240','\10495')+    , ('\11008','\11055')+    , ('\11077','\11078')+    , ('\11088','\11097')+    , ('\11493','\11498')+    , ('\11904','\11929')+    , ('\11931','\12019')+    , ('\12032','\12245')+    , ('\12272','\12283')+    , ('\12292','\12292')+    , ('\12306','\12307')+    , ('\12320','\12320')+    , ('\12342','\12343')+    , ('\12350','\12351')+    , ('\12688','\12689')+    , ('\12694','\12703')+    , ('\12736','\12771')+    , ('\12800','\12830')+    , ('\12842','\12880')+    , ('\12896','\12927')+    , ('\12938','\12976')+    , ('\12992','\13054')+    , ('\13056','\13311')+    , ('\19904','\19967')+    , ('\42128','\42182')+    , ('\43048','\43051')+    , ('\43062','\43063')+    , ('\43065','\43065')+    , ('\43639','\43641')+    , ('\65021','\65021')+    , ('\65508','\65508')+    , ('\65512','\65512')+    , ('\65517','\65518')+    , ('\65532','\65533')+    , ('\65794','\65794')+    , ('\65847','\65855')+    , ('\65913','\65929')+    , ('\65936','\65947')+    , ('\66000','\66044')+    , ('\118784','\119029')+    , ('\119040','\119078')+    , ('\119081','\119140')+    , ('\119146','\119148')+    , ('\119171','\119172')+    , ('\119180','\119209')+    , ('\119214','\119261')+    , ('\119296','\119361')+    , ('\119365','\119365')+    , ('\119552','\119638')+    , ('\126976','\127019')+    , ('\127024','\127123')+    , ('\127248','\127278')+    , ('\127281','\127281')+    , ('\127293','\127293')+    , ('\127295','\127295')+    , ('\127298','\127298')+    , ('\127302','\127302')+    , ('\127306','\127310')+    , ('\127319','\127319')+    , ('\127327','\127327')+    , ('\127353','\127353')+    , ('\127355','\127356')+    , ('\127359','\127359')+    , ('\127370','\127373')+    , ('\127376','\127376')+    , ('\127488','\127488')+    , ('\127504','\127537')+    , ('\127552','\127560')+    ]++-- ------------------------------------------------------------++isUnicodeZ	:: Char -> Bool+isUnicodeZ c+  = isInList c+    [ (' ',' ')+    , ('\160','\160')+    , ('\5760','\5760')+    , ('\6158','\6158')+    , ('\8192','\8202')+    , ('\8232','\8233')+    , ('\8239','\8239')+    , ('\8287','\8287')+    , ('\12288','\12288')+    ]++-- ------------------------------------------------------------++isUnicodeZl	:: Char -> Bool+isUnicodeZl c+  = isInList c+    [ ('\8232','\8232')+    ]++-- ------------------------------------------------------------++isUnicodeZp	:: Char -> Bool+isUnicodeZp c+  = isInList c+    [ ('\8233','\8233')+    ]++-- ------------------------------------------------------------++isUnicodeZs	:: Char -> Bool+isUnicodeZs c+  = isInList c+    [ (' ',' ')+    , ('\160','\160')+    , ('\5760','\5760')+    , ('\6158','\6158')+    , ('\8192','\8202')+    , ('\8239','\8239')+    , ('\8287','\8287')+    , ('\12288','\12288')+    ]++-- ------------------------------------------------------------+
+ src/Yuuko/Text/XML/HXT/RelaxNG/Utils.hs view
@@ -0,0 +1,161 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.RelaxNG.Utils+   Copyright  : Copyright (C) 2008 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : stable+   Portability: portable++   Helper functions for RelaxNG validation++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.RelaxNG.Utils+    ( isRelaxAnyURI+    , compareURI+    , normalizeURI+    , isNumber+    , isNmtoken+    , isName+    , formatStringList+    , formatStringListPatt+    , formatStringListId+    , formatStringListQuot+    , formatStringListPairs+    , formatStringListArr+    )+where++import Text.ParserCombinators.Parsec++import Yuuko.Text.XML.HXT.Parser.XmlTokenParser+    ( skipS0+    , nmtoken+    , name+    )++import Network.URI+    ( isURI+    , isRelativeReference+    , parseURI+    , URI(..)+    )++import Data.Maybe+    ( fromMaybe+    )++import Data.Char+    ( toLower+    )+++-- ------------------------------------------------------------+++-- | Tests whether a URI matches the Relax NG anyURI symbol++isRelaxAnyURI :: String -> Bool+isRelaxAnyURI s +    = s == "" ||+      ( isURI s && not (isRelativeReference s) &&+	( let (URI _ _ path _ frag) = fromMaybe (URI "" Nothing "" "" "") $ parseURI s+          in (frag == "" && path /= "")+	)+      )+++-- | Tests whether two URIs are equal after 'normalizeURI' is performed++compareURI :: String -> String -> Bool+compareURI uri1 uri2+    = normalizeURI uri1 == normalizeURI uri2+++-- |  Converts all letters to the corresponding lower-case letter +-- and removes a trailing \"\/\" ++normalizeURI :: String -> String+normalizeURI ""+    = ""+normalizeURI uri+    = map toLower ( if last uri == '/'+		    then init uri+		    else uri+		  )++checkByParsing	:: Parser String -> String -> Bool+checkByParsing p s+    = either (const False) (const True) (parse p' "" s)+      where+      p' = do+	   r <- p+	   eof+	   return r++-- | Tests whether a string matches a number [-](0-9)*+isNumber :: String -> Bool+isNumber+    = checkByParsing parseNumber'+    where+    parseNumber' :: Parser String+    parseNumber'+	= do+	  skipS0+	  m <- option "" (string "-")+	  n <- many1 digit+	  skipS0+	  return $ m ++ n++isNmtoken	:: String -> Bool+isNmtoken    = checkByParsing nmtoken++isName	:: String -> Bool+isName	= checkByParsing name++{- | ++Formats a list of strings into a single string.+The first parameter formats the elements, the 2. is inserted+between two elements.++example:++> formatStringList show ", " ["foo", "bar", "baz"] -> "foo", "bar", "baz"++-}++formatStringListPatt :: [String] -> String+formatStringListPatt+    = formatStringList (++ "-") ", "++formatStringListPairs :: [(String,String)] -> String+formatStringListPairs+    = formatStringList id ", "+      . map (\ (a, b) -> a ++ " = " ++ show b)++formatStringListQuot :: [String] -> String+formatStringListQuot+    = formatStringList show ", "++formatStringListId :: [String] -> String+formatStringListId+    = formatStringList id ", "++formatStringListArr :: [String] -> String+formatStringListArr+    = formatStringList show " -> "++formatStringList :: (String -> String) -> String -> [String] -> String+formatStringList _sf _sp []+    = ""+formatStringList sf spacer l+    = reverse $ drop (length spacer) $ reverse $ +      foldr (\e -> ((if e /= "" then sf e ++ spacer else "") ++)) "" l++-- ----------------------------------------
+ src/Yuuko/Text/XML/HXT/RelaxNG/Validation.hs view
@@ -0,0 +1,617 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.RelaxNG.Validation+   Copyright  : Copyright (C) 2008 Torben Kuseler, Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : stable+   Portability: portable++   Validation of a XML document with respect to a valid Relax NG schema in simple form.+   Copied and modified from \"An algorithm for RELAX NG validation\" by James Clark+   (<http://www.thaiopensource.com/relaxng/derivative.html>).++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.RelaxNG.Validation+    ( validateWithRelaxAndHandleErrors+    , validateDocWithRelax+    , validateRelax+    , validateXMLDoc+    , readForRelax+    , normalizeForRelaxValidation+    , contains+    )+where++import Yuuko.Control.Arrow.ListArrows++import           Yuuko.Text.XML.HXT.DOM.Interface+import qualified Yuuko.Text.XML.HXT.DOM.XmlNode as XN+import           Yuuko.Text.XML.HXT.DOM.Unicode+    ( isXmlSpaceChar+    )+++import Yuuko.Text.XML.HXT.Arrow.XmlArrow+import Yuuko.Text.XML.HXT.Arrow.XmlIOStateArrow++import Yuuko.Text.XML.HXT.Arrow.Edit+    ( canonicalizeAllNodes+    , collapseAllXText+    )++import Yuuko.Text.XML.HXT.Arrow.ProcessDocument+    ( propagateAndValidateNamespaces+    , getDocumentContents+    , parseXmlDocument+    )++import Yuuko.Text.XML.HXT.RelaxNG.DataTypes+import Yuuko.Text.XML.HXT.RelaxNG.CreatePattern+import Yuuko.Text.XML.HXT.RelaxNG.PatternToString+import Yuuko.Text.XML.HXT.RelaxNG.DataTypeLibraries+import Yuuko.Text.XML.HXT.RelaxNG.Utils+    ( formatStringListQuot+    , compareURI+    )++import Data.Maybe+    ( fromJust+    )++{-+import qualified Debug.Trace as T+-}++-- ------------------------------------------------------------++validateWithRelaxAndHandleErrors	:: IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree+validateWithRelaxAndHandleErrors theSchema+    = validateWithRelax theSchema+      >>>+      handleErrors++validateWithRelax	:: IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree+validateWithRelax theSchema+    = traceMsg 2 "validate with Relax NG schema"+      >>>+      ( ( normalizeForRelaxValidation		-- prepare the document for validation+	  >>>+	  getChildren+	  >>>+	  isElem				-- and select the root element+	)+	&&&+	theSchema+      )+      >>>+      arr2A validateRelax			-- compute vaidation errors as a document++handleErrors	:: IOSArrow XmlTree XmlTree+handleErrors+    = traceDoc "error found when validating with Relax NG schema"+      >>>+      ( getChildren				-- prepare error format+	>>>+	getText+	>>>+	arr ("Relax NG validation: " ++)+	>>>+	mkError c_err+      )+      >>>+      filterErrorMsg				-- issue errors and set system status+++{- |+   normalize a document for validation with Relax NG: remove all namespace declaration attributes,+   remove all processing instructions and merge all sequences of text nodes into a single text node+-}++normalizeForRelaxValidation :: ArrowXml a => a XmlTree XmlTree+normalizeForRelaxValidation+  = processTopDownWithAttrl+    (+     ( none `when`			-- remove all namespace attributes+       ( isAttr+         >>> +         getNamespaceUri+         >>>+         isA (compareURI xmlnsNamespace)+       )+     )+     >>>+     (none `when` isPi)			-- processing instructions+    )+    >>>+    collapseAllXText			-- all text node sequences are merged into a single text node++-- ------------------------------------------------------------++{- | Validates a xml document with respect to a Relax NG schema++   * 1.parameter  :  the arrow for computing the Relax NG schema++   - 2.parameter  :  list of options for reading and validating+   +   - 3.parameter  :  XML document URI++   - arrow-input  :  ignored+   +   - arrow-output :  list of errors or 'none'+-}  ++validateDocWithRelax :: IOSArrow XmlTree XmlTree -> Attributes -> String -> IOSArrow XmlTree XmlTree+validateDocWithRelax theSchema al doc+  = ( if null doc+      then root [] []+      else readForRelax al doc+    )+    >>>+    validateWithRelax theSchema+    >>>+    perform handleErrors+++{- | Validates a xml document with respect to a Relax NG schema++   * 1.parameter  :  XML document++   - arrow-input  :  Relax NG schema+   +   - arrow-output :  list of errors or 'none'+-}++validateRelax :: XmlTree -> IOSArrow XmlTree XmlTree+validateRelax xmlDoc+  = fromLA+    ( createPatternFromXmlTree+      >>>+      arr (\p -> childDeriv ("",[]) p xmlDoc)+      >>>+      ( (not . nullable)+        `guardsP`+        root [] [ (take 1024 . show) ^>> mkText ]	-- pattern may be recursive, so the string representation+	                                                -- is truncated to 1024 chars to assure termination+      )+    )++-- ------------------------------------------------------------++readForRelax	:: Attributes -> String -> IOSArrow b XmlTree+readForRelax options schema+    = getDocumentContents options schema+      >>>+      parseXmlDocument False+      >>>+      canonicalizeAllNodes+      >>>+      propagateAndValidateNamespaces++-- ------------------------------------------------------------++{- old stuff -}++validateXMLDoc :: Attributes -> String -> IOSArrow XmlTree XmlTree+validateXMLDoc al xmlDoc+  = validateRelax+    $<+    ( readForRelax al xmlDoc+      >>>+      normalizeForRelaxValidation+      >>>+      getChildren+    )+++-- ------------------------------------------------------------+--+-- | tests whether a 'NameClass' contains a particular 'QName'++contains :: NameClass -> QName -> Bool+contains AnyName _			= True+contains (AnyNameExcept nc)    n	= not (contains nc n)+contains (NsName ns1)          qn	= ns1 == namespaceUri qn+contains (NsNameExcept ns1 nc) qn	= ns1 == namespaceUri qn && not (contains nc qn)+contains (Name ns1 ln1)        qn	= (ns1 == namespaceUri qn) && (ln1 == localPart qn)+contains (NameClassChoice nc1 nc2) n 	= (contains nc1 n) || (contains nc2 n)+contains (NCError _) _ 			= False+++-- ------------------------------------------------------------+--  +-- | tests whether a pattern matches the empty sequence+nullable:: Pattern -> Bool+nullable (Group p1 p2)		= nullable p1 && nullable p2+nullable (Interleave p1 p2)	= nullable p1 && nullable p2+nullable (Choice p1 p2)		= nullable p1 || nullable p2+nullable (OneOrMore p)		= nullable p+nullable (Element _ _)		= False+nullable (Attribute _ _)	= False+nullable (List _)		= False+nullable (Value _ _ _)		= False+nullable (Data _ _)		= False+nullable (DataExcept _ _ _)	= False+nullable (NotAllowed _)		= False+nullable Empty			= True+nullable Text			= True+nullable (After _ _)		= False+++-- ------------------------------------------------------------+--  +-- | computes the derivative of a pattern with respect to a XML-Child and a 'Context'++childDeriv :: Context -> Pattern -> XmlTree -> Pattern++childDeriv cx p t+    | XN.isText t	= textDeriv cx p . fromJust . XN.getText $ t+    | XN.isElem t	= endTagDeriv p4+    | otherwise		= notAllowed "Call to childDeriv with wrong arguments"+    where+    children	=            XN.getChildren $ t+    qn		= fromJust . XN.getElemName $ t +    atts	= fromJust . XN.getAttrl    $ t+    cx1		= ("",[])+    p1		= startTagOpenDeriv p qn+    p2		= attsDeriv cx1 p1 atts+    p3		= startTagCloseDeriv p2+    p4		= childrenDeriv cx1 p3 children++-- ------------------------------------------------------------+--  +-- | computes the derivative of a pattern with respect to a text node++textDeriv :: Context -> Pattern -> String -> Pattern++textDeriv cx (Choice p1 p2) s+    = choice (textDeriv cx p1 s) (textDeriv cx p2 s)++textDeriv cx (Interleave p1 p2) s+    = choice+      (interleave (textDeriv cx p1 s) p2)+      (interleave p1 (textDeriv cx p2 s))++textDeriv cx (Group p1 p2) s+    = let+      p = group (textDeriv cx p1 s) p2+      in+      if nullable p1+      then choice p (textDeriv cx p2 s)+      else p++textDeriv cx (After p1 p2) s+    = after (textDeriv cx p1 s) p2++textDeriv cx (OneOrMore p) s+    = group (textDeriv cx p s) (choice (OneOrMore p) Empty)++textDeriv _ Text _+    = Text++textDeriv cx1 (Value (uri, s) value cx2) s1+    = case datatypeEqual uri s value cx2 s1 cx1+      of+      Nothing     -> Empty +      Just errStr -> notAllowed errStr++textDeriv cx (Data (uri, s) params) s1+    = case datatypeAllows uri s params s1 cx+      of+      Nothing     -> Empty +      Just errStr -> notAllowed2 errStr++textDeriv cx (DataExcept (uri, s) params p) s1+    = case (datatypeAllows uri s params s1 cx)+      of+      Nothing     -> if not $ nullable $ textDeriv cx p s1 +                     then Empty +		     else notAllowed+			      ( "Any value except " +++				show (show p) ++ +				" expected, but value " +++				show (show s1) +++				" found"+			      )+      Just errStr -> notAllowed errStr++textDeriv cx (List p) s+    = if nullable (listDeriv cx p (words s)) +      then Empty+      else notAllowed+	       ( "List with value(s) " +++		 show p ++ +		 " expected, but value(s) " ++ +		 formatStringListQuot (words s) +++		 " found"+	       )++textDeriv _ n@(NotAllowed _) _+    = n++textDeriv _ p s+    = notAllowed+      ( "Pattern " ++ show (getPatternName p) +++	" expected, but text " ++ show s ++ " found"+      )+++-- ------------------------------------------------------------+--  +-- | To compute the derivative of a pattern with respect to a list of strings, +-- simply compute the derivative with respect to each member of the list in turn.++listDeriv :: Context -> Pattern -> [String] -> Pattern++listDeriv _ p []+    = p++listDeriv cx p (x:xs)+    = listDeriv cx (textDeriv cx p x) xs+    ++-- ------------------------------------------------------------+--  +-- | computes the derivative of a pattern with respect to a start tag open++startTagOpenDeriv :: Pattern -> QName -> Pattern++startTagOpenDeriv (Choice p1 p2) qn+    = choice (startTagOpenDeriv p1 qn) (startTagOpenDeriv p2 qn)++startTagOpenDeriv (Element nc p) qn+    | contains nc qn+	= after p Empty+    | otherwise+	= notAllowed $+	  "Element with name " ++ nameClassToString nc ++ +	    " expected, but " ++ universalName qn ++ " found"++startTagOpenDeriv (Interleave p1 p2) qn+    = choice+      (applyAfter (flip interleave p2) (startTagOpenDeriv p1 qn))+      (applyAfter (interleave p1) (startTagOpenDeriv p2 qn))++startTagOpenDeriv (OneOrMore p) qn+    = applyAfter+      (flip group (choice (OneOrMore p) Empty))+      (startTagOpenDeriv p qn)++startTagOpenDeriv (Group p1 p2) qn+    = let+      x = applyAfter (flip group p2) (startTagOpenDeriv p1 qn)+      in+      if nullable p1 +      then choice x (startTagOpenDeriv p2 qn)+      else x++startTagOpenDeriv (After p1 p2) qn+    = applyAfter (flip after p2) (startTagOpenDeriv p1 qn)++startTagOpenDeriv n@(NotAllowed _) _+    = n++startTagOpenDeriv p qn+    = notAllowed ( show p ++ " expected, but Element " ++ universalName qn ++ " found" )++-- ------------------------------------------------------------++-- auxiliary functions for tracing+{-+attsDeriv' cx p ts+    = T.trace ("attsDeriv: p=" ++ (take 1000 . show) p ++ ", t=" ++ showXts ts) $+      T.trace ("res= " ++ (take 1000 . show) res) res+    where+    res = attsDeriv cx p ts++attDeriv' cx p t+    = T.trace ("attDeriv: p=" ++ (take 1000 . show) p ++ ", t=" ++ showXts [t]) $+      T.trace ("res= " ++ (take 1000 . show) res) res+    where+    res = attDeriv cx p t+-}++-- | To compute the derivative of a pattern with respect to a sequence of attributes, +-- simply compute the derivative with respect to each attribute in turn.++attsDeriv :: Context -> Pattern -> XmlTrees -> Pattern++attsDeriv _ p []+    = p+attsDeriv cx p (t : ts)+    | XN.isAttr t+	= attsDeriv cx (attDeriv cx p t) ts+    | otherwise+	= notAllowed "Call to attsDeriv with wrong arguments"++attDeriv :: Context -> Pattern -> XmlTree -> Pattern++attDeriv cx (After p1 p2) att+    = after (attDeriv cx p1 att) p2++attDeriv cx (Choice p1 p2) att+    = choice (attDeriv cx p1 att) (attDeriv cx p2 att)++attDeriv cx (Group p1 p2) att+    = choice+      (group (attDeriv cx p1 att) p2)+      (group p1 (attDeriv cx p2 att))++attDeriv cx (Interleave p1 p2) att+    = choice+      (interleave (attDeriv cx p1 att) p2)+      (interleave p1 (attDeriv cx p2 att))++attDeriv cx (OneOrMore p) att+    = group+      (attDeriv cx p att)+      (choice (OneOrMore p) Empty)++attDeriv cx (Attribute nc p) att+    | isa+      &&+      not (contains nc qn)+	= notAllowed1 $+	  "Attribute with name " ++ nameClassToString nc+          ++ " expected, but " ++ universalName qn ++ " found"+    | isa+      &&+      ( ( nullable p+	  &&+	  whitespace val+	)+	|| nullable p'+      )+	= Empty+    | isa+	= err' p'+    where+    isa =            XN.isAttr      $ att+    qn  = fromJust . XN.getAttrName $ att+    av  =            XN.getChildren $ att+    val = showXts av+    p'  = textDeriv cx p val++    err' (NotAllowed (ErrMsg _l es))+	= err'' (": " ++ head es)+    err' _+	= err'' ""+    err'' e+	= notAllowed2 $+	  "Attribute value \"" ++ val +++	  "\" does not match datatype spec " ++ show p ++ e++attDeriv _ n@(NotAllowed _) _+    = n++attDeriv _ _p att+    = notAllowed $+      "No matching pattern for attribute '" ++  showXts [att] ++ "' found"++-- ------------------------------------------------------------+--  +-- | computes the derivative of a pattern with respect to a start tag close++startTagCloseDeriv :: Pattern -> Pattern++startTagCloseDeriv (After p1 p2)+    = after (startTagCloseDeriv p1) p2++startTagCloseDeriv (Choice p1 p2)+    = choice+      (startTagCloseDeriv p1)+      (startTagCloseDeriv p2)++startTagCloseDeriv (Group p1 p2)+    = group+      (startTagCloseDeriv p1)+      (startTagCloseDeriv p2)++startTagCloseDeriv (Interleave p1 p2)+    = interleave+      (startTagCloseDeriv p1)+      (startTagCloseDeriv p2)++startTagCloseDeriv (OneOrMore p)+    = oneOrMore (startTagCloseDeriv p)++startTagCloseDeriv (Attribute nc _)+    = notAllowed1 $+      "Attribut with name, " ++ show nc ++ +      " expected, but no more attributes found"++startTagCloseDeriv p+    = p+++-- ------------------------------------------------------------+--  +-- | Computing the derivative of a pattern with respect to a list of children involves +-- computing the derivative with respect to each pattern in turn, except+-- that whitespace requires special treatment.++childrenDeriv :: Context -> Pattern -> XmlTrees -> Pattern+childrenDeriv _cx p@(NotAllowed _) _+    = p++childrenDeriv cx p []+    = childrenDeriv cx p [XN.mkText ""]++childrenDeriv cx p [tt]+    | ist+      &&+      whitespace s+	= choice p p1+    | ist+	= p1+    where+    ist =            XN.isText    tt+    s   = fromJust . XN.getText $ tt+    p1  = childDeriv cx p tt++childrenDeriv cx p children+    = stripChildrenDeriv cx p children    ++stripChildrenDeriv :: Context -> Pattern -> XmlTrees -> Pattern+stripChildrenDeriv _ p []+    = p++stripChildrenDeriv cx p (h:t)+    = stripChildrenDeriv cx+      ( if strip h+	then p+	else (childDeriv cx p h)+      ) t+++-- ------------------------------------------------------------+--  +-- | computes the derivative of a pattern with respect to a end tag++endTagDeriv :: Pattern -> Pattern+endTagDeriv (Choice p1 p2)+    = choice (endTagDeriv p1) (endTagDeriv p2)++endTagDeriv (After p1 p2)+    | nullable p1 +	= p2 +    | otherwise+	= notAllowed $+	  show p1 ++ " expected"++endTagDeriv n@(NotAllowed _)+    = n++endTagDeriv _+    = notAllowed "Call to endTagDeriv with wrong arguments"++-- ------------------------------------------------------------+--  +-- | applies a function (first parameter) to the second part of a after pattern++applyAfter :: (Pattern -> Pattern) -> Pattern -> Pattern++applyAfter f (After p1 p2)	= after p1 (f p2)+applyAfter f (Choice p1 p2)	= choice (applyAfter f p1) (applyAfter f p2)+applyAfter _ n@(NotAllowed _)	= n+applyAfter _ _			= notAllowed "Call to applyAfter with wrong arguments"++-- --------------------++-- mothers little helpers++strip		:: XmlTree -> Bool+strip		= maybe False whitespace . XN.getText++whitespace 	:: String -> Bool+whitespace	= all isXmlSpaceChar++showXts		:: XmlTrees -> String+showXts		= concat . runLA (xshow $ arrL id)++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/RelaxNG/Validator.hs view
@@ -0,0 +1,308 @@+-- |+-- This module exports the core functions from the basic validation und simplification libraries.+-- It also exports some helper functions for easier access to the validation functionality.++module Yuuko.Text.XML.HXT.RelaxNG.Validator+  ( validateDocumentWithRelaxSchema+  , validateDocumentWithRelax++  , validate+  , validateSchema+  , validateWithSpezification+  , validateSchemaWithSpezification+  , validateWithoutSpezification+  , module Yuuko.Text.XML.HXT.RelaxNG.Validation+  , module Yuuko.Text.XML.HXT.RelaxNG.Simplification+  )+where++import Yuuko.Control.Arrow.ListArrows++import Yuuko.Text.XML.HXT.DOM.Interface+import Yuuko.Text.XML.HXT.Arrow.XmlArrow+import Yuuko.Text.XML.HXT.Arrow.XmlIOStateArrow++import Yuuko.Text.XML.HXT.RelaxNG.Validation+import Yuuko.Text.XML.HXT.RelaxNG.Simplification+import Yuuko.Text.XML.HXT.RelaxNG.Schema        as S++-- ------------------------------------------------------------++{- |+   validate a document with a Relax NG schema++   * 1.parameter  : the option list for validation++   - 2.parameter  : the URI of the Relax NG Schema++   - arrow-input  : the document to be validated, namespaces must have been processed++   - arrow-output : the input document, or in case of validation errors, an empty document with status information in the root++options evaluated by validateDocumentWithRelaxSchema:++    * 'a_check_restrictions'   : check Relax NG schema restrictions when simplifying the schema (default: on)+    +    - 'a_validate_externalRef' : validate a Relax NG schema referenced by a externalRef-Pattern (default: on)+    +    - 'a_validate_include'     : validate a Relax NG schema referenced by a include-Pattern (default: on)+    +all other options are propagated to the read functions for schema input++example:++> validateDocumentWithRelaxSchema [(a_check_restrictions, "0")] "testSchema.rng"+++-}++validateDocumentWithRelaxSchema	:: Attributes -> String -> IOStateArrow s XmlTree XmlTree+validateDocumentWithRelaxSchema userOptions relaxSchema+    = withOtherUserState ()+      $+      ( ( validate' $< validSchema )	-- try to validate, only possible if schema is o.k.+	`orElse`+	this+      )+      `when`+      documentStatusOk			-- only do something when document status is ok+    where+    validate' schema+	= setDocumentStatusFromSystemState "read and build Relax NG schema"+	  >>>+	  validateDocumentWithRelax schema++    validSchema+	= traceMsg 2 ( "read Relax NG schema document: " ++ show relaxSchema )+	  >>>+	  readForRelax remainingOptions relaxSchema+	  >>>+	  perform ( let checkSchema = True in		-- test option in al+		    if checkSchema+		    then validateWithRelaxAndHandleErrors S.relaxSchemaArrow+		    else none+		  )+          >>>+	  traceMsg 2 "create simplified schema"+	  >>>+	  createSimpleForm remainingOptions+	    ( hasOption a_check_restrictions   )+	    ( hasOption a_validate_externalRef )+	    ( hasOption a_validate_include     )+	  >>>+	  traceDoc "simplified schema"+          >>>+	  perform ( getErrors+		    >>>+		    handleSimplificationErrors+		  )+    hasOption n+	= optionIsSet n options++    options = addEntries userOptions defaultOptions++    defaultOptions+	= [ ( a_check_restrictions,	v_1 )+	  , ( a_validate_externalRef,	v_1 )+	  , ( a_validate_include,	v_1 )+	  ]++    remainingOptions+	 = filter (not . flip hasEntry defaultOptions . fst) options++++handleSimplificationErrors	:: IOSArrow XmlTree XmlTree+handleSimplificationErrors+    = traceDoc "simplification errors"+      >>>+      getChildren >>> getAttrValue "desc"+      >>>+      arr ("Relax NG validation: " ++)+      >>>+      mkError c_err+      >>>+      filterErrorMsg+++{- | validate an XML document with respect to a Relax NG schema++   * 1.parameter  : the valid and simplified schema as XML tree++   - arrow-input  : the document to be validated++   - arrow-output : the validated and unchanged document or the empty document with status information set in the root node+-}++validateDocumentWithRelax	:: XmlTree -> IOSArrow XmlTree XmlTree+validateDocumentWithRelax schema+    = ( traceMsg 1 "validate document with Relax NG schema"+	>>>+	perform ( validateWithRelaxAndHandleErrors (constA schema) )+	>>>+	setDocumentStatusFromSystemState "validate document with Relax NG schema"+      )+      `when` documentStatusOk				-- only do something when document status is ok+++{- |+   normalize a document for Relax NG validation,+   call the 'Yuuko.Text.XML.HXT.RelaxNG.Validation.validateRelax' function for doing the hard work,+   and issue errors++   * 1.parameter  : the arrow for computing the schema++   - arrow-input  : the document to be validated++   - arrow-output : nothing+-}++-- ------------------------------------------------------------++{- | Document validation++Validates a xml document with respect to a Relax NG schema.++First, the schema is validated with respect to the Relax NG Spezification. If no error is found, the xml document is validated with respect to the schema.++   * 1.parameter :  list of options; namespace progagation is always done++   - 2.parameter :  XML document+   +   - 3.parameter :  Relax NG schema file++available options:++    * 'a_do_not_check_restrictions' : do not check Relax NG schema restrictions (includes do-not-validate-externalRef, do-not-validate-include)+    +    - 'a_do_not_validate_externalRef' : do not validate a Relax NG schema referenced by a externalRef-Pattern+    +    - 'a_validate_externalRef' : validate a Relax NG schema referenced by a externalRef-Pattern (default)+    +    - 'a_do_not_validate_include' : do not validate a Relax NG schema referenced by a include-Pattern+    +    - 'a_validate_include' : validate a Relax NG schema referenced by a include-Pattern (default)+    +    - 'a_output_changes' : output Pattern transformations in case of an error+    +    - 'a_do_not_collect_errors' : stop Relax NG simplification after the first error has occurred+    +    - all 'Yuuko.Text.XML.HXT.Arrow.ReadDocument.readDocument' options++example:++> validate [(a_do_not_check_restrictions, "1")] "test.xml" "testSchema.rng"++-}+validate :: Attributes -> String -> String -> IOSArrow n XmlTree+validate al xmlDocument relaxSchema+  = S.relaxSchemaArrow+    >>> +    validateWithSpezification al xmlDocument relaxSchema+++++{- | Relax NG schema validation++Validates a Relax NG schema with respect to the Relax NG Spezification.++   * 1.parameter :  list of available options (see also: 'validate')++   - 2.parameter :  Relax NG schema file+ +-}+validateSchema :: Attributes -> String -> IOSArrow n XmlTree+validateSchema al relaxSchema+  = validate al "" relaxSchema++++{- | Document validation++Validates a xml document with respect to a Relax NG schema. Similar to 'validate', but the Relax NG Specification is not created. Can be used, to check a list of documents more efficiently.++   * 1.parameter :  list of available options (see also: 'validate')++   - 2.parameter :  XML document+   +   - 3.parameter :  Relax NG schema file+   +   - arrow-input  :  Relax NG Specification in simple form++example:++> Yuuko.Text.XML.HXT.RelaxNG.Schema.relaxSchemaArrow+> >>>+> ( validateWithSpezification [] "foo.xml" "foo.rng"+>   &&&+>   validateWithSpezification [] "bar.xml" "bar.rng"+> )+++-}+validateWithSpezification :: Attributes -> String -> String -> IOSArrow XmlTree XmlTree+validateWithSpezification al xmlDocument relaxSchema+  = -- validation of the schema with respect to the specification+    -- returns a list of errors or none if the schema is correct++    ( validateRelax $< ( readForRelax al relaxSchema+			 >>>+			 getChildren+		       )+    )+    `orElse`++    -- validation of the xml document with respect to the schema+    -- returns a list of errors or none if the xml document is correct    ++    validateWithoutSpezification al xmlDocument relaxSchema++{- | Relax NG schema validation++    see 'validateSchema' and 'validateWithSpezification'++   * 1.parameter :  list of available options (see also: 'validate')++   - 2.parameter :  Relax NG schema file   +   +   - arrow-input  :  Relax NG Specification in simple form+-}++validateSchemaWithSpezification :: Attributes -> String -> IOSArrow XmlTree XmlTree+validateSchemaWithSpezification al relaxSchema+  = validateWithSpezification al "" relaxSchema++++{- | Document validation++Validates a xml document with respect to a Relax NG schema, but the schema is @not@ validated with respect to a specification first. Should be used only for valid Relax NG schemes.++   * 1.parameter :  list of available options (see also: 'validate')++   - 2.parameter :  XML document+   +   - 3.parameter :  Relax NG schema file+   +-}+++validateWithoutSpezification :: Attributes -> String -> String -> IOSArrow n XmlTree+validateWithoutSpezification al xmlDocument relaxSchema+  = readForRelax al relaxSchema+    >>> +    createSimpleForm al True True True+    >>>+    ( ( getErrors >>> perform handleSimplificationErrors )		-- issue errors in schema simplification+      `orElse`+      ( if null xmlDocument						-- no errors: validate document+	then none+	else validateRelax $< ( readForRelax al xmlDocument+				>>>+				normalizeForRelaxValidation+				>>>+				getChildren+			      )+      )+    )
+ src/Yuuko/Text/XML/HXT/RelaxNG/XmlSchema/DataTypeLibW3C.hs view
@@ -0,0 +1,610 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.RelaxNG.XmlSchema.DataTypeLibW3C+   Copyright  : Copyright (C) 2005 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable+   Version    : $Id$++   Datatype library for the W3C XML schema datatypes++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.RelaxNG.XmlSchema.DataTypeLibW3C+  ( w3cNS+  , w3cDatatypeLib++  , xsd_string			-- data type names+  , xsd_normalizedString+  , xsd_token+  , xsd_language+  , xsd_NMTOKEN+  , xsd_NMTOKENS+  , xsd_Name+  , xsd_NCName+  , xsd_ID+  , xsd_IDREF+  , xsd_IDREFS+  , xsd_ENTITY+  , xsd_ENTITIES+  , xsd_anyURI+  , xsd_QName+  , xsd_NOTATION+  , xsd_hexBinary+  , xsd_base64Binary+  , xsd_decimal++  , xsd_length			-- facet names+  , xsd_maxLength+  , xsd_minLength+  , xsd_maxExclusive+  , xsd_minExclusive+  , xsd_maxInclusive+  , xsd_minInclusive+  , xsd_totalDigits+  , xsd_fractionDigits+  , xsd_pattern+  , xsd_enumeration+  )+where++import Data.Maybe+import Data.Ratio++import Network.URI				( isURIReference )++import Yuuko.Text.XML.HXT.DOM.QualifiedName		( isWellformedQualifiedName+						, isNCName+						)+import Yuuko.Text.XML.HXT.RelaxNG.DataTypeLibUtils+import Yuuko.Text.XML.HXT.RelaxNG.XmlSchema.Regex	( Regex+						, matchWithRE+						)+import Yuuko.Text.XML.HXT.RelaxNG.XmlSchema.RegexParser+                                                ( parseRegex+						)+  +-- ------------------------------------------------------------++-- | Namespace of the W3C XML schema datatype library++w3cNS	:: String+w3cNS	= "http://www.w3.org/2001/XMLSchema-datatypes"+++xsd_string+ , xsd_normalizedString+ , xsd_token+ , xsd_language+ , xsd_NMTOKEN+ , xsd_NMTOKENS+ , xsd_Name+ , xsd_NCName+ , xsd_ID+ , xsd_IDREF+ , xsd_IDREFS+ , xsd_ENTITY+ , xsd_ENTITIES+ , xsd_anyURI+ , xsd_QName+ , xsd_NOTATION+ , xsd_hexBinary+ , xsd_base64Binary+ , xsd_decimal+ , xsd_integer+ , xsd_nonPositiveInteger+ , xsd_negativeInteger+ , xsd_nonNegativeInteger+ , xsd_positiveInteger+ , xsd_long+ , xsd_int+ , xsd_short+ , xsd_byte+ , xsd_unsignedLong+ , xsd_unsignedInt+ , xsd_unsignedShort+ , xsd_unsignedByte :: String++xsd_string		= "string"+xsd_normalizedString	= "normalizedString"+xsd_token		= "token"+xsd_language		= "language"+xsd_NMTOKEN		= "NMTOKEN"+xsd_NMTOKENS		= "NMTOKENS"+xsd_Name		= "Name"+xsd_NCName		= "NCName"+xsd_ID			= "ID"+xsd_IDREF		= "IDREF"+xsd_IDREFS		= "IDREFS"+xsd_ENTITY		= "ENTITY"+xsd_ENTITIES		= "ENTITIES"+xsd_anyURI		= "anyURI"+xsd_QName		= "QName"+xsd_NOTATION		= "NOTATION"+xsd_hexBinary		= "hexBinary"+xsd_base64Binary	= "base64Binary"+xsd_decimal		= "decimal"+xsd_integer		= "integer"+xsd_nonPositiveInteger	= "nonPositiveInteger"+xsd_negativeInteger	= "negativeInteger"+xsd_nonNegativeInteger	= "nonNegativeInteger"+xsd_positiveInteger	= "positiveInteger"+xsd_long		= "long"+xsd_int			= "int"+xsd_short		= "short"+xsd_byte		= "byte"+xsd_unsignedLong	= "unsignedLong"+xsd_unsignedInt		= "unsignedInt"+xsd_unsignedShort	= "unsignedShort"+xsd_unsignedByte	= "unsignedByte"+++xsd_length+ , xsd_maxLength+ , xsd_minLength+ , xsd_maxExclusive+ , xsd_minExclusive+ , xsd_maxInclusive+ , xsd_minInclusive+ , xsd_totalDigits+ , xsd_fractionDigits+ , xsd_pattern+ , xsd_enumeration :: String++xsd_length		= rng_length+xsd_maxLength		= rng_maxLength+xsd_minLength		= rng_minLength++xsd_maxExclusive	= rng_maxExclusive+xsd_minExclusive	= rng_minExclusive+xsd_maxInclusive	= rng_maxInclusive+xsd_minInclusive	= rng_minInclusive++xsd_totalDigits		= "totalDigits"+xsd_fractionDigits	= "fractionDigits"++xsd_pattern		= "pattern"+xsd_enumeration		= "enumeration"++-- ----------------------------------------++-- | The main entry point to the W3C XML schema datatype library.+--+-- The 'DTC' constructor exports the list of supported datatypes and params.+-- It also exports the specialized functions to validate a XML instance value with+-- respect to a datatype.+w3cDatatypeLib :: DatatypeLibrary+w3cDatatypeLib = (w3cNS, DTC datatypeAllowsW3C datatypeEqualW3C w3cDatatypes)+++-- | All supported datatypes of the library+w3cDatatypes :: AllowedDatatypes+w3cDatatypes = [ (xsd_string,			stringParams)+	       , (xsd_normalizedString, 	stringParams)+               , (xsd_token,			stringParams)+	       , (xsd_language,			stringParams)+               , (xsd_NMTOKEN,			stringParams)+               , (xsd_NMTOKENS,			listParams  )+	       , (xsd_Name,			stringParams)+	       , (xsd_NCName,			stringParams)+	       , (xsd_ID,			stringParams)+	       , (xsd_IDREF,			stringParams)+	       , (xsd_IDREFS,			listParams  )+	       , (xsd_ENTITY,			stringParams)+	       , (xsd_ENTITIES,			listParams  )+               , (xsd_anyURI,			stringParams)+               , (xsd_QName,			stringParams)+               , (xsd_NOTATION,			stringParams)+	       , (xsd_hexBinary,		stringParams)+	       , (xsd_base64Binary,		stringParams)+	       , (xsd_decimal,			decimalParams)+	       , (xsd_integer,			integerParams)+	       , (xsd_nonPositiveInteger,	integerParams)+	       , (xsd_negativeInteger,		integerParams)+	       , (xsd_nonNegativeInteger,	integerParams)+	       , (xsd_positiveInteger,		integerParams)+	       , (xsd_long,			integerParams)+	       , (xsd_int,			integerParams)+	       , (xsd_short,			integerParams)+	       , (xsd_byte,			integerParams)+	       , (xsd_unsignedLong,		integerParams)+	       , (xsd_unsignedInt,		integerParams)+	       , (xsd_unsignedShort,		integerParams)+	       , (xsd_unsignedByte,		integerParams)+               ]++-- ----------------------------------------++-- | List of allowed params for the string datatypes+stringParams	:: AllowedParams+stringParams	= xsd_pattern : map fst fctTableString++-- ----------------------------------------++patternValid	:: ParamList -> CheckString+patternValid params+    = foldr (>>>) ok . map paramPatternValid $ params+      where+      paramPatternValid (pn, pv)+	  | pn == xsd_pattern   = assert (patParamValid pv) (errorMsgParam pn pv)+	  | otherwise		= ok++patParamValid :: String -> String -> Bool+patParamValid regex a+    = case parseRegex regex of+      (Left _  )	-> False+      (Right ex)	-> isNothing . matchWithRE ex $ a++-- ----------------------------------------++-- | List of allowed params for the decimal datatypes++decimalParams	:: AllowedParams+decimalParams	= xsd_pattern : map fst fctTableDecimal++fctTableDecimal	:: [(String, String -> Rational -> Bool)]+fctTableDecimal+    = [ (xsd_maxExclusive,   cvd (>))+      , (xsd_minExclusive,   cvd (<))+      , (xsd_maxInclusive,   cvd (>=))+      , (xsd_minInclusive,   cvd (<=))+      , (xsd_totalDigits,    cvi (\ l v ->    totalDigits v == l))+      , (xsd_fractionDigits, cvi (\ l v -> fractionDigits v == l))+      ]+    where+    cvd		:: (Rational -> Rational -> Bool) -> (String -> Rational -> Bool)+    cvd	op	= \ x y -> isDecimal x && readDecimal x `op` y++    cvi		:: (Int -> Rational -> Bool) -> (String -> Rational -> Bool)+    cvi	op	= \ x y -> isNumber x && read x `op` y++decimalValid	:: ParamList -> CheckA Rational Rational+decimalValid params+    = foldr (>>>) ok . map paramDecimalValid $ params+    where+    paramDecimalValid (pn, pv)+	= assert+	  ((fromMaybe (const . const $ True) . lookup pn $ fctTableDecimal) pv)+	  (errorMsgParam pn pv . showDecimal)++-- ----------------------------------------++-- | List of allowed params for the decimal and integer datatypes++integerParams	:: AllowedParams+integerParams	= xsd_pattern : map fst fctTableInteger++fctTableInteger	:: [(String, String -> Integer -> Bool)]+fctTableInteger+    = [ (xsd_maxExclusive,   cvi (>))+      , (xsd_minExclusive,   cvi (<))+      , (xsd_maxInclusive,   cvi (>=))+      , (xsd_minInclusive,   cvi (<=))+      , (xsd_totalDigits,    cvi (\ l v -> totalD v == toInteger l))+      ]+    where+    cvi		:: (Integer -> Integer -> Bool) -> (String -> Integer -> Bool)+    cvi	op	= \ x y -> isNumber x && read x `op` y++    totalD i+	| i < 0	    = totalD (0-i)+	| otherwise = toInteger . length . show $ i++integerValid	:: DatatypeName -> ParamList -> CheckA Integer Integer+integerValid datatype params +    = assertInRange+      >>>+      (foldr (>>>) ok . map paramIntegerValid $ params)+    where+    assertInRange 	:: CheckA Integer Integer+    assertInRange+	= assert+	  (fromMaybe (const True) . lookup datatype $ integerRangeTable)+	  (\ v -> ( "Datatype " ++ show datatype +++		    " with value = " ++ show v +++		    " not in integer value range"+		  )+	  )+    paramIntegerValid (pn, pv)+	= assert+	  ((fromMaybe (const . const $ True) . lookup pn $ fctTableInteger) pv)+	  (errorMsgParam pn pv . show)++integerRangeTable	:: [(String, Integer -> Bool)]+integerRangeTable	= [ (xsd_integer,		const True)+			  , (xsd_nonPositiveInteger,	(<=0)	)+			  , (xsd_negativeInteger,	( <0)	)+			  , (xsd_nonNegativeInteger,	(>=0)	)+			  , (xsd_positiveInteger,	( >0)	)+			  , (xsd_long,			inR 9223372036854775808)+			  , (xsd_int,			inR 2147483648)+			  , (xsd_short,			inR 32768)+			  , (xsd_byte,			inR 128)+			  , (xsd_unsignedLong,		inP 18446744073709551616)+			  , (xsd_unsignedInt,		inP 4294967296)+			  , (xsd_unsignedShort,		inP 65536)+			  , (xsd_unsignedByte,		inP 256)+			  ]+                          where+			  inR b i	= (0 - b) <= i && i < b+			  inP b i	= 0 <= i       && i < b++-- ----------------------------------------++-- | List of allowed params for the list datatypes++listParams	:: AllowedParams+listParams	= xsd_pattern : map fst fctTableList++listValid	:: DatatypeName -> ParamList -> CheckString+listValid d	= stringValidFT fctTableList d 0 (-1)++-- ----------------------------------------++isNameList	:: (String -> Bool) -> String -> Bool+isNameList p w+    = not (null ts) && all p ts+      where+      ts = words w++-- ----------------------------------------++rex		:: String -> Regex+rex		= either undefined id . parseRegex++isRex		:: Regex -> String -> Bool+isRex ex	= isNothing . matchWithRE ex++-- ----------------------------------------++rexLanguage+  , rexHexBinary+  , rexBase64Binary+  , rexDecimal+  , rexInteger	:: Regex++rexLanguage	= rex "[A-Za-z]{1,8}(-[A-Za-z]{1,8})*"+rexHexBinary	= rex "([A-Fa-f0-9]{2})*"+rexBase64Binary	= rex $+		  "(" ++ b64 ++ "{4})*((" ++ b64 ++ "{2}==)|(" ++ b64 ++ "{3}=)|)"+		  where+		  b64     = "[A-Za-z0-9+/]"+rexDecimal	= rex "(\\+|-)?(([0-9]+(\\.[0-9]*)?)|(\\.[0-9]+))"+rexInteger	= rex "(\\+|-)?[0-9]+"++isLanguage+  , isHexBinary+  , isBase64Binary+  , isDecimal+  , isInteger	:: String -> Bool++isLanguage	= isRex rexLanguage+isHexBinary	= isRex rexHexBinary+isBase64Binary	= isRex rexBase64Binary+isDecimal	= isRex rexDecimal+isInteger	= isRex rexInteger++-- ----------------------------------------++normBase64	:: String -> String+normBase64	= filter isB64+		  where+		  isB64 c = ( 'A' <= c && c <= 'Z')+			    ||+			    ( 'a' <= c && c <= 'z')+			    ||+			    ( '0' <= c && c <= '9')+			    ||+			    c == '+'+			    ||+			    c == '/'+			    ||+			    c == '='++-- ----------------------------------------++readDecimal+  , readDecimal'	:: String -> Rational++readDecimal ('+':s)	= readDecimal' s+readDecimal ('-':s)	= negate (readDecimal' s)+readDecimal      s	= readDecimal' s++readDecimal' s+    | f == 0	= (n % 1)+    | otherwise	= (n % 1) + (f % (10 ^ (toInteger (length fs))))+    where+    (ns, fs') = span (/= '.') s+    fs = drop 1 fs'++    f :: Integer+    f | null fs		= 0+      | otherwise	= read fs+    n :: Integer+    n | null ns		= 0+      | otherwise	= read ns++totalDigits+  , totalDigits'+  , fractionDigits	:: Rational -> Int++totalDigits r+    | r == 0			= 0+    | r < 0			= totalDigits' . negate  $ r+    | otherwise			= totalDigits'           $ r++totalDigits' r+    | denominator r == 1	= length . show . numerator  $ r+    | r < (1%1)			= (\ x -> x-1) . totalDigits' . (+ (1%1))    $ r+    | otherwise			= totalDigits' . (* (10 % 1)) $ r++fractionDigits r+    | denominator r == 1	= 0+    | otherwise			= (+1) . fractionDigits . (* (10 % 1)) $ r++showDecimal+  , showDecimal'		:: Rational -> String++showDecimal d+    | d < 0	= ('-':) . showDecimal' . negate    $ d+    | d < 1	= drop 1 . showDecimal' . (+ (1%1)) $ d+    | otherwise	=          showDecimal'             $ d++showDecimal' d+    | denominator d == 1    	= show . numerator $ d+    | otherwise			= times10 0        $ d+    where+    times10 i' d'+	| denominator d' == 1	= let+				  (x, y) = splitAt i' . reverse . show . numerator $ d'+				  in+				  reverse y ++ "." ++ reverse x+	| otherwise		= times10 (i' + 1) (d' * (10 % 1))+				  +-- ----------------------------------------++-- | Tests whether a XML instance value matches a data-pattern.+-- (see also: 'stringValid')++datatypeAllowsW3C :: DatatypeAllows+datatypeAllowsW3C d params value _+    = performCheck check value+    where+    validString normFct+	= validPattern+	  >>>+	  arr normFct+	  >>>+	  validLength++    validNormString+	= validString normalizeWhitespace++    validPattern+	= patternValid params++    validLength+	= stringValid d 0 (-1) params++    validList+	= validPattern+	  >>>+	  arr normalizeWhitespace+	  >>>+	  validListLength++    validListLength+	= listValid d params++    validName isN+	= assertW3C isN++    validNCName+	= validNormString >>> validName isNCName++    validQName+	= validNormString >>> validName isWellformedQualifiedName++    validDecimal+	= arr normalizeWhitespace+	  >>>+	  assertW3C isDecimal+	  >>>+	  checkWith readDecimal (decimalValid params)++    validInteger inRange+	= validPattern+	  >>>+	  arr normalizeWhitespace+	  >>>+	  assertW3C isInteger+	  >>>+	  checkWith read (integerValid inRange params)++    check	:: CheckString+    check	= fromMaybe notFound . lookup d $ checks++    notFound	= failure $ errorMsgDataTypeNotAllowed w3cNS d params++    checks	:: [(String, CheckA String String)]+    checks	= [ (xsd_string,		validString id)+		  , (xsd_normalizedString,	validString normalizeBlanks)+		  , (xsd_token,			validNormString)+		  , (xsd_language,		validNormString >>> assertW3C isLanguage)+		  , (xsd_NMTOKEN,		validNormString >>> validName isNmtoken)+		  , (xsd_NMTOKENS,		validList       >>> validName (isNameList isNmtoken))+		  , (xsd_Name,			validNormString >>> validName isName)+		  , (xsd_NCName,		validNCName)+		  , (xsd_ID,			validNCName)+		  , (xsd_IDREF,			validNCName)+		  , (xsd_IDREFS,		validList       >>> validName (isNameList isNCName))+		  , (xsd_ENTITY,		validNCName)+		  , (xsd_ENTITIES,		validList       >>> validName (isNameList isNCName))+		  , (xsd_anyURI,		validName isURIReference >>> validString escapeURI)+		  , (xsd_QName,			validQName)+		  , (xsd_NOTATION,		validQName)+		  , (xsd_hexBinary,		validString id         >>> assertW3C isHexBinary)+		  , (xsd_base64Binary,		validString normBase64 >>> assertW3C isBase64Binary)+		  , (xsd_decimal,		validPattern >>> validDecimal)+		  , (xsd_integer,		validInteger xsd_integer)+		  , (xsd_nonPositiveInteger,	validInteger xsd_nonPositiveInteger)+		  , (xsd_negativeInteger,	validInteger xsd_negativeInteger)+		  , (xsd_nonNegativeInteger,	validInteger xsd_nonNegativeInteger)+		  , (xsd_positiveInteger,	validInteger xsd_positiveInteger)+		  , (xsd_long,			validInteger xsd_long)+		  , (xsd_int,			validInteger xsd_int)+		  , (xsd_short,			validInteger xsd_short)+		  , (xsd_byte,			validInteger xsd_byte)+		  , (xsd_unsignedLong,		validInteger xsd_unsignedLong)+		  , (xsd_unsignedInt,		validInteger xsd_unsignedInt)+		  , (xsd_unsignedShort,		validInteger xsd_unsignedShort)+		  , (xsd_unsignedByte,		validInteger xsd_unsignedByte)+		  ]+    assertW3C p	= assert p errW3C+    errW3C	= errorMsgDataLibQName w3cNS d++-- ----------------------------------------++-- | Tests whether a XML instance value matches a value-pattern.++datatypeEqualW3C :: DatatypeEqual+datatypeEqualW3C d s1 _ s2 _+    = performCheck check (s1, s2)+    where+    check	:: CheckA (String, String) (String, String)+    check	= maybe notFound found . lookup d $ norm++    notFound	= failure $ const (errorMsgDataTypeNotAllowed0 w3cNS d)++    found nf	= arr (\ (x1, x2) -> (nf x1, nf x2))			-- normalize both values+		  >>>+		  assert (uncurry (==)) (uncurry $ errorMsgEqual d)	-- and check on (==)++    norm = [ (xsd_string,		id			)+	   , (xsd_normalizedString,	normalizeBlanks		)+	   , (xsd_token,		normalizeWhitespace	)+	   , (xsd_language,		normalizeWhitespace	)+	   , (xsd_NMTOKEN,		normalizeWhitespace	)+	   , (xsd_NMTOKENS,		normalizeWhitespace	)+	   , (xsd_Name,			normalizeWhitespace	)+	   , (xsd_NCName,		normalizeWhitespace	)+	   , (xsd_ID,			normalizeWhitespace	)+	   , (xsd_IDREF,		normalizeWhitespace	)+	   , (xsd_IDREFS,		normalizeWhitespace	)+	   , (xsd_ENTITY,		normalizeWhitespace	)+	   , (xsd_ENTITIES,		normalizeWhitespace	)+	   , (xsd_anyURI,		escapeURI . normalizeWhitespace	)+	   , (xsd_QName,		normalizeWhitespace	)+	   , (xsd_NOTATION,		normalizeWhitespace	)+	   , (xsd_hexBinary,		id			)+	   , (xsd_base64Binary,		normBase64		)+	   , (xsd_decimal,		show . readDecimal . normalizeWhitespace	)+	   ]++-- ----------------------------------------
+ src/Yuuko/Text/XML/HXT/RelaxNG/XmlSchema/Regex.hs view
@@ -0,0 +1,317 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.RelaxNG.XmlSchema.Regex+   Copyright  : Copyright (C) 2005 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   W3C XML Schema Regular Expression Matcher++   Grammar can be found under <http://www.w3.org/TR/xmlschema11-2/#regexs>++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.RelaxNG.XmlSchema.Regex+    ( Regex+    , chars+    , charRngs+    , mkZero+    , mkUnit+    , mkSym+    , mkSym1+    , mkSymRng+    , mkDot+    , mkStar+    , mkAlt+    , mkSeq+    , mkRep+    , mkRng+    , mkOpt+    , mkDif+    , mkCompl+    , isZero+    , nullable+    , delta+    , matchWithRE+    , (<&&>)+    , (<||>)+    )+where++import Data.List	( foldl' )++-- ------------------------------------------------------------++data Regex	= Zero String+		| Unit+		| Sym (Char -> Bool)+		| Dot+		| Star Regex+		| Alt Regex Regex+		| Seq Regex Regex+		| Rep Int Regex		-- 1 or more repetitions+		| Rng Int Int Regex	-- n..m repetitions+		| Dif Regex Regex	-- r1 - r2++-- ------------------------------------------------------------++{- just for documentation++class Inv a where+    inv		:: a -> Bool++instance Inv Regex where+    inv (Zero _)	= True+    inv Unit		= True+    inv (Sym p)		= not . null . chars $ p+    inv Dot		= True+    inv (Star e)	= inv e+    inv (Alt e1 e2)	= inv e1 &&+			  inv e2+    inv (Seq e1 e2)	= inv e1 &&+			  inv e2+    inv (Rep i e)	= i > 0 && inv e+    inv (Rng i j e)	= (i < j || (i == j && i > 1)) &&+			  inv e+    inv (Dif e1 e2)	= inv e1 &&+			  inv e2+-}++-- ------------------------------------------------------------+-- | enumerate all chars specified by a predicate+--+-- this function is expensive, it should only be used for testing++chars				:: (Char -> Bool) -> [Char]+chars p				= filter p $ [minBound .. maxBound]++charRngs			:: [Char] -> [(Char, Char)]+charRngs []			= []+charRngs (x:xs)			= charRng x xs+                  		where+		  		charRng y []		= (x,y) : []+		  		charRng y xs'@(x1:xs1)+		      		    | x1 == succ y	= charRng x1 xs1+				    | otherwise		= (x,y) : charRngs xs'++-- ------------------------------------------------------------+--+-- smart constructors++mkZero				:: String -> Regex+mkZero				= Zero+{-# INLINE mkZero #-}++mkUnit				:: Regex+mkUnit				= Unit+{-# INLINE mkUnit #-}++mkSym				:: (Char -> Bool) -> Regex+mkSym				= Sym+{-# INLINE mkSym #-}++mkSym1				:: Char	-> Regex+mkSym1	c			= mkSym (==c)++mkSymRng			:: Char -> Char -> Regex+mkSymRng c1 c2+    | c1 == minBound &&+      c2 == maxBound		= mkDot+    | c1 <= c2			= mkSym  $ (>= c1) <&&> (<= c2)+    | otherwise			= mkZero $ "empty char range"++mkDot				:: Regex+mkDot				= Dot+{-# INLINE mkDot #-}++mkStar				:: Regex -> Regex+mkStar (Zero _)			= mkUnit		-- {}* == ()+mkStar e@Unit			= e			-- ()* == ()+mkStar e@(Star _e1)		= e			-- (r*)* == r*+mkStar (Rep 1 e1)		= mkStar e1		-- (r+)* == r*+mkStar e@(Alt _ _)		= Star (rmStar e)	-- (a*|b)* == (a|b)*+mkStar e			= Star e++rmStar				:: Regex -> Regex+rmStar (Alt e1 e2)		= mkAlt (rmStar e1) (rmStar e2)+rmStar (Star e1)		= rmStar e1+rmStar (Rep 1 e1)		= rmStar e1+rmStar e1			= e1++mkAlt					:: Regex -> Regex -> Regex+mkAlt e1            (Zero _)		= e1				-- e1 u {} = e1+mkAlt (Zero _)      e2			= e2				-- {} u e2 = e2+mkAlt e1@(Star Dot) _e2			= e1				-- A* u e1 = A*+mkAlt _e1           e2@(Star Dot)	= e2				-- e1 u A* = A*+mkAlt (Sym p1)      (Sym p2)		= mkSym $ p1 <||> p2		-- melting of predicates+mkAlt e1            e2@(Sym _)		= mkAlt e2 e1			-- symmetry: predicates always first+mkAlt e1@(Sym _)    (Alt e2@(Sym _) e3)	= mkAlt (mkAlt e1 e2) e3	-- prepare melting of predicates+mkAlt (Alt e1 e2)   e3			= mkAlt e1 (mkAlt e2 e3)	-- associativity+mkAlt e1 e2				= Alt e1 e2++mkSeq				:: Regex -> Regex -> Regex+mkSeq e1@(Zero _) _e2		= e1+mkSeq _e1         e2@(Zero _)	= e2+mkSeq Unit        e2		= e2+mkSeq e1          Unit		= e1+mkSeq (Seq e1 e2) e3		= mkSeq e1 (mkSeq e2 e3)+mkSeq e1 e2			= Seq e1 e2++mkRep		:: Int -> Regex -> Regex+mkRep 0 e			= mkStar e+mkRep _ e@(Zero _)		= e+mkRep _ e@Unit			= e+mkRep i e			= Rep i e++mkRng	:: Int -> Int -> Regex -> Regex+mkRng 0  0  _e			= mkUnit+mkRng 1  1  e			= e+mkRng lb ub _e+    | lb > ub			= Zero $+				  "illegal range " +++				  show lb ++ ".." ++ show ub+mkRng _l _u e@(Zero _)		= e+mkRng _l _u e@Unit		= e+mkRng lb ub e			= Rng lb ub e++mkOpt				:: Regex -> Regex+mkOpt				= mkRng 0 1++mkDif	:: Regex -> Regex -> Regex+mkDif e1@(Zero _) _e2		= e1+mkDif e1          (Zero	_)	= e1+mkDif _e1         (Star Dot)	= mkZero "empty set in difference expr"+mkDif Dot         (Sym p)	= mkSym (not . p)+mkDif (Sym _)     Dot		= mkZero "empty set of chars in difference expr"+mkDif (Sym p1)    (Sym p2)+    | null . chars $ (\ x -> p1 x && not (p2 x))+				= mkZero "empty set of chars in difference expr"+mkDif e1          e2		= Dif e1 e2++mkCompl				:: Regex -> Regex+mkCompl				= mkDif mkDot++-- ------------------------------------------------------------++instance Show Regex where+    show (Zero s)	= "{err:" ++ s ++ "}"+    show Unit		= "()"+    show (Sym p)+	| null (tail cs) &&+	  rng1 (head cs)+			= escRng . head $ cs+	| otherwise	= "[" ++ concat cs' ++ "]"+			  where+			  rng1 (x,y)	= x == y+			  cs		= charRngs . chars $ p+			  cs' 		= map escRng cs+			  escRng (x, y)+			      | x == y	= esc x+			      | succ x == y+				        = esc x        ++ esc y+			      | otherwise+					= esc x ++ "-" ++ esc y+			  esc x+			      | x `elem` "\\-[]{}()*+?.^"+				  	= '\\':x:""+			      | x >= ' ' && x <= '~'+				  	= x:""+			      | otherwise+				  	= "&#" ++ show (fromEnum x) ++ ";"+    show Dot		= "."+    show (Star e)	= "(" ++ show e ++ ")*"+    show (Alt e1 e2)	= "(" ++ show e1 ++ "|" ++ show e2 ++ ")"+    show (Seq e1 e2)	= show e1 ++ show e2+    show (Rep 1 e)	= "(" ++ show e ++ ")+"+    show (Rep i e)	= "(" ++ show e ++ "){" ++ show i ++ ",}"+    show (Rng 0 1 e)	= "(" ++ show e ++ ")?"+    show (Rng i j e)	= "(" ++ show e ++ "){" ++ show i ++ "," ++ show j ++ "}"+    show (Dif e1 e2)	= "(" ++ show e1 ++ "-" ++ show e2 ++ ")"++-- ------------------------------------------------------------++isZero			:: Regex -> Bool+isZero (Zero _)		= True+isZero _		= False+{-# INLINE isZero #-}++nullable		:: Regex -> Bool+nullable (Zero _)	= False+nullable Unit		= True+nullable (Sym _p)	= False		-- assumption: p holds for at least one char+nullable Dot		= False+nullable (Star _)	= True+nullable (Alt e1 e2)	= nullable e1 ||+			  nullable e2+nullable (Seq e1 e2)	= nullable e1 &&+			  nullable e2+nullable (Rep _i e)	= nullable e+nullable (Rng i _ e)	= i == 0 ||+			  nullable e+nullable (Dif e1 e2)	= nullable e1 &&+			  not (nullable e2)++-- ------------------------------------------------------------++delta	:: Regex -> Char -> Regex+delta e@(Zero _)  _	= e+delta Unit        c	= mkZero $+			  "unexpected char " ++ show c+delta (Sym p)     c+    | p c		= mkUnit+    | otherwise		= mkZero $+			  "unexpected char " ++ show c ++ ", expected: " ++ oneof ++ chars'+                          where+			  (cs, ds) = splitAt 40 (chars p)+			  oneof+			      | null (tail cs) = ""+			      | otherwise      = "one of "+			  chars'+			      | null (tail cs) = "'" ++ cs ++ "'"+			      | null ds   = "[" ++ cs ++ "]"+			      | otherwise = "[" ++ cs ++ "...]"++delta Dot         _	= mkUnit+delta e@(Star e1) c	= mkSeq (delta e1 c) e+delta (Alt e1 e2) c	= mkAlt (delta e1 c) (delta e2 c)+delta (Seq e1 e2) c+    | nullable e1	= mkAlt (mkSeq (delta e1 c) e2) (delta e2 c)+    | otherwise		= mkSeq (delta e1 c) e2+delta (Rep i e)   c	= mkSeq (delta e c) (mkRep (i-1) e)+delta (Rng i j e) c	= mkSeq (delta e c) (mkRng ((i-1) `max` 0) (j-1) e)+delta (Dif e1 e2) c	= mkDif (delta e1 c) (delta e2 c)++-- ------------------------------------------------------------++delta'		:: Regex -> String -> Regex+delta'		= foldl' delta++matchWithRE		:: Regex -> String -> Maybe String+matchWithRE e+    = res . delta' e+    where+    res (Zero err)	= Just err+    res re+	| nullable re	= Nothing	-- o.k.+	| otherwise	= Just $ "input does not match " ++ show e++-- ------------------------------------------------------------++(<&&>)		:: (Char -> Bool) -> (Char -> Bool) -> (Char -> Bool)+f <&&> g	= \ x -> f x && g x		-- liftA2 (&&)++{-# INLINE (<&&>) #-}+++(<||>)		:: (Char -> Bool) -> (Char -> Bool) -> (Char -> Bool)+f <||> g	= \ x -> f x || g x		-- liftA2 (||)++{-# INLINE (<||>) #-}++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/RelaxNG/XmlSchema/RegexMatch.hs view
@@ -0,0 +1,238 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.RelaxNG.XmlSchema.RegexMatch+   Copyright  : Copyright (C) 2005 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   Convenient functions for W3C XML Schema Regular Expression Matcher.+   For internals see 'Yuuko.Text.XML.HXT.RelaxNG.XmlSchema.Regex'++   Grammar can be found under <http://www.w3.org/TR/xmlschema11-2/#regexs>++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.RelaxNG.XmlSchema.RegexMatch+    ( matchRE+    , splitRE+    , sedRE+    , tokenizeRE+    , tokenizeRE'+    , match+    , tokenize+    , tokenize'+    , sed+    , split+    )+where++import Data.Maybe++import Yuuko.Text.XML.HXT.RelaxNG.XmlSchema.Regex+import Yuuko.Text.XML.HXT.RelaxNG.XmlSchema.RegexParser++{-+import qualified Debug.Trace as T+-}++-- ------------------------------------------------------------++splitRegex		:: Regex -> String -> Maybe (String, String)+splitRegex re ""+    | nullable re	= Just ("", "")+    | otherwise		= Nothing++splitRegex re inp@(c : inp')+    | isZero   re	= Nothing+    | otherwise		= evalRes . splitRegex {- (T.trace (show re') re') -} re' $ inp'+    where+    re' = delta re c+    evalRes Nothing+	| nullable re	= Just ("", inp)+	| otherwise	= Nothing++    evalRes (Just (tok, rest))+	    		= Just (c : tok, rest)++-- ------------------------------------------------------------++-- | split a string by taking the longest prefix matching a regular expression+--+-- @Nothing@ is returned in case of a syntactically wrong regex string+-- or in case there is no matching prefix, else the pair of prefix and rest is returned+--+-- examples:+--+-- > splitRE "a*b" "abc" = Just ("ab","c")+-- > splitRE "a*"  "bc"  = Just ("", "bc")+-- > splitRE "a+"  "bc"  = Nothing+-- > splitRE "["   "abc" = Nothing++splitRE	:: String -> String -> Maybe (String, String)+splitRE re input+    = either (const Nothing) (flip splitRegex input) . parseRegex $ re++-- | convenient function for splitRE+--+-- syntax errors in R.E. are interpreted as no matching prefix found++split		:: String -> String -> (String, String)+split re input+    = fromMaybe ("", input) . splitRE re $ input++-- ------------------------------------------------------------++-- | split a string into tokens (words) by giving a regular expression+-- which all tokens must match+--+-- This can be used for simple tokenizers.+-- The words in the result list contain at least one char.+-- All none matching chars are discarded. If the given regex contains syntax errors,+-- @Nothing@ is returned+--+-- examples:+--+-- > tokenizeRE "a*b" ""         = Just []+-- > tokenizeRE "a*b" "abc"      = Just ["ab"]+-- > tokenizeRE "a*b" "abaab ab" = Just ["ab","aab","ab"]+-- >+-- > tokenizeRE "[a-z]{2,}|[0-9]{2,}|[0-9]+[.][0-9]+" "ab123 456.7abc"+-- >                                = Just ["ab","123","456.7","abc"]+-- >+-- > tokenizeRE "[a-z]*|[0-9]{2,}|[0-9]+[.][0-9]+" "cab123 456.7abc"+-- >                                = Just ["cab","123","456.7","abc"]+-- >+-- > tokenizeRE "[^ \t\n\r]*" "abc def\t\n\rxyz"+-- >                                = Just ["abc","def","xyz"]+-- >+-- > tokenizeRE "[^ \t\n\r]*"    = words++tokenizeRE	:: String -> String -> Maybe [String]+tokenizeRE regex input+    = either (const Nothing) (Just . flip token' input) $ parseRegex regex+    where+    token'	:: Regex -> String -> [String]+    token' re inp+	| null inp	= []+	| otherwise	= evalRes . splitRegex re $ inp+	where+	token''         = token' re+	evalRes Nothing	= token'' (tail inp)		-- re does not match any prefix+	evalRes (Just (tok, rest))+	    | null tok	= token'' (tail rest)		-- re is nullable and only the empty prefix matches+	    | otherwise	= tok : token'' rest		-- token found, tokenize the rest++-- | convenient function for tokenizeRE a string+--+-- syntax errors in R.E. result in an empty list++tokenize	:: String -> String -> [String]+tokenize re+    = fromMaybe [] . tokenizeRE re++-- ------------------------------------------------------------++-- | split a string into tokens and delimierter by giving a regular expression+-- wich all tokens must match+--+-- This is a generalisation of the above 'tokenizeRE' functions.+-- The none matching char sequences are marked with @Left@, the matching ones are marked with @Right@+--+-- If the regular expression contains syntax errors @Nothing@ is returned+--+-- The following Law holds:+--+-- > concat . map (either id id) . fromJust . tokenizeRE' re == id++tokenizeRE'	:: String -> String -> Maybe [Either String String]+tokenizeRE' regex input+    = either (const Nothing) (Just . flip token' input) $ parseRegex regex+    where+    token'	:: Regex -> String -> [Either String String]+    token' re+	= tok2 ""+	where+	tok2 :: String -> String -> [Either String String]+	tok2 noMatchPrefix inp+	    | null inp	= addNoMatch []+	    | otherwise	= evalRes . splitRegex re $ inp+	    where+	    addNoMatch res+		| null noMatchPrefix	= res+		| otherwise		= (Left . reverse $ noMatchPrefix) : res++	    evalRes Nothing		= tok2 (head inp : noMatchPrefix) (tail inp)		-- re does not match any prefix+	    evalRes (Just (tok, rest))+		| null tok		= tok2 (head rest : noMatchPrefix) (tail rest)		-- re is nullable and only the empty prefix matches+		| otherwise		= addNoMatch . (Right tok :) . tok2 "" $ rest		-- token found, tokenize the rest++-- | convenient function for tokenizeRE'+--+-- When the regular expression contains errors @[Left input]@ is returned, that means tokens are found++tokenize'	:: String -> String -> [Either String String]+tokenize' regex input+    = fromMaybe [Left input] . tokenizeRE' regex $ input++-- ------------------------------------------------------------++-- | sed like editing function+--+-- All matching tokens are edited by the 1. argument, the editing function,+-- all other chars remain as they are+--+-- examples:+--+-- > sedRE (const "b") "a" "xaxax"       = Just "xbxbx"+-- > sedRE (\ x -> x ++ x) "a" "xax"     = Just "xaax"+-- > sedRE undefined       "[" undefined = Nothing++sedRE		:: (String -> String) -> String -> String -> Maybe String+sedRE edit regex input+    = maybe Nothing (Just . concatMap (either id edit)) $ tokenizeRE' regex input++-- | convenient function for sedRE+--+-- When the regular expression contains errors, sed is the identity, else+-- the funtionality is like 'sedRE'+--+-- > sed undefined "["  == id++sed		:: (String -> String) -> String -> String -> String+sed edit regex input+    = fromMaybe input . sedRE edit regex $ input++-- ------------------------------------------------------------++-- | match a string with a regular expression+--+-- First argument is the regex, second the input string,+-- if the regex is not well formed, @Nothing@ is returned,+-- else @Just@ the match result+--+-- Examples:+--+-- > matchRE "x*" "xxx" = Just True+-- > matchRE "x" "xxx"  = Just False+-- > matchRE "[" "xxx"  = Nothing++matchRE	:: String -> String -> Maybe Bool+matchRE regex input+    = either (const Nothing) (Just . isNothing . flip matchWithRE input) $ parseRegex regex+++-- | convenient function for matchRE+--+-- syntax errors in R.E. are interpreted as no match found++match		:: String -> String -> Bool+match re	= fromMaybe False . matchRE re++-- ------------------------------------------------------------+
+ src/Yuuko/Text/XML/HXT/RelaxNG/XmlSchema/RegexParser.hs view
@@ -0,0 +1,354 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.RelaxNG.XmlSchema.RegexParser+   Copyright  : Copyright (C) 2005 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   W3C XML Schema Regular Expression Parser++   This parser supports the full W3C standard, the+   complete grammar can be found under <http://www.w3.org/TR/xmlschema11-2/#regexs>++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.RelaxNG.XmlSchema.RegexParser+    ( parseRegex )+where++import Data.Maybe++import Text.ParserCombinators.Parsec++import Yuuko.Text.XML.HXT.DOM.Unicode++import Yuuko.Text.XML.HXT.RelaxNG.Unicode.Blocks+import Yuuko.Text.XML.HXT.RelaxNG.Unicode.CharProps+import Yuuko.Text.XML.HXT.RelaxNG.XmlSchema.Regex++-- ------------------------------------------------------------++parseRegex :: String -> Either String Regex+parseRegex+    = either (Left . show) Right+      .+      parse ( do+	      r <- regExp+	      eof+	      return r+	    ) ""++-- ------------------------------------------------------------++regExp	:: Parser Regex+regExp+    = do+      r1 <- branch+      rs <- many branch1+      return (foldr1 mkAlt $ r1:rs)+    where+    branch1+	= do+	  _ <- char '|'+	  branch++branch	:: Parser Regex+branch+    = do+      rs <- many piece+      return $ foldr mkSeq mkUnit rs++piece	:: Parser Regex+piece+    = do+      r <- atom+      quantifier r++quantifier	:: Regex -> Parser Regex+quantifier r+    = ( do+	_ <- char '?'+	return $ mkOpt r )+      <|>+      ( do+	_ <- char '*'+	return $ mkStar r )+      <|>+      ( do+	_ <- char '+'+	return $ mkRep 1 r )+      <|>+      ( do+	_ <- char '{'+	res <- quantity r+	_ <- char '}'+	return res+      )+      <|>+      ( return r )++quantity	:: Regex -> Parser Regex+quantity r+    = do+      lb <- many1 digit+      quantityRest r (read lb)++quantityRest	:: Regex -> Int -> Parser Regex+quantityRest r lb+    = ( do+	_ <- char ','+	ub <- many digit+	return ( if null ub+		 then mkRep lb r+		 else mkRng lb (read ub) r+	       )+      )+      <|>+      ( return $ mkRng lb lb r)++atom	:: Parser Regex+atom+    = char1+      <|>+      charClass+      <|>+      between (char '(') (char ')') regExp++char1	:: Parser Regex+char1+    = do+      c <- satisfy $ (`notElem` ".\\?*+{}()|[]")+      return $ mkSym1 c++charClass	:: Parser Regex+charClass+    = charClassEsc+      <|>+      charClassExpr+      <|>+      wildCardEsc++charClassEsc	:: Parser Regex+charClassEsc+    = do+      _ <- char '\\'+      ( singleCharEsc+	<|>+	multiCharEsc+	<|>+	catEsc+	<|>+	complEsc )++singleCharEsc	:: Parser Regex+singleCharEsc+    = do+      c <- singleCharEsc'+      return $ mkSym1 c++singleCharEsc'	:: Parser Char+singleCharEsc'+    = do+      c <- satisfy (`elem` "nrt\\|.?*+(){}-[]^")+      return $ maybe c id . lookup c . zip "ntr" $ "\n\r\t"++multiCharEsc	:: Parser Regex+multiCharEsc+    = do+      c <- satisfy (`elem` es)+      return $ mkSym . fromJust . lookup c $ pm+    where+    es = map fst pm+    pm = [ ('s',       isXmlSpaceChar		)+	 , ('S', not . isXmlSpaceChar		)+	 , ('i',       isXmlNameStartChar	)+	 , ('I', not . isXmlNameStartChar	)+	 , ('c',       isXmlNameChar		)+	 , ('C', not . isXmlNameChar		)+	 , ('d',       isDigit			)+	 , ('D', not . isDigit			)+	 , ('w', not . isNotWord		)+	 , ('W',       isNotWord		)+	 ]+    isDigit   = ('0' <=) <&&> (<= '9')+    isNotWord = isUnicodeP <||>+		isUnicodeZ <||>+		isUnicodeC++catEsc	:: Parser Regex+catEsc+    = do+      _ <- char 'p'+      s <- between (char '{') (char '}') charProp+      return $ mkSym s++charProp	:: Parser (Char -> Bool)+charProp+    = isCategory+      <|>+      isBlock++isBlock		:: Parser (Char -> Bool)+isBlock+    = do+      _ <- string "Is"+      name <- many1 (satisfy legalChar)+      let b = lookup name codeBlocks+      if isJust b+	 then return $ let+		       (lb, ub) = fromJust b+		       in+		       (lb <=) <&&> (<= ub)+	 else fail   $ "unknown Unicode code block " ++ show name+    where+    legalChar c	 = 'A' <= c && c <= 'Z' ||+		   'a' <= c && c <= 'z' ||+	           '0' <= c && c <= '9' ||+		   '-' == c++isCategory	:: Parser (Char -> Bool)+isCategory+    = do+      pr <- isCategory'+      return $ fromJust (lookup pr categories)++categories	:: [(String, Char -> Bool)]+categories+    = [ ("C",  isUnicodeC )+      , ("Cc", isUnicodeCc)+      , ("Cf", isUnicodeCf)+      , ("Co", isUnicodeCo)+      , ("Cs", isUnicodeCs)+      , ("L",  isUnicodeL )+      , ("Ll", isUnicodeLl)+      , ("Lm", isUnicodeLm)+      , ("Lo", isUnicodeLo)+      , ("Lt", isUnicodeLt)+      , ("Lu", isUnicodeLu)+      , ("M",  isUnicodeM )+      , ("Mc", isUnicodeMc)+      , ("Me", isUnicodeMe)+      , ("Mn", isUnicodeMn)+      , ("N",  isUnicodeN )+      , ("Nd", isUnicodeNd)+      , ("Nl", isUnicodeNl)+      , ("No", isUnicodeNo)+      , ("P",  isUnicodeP )+      , ("Pc", isUnicodePc)+      , ("Pd", isUnicodePd)+      , ("Pe", isUnicodePe)+      , ("Pf", isUnicodePf)+      , ("Pi", isUnicodePi)+      , ("Po", isUnicodePo)+      , ("Ps", isUnicodePs)+      , ("S",  isUnicodeS )+      , ("Sc", isUnicodeSc)+      , ("Sk", isUnicodeSk)+      , ("Sm", isUnicodeSm)+      , ("So", isUnicodeSo)+      , ("Z",  isUnicodeZ )+      , ("Zl", isUnicodeZl)+      , ("Zp", isUnicodeZp)+      , ("Zs", isUnicodeZs)+      ]++isCategory'	:: Parser String+isCategory'+    = ( foldr1 (<|>) . map (uncurry prop) $+	[ ('L', "ultmo")+	, ('M', "nce")+	, ('N', "dlo")+	, ('P', "cdseifo")+	, ('Z', "slp")+	, ('S', "mcko")+	, ('C', "cfon")+	]+      ) <?> "illegal Unicode character property"+    where+    prop c1 cs2+	= do+	  _ <- char c1+	  s2 <- option ""+		( do+		  c2 <- satisfy (`elem` cs2)+		  return [c2] )+	  return $ c1:s2++complEsc	:: Parser Regex+complEsc+    = do+      _ <- char 'P'+      s <- between (char '{') (char '}') charProp+      return $ mkSym (not . s)++charClassExpr	:: Parser Regex+charClassExpr+    = between (char '[') (char ']') charGroup++charGroup	:: Parser Regex+charGroup+    = do+      r <- ( negCharGroup	-- a ^ at beginning denotes negation, not start of posCharGroup+	     <|>+	     posCharGroup+	   )+      s <- option (mkZero "")	-- charClassSub+	   ( do+	     _ <- char '-'+	     charClassExpr+	   )+      return $ mkDif r s++posCharGroup	:: Parser Regex+posCharGroup+    = do+      rs <- many1 (charRange <|> charClassEsc)+      return $ foldr1 mkAlt rs++charRange	:: Parser Regex+charRange+    = try seRange+      <|>+      xmlCharIncDash++seRange	:: Parser Regex+seRange+    = do+      c1 <- charOrEsc'+      _ <- char '-'+      c2 <- charOrEsc'+      return $ mkSymRng c1 c2++charOrEsc'	:: Parser Char+charOrEsc'+    = satisfy (`notElem` "\\-[]")+      <|>+      singleCharEsc'++xmlCharIncDash	:: Parser Regex+xmlCharIncDash+    = do+      c <- satisfy (`notElem` "\\[]")+      return $ mkSym1 c++negCharGroup	:: Parser Regex+negCharGroup+    = do+      _ <- char '^'+      r <- posCharGroup+      return $ mkCompl r++wildCardEsc	:: Parser Regex+wildCardEsc+    = do+      _ <- char '.'+      return $ mkSym (`notElem` "\n\r")+++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/Version.hs view
@@ -0,0 +1,4 @@+module Yuuko.Text.XML.HXT.Version+where+hxt_version :: String+hxt_version = "8.4.1"
+ src/Yuuko/Text/XML/HXT/XPath.hs view
@@ -0,0 +1,17 @@+-- |
+-- This helper module exports elements from the basic libraries:
+-- XPathEval, XPathToString and XPathParser
+--
+-- Author : Torben Kuseler
+
+
+module Yuuko.Text.XML.HXT.XPath
+    ( module Yuuko.Text.XML.HXT.XPath.XPathEval
+    , module Yuuko.Text.XML.HXT.XPath.XPathToString
+    , module Yuuko.Text.XML.HXT.XPath.XPathParser
+    ) 
+where
+
+import Yuuko.Text.XML.HXT.XPath.XPathEval
+import Yuuko.Text.XML.HXT.XPath.XPathToString
+import Yuuko.Text.XML.HXT.XPath.XPathParser
+ src/Yuuko/Text/XML/HXT/XPath/NavTree.hs view
@@ -0,0 +1,79 @@+-- |+-- Navigable tree structure which allow a program to traverse+-- for XPath expressions+-- copied and modified from HXML (<http://www.flightlab.com/~joe/hxml/>)+--++module Yuuko.Text.XML.HXT.XPath.NavTree+    ( module Yuuko.Text.XML.HXT.XPath.NavTree+    , module Yuuko.Data.NavTree+    )+where++import Data.Maybe++import Yuuko.Data.NavTree++import Yuuko.Text.XML.HXT.DOM.Interface+    ( XNode+    , xmlnsNamespace+    , namespaceUri+    )++import Yuuko.Text.XML.HXT.DOM.XmlNode+    ( isRoot+    , isElem+    , getName+    , getAttrl+    )++-- -----------------------------------------------------------------------------+-- functions for representing XPath axes. All axes except the namespace-axis are supported+++parentAxis		:: NavTree a -> [NavTree a]+parentAxis		= maybeToList . upNT++ancestorAxis		:: NavTree a -> [NavTree a]+ancestorAxis 		= \(NT _ u _ _) -> u		-- or: maybePlus upNT++ancestorOrSelfAxis	:: NavTree a -> [NavTree a]+ancestorOrSelfAxis	= \t@(NT _ u _ _) -> t:u	-- or: maybeStar upNT++childAxis		:: NavTree a -> [NavTree a]+childAxis		= maybe [] (maybeStar rightNT) . downNT++descendantAxis		:: NavTree a -> [NavTree a]+descendantAxis		= tail . preorderNT -- concatMap preorderNT . childAxis++descendantOrSelfAxis		:: NavTree a -> [NavTree a]+descendantOrSelfAxis	= preorderNT++followingSiblingAxis	:: NavTree a -> [NavTree a]+followingSiblingAxis	= maybePlus rightNT++precedingSiblingAxis	:: NavTree a -> [NavTree a]+precedingSiblingAxis	= maybePlus leftNT++selfAxis		:: NavTree a -> [NavTree a]+selfAxis		= wrap  where wrap x = [x]++followingAxis		:: NavTree a -> [NavTree a]+followingAxis		= preorderNT     `o'` followingSiblingAxis `o'` ancestorOrSelfAxis++precedingAxis		:: NavTree a -> [NavTree a]+precedingAxis		= revPreorderNT  `o'` precedingSiblingAxis `o'` ancestorOrSelfAxis+++attributeAxis :: NavTree XNode -> [NavTree XNode]+attributeAxis t@(NT xt a _ _)+    | isElem xt+      &&+      not (isRoot xt)+	= foldr (\ attr -> ((NT attr (t:a) [] []):)) [] al+    | otherwise+	= []+    where+    al = filter ((/= xmlnsNamespace) . maybe "" namespaceUri . getName) . fromMaybe [] . getAttrl $ xt++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/XPath/XPathArithmetic.hs view
@@ -0,0 +1,166 @@+-- |+-- The module contains arithmetic calculations according the IEEE 754 standard+-- for plus, minus, unary minus, multiplication, modulo and division.+--+++module Yuuko.Text.XML.HXT.XPath.XPathArithmetic+    ( xPathMulti+    , xPathMod+    , xPathDiv+    , xPathAdd+    , xPathUnary+    )+where++import Yuuko.Text.XML.HXT.XPath.XPathDataTypes+++-- |+-- Unary minus: the value 'NaN' is not calculatable and returned unchanged,+-- all other values can be denied.+--++xPathUnary :: XPathFilter+xPathUnary (XPVNumber (Float f)) =  XPVNumber (Float (-f))+xPathUnary (XPVError e)          = XPVError e+xPathUnary (XPVNumber NaN)       = XPVNumber NaN+xPathUnary (XPVNumber Pos0)      = XPVNumber Neg0+xPathUnary (XPVNumber Neg0)      = XPVNumber Pos0+xPathUnary (XPVNumber PosInf)    = XPVNumber NegInf+xPathUnary (XPVNumber NegInf)    = XPVNumber PosInf+xPathUnary _                     = XPVError "Call to unaryEval without a number"+++-- |+-- Multiplication+--++xPathMulti :: Op -> XPathValue -> XPathFilter+xPathMulti _ (XPVNumber (Float a)) (XPVNumber (Float b))+    = XPVNumber (Float (a * b))+xPathMulti _ (XPVNumber NegInf) (XPVNumber (Float a))+    | a < 0     = XPVNumber PosInf+    | otherwise = XPVNumber NegInf+xPathMulti _ (XPVNumber PosInf) (XPVNumber (Float a))+    | a < 0     = XPVNumber NegInf+    | otherwise = XPVNumber PosInf+xPathMulti _ (XPVNumber (Float a)) (XPVNumber NegInf)+    | a < 0     = XPVNumber PosInf+    | otherwise = XPVNumber NegInf+xPathMulti _ (XPVNumber (Float a)) (XPVNumber PosInf)+    | a < 0     = XPVNumber NegInf+    | otherwise = XPVNumber PosInf+xPathMulti _ (XPVNumber Pos0) (XPVNumber (Float a))+    | a < 0     = XPVNumber Neg0+    | otherwise = XPVNumber Pos0+xPathMulti _ (XPVNumber Neg0) (XPVNumber (Float a))+    | a < 0     = XPVNumber Pos0+    | otherwise = XPVNumber Neg0+xPathMulti _ (XPVNumber (Float a)) (XPVNumber Pos0)+    | a < 0     = XPVNumber Neg0+    | otherwise = XPVNumber Pos0+xPathMulti _ (XPVNumber (Float a)) (XPVNumber Neg0)+    | a < 0     = XPVNumber Pos0+    | otherwise = XPVNumber Neg0+xPathMulti a b c = xPathSpez a b c+++-- |+-- Modulo+--++xPathMod :: Op -> XPathValue -> XPathFilter+xPathMod _ (XPVNumber (Float a)) (XPVNumber (Float b))+    | floatMod a b == 0 = XPVNumber Pos0+    | otherwise = XPVNumber (Float (floatMod a b))+      where+      floatMod x y+        | x/y >= 0 = x - y * fromInteger(floor (x / y))+        | otherwise =x - y * fromInteger(ceiling (x / y))++xPathMod _ (XPVNumber (Float a)) (XPVNumber NegInf)+    = XPVNumber (Float a)+xPathMod _ (XPVNumber (Float a)) (XPVNumber PosInf)+    = XPVNumber (Float a)+xPathMod _ (XPVNumber Neg0) (XPVNumber Pos0)+    = XPVNumber Neg0+xPathMod a b c = xPathSpez a b c+++-- |+-- Division: the divison-operator is not according the IEEE 754 standard,+-- it calculates the same as the % operator in Java and ECMAScript+--++xPathDiv :: Op -> XPathValue -> XPathFilter+xPathDiv _ (XPVNumber (Float a)) (XPVNumber (Float b))+    = XPVNumber (Float (a / b))+xPathDiv _ (XPVNumber NegInf) (XPVNumber (Float a))+    | a < 0     = XPVNumber PosInf+    | otherwise = XPVNumber NegInf+xPathDiv _ (XPVNumber PosInf) (XPVNumber (Float a))+    | a < 0     = XPVNumber NegInf+    | otherwise = XPVNumber PosInf+xPathDiv _ (XPVNumber (Float a)) (XPVNumber NegInf)+    | a < 0     = XPVNumber Pos0+    | otherwise = XPVNumber Neg0+xPathDiv _ (XPVNumber (Float a)) (XPVNumber PosInf)+    | a < 0     = XPVNumber Neg0+    | otherwise = XPVNumber Pos0+xPathDiv _ (XPVNumber Neg0) (XPVNumber (Float a))+    | a < 0     = XPVNumber Pos0+    | otherwise = XPVNumber Neg0+xPathDiv _ (XPVNumber (Float a)) (XPVNumber Neg0)+    | a < 0     = XPVNumber PosInf+    | otherwise = XPVNumber NegInf+xPathDiv _ (XPVNumber (Float a)) (XPVNumber Pos0)+    | a < 0     = XPVNumber NegInf+    | otherwise = XPVNumber PosInf+xPathDiv a b c  = xPathSpez a b c+++-- |+-- Plus and minus+--+--    1.parameter op :  plus or minus operation+--++xPathAdd :: Op -> XPathValue -> XPathFilter+xPathAdd Plus (XPVNumber (Float a)) (XPVNumber (Float b))+    = if a + b == 0+        then XPVNumber Pos0+        else XPVNumber (Float (a+b))+xPathAdd Minus (XPVNumber (Float a)) (XPVNumber (Float b))+    = if a - b == 0+        then XPVNumber Pos0+        else XPVNumber (Float (a-b))+xPathAdd _ (XPVNumber PosInf) (XPVNumber NegInf)  = XPVNumber NaN+xPathAdd _ (XPVNumber NegInf) (XPVNumber PosInf)  = XPVNumber NaN+xPathAdd _ (XPVNumber PosInf) _                   = XPVNumber PosInf+xPathAdd _ (XPVNumber NegInf) _                   = XPVNumber NegInf+xPathAdd _ _ (XPVNumber PosInf)                   = XPVNumber PosInf+xPathAdd _ _ (XPVNumber NegInf)                   = XPVNumber NegInf+xPathAdd _ (XPVNumber (Float a)) (XPVNumber Pos0) = XPVNumber (Float a)+xPathAdd op (XPVNumber Pos0) (XPVNumber (Float a))+    | op == Minus = XPVNumber (Float (-a))+    | otherwise   = XPVNumber (Float a)+xPathAdd op (XPVNumber Neg0) (XPVNumber (Float a))+    | op == Minus = XPVNumber (Float (-a))+    | otherwise   = XPVNumber (Float a)+xPathAdd _ (XPVNumber (Float a)) (XPVNumber Neg0) = XPVNumber (Float a)+xPathAdd _ (XPVNumber Neg0) (XPVNumber Pos0)      = XPVNumber Neg0+xPathAdd _ (XPVNumber Pos0) (XPVNumber Neg0)      = XPVNumber Neg0+xPathAdd _ (XPVNumber Neg0) (XPVNumber Neg0)      = XPVNumber Neg0+xPathAdd _ (XPVNumber Pos0) (XPVNumber Pos0)      = XPVNumber Pos0+xPathAdd a b c = xPathSpez a b c+++-- |+-- Identically results of the operators are combined to get+-- as few as possible combinations of the special IEEE values+--+xPathSpez :: Op -> XPathValue -> XPathFilter+xPathSpez _ (XPVError e) _ = XPVError e+xPathSpez _ _ (XPVError e) = XPVError e+xPathSpez _ _ _            = XPVNumber NaN
+ src/Yuuko/Text/XML/HXT/XPath/XPathDataTypes.hs view
@@ -0,0 +1,285 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.XPath.XPathDataTypes+   Copyright  : Copyright (C) 2006 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   The core data types of XPath.+   The Type NodeSet is based on the module "NavTree" which was adapted from+   HXML (<http://www.flightlab.com/~joe/hxml/>)++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.XPath.XPathDataTypes+    ( module Yuuko.Text.XML.HXT.XPath.XPathDataTypes+    , module Yuuko.Text.XML.HXT.XPath.NavTree+    )+where++import Yuuko.Text.XML.HXT.XPath.NavTree+import Yuuko.Text.XML.HXT.DOM.Interface++-- -----------------------------------------------------------------------------+--+-- Expr++-- | Represents expression+-- ++data Expr     = GenExpr Op [Expr]             -- ^ generic expression with an operator and one or more operands+              | PathExpr (Maybe Expr) (Maybe LocationPath)+	                                      -- ^ a path expression contains an optional filter-expression+					      -- or an optional locationpath. one expression is urgently+					      -- necessary, both are possible+              | FilterExpr [Expr]             -- ^ filter-expression with zero or more predicates+              | VarExpr VarName               -- ^ variable+              | LiteralExpr Literal           -- ^ string+              | NumberExpr XPNumber           -- ^ number+              | FctExpr FctName FctArguments  -- ^ a function with a name and an optional list of arguments+              deriving (Show, Eq)+++-- -----------------------------------------------------------------------------+--+-- Op++-- | Represents XPath operators++data Op       = Or | And | Eq | NEq | Less | Greater | LessEq+              | GreaterEq |Plus | Minus | Div | Mod | Mult| Unary | Union+              deriving (Show, Eq)+++-- -----------------------------------------------------------------------------+--+-- |+-- Represents a floating-point number according the IEEE 754 standard+--+-- The standard includes a special Not-a-Number (NaN) value,+-- positive and negative infinity, positive and negative zero.++data XPNumber = Float Float  -- ^ floating-point number+              | NaN          -- ^ not-a-number+              | NegInf       -- ^ negative infinity+              | Neg0         -- ^ negative zero+              | Pos0         -- ^ positive zero+              | PosInf       -- ^ positive infinity+++instance Show XPNumber+    where+    show NaN           = "NaN"+    show NegInf        = "-Infinity"+    show Neg0          = "-0"+    show Pos0          = "0"+    show (Float f)     = show f+    show PosInf        = "Infinity"++++-- Negative zero is equal to positive zero,+-- equality test with NaN-value is always false+instance Eq XPNumber+    where+    NegInf  == NegInf  = True+    Pos0    == Neg0    = True+    Neg0    == Pos0    = True+    Pos0    == Pos0    = True+    Neg0    == Neg0    = True+    Float f == Float g = f == g+    PosInf  == PosInf  = True+    _       == _       = False+++instance Ord XPNumber+    where+    a       <= b       = (a < b) || (a == b)+    a       >= b       = (a > b) || (a == b)+    a       >  b       =  b < a++    NaN     < _        = False+    _       < NaN      = False++    _       < NegInf   = False+    NegInf  < _	       = True++    Neg0    < Neg0     = False+    Pos0    < Pos0     = False+    Pos0    < Neg0     = False+    Neg0    < Pos0     = False++    Neg0    < Float f  = 0 < f+    Pos0    < Float f  = 0 < f+    Float f < Neg0     = f < 0+    Float f < Pos0     = f < 0++    Float f < Float g  = f < g++    PosInf  < _        = False+    _       < PosInf   = True+++-- -----------------------------------------------------------------------------+-- | Represents location path+--+-- A location path consists of a sequence of one or more location steps.++data LocationPath = LocPath Path [XStep]+                  deriving (Show, Eq)+++-- -----------------------------------------------------------------------------                  +-- |+-- A location path is either a relative or an absolute path.++data Path         = Rel | Abs+                  deriving (Show, Eq)+					++-- | Represents location step+-- +-- A location step consists of an axis, a node-test and zero or more predicates.++data XStep        = Step AxisSpec NodeTest [Expr]+                  deriving (Show, Eq)++			+-- -----------------------------------------------------------------------------+--+-- AxisSpec++-- | Represents XPath axis++data AxisSpec     = Ancestor | AncestorOrSelf | Attribute | Child | Descendant  +                  | DescendantOrSelf | Following | FollowingSibling+                  | Namespace | Parent | Preceding | PrecedingSibling | Self+                  deriving (Show, Eq)+++-- -----------------------------------------------------------------------------+--+-- NodeTest++-- | Represents XPath node-tests++--data NodeTest     = NameTest Name     -- ^ name-test+data NodeTest     = NameTest QName     -- ^ name-test+                  | PI String           -- ^ processing-instruction-test with a literal argument+                  | TypeTest XPathNode  -- ^ all nodetype-tests+                  deriving (Show, Eq)++++++-- -----------------------------------------------------------------------------+--+-- XPathNode++-- | Represents nodetype-tests++data XPathNode    = XPNode            -- ^ all 7 nodetypes+                                      --  (root, element, attribute, namespace, pi, comment, text)+                  | XPCommentNode     -- ^ comment-nodes+                  | XPPINode          -- ^ processing-instruction-nodes+                  | XPTextNode        -- ^ text-nodes: cdata, character data+                  deriving (Show, Eq)+++-- -----------------------------------------------------------------------------+--+-- useful type definitions++type Name = (NamePrefix, LocalName)+type NamePrefix = String+type LocalName = String++-- | Variable name+type VarName      = Name++-- | a string+type Literal      = String					++-- | Function name+type FctName      = String++-- | Function arguments+type FctArguments = [Expr]++-- | Evaluation context+type Context      = (ConPos ,ConLen, ConNode)++-- | Context position+type ConPos       = Int++-- | Context length+type ConLen       = Int++-- | Context node+type ConNode      = NavXmlTree++++-- -----------------------------------------------------------------------------+--+-- XPathValue++-- | Represents XPath results++data XPathValue   = XPVNode NodeSet      -- ^ node-set+                  | XPVBool Bool         -- ^ boolean value+                  | XPVNumber XPNumber   -- ^ number according the IEEE 754 standard+                  | XPVString String     -- ^ string value+                  | XPVError String      -- ^ error message with text+                  deriving (Show, Eq, Ord)+++-- -----------------------------------------------------------------------------+--+-- Basic types for navigable tree and filters++-- | Node of navigable tree representation++type NavXmlTree   = NavTree XNode++-- | List of nodes of navigable tree representation++type NavXmlTrees  = [NavXmlTree]++-- | Type synonym for a list of navigable tree representation++type NodeSet      = NavXmlTrees++-- | A functions that takes a XPath result and returns a XPath result++type XPathFilter  = XPathValue -> XPathValue++++-- -----------------------------------------------------------------------------+--+-- Env++-- | XPath environment+--+-- All variables are stored in the environment,+-- each variable name is bound to a value.++type VarTab       = [(VarName, XPathValue)]+type KeyTab       = [(QName, String, NavXmlTree)]++type Env          = (VarTab, KeyTab)++varEnv :: Env+varEnv = ( [ (("", "name"), XPVNumber NaN) ]+	 , []+         )++-- -----------------------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/XPath/XPathEval.hs view
@@ -0,0 +1,662 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.XPath.XPathEval+   Copyright  : Copyright (C) 2006 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable+   Version    : $Id: XPathEval.hs,v 1.8 2006/10/12 11:51:29 hxml Exp $++   The core functions for evaluating the different types of XPath expressions.+   Each 'Expr'-constructor is mapped to an evaluation function.++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.XPath.XPathEval+    ( getXPath+    , getXPathWithNsEnv+    , getXPathSubTrees+    , getXPathSubTreesWithNsEnv+    , getXPathNodeSet+    , getXPathNodeSetWithNsEnv+    , evalExpr+    )+where++import Yuuko.Text.XML.HXT.XPath.XPathFct+import Yuuko.Text.XML.HXT.XPath.XPathDataTypes+import Yuuko.Text.XML.HXT.XPath.XPathArithmetic+    ( xPathAdd+    , xPathDiv+    , xPathMod+    , xPathMulti+    , xPathUnary+    )+import Yuuko.Text.XML.HXT.XPath.XPathParser+    ( parseXPath )++import Yuuko.Text.XML.HXT.XPath.XPathToString+    ( xPValue2XmlTrees )++import Yuuko.Text.XML.HXT.XPath.XPathToNodeSet+    ( xPValue2NodeSet+    , emptyNodeSet+    )++import Text.ParserCombinators.Parsec+    ( runParser )++import Data.Maybe+    ( fromJust )++-- ----------------------------------------++-- the DOM functions++import           Yuuko.Text.XML.HXT.DOM.Interface+import qualified Yuuko.Text.XML.HXT.DOM.XmlNode as XN++-- ----------------------------------------++-- the list arrow functions++import Control.Arrow			( (>>>), (>>^) )+import Yuuko.Control.Arrow.ArrowList		( arrL, isA )+import Yuuko.Control.Arrow.ArrowIf    	( filterA )+import Yuuko.Control.Arrow.ListArrow		( runLA )+import qualified+       Yuuko.Control.Arrow.ArrowTree		as AT+import Yuuko.Text.XML.HXT.Arrow.XmlArrow	( ArrowDTD, isDTD, getDTDAttrl )+import Yuuko.Text.XML.HXT.Arrow.Edit		( canonicalizeForXPath )++-- -----------------------------------------------------------------------------++-- |+-- Select parts of a document by an XPath expression.+--+-- The main filter for selecting parts of a document via XPath.+-- The string argument must be a XPath expression with an absolute location path,+-- the argument tree must be a complete document tree.+-- Result is a possibly empty list of XmlTrees forming the set of selected XPath values.+-- XPath values other than XmlTrees (numbers, attributes, tagnames, ...)+-- are convertet to text nodes.++getXPath		:: String -> XmlTree -> XmlTrees+getXPath		= getXPathWithNsEnv []++-- |+-- Select parts of a document by a namespace aware XPath expression.+--+-- Works like 'getXPath' but the prefix:localpart names in the XPath expression+-- are interpreted with respect to the given namespace environment++getXPathWithNsEnv	:: Attributes -> String -> XmlTree -> XmlTrees+getXPathWithNsEnv env s	= runLA ( canonicalizeForXPath+				  >>>+				  arrL (getXPathValues xPValue2XmlTrees xPathErr (toNsEnv env) s)+				)++-- |+-- Select parts of an XML tree by a XPath expression.+--+-- The main filter for selecting parts of an arbitrary XML tree via XPath.+-- The string argument must be a XPath expression with an absolute location path,+-- There are no restrictions on the arument tree.+--+-- No canonicalization is performed before evaluating the query+--+-- Result is a possibly empty list of XmlTrees forming the set of selected XPath values.+-- XPath values other than XmlTrees (numbers, attributes, tagnames, ...)+-- are convertet to text nodes.++getXPathSubTrees	:: String -> XmlTree -> XmlTrees+getXPathSubTrees	= getXPathSubTreesWithNsEnv []++-- | Same as 'getXPathSubTrees' but with namespace aware XPath expression++getXPathSubTreesWithNsEnv	:: Attributes -> String -> XmlTree -> XmlTrees+getXPathSubTreesWithNsEnv nsEnv xpStr+    = getXPathValues xPValue2XmlTrees xPathErr (toNsEnv nsEnv) xpStr++-- | compute the node set of an XPath query++getXPathNodeSet		:: String -> XmlTree -> XmlNodeSet+getXPathNodeSet		= getXPathNodeSetWithNsEnv []++-- | compute the node set of a namespace aware XPath query++getXPathNodeSetWithNsEnv	:: Attributes -> String -> XmlTree -> XmlNodeSet+getXPathNodeSetWithNsEnv nsEnv xpStr+    = getXPathValues xPValue2NodeSet (const (const emptyNodeSet)) (toNsEnv nsEnv) xpStr++-- | parse xpath, evaluate xpath expr and prepare results++getXPathValues	:: (XPathValue -> a) -> (String -> String -> a) -> NsEnv -> String -> XmlTree -> a+getXPathValues cvRes cvErr nsEnv xpStr t+    = case (runParser parseXPath nsEnv "" xpStr) of+      Left parseError+	  -> cvErr xpStr (show parseError)+      Right xpExpr+	  -> evalXP xpExpr+    where+    evalXP xpe+	= cvRes xpRes+	where+	t'      = addRoot t				-- we need a root node for starting xpath eval+	idAttr	= ( ("", "idAttr")			-- id attributes from DTD (if there)+		  , idAttributesToXPathValue . getIdAttributes $ t'+		  )+	navTD	= ntree t'+	xpRes	= evalExpr (idAttr:(getVarTab varEnv),[]) (1, 1, navTD) xpe (XPVNode [navTD])++addRoot	:: XmlTree -> XmlTree+addRoot t+    | XN.isRoot t+	= t+    | otherwise+	= XN.mkRoot [] [t]++xPathErr	:: String -> String -> [XmlTree]+xPathErr xpStr parseError+    = [XN.mkError c_err ("Syntax error in XPath expression " ++ show xpStr ++ ": " ++ show parseError)]++-- |+-- The main evaluation entry point. +-- Each XPath-'Expr' is mapped to an evaluation function. The 'Env'-parameter contains the set of global variables+-- for the evaluator, the 'Context'-parameter the root of the tree in which the expression is evaluated.+-- ++evalExpr :: Env -> Context -> Expr -> XPathFilter+evalExpr env cont (GenExpr Or ex)+    = boolEval env cont Or ex+evalExpr env cont (GenExpr And ex)+    = boolEval env cont And ex+    +evalExpr env cont (GenExpr Eq ex)+    = relEqEval env cont Eq . evalExprL env cont ex+evalExpr env cont (GenExpr NEq ex)+    = relEqEval env cont NEq . evalExprL env cont ex+evalExpr env cont (GenExpr Less ex)+    = relEqEval env cont Less . evalExprL env cont ex+evalExpr env cont (GenExpr LessEq ex)+    = relEqEval env cont LessEq . evalExprL env cont ex+evalExpr env cont (GenExpr Greater ex)+    = relEqEval env cont Greater . evalExprL env cont ex+evalExpr env cont (GenExpr GreaterEq ex)+    = relEqEval env cont GreaterEq . evalExprL env cont ex++evalExpr env cont (GenExpr Plus ex)+    = numEval xPathAdd Plus . toXValue xnumber cont env . evalExprL env cont ex+evalExpr env cont (GenExpr Minus ex)+    = numEval xPathAdd Minus . toXValue xnumber cont env . evalExprL env cont ex+evalExpr env cont (GenExpr Div ex)+    = numEval xPathDiv Div . toXValue xnumber cont env . evalExprL env cont ex+evalExpr env cont (GenExpr Mod ex)+    = numEval xPathMod Mod . toXValue xnumber cont env . evalExprL env cont ex+evalExpr env cont (GenExpr Mult ex)+    = numEval xPathMulti Mult . toXValue xnumber cont env . evalExprL env cont ex++evalExpr env cont (GenExpr Unary ex)+    = xPathUnary . xnumber cont env . evalExprL env cont ex++evalExpr env cont (GenExpr Union ex)+    = unionEval . evalExprL env cont ex++evalExpr env cont (FctExpr name args)+    = fctEval env cont name args++evalExpr env _ (PathExpr Nothing (Just lp))+    = locPathEval env lp+evalExpr env cont (PathExpr (Just fe) (Just lp))+    = locPathEval env lp . evalExpr env cont fe++evalExpr env cont (FilterExpr ex)+    = filterEval env cont ex+evalExpr env _ ex+    = evalSpezExpr env ex++++evalExprL :: Env -> Context -> [Expr] -> XPathValue -> [XPathValue]+evalExprL env cont ex ns+    = map (\e -> evalExpr env cont e ns) ex++evalSpezExpr :: Env -> Expr -> XPathFilter+evalSpezExpr _ (NumberExpr (Float 0)) _+    = XPVNumber Pos0+evalSpezExpr _ (NumberExpr (Float f)) _+    = XPVNumber (Float f)+evalSpezExpr _ (LiteralExpr s) _+    = XPVString s+evalSpezExpr env (VarExpr name) v+    = getVariable env name v+evalSpezExpr _ _ _+    = XPVError "Call to evalExpr with a wrong argument"+++-- -----------------------------------------------------------------------------++-- |+-- filter for evaluating a filter-expression+filterEval :: Env -> Context -> [Expr] -> XPathFilter+filterEval env cont (prim:predicates) ns+    = case evalExpr env cont prim ns of+        new_ns@(XPVNode _) -> evalPredL env predicates new_ns+        _                  -> XPVError "Return of a filterexpression is not a nodeset"+filterEval _ _ _ _+    = XPVError "Call to filterEval without an expression"++++-- |+-- returns the union of its arguments, the arguments have to be node-sets.+unionEval :: [XPathValue] -> XPathValue+unionEval+    = createDocumentOrder . remDups . unionEval'+      where+      unionEval' (e@(XPVError _):_)           = e+      unionEval' (_:e@(XPVError _):_)         = e+      unionEval' [n@(XPVNode _)]              = n+      unionEval' ((XPVNode n):(XPVNode m):xs) = unionEval ( (XPVNode (n ++ m)):xs)+      unionEval' _                            = XPVError "The value of a union ( | ) is not a nodeset"++++-- |+-- Equality or relational test for node-sets, numbers, boolean values or strings,+-- each computation of two operands is done by relEqEv'+relEqEval :: Env -> Context -> Op -> [XPathValue] -> XPathValue+relEqEval env cont op+    = foldl1 (relEqEv' env cont op)++    ++relEqEv' :: Env -> Context -> Op -> XPathValue -> XPathFilter+relEqEv' _ _ _ e@(XPVError _) _ = e+relEqEv' _ _ _ _ e@(XPVError _) = e++-- two node-sets+relEqEv' env cont op a@(XPVNode _) b@(XPVNode _)+    = relEqTwoNodes env cont op a b++-- one node-set+relEqEv' env cont op a b@(XPVNode _)+    = relEqOneNode env cont (fromJust $ getOpFct op) a b+relEqEv' env cont op a@(XPVNode _) b+    = relEqOneNode env cont (flip $ fromJust $ getOpFct op) b a+++--  test without a node-set and equality or not-equality operator+relEqEv' env cont Eq a b  = eqEv env cont (==) a b+relEqEv' env cont NEq a b = eqEv env cont (/=) a b++-- test without a node-set and less, less-equal, greater or greater-equal operator+relEqEv' env cont op a b+    = XPVBool ((fromJust $ getOpFct op) (toXNumber a) (toXNumber b))+      where+      toXNumber x = xnumber cont env [x]++++-- |+-- Equality or relational test for two node-sets.+-- The comparison will be true if and only if there is a node in the first node-set+-- and a node in the second node-set such that the result of performing the+-- comparison on the string-values of the two nodes is true+relEqTwoNodes :: Env -> Context -> Op -> XPathValue -> XPathFilter+relEqTwoNodes _ _ op (XPVNode ns) (XPVNode ms)+    = XPVBool (foldr  (\n -> (any (fct op n) (getStrValues ms) ||)) False ns)+      where+      fct op' n'   = (fromJust $ getOpFct op') (stringValue n')+      getStrValues = map stringValue+relEqTwoNodes _ _ _ _ _+    = XPVError "Call to relEqTwoNodes without a nodeset"+++-- |+-- Comparison between a node-set and different type.+-- The node-set is converted in a boolean value if the second argument is of type boolean.+-- If the argument is of type number, the node-set is converted in a number, otherwise it is converted+-- in a string value.+relEqOneNode :: Env -> Context -> (XPathValue -> XPathValue -> Bool) -> XPathValue -> XPathFilter+relEqOneNode env cont fct arg (XPVNode ns)+    = XPVBool (any  (fct arg) (getStrValues arg ns))+      where+      getStrValues arg' = map ((fromJust $ getConvFct arg') cont env . wrap) . map stringValue+      wrap x = [x]+relEqOneNode _ _ _ _ _+    = XPVError "Call to relEqOneNode without a nodeset"++++-- |+-- No node-set is involved and the operator is equality or not-equality.+-- The arguments are converted in a common type. If one argument is a boolean value+-- then it is the boolean type. If a number is involved, the arguments have to converted in numbers,+-- else the string type is the common type.+eqEv :: Env -> Context -> (XPathValue -> XPathValue -> Bool) -> XPathValue -> XPathFilter+eqEv env cont fct f@(XPVBool _) g+    = XPVBool (f `fct` xboolean cont env [g])+eqEv env cont fct f g@(XPVBool _)+    = XPVBool (xboolean cont env [f] `fct` g)++eqEv env cont fct f@(XPVNumber _) g+    = XPVBool (f `fct` xnumber cont env [g])+eqEv env cont fct f g@(XPVNumber _)+    = XPVBool (xnumber cont env [f] `fct` g)++eqEv env cont fct f g+    = XPVBool (xstring cont env [f] `fct` xstring cont env [g])+++getOpFct :: Op -> Maybe (XPathValue -> XPathValue -> Bool)+getOpFct Eq        = Just (==)+getOpFct NEq       = Just (/=)+getOpFct Less      = Just (<)+getOpFct LessEq    = Just (<=)+getOpFct Greater   = Just (>)+getOpFct GreaterEq = Just (>=)+getOpFct _         = Nothing++++-- |+-- Filter for accessing the root element of a document tree+getRoot :: XPathFilter+getRoot (XPVNode (n:_))+    = XPVNode [getRoot' n]+      where+      getRoot' tree+        = case upNT tree of+            Nothing -> tree+            Just t -> getRoot' t+getRoot _+    = XPVError "Call to getRoot without a nodeset"++++-- |+-- Filter for accessing all nodes of a XPath-axis+--+--    * 1.parameter as :  axis specifier+--+getAxisNodes :: AxisSpec ->  XPathFilter+getAxisNodes as (XPVNode ns)+    = XPVNode (concat $ map (fromJust $ lookup as axisFctL) ns)+getAxisNodes _ _+    = XPVError "Call to getAxis without a nodeset"++++-- |+-- Axis-Function-Table.+-- Each XPath axis-specifier is mapped to the corresponding axis-function+axisFctL :: [(AxisSpec, (NavXmlTree -> NavXmlTrees))]+axisFctL = [ (Ancestor, ancestorAxis)+           , (AncestorOrSelf, ancestorOrSelfAxis)+           , (Attribute, attributeAxis)+           , (Child, childAxis)+           , (Descendant, descendantAxis)+           , (DescendantOrSelf, descendantOrSelfAxis)+           , (Following, followingAxis)+           , (FollowingSibling, followingSiblingAxis)+           , (Parent, parentAxis)+           , (Preceding, precedingAxis)+           , (PrecedingSibling, precedingSiblingAxis)+           , (Self, selfAxis)+           ]+++-- |+-- evaluates a location path,+-- evaluation of an absolute path starts at the document root, +-- the relative path at the context node+locPathEval :: Env -> LocationPath -> XPathFilter+locPathEval env (LocPath Rel steps)+    = evalSteps env steps+locPathEval env (LocPath Abs steps)+    = evalSteps env steps . getRoot+++++evalSteps :: Env -> [XStep] -> XPathFilter+evalSteps env steps ns+    = foldl (evalStep env) ns steps+++-- |+-- evaluate a single XPath step+-- namespace-axis is not supported+evalStep :: Env -> XPathValue -> XStep -> XPathValue+evalStep _   _  (Step Namespace _ _)  = XPVError "namespace-axis not supported"+evalStep _   ns (Step Attribute nt _) = evalAttr nt (getAxisNodes Attribute ns)+evalStep env ns (Step axisSpec nt pr) = evalStep' env pr nt (getAxisNodes axisSpec ns)++++evalAttr :: NodeTest -> XPathFilter+evalAttr nt (XPVNode ns)+    = XPVNode (foldr (\n -> (evalAttrNodeTest nt n ++)) [] ns)+evalAttr _ _+    = XPVError "Call to evalAttr without a nodeset"+++evalAttrNodeTest :: NodeTest -> NavXmlTree -> NavXmlTrees+evalAttrNodeTest (NameTest qn) ns@(NT (NTree (XAttr qn1) _) _ _ _)+    = if ( ( uri == uri1               && lp == lp1)+	   || +           ((uri == "" || uri == uri1) && lp == "*") +         )+      then [ns]+      else []+      where+      uri  = namespaceUri qn+      uri1 = namespaceUri qn1+      lp   = localPart    qn+      lp1  = localPart    qn1++evalAttrNodeTest (TypeTest XPNode) ns@(NT (NTree (XAttr _) _) _ _ _)+    = [ns]++evalAttrNodeTest _ _+    = []++evalStep' :: Env -> [Expr] -> NodeTest -> XPathFilter+evalStep' env pr nt+    = evalPredL env pr . nodeTest nt+++evalPredL :: Env -> [Expr] -> XPathFilter+evalPredL env pr n@(XPVNode ns)+    = remDups $ foldl (evalPred env 1 (length ns)) n pr+evalPredL _ _ _+    = XPVError "Call to evalPredL without a nodeset"+++evalPred :: Env -> Int -> Int -> XPathValue -> Expr -> XPathValue+evalPred _ _ _ ns@(XPVNode []) _ = ns+evalPred env pos len (XPVNode (x:xs)) ex+    = case testPredicate env (pos, len, x) ex (XPVNode [x]) of+        e@(XPVError _) -> e+        XPVBool True   -> XPVNode (x : n)+        XPVBool False  -> nextNode+        _              -> XPVError "Value of testPredicate is not a boolean"+      where nextNode@(XPVNode n) = evalPred env (pos+1) len (XPVNode xs) ex+evalPred _ _ _ _ _+    = XPVError "Call to evalPred without a nodeset"++++testPredicate :: Env -> Context -> Expr -> XPathFilter+testPredicate env context@(pos, _, _) ex ns+    = case evalExpr env context ex ns of+        XPVNumber (Float f) -> XPVBool (f == fromIntegral pos)+        XPVNumber _         -> XPVBool False+        _                   -> xboolean context env [evalExpr env context ex ns]+++-- |+-- filter for selecting a special type of nodes from the current fragment tree+--+-- the filter works with namespace activated and without namespaces.+-- If namespaces occur in XPath names, the uris are used for matching,+-- else the name prefix+--+--    Bugfix : "*" (or any other name-test) must not match the root node++nodeTest :: NodeTest -> XPathFilter++-- nodeTest (NameTest (QN "" "*" ""))      = filterNodes (\n -> isXTagNode n && not (isRootNode n))+-- nodeTest (NameTest (QN _ "*" uri))      = filterNodes (filterd uri)++nodeTest (NameTest q)+    | isWildcardTest+	= filterNodes (wildcardTest q)+    | otherwise+        = filterNodes (nameTest q)		-- old: (isOfTagNode1 q)+      where+      isWildcardTest = localPart q == "*"++nodeTest (PI n)                         = filterNodes isPiNode+					  where+					  isPiNode = maybe False ((== n) . qualifiedName) . XN.getPiName++nodeTest (TypeTest t)                   = typeTest t++nameTest	:: QName -> XNode -> Bool+nameTest xpName (XTag elemName _)+    | namespaceAware+	= localPart xpName == localPart elemName+	  &&+	  namespaceUri xpName == namespaceUri elemName+    | otherwise+	= qualifiedName xpName == qualifiedName elemName+    where+    namespaceAware = not . null . namespaceUri $ xpName++nameTest _ _ = False++wildcardTest	:: QName -> XNode -> Bool+wildcardTest xpName (XTag elemName _)+    | namespaceAware+	= namespaceUri xpName == namespaceUri elemName+    | prefixMatch+	= namePrefix xpName == namePrefix elemName+    | otherwise+	= localPart elemName /= t_root			-- all names except the root name "/"+    where+    namespaceAware = not . null . namespaceUri $ xpName+    prefixMatch    = not . null . namePrefix   $ xpName++wildcardTest _ _ = False++-- |+-- tests whether a node is of a special type+--+typeTest :: XPathNode -> XPathFilter+typeTest XPNode         = id+typeTest XPCommentNode  = filterNodes XN.isCmt+typeTest XPPINode       = filterNodes XN.isPi+typeTest XPTextNode     = filterNodes XN.isText++-- |+-- the filter selects the NTree part of a navigable tree and+-- tests whether the node is of the necessary type+--+--    * 1.parameter fct :  filter function from the XmlTreeFilter module which tests the type of a node+--+filterNodes :: (XNode -> Bool) -> XPathFilter+filterNodes fct (XPVNode ns)+    = XPVNode ([n | n@(NT (NTree node _) _ _ _) <- ns , fct node])+filterNodes _ _+    = XPVError "Call to filterNodes without a nodeset"++-- |+-- evaluates a boolean expression, the evaluation is non-strict+boolEval :: Env -> Context -> Op -> [Expr] -> XPathFilter+boolEval _ _ op [] _+    = XPVBool (op==And)+boolEval env cont Or (x:xs) ns+    = case xboolean cont env [evalExpr env cont x ns] of+        e@(XPVError _) -> e+        XPVBool True   -> XPVBool True+        _              -> boolEval env cont Or xs ns++boolEval env cont And (x:xs) ns+    = case xboolean cont env [evalExpr env cont x ns] of+        e@(XPVError _) -> e+        XPVBool True   -> boolEval env cont And xs ns+        _              -> XPVBool False+boolEval _ _ _ _ _+    = XPVError "Call to boolEval with a wrong argument"++++-- |+-- returns the value of a variable+getVariable :: Env -> VarName -> XPathFilter+getVariable env name _+    = case lookup name (getVarTab env) of+        Nothing -> XPVError ("Variable: " ++ show name ++ " not found")+        Just v  -> v+++-- |+-- evaluates a function, +-- computation is done by 'XPathFct.evalFct' which is defined in "XPathFct".+fctEval :: Env -> Context -> FctName -> [Expr] -> XPathFilter+fctEval env cont name args+    = evalFct name env cont . evalExprL env cont args++++-- |+-- evaluates an arithmetic operation.+--+--   1.parameter f :  arithmetic function from "XPathArithmetic"+--+numEval :: (Op -> XPathValue -> XPathValue -> XPathValue) -> Op -> [XPathValue] -> XPathValue+numEval f op = foldl1 (f op)++++-- |+-- Convert list of ID attributes from DTD into a space separated 'XPVString'+--++idAttributesToXPathValue	:: XmlTrees -> XPathValue+idAttributesToXPathValue ts+    = XPVString (foldr (\ n -> ( (valueOfDTD a_value n ++ " ") ++)) [] ts)++-- |+-- Extracts all ID-attributes from the document type definition (DTD).+--++getIdAttributes	:: XmlTree -> XmlTrees+getIdAttributes+    = runLA $+      AT.getChildren+      >>>+      isDTD+      >>>+      AT.deep (isIdAttrType)++-- ----------------------------------------++isIdAttrType		:: ArrowDTD a => a XmlTree XmlTree+isIdAttrType		= hasDTDAttrValue a_type (== k_id)++valueOfDTD		:: String -> XmlTree -> String+valueOfDTD n		= concat . runLA ( getDTDAttrl >>^ lookup1 n )++hasDTDAttrValue		:: ArrowDTD a => String -> (String -> Bool) -> a XmlTree XmlTree+hasDTDAttrValue	an p	= filterA $+			  getDTDAttrl >>> isA (p . lookup1 an)++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/XPath/XPathFct.hs view
@@ -0,0 +1,887 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.XPath.XPathFct+   Copyright  : Copyright (C) 2008 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   The module contains the core-functions of the XPath function library.+   All functions are implemented as XFct. Each XFct contains the evaluation context,+   the variable environment and the function arguments.++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.XPath.XPathFct+    ( XFct+    , evalFct+    , toXValue+    , xnumber+    , xboolean+    , xstring+    , getConvFct+    , stringValue+    , remDups+    , isNotInNodeList+    , createDocumentOrder+    , createDocumentOrderReverse+    , getVarTab+    , getKeyTab+    )+where++import Yuuko.Text.XML.HXT.XPath.XPathDataTypes+import Yuuko.Text.XML.HXT.XPath.XPathParser+    ( parseNumber+    )+import Yuuko.Text.XML.HXT.XPath.XPathArithmetic+    ( xPathAdd+    )++import Control.Arrow				( (>>>), (<+>) )+import Yuuko.Control.Arrow.ArrowList			( constA )+import Yuuko.Control.Arrow.ArrowIf    		( ifA )+import Yuuko.Control.Arrow.ArrowTree			( deep )+import Yuuko.Control.Arrow.ListArrow			( LA, runLA )+import Yuuko.Text.XML.HXT.Arrow.XmlArrow+import Yuuko.Text.XML.HXT.Arrow.ReadDocument		(readDocument)+import Yuuko.Text.XML.HXT.Arrow.XmlIOStateArrow	(runX)++import           Yuuko.Text.XML.HXT.DOM.Interface+import qualified Yuuko.Text.XML.HXT.DOM.XmlNode as XN++import System.IO.Unsafe+    ( unsafePerformIO+    )++import Data.Char+    ( isAscii+    , isUpper+    , isLower+    , isDigit+    , ord+    )++import Data.List+    ( sortBy+    )++import Data.Maybe++-- -----------------------------------------------------------------------------++-- added by Tim Walkenhorst to fix Pos0 vs. Float 0.0 problems...++int2XPNumber :: Int -> XPNumber+int2XPNumber 0 = Pos0+int2XPNumber i = Float $ fromIntegral i++-- |+-- Type signature for all functions which can be used in the XPath module.++type XFct = (Context -> Env -> [XPathValue] -> XPathValue)++-- |+-- All functions are stored in a function table.++type FctTable = [(FctName, FctTableElem)]++-- |+-- Each table entry consists of the function and the expected function arguments.++type FctTableElem = (XFct, CheckArgCount)++-- |+-- Tests whether the number of current function arguments is correct++type CheckArgCount = ([XPathValue] -> Bool)++zero, zeroOrOne, one, two, twoOrM, twoOrThree, three :: CheckArgCount+zero ex       = length ex == 0+zeroOrOne ex  = length ex == 0 || length ex == 1+one ex        = length ex == 1+two ex        = length ex == 2+twoOrM ex     = length ex >= 2+twoOrThree ex = length ex == 2 || length ex == 3+three ex      = length ex == 3+++-- |+-- The core-functions library++fctTable :: FctTable+fctTable = [+            ("last", (xlast, zero)), -- nodeset functions+            ("position",(xposition, zero)),+            ("count",(xcount, one)),+            ("id", (xid, one)),+            ("local-name", (xlocalName, zeroOrOne)),+            ("namespace-uri", (xnamespaceUri, zeroOrOne)),+            ("name", (xname, zeroOrOne)),++            ("string", (xstring, zeroOrOne)), -- string functions+            ("concat", (xconcat, twoOrM)),+            ("starts-with",(xstartsWith, two)),+            ("contains", (xcontains, two)),+            ("substring-before", (xsubstringBefore, two)),+            ("substring-after", (xsubstringAfter, two)),+            ("substring", (xsubstring, twoOrThree)),+            ("string-length", (xstringLength, zeroOrOne)),+            ("normalize-space", (xnormalizeSpace, zeroOrOne)),+            ("translate", (xtranslate, three)),++            ("boolean", (xboolean, one)), -- boolean functions+            ("not", (xnot, one)),+            ("true", (xtrue, zero)),+            ("false",(xfalse, zero)),+            ("lang", (xlang, one)),++            ("number",(xnumber, zeroOrOne)), -- number functions+            ("sum",(xsum, one)),+            ("floor",(xfloor, one)),+            ("ceiling",(xceiling, one)),+            ("round",(xround, one)),+            ("key",(xkey, two)),+            ("format-number",(xformatNumber, twoOrThree)),+            +            ("document", (xdocument, one)),-- extension functions for xslt 1.0+            ("generate-id", (xgenerateId, zeroOrOne))+            +           ]++-- -----------------------------------------------------------------------------++-- some helper functions++-- |+-- Returns the table of keys, needed by xslt, from the environment++getKeyTab :: Env -> KeyTab+getKeyTab (_, keyTab) = keyTab+++-- |+-- Returns the table of variables from the environment++getVarTab :: Env -> VarTab+getVarTab (varTab, _) = varTab+++-- |+-- Returns the conversion function for the XPath results: string, boolean and number+-- A nodeset can not be converted.++getConvFct :: XPathValue -> Maybe XFct+getConvFct (XPVNumber _) = Just xnumber+getConvFct (XPVString _) = Just xstring+getConvFct (XPVBool _)   = Just xboolean+getConvFct _             = Nothing+++-- |+-- Filter for ordering a list of Nodes in document order++createDocumentOrder :: XPathFilter+createDocumentOrder (XPVNode n) = XPVNode (sortBy documentOrder n)+      where+      documentOrder :: NavXmlTree -> NavXmlTree -> Ordering+      documentOrder a b = compare (documentPos a) (documentPos b)++createDocumentOrder e@(XPVError _) = e+createDocumentOrder _ = XPVError "Call to createDocumentOrder without a nodeset"+++-- |+-- Filter for ordering a list of Nodes in reverse document order++createDocumentOrderReverse :: XPathFilter+createDocumentOrderReverse (XPVNode n) = XPVNode (sortBy documentOrderReverse n)+      where+      documentOrderReverse :: NavXmlTree -> NavXmlTree -> Ordering+      documentOrderReverse a b = compare (documentPos b) (documentPos a)++createDocumentOrderReverse e@(XPVError _) = e+createDocumentOrderReverse _              = XPVError "Call to createDocumentOrderReverse without a nodeset"++-- |+-- Filter for removing identical fragment trees in a nodeset++remDups :: XPathFilter+remDups e@(XPVError _) = e+remDups (XPVNode []) = XPVNode []+remDups (XPVNode (x:xs))+    | isNotInNodeList x xs = XPVNode (x : y)+    | otherwise            = remDups (XPVNode xs)+      where+      (XPVNode y) = remDups (XPVNode xs)+remDups _ = XPVError "Call to remDups without a nodeset"++-- |+-- Check whether a node is not a part of a node list. Needed to implement matching & testing in xslt.++isNotInNodeList :: NavXmlTree -> [NavXmlTree] -> Bool+isNotInNodeList n xs' = nodeID (Just n) `notElem` map (nodeID . Just) xs'+++-- |+-- calculate an ID for a NODE+--+--    - returns : a list of numbers, one number for each level of the tree++-- Tim Walkenhorst:+--   - Attributes are identified by their QName (they do not have previous siblings)+--   - Elements are identified by their relative position (# of previous siblings)++data IdPathStep = IdRoot String | IdPos Int | IdAttr QName deriving (Show, Eq, Ord)++nodeID :: Maybe (NavXmlTree) -> [IdPathStep]+nodeID Nothing = []+nodeID (Just t@(NT (NTree (XAttr qn) _)  _ _ _)) = IdAttr qn : nodeID (upNT t)+nodeID (Just t@(NT node _ prev _))               +   | XN.isRoot node+       = return $ IdRoot (getRootId node) +   | otherwise+       = IdPos (length prev) : nodeID (upNT t)+   where+   getRootId	= concat . runLA (getAttrValue "rootId")++-- |+-- Calculates the position of a node in a tree (in document order)++documentPos :: NavXmlTree -> [IdPathStep]+documentPos tree = reverse $ nodeID (Just tree)+++-- |+-- Evaluates a function.+-- Calculation of the function value is done by looking up the function name in the function table,+-- check the number of arguments and calculate the funtion, if no+-- argument evaluation returns an error.+--+--    - returns : the function value as 'XPathValue'++evalFct :: FctName -> Env -> Context -> [XPathValue] -> XPathValue+evalFct name env cont args+    = case (lookup name fctTable) of+        Nothing -> XPVError ("Call to undefined function "++ name)+        Just (fct, checkArgCount) ->+          if not (checkArgCount args)+            then XPVError ("Call to function "++ name ++ " with wrong arguments")+            else case (checkArgErrors args) of+                   Just e  -> e+                   Nothing -> fct cont env args+      where+      checkArgErrors [] = Nothing+      checkArgErrors ((XPVError r):_) = Just (XPVError r)+      checkArgErrors (_:xs) = checkArgErrors xs+++-- |+-- Converts a list of different 'XPathValue' types in a list of one 'XPathValue' type.+--+--    * 1.parameter fct :  the conversion function+--++toXValue :: XFct -> Context -> Env -> [XPathValue] -> [XPathValue]+toXValue fct c env args = [fct c env [x] | x <- args]+++-- -----------------------------------------------------------------------------+-- core-funktions library++-- nodeset functions++-- |+-- number last(): returns a number equal to the context size from the expression evaluation context++xlast :: XFct+xlast (_, len , _) _ _ = XPVNumber $ int2XPNumber len+++-- |+-- number position(): returns a number equal to the context position from the expression evaluation context++xposition :: XFct+xposition (pos, _ , _) _ _ = XPVNumber $ int2XPNumber pos+++-- |+-- number count(node-set): returns the number of nodes in the argument node-set++xcount :: XFct+xcount _ _ [XPVNode ns] = XPVNumber $ int2XPNumber $ length ns+xcount _ _ _ = XPVError "Call to function count with wrong arguments"+++-- |+-- node-set id(object): selects elements by their unique ID++xid :: XFct+xid (_, _, cn) env [XPVNode ns]+    = isInId  (getIds env) (strValues ns) [cn]+      where+      strValues = map ((\ (XPVString str) -> str) . stringValue)++xid c@(_, _, cn) env arg+    = isInId (getIds env) ( (\(XPVString s) -> words s) (xstring c env arg)) [cn]++++-- |+-- returns all IDs from the variable environment as a list of strings.+-- the IDs are stored in the variable: idAttr++getIds :: Env -> [String]+getIds env+-- hier muss noch auf prefix getestet werden+    = words $ (\ (XPVString str) -> str) . fromJust $ lookup ("", "idAttr") $ getVarTab env +++isInId :: [String] -> [String] -> NavXmlTrees -> XPathValue+isInId ids str ns+    = remDups (XPVNode (concat $ map (filterNS ids str . descendantOrSelfAxis) ns))+++filterNS :: [String] -> [String] -> NavXmlTrees -> NavXmlTrees+filterNS ids str ns+    = [ n | n@(NT a@(NTree _ _) _ _ _) <- ns, or $ map (idInIdList a str) ids]+      where+      idInIdList :: XmlTree -> [String] -> String -> Bool+      idInIdList al str' b = (getValue b al) `elem` str'+++-- |+-- string local-name(node-set?):+-- returns the local part of the expanded-name of the node in the argument node-set+-- that is first in document order. +-- If the argument node-set is empty or the first node has no expanded-name, an empty string is returned. +-- If the argument is omitted, it defaults to a node-set with the context node as its only member++--   Bugfix: name(\/) is "" not "\/"!++xlocalName :: XFct+xlocalName (_, _, cn) _ []  = XPVString (xpLocalPartOf $ subtreeNT cn)+xlocalName _ _ [XPVNode []] = XPVString ""+xlocalName _ _ [XPVNode ns] = XPVString (xpLocalPartOf $ subtreeNT $ head $ ns)+xlocalName _ _ _            = XPVError "Call to function local-name with wrong arguments"++-- |+-- string namespace-uri(node-set?):+-- returns the namespace URI of the expanded-name of the node in the argument node-set+-- that is first in document order.+-- If the argument node-set is empty, the first node has no expanded-name,+-- or the namespace URI of the expanded-name+-- is null, an empty string is returned. If the argument is omitted,+-- it defaults to a node-set with the context node as its only member++xnamespaceUri :: XFct+xnamespaceUri (_, _, cn) _ []  = XPVString (xpNamespaceOf $ subtreeNT cn)+xnamespaceUri _ _ [XPVNode []] = XPVString ""+xnamespaceUri _ _ [XPVNode ns] = XPVString (xpNamespaceOf $ subtreeNT $ head $ ns)+xnamespaceUri _ _ _            = XPVError "Call to function namespace-uri with wrong arguments"+++-- |+-- string name(node-set?): +-- returns a string containing a QName representing the expanded-name of the node+-- in the argument node-set +-- that is first in document order. If the argument node-set is empty or the first+-- node has no expanded-name, +-- an empty string is returned. If the argument it omitted, it defaults to a node-set+-- with the context node as its only member.+-- Tim Walkenhorst: ++--   Bugfix: name(\/) is "" not "\/"!++xname :: XFct+xname (_, _, cn) _ []  =  XPVString (xpNameOf $ subtreeNT cn)+xname _ _ [XPVNode []] = XPVString ""+xname _ _ [XPVNode ns] = XPVString (xpNameOf $ subtreeNT $ head $ ns)+xname _ _ _            = XPVError "Call to function name with wrong arguments"++-- ------------------------------------------------------------+-- string functions++-- |+-- some helper functions+getFirstPos :: String -> String -> Int+getFirstPos s sub+    = if (getFirstPos' s sub) > length s+        then -1+        else getFirstPos' s sub++getFirstPos' :: String -> String -> Int+getFirstPos' [] _ = 2+getFirstPos' (x:xs) sub+    = if strStartsWith (x:xs) sub+      then 0+      else 1 + getFirstPos' xs sub++strStartsWith :: String -> String -> Bool+strStartsWith a b+    = take (length b) a == b++++-- |+-- Returns the string-value of a node,+-- the value of a namespace node is not supported++stringValue :: NavXmlTree -> XPathValue+stringValue (NT a _ _ _)+    = XPVString $ xpTextOf a++{-+      textFilter +        = getXCmt `orElse`+--        getXNamespace `orElse`+          multi isXText+         +--        = (isXTag `guards` multi isXText) `orElse`+--          (isXPi `guards` multi isXText) `orElse`+--          (isXAttr `guards` multi isXText) `orElse`          +--          (isXText `guards` multi isXText) `orElse`+--          getXCmt+-}+++-- |+-- string string(object?): converts an object to a string++xstring :: XFct+xstring _ _ [XPVNode []]           = XPVString ""+xstring _ _ [XPVNode (x:_)]        = stringValue x+xstring (_, _, cn) _ []            = stringValue cn++xstring _ _ [XPVNumber (Float a)]+    | a == (fromInteger $ round a) = XPVString (show ((round a)::Integer))+    | otherwise                    = XPVString (show a)+xstring _ _ [XPVNumber s]          = XPVString (show s)++xstring _ _ [XPVBool True]         = XPVString "true"+xstring _ _ [XPVBool False]        = XPVString "false"++xstring _ _ [XPVString s]          = XPVString s+xstring _ _ [XPVError e]           = XPVError e+xstring _ _ _                      = XPVError "Call to xstring with a wrong argument"++++-- |+-- string concat(string, string, string*): returns the concatenation of its arguments++xconcat :: XFct+xconcat c env args +    = XPVString (foldr (\ (XPVString s) -> (s ++)) "" (toXValue xstring c env args))+++-- |+-- boolean starts-with(string, string): +-- returns true if the first argument string starts +-- with the second argument string, and otherwise returns false++xstartsWith :: XFct+xstartsWith c env args+    = XPVBool ( (\ ((XPVString a):[XPVString b]) -> strStartsWith a b) (toXValue xstring c env args))+++-- |+-- boolean contains(string, string):+-- returns true if the first argument string contains the second argument string,+-- and otherwise returns false++xcontains :: XFct+xcontains c env args+    = XPVBool ( (\ ((XPVString s):[XPVString sub]) -> getFirstPos s sub /= -1) (toXValue xstring c env args))+++-- |+-- string substring-before(string, string):+-- returns the substring of the first argument string that precedes the first occurrence of+-- the second argument string +-- in the first argument string, or the empty string if the first argument string does not+-- contain the second argument string++xsubstringBefore :: XFct+xsubstringBefore c env args+    = xsubstringBefore' c env (toXValue xstring c env args)++xsubstringBefore' :: XFct+xsubstringBefore' _ _ ((XPVString _):[XPVString []]) = XPVString ""+xsubstringBefore' _ _ ((XPVString s):[XPVString sub]) = XPVString (take (getFirstPos s sub) s)+xsubstringBefore' _ _ _ = XPVError "Call to xsubstringBefore' with a wrong argument"+++++-- |+-- string substring-after(string, string):+-- returns the substring of the first argument string that follows the first occurrence of+-- the second argument string +-- in the first argument string, or the empty string if the first argument string does not+-- contain the second argument string++xsubstringAfter :: XFct+xsubstringAfter c env args+    = xsubstringAfter' c env (toXValue xstring c env args)++xsubstringAfter' :: XFct+xsubstringAfter' _ _ ((XPVString s):[XPVString []])+    = XPVString s+xsubstringAfter' _ _ ((XPVString s):[XPVString sub])+    = if getFirstPos s sub == -1+        then (XPVString "")+        else XPVString (drop ((getFirstPos s sub)+length sub) s)+xsubstringAfter' _ _ _ +    = XPVError "Call to xsubstringAfter' with a wrong argument"+++-- |+-- string substring(string, number, number?):+-- returns the substring of the first argument starting at the position specified+-- in the second argument +-- with length specified in the third argument. If the third argument is not specified,+-- it returns the substring +-- starting at the position specified in the second argument and continuing to the end of the string.++xsubstring :: XFct+xsubstring c env (x:xs)+    = xsubstring' c env ((toXValue xstring c env [x])++(toXValue xnumber c env xs))+xsubstring _ _ _+    = XPVError "Call to xsubstring with a wrong argument"++xsubstring' :: XFct+xsubstring' c env ((XPVString s):start:[])+    = case xround c env [start] of+        XPVNumber NaN       -> XPVString ""+        XPVNumber PosInf    -> XPVString ""+        XPVNumber (Float f) -> XPVString (drop ((round f)-1) s)+        XPVNumber _         -> XPVString s+        _                   -> XPVError "Call to xsubstring' with a wrong argument"++xsubstring' c env ((XPVString s):start:[end])+    = case xPathAdd Plus (xround c env [start]) (xround c env [end]) of+        XPVNumber (Float f) -> xsubstring' c env ( (XPVString (take ((round f) -1) s)):[start])+        XPVNumber PosInf    -> xsubstring' c env ( (XPVString s):[start])+        XPVNumber _         -> XPVString ""+        _                   -> XPVError "Call to xsubstring' with a wrong argument"+xsubstring' _ _ _+    = XPVError "Call to xsubstring' with a wrong argument"+++-- |+-- number string-length(string?):+-- returns the number of characters in the string. If the argument is omitted,+-- it defaults to the context node +-- converted to a string, in other words the string-value of the context node.++xstringLength :: XFct+xstringLength c@(_, _, cn) env []+    = XPVNumber (Float (fromIntegral $ length s))+      where (XPVString s) = xstring c env [XPVNode [cn]]+xstringLength c env args+    = XPVNumber $ (\[XPVString s] -> int2XPNumber $ length s) (toXValue xstring c env args)+++-- |+-- string normalize-space(string?):+-- returns the argument string with whitespace normalized by stripping leading+-- and trailing whitespace and replacing sequences +-- of whitespace characters by a single space. If the argument is omitted,+-- it defaults to the context node converted to a string, +-- in other words the string-value of the context node.+-- The string is parsed by a function parseStr from XPathParser module. <-- No longer! Tim Walkenhorst++xnormalizeSpace :: XFct+xnormalizeSpace c@(_, _, cn) env []+    = (\(XPVString s) -> XPVString $ normStr s) (xstring c env [XPVNode [cn]])+xnormalizeSpace c env args+    = (\ [XPVString s] -> XPVString $ normStr s) (toXValue xstring c env args)++-- Tim Walkenhorst normStr replaces the use of parseStr...+normStr :: String -> String+normStr = unwords . words++-- |+-- string translate(string, string, string):+-- returns the first argument string with occurrences of characters in the second argument string replaced by the character at +-- the corresponding position in the third argument string+xtranslate :: XFct+xtranslate c env args+    = xtranslate' c env (toXValue xstring c env args)++xtranslate' :: XFct+xtranslate' _ _ ((XPVString a):(XPVString b):[XPVString c])+    = XPVString (replace a b c)+xtranslate' _ _ _+    = XPVError "Call to xtranslate' with a wrong argument"++replace :: String -> String -> String -> String+replace str [] _ = str++-- remove all characters, if there is no corresponding character in the third argument+replace str (x:xs) []+    = replace [ s | s <- str, x /= s] xs []++replace str (x:xs) (y:ys)+    = replace (rep x y str) xs ys+      where -- replace all characters in the first argument+      rep :: Char -> Char -> String -> String+      rep a b = foldr (\c -> if c == a then (b:) else (c:)) ""+++-- ------------------------------------------------------------+-- boolean functions++-- |+-- boolean boolean(object): converts its argument to a boolean value+xboolean :: XFct+xboolean _ _ [XPVNumber a] = XPVBool (a/= NaN && a/= Neg0 && a/= Pos0)+xboolean _ _ [XPVString s] = XPVBool (length s /= 0)+xboolean _ _ [XPVBool b]   = XPVBool b+xboolean _ _ [XPVNode ns]  = XPVBool (length ns > 0)+xboolean _ _ [XPVError e]  = XPVError e+xboolean _ _ _             = XPVError "Call to xboolean with a wrong argument"+++-- |+-- boolean not(boolean): returns true if its argument is false, and false otherwise+xnot :: XFct+xnot c env args+    = XPVBool ( (\ (XPVBool b) -> not b) (xboolean c env args) )+++-- |+-- boolean true(): returns true+xtrue :: XFct+xtrue _ _ _ = XPVBool True+++-- |+-- boolean false(): returns false+xfalse :: XFct+xfalse _ _ _ = XPVBool False+++-- |+-- boolean lang(string):+-- returns true or false depending on whether the language of the context node as specified by xml:lang attributes +-- is the same as or is a sublanguage of the language specified by the argument string++-- function needs namespaces which are not supported by the toolbox+xlang :: XFct+xlang _ _ _+    = XPVError "namespaces are not supported"++-- xlang c env args+--    = (\ (_, _, cn) [XPVString s] -> ...) c (toXValue xstring c env args)++++-- ------------------------------------------------------------+-- number functions++-- |+-- number number(object?): converts its argument to a number+xnumber :: XFct+xnumber c@(_, _, cn) env []+    = (\(XPVString s) -> parseNumber s) (xstring c env [XPVNode [cn]])+xnumber c env [n@(XPVNode _)]+    = (\(XPVString s) -> parseNumber s) (xstring c env [n])++xnumber _ _ [XPVBool b]+    | b                   = XPVNumber (Float 1)+    | otherwise           = XPVNumber Pos0++xnumber _ _ [XPVString s] = parseNumber s+xnumber _ _ [XPVNumber a] = XPVNumber a+xnumber _ _ [XPVError e]  = XPVError e+xnumber _ _ _             = XPVError "Call to xnumber with a wrong argument"+++-- |+-- number sum(node-set): +-- returns the sum, for each node in the argument node-set, of the result of +-- converting the string-values of the node to a number+xsum :: XFct+xsum _ _ [XPVNode []] = XPVNumber NaN+xsum c env [XPVNode ns]+    = foldr1 (\ a b -> (xPathAdd Plus a b)) (getValues ns)+      where+      getValues :: NodeSet -> [XPathValue]+      getValues = foldr (\ n -> ([xnumber c env $ [stringValue n] ] ++) ) []++xsum _ _ _+    = XPVError "The value of the function sum is not a nodeset"++-- |+-- number floor(number): returns the largest (closest to positive infinity) number that is not greater +-- than the argument and that is an integer+xfloor :: XFct+xfloor c env args+    = xfloor' (toXValue xnumber c env args)+      where+      xfloor' [XPVNumber (Float f)]+        | f > 0 && f < 1    = XPVNumber Pos0+        | otherwise         = XPVNumber (Float (fromInteger $ floor f))+      xfloor' [XPVNumber a] = XPVNumber a+      xfloor' _             = XPVError "Call to xfloor' without a number"+++-- |+-- number ceiling(number): returns the smallest (closest to negative infinity) number that is not less +-- than the argument and that is an integer+xceiling  :: XFct+xceiling c env args+    = xceiling' (toXValue xnumber c env args)+      where+      xceiling' [XPVNumber (Float f)]+        | f < 0 && f > -1     = XPVNumber Pos0+        | otherwise           = XPVNumber (Float (fromInteger $ ceiling f))+      xceiling' [XPVNumber a] = XPVNumber a+      xceiling' _             = XPVError "Call to xceiling' without a number"++-- |+-- number round(number):+-- returns the number that is closest to the argument and that is an integer. +-- If there are two such numbers, then the one that is closest to positive infinity is returned.+xround :: XFct+xround c env args+    = xround' c env (toXValue xnumber c env args)++xround' :: XFct+xround' _ _ [XPVNumber (Float f)]+    | f < 0 && f >= -0.5  = XPVNumber Neg0+    | f >= 0 && f < 0.5   = XPVNumber Pos0+    | otherwise           = XPVNumber (Float (fromInteger $ xPathRound f))+      where+      xPathRound a +        = if a - (fromInteger $ floor a) < 0.5+            then floor a+            else floor (a+1)++xround' _ _ [XPVNumber a] = XPVNumber a+xround' _ _ _             = XPVError "Call to xround' without a number"++++-- |+-- node-set key(string, object):+-- does for keys what the id function does for IDs+-- The first argument specifies the name of the key.+-- When the second argument is of type node-set, then the result is the+-- union of the result of applying the key function to the string value+-- of each of the nodes in the argument node-set.+-- When the second argument is of any other type, the argument is+-- converted to a string +xkey :: XFct+xkey _ env ((XPVString s) : [XPVNode ns])+    = isInKey (getKeyTab env) s (strValues ns)+      where+      strValues = map ((\ (XPVString str) -> str) . stringValue)++xkey c env ((XPVString s) : arg)+    -- = isInKey (getKeyTab env) s  ( (\(XPVString s) -> words s) (xstring c env arg))+    = isInKey (getKeyTab env) s [str]+      where+        (XPVString str) = xstring c env arg++xkey _ _ _ = XPVError "Call to xkey with a wrong argument"+++isInKey :: KeyTab -> String -> [String] -> XPathValue+isInKey kt kn kv+    -- = remDups (XPVNode (map ntree ts) )+    = XPVNode ts --(map ntree ts)+      where+        (_, _, ts) = unzip3 $ concat $ map (isKeyVal (isKeyName kt kn)) kv++isKeyName :: KeyTab -> String -> KeyTab+isKeyName kt kn = filter (isOfKeyName kn) kt++isKeyVal :: KeyTab -> String -> KeyTab+isKeyVal kt kv = filter (isOfKeyValue kv) kt++isOfKeyName :: String -> (QName, String, NavXmlTree) -> Bool+isOfKeyName kn (qn, _, _) = (localPart qn) == kn+++isOfKeyValue :: String -> (QName, String, NavXmlTree) -> Bool+isOfKeyValue kv (_, v, _)   = v == kv+++-- |+-- string format-number(number, string, string?):+-- converts its first argument to a string using the format pattern string+-- specified by the second argument and the decimal-format named by the+-- third argument, or the default decimal-format, if there is no third argument++xformatNumber :: XFct+xformatNumber c env (x:xs)+    = xsubstring' c env ((toXValue xstring c env [x])++(toXValue xnumber c env xs))+xformatNumber _ _ _+    = XPVError "Call to xformatNumber with a wrong argument"+++-- Poor man's document(...) function. Opens exactly one document. +-- Does not support "fragment identifiers". "Base-URI" is always current directory.+-- Should still be good enough for home use.++xdocument :: XFct+xdocument c e val = XPVNode $ (\(XPVString s) -> xdocument' s) $ xstring c e val++xdocument' :: String -> [NavXmlTree]+xdocument' uri = map ntree $+		 unsafePerformIO $+		 runX ( readDocument [(a_validate, v_0)] uri+			>>>+			addAttr "rootId" ("doc " ++ uri)+		      )++-- generate-id, should be fully compliant with XSLT specification.+xgenerateId :: XFct+xgenerateId _            _ [XPVNode (node:_)] = xgenerateId' node+xgenerateId (_, _, node) _ []                 = xgenerateId' node+xgenerateId _            _ _                  = error "illegal arguments in xgenerateId"++xgenerateId' :: NavXmlTree -> XPathValue+xgenerateId' = XPVString . ("id_"++) . str2XmlId . show . nodeID . Just++str2XmlId :: String -> String+str2XmlId = concatMap convert+    where convert c = if isAscii c && (isUpper c || isLower c || isDigit c)+                      then [c]+                      else "_" ++ (show $ ord c) ++ "_"++-- ------------------------------------------------------------++xpNamePart :: LA XmlTree String -> XmlTree -> String+xpNamePart getNp+    = concat+      .+      runLA ( ifA isRoot+	      (constA "")+	      getNp+	    )++xpLocalPartOf	:: XmlTree -> String+xpLocalPartOf	= xpNamePart getLocalPart++xpNamespaceOf	:: XmlTree -> String+xpNamespaceOf	= xpNamePart getNamespaceUri++xpNameOf	:: XmlTree -> String+xpNameOf	= xpNamePart getName++getValue	:: String -> XmlTree -> String+getValue n	= concat . runLA (getAttrValue n)++xpTextOf	:: XmlTree -> String+xpTextOf	= concat . runLA (xshow ((getCmt >>> mkText) <+> deep isText))++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/XPath/XPathKeywords.hs view
@@ -0,0 +1,57 @@+-- |+-- $Id: XPathKeywords.hs,v 1.1 2004/09/02 19:12:05 hxml Exp $+--+-- the XPath keywords+--+++module Yuuko.Text.XML.HXT.XPath.XPathKeywords+where++-- ------------------------------------------------------------+--+-- string constants for representing XPath keywords and axis++a_ancestor,			-- axisNames+ a_ancestor_or_self,+ a_attribute,+ a_child,+ a_descendant,+ a_descendant_or_self,+ a_following,+ a_following_sibling,+ a_namespace,+ a_parent,+ a_preceding,+ a_preceding_sibling,+ a_self				:: String+++n_comment,			-- nodeTypes+ n_text,+ n_processing_instruction,+ n_node				:: String++-- ------------------------------------------------------------++a_ancestor			= "ancestor"  +a_ancestor_or_self		= "ancestor-or-self"  +a_attribute 			= "attribute"  +a_child				= "child"  +a_descendant			= "descendant"  +a_descendant_or_self		= "descendant-or-self"  +a_following			= "following"  +a_following_sibling		= "following-sibling"  +a_namespace			= "namespace"  +a_parent			= "parent"  +a_preceding			= "preceding"  +a_preceding_sibling		= "preceding-sibling"  +a_self				= "self" +++n_comment 			= "comment"+n_text 				= "text"+n_processing_instruction 	= "processing-instruction"+n_node 				= "node"++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/XPath/XPathParser.hs view
@@ -0,0 +1,652 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.XPath.XPathParser+   Copyright  : Copyright (C) 2006-2008 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   the XPath Parser++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.XPath.XPathParser+    ( parseNumber+    , parseXPath+    )+where++import Data.Maybe++import Text.ParserCombinators.Parsec++import Yuuko.Text.XML.HXT.DOM.TypeDefs++import Yuuko.Text.XML.HXT.XPath.XPathKeywords+import Yuuko.Text.XML.HXT.XPath.XPathDataTypes++import Yuuko.Text.XML.HXT.Parser.XmlTokenParser+    ( separator+    , systemLiteral+    , skipS0+    , ncName+    , qName+    )++lookupNs				:: NsEnv -> XName -> XName+lookupNs uris prefix+					-- downwards compatibility: if namespace env is not supported+					-- no error is raised, but the uri remains empty+					-- not conformant to XPath spec:+					-- If namespaces are used, a complete env must be supported,+					-- but we don't care about this+					= fromMaybe nullXName $ lookup prefix uris++enhanceAttrQName			:: NsEnv -> QName -> QName+enhanceAttrQName uris qn+    | isNullXName (namePrefix' qn)	= qn+    | otherwise				= enhanceQName uris qn++enhanceQName 				:: NsEnv -> QName -> QName+enhanceQName uris qn			= setNamespaceUri' ( lookupNs uris (namePrefix' qn) ) qn++enhanceQN				::  AxisSpec -> NsEnv -> QName -> QName+enhanceQN Attribute			= enhanceAttrQName+enhanceQN _				= enhanceQName++type XParser a = GenParser Char NsEnv a++-- ------------------------------------------------------------+-- parse functions which are used in the XPathFct module++-- |+-- parsing a number, parseNumber is used in "XPathFct"+-- by the number function+--+--    - returns : the parsed number as 'XPNumber' float+--                or 'XPVNumber' 'NaN' in case of error+parseNumber :: String -> XPathValue+parseNumber s+    = case (runParser parseNumber' [] {- Map.empty -} "" s) of+        Left _ -> XPVNumber NaN+        Right x  -> if (read x :: Float) == 0+                      then (XPVNumber Pos0)+                      else XPVNumber (Float (read x))++parseNumber' :: XParser String+parseNumber'+    = do+      skipS0+      m <- option "" (string "-")+      n <- number+      skipS0+      eof+      return (m ++ n)++-- ------------------------------------------------------------+++-- |+-- the main entry point:+-- parsing a XPath expression++parseXPath :: XParser Expr+parseXPath+    = do+      skipS0+      xPathExpr <- expr+      skipS0+      eof+      return xPathExpr+++-- some useful token and symbol parser+lpar, rpar, lbra, rbra, slash, dslash	:: XParser ()++lpar   = tokenParser (symbol "(")+rpar   = tokenParser (symbol ")")+lbra   = tokenParser (symbol "[")+rbra   = tokenParser (symbol "]")+slash  = tokenParser (symbol "/")+dslash = tokenParser (symbol "//")+++tokenParser :: XParser String -> XParser ()+tokenParser p+    = try ( do+            skipS0+            _ <- p+            skipS0+           )+++symbolParser :: (String, a) -> XParser a+symbolParser (s,a)+    = do+      tokenParser (symbol s)+      return a+++symbol :: String -> XParser String+symbol s = try (string s)++++--  operation parser+orOp, andOp, eqOp, relOp, addOp, multiOp, unionOp :: XParser Op++orOp  = symbolParser ("or", Or)+andOp =	symbolParser ("and", And)++eqOp+    = symbolParser ("=", Eq)+      <|> +      symbolParser ("!=", NEq)++relOp+    = choice [ symbolParser ("<=", LessEq)+             , symbolParser (">=", GreaterEq)+             , symbolParser ("<", Less)+             , symbolParser (">", Greater)+             ]++addOp+    = symbolParser ("+", Plus)+      <|> +      symbolParser ("-", Minus)+++multiOp+    = choice [ symbolParser ("*", Mult)+             , symbolParser ("mod", Mod)+             , symbolParser ("div", Div)+             ]+++unionOp	= symbolParser ("|", Union)++-- ------------------------------------------------------------++mkExprNode :: Expr -> [(Op, Expr)] -> Expr+mkExprNode e1 [] = e1+mkExprNode e1 l@((op, _): _) = +    if null rest+      then GenExpr op (e1:(map snd l))+      else GenExpr op $ (e1:(map snd $ init same)) ++ [mkExprNode (snd $ last same) rest]+  where +    (same, rest) = span ((==op) . fst) l+    +-- Tim Walkenhorst, original expr. below:+-- It seems mkExprNode is called only with operators of the same precedence, that should make it fixable+-- FIXED, see above!+--mkExprNode e1 l@((op, _): _) = GenExpr op (e1:(map snd l))  -- Less than ideal: 1+1-1 = 3 ???+++--GenExpr op (e1:(map snd l))+++exprRest :: XParser Op -> XParser Expr -> XParser (Op, Expr)+exprRest parserOp parserExpr+    = do+      op <- parserOp+      e2 <- parserExpr+      return (op, e2)+++-- ------------------------------------------------------------++-- abbreviation of "//"+descOrSelfStep :: XStep +descOrSelfStep = (Step DescendantOrSelf (TypeTest XPNode) [])++-- ------------------------------------------------------------+-- Location Paths (2)+++-- [1] LocationPath +locPath :: XParser LocationPath+locPath+    = absLocPath+      <|> +      relLocPath'+++-- [2] AbsoluteLocationPath+absLocPath :: XParser LocationPath+absLocPath+    = do -- [10]+      dslash+      s <- relLocPath+      return (LocPath Abs ([descOrSelfStep] ++ s))+      <|> +      do+      slash+      s <- option [] relLocPath+      return (LocPath Abs s)+      <?> "absLocPath"+++-- [3] RelativeLocationPath+relLocPath' :: XParser LocationPath+relLocPath'+    = do+      rel <- relLocPath+      return (LocPath Rel rel)++relLocPath :: XParser [XStep]+relLocPath+    = do+      s1 <- step+      s2 <- many (step')+      return ([s1] ++ (concat s2))+      <?> "relLocPath"+++-- Location Steps (2.1)+--+-- [4] Step+step' :: XParser [XStep]+step'+    = do -- [11]+      dslash+      s <- step+      return [descOrSelfStep,s]+      <|>+      do+      slash+      s <- step+      return [s]+      <?> "step'"++step :: XParser XStep+step+    = abbrStep+      <|>+      do+      as <- axisSpecifier'+      nt <- nodeTest as+      pr <- many predicate+      return (Step as nt pr)+      <?> "step"+++-- [5] AxisSpecifier+axisSpecifier' :: XParser AxisSpec+axisSpecifier'+    = do  -- [13]+      tokenParser (symbol "@")+      return Attribute+      <|>+      do+      as <- option Child ( try ( do -- child-axis is default-axis+                                 a <- axisSpecifier+                                 tokenParser (symbol "::")+                                 return a+                               )+                          )+      return as+      <?> "axisSpecifier'"+++-- Axes (2.2)+--+-- [6] AxisName+axisSpecifier :: XParser AxisSpec+axisSpecifier+    = choice [ symbolParser (a_ancestor_or_self, AncestorOrSelf)+             , symbolParser (a_ancestor, Ancestor)+             , symbolParser (a_attribute, Attribute)+             , symbolParser (a_child, Child)+             , symbolParser (a_descendant_or_self, DescendantOrSelf)+             , symbolParser (a_descendant, Descendant)+             , symbolParser (a_following_sibling, FollowingSibling)+             , symbolParser (a_following, Following)+             , symbolParser (a_namespace, Namespace)+             , symbolParser (a_parent, Parent)+             , symbolParser (a_preceding_sibling, PrecedingSibling)+             , symbolParser (a_preceding, Preceding)+             , symbolParser (a_self, Self)+             ]+      <?> "axisSpecifier"+++-- Node Tests (2.3)+--+-- [7] NodeTest+nodeTest :: AxisSpec -> XParser NodeTest+nodeTest as+    = do+      nt <- try nodeType'+      return (TypeTest nt)+      <|>+      do+      processInst <- pI+      return (PI processInst)+      <|>+      do+      nt <- nameTest as+      return (NameTest nt)+      <?> "nodeTest"++pI :: XParser String+pI+    = do+      tokenParser (symbol n_processing_instruction)+      li <- between lpar rpar literal+      return li+      <?> "Processing-Instruction"+++-- Predicates (2.4)+--+-- [8] Predicate+-- [9] PredicateExpr+predicate :: XParser Expr+predicate +    = do+      ex <- between lbra rbra expr+      return ex+++-- Abbreviated Syntax (2.5)+--+-- [10] AbbreviatedAbsoluteLocationPath: q.v. [2]+-- [11] AbbreviatedRelativeLocationPath: q.v. [4]++-- [12] AbbreviatedStep+abbrStep :: XParser XStep+abbrStep +    = do+      tokenParser (symbol "..")+      return (Step Parent (TypeTest XPNode) [])+      <|>+      do+      tokenParser (symbol ".")+      return (Step Self (TypeTest XPNode) [])+      <?> "abbrStep"++-- [13] AbbreviatedAxisSpecifier: q.v. [5]+++-- ------------------------------------------------------------+-- Expressions (3)+++-- Basics (3.1)+--+-- [14] Expr+expr :: XParser Expr+expr = orExpr+++-- [15] PrimaryExpr+primaryExpr ::  XParser Expr+primaryExpr+    = do+      vr <- variableReference+      return (VarExpr vr)+      <|>+      do+      ex <- between lpar rpar expr+      return ex+      <|>+      do+      li <- literal+      return (LiteralExpr li)+      <|> +      do+      num <- number+      return (NumberExpr (Float $ read num))+      <|>+      do+      fc <- functionCall+      return (fc)+      <?> "primaryExpr"+++-- Function Calls (3.2)+--+-- [16] FunctionCall+-- [17] Argument+functionCall :: XParser Expr+functionCall+    = do+      fn <- functionName+      arg <- between lpar rpar ( sepBy expr (separator ',') )+      return (FctExpr fn arg)+      <?> "functionCall"+++-- Node-sets (3.3)+--+-- [18] UnionExpr+unionExpr :: XParser Expr+unionExpr+    = do+      e1 <- pathExpr+      eRest <- many (exprRest unionOp pathExpr)+      return (mkExprNode e1 eRest)+++-- [19] PathExpr+pathExpr :: XParser Expr+pathExpr+    = do+      fe <- try filterExpr+      path <- do+              dslash+              LocPath t1 t2 <- relLocPath'+              return (PathExpr (Just fe) (Just (LocPath t1 ([descOrSelfStep] ++ t2))))+              <|>+              do+              slash+              relPath <- relLocPath'+              return (PathExpr (Just fe) (Just relPath))+              <|>+              return fe+      return path+      <|>+      do+      lp <- locPath+      return (PathExpr Nothing (Just lp))+      <?> "pathExpr"+++-- [20] FilterExpr+filterExpr :: XParser Expr+filterExpr+    = do+      prim <- primaryExpr+      predicates <- many predicate+      if length predicates > 0+        then return (FilterExpr (prim : predicates))+        else return prim+      <?> "filterExpr"+++-- Booleans (3.4)+--+-- [21] OrExpr+orExpr :: XParser Expr+orExpr+    = do+      e1 <- andExpr+      eRest <- many (exprRest orOp andExpr)+      return (mkExprNode e1 eRest)+      <?> "orExpr"+++-- [22] AndExpr+andExpr :: XParser Expr+andExpr+    = do+      e1 <- equalityExpr+      eRest <- many (exprRest andOp equalityExpr)+      return (mkExprNode e1 eRest)+      <?> "andExpr"+++-- [23] EqualityExpr+equalityExpr :: XParser Expr+equalityExpr+    = do+      e1 <- relationalExpr+      eRest <- many (exprRest eqOp relationalExpr)+      return (mkExprNode e1 eRest)+      <?> "equalityExpr"+++-- [24] RelationalExpr+relationalExpr :: XParser Expr+relationalExpr+    = do+      e1 <- additiveExpr+      eRest <- many (exprRest relOp additiveExpr)+      return (mkExprNode e1 eRest)+      <?> "relationalExpr"+++-- Numbers (3.5)+--+-- [25] AdditiveExpr+additiveExpr :: XParser Expr+additiveExpr+    = do+      e1 <- multiplicativeExpr+      eRest <- many (exprRest addOp multiplicativeExpr)+      return (mkExprNode e1 eRest)+      <?> "additiveExpr"+++-- [26] MultiplicativeExpr+multiplicativeExpr :: XParser Expr+multiplicativeExpr+    = do+      e1 <- unaryExpr+      eRest <- many (exprRest multiOp unaryExpr)+      return (mkExprNode e1 eRest)+      <?> "multiplicativeExpr"+++-- [27] UnaryExpr+unaryExpr :: XParser Expr+unaryExpr+    = do+      tokenParser (symbol "-")+      u <- unaryExpr+      return (GenExpr Unary [u])+      <|>+      do+      u <- unionExpr+      return u+      <?> "unaryExpr"+++-- Lexical Structure (3.7)+--+-- [29] Literal+-- systemLiteral from XmlParser is used+literal :: XParser String+literal = systemLiteral+++-- [30] Number+number :: XParser String+number+    = do+      tokenParser (symbol ".")+      d <- many1 digit+      return ("0." ++ d)+      <|>+      do+      d <- many1 digit+      d1 <- option "" ( do+                        tokenParser (symbol ".")+                        d2 <- option "0" (many1 digit)+                        return ("." ++ d2)+                      )+      return (d ++ d1)+      <?> "number"+++-- [35] FunctionName+-- no nodetype name is allowed as a function name+-- Tim Walkenhorst:+--   Change in String encoding for function name+--+--         previoulsy:      new:+--           +--         name             name+--         pref:name        {http://uri-for-pref}name++functionName :: XParser String+functionName+    = try ( do           +            (p, n) <- qName+            uris   <- getState+            u      <- return $ if null p+	                       then ""+                               else '{' : show (lookupNs uris (newXName p)) ++ "}"+            let fn = (u ++ n) in+              if fn `elem` ["processing-instruction", "comment", "text", "node"]+                then fail ("function name: " ++ fn ++ "not allowed")+                else return fn+          )+      <?> "functionName"+++-- [36] VariableReference+variableReference :: XParser (String, String)+variableReference+    = do+      tokenParser (symbol "$")+      (p,n) <- qName+      uris   <- getState+      return (show (lookupNs uris (newXName p)), n)+      <?> "variableReference"+++-- [37] NameTest+nameTest :: AxisSpec -> XParser QName+nameTest as+    = do tokenParser (symbol "*")+	 uris <- getState+	 return (enhanceQN as uris $ mkPrefixLocalPart "" "*")+      <|>+      try ( do pre <- ncName+               _ <- symbol ":*"+               uris <- getState+               return (enhanceQN as uris $ mkPrefixLocalPart pre "*")+	  )+      <|>+      do (pre,local) <- qName+	 uris <- getState+	 return (enhanceQN as uris $ mkPrefixLocalPart pre local)+      <?> "nameTest"++	+-- [38] NodeType+nodeType' :: XParser XPathNode+nodeType' +    = do+      nt <- nodeType+      lpar+      rpar+      return nt+      <?> "nodeType'"+	+nodeType :: XParser XPathNode+nodeType +    = choice [ symbolParser (n_comment, XPCommentNode)+             , symbolParser (n_text, XPTextNode)+             , symbolParser (n_processing_instruction, XPPINode)+             , symbolParser (n_node, XPNode)+             ]+      <?> "nodeType"++-- ------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/XPath/XPathToNodeSet.hs view
@@ -0,0 +1,78 @@+-- |+-- Convert an XPath result set into a node set+--+++module Yuuko.Text.XML.HXT.XPath.XPathToNodeSet+    ( xPValue2NodeSet+    , emptyNodeSet+    )+where++import Yuuko.Text.XML.HXT.DOM.TypeDefs+import Yuuko.Text.XML.HXT.XPath.XPathDataTypes++import Data.Maybe++-- -----------------------------------------------------------------------------+-- |+-- Convert a a XPath-value into a XmlNodeSet represented by a tree structure+--+-- The XmlNodeSet can be used to traverse a tree an process all+-- marked nodes.++xPValue2NodeSet		:: XPathValue -> XmlNodeSet+xPValue2NodeSet (XPVNode ns)+    = toNodeSet ns++xPValue2NodeSet _+    = emptyNodeSet++emptyNodeSet		:: XmlNodeSet+emptyNodeSet		= XNS False [] []++leafNodeSet		:: XmlNodeSet+leafNodeSet		= XNS True [] []++toNodeSet		:: NodeSet -> XmlNodeSet+toNodeSet+    = pathListToNodeSet . map toPath++toPath			:: NavXmlTree -> XmlNodeSet+toPath+    = upTree leafNodeSet+++upTree			:: XmlNodeSet -> NavXmlTree -> XmlNodeSet+upTree ps t@(NT (NTree n _) _par left _right)+    = up (upNT t)+    where+    up (Just pt)+	| isJust . upNT $ pt		-- pt is a "real" node+	    = upTree (pix n) pt+	| otherwise			-- pt is the added root node, stop recursion+	    = ps+    up Nothing				-- never used recursion should stop earler+	= ps++    pix (XAttr qn)	= XNS False [qn] []+    pix _		= XNS False []   [(length left, ps)]++pathListToNodeSet	::[XmlNodeSet] -> XmlNodeSet+pathListToNodeSet+    = foldr mergePaths emptyNodeSet+    where+    mergePaths (XNS p1 al1 cl1) (XNS p2 al2 cl2)+	= XNS (p1 || p2) (al1 ++ al2) (mergeSubPaths cl1 cl2)++    mergeSubPaths []       sp2 = sp2+    mergeSubPaths (s1:sp1) sp2 = mergeSubPath s1 (mergeSubPaths sp1 sp2)++    mergeSubPath s1 []+	= [s1]+    mergeSubPath s1@(ix1,p1) sl@(s2@(ix2, p2) : sl')+	| ix1 < ix2	= s1 : sl+	| ix1 > ix2	= s2 : mergeSubPath s1 sl'		-- ordered insert of s1 +	| otherwise	= (ix1, mergePaths p1 p2) : sl'		-- same ix merge subpaths++-- -----------------------------------------------------------------------------
+ src/Yuuko/Text/XML/HXT/XPath/XPathToString.hs view
@@ -0,0 +1,136 @@+-- ------------------------------------------------------------++{- |+   Module     : Yuuko.Text.XML.HXT.XPath.XPathToString+   Copyright  : Copyright (C) 2008 Uwe Schmidt+   License    : MIT++   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+   Stability  : experimental+   Portability: portable++   Format an expression or value in tree- or string-representation++-}++-- ------------------------------------------------------------++module Yuuko.Text.XML.HXT.XPath.XPathToString+    ( expr2XPathTree+    , xPValue2String+    , xPValue2XmlTrees+    , nt2XPathTree+    , pred2XPathTree+    , toXPathTree+    )+where++-- import Yuuko.Text.XML.HXT.DOM.XmlTree++import Yuuko.Text.XML.HXT.DOM.Interface+import Yuuko.Text.XML.HXT.DOM.XmlNode+    ( mkText+    , mkError+    )+import Yuuko.Text.XML.HXT.DOM.FormatXmlTree+    ( formatXmlTree )++import Yuuko.Text.XML.HXT.XPath.XPathDataTypes++import Data.Char+    ( toLower )++-- ------------------------------------------------------------++type XPathTree = NTree String+++-- -----------------------------------------------------------------------------+-- |+-- Convert an navigable tree in a xmltree+--+toXPathTree			:: [NavTree a] -> [NTree a]+toXPathTree xs			= foldr (\ x -> (subtreeNT x :)) [] xs++-- -----------------------------------------------------------------------------+-- |+-- Format a XPath-value in string representation.+-- Text output is done by 'formatXmlTree' for node-sets (trees),+-- all other values are represented as strings.+--++xPValue2String			:: XPathValue -> String+xPValue2String (XPVNode ns)+    = foldr (\t -> ((formatXmlTree t ++ "\n") ++)) "" (toXPathTree ns)+xPValue2String (XPVBool b) 	= map toLower (show b)+xPValue2String (XPVNumber (Float f)) = show f+xPValue2String (XPVNumber s) 	= show s+xPValue2String (XPVString s) 	= s+xPValue2String (XPVError s) 	= "Error: " ++ s++-- -----------------------------------------------------------------------------+-- |+-- Convert a a XPath-value into XmlTrees.+--++xPValue2XmlTrees			:: XPathValue -> XmlTrees+xPValue2XmlTrees (XPVNode ns)		= toXPathTree ns+xPValue2XmlTrees (XPVBool b)		= xtext (show b)+xPValue2XmlTrees (XPVNumber (Float f))	= xtext (show f)+xPValue2XmlTrees (XPVNumber s)		= xtext (show s)+xPValue2XmlTrees (XPVString s)		= xtext s+xPValue2XmlTrees (XPVError  s)		= xerr s++xtext, xerr	:: String -> XmlTrees+xtext = (:[]) . mkText+xerr  = (:[]) . mkError c_err+++-- -----------------------------------------------------------------------------+-- |+-- Format a parsed XPath-expression in tree representation.+-- Text output is done by 'formatXmlTree'+--+expr2XPathTree			:: Expr -> XPathTree+expr2XPathTree (GenExpr op ex)	= NTree (show op) (map expr2XPathTree ex)+expr2XPathTree (NumberExpr f) 	= NTree (show f) []+expr2XPathTree (LiteralExpr s) 	= NTree s []+expr2XPathTree (VarExpr name) 	= NTree ("Var: " ++ show name) []+expr2XPathTree (FctExpr n arg)	= NTree ("Fct: " ++ n) (map expr2XPathTree arg)++expr2XPathTree (FilterExpr [])	= NTree "" []+expr2XPathTree (FilterExpr (primary:predicate))+    = NTree "FilterExpr" [expr2XPathTree primary, pred2XPathTree predicate]++expr2XPathTree (PathExpr Nothing (Just lp)) = locpath2XPathTree lp+expr2XPathTree (PathExpr (Just fe) (Just lp))+    = NTree "PathExpr" [expr2XPathTree fe, locpath2XPathTree lp]+expr2XPathTree (PathExpr _ _) 	= NTree "" []++locpath2XPathTree		:: LocationPath -> XPathTree+locpath2XPathTree (LocPath rel steps)+    = NTree (show rel ++ "LocationPath") (map step2XPathTree steps)+++step2XPathTree 			:: XStep -> XPathTree+step2XPathTree (Step axis nt [])+    = NTree (show axis) [nt2XPathTree nt]+step2XPathTree (Step axis nt expr)+    = NTree (show axis) [nt2XPathTree nt, pred2XPathTree expr]++nt2XPathTree 			:: NodeTest -> XPathTree+nt2XPathTree (TypeTest s) 	= NTree ("TypeTest: "++ typeTest2String s) []+nt2XPathTree (PI s) 		= NTree ("TypeTest: processing-instruction("++ show s ++ ")") []+nt2XPathTree (NameTest s) 	= NTree ("NameTest: "++ show s) []+++pred2XPathTree 			:: [Expr] -> XPathTree+pred2XPathTree exprL 		= NTree "Predicates" (map expr2XPathTree exprL)++typeTest2String 		:: XPathNode -> String+typeTest2String XPNode 		= "node()"+typeTest2String XPCommentNode	= "comment()"+typeTest2String XPPINode 	= "processing-instruction()"+typeTest2String XPTextNode 	= "text()"++-- ------------------------------------------------------------
yuuko.cabal view
@@ -1,5 +1,5 @@ Name:                 yuuko-Version:              2010.11.5+Version:              2010.11.28 Build-type:           Simple Synopsis:             A transcendental HTML parser gently wrapping the HXT library Description:@@ -17,23 +17,291 @@ Author:               Jinjing Wang Maintainer:           Jinjing Wang <nfjinjing@gmail.com> Build-Depends:        base-Cabal-version:        >= 1.2+Cabal-version:        >= 1.2.3 category:             Text homepage:             http://github.com/nfjinjing/yuuko-data-files:           readme.md, changelog.md, known-issues.md, Nemesis+data-files:           readme.md, changelog.md, known-issues.md, Nemesis, LICENSE-hxt, LICENSE-tagsoup  library   ghc-options: -Wall-  build-depends:      base >= 4 && < 5, hxt >= 8.3.2.3 && < 8.5, tagsoup <= 0.8+  build-depends:      base >= 4 && < 5+                    , haskell98+                    , containers+                    , directory+                    , filepath+                    , parsec+                    , network+                    , deepseq+                    , bytestring+                    , curl+                    , mtl+  +  extensions:         MultiParamTypeClasses DeriveDataTypeable FunctionalDependencies FlexibleInstances   hs-source-dirs:     src/   exposed-modules:                         Text.HTML.Yuuko-                      Text.HTML.Yuuko.Cookbook+                      Text.HTML.Yuuko.Cookbook,+                      +                      Yuuko.Text.XML.HXT.Arrow,+                      Yuuko.Text.XML.HXT.Arrow.DTDProcessing,+                      Yuuko.Text.XML.HXT.Arrow.DocumentInput,+                      Yuuko.Text.XML.HXT.Arrow.DocumentOutput,+                      Yuuko.Text.XML.HXT.Arrow.Edit,+                      Yuuko.Text.XML.HXT.Arrow.GeneralEntitySubstitution,+                      Yuuko.Text.XML.HXT.Arrow.Namespace,+                      Yuuko.Text.XML.HXT.Arrow.ParserInterface,+                      Yuuko.Text.XML.HXT.Arrow.Pickle,+                      Yuuko.Text.XML.HXT.Arrow.Pickle.DTD,+                      Yuuko.Text.XML.HXT.Arrow.Pickle.Schema,+                      Yuuko.Text.XML.HXT.Arrow.Pickle.Xml,+                      Yuuko.Text.XML.HXT.Arrow.ProcessDocument,+                      Yuuko.Text.XML.HXT.Arrow.ReadDocument,+                      Yuuko.Text.XML.HXT.Arrow.WriteDocument,+                      Yuuko.Text.XML.HXT.Arrow.XPath,+                      Yuuko.Text.XML.HXT.Arrow.XPathSimple,+                      Yuuko.Text.XML.HXT.Arrow.XmlArrow,+                      Yuuko.Text.XML.HXT.Arrow.XmlIOStateArrow,+                      Yuuko.Text.XML.HXT.Arrow.XmlRegex,+                      Yuuko.Text.XML.HXT.DOM.FormatXmlTree,+                      Yuuko.Text.XML.HXT.DOM.Interface,+                      Yuuko.Text.XML.HXT.DOM.IsoLatinTables,+                      Yuuko.Text.XML.HXT.DOM.MimeTypeDefaults,+                      Yuuko.Text.XML.HXT.DOM.MimeTypes,+                      Yuuko.Text.XML.HXT.DOM.QualifiedName,+                      Yuuko.Text.XML.HXT.DOM.ShowXml,+                      Yuuko.Text.XML.HXT.DOM.TypeDefs,+                      Yuuko.Text.XML.HXT.DOM.UTF8Decoding,+                      Yuuko.Text.XML.HXT.DOM.Unicode,+                      Yuuko.Text.XML.HXT.DOM.Util,+                      Yuuko.Text.XML.HXT.DOM.XmlKeywords,+                      Yuuko.Text.XML.HXT.DOM.XmlNode,+                      Yuuko.Text.XML.HXT.DOM.XmlOptions,+                      Yuuko.Text.XML.HXT.DTDValidation.AttributeValueValidation,+                      Yuuko.Text.XML.HXT.DTDValidation.DTDValidation,+                      Yuuko.Text.XML.HXT.DTDValidation.DocTransformation,+                      Yuuko.Text.XML.HXT.DTDValidation.DocValidation,+                      Yuuko.Text.XML.HXT.DTDValidation.IdValidation,+                      Yuuko.Text.XML.HXT.DTDValidation.RE,+                      Yuuko.Text.XML.HXT.DTDValidation.TypeDefs,+                      Yuuko.Text.XML.HXT.DTDValidation.Validation,+                      Yuuko.Text.XML.HXT.DTDValidation.XmlRE,+                      Yuuko.Text.XML.HXT.IO.GetFILE,+                      Yuuko.Text.XML.HXT.IO.GetHTTPLibCurl,+                      Yuuko.Text.XML.HXT.Parser.HtmlParsec,+                      Yuuko.Text.XML.HXT.Parser.ProtocolHandlerUtil,+                      Yuuko.Text.XML.HXT.Parser.TagSoup,+                      Yuuko.Text.XML.HXT.Parser.XhtmlEntities,+                      Yuuko.Text.XML.HXT.Parser.XmlCharParser,+                      Yuuko.Text.XML.HXT.Parser.XmlDTDParser,+                      Yuuko.Text.XML.HXT.Parser.XmlDTDTokenParser,+                      Yuuko.Text.XML.HXT.Parser.XmlEntities,+                      Yuuko.Text.XML.HXT.Parser.XmlParsec,+                      Yuuko.Text.XML.HXT.Parser.XmlTokenParser,+                      Yuuko.Text.XML.HXT.RelaxNG,+                      Yuuko.Text.XML.HXT.RelaxNG.BasicArrows,+                      Yuuko.Text.XML.HXT.RelaxNG.CreatePattern,+                      Yuuko.Text.XML.HXT.RelaxNG.DataTypeLibMysql,+                      Yuuko.Text.XML.HXT.RelaxNG.DataTypeLibUtils,+                      Yuuko.Text.XML.HXT.RelaxNG.DataTypeLibraries,+                      Yuuko.Text.XML.HXT.RelaxNG.DataTypes,+                      Yuuko.Text.XML.HXT.RelaxNG.PatternFunctions,+                      Yuuko.Text.XML.HXT.RelaxNG.PatternToString,+                      Yuuko.Text.XML.HXT.RelaxNG.Schema,+                      Yuuko.Text.XML.HXT.RelaxNG.SchemaGrammar,+                      Yuuko.Text.XML.HXT.RelaxNG.Simplification,+                      Yuuko.Text.XML.HXT.RelaxNG.Unicode.Blocks,+                      Yuuko.Text.XML.HXT.RelaxNG.Unicode.CharProps,+                      Yuuko.Text.XML.HXT.RelaxNG.Utils,+                      Yuuko.Text.XML.HXT.RelaxNG.Validation,+                      Yuuko.Text.XML.HXT.RelaxNG.Validator,+                      Yuuko.Text.XML.HXT.RelaxNG.XmlSchema.DataTypeLibW3C,+                      Yuuko.Text.XML.HXT.RelaxNG.XmlSchema.Regex,+                      Yuuko.Text.XML.HXT.RelaxNG.XmlSchema.RegexMatch,+                      Yuuko.Text.XML.HXT.RelaxNG.XmlSchema.RegexParser,+                      Yuuko.Text.XML.HXT.Version,+                      Yuuko.Text.XML.HXT.XPath,+                      Yuuko.Text.XML.HXT.XPath.NavTree,+                      Yuuko.Text.XML.HXT.XPath.XPathArithmetic,+                      Yuuko.Text.XML.HXT.XPath.XPathDataTypes,+                      Yuuko.Text.XML.HXT.XPath.XPathEval,+                      Yuuko.Text.XML.HXT.XPath.XPathFct,+                      Yuuko.Text.XML.HXT.XPath.XPathKeywords,+                      Yuuko.Text.XML.HXT.XPath.XPathParser,+                      Yuuko.Text.XML.HXT.XPath.XPathToNodeSet,+                      Yuuko.Text.XML.HXT.XPath.XPathToString,+                                            +                      Yuuko.Control.Arrow.ArrowIO,+                      Yuuko.Control.Arrow.ArrowIf,+                      Yuuko.Control.Arrow.ArrowList,+                      Yuuko.Control.Arrow.ArrowNF,+                      Yuuko.Control.Arrow.ArrowState,+                      Yuuko.Control.Arrow.ArrowTree,+                      Yuuko.Control.Arrow.IOListArrow,+                      Yuuko.Control.Arrow.IOStateListArrow,+                      Yuuko.Control.Arrow.ListArrow,+                      Yuuko.Control.Arrow.ListArrows,+                      Yuuko.Control.Arrow.StateListArrow,+                      Yuuko.Data.AssocList,+                      Yuuko.Data.Atom,+                      Yuuko.Data.Char.UTF8,+                      Yuuko.Data.NavTree,+                      Yuuko.Data.Tree.Class,+                      Yuuko.Data.Tree.NTree.TypeDefs+  +  +  other-modules:+                      Text.HTML.Download+                      Text.HTML.TagSoup+                      Text.HTML.TagSoup.Entity+                      Text.HTML.TagSoup.Tree+                      Text.StringLike+                      Text.HTML.TagSoup.Generated+                      Text.HTML.TagSoup.Implementation+                      Text.HTML.TagSoup.Manual+                      Text.HTML.TagSoup.Match+                      Text.HTML.TagSoup.Options+                      Text.HTML.TagSoup.Parser+                      Text.HTML.TagSoup.Render+                      Text.HTML.TagSoup.Specification+                      Text.HTML.TagSoup.Type   Executable            yuuko   ghc-options:        -Wall-  build-depends:      base >= 4 && < 5, hxt >= 8.3.2.3 && < 8.5, tagsoup <= 0.8, haskell98+  build-depends:      base >= 4 && < 5+                    , haskell98+                    , containers+                    , directory+                    , filepath+                    , parsec+                    , network+                    , deepseq+                    , bytestring+                    , curl+                    , mtl+                 +  extensions:         MultiParamTypeClasses DeriveDataTypeable FunctionalDependencies FlexibleInstances   hs-source-dirs:     src/   main-is:            Main.hs   other-modules:      Text.HTML.Yuuko++                      Yuuko.Control.Arrow.ArrowIO,+                      Yuuko.Control.Arrow.ArrowIf,+                      Yuuko.Control.Arrow.ArrowList,+                      Yuuko.Control.Arrow.ArrowNF,+                      Yuuko.Control.Arrow.ArrowState,+                      Yuuko.Control.Arrow.ArrowTree,+                      Yuuko.Control.Arrow.IOListArrow,+                      Yuuko.Control.Arrow.IOStateListArrow,+                      Yuuko.Control.Arrow.ListArrow,+                      Yuuko.Control.Arrow.ListArrows,+                      Yuuko.Control.Arrow.StateListArrow,+                      Yuuko.Data.AssocList,+                      Yuuko.Data.Atom,+                      Yuuko.Data.Char.UTF8,+                      Yuuko.Data.NavTree,+                      Yuuko.Data.Tree.Class,+                      Yuuko.Data.Tree.NTree.TypeDefs,+                      Yuuko.Text.XML.HXT.Arrow,+                      Yuuko.Text.XML.HXT.Arrow.DTDProcessing,+                      Yuuko.Text.XML.HXT.Arrow.DocumentInput,+                      Yuuko.Text.XML.HXT.Arrow.DocumentOutput,+                      Yuuko.Text.XML.HXT.Arrow.Edit,+                      Yuuko.Text.XML.HXT.Arrow.GeneralEntitySubstitution,+                      Yuuko.Text.XML.HXT.Arrow.Namespace,+                      Yuuko.Text.XML.HXT.Arrow.ParserInterface,+                      Yuuko.Text.XML.HXT.Arrow.Pickle,+                      Yuuko.Text.XML.HXT.Arrow.Pickle.DTD,+                      Yuuko.Text.XML.HXT.Arrow.Pickle.Schema,+                      Yuuko.Text.XML.HXT.Arrow.Pickle.Xml,+                      Yuuko.Text.XML.HXT.Arrow.ProcessDocument,+                      Yuuko.Text.XML.HXT.Arrow.ReadDocument,+                      Yuuko.Text.XML.HXT.Arrow.WriteDocument,+                      Yuuko.Text.XML.HXT.Arrow.XPath,+                      Yuuko.Text.XML.HXT.Arrow.XPathSimple,+                      Yuuko.Text.XML.HXT.Arrow.XmlArrow,+                      Yuuko.Text.XML.HXT.Arrow.XmlIOStateArrow,+                      Yuuko.Text.XML.HXT.Arrow.XmlRegex,+                      Yuuko.Text.XML.HXT.DOM.FormatXmlTree,+                      Yuuko.Text.XML.HXT.DOM.Interface,+                      Yuuko.Text.XML.HXT.DOM.IsoLatinTables,+                      Yuuko.Text.XML.HXT.DOM.MimeTypeDefaults,+                      Yuuko.Text.XML.HXT.DOM.MimeTypes,+                      Yuuko.Text.XML.HXT.DOM.QualifiedName,+                      Yuuko.Text.XML.HXT.DOM.ShowXml,+                      Yuuko.Text.XML.HXT.DOM.TypeDefs,+                      Yuuko.Text.XML.HXT.DOM.UTF8Decoding,+                      Yuuko.Text.XML.HXT.DOM.Unicode,+                      Yuuko.Text.XML.HXT.DOM.Util,+                      Yuuko.Text.XML.HXT.DOM.XmlKeywords,+                      Yuuko.Text.XML.HXT.DOM.XmlNode,+                      Yuuko.Text.XML.HXT.DOM.XmlOptions,+                      Yuuko.Text.XML.HXT.DTDValidation.AttributeValueValidation,+                      Yuuko.Text.XML.HXT.DTDValidation.DTDValidation,+                      Yuuko.Text.XML.HXT.DTDValidation.DocTransformation,+                      Yuuko.Text.XML.HXT.DTDValidation.DocValidation,+                      Yuuko.Text.XML.HXT.DTDValidation.IdValidation,+                      Yuuko.Text.XML.HXT.DTDValidation.RE,+                      Yuuko.Text.XML.HXT.DTDValidation.TypeDefs,+                      Yuuko.Text.XML.HXT.DTDValidation.Validation,+                      Yuuko.Text.XML.HXT.DTDValidation.XmlRE,+                      Yuuko.Text.XML.HXT.IO.GetFILE,+                      Yuuko.Text.XML.HXT.IO.GetHTTPLibCurl,+                      Yuuko.Text.XML.HXT.Parser.HtmlParsec,+                      Yuuko.Text.XML.HXT.Parser.ProtocolHandlerUtil,+                      Yuuko.Text.XML.HXT.Parser.TagSoup,+                      Yuuko.Text.XML.HXT.Parser.XhtmlEntities,+                      Yuuko.Text.XML.HXT.Parser.XmlCharParser,+                      Yuuko.Text.XML.HXT.Parser.XmlDTDParser,+                      Yuuko.Text.XML.HXT.Parser.XmlDTDTokenParser,+                      Yuuko.Text.XML.HXT.Parser.XmlEntities,+                      Yuuko.Text.XML.HXT.Parser.XmlParsec,+                      Yuuko.Text.XML.HXT.Parser.XmlTokenParser,+                      Yuuko.Text.XML.HXT.RelaxNG,+                      Yuuko.Text.XML.HXT.RelaxNG.BasicArrows,+                      Yuuko.Text.XML.HXT.RelaxNG.CreatePattern,+                      Yuuko.Text.XML.HXT.RelaxNG.DataTypeLibMysql,+                      Yuuko.Text.XML.HXT.RelaxNG.DataTypeLibUtils,+                      Yuuko.Text.XML.HXT.RelaxNG.DataTypeLibraries,+                      Yuuko.Text.XML.HXT.RelaxNG.DataTypes,+                      Yuuko.Text.XML.HXT.RelaxNG.PatternFunctions,+                      Yuuko.Text.XML.HXT.RelaxNG.PatternToString,+                      Yuuko.Text.XML.HXT.RelaxNG.Schema,+                      Yuuko.Text.XML.HXT.RelaxNG.SchemaGrammar,+                      Yuuko.Text.XML.HXT.RelaxNG.Simplification,+                      Yuuko.Text.XML.HXT.RelaxNG.Unicode.Blocks,+                      Yuuko.Text.XML.HXT.RelaxNG.Unicode.CharProps,+                      Yuuko.Text.XML.HXT.RelaxNG.Utils,+                      Yuuko.Text.XML.HXT.RelaxNG.Validation,+                      Yuuko.Text.XML.HXT.RelaxNG.Validator,+                      Yuuko.Text.XML.HXT.RelaxNG.XmlSchema.DataTypeLibW3C,+                      Yuuko.Text.XML.HXT.RelaxNG.XmlSchema.Regex,+                      Yuuko.Text.XML.HXT.RelaxNG.XmlSchema.RegexMatch,+                      Yuuko.Text.XML.HXT.RelaxNG.XmlSchema.RegexParser,+                      Yuuko.Text.XML.HXT.Version,+                      Yuuko.Text.XML.HXT.XPath,+                      Yuuko.Text.XML.HXT.XPath.NavTree,+                      Yuuko.Text.XML.HXT.XPath.XPathArithmetic,+                      Yuuko.Text.XML.HXT.XPath.XPathDataTypes,+                      Yuuko.Text.XML.HXT.XPath.XPathEval,+                      Yuuko.Text.XML.HXT.XPath.XPathFct,+                      Yuuko.Text.XML.HXT.XPath.XPathKeywords,+                      Yuuko.Text.XML.HXT.XPath.XPathParser,+                      Yuuko.Text.XML.HXT.XPath.XPathToNodeSet,+                      Yuuko.Text.XML.HXT.XPath.XPathToString+++                      Text.HTML.Download+                      Text.HTML.TagSoup+                      Text.HTML.TagSoup.Entity+                      Text.HTML.TagSoup.Tree+                      Text.StringLike+                      Text.HTML.TagSoup.Generated+                      Text.HTML.TagSoup.Implementation+                      Text.HTML.TagSoup.Manual+                      Text.HTML.TagSoup.Match+                      Text.HTML.TagSoup.Options+                      Text.HTML.TagSoup.Parser+                      Text.HTML.TagSoup.Render+                      Text.HTML.TagSoup.Specification+                      Text.HTML.TagSoup.Type