diff --git a/hxt-relaxng.cabal b/hxt-relaxng.cabal --- a/hxt-relaxng.cabal +++ b/hxt-relaxng.cabal @@ -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 diff --git a/src/Text/XML/HXT/RelaxNG/DataTypes.hs b/src/Text/XML/HXT/RelaxNG/DataTypes.hs --- a/src/Text/XML/HXT/RelaxNG/DataTypes.hs +++ b/src/Text/XML/HXT/RelaxNG/DataTypes.hs @@ -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 diff --git a/src/Text/XML/HXT/RelaxNG/Validation.hs b/src/Text/XML/HXT/RelaxNG/Validation.hs --- a/src/Text/XML/HXT/RelaxNG/Validation.hs +++ b/src/Text/XML/HXT/RelaxNG/Validation.hs @@ -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) diff --git a/src/Text/XML/HXT/RelaxNG/XMLSchema/DataTypeLibW3C.hs b/src/Text/XML/HXT/RelaxNG/XMLSchema/DataTypeLibW3C.hs --- a/src/Text/XML/HXT/RelaxNG/XMLSchema/DataTypeLibW3C.hs +++ b/src/Text/XML/HXT/RelaxNG/XMLSchema/DataTypeLibW3C.hs @@ -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 -- ------------------------------------------------------------