module Text.XML.HXT.RelaxNG.Simplification
( createSimpleForm
, getErrors
, resetStates
)
where
import Control.Arrow.ListArrows
import Text.XML.HXT.DOM.Interface
import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.Arrow.Edit ( removeWhiteSpace
)
import Text.XML.HXT.Arrow.Namespace ( processWithNsEnv
)
import Text.XML.HXT.Arrow.XmlState
import Text.XML.HXT.Arrow.XmlState.TypeDefs
import Text.XML.HXT.RelaxNG.DataTypes
import Text.XML.HXT.RelaxNG.BasicArrows
import Text.XML.HXT.RelaxNG.CreatePattern
import Text.XML.HXT.RelaxNG.DataTypeLibraries
import Text.XML.HXT.RelaxNG.Utils
import Text.XML.HXT.RelaxNG.Validation
import Text.XML.HXT.RelaxNG.Schema as S
import Text.XML.HXT.RelaxNG.SchemaGrammar as SG
import Data.Maybe
( fromJust
, fromMaybe
)
import Data.List
( (\\)
)
import Data.Map
( Map, fromListWithKey, toList )
infixr 1 !>>>
simplificationStep1 :: IOSArrow XmlTree XmlTree
simplificationStep1
= (
( processHref $< getBaseURI )
>>>
processWithNsEnv processEnvNames (toNsEnv [("xml", xmlNamespace)])
>>>
processdatatypeLib ""
>>>
processTopDownWithAttrl
(
(
none
`when`
( ( isElem >>> neg isRoot
>>>
getNamespaceUri
>>>
isA (\ uri -> (not $ compareURI uri relaxNamespace))
)
`orElse`
( isAttr
>>>
getNamespaceUri
>>>
isA (\ uri -> (uri /= "" && (not $ compareURI uri relaxNamespace)))
)
)
)
>>>
(
( processChildren removeWhiteSpace
`whenNot`
(isRngParam `orElse` isRngValue)
)
`when` isElem
)
>>>
(
changeAttrValue normalizeWhitespace
`when`
( isRngAttrName `orElse` isRngAttrType `orElse` isRngAttrCombine)
)
>>>
(
processChildren (changeText normalizeWhitespace)
`when`
isRngName
)
>>>
(
changeAttrValue escapeURI
`when`
isRngAttrDatatypeLibrary
)
>>>
(
( mkRelaxError "" $< ( getRngAttrDatatypeLibrary
>>>
arr (\ a -> ( "datatypeLibrary attribute: " ++
a ++ " is not a valid URI"
)
)
)
)
`when`
( isElem
>>>
hasRngAttrDatatypeLibrary
>>>
getRngAttrDatatypeLibrary >>> isA (not . isRelaxAnyURI)
)
)
>>>
(
removeAttr "datatypeLibrary"
`when`
( isElem
>>>
neg (isRngData `orElse` isRngValue)
>>>
hasRngAttrDatatypeLibrary
)
)
>>>
(
( addAttr "type" "token"
>>>
addAttr "datatypeLibrary" ""
)
`when`
( isRngValue >>> neg hasRngAttrType )
)
)
) `when` collectErrors
where
processHref :: String -> IOSArrow XmlTree XmlTree
processHref uri
= processChildren
( choiceA
[ ( isElem >>> hasAttr "xml:base" )
:-> ( ifA ( isExternalRefInclude >>> hasRngAttrHref )
(
(processAttrl (changeAttrValue escapeURI `when` isRngAttrHref))
>>>
(addAttr "href" $< (absURI "href" $< (absURI "xml:base" uri)))
>>>
(processHref $< absURI "xml:base" uri)
)
(processHref $< absURI "xml:base" uri)
)
, ( isExternalRefInclude >>> hasRngAttrHref )
:-> (
(processAttrl (changeAttrValue escapeURI `when` isRngAttrHref))
>>>
(addAttr "href" $< absURI "href" uri)
)
, this
:-> processHref uri
]
)
where
absURI :: String -> String -> IOSArrow XmlTree String
absURI attrName u
= ( getAttrValue attrName
>>>
arr (\ a -> fromMaybe "" (expandURIString a u))
>>>
( arr ("illegal URI, fragment identifier not allowed: " ++)
`whenNot`
(getFragmentFromURI >>> isA null)
)
)
processEnvNames :: NsEnv -> IOSArrow XmlTree XmlTree
processEnvNames env
= ( ( (replaceQNames env $< getAttrValue "name")
`when`
( (isRngElement `orElse` isRngAttribute)
>>>
hasRngAttrName
)
)
>>>
( (addAttrl (getBaseURI >>> createAttrL))
`when`
isRngValue
)
)
where
createAttrL :: IOSArrow String XmlTree
createAttrL
= setBaseUri
<+>
( fromLA $ txt "" >>> catA (map createAttr env) )
where
createAttr :: (XName, XName) -> LA XmlTree XmlTree
createAttr (pre, uri)
= mkAttr qn (txt (unXN uri))
where
qn :: QName
qn | isNullXName pre = mkName $ contextAttributesDefault
| otherwise = mkName $ contextAttributes ++ unXN pre
setBaseUri :: IOSArrow String XmlTree
setBaseUri = mkRngAttrContextBase this
replaceQNames :: NsEnv -> String -> IOSArrow XmlTree XmlTree
replaceQNames env' name
| null px
= this
| null ns
= mkRelaxError "" ( "No namespace mapping for the prefix " ++ show px ++
" in the context of element: " ++ show name ++
", namespace env is " ++ show (map (unXN *** unXN) env')
)
| otherwise
= addAttr "name" (universalName qn)
where
qn = setNamespace env' . mkName $ name
px = namePrefix qn
ns = namespaceUri qn
processdatatypeLib :: (ArrowXml a) => String -> a XmlTree XmlTree
processdatatypeLib lib
= processChildren $
choiceA
[ hasRngAttrDatatypeLibrary
:-> ( processdatatypeLib $< getRngAttrDatatypeLibrary )
, ( (isRngData `orElse` isRngValue)
>>>
neg hasRngAttrDatatypeLibrary
)
:-> ( addAttr "datatypeLibrary" lib
>>>
processdatatypeLib lib
)
, this
:-> processdatatypeLib lib
]
`when` isElem
simplificationStep2 :: Bool -> Bool -> [Uri] -> [Uri] -> IOSArrow XmlTree XmlTree
simplificationStep2 validateExternalRef validateInclude extHRefs includeHRefs =
( processTopDown (
( (importExternalRef $<< (getRngAttrNs &&& getRngAttrHref))
`when`
isRngExternalRef
)
>>>
( (importInclude $< getAttrValue "href")
`when`
isRngInclude
)
)
) `when` collectErrors
where
importExternalRef :: String -> String -> IOSArrow XmlTree XmlTree
importExternalRef ns href
| href `elem` extHRefs
= mkRelaxError ""
( "loop in externalRef-Pattern, " ++ formatStringListArr (reverse $ href:extHRefs) )
| otherwise
= readForRelax href
>>>
( mkRelaxError "" (show href ++ ": can't read URI, referenced in externalRef-Pattern")
`whenNot`
documentStatusOk
)
!>>>
( if validateExternalRef
then ( mkRelaxError ""
( "The content of the schema " ++ show href ++
", referenced in externalRef does not " ++
"match the syntax for pattern"
)
`whenNot`
validateWithRelax S.relaxSchemaArrow
)
else this
)
!>>>
( simplificationStep1
>>>
simplificationStep2 validateExternalRef validateInclude (href:extHRefs) includeHRefs
>>>
getChildren
>>>
isElem
>>>
(
addRngAttrNs ns
`when`
(getRngAttrNs >>> isA (\ a -> a == "" && ns /= ""))
)
)
>>>
traceDoc ("imported external ref: " ++ show href)
importInclude :: String -> IOSArrow XmlTree XmlTree
importInclude href
| href `elem` includeHRefs
= mkRelaxError ""
( "loop in include-Pattern, " ++ formatStringListArr (reverse $ href:includeHRefs) )
| otherwise
= processInclude' $< newDoc
where
processInclude' newDoc'
| not . null . runLA isRngRelaxError $ newDoc'
= constA newDoc'
| otherwise
= processInclude href newDoc'
newDoc
= readForRelax href
>>>
( mkRelaxError "" (show href ++ ": can't read URI, referenced in include-Pattern")
`whenNot`
documentStatusOk
)
!>>>
( if validateInclude
then ( mkRelaxError ""
( "The content of the schema " ++ show href ++
", referenced in include does not " ++
"match the syntax for grammar"
)
`whenNot`
validateWithRelax SG.relaxSchemaArrow
)
else this
)
!>>>
( simplificationStep1
>>>
simplificationStep2 validateExternalRef validateInclude extHRefs (href:includeHRefs)
>>>
getChildren
>>>
isElem
)
processInclude :: String -> XmlTree -> IOSArrow XmlTree XmlTree
processInclude href newDoc
=
setRngNameDiv
>>>
removeAttr "href"
>>>
checkInclude href newDoc
insertNewDoc :: XmlTree -> Bool -> [String] -> IOSArrow XmlTree XmlTree
insertNewDoc newDoc hasStart defNames
= insertChildrenAt 0 $
constA newDoc
>>>
(removeStartComponent `whenP` (const hasStart))
>>>
((removeDefineComponent defNames) `whenP` (const $ defNames /= []))
>>>
setRngNameDiv
checkInclude :: String -> XmlTree -> IOSArrow XmlTree XmlTree
checkInclude href newDoc
= ifA (
hasStartComponent &&& (constA newDoc >>> hasStartComponent)
>>>
isA (\ (a, b) -> if a then b else True)
)
( ifA (
getDefineComponents &&& (constA newDoc >>> getDefineComponents)
>>>
isA (\ (a, b) -> (diff a b) == [])
)
(insertNewDoc newDoc $<< hasStartComponent &&& getDefineComponents)
( mkRelaxError ""
( "Define-pattern missing in schema " ++ show href ++
", referenced in include-pattern"
)
)
)
( mkRelaxError ""
( "Grammar-element without a start-pattern in schema " ++
show href ++ ", referenced in include-pattern"
)
)
where
diff a b = (noDoubles a) \\ (noDoubles b)
removeStartComponent :: IOSArrow XmlTree XmlTree
removeStartComponent
= processChildren $
choiceA [
isRngStart :-> none,
isRngDiv :-> removeStartComponent,
this :-> this
]
removeDefineComponent :: [String] -> IOSArrow XmlTree XmlTree
removeDefineComponent defNames
= processChildren $
choiceA [
( isRngDefine
>>>
getRngAttrName
>>>
isA (\n -> elem n defNames)) :-> none,
(isElem >>> getName >>> isA (== "div")) :-> (removeDefineComponent defNames),
(constA "foo" >>> isA (== "foo")) :-> this
]
hasStartComponent :: IOSArrow XmlTree Bool
hasStartComponent = listA hasStartComponent' >>> arr (any id)
where
hasStartComponent' :: IOSArrow XmlTree Bool
hasStartComponent'
= getChildren
>>>
choiceA [
isRngStart :-> (constA True),
isRngDiv :-> hasStartComponent',
this :-> (constA False)
]
getDefineComponents :: IOSArrow XmlTree [String]
getDefineComponents = listA getDefineComponents'
>>>
arr (\xs -> [x | x <- xs, x /= ""])
where
getDefineComponents' :: IOSArrow XmlTree String
getDefineComponents'
= getChildren
>>>
choiceA
[ isRngDefine :-> getRngAttrName
, isRngDiv :-> getDefineComponents'
, this :-> constA ""
]
simplificationStep3 :: IOSArrow XmlTree XmlTree
simplificationStep3 =
( processTopDown (
(
( insertChildrenAt 0 (mkRngName none (txt $< getRngAttrName))
)
>>>
(
(processChildren (addRngAttrNs "" `when` isRngName))
`when`
(isRngAttribute >>> hasRngAttrName >>> neg hasRngAttrNs)
)
>>>
removeAttr "name"
)
`when`
( (isRngElement `orElse` isRngAttribute) >>> hasRngAttrName )
)
>>>
processnsAttribute ""
>>>
processTopDown (
(
rmRngAttrNs
`when`
( isElem
>>>
neg (isRngName `orElse` isRngNsName `orElse` isRngValue)
)
)
>>>
(
( replaceNameAttr $< (getChildren >>> isText >>> getText) )
`when`
isRngName
)
)
) `when` collectErrors
where
replaceNameAttr :: (ArrowXml a) => String -> a XmlTree XmlTree
replaceNameAttr name
| '}' `elem` name
= ( addRngAttrNs pre
>>>
processChildren (changeText $ const local)
)
| otherwise
= this
where
(pre', local') = span (/= '}') name
pre = tail pre'
local = tail local'
processnsAttribute :: String -> IOSArrow XmlTree XmlTree
processnsAttribute name
= processChildren $
choiceA
[ (isElem >>> hasRngAttrNs)
:-> (processnsAttribute $< getRngAttrNs)
, ( isNameNsNameValue
>>>
neg hasRngAttrNs
)
:-> ( addRngAttrNs name
>>>
processnsAttribute name
)
, this
:-> processnsAttribute name
]
simplificationStep4 :: IOSArrow XmlTree XmlTree
simplificationStep4 =
( processTopDown (
(
(getChildren >>> simplificationStep4)
`when`
isRngDiv
)
>>>
(
( replaceChildren
( mkRngGroup
(setChangesAttr $< (getName >>> arr ("group-Pattern: " ++)))
getChildren
)
)
`when`
( isDefineOneOrMoreZeroOrMoreOptionalListMixed
>>>
noOfChildren (> 1)
)
)
>>>
(
( replaceChildren
( ( getChildren >>> isNameAnyNameNsName )
<+>
( mkRngGroup none
( getChildren
>>>
neg isNameAnyNameNsName
)
)
)
)
`when`
( isRngElement >>> noOfChildren (> 2) )
)
>>>
(
replaceChildren ( mkRngChoice none getChildren )
`when`
( isRngExcept >>> noOfChildren (> 1) )
)
>>>
(
insertChildrenAt 1 (mkRngText none)
`when`
( isRngAttribute >>> noOfChildren (== 1) )
)
>>>
(
((wrapPattern2Two $< getQName) >>> simplificationStep4)
`when`
( isChoiceGroupInterleave
>>>
noOfChildren (\ i -> i > 2 || i == 1)
)
)
>>>
(
( mkRngInterleave
( setChangesAttr "mixed is transformed into an interleave" )
( getChildren
<+>
mkRngText
( setChangesAttr ( "new text-Pattern: mixed is transformed into " ++
" an interleave with text"
)
)
)
)
`when`
isRngMixed
)
>>>
(
( mkRngChoice
( setChangesAttr "optional is transformed into a choice" )
( getChildren
<+>
mkRngEmpty
( setChangesAttr ( "new empty-Pattern: optional is transformed " ++
" into a choice with empty"
)
)
)
)
`when`
isRngOptional
)
>>>
(
( mkRngChoice
( setChangesAttr "zeroOrMore is transformed into a choice" )
( ( mkRngOneOrMore
( setChangesAttr ( "zeroOrMore is transformed into a " ++
"choice between oneOrMore and empty"
)
)
getChildren
)
<+>
( mkRngEmpty
( setChangesAttr ( "new empty-Pattern: zeroOrMore is transformed " ++
"into a choice between oneOrMore and empty"
)
)
)
)
)
`when`
isRngZeroOrMore
)
)
) `when` collectErrors
restrictionsStep1 :: IOSArrow XmlTree XmlTree
restrictionsStep1 =
( processTopDown (
( ( mkRelaxError ""
( "An except element that is a child of an anyName " ++
"element must not have any anyName descendant elements"
)
)
`when`
( isRngAnyName
>>>
getChildren
>>>
isRngExcept
>>>
deep isRngAnyName
)
)
>>>
( ( mkRelaxError ""
( "An except element that is a child of an nsName element " ++
"must not have any nsName or anyName descendant elements."
)
)
`when`
( isRngNsName
>>>
getChildren
>>>
isRngExcept
>>>
deep (isRngAnyName `orElse` isRngNsName)
)
)
>>>
( ( mkRelaxError ""
( "A name element that occurs as the first child or descendant of " ++
"an attribute and has an ns attribute with an empty value must " ++
"not have content equal to \"xmlns\""
)
)
`when`
( isRngAttribute
>>>
firstChild
>>>
( multi (isRngName >>> hasRngAttrNs) )
>>>
( ( getRngAttrNs >>> isA null)
`guards`
(getChildren >>> getText >>> isA (== "xmlns"))
)
)
)
>>>
( ( mkRelaxError ""
( "A name or nsName element that occurs as the first child or " ++
"descendant of an attribute must not have an ns attribute " ++
"with value http://www.w3.org/2000/xmlns"
)
)
`when`
( isRngAttribute
>>>
firstChild
>>>
( multi (isNameNsName >>> hasRngAttrNs) )
>>>
getRngAttrNs
>>>
isA (compareURI xmlnsNamespace)
)
)
>>>
( ( checkDatatype $<< getRngAttrDatatypeLibrary &&& getRngAttrType )
`when`
( isRngData `orElse` isRngValue )
)
)
) `when` collectErrors
where
checkDatatype :: Uri -> DatatypeName -> IOSArrow XmlTree XmlTree
checkDatatype libName typeName
= ifP (const $ elem libName $ map fst datatypeLibraries)
( checkType libName typeName allowedDataTypes )
( mkRelaxError ""
( "DatatypeLibrary " ++ show libName ++ " not found" )
)
where
DTC _ _ allowedDataTypes = fromJust $ lookup libName datatypeLibraries
checkType :: Uri -> DatatypeName -> AllowedDatatypes -> IOSArrow XmlTree XmlTree
checkType libName typeName allowedTypes
= ifP (const $ elem typeName $ map fst allowedTypes)
( checkParams typeName libName getParams $<
( listA (getChildren >>> isRngParam >>> getRngAttrName) )
)
( mkRelaxError ""
( "Datatype " ++ show typeName ++
" not declared for DatatypeLibrary " ++ show libName
)
)
where
getParams = fromJust $ lookup typeName allowedTypes
checkParams :: DatatypeName -> Uri -> AllowedParams -> [ParamName] -> IOSArrow XmlTree XmlTree
checkParams typeName libName allowedParams paramNames
= ( mkRelaxError ""
( "Param(s): " ++ formatStringListQuot diff ++
" not allowed for Datatype " ++ show typeName ++
" in Library " ++
show ( if null libName
then relaxNamespace
else libName
)
)
)
`when`
( isRngData >>> isA (const $ diff /= []) )
where
diff = filter (\param -> not $ elem param allowedParams) paramNames
simplificationStep5 :: IOSArrow XmlTree XmlTree
simplificationStep5
= ( processTopDown
( ( ( ( (deep isRngRelaxError)
<+>
( mkRelaxError "" "A grammar must have a start child element" )
)
`when`
(neg (getChildren >>> isRngStart))
)
>>>
( mergeCombinedPatternMap "define" $< getPatternNameMapInGrammar "define" (combinePatterns "define" True))
>>>
( mergeCombinedPatternMap "start" $< (getPatternNameMapInGrammar "start" (combinePatterns "start" False)) )
)
`when`
isRngGrammar
)
>>>
(
( replaceChildren
( mkRngGrammar none
( mkRngStart none getChildren )
)
)
`when`
neg (getChildren >>> isRngGrammar)
)
>>>
( renameDefines $<<
( getPatternNamesInGrammar "define"
>>>
( createUniqueNames
&&&
constA []
)
)
)
>>>
( processChildren
(
processChildren
(
( deleteAllDefines
<+>
( getAllDefines >>> processChildren deleteAllDefines )
)
>>>
processTopDown
( (
( getChildren >>> isRngStart >>> getChildren )
`when`
isRngGrammar
)
>>>
(
( setRngNameRef
`when`
isRngParentRef
)
)
)
)
)
)
) `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
( processTopDown ( none `when` isRngGrammar ) )
>>>
listA ( (multi (hasRngElemName pattern))
>>>
getRngAttrName
)
renameDefines :: RefList -> RefList -> IOSArrow XmlTree XmlTree
renameDefines ref parentRef
= processChildren
( choiceA
[ isRngDefine
:-> (
addAttr defineOrigName $< getRngAttrName
>>>
addAttr "name" $< ( getRngAttrName
>>>
arr (\n -> fromJust $ lookup n ref)
)
>>>
renameDefines ref parentRef
)
, isRngGrammar
:-> ( renameDefines $<<
( (
getPatternNamesInGrammar "define"
>>>
createUniqueNames
)
&&&
constA ref
)
)
, isRngRef
:-> ( ifA ( getRngAttrName
>>>
isA (\name -> (elem name (map fst ref)))
)
(
addAttr defineOrigName $< getRngAttrName
>>>
addAttr "name" $< ( getRngAttrName
>>>
arr (\n -> fromJust $ lookup n ref)
)
)
(
mkRelaxError "" $< ( getRngAttrName
>>>
arr (\ n -> ( "Define-Pattern with name " ++ show n ++
" referenced in ref-Pattern not " ++
"found in schema"
)
)
)
)
)
, isRngParentRef
:-> ( ifA ( getRngAttrName
>>>
isA (\name -> (elem name (map fst parentRef)))
)
( addAttr defineOrigName $< getRngAttrName
>>>
addAttr "name" $< ( getRngAttrName
>>>
arr (\n -> fromJust $ lookup n parentRef)
)
)
( mkRelaxError "" $<
( getRngAttrName
>>>
arr (\ n -> ( "Define-Pattern with name " ++ show n ++
" referenced in parentRef-Pattern " ++
"not found in schema"
)
)
)
)
)
, this
:-> renameDefines ref parentRef
]
)
getAllDefines :: IOSArrow XmlTree XmlTree
getAllDefines = multi isRngDefine
deleteAllDefines :: IOSArrow XmlTree XmlTree
deleteAllDefines = processTopDown $ none `when` isRngDefine
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
]
simplificationStep6 :: IOSArrow XmlTree XmlTree
simplificationStep6 =
(
(removeUnreachableDefines $<<< getAllDeepDefines
&&&
constA []
&&&
getRefsFromStartPattern
)
>>>
( processElements False
>>>
processChildren (insertChildrenAt 1 (getRelaxParam "elementTable"))
)
>>>
(replaceExpandableRefs [] $< getExpandableDefines >>> deleteExpandableDefines)
) `when` collectErrors
where
replaceExpandableRefs :: RefList -> Env -> IOSArrow XmlTree XmlTree
replaceExpandableRefs foundNames defTable
= choiceA [
isRngRef
:-> (ifA ( getRngAttrName
>>>
isA (\name -> elem name (map fst foundNames))
)
(mkRelaxError "" $< ( getAttrValue defineOrigName
>>>
arr (\ n -> ( "Recursion in ref-Pattern: " ++
formatStringListArr (reverse $ (n:) $ map snd foundNames)
)
)
)
)
(replaceRef $<< getRngAttrName &&& getAttrValue defineOrigName)
),
this :-> (processChildren $ replaceExpandableRefs foundNames defTable)
]
where
replaceRef :: NewName -> OldName -> IOSArrow XmlTree XmlTree
replaceRef name oldname
= ( constA (fromJust $ lookup name defTable)
>>>
getChildren
>>>
replaceExpandableRefs ((name,oldname):foundNames) defTable
)
`whenP`
(const $ elem name $ map fst defTable)
processElements :: Bool -> IOSArrow XmlTree XmlTree
processElements parentIsDefine
= processChildren
( choiceA
[ isRngElement
:-> ( ifP (const parentIsDefine)
(processElements False)
( processElements' $<
( listA getDefineName
>>>
createUniqueNames
)
)
)
, isRngDefine
:-> processElements True
, this
:-> processElements False
])
where
getDefineName :: IOSArrow XmlTree String
getDefineName
= firstChild
>>>
fromLA createNameClass
>>>
arr show
processElements' :: RefList -> IOSArrow XmlTree XmlTree
processElements' [(oldname, name)]
= storeElement name oldname
>>>
mkRngRef (createAttr name oldname) none
processElements' l
= error $ "processElements' called with illegal arg: " ++ show l
storeElement :: NewName -> OldName -> IOSArrow XmlTree XmlTree
storeElement name oldname
= perform $
( mkRngDefine
(createAttr name oldname) (processElements False)
)
&&&
(listA $ getRelaxParam "elementTable")
>>>
arr2 (:)
>>>
setRelaxParam "elementTable"
createAttr :: NewName -> OldName -> IOSArrow XmlTree XmlTree
createAttr name oldname
= mkRngAttrName name
<+>
mkRngAttrDefineOrigName ("created for element " ++ oldname)
getExpandableDefines :: (ArrowXml a) => a XmlTree Env
getExpandableDefines
= listA $ (multi ( ( isRngDefine
>>>
getChildren
>>>
neg isRngElement
)
`guards`
this
)
)
>>>
(getRngAttrName &&& this)
deleteExpandableDefines :: (ArrowXml a) => a XmlTree XmlTree
deleteExpandableDefines
= processTopDown $ none
`when`
( isRngDefine
>>>
getChildren
>>>
neg isRngElement
)
simplificationStep7 :: IOSArrow XmlTree XmlTree
simplificationStep7
= ( markTreeChanged 0
>>>
processTopDownWithAttrl
( (
( ( mkRngNotAllowed none none
>>>
markTreeChanged 1
)
`whenNot`
(deep isRngRelaxError)
)
`when`
( isAttributeListGroupInterleaveOneOrMore
>>>
getChildren
>>>
isRngNotAllowed
)
)
>>>
(
( mkRngNotAllowed none none
>>>
markTreeChanged 1
)
`when`
( isRngChoice
>>>
listA (getChildren >>> isRngNotAllowed)
>>>
isA (\s -> length s == 2)
)
)
>>>
(
( getChildren >>> neg isRngNotAllowed
>>>
markTreeChanged 1
)
`when`
( isRngChoice >>> getChildren >>> isRngNotAllowed )
)
>>>
(
( ( markTreeChanged 1
>>>
none
)
`whenNot`
deep isRngRelaxError
)
`when`
( isRngExcept >>> getChildren >>> isRngNotAllowed )
)
>>>
(
( mkRngEmpty none
>>>
markTreeChanged 1
)
`when`
( isChoiceGroupInterleave
>>>
listA (getChildren >>> isRngEmpty)
>>>
isA (\s -> length s == 2)
)
)
>>>
(
( getChildren
>>>
neg isRngEmpty
>>>
markTreeChanged 1
)
`when`
( isGroupInterleave >>> getChildren >>> isRngEmpty )
)
>>>
(
changeChoiceChildren
`when`
( isRngChoice >>> getChildren >>> isRngEmpty )
)
>>>
(
( mkRngEmpty none
>>>
markTreeChanged 1
)
`when`
( isRngOneOrMore >>> getChildren >>> isRngEmpty )
)
)
>>>
( simplificationStep7
`when`
hasTreeChanged
)
) `when` collectErrors
where
changeChoiceChildren :: IOSArrow XmlTree XmlTree
changeChoiceChildren
= ( ( replaceChildren
( mkRngEmpty none
<+>
(getChildren >>> neg isRngEmpty)
)
>>>
markTreeChanged 1
)
`when`
( single (getChildren >>> isElem)
>>>
neg isRngEmpty
)
)
hasTreeChanged :: IOSArrow b Int
hasTreeChanged
= getSysAttrInt 0 "rng:changeTree"
>>>
isA (== 1)
markTreeChanged :: Int -> IOSArrow b b
markTreeChanged i
= perform (setSysAttrInt "rng:changeTree" i)
simplificationStep8 :: IOSArrow XmlTree XmlTree
simplificationStep8
= ( ( removeUnreachableDefines $<<<
( getAllDeepDefines
&&&
constA []
&&&
getRefsFromStartPattern
)
)
`when` collectErrors
)
restrictionsStep2 :: IOSArrow XmlTree XmlTree
restrictionsStep2 =
processTopDown (
choiceA [
isRngAttribute :->
( ( deep isRngRelaxError
<+>
( mkRelaxError $<< (getChangesAttr
&&&
( listA ( getChildren
>>>
deep isAttributeRef
>>>
(getName &&& getChangesAttr >>> arr2 (++))
)
>>>
arr (\n -> formatStringListPatt n ++
"Pattern not allowed as descendent(s)" ++
" of a attribute-Pattern"
)
)
)
)
)
`when`
( getChildren >>> deep isAttributeRef )
),
isRngOneOrMore :->
( ( deep isRngRelaxError
<+>
( mkRelaxError $<< (getChangesAttr
&&&
( listA ( getChildren
>>>
deep isGroupInterleave
>>>
(getName &&& getChangesAttr >>> arr2 (++))
)
&&&
getChangesAttr
>>>
arr2 (\ n c -> ( formatStringListPatt n ++
"Pattern not allowed as descendent(s) " ++
"of a oneOrMore-Pattern" ++
(if null c then "" else " " ++ show c) ++
" followed by an attribute descendent"
)
)
)
)
)
)
`when`
( getChildren >>> deep isGroupInterleave
>>>
getChildren >>> deep isRngAttribute
)
),
isRngList :->
( ( deep isRngRelaxError
<+>
( mkRelaxError $<< (getChangesAttr
&&&
( listA ( getChildren
>>>
deep isAttributeRefTextListInterleave
>>>
(getName &&& getChangesAttr >>> arr2 (++))
)
>>>
arr (\n -> formatStringListPatt n ++
"Pattern not allowed as descendent(s) of a list-Pattern")
)
)
)
)
`when`
( getChildren
>>>
deep isAttributeRefTextListInterleave
)
),
isRngData :->
( ( deep isRngRelaxError
<+>
( mkRelaxError $<< (getChangesAttr
&&&
( listA (getChildren
>>>
deep isAttributeRefTextListGroupInterleaveOneOrMoreEmpty
>>>
(getName &&& getChangesAttr >>> arr2 (++))
)
>>>
arr (\n -> formatStringListPatt n ++
"Pattern not allowed as descendent(s) of a data/except-Pattern")
)
)
)
)
`when`
( getChildren
>>>
isRngExcept
>>>
deep isAttributeRefTextListGroupInterleaveOneOrMoreEmpty
)
),
isRngStart :->
( ( deep isRngRelaxError
<+>
( mkRelaxError $<< (getChangesAttr
&&&
( listA (getChildren
>>>
deep (checkElemName [ "attribute", "data", "value", "text", "list",
"group", "interleave", "oneOrMore", "empty"])
>>>
(getName &&& getChangesAttr >>> arr2 (++))
)
>>>
arr (\n -> formatStringListPatt n ++
"Pattern not allowed as descendent(s) of a start-Pattern")
)
)
)
)
`when`
( getChildren
>>>
deep (checkElemName [ "attribute", "data", "value", "text", "list",
"group", "interleave", "oneOrMore", "empty"])
)
),
this :-> this
]
) `when` collectErrors
restrictionsStep3 :: IOSArrow XmlTree XmlTree
restrictionsStep3
= processTopDown
( ( deep isRngRelaxError
<+>
( mkRelaxError "" $<
(
( getChildren >>> isRngName >>> getChildren >>> getText )
>>>
arr (\ n -> ( "Content of element " ++ show n ++ " contains a pattern that can match " ++
"a child and a pattern that matches a single string"
)
)
)
)
)
`when`
( isRngElement
>>>
( getChildren >>. (take 1 . reverse) )
>>>
getContentType >>> isA (== CTNone)
)
) `when` collectErrors
getContentType :: IOSArrow XmlTree ContentType
getContentType
= choiceA
[ isRngValue :-> (constA CTSimple)
, isRngData :-> processData
, isRngList :-> (constA CTSimple)
, isRngText :-> (constA CTComplex)
, isRngRef :-> (constA CTComplex)
, isRngEmpty :-> (constA CTEmpty)
, isRngAttribute :-> processAttribute
, isRngGroup :-> processGroup
, isRngInterleave :-> processInterleave
, isRngOneOrMore :-> processOneOrMore
, isRngChoice :-> processChoice
]
where
processData :: IOSArrow XmlTree ContentType
processData
= ifA (neg (getChildren >>> isRngExcept))
(constA CTSimple)
( getChildren
>>>
isRngExcept
>>>
getChildren
>>>
getContentType
>>>
ifP (/= CTNone) (constA CTSimple) (constA CTNone)
)
processAttribute :: IOSArrow XmlTree ContentType
processAttribute
= ifA ( lastChild
>>>
getContentType
>>>
isA (/= CTNone)
)
(constA CTEmpty)
(constA CTNone)
processGroup :: IOSArrow XmlTree ContentType
processGroup
= get2ContentTypes
>>>
arr2 (\a b -> if isGroupable a b then max a b else CTNone)
processInterleave :: IOSArrow XmlTree ContentType
processInterleave
= get2ContentTypes
>>>
arr2 (\a b -> if isGroupable a b then max a b else CTNone)
processOneOrMore :: IOSArrow XmlTree ContentType
processOneOrMore
= ifA ( getChildren
>>>
getContentType >>> isA (/= CTNone)
>>>
isA (\t -> isGroupable t t)
)
( getChildren >>> getContentType )
( constA CTNone )
processChoice :: IOSArrow XmlTree ContentType
processChoice
= get2ContentTypes
>>>
arr2 max
isGroupable :: ContentType -> ContentType -> Bool
isGroupable CTEmpty _ = True
isGroupable _ CTEmpty = True
isGroupable CTComplex CTComplex = True
isGroupable _ _ = False
checkPattern :: IOSArrow (XmlTree, ([NameClass], [NameClass])) XmlTree
checkPattern
= (\ (_, (a, b)) -> isIn a b) `guardsP` (arr fst)
where
isIn :: [NameClass] -> [NameClass] -> Bool
isIn _ [] = False
isIn [] _ = False
isIn (x:xs) ys = (any (overlap x) ys) || isIn xs ys
occur :: String -> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
occur name fct
= choiceA
[ hasRngElemName name
:->
fct
, isChoiceGroupInterleaveOneOrMore
:->
(getChildren >>> occur name fct)
]
get2ContentTypes :: IOSArrow XmlTree (ContentType, ContentType)
get2ContentTypes
= ( ( firstChild >>> getContentType )
&&&
( lastChild >>> getContentType )
)
restrictionsStep4 :: IOSArrow XmlTree XmlTree
restrictionsStep4
= ( restrictionsStep4' $<
listA ( deep isRngDefine
>>>
( getRngAttrName
&&&
( single ( getChildren
>>>
getChildren
>>>
fromLA createNameClass
)
`orElse`
(constA AnyName)
)
)
)
) `when` collectErrors
restrictionsStep4' :: [(String, NameClass)] -> IOSArrow XmlTree XmlTree
restrictionsStep4' nc =
processTopDown (
(
( deep isRngRelaxError
<+>
( mkRelaxError "" $<
( getRngAttrName
>>>
arr (\ n -> ( "Both attribute-pattern occuring in an " ++
show n ++ " belong to the same name-class"
)
)
)
)
)
`when`
( (isRngGroup `orElse` isRngInterleave)
>>>
( getChildren
&&&
( firstChild
>>>
listA ( occur "attribute" (single getChildren)
>>>
fromLA createNameClass
)
)
&&&
( lastChild
>>>
listA ( occur "attribute" (single getChildren)
>>>
fromLA createNameClass
)
)
)
>>> checkPattern
)
)
>>>
(
( deep isRngRelaxError
<+>
( mkRelaxError ""
( "An attribute that has an anyName or nsName descendant element " ++
"must have a oneOrMore ancestor element"
)
)
)
`when`
(isRngElement >>> checkInfiniteAttribute)
)
>>>
( ( deep isRngRelaxError
<+>
( mkRelaxError ""
( "Both element-pattern occuring in an interleave " ++
"belong to the same name-class"
)
)
)
`when`
( isRngInterleave
>>>
( getChildren
&&&
(firstChild >>> listA (occur "ref" this >>> getRngAttrName))
&&&
(lastChild >>> listA (occur "ref" this >>> getRngAttrName))
)
>>>
checkNames
)
)
>>>
( ( deep isRngRelaxError
<+>
( mkRelaxError "" "A text pattern must not occur in both children of an interleave" )
)
`when`
(isRngInterleave >>> checkText)
)
)
where
checkInfiniteAttribute :: IOSArrow XmlTree XmlTree
checkInfiniteAttribute
= getChildren
>>>
choiceA
[ isRngOneOrMore :-> none
, ( isRngAttribute
>>>
deep (isRngAnyName `orElse` isRngNsName)
) :-> this
, this :-> checkInfiniteAttribute
]
checkNames :: IOSArrow (XmlTree, ([String], [String])) XmlTree
checkNames = (arr fst)
&&&
(arr (\(_, (a, _)) -> getNameClasses nc a))
&&&
(arr (\(_, (_, b)) -> getNameClasses nc b))
>>>
checkPattern
where
getNameClasses :: [(String, NameClass)] -> [String] -> [NameClass]
getNameClasses nc' l = map (\x -> fromJust $ lookup x nc') l
checkText :: IOSArrow XmlTree XmlTree
checkText
= ( firstChild >>> occur "text" this )
`guards`
( lastChild >>> occur "text" this )
overlap :: NameClass -> NameClass -> Bool
overlap nc1 nc2
= any (bothContain nc1 nc2) (representatives nc1 ++ representatives nc2)
bothContain :: NameClass -> NameClass -> QName -> Bool
bothContain nc1 nc2 qn
= contains nc1 qn && contains nc2 qn
illegalLocalName :: LocalName
illegalLocalName = ""
illegalUri :: Uri
illegalUri = "\x1"
representatives :: NameClass -> [QName]
representatives AnyName
= [mkQName "" illegalLocalName illegalUri]
representatives (AnyNameExcept nc)
= (mkQName "" illegalLocalName illegalUri) : (representatives nc)
representatives (NsName ns)
= [mkQName "" illegalLocalName ns]
representatives (NsNameExcept ns nc)
= (mkQName "" illegalLocalName ns) : (representatives nc)
representatives (Name ns ln)
= [mkQName "" ln ns]
representatives (NameClassChoice nc1 nc2)
= (representatives nc1) ++ (representatives nc2)
representatives _
= []
resetStates :: IOSArrow XmlTree XmlTree
resetStates
= ( perform (constA 0 >>> setSysVar theRelaxDefineId)
>>>
perform (constA 0 >>> setSysVar theRelaxNoOfErrors)
>>>
perform (constA [] >>> setRelaxParam "elementTable" )
)
getAllDeepDefines :: IOSArrow XmlTree Env
getAllDeepDefines
= listA $ deep isRngDefine
>>>
( getRngAttrName &&& this )
createUniqueNames :: IOSArrow [String] RefList
createUniqueNames
= createUnique $< incrSysVar theRelaxDefineId
where
createUnique num
= arr (unique num)
>>>
( this
***
perform (setSysVar theRelaxDefineId)
)
>>>
arr fst
where
unique :: Int -> [String] -> (RefList, Int)
unique n0 l
= ( zipWith (\ x n -> (x, show n)) l [n0 ..]
, n0 + length l
)
getRefsFromStartPattern :: IOSArrow XmlTree [String]
getRefsFromStartPattern
= listA
( getChildren
>>>
isRngGrammar
>>>
getChildren
>>>
isRngStart
>>>
deep isRngRef
>>>
getRngAttrName
)
removeUnreachableDefines :: Env -> [String] -> [String] -> IOSArrow XmlTree XmlTree
removeUnreachableDefines allDefs processedDefs reachableDefs
= ifP (const $ unprocessedDefs /= [])
( removeUnreachableDefines allDefs (nextTreeName : processedDefs) $< newReachableDefs )
( processChildren $
processChildren $
( none
`when`
( isRngDefine
>>>
getRngAttrName
>>>
isA (\n -> not $ elem n reachableDefs)
)
)
)
where
unprocessedDefs :: [String]
unprocessedDefs
= reachableDefs \\ processedDefs
newReachableDefs :: IOSArrow n [String]
newReachableDefs
= constA getTree
>>>
listA ( deep isRngRef
>>>
getRngAttrName
)
>>>
arr (noDoubles . (reachableDefs ++))
getTree :: XmlTree
getTree
= fromJust $ lookup nextTreeName allDefs
nextTreeName :: String
nextTreeName
= head unprocessedDefs
checkElemName :: [String] -> IOSArrow XmlTree XmlTree
checkElemName l
= ( isElem >>> getLocalPart >>> isA (\s -> elem s l) )
`guards`
this
wrapPattern2Two :: (ArrowXml a) => QName -> a XmlTree XmlTree
wrapPattern2Two name
= choiceA
[ noOfChildren (> 2)
:-> ( replaceChildren ( (mkElement name none
(getChildren >>. take 2)
)
<+>
(getChildren >>. drop 2)
)
>>>
wrapPattern2Two name
)
, noOfChildren (== 1)
:-> getChildren
, this
:-> this
]
(!>>>) :: IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
f !>>> g
= f
>>>
ifA (getSysVar theRelaxNoOfErrors >>> isA (> 0))
this
g
mkRelaxError :: String -> String -> IOSArrow n XmlTree
mkRelaxError changesStr errStr
= perform (constA 1 >>> chgSysVar theRelaxNoOfErrors (+))
>>>
mkRngRelaxError
>>>
addRngAttrDescr errStr
>>>
( if null changesStr
then this
else addRngAttrChanges changesStr
)
collectErrors :: IOSArrow XmlTree XmlTree
collectErrors
= none
`when`
( (getSysVar theRelaxCollectErrors >>> isA not)
>>>
errorsFound
)
errorsFound :: IOSArrow a a
errorsFound
= ( getSysVar theRelaxNoOfErrors >>> isA (> 0) )
`guards`
this
getErrors :: IOSArrow XmlTree XmlTree
getErrors = errorsFound
`guards`
multi isRngRelaxError
setChangesAttr :: String -> IOSArrow XmlTree XmlTree
setChangesAttr str
= ifA (hasRngAttrRelaxSimplificationChanges)
( processAttrl $
changeAttrValue (++ (", " ++ str))
`when`
isRngAttrRelaxSimplificationChanges
)
(mkRngAttrRelaxSimplificationChanges str)
getChangesAttr :: IOSArrow XmlTree String
getChangesAttr
= getAttrValue a_relaxSimplificationChanges
&&&
getSysAttr a_output_changes
>>>
ifP (\(changes, param) -> changes /= "" && param == "1")
(arr2 $ \l _ -> " (" ++ l ++ ")")
(constA "")
createSimpleForm :: Bool -> Bool -> Bool -> IOSArrow XmlTree XmlTree
createSimpleForm checkRestrictions validateExternalRef validateInclude
= traceMsg 2 ("createSimpleForm: " ++ show (checkRestrictions,validateExternalRef, validateInclude))
>>>
( if checkRestrictions
then createSimpleWithRest
else createSimpleWithoutRest
)
where
createSimpleWithRest :: IOSArrow XmlTree XmlTree
createSimpleWithRest
= foldr (!>>>) this $
concat [ return $ traceDoc "relax NG: simplificationPart1 starts"
, simplificationPart1
, return $ traceDoc "relax NG: simplificationPart1 done"
, restrictionsPart1
, return $ traceDoc "relax NG: restrictionsPart1 done"
, simplificationPart2
, return $ traceDoc "relax NG simplificationPart2 done"
, restrictionsPart2
, return $ traceDoc "relax NG: restrictionsPart2 done"
, finalCleanUp
, return $ traceDoc "relax NG: finalCleanUp done"
]
createSimpleWithoutRest :: IOSArrow XmlTree XmlTree
createSimpleWithoutRest
= foldr (!>>>) this $
concat [ simplificationPart1
, simplificationPart2
, finalCleanUp
]
simplificationPart1 :: [IOSArrow XmlTree XmlTree]
simplificationPart1
= [ simplificationStep1
, simplificationStep2 validateExternalRef validateInclude [] []
, simplificationStep3
, simplificationStep4
]
simplificationPart2 :: [IOSArrow XmlTree XmlTree]
simplificationPart2
= [ simplificationStep5
, simplificationStep6
, simplificationStep7
, simplificationStep8
]
restrictionsPart1 :: [IOSArrow XmlTree XmlTree]
restrictionsPart1
= [ restrictionsStep1 ]
restrictionsPart2 :: [IOSArrow XmlTree XmlTree]
restrictionsPart2
= [ restrictionsStep2
, restrictionsStep3
, restrictionsStep4
]
finalCleanUp :: [IOSArrow XmlTree XmlTree]
finalCleanUp
= [ cleanUp
]
cleanUp :: IOSArrow XmlTree XmlTree
cleanUp = processTopDown $
removeAttr a_relaxSimplificationChanges
>>>
removeAttr defineOrigName
setRelaxParam :: String -> IOStateArrow s XmlTrees XmlTree
setRelaxParam n = chgSysVar theRelaxAttrList (addEntry n)
>>>
arrL id
getRelaxParam :: String -> IOStateArrow s b XmlTree
getRelaxParam n = getSysVar theRelaxAttrList
>>>
arrL (lookup1 n)