hxt-relaxng 9.1.4 → 9.1.5
raw patch · 5 files changed
+112/−162 lines, 5 files
Files
- hxt-relaxng.cabal +1/−1
- src/Text/XML/HXT/RelaxNG/CreatePattern.hs +30/−26
- src/Text/XML/HXT/RelaxNG/DataTypes.hs +2/−0
- src/Text/XML/HXT/RelaxNG/Simplification.hs +74/−134
- src/Text/XML/HXT/RelaxNG/SystemConfig.hs +5/−1
hxt-relaxng.cabal view
@@ -1,6 +1,6 @@ -- arch-tag: Haskell XML Toolbox main description file Name: hxt-relaxng-Version: 9.1.4+Version: 9.1.5 Synopsis: The HXT RelaxNG validator Description: The HXT RelaxNG validator License: MIT
src/Text/XML/HXT/RelaxNG/CreatePattern.hs view
@@ -36,20 +36,23 @@ -- | 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)+createPatternFromXmlTree = arr patternFromXmlTree +patternFromXmlTree :: XmlTree -> Pattern+patternFromXmlTree t = patternFromXml env t+ where env = map (fmap $ patternFromXml env) definitions+ definitions = runLA createDefinitionList t+ createDefinitionList :: LA XmlTree (String, XmlTree)+ createDefinitionList = deep isRngDefine+ >>>+ (getRngAttrName &&& getChildren) +patternFromXml :: PatternEnv -> XmlTree -> Pattern+patternFromXml env = head . runLA (createPatternFromXml env)+ -- | Transforms each XML-element to the corresponding pattern -createPatternFromXml :: Env -> LA XmlTree Pattern+createPatternFromXml :: PatternEnv -> LA XmlTree Pattern createPatternFromXml env = choiceA [ isRoot :-> processRoot env@@ -69,7 +72,7 @@ , this :-> mkRelaxError "internal HXT RelaxNG error" ] -processRoot :: Env -> LA XmlTree Pattern+processRoot :: PatternEnv -> LA XmlTree Pattern processRoot env = getChildren >>>@@ -80,7 +83,7 @@ ] -processGrammar :: Env -> LA XmlTree Pattern+processGrammar :: PatternEnv -> LA XmlTree Pattern processGrammar env = getChildren >>>@@ -98,19 +101,20 @@ to find the corresponding define-pattern. Haskells lazy-evaluation is used to transform circular structures. -}-mkRelaxRef :: Env -> LA XmlTree Pattern+mkRelaxRef :: PatternEnv -> LA XmlTree Pattern mkRelaxRef e = getRngAttrName >>> arr (\n -> fromMaybe (notAllowed $ "define-pattern with name " ++ n ++ " not found")- . lookup n $ transformEnv e+ $ lookup n e )- where+{-+ 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@@ -144,7 +148,7 @@ -- | Transforms a choice-element.-mkRelaxChoice :: Env -> LA XmlTree Pattern+mkRelaxChoice :: PatternEnv -> LA XmlTree Pattern mkRelaxChoice env = ifA ( getChildren >>. ( \ l -> if length l == 1 then l else [] )@@ -153,7 +157,7 @@ ( getTwoChildrenPattern env >>> arr2 Choice ) -- | Transforms a interleave-element.-mkRelaxInterleave :: Env -> LA XmlTree Pattern+mkRelaxInterleave :: PatternEnv -> LA XmlTree Pattern mkRelaxInterleave env = getTwoChildrenPattern env >>>@@ -161,7 +165,7 @@ -- | Transforms a group-element.-mkRelaxGroup :: Env -> LA XmlTree Pattern+mkRelaxGroup :: PatternEnv -> LA XmlTree Pattern mkRelaxGroup env = getTwoChildrenPattern env >>>@@ -169,7 +173,7 @@ -- | Transforms a oneOrMore-element.-mkRelaxOneOrMore :: Env -> LA XmlTree Pattern+mkRelaxOneOrMore :: PatternEnv -> LA XmlTree Pattern mkRelaxOneOrMore env = getOneChildPattern env >>>@@ -177,7 +181,7 @@ -- | Transforms a list-element.-mkRelaxList :: Env -> LA XmlTree Pattern+mkRelaxList :: PatternEnv -> LA XmlTree Pattern mkRelaxList env = getOneChildPattern env >>>@@ -185,7 +189,7 @@ -- | Transforms a data- or dataExcept-element.-mkRelaxData :: Env -> LA XmlTree Pattern+mkRelaxData :: PatternEnv -> LA XmlTree Pattern mkRelaxData env = ifA (getChildren >>> isRngExcept) (processDataExcept >>> arr3 DataExcept)@@ -243,7 +247,7 @@ -- | Transforms a attribute-element. -- The first child is a 'NameClass', the second (the last) one a pattern. -mkRelaxAttribute :: Env -> LA XmlTree Pattern+mkRelaxAttribute :: PatternEnv -> LA XmlTree Pattern mkRelaxAttribute env = ( ( firstChild >>> createNameClass ) &&&@@ -254,7 +258,7 @@ -- | Transforms a element-element. -- The first child is a 'NameClass', the second (the last) one a pattern.-mkRelaxElement :: Env -> LA XmlTree Pattern+mkRelaxElement :: PatternEnv -> LA XmlTree Pattern mkRelaxElement env = ( ( firstChild >>> createNameClass ) &&&@@ -333,12 +337,12 @@ ] -getOneChildPattern :: Env -> LA XmlTree Pattern+getOneChildPattern :: PatternEnv -> LA XmlTree Pattern getOneChildPattern env = firstChild >>> createPatternFromXml env -getTwoChildrenPattern :: Env -> LA XmlTree (Pattern, Pattern)+getTwoChildrenPattern :: PatternEnv -> LA XmlTree (Pattern, Pattern) getTwoChildrenPattern env = ( getOneChildPattern env ) &&&
src/Text/XML/HXT/RelaxNG/DataTypes.hs view
@@ -28,6 +28,8 @@ type Env = [(String, XmlTree)] +type PatternEnv = [(String, Pattern)]+ -- | Start of a context attribute value -- (see also: 'Text.XML.HXT.RelaxNG.Simplification.simplificationStep1') --
src/Text/XML/HXT/RelaxNG/Simplification.hs view
@@ -51,12 +51,10 @@ , fromMaybe ) import Data.List- ( elemIndices- , nub- , deleteBy- , find- , (\\)+ ( (\\) )+import Data.Map+ ( Map, fromListWithKey, toList ) infixr 1 !>>> @@ -975,11 +973,12 @@ >>> -- For each grammar element, all define elements with the same -- name are combined together.- ( combinePatternList "define" $< (getPatternNamesInGrammar "define" >>> arr nub) )+ -- ( combinePatternList "define" $< (getPatternNamesInGrammar "define" >>> arr nub) )+ ( mergeCombinedPatternMap "define" $< getPatternNameMapInGrammar "define" (combinePatterns "define" True)) >>> -- Similarly, for each grammar element all start elements -- are combined together.- ( combinePatternList "start" $< (getPatternNamesInGrammar "start" >>> arr nub) )+ ( mergeCombinedPatternMap "start" $< (getPatternNameMapInGrammar "start" (combinePatterns "start" False)) ) ) `when` isRngGrammar@@ -1034,6 +1033,31 @@ ) ) `when` collectErrors where+ getPatternNameMapInGrammar :: (ArrowXml a) => String -> (String -> XmlTree -> XmlTree -> XmlTree)+ -> a XmlTree (Map String XmlTree)+ getPatternNameMapInGrammar pattern combinator+ = (+ getChildren + >>>+ allGrammarPatterns+ >>>+ (getRngAttrName &&& this)+ )+ >.+ fromListWithKey combinator+ where allGrammarPatterns + = choiceA+ [ hasRngElemName pattern+ :->+ this+ , isRngGrammar + :-> + none+ , this+ :->+ (getChildren >>> allGrammarPatterns)+ ]+ getPatternNamesInGrammar :: (ArrowXml a) => String -> a XmlTree [String] getPatternNamesInGrammar pattern = processChildren@@ -1135,134 +1159,50 @@ 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 (mkRngAttrName name)- ( ( mkRngElement combine none- (arrL (const trees) >>> getChildren)- )- >>>- (wrapPattern2Two $< getQName)- )-- 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- = ( hasRngElemName 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 )- ]+ combinePatterns :: String -> Bool -> String -> XmlTree -> XmlTree -> XmlTree+ combinePatterns pattern keepName name t1 t2 = combined+ where [combined] = runLA (combine $<< parts) undefined+ combine (c1, d1) (c2, d2)+ | c1 == "" && c2 == "" = mkRngRelaxError+ >>>+ addRngAttrDescr ("More than one " ++ pattern ++ "-Pattern: " ++ show name + ++ " without a combine-attribute in the same grammar")+ | c1 == "" = combineWith c2 d1 d2+ | c2 == "" = combineWith c1 d1 d2+ | c1 == c2 = combineWith c1 d1 d2+ | otherwise = mkRngRelaxError+ >>>+ addRngAttrDescr ("Different combine-Attributes: " +++ (formatStringListQuot [c1, c2]) +++ " for the " ++ pattern ++ "-Pattern " +++ show name ++ " in the same grammar")+ combineWith :: String -> XmlTree -> XmlTree -> LA n XmlTree+ combineWith c d1 d2 = mkRngElement pattern+ (mkRngAttr "combine" (constA c) <+> if keepName then mkRngAttrName name else none)+ (mkRngElement c none $ arrL $ const [d1, d2])+ parts = (+ (constA t1 >>> getRngAttrCombine &&& getChildren)+ &&&+ (constA t2 >>> getRngAttrCombine &&& getChildren)+ ) + mergeCombinedPatternMap :: String -> Map String XmlTree -> IOSArrow XmlTree XmlTree+ mergeCombinedPatternMap pattern definitions+ = replaceChildren ((constL (toList definitions) >>> arr snd)+ <+>+ (getChildren >>> deleteDefinitions))+ where deleteDefinitions + = choiceA+ [ hasRngElemName pattern+ :->+ none+ , isRngGrammar + :-> + this+ , this+ :->+ processChildren deleteDefinitions+ ] -- ------------------------------------------------------------
src/Text/XML/HXT/RelaxNG/SystemConfig.hs view
@@ -35,7 +35,11 @@ withRelaxNG s = setS (theRelaxValidate .&&&. theRelaxSchema .&&&. theRelaxValidator- ) (True, (s, validateDocumentWithRelaxSchema [] s))+ ) ( not (null s) -- null s turns off validation+ , ( s+ , validateDocumentWithRelaxSchema [] s+ )+ ) withRelaxCheckRestr :: Bool -> SysConfig withRelaxCheckRestr = setS theRelaxCheckRestr