Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

in hxt-xmlschema fiddled around with elements without explicit type (…

…wildcard ##any with strict processing)
  • Loading branch information...
commit d604ff6fd5b4d1e7e51d2c671d3370d8d7eaee9e 1 parent 7ebb03d
Uwe Schmidt authored
View
23 hxt-xmlschema/src/Text/XML/HXT/XMLSchema/Loader.hs
@@ -31,6 +31,12 @@ import Data.Map ( empty
import Prelude hiding ( lookup )
import Text.XML.HXT.XMLSchema.AbstractSyntax
+import Text.XML.HXT.XMLSchema.XmlUtils ( nsUri
+ , nsPrefix
+ , illegalNsUri
+ , mkXsdName
+ , anyTypeQName
+ )
import Text.XML.HXT.Core
@@ -59,21 +65,6 @@ data XmlSchemaPart = In {unIn :: Include}
--
-- ----------------------------------------
--- | The XML Schema namespace
-nsUri :: String
-nsUri = "http://www.w3.org/2001/XMLSchema"
-
--- | The XML Schema namespace prefix
-nsPrefix :: String
-nsPrefix = "xs"
-
-illegalNsUri :: String
-illegalNsUri ="missing namespace URI for prefix"
-
-mkXsdName :: String -> QName
-mkXsdName name
- = mkQName nsPrefix name nsUri
-
-- | Basic namespace-aware element pickler
xpElem' :: String -> PU a -> PU a
xpElem' name
@@ -449,7 +440,7 @@ xpElemTypeDef
tag (ETDTypeAttr _) = 2 -- if just a name is given, no simple or complex type, type defaults to xs:anyType
ps = [ xpWrap (ETDAnonymStDecl, unETDAnonymStDecl) $ xpSchemaElem "simpleType" $ xpSimpleType
, xpWrap (ETDAnonymCtDecl, unETDAnonymCtDecl) $ xpSchemaElem "complexType" $ xpComplexType
- , xpWrap (ETDTypeAttr, unETDTypeAttr) $ xpDefault (mkQName nsPrefix "anyType" nsUri)
+ , xpWrap (ETDTypeAttr, unETDTypeAttr) $ xpDefault anyTypeQName
$ xpAttr "type" xpQName
]
View
37 hxt-xmlschema/src/Text/XML/HXT/XMLSchema/Transformation.hs
@@ -51,6 +51,7 @@ import Text.XML.HXT.XMLSchema.W3CDataTypeCheck
import Text.XML.HXT.XMLSchema.ValidationTypes
import Text.XML.HXT.XMLSchema.ValidationCore
import Text.XML.HXT.XMLSchema.Regex
+import Text.XML.HXT.XMLSchema.XmlUtils
-- ----------------------------------------
@@ -542,22 +543,26 @@ createElemDesc (ElRef n)
createElemDesc (ElDef (ElementDef _ tdef))
= do s <- ask
- t <- case tdef of
- ETDTypeAttr r
- -> case lookup r $ sComplexTypes s of
- Nothing
- -> Left <$> lookupSTTF r
- Just ctr
- -> return $ Right ctr
- ETDAnonymStDecl st
- -> Left <$> stToSTTF st
- ETDAnonymCtDecl ct
- -> return $ Right ct
- case t of
- Left tf
- -> return $ mkSimpleElemDesc (empty, []) tf
- Right ct
- -> ctToElemDesc ct
+ case tdef of
+ ETDTypeAttr r
+ -> if r == anyTypeQName
+ then return $
+ setWildcard (WC (const True) Strict) $ nullElemDesc
+ else
+ case lookup r $ sComplexTypes s of
+ Nothing
+ -> (Left <$> lookupSTTF r) >>= toED
+ Just ctr
+ -> toED $ Right ctr
+ ETDAnonymStDecl st
+ -> (Left <$> stToSTTF st) >>= toED
+ ETDAnonymCtDecl ct
+ -> toED $ Right ct
+ where
+ toED (Left tf)
+ = return $ mkSimpleElemDesc (empty, []) tf
+ toED (Right ct)
+ = ctToElemDesc ct
-- ----------------------------------------
View
26 hxt-xmlschema/src/Text/XML/HXT/XMLSchema/ValidationCore.hs
@@ -32,6 +32,7 @@ import Data.Map ( Map
-- , insert
, fromList
, toList
+ , keys
)
import Prelude hiding ( lookup )
@@ -159,9 +160,14 @@ checkAllowedAttr (n, val)
res <- case lookup n am of
Nothing
-> if isNameSpaceName n
- then return True -- namespace declarations may occure everywhere
+ then return True -- namespace declarations may occure everywhere
else
- if illegalNsUri `isPrefixOf` namespaceUri n
+ if namespaceUri n == nsUriXMLSchemaInstance
+ &&
+ localPart n `elem` localNamesXMLSchemaInstance
+ then return True -- predefined XML schema instance names
+ else
+ if illegalNsUri `isPrefixOf` namespaceUri n -- TODO: this is a hack
then mkErrorSTTF''
(++ ("/@" ++ qualifiedName n))
(namespaceUri n)
@@ -333,7 +339,7 @@ testElem
testElem' :: XmlTree -> SVal Bool
testElem' e
= do ed <- asks elemDesc
- logg ["testElem'", showSym e]
+ logg ["testElem'", showSym e, "elemDesc =", showElemDesc ed]
case (errmsg ed) of
Just msg -> mkErrorSTTF' msg
Nothing -> testElem'' ed
@@ -351,7 +357,7 @@ testElem' e
| allText
= local (appendXPath "/child::text()") $ sf $ getCombinedText content
| otherwise
- = mkErrorSTTF'' (++ "/*") "no mixed content allowed here."
+ = mkErrorSTTF'' (++ "/*") $ "no mixed content allowed here." ++ show content
content = filter isElemOrText $ getElemChildren e
allText = all isText content
@@ -373,13 +379,17 @@ testWildcard' wc t
Strict -> maybe errMsg test ed
where
test ed' = localED ed' testElem' t
- qn = qualifiedName . getElemName $ t
+ -- qn = qualifiedName . getElemName $ t
+ un = getElemName $ t
errMsg
= do xp <- asks xpath
+ alluns <- asks (keys . allElemDesc)
mkErrorSTTF'' (const xp) $
- unwords [ "undefined element"
- , show qn
- , "found in wildcard contents (processContents=\"strict\")"
+ unwords [ "undefined element:"
+ , show un -- qn
+ , ", found in wildcard contents (processContents=\"strict\")"
+ , "\nelements defined:", show alluns
+ , "\ninput", show t
]
localPath :: (XmlTree -> SVal a) -> XmlTree -> SVal a
View
29 hxt-xmlschema/src/Text/XML/HXT/XMLSchema/ValidationTypes.hs
@@ -39,7 +39,9 @@ import Control.Monad.Writer ( WriterT
, tell
)
-import Data.Map ( Map )
+import Data.Map ( Map
+ , keys
+ )
import Text.XML.HXT.XMLSchema.Regex
@@ -182,5 +184,30 @@ logg msg
{-# INLINE #-}
-- -}
+showElemDesc :: ElemDesc -> String
+showElemDesc e
+ = unwords [ "ElemDesc {"
+ , show $ errmsg e
+ , ",attrDesc ="
+ , showAttrDesc $ attrDesc e
+ , ",mixedDontent ="
+ , show $ mixedContent e
+ , ",contentModel ="
+ , show $ contentModel e
+ , ",subElemDesc = "
+ , show . keys $ subElemDesc e
+ , ",sttf ="
+ , show . fmap (const "<sttf>") $ sttf e
+ ]
+
+showAttrDesc :: AttrDesc -> String
+showAttrDesc a
+ = unwords [ "("
+ , show . keys . fst $ a
+ , ","
+ , show . map (const "<wcf>") . snd $ a
+ , ")"
+ ]
+
-- ----------------------------------------
View
34 hxt-xmlschema/src/Text/XML/HXT/XMLSchema/XmlUtils.hs
@@ -17,6 +17,7 @@ import qualified Text.XML.HXT.DOM.XmlNode as XN
import Text.XML.HXT.Core ( QName
, mkName
+ , mkQName
, XmlTree
, XmlTrees
)
@@ -29,6 +30,39 @@ import Data.Tree.NTree.TypeDefs
-- ----------------------------------------
+-- | The XML Schema namespace
+nsUri :: String
+nsUri = "http://www.w3.org/2001/XMLSchema"
+
+-- | The XML Schema namespace prefix
+nsPrefix :: String
+nsPrefix = "xs"
+
+nsUriXMLSchemaInstance :: String
+nsUriXMLSchemaInstance = "http://www.w3.org/2001/XMLSchema-instance"
+
+localNamesXMLSchemaInstance :: [String]
+localNamesXMLSchemaInstance
+ = [ "type"
+ , "nil"
+ , "schemaLocation"
+ , "noNamespaceSchemaLocation"
+ ]
+
+
+illegalNsUri :: String
+illegalNsUri ="missing namespace URI for prefix"
+
+mkXsdName :: String -> QName
+mkXsdName name
+ = mkQName nsPrefix name nsUri
+
+anyTypeQName :: QName
+anyTypeQName
+ = mkQName nsPrefix "anyType" nsUri
+
+-- ----------------------------------------
+
-- | Create a root XmlTree
mkRoot :: XmlTrees -> XmlTrees -> XmlTree
mkRoot = XN.mkRoot
Please sign in to comment.
Something went wrong with that request. Please try again.