diff --git a/examples/hrelaxng/Makefile b/examples/hrelaxng/Makefile --- a/examples/hrelaxng/Makefile +++ b/examples/hrelaxng/Makefile @@ -65,7 +65,17 @@ $(prog) ./valid1.xml ./invalid3.rng || true @echo -EX = $(wildcard *valid*.xml *valid*.rng) +example6 : + @echo "===> Validate a valid xml file with a valid Relax NG schema with name prefixes" ; echo ; sleep 1 + $(prog) ./simple.xml ./simple-qualified.rng + @echo + +example6a : + @echo "===> Validate a valid xml file with a valid Relax NG schema without name prefixes" ; echo ; sleep 1 + $(prog) ./simple.xml ./simple-unqualified.rng + @echo + +EX = $(wildcard *valid*.xml *valid*.rng simple*.xml simple*.rng) dist : [ -d $(DIST_DIR) ] || mkdir -p $(DIST_DIR) diff --git a/examples/hrelaxng/simple-qualified.rng b/examples/hrelaxng/simple-qualified.rng new file mode 100644 --- /dev/null +++ b/examples/hrelaxng/simple-qualified.rng @@ -0,0 +1,32 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/examples/hrelaxng/simple-unqualified.rng b/examples/hrelaxng/simple-unqualified.rng new file mode 100644 --- /dev/null +++ b/examples/hrelaxng/simple-unqualified.rng @@ -0,0 +1,32 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/examples/hrelaxng/simple.xml b/examples/hrelaxng/simple.xml new file mode 100644 --- /dev/null +++ b/examples/hrelaxng/simple.xml @@ -0,0 +1,6 @@ + + + red + die + plastic + diff --git a/hxt-relaxng.cabal b/hxt-relaxng.cabal --- a/hxt-relaxng.cabal +++ b/hxt-relaxng.cabal @@ -1,16 +1,16 @@ -- arch-tag: Haskell XML Toolbox main description file Name: hxt-relaxng -Version: 9.1.0 +Version: 9.1.1 Synopsis: The HXT RelaxNG validator Description: The HXT RelaxNG validator -License: OtherLicense +License: MIT License-file: LICENSE Author: Uwe Schmidt, Martin Schmidt, Torben Kuseler Maintainer: Uwe Schmidt Stability: Stable Category: XML Homepage: http://www.fh-wedel.de/~si/HXmlToolbox/index.html -Copyright: Copyright (c) 2005-2010 Uwe Schmidt +Copyright: Copyright (c) 2005-2011 Uwe Schmidt Build-type: Simple Cabal-version: >=1.6 @@ -33,6 +33,9 @@ examples/hrelaxng/valid1.xml examples/hrelaxng/valid2.rng examples/hrelaxng/valid2.xml + examples/hrelaxng/simple.xml + examples/hrelaxng/simple-qualified.rng + examples/hrelaxng/simple-unqualified.rng library exposed-modules: diff --git a/src/Text/XML/HXT/RelaxNG/CreatePattern.hs b/src/Text/XML/HXT/RelaxNG/CreatePattern.hs --- a/src/Text/XML/HXT/RelaxNG/CreatePattern.hs +++ b/src/Text/XML/HXT/RelaxNG/CreatePattern.hs @@ -28,7 +28,9 @@ import Data.List ( isPrefixOf ) - +{- +import qualified Debug.Trace as T +-} -- ------------------------------------------------------------ -- | Creates the 'Pattern' datastructure from a simplified Relax NG schema. @@ -49,25 +51,24 @@ 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 "" + = 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 "internal HXT RelaxNG error" ] - processRoot :: Env -> LA XmlTree Pattern processRoot env = getChildren @@ -75,7 +76,7 @@ choiceA [ isRngRelaxError :-> (mkRelaxError $< getRngAttrDescr), isRngGrammar :-> (processGrammar env), - this :-> (mkRelaxError "no grammar-pattern in schema") + this :-> (mkRelaxError "no grammar-pattern in schema") ] @@ -83,11 +84,11 @@ processGrammar env = getChildren >>> - choiceA [ - isRngDefine :-> none, - isRngRelaxError :-> (mkRelaxError $< getAttrValue "desc"), - isRngStart :-> (getChildren >>> createPatternFromXml env), - this :-> (mkRelaxError "no start-pattern in schema") + choiceA + [ isRngDefine :-> none + , isRngRelaxError :-> (mkRelaxError $< getAttrValue "desc") + , isRngStart :-> (getChildren >>> createPatternFromXml env) + , this :-> (mkRelaxError "no start-pattern in schema") ] @@ -119,25 +120,26 @@ -- | Creates an error message. mkRelaxError :: String -> LA XmlTree Pattern mkRelaxError errStr - = choiceA [ - isRngRelaxError :-> (getRngAttrDescr >>> arr notAllowed), - isElem :-> ( getName + = choiceA + [ isRngRelaxError :-> (getRngAttrDescr >>> arr notAllowed) + , isElem :-> ( getName >>> arr (\n -> notAllowed $ "Pattern " ++ n ++ - " is not allowed in Relax NG schema" + " is not allowed in Relax NG schema" ++ + " (" ++ errStr ++ ")" ) - ), - isAttr :-> ( getName + ) + , isAttr :-> ( getName >>> arr (\n -> notAllowed $ "Attribute " ++ n ++ " is not allowed in Relax NG schema" ) - ), - isError :-> (getErrorMsg >>> arr notAllowed), - this :-> (arr (\e -> notAllowed $ if errStr /= "" + ) + , isError :-> ( getErrorMsg >>> arr notAllowed ) + + , this :-> arr ( \e -> notAllowed $ if errStr /= "" then errStr else "Can't create pattern from " ++ show e) - ) ] diff --git a/src/Text/XML/HXT/RelaxNG/Simplification.hs b/src/Text/XML/HXT/RelaxNG/Simplification.hs --- a/src/Text/XML/HXT/RelaxNG/Simplification.hs +++ b/src/Text/XML/HXT/RelaxNG/Simplification.hs @@ -744,7 +744,7 @@ >>> ( -- A choice, group or interleave element is transformed so -- that it has exactly two child elements. - ((wrapPattern2Two $< getName) >>> simplificationStep4) + ((wrapPattern2Two $< getQName) >>> simplificationStep4) `when` ( isChoiceGroupInterleave >>> @@ -1152,26 +1152,29 @@ createPatternElems :: String -> String -> IOSArrow XmlTree XmlTree createPatternElems pattern name - = ( ( (listA (getElems pattern name >>> getRngAttrCombine)) + = ( ( 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) + listA (getElems pattern name >>> removeAttr "combine")) + >>> -- ((errorCode::Int, errorMessage::String), result::XmlTrees) choiceA - [ isA (\ ((code,_) , _) -> code == 0) + [ isA (\ ((code, _) , _) -> code == 0) :-> (mkRelaxError "" $< arr (snd . fst)) - , isA (\ ((code,str) , _) -> code == 1 && str == "") + + , isA (\ ((code, str) , _) -> code == 1 && str == "") :-> arrL snd - , isA (\ ((code,str) , _) -> code == 1 && str /= "") + + , isA (\ ((code, str) , _) -> code == 1 && str /= "") :-> ( createPatternElem pattern name $<< ( arr (snd . fst) &&& (arr snd) ) ) + , this :-> ( mkRelaxError "" @@ -1188,7 +1191,7 @@ (arrL (const trees) >>> getChildren) ) >>> - wrapPattern2Two combine + (wrapPattern2Two $< getQName) ) checkPatternCombine :: (ArrowXml a) => String -> String -> a [String] (Int, String) @@ -1198,12 +1201,14 @@ (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 @@ -1213,6 +1218,7 @@ show name ++ " in the same grammar" ) ) + , -- ok -> combine value is returned this :-> @@ -2180,11 +2186,11 @@ `guards` this -wrapPattern2Two :: (ArrowXml a) => String -> a XmlTree XmlTree +wrapPattern2Two :: (ArrowXml a) => QName -> a XmlTree XmlTree wrapPattern2Two name = choiceA [ noOfChildren (> 2) - :-> ( replaceChildren ( (mkRngElement name none + :-> ( replaceChildren ( (mkElement name none (getChildren >>. take 2) ) <+>