hxt-relaxng 9.1.5.1 → 9.1.5.3

raw patch · 4 files changed

+213/−65 lines, 4 filesdep ~hxt-regex-xmlschemaPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependency ranges changed: hxt-regex-xmlschema

API changes (from Hackage documentation)

Files

• hxt-relaxng.cabal +2/−2
• src/Text/XML/HXT/RelaxNG/DataTypes.hs +150/−18
• src/Text/XML/HXT/RelaxNG/Validation.hs +52/−32
• src/Text/XML/HXT/RelaxNG/XMLSchema/DataTypeLibW3C.hs +9/−13

@@ -1,6 +1,6 @@ -- arch-tag: Haskell XML Toolbox main description file Name:           hxt-relaxng-Version:        9.1.5.1+Version:        9.1.5.3 Synopsis:       The HXT RelaxNG validator Description:    The HXT RelaxNG validator License:        MIT@@ -74,7 +74,7 @@                 parsec     >= 2.1 && < 4,                 hxt                 >= 9.1.3 && < 10,                 hxt-charproperties  >= 9     && < 10,-                hxt-regex-xmlschema >= 9     && < 10+                hxt-regex-xmlschema >= 9.2   && < 10   if flag(network-uri)    build-depends: network-uri >= 2.6

@@ -1,8 +1,12 @@ module Text.XML.HXT.RelaxNG.DataTypes where -import Text.XML.HXT.DOM.TypeDefs+import           Text.XML.HXT.DOM.TypeDefs +{- debug code+import qualified Debug.Trace               as T+-- -}+ -- ------------------------------------------------------------  relaxSchemaFile :: String@@ -147,7 +151,7 @@                | NsNameExcept Uri NameClass                | NameClassChoice NameClass NameClass                | NCError String-               deriving Eq+               deriving (Eq, Ord)  instance Show NameClass     where@@ -168,21 +172,100 @@  -- | 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+data Pattern = NotAllowed ErrMessage			-- {}+             | Empty					-- {epsilon}+             | Text					-- symbol: text+             | Element    NameClass Pattern     	-- symbol: element with pattern for children+             | Attribute  NameClass Pattern     	-- symbol: attr    with pattern for value+             | Choice     Pattern   Pattern		-- binary combinator, symmetric+             | Interleave Pattern   Pattern		--   "         "    , symmetric+             | Group      Pattern   Pattern		--   "         "+             | After      Pattern   Pattern		--   "         "+             | OneOrMore  Pattern			-- unary combinator+             | Data       Datatype  ParamList   	-- value check+             | DataExcept Datatype  ParamList Pattern+             | List       Pattern               	-- value check+             | Value      Datatype  String    Context	-- value check +data Pattern' = NotAllowed'+             | Empty'+             | Text'+             | Element'+             | Attribute'+             | Data'+             | DataExcept'+             | List'+             | Value'+             | OneOrMore'+             | Interleave'+             | Group'+             | After'+             | Choice'+               deriving (Eq, Ord)++ord' :: Pattern -> Pattern'+ord' NotAllowed{}            = NotAllowed'+ord' Empty                   = Empty'+ord' Text                    = Text'+ord' Element{}               = Element'+ord' Attribute{}             = Attribute'+ord' Choice{}                = Choice'+ord' Interleave{}            = Interleave'+ord' Group{}                 = Group'+ord' After{}                 = After'+ord' OneOrMore{}             = OneOrMore'+ord' Data{}                  = Data'+ord' DataExcept{}            = DataExcept'+ord' List{}                  = List'+ord' Value{}                 = Value'+++equiv :: Pattern -> Pattern -> Bool+equiv NotAllowed{}            NotAllowed{}            = True+equiv Empty                   Empty                   = True+equiv Text                    Text                    = True+equiv (Element    nc1 _p1)    (Element nc2 _p2)       = nc1 == nc2+equiv (Attribute  nc1 _p1)    (Attribute nc2 _p2)     = nc1 == nc2+equiv (Choice     p11 p12)    (Choice p21 p22)        = p11 `equiv` p21 && p12 `equiv` p22+equiv (Interleave p11 p12)    (Interleave p21 p22)    = p11 `equiv` p21 && p12 `equiv` p22+equiv (Group      p11 p12)    (Group      p21 p22)    = p11 `equiv` p21 && p12 `equiv` p22+equiv (After      p11 p12)    (After      p21 p22)    = p11 `equiv` p21 && p12 `equiv` p22+equiv (OneOrMore  p1)         (OneOrMore  p2)         = p1  `equiv` p2+equiv (Data       dt1 pl1)    (Data       dt2 pl2)    = dt1 == dt2 && pl1 == pl2+equiv (DataExcept dt1 pl1 p1) (DataExcept dt2 pl2 p2) = dt1 == dt2 && pl1 == pl2 && p1 `equiv` p2+equiv (List p1)               (List p2)               = p1  `equiv` p2+equiv (Value dt1 s1 cx1)      (Value dt2 s2 cx2)      = dt1 == dt2 && s1 == s2 && cx1 == cx2+equiv _                       _                       = False+++gt :: Pattern -> Pattern -> Bool+gt p1                      p2+    | ord' p1 > ord' p2                            = True+    | ord' p1 < ord' p2                            = False+gt (Element    nc1 _p1)    (Element nc2 _p2)       = nc1 > nc2+gt (Attribute  nc1 _p1)    (Attribute nc2 _p2)     = nc1 > nc2+gt (Choice     p11 p12)    (Choice p21 p22)        = p11 `gt` p21+                                                     || p11 `equiv` p21 && p12 `gt` p22+gt (Interleave p11 p12)    (Interleave p21 p22)    = p11 `gt` p21+                                                     || p11 `equiv` p21 && p12 `gt` p22+gt (Group      p11 p12)    (Group      p21 p22)    = p11 `gt` p21+                                                     || p11 `equiv` p21 && p12 `gt` p22+gt (After      p11 p12)    (After      p21 p22)    = p11 `gt` p21+                                                     || p11 `equiv` p21 && p12 `gt` p22+gt (OneOrMore  p1)         (OneOrMore  p2)         = p1  `gt` p2+gt (Data dt1 pl1)          (Data dt2 pl2)          = dt1 > dt2+                                                     || dt1 == dt2 && pl1 == pl2+gt (DataExcept dt1 pl1 p1) (DataExcept dt2 pl2 p2) = dt1 > dt2+                                                     || dt1 == dt2+                                                        && (pl1 > pl2 || pl1 == pl2 && p1 `gt` p2)+gt (List p1)               (List p2)               = p1  `gt` p2+gt (Value dt1 s1 cx1)      (Value dt2 s2 cx2)      = dt1 > dt2+                                                     || dt1 == dt2+                                                        && (s1 > s2 || s1 == s2 && cx1 > cx2)+gt _                       _                       = False+++{- instance Show Pattern where     show Empty                  = "empty"     show (NotAllowed e)         = show e@@ -202,7 +285,29 @@     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 ++ " )"+-- -} +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)      = "a[" ++ show nc ++ "]{...}"+    show (Element   nc _p)      = "e[" ++ show nc ++ "]{...}"+    show (After p1 p2)          =  "( " ++ show p1 ++ " ; " ++ show p2 ++ " )"++ data ErrMessage = ErrMsg ErrLevel [String]                   -- deriving Show @@ -248,12 +353,31 @@     = notAllowed2 "mergeNotAllowed with wrong patterns"  -- | smart constructor for Choice+--+-- nexted choices are transformed into a sorted list +{-+choice' :: Pattern -> Pattern -> Pattern+choice' p1 p2+    = T.trace ("choice:\np1=" ++ show p1 ++ "\np2=" ++ show p2) $+      T.trace ("res=" ++ show res) $ res+    where+      res = choice p1 p2+-- -}+ 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+choice (Choice p11 p12)  p2                     = choice p11 (choice p12 p2)+choice p1                p2@(Choice p21 p22)+    | p1 `equiv` p21                            = p2+    | p1 `gt`    p21                            = choice p21 (choice p1 p22)+    | otherwise                                 = Choice p1 p2+choice p1                p2+    | p1 `equiv` p2                             = p2+    | p1 `gt`    p2                             = choice p2 p1+    | otherwise                                 = Choice p1 p2  -- | smart constructor for Group @@ -272,6 +396,8 @@ oneOrMore p                = OneOrMore p  -- | smart constructor for Interleave+--+-- nested interleaves are transformed into a sorted list  interleave :: Pattern -> Pattern -> Pattern interleave p1@(NotAllowed _) p2@(NotAllowed _)  = mergeNotAllowed p1 p2@@ -279,7 +405,13 @@ interleave p1@(NotAllowed _) _                  = p1 interleave p1                Empty              = p1 interleave Empty             p2                 = p2-interleave p1                p2                 = Interleave p1 p2+interleave (Interleave p11 p12) p2              = interleave p11 (interleave p12 p2)+interleave p1                p2@(Interleave p21 p22)+    | p1 `gt` p21                               = interleave p21 (interleave p1 p22)+    | otherwise                                 = Interleave p1 p2+interleave p1                p2+    | p1 `gt` p2                                = interleave p2 p1+    | otherwise                                 = Interleave p1 p2  -- | smart constructor for After 

@@ -1,3 +1,5 @@+{-# LANGUAGE BangPatterns #-}+ -- ------------------------------------------------------------  {- |@@ -30,44 +32,42 @@  import           Control.Arrow.ListArrows -import           Data.Char.Properties.XMLCharProps      ( isXmlSpaceChar )-import           Data.Maybe                             ( fromJust )+import           Data.Char.Properties.XMLCharProps      (isXmlSpaceChar)+import           Data.Maybe                             (fromJust)  import           Text.XML.HXT.DOM.Interface-import qualified Text.XML.HXT.DOM.XmlNode as XN+import qualified Text.XML.HXT.DOM.XmlNode               as XN +import           Text.XML.HXT.Arrow.Edit                (canonicalizeAllNodes,+                                                         collapseAllXText) import           Text.XML.HXT.Arrow.XmlArrow-import           Text.XML.HXT.Arrow.Edit                ( canonicalizeAllNodes-                                                        , collapseAllXText-                                                        ) -import           Text.XML.HXT.Arrow.ProcessDocument     ( propagateAndValidateNamespaces-                                                        , getDocumentContents-                                                        , parseXmlDocument-                                                        )+import           Text.XML.HXT.Arrow.ProcessDocument     (getDocumentContents,+                                                         parseXmlDocument, propagateAndValidateNamespaces) import           Text.XML.HXT.Arrow.XmlState import           Text.XML.HXT.Arrow.XmlState.TypeDefs -import           Text.XML.HXT.RelaxNG.DataTypes import           Text.XML.HXT.RelaxNG.CreatePattern-import           Text.XML.HXT.RelaxNG.PatternToString import           Text.XML.HXT.RelaxNG.DataTypeLibraries-import           Text.XML.HXT.RelaxNG.Utils             ( formatStringListQuot-                                                        , compareURI-                                                        )+import           Text.XML.HXT.RelaxNG.DataTypes+import           Text.XML.HXT.RelaxNG.PatternToString+import           Text.XML.HXT.RelaxNG.Utils             (compareURI,+                                                         formatStringListQuot)  {--import qualified Debug.Trace as T--}+import qualified Debug.Trace                            as T+-- -}  -- ------------------------------------------------------------  validateWithRelax       :: IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree validateWithRelax theSchema-    = traceMsg 2 "validate with Relax NG schema"+    = traceMsg 2 "normalize document for validation"       >>>       normalizeForRelaxValidation             -- prepare the document for validation       >>>+      traceMsg 2 "start validation"+      >>>       ( validateRelax $< theSchema )          -- compute and issue validation errors  {- |@@ -161,7 +161,7 @@           )         )         >>>-        arr2 (\ pattern xmlDoc -> childDeriv ("", []) pattern xmlDoc)+        arr2 (\ !pattern !xmlDoc -> childDeriv ("", []) pattern xmlDoc)         >>>         isA (not . nullable)         >>>@@ -229,8 +229,8 @@ childDeriv :: Context -> Pattern -> XmlTree -> Pattern  childDeriv cx p t-    | XN.isText t       = textDeriv cx p . fromJust . XN.getText $ t-    | XN.isElem t       = endTagDeriv p4+    | 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@@ -238,7 +238,7 @@     atts        = fromJust . XN.getAttrl    $ t     cx1         = ("",[])     p1          = startTagOpenDeriv p qn-    p2          = attsDeriv cx1 p1 atts+    p2          = attsDeriv{- ' -} cx1 p1 atts     p3          = startTagCloseDeriv p2     p4          = childrenDeriv cx1 p3 children @@ -246,6 +246,15 @@ -- -- | computes the derivative of a pattern with respect to a text node +{-+textDeriv' cx p t+    = T.trace ("textDeriv: p=\n" ++ (take 10000 . show) p ++ ", t=\n" ++ t) $+      T.trace ("res=\n" ++ (take 10000 . show) res) res+    where+    res = textDeriv cx p t+-- -}++ textDeriv :: Context -> Pattern -> String -> Pattern  textDeriv cx (Choice p1 p2) s@@ -327,10 +336,10 @@  listDeriv :: Context -> Pattern -> [String] -> Pattern -listDeriv _ p []+listDeriv _ !p []     = p -listDeriv cx p (x:xs)+listDeriv cx !p (x:xs)     = listDeriv cx (textDeriv cx p x) xs  @@ -381,30 +390,33 @@ -- ------------------------------------------------------------  -- 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+    = T.trace ("attDeriv: p=\n" ++ (take 10000 . show) p ++ ", t=\n" ++ showXts [t]) $+      T.trace ("res=\n" ++ (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 []+attsDeriv _ !p []     = p-attsDeriv cx p (t : ts)+attsDeriv cx !p (t : ts)     | XN.isAttr t-        = attsDeriv cx (attDeriv cx p t) ts+        = attsDeriv cx (attDeriv{- ' -} cx p t) ts     | otherwise         = notAllowed "Call to attsDeriv with wrong arguments" @@ -537,10 +549,10 @@     = stripChildrenDeriv cx p children  stripChildrenDeriv :: Context -> Pattern -> XmlTrees -> Pattern-stripChildrenDeriv _ p []+stripChildrenDeriv _ !p []     = p -stripChildrenDeriv cx p (h:t)+stripChildrenDeriv cx !p (h:t)     = stripChildrenDeriv cx       ( if strip h         then p@@ -551,6 +563,14 @@ -- ------------------------------------------------------------ -- -- | computes the derivative of a pattern with respect to a end tag++{-+endTagDeriv' p+    = T.trace ("endTagDeriv: p=\n" ++ (take 10000 . show) p) $+      T.trace ("res=\n" ++ (take 10000 . show) res) res+    where+    res = endTagDeriv p+-- -}  endTagDeriv :: Pattern -> Pattern endTagDeriv (Choice p1 p2)

@@ -22,23 +22,19 @@   ) where -import Data.Maybe-import Data.Ratio+import           Data.Maybe+import           Data.Ratio -import Network.URI                              ( isURIReference )+import           Network.URI                                (isURIReference) -import Text.Regex.XMLSchema.String              ( Regex-                                                , matchRE-                                                , parseRegex-                                                , isZero-                                                )+import           Text.Regex.XMLSchema.Generic               (Regex, isZero,+                                                             matchRE,+                                                             parseRegex) -import Text.XML.HXT.DOM.QualifiedName           ( isWellformedQualifiedName-                                                , isNCName-                                                )-import Text.XML.HXT.XMLSchema.DataTypeLibW3CNames+import           Text.XML.HXT.DOM.QualifiedName             (isNCName, isWellformedQualifiedName)+import           Text.XML.HXT.XMLSchema.DataTypeLibW3CNames -import Text.XML.HXT.RelaxNG.DataTypeLibUtils+import           Text.XML.HXT.RelaxNG.DataTypeLibUtils  -- ------------------------------------------------------------