module Text.XML.HXT.RelaxNG.Simplification
( createSimpleForm
, getErrors
)
where
import Control.Arrow.ListArrows
import Text.XML.HXT.DOM.Interface
import qualified Text.XML.HXT.DOM.XmlNode as XN
( mkAttr
, mkText
)
import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.Arrow.XmlIOStateArrow
import Text.XML.HXT.Arrow.Namespace
( processWithNsEnv
, propagateNamespaces
)
import Text.XML.HXT.Arrow.Edit
( removeWhiteSpace
)
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
, isNothing
)
import Data.List
( elemIndices
, isPrefixOf
, nub
, deleteBy
, find
, (\\)
)
import System.Directory
( doesFileExist )
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)
>>>
getRngAttrName
>>>
isA (elem ':')
)
)
>>>
( (addAttrl (getBaseURI >>> createAttrL))
`when`
isRngValue
)
)
where
createAttrL :: IOSArrow String XmlTree
createAttrL
= setBaseUri &&& constA (map createAttr env) >>> arr2L (:)
where
createAttr :: (XName, XName) -> XmlTree
createAttr (pre, uri)
= XN.mkAttr (mkName nm) [XN.mkText (show uri)]
where
nm | isNullXName pre = "RelaxContextDefault"
| otherwise = contextAttributes ++ show pre
setBaseUri :: IOSArrow String XmlTree
setBaseUri = mkAttr (mkName contextBaseAttr) (txt $< this)
replaceQNames :: NsEnv -> String -> IOSArrow XmlTree XmlTree
replaceQNames e name
| isNothing uri
= mkRelaxError "" ( "No Namespace-Mapping for the prefix " ++ show pre ++
" in the Context of Element: " ++ show name
)
| otherwise
= addAttr "name" ( "{" ++ (show . fromJust $ uri) ++ "}" ++ local )
where
(pre, local') = span (/= ':') name
local = tail local'
uri :: Maybe XName
uri = lookup (newXName pre) e
processdatatypeLib :: (ArrowXml a) => String -> a XmlTree XmlTree
processdatatypeLib lib
= processChildren $
choiceA
[ ( isElem >>> hasRngAttrDatatypeLibrary
)
:->
( processdatatypeLib $< getRngAttrDatatypeLibrary )
, ( (isRngData `orElse` isRngValue)
>>>
neg hasRngAttrDatatypeLibrary
)
:->
( addAttr "datatypeLibrary" lib >>> processdatatypeLib lib )
, this
:->
processdatatypeLib lib
]
simplificationStep2 :: Attributes -> Bool -> Bool -> [Uri] -> [Uri] -> IOSArrow XmlTree XmlTree
simplificationStep2 readOptions 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
= ifA ( neg $ constA href
>>> getPathFromURI
>>> ( isA (not . ("illegal URI" `isPrefixOf`))
`guards`
isIOA doesFileExist
)
)
( mkRelaxError ""
( show href ++
": can't read URI, referenced in externalRef-Pattern"
)
)
( ifP (const $ elem href extHRefs)
( mkRelaxError ""
( "loop in externalRef-Pattern, " ++
formatStringListArr (reverse $ href:extHRefs)
)
)
( ifA ( if validateExternalRef
then validateDocWithRelax S.relaxSchemaArrow [] href
else none
)
( mkRelaxError ""
( "The content of the schema " ++ show href ++
", referenced in externalRef does not " ++
"match the syntax for pattern"
)
)
( readForRelax readOptions href
>>>
simplificationStep1
>>>
simplificationStep2 readOptions validateExternalRef validateInclude (href:extHRefs) includeHRefs
>>>
getChildren
>>>
(
addAttr "ns" ns
`when`
(getRngAttrNs >>> isA (\a -> a == "" && ns /= ""))
)
)
)
)
importInclude :: String -> IOSArrow XmlTree XmlTree
importInclude href
= ifA (
neg $ constA href >>> getPathFromURI >>> isIOA doesFileExist
)
( mkRelaxError ""
( "Can't read " ++ show href ++
", referenced in include-Pattern"
)
)
( ifP (const $ elem href includeHRefs)
( mkRelaxError ""
( "loop in include-Pattern, " ++
formatStringListArr (reverse $ href:includeHRefs)
)
)
( ifA ( if validateInclude
then validateDocWithRelax SG.relaxSchemaArrow [] href
else none
)
( mkRelaxError ""
( "The content of the schema " ++ show href ++
", referenced in include does not match " ++
"the syntax for grammar"
)
)
( processInclude href $< ( readForRelax readOptions href
>>>
simplificationStep1
>>>
simplificationStep2 readOptions validateExternalRef validateInclude extHRefs (href:includeHRefs)
>>>
getChildren
)
)
)
)
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 (addAttr "ns" "" `when` isRngName))
`when`
(isRngAttribute >>> hasRngAttrName >>> neg hasRngAttrNs)
)
>>>
removeAttr "name"
)
`when`
( (isRngElement `orElse` isRngAttribute) >>> hasRngAttrName )
)
>>>
processnsAttribute ""
>>>
processTopDown (
(
(removeAttr "ns")
`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
= (addAttr "ns" pre >>> processChildren (changeText $ const local))
`whenP`
(const $ elem '}' name)
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)
:-> (addAttr "ns" 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 $< getName) >>> 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))
)
>>>
( combinePatternList "define" $< (getPatternNamesInGrammar "define" >>> arr nub) )
>>>
( combinePatternList "start" $< (getPatternNamesInGrammar "start" >>> arr nub) )
)
`when`
isRngGrammar
)
>>>
(
( replaceChildren
( mkRngGrammar none
( mkRngStart none getChildren )
)
)
`when`
neg (getChildren >>> isRngGrammar)
)
>>>
( renameDefines $<<
( getPatternNamesInGrammar "define"
>>>
(createUniqueNames $< (getAndSetCounter "define_id" >>> arr read))
&&&
constA []
)
)
>>>
( processChildren
(
processChildren
(
( deleteAllDefines
<+>
( getAllDefines >>> processChildren deleteAllDefines )
)
>>>
processTopDown
( (
( getChildren >>> isRngStart >>> getChildren )
`when`
isRngGrammar
)
>>>
(
( setRngNameRef
`when`
isRngParentRef
)
)
)
)
)
)
) `when` collectErrors
where
getPatternNamesInGrammar :: (ArrowXml a) => String -> a XmlTree [String]
getPatternNamesInGrammar pattern
= processChildren
( processTopDown ( none `when` isRngGrammar ) )
>>>
listA ( (multi (isElem >>> hasRngName pattern))
>>>
getRngAttrName
)
createUniqueNames :: Int -> IOSArrow [String] RefList
createUniqueNames num
= arr (\ l -> unique l num)
>>>
perform (setParamInt "define_id" $< arr (max num . getNextValue))
where
unique :: [String] -> Int -> RefList
unique [] _ = []
unique (x:xs) num' = (x, (show num')):(unique xs (num'+1))
getNextValue :: RefList -> Int
getNextValue [] = 0
getNextValue rl = maximum (map (read . snd) rl) + 1
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 $< (getParamInt 0 "define_id"))
)
&&&
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
combinePatternList :: String -> [String] -> IOSArrow XmlTree XmlTree
combinePatternList _ [] = this
combinePatternList pattern (x:xs)
= (replaceChildren $ combinePattern pattern x)
>>>
combinePatternList pattern xs
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
)
&&&
(listA (getElems pattern name >>> removeAttr "combine")))
>>>
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 (mkAttr (mkName "name") (txt name))
( ( mkRngElement combine none
(arrL (const trees) >>> getChildren)
)
>>>
wrapPattern2Two combine
)
checkPatternCombine :: (ArrowXml a) => String -> String -> a [String] (Int, String)
checkPatternCombine pattern name
= choiceA
[
(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"
)
)
,
this
:->
arr (\ cl -> (1, fromJust $ find (/= "") cl))
]
isElemWithNameValue :: (ArrowXml a) => String -> String -> a XmlTree XmlTree
isElemWithNameValue ename nvalue
= ( isElem
>>>
hasRngName 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 )
]
simplificationStep6 :: IOSArrow XmlTree XmlTree
simplificationStep6 =
(
(removeUnreachableDefines $<<< getAllDeepDefines
&&&
constA []
&&&
getRefsFromStartPattern
)
>>>
( processElements False
>>>
processChildren (insertChildrenAt 1 (getParam "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' $<< ( getAndSetCounter "define_id"
&&&
getDefineName
)
)
)
, isRngDefine
:-> processElements True
, this
:-> processElements False
])
where
getDefineName :: IOSArrow XmlTree String
getDefineName
= firstChild
>>>
fromLA createNameClass
>>>
arr show
processElements' :: NewName -> OldName -> IOSArrow XmlTree XmlTree
processElements' name oldname
= storeElement name oldname
>>>
mkRngRef (createAttr name oldname) none
storeElement :: NewName -> OldName -> IOSArrow XmlTree XmlTree
storeElement name oldname
= perform $
( mkRngDefine
(createAttr name oldname) (processElements False)
)
&&&
(listA $ getParam "elementTable")
>>>
arr2 (:)
>>>
setParamList "elementTable"
createAttr :: NewName -> OldName -> IOSArrow XmlTree XmlTree
createAttr name oldname
= mkAttr (mkName "name") (txt name)
<+>
mkAttr (mkName defineOrigName) (txt $ "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
= getParamInt 0 "rng:changeTree"
>>>
isA (== 1)
markTreeChanged :: Int -> IOSArrow b b
markTreeChanged i
= perform (setParamInt "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
[ ( isElem >>> hasRngName 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 $ setParamInt "define_id" 0)
>>>
perform (constA [] >>> setParamList "elementTable" )
>>>
perform (constA $ setParamInt a_numberOfErrors 0)
)
getAllDeepDefines :: IOSArrow XmlTree Env
getAllDeepDefines
= listA $ deep isRngDefine
>>>
( getRngAttrName &&& this )
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) => String -> a XmlTree XmlTree
wrapPattern2Two name
= choiceA
[ noOfChildren (> 2)
:-> ( replaceChildren ( (mkRngElement name none
(getChildren >>. take 2)
)
<+>
(getChildren >>. drop 2)
)
>>>
wrapPattern2Two name
)
, noOfChildren (== 1)
:-> getChildren
, this
:-> this
]
mkRelaxError :: String -> String -> IOSArrow n XmlTree
mkRelaxError changesStr errStr
= perform (getAndSetCounter a_numberOfErrors)
>>>
mkRngRelaxError none none
>>>
addAttr "desc" errStr
>>>
( addAttr "changes" changesStr
`whenP`
(const $ changesStr /= "")
)
collectErrors :: IOSArrow XmlTree XmlTree
collectErrors
= none
`when`
( stopAfterFirstError
>>>
getParamInt 0 a_numberOfErrors >>> isA (>0)
)
where
stopAfterFirstError = getParamString a_do_not_collect_errors
>>>
isA (== "1")
getErrors :: IOSArrow XmlTree XmlTree
getErrors = (getParamInt 0 a_numberOfErrors >>> isA (>0))
`guards`
(root [] [multi isRngRelaxError])
setChangesAttr :: String -> IOSArrow XmlTree XmlTree
setChangesAttr str
= ifA (hasAttr a_relaxSimplificationChanges)
( processAttrl $
changeAttrValue (++ (", " ++ str))
`when`
(hasRngName a_relaxSimplificationChanges)
)
(mkAttr (mkName a_relaxSimplificationChanges) (txt str))
getChangesAttr :: IOSArrow XmlTree String
getChangesAttr
= getAttrValue a_relaxSimplificationChanges
&&&
getParamString a_output_changes
>>>
ifP (\(changes, param) -> changes /= "" && param == "1")
(arr2 $ \l _ -> " (" ++ l ++ ")")
(constA "")
getAndSetCounter :: String -> IOSArrow b String
getAndSetCounter name
= genNewId $< getParamInt 0 name
where
genNewId :: Int -> IOSArrow b String
genNewId i = setParamInt name (i+1) >>> constA (show i)
createSimpleForm :: Attributes -> Bool -> Bool -> Bool -> IOSArrow XmlTree XmlTree
createSimpleForm remainingOptions checkRestrictions validateExternalRef validateInclude
= traceMsg 2 ("createSimpleForm: " ++ show (remainingOptions, checkRestrictions,validateExternalRef, validateInclude))
>>>
( if checkRestrictions
then createSimpleWithRest
else createSimpleWithoutRest
)
where
createSimpleWithRest :: IOSArrow XmlTree XmlTree
createSimpleWithRest
= seqA $ concat [ 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
= seqA $ concat [ simplificationPart1
, simplificationPart2
, finalCleanUp
]
simplificationPart1 :: [IOSArrow XmlTree XmlTree]
simplificationPart1
= [ propagateNamespaces
, simplificationStep1
, simplificationStep2 remainingOptions 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
, resetStates
]
cleanUp :: IOSArrow XmlTree XmlTree
cleanUp = processTopDown $
removeAttr a_relaxSimplificationChanges
>>>
removeAttr defineOrigName