module Text.XML.HXT.RelaxNG.CreatePattern
( createPatternFromXmlTree
, createNameClass
, firstChild
, lastChild
, module Text.XML.HXT.RelaxNG.PatternFunctions
)
where
import Control.Arrow.ListArrows
import Text.XML.HXT.DOM.Interface
import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.RelaxNG.DataTypes
import Text.XML.HXT.RelaxNG.BasicArrows
import Text.XML.HXT.RelaxNG.PatternFunctions
import Data.Maybe
( fromMaybe )
import Data.List
( isPrefixOf )
createPatternFromXmlTree :: LA XmlTree Pattern
createPatternFromXmlTree = createPatternFromXml $< createEnv
where
createEnv :: LA XmlTree Env
createEnv = listA $ deep isRngDefine
>>>
(getRngAttrName &&& getChildren)
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 ""
]
processRoot :: Env -> LA XmlTree Pattern
processRoot env
= getChildren
>>>
choiceA [
isRngRelaxError :-> (mkRelaxError $< getRngAttrDescr),
isRngGrammar :-> (processGrammar env),
this :-> (mkRelaxError "no grammar-pattern in schema")
]
processGrammar :: Env -> LA XmlTree Pattern
processGrammar env
= getChildren
>>>
choiceA [
isRngDefine :-> none,
isRngRelaxError :-> (mkRelaxError $< getAttrValue "desc"),
isRngStart :-> (getChildren >>> createPatternFromXml env),
this :-> (mkRelaxError "no start-pattern in schema")
]
mkRelaxRef :: Env -> LA XmlTree Pattern
mkRelaxRef e
= getRngAttrName
>>>
arr (\n -> fromMaybe (notAllowed $ "define-pattern with name " ++ n ++ " not found")
. lookup n $ transformEnv e
)
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
mkNotAllowed :: LA XmlTree Pattern
mkNotAllowed = constA $ notAllowed "notAllowed-pattern in Relax NG schema definition"
mkRelaxError :: String -> LA XmlTree Pattern
mkRelaxError errStr
= choiceA [
isRngRelaxError :-> (getRngAttrDescr >>> arr notAllowed),
isElem :-> ( getName
>>>
arr (\n -> notAllowed $ "Pattern " ++ n ++
" is not allowed in Relax NG schema"
)
),
isAttr :-> ( getName
>>>
arr (\n -> notAllowed $ "Attribute " ++ n ++
" is not allowed in Relax NG schema"
)
),
isError :-> (getErrorMsg >>> arr notAllowed),
this :-> (arr (\e -> notAllowed $ if errStr /= ""
then errStr
else "Can't create pattern from " ++ show e)
)
]
mkRelaxChoice :: Env -> LA XmlTree Pattern
mkRelaxChoice env
= ifA ( getChildren >>.
( \ l -> if length l == 1 then l else [] )
)
( createPatternFromXml env )
( getTwoChildrenPattern env >>> arr2 Choice )
mkRelaxInterleave :: Env -> LA XmlTree Pattern
mkRelaxInterleave env
= getTwoChildrenPattern env
>>>
arr2 Interleave
mkRelaxGroup :: Env -> LA XmlTree Pattern
mkRelaxGroup env
= getTwoChildrenPattern env
>>>
arr2 Group
mkRelaxOneOrMore :: Env -> LA XmlTree Pattern
mkRelaxOneOrMore env
= getOneChildPattern env
>>>
arr OneOrMore
mkRelaxList :: Env -> LA XmlTree Pattern
mkRelaxList env
= getOneChildPattern env
>>>
arr List
mkRelaxData :: Env -> LA XmlTree Pattern
mkRelaxData env
= ifA (getChildren >>> isRngExcept)
(processDataExcept >>> arr3 DataExcept)
(processData >>> arr2 Data)
where
processDataExcept :: LA XmlTree (Datatype, (ParamList, Pattern))
processDataExcept = getDatatype &&& getParamList &&&
( getChildren
>>>
isRngExcept
>>>
getChildren
>>>
createPatternFromXml env
)
processData :: LA XmlTree (Datatype, ParamList)
processData = getDatatype &&& getParamList
getParamList :: LA XmlTree ParamList
getParamList = listA $ getChildren
>>>
isRngParam
>>>
(getRngAttrName &&& (getChildren >>> getText))
mkRelaxValue :: LA XmlTree Pattern
mkRelaxValue = getDatatype &&& getValue &&& getContext
>>>
arr3 Value
where
getContext :: LA XmlTree Context
getContext = getAttrValue contextBaseAttr &&& getMapping
getMapping :: LA XmlTree [(Prefix, Uri)]
getMapping = listA $ getAttrl >>>
( (getName >>> isA (contextAttributes `isPrefixOf`))
`guards`
( (getName >>> arr (drop $ length contextAttributes))
&&&
(getChildren >>> getText)
)
)
getValue :: LA XmlTree String
getValue = (getChildren >>> getText) `orElse` (constA "")
getDatatype :: LA XmlTree Datatype
getDatatype = getRngAttrDatatypeLibrary
&&&
getRngAttrType
mkRelaxAttribute :: Env -> LA XmlTree Pattern
mkRelaxAttribute env
= ( ( firstChild >>> createNameClass )
&&&
( lastChild >>> createPatternFromXml env )
)
>>>
arr2 Attribute
mkRelaxElement :: Env -> LA XmlTree Pattern
mkRelaxElement env
= ( ( firstChild >>> createNameClass )
&&&
( lastChild >>> createPatternFromXml env )
)
>>>
arr2 Element
createNameClass :: LA XmlTree NameClass
createNameClass
= choiceA
[ isRngAnyName :-> processAnyName
, isRngNsName :-> processNsName
, isRngName :-> processName
, isRngChoice :-> processChoice
, this :-> mkNameClassError
]
where
processAnyName :: LA XmlTree NameClass
processAnyName
= ifA (getChildren >>> isRngExcept)
( getChildren
>>> getChildren
>>> createNameClass
>>> arr AnyNameExcept
)
( constA AnyName )
processNsName :: LA XmlTree NameClass
processNsName
= ifA (getChildren >>> isRngExcept)
( ( getRngAttrNs
&&&
( getChildren >>> getChildren >>> createNameClass )
)
>>>
arr2 NsNameExcept
)
( getRngAttrNs >>> arr NsName )
processName :: LA XmlTree NameClass
processName
= (getRngAttrNs &&& (getChildren >>> getText)) >>> arr2 Name
processChoice :: LA XmlTree NameClass
processChoice
= ( ( firstChild >>> createNameClass )
&&&
( lastChild >>> createNameClass )
)
>>>
arr2 NameClassChoice
mkNameClassError :: LA XmlTree NameClass
mkNameClassError
= choiceA [ isRngRelaxError
:-> ( getRngAttrDescr
>>>
arr NCError
)
, isElem :-> ( getName
>>>
arr (\n -> NCError ("Can't create name class from element " ++ n))
)
, isAttr :-> ( getName
>>>
arr (\n -> NCError ("Can't create name class from attribute: " ++ n))
)
, isError :-> ( getErrorMsg
>>>
arr NCError
)
, this :-> ( arr (\e -> NCError $ "Can't create name class from " ++ show e) )
]
getOneChildPattern :: Env -> LA XmlTree Pattern
getOneChildPattern env
= firstChild >>> createPatternFromXml env
getTwoChildrenPattern :: Env -> LA XmlTree (Pattern, Pattern)
getTwoChildrenPattern env
= ( getOneChildPattern env )
&&&
( lastChild >>> createPatternFromXml env )
firstChild :: (ArrowTree a, Tree t) => a (t b) (t b)
firstChild = single getChildren
lastChild :: (ArrowTree a, Tree t) => a (t b) (t b)
lastChild = getChildren >>. (take 1 . reverse)