module Text.XML.HXT.RelaxNG.PatternToString
( patternToStringTree
, patternToFormatedString
, xmlTreeToPatternStringTree
, xmlTreeToPatternFormatedString
, xmlTreeToPatternString
, nameClassToString
)
where
import Control.Arrow.ListArrows
import Data.Tree.NTree.TypeDefs
import Text.XML.HXT.DOM.Interface
import Text.XML.HXT.RelaxNG.DataTypes
import Text.XML.HXT.RelaxNG.CreatePattern
import Text.XML.HXT.RelaxNG.Utils
type PatternTree = NTree String
xmlTreeToPatternString :: LA XmlTree String
xmlTreeToPatternString
= createPatternFromXmlTree
>>^
show
nameClassToString :: NameClass -> String
nameClassToString AnyName
= "AnyName"
nameClassToString (AnyNameExcept nc)
= "AnyNameExcept " ++ nameClassToString nc
nameClassToString (Name uri local)
= "{" ++ uri ++ "}" ++ local
nameClassToString (NsName uri)
= "{" ++ uri ++ "}"
nameClassToString (NsNameExcept uri nc)
= uri ++ "except (NsName) " ++ nameClassToString nc
nameClassToString (NameClassChoice nc1 nc2)
= nameClassToString nc1 ++ " " ++ nameClassToString nc2
nameClassToString (NCError e)
= "NameClass Error: " ++ e
patternToStringTree :: LA Pattern String
patternToStringTree
= fromSLA [] pattern2PatternTree
>>^
(\p -> formatTree id p ++ "\n")
xmlTreeToPatternStringTree :: LA XmlTree String
xmlTreeToPatternStringTree
= createPatternFromXmlTree
>>>
patternToStringTree
pattern2PatternTree :: SLA [NameClass] Pattern PatternTree
pattern2PatternTree
= choiceA
[ isA isRelaxEmpty :-> (constA $ NTree "empty" [])
, isA isRelaxNotAllowed :-> notAllowed2PatternTree
, isA isRelaxText :-> (constA $ NTree "text" [])
, isA isRelaxChoice :-> choice2PatternTree
, isA isRelaxInterleave :-> children2PatternTree "interleave"
, isA isRelaxGroup :-> children2PatternTree "group"
, isA isRelaxOneOrMore :-> children2PatternTree "oneOrMore"
, isA isRelaxList :-> children2PatternTree "list"
, isA isRelaxData :-> data2PatternTree
, isA isRelaxDataExcept :-> dataExcept2PatternTree
, isA isRelaxValue :-> value2PatternTree
, isA isRelaxAttribute :-> createPatternTreeFromElement "attribute"
, isA isRelaxElement :-> element2PatternTree
, isA isRelaxAfter :-> children2PatternTree "after"
]
notAllowed2PatternTree :: SLA [NameClass] Pattern PatternTree
notAllowed2PatternTree
= arr $ \(NotAllowed (ErrMsg _l sl)) -> NTree "notAllowed" $ map (\ s -> NTree s []) sl
data2PatternTree :: SLA [NameClass] Pattern PatternTree
data2PatternTree
= arr $ \ (Data d p) -> NTree "data" [ datatype2PatternTree d
, mapping2PatternTree "parameter" p
]
dataExcept2PatternTree :: SLA [NameClass] Pattern PatternTree
dataExcept2PatternTree
= this &&& (listA $ arrL getChildrenPattern >>> pattern2PatternTree)
>>>
arr2 ( \ (DataExcept d param _) pattern ->
NTree "dataExcept" ([ datatype2PatternTree d
, mapping2PatternTree "parameter" param
] ++ pattern)
)
value2PatternTree :: SLA [NameClass] Pattern PatternTree
value2PatternTree
= arr $ \ (Value d v c) -> NTree ("value = " ++ v) [ datatype2PatternTree d
, context2PatternTree c
]
createPatternTreeFromElement :: String -> SLA [NameClass] Pattern PatternTree
createPatternTreeFromElement name
= ( arr getNameClassFromPattern
&&&
listA (arrL getChildrenPattern >>> pattern2PatternTree)
)
>>>
arr2 (\nc rl -> NTree (name ++ " " ++ show nc) rl)
children2PatternTree :: String -> SLA [NameClass] Pattern PatternTree
children2PatternTree name
= listA (arrL getChildrenPattern >>> pattern2PatternTree)
>>^
(NTree name)
choice2PatternTree :: SLA [NameClass] Pattern PatternTree
choice2PatternTree
= ifA (
arr (last . getChildrenPattern) >>> isA (isRelaxElement) >>>
(arr getNameClassFromPattern &&& getState) >>>
isA(\ (nc, liste) -> not $ elem nc liste)
)
(
arr getChildrenPattern
>>>
changeState (\s p -> (getNameClassFromPattern (last p)) : s)
>>>
( ( head ^>> pattern2PatternTree )
&&&
( last ^>> createPatternTreeFromElement "element" )
)
>>>
arr2 ( \ l1 l2 -> NTree "choice" [l1, l2] )
)
( children2PatternTree "choice" )
element2PatternTree :: SLA [NameClass] Pattern PatternTree
element2PatternTree
= ifA ( (arr getNameClassFromPattern &&& getState)
>>>
isA (\ (nc, liste) -> elem nc liste)
)
( arr getNameClassFromPattern
>>>
arr (\nc -> NTree ("reference to element " ++ show nc) [])
)
( changeState (\ s p -> (getNameClassFromPattern p) : s)
>>>
createPatternTreeFromElement "element"
)
mapping2PatternTree :: String -> [(Prefix, Uri)] -> PatternTree
mapping2PatternTree name mapping
= NTree name (map (\(a, b) -> NTree (a ++ " = " ++ b) []) mapping)
datatype2PatternTree :: Datatype -> PatternTree
datatype2PatternTree dt
= NTree (datatype2String dt) []
context2PatternTree :: Context -> PatternTree
context2PatternTree (base, mapping)
= NTree "context" [ NTree ("base-uri = " ++ base) []
, mapping2PatternTree "namespace environment" mapping
]
xmlTreeToPatternFormatedString :: LA XmlTree String
xmlTreeToPatternFormatedString
= createPatternFromXmlTree
>>>
fromSLA [] patternToFormatedString
patternToFormatedString :: SLA [NameClass] Pattern String
patternToFormatedString
= choiceA
[ isA isRelaxEmpty :-> (constA " empty ")
, isA isRelaxNotAllowed :-> (arr $ \ (NotAllowed errorEnv) -> show errorEnv)
, isA isRelaxText :-> (constA " text ")
, isA isRelaxChoice :-> children2FormatedString "choice"
, isA isRelaxInterleave :-> children2FormatedString "interleave"
, isA isRelaxGroup :-> children2FormatedString "group"
, isA isRelaxOneOrMore :-> children2FormatedString "oneOrMore"
, isA isRelaxList :-> children2FormatedString "list"
, isA isRelaxData :-> data2FormatedString
, isA isRelaxDataExcept :-> dataExcept2FormatedString
, isA isRelaxValue :-> value2FormatedString
, isA isRelaxAttribute :-> createFormatedStringFromElement "attribute"
, isA isRelaxElement :-> element2FormatedString
, isA isRelaxAfter :-> children2FormatedString "after"
]
children2FormatedString :: String -> SLA [NameClass] Pattern String
children2FormatedString name
= listA (arrL getChildrenPattern >>> patternToFormatedString)
>>^
(\ l -> name ++ " (" ++ formatStringListPatt l ++ ") " )
data2FormatedString :: SLA [NameClass] Pattern String
data2FormatedString
= arr ( \ (Data datatype paramList) ->
"Data " ++ datatype2String datatype ++ "\n " ++
mapping2String "parameter" paramList ++ "\n"
)
dataExcept2FormatedString :: SLA [NameClass] Pattern String
dataExcept2FormatedString
= arr ( \ (DataExcept datatype paramList _) ->
"DataExcept " ++ show datatype ++ "\n " ++
mapping2String "parameter" paramList ++ "\n "
)
&&&
( arr (\ (DataExcept _ _ p) -> p) >>> patternToFormatedString )
>>>
arr2 (++)
value2FormatedString :: SLA [NameClass] Pattern String
value2FormatedString
= arr $ \(Value datatype val context) ->
"Value = " ++ val ++ ", " ++ datatype2String datatype ++
"\n " ++ context2String context ++ "\n"
element2FormatedString :: SLA [NameClass] Pattern String
element2FormatedString
= ifA ( (arr getNameClassFromPattern &&& getState)
>>>
isA (\ (nc, liste) -> elem nc liste)
)
( arr getNameClassFromPattern
>>^
( \nc -> "reference to element " ++ nameClassToString nc ++ " " )
)
( changeState (\ s p -> (getNameClassFromPattern p) : s)
>>>
createFormatedStringFromElement "element"
)
createFormatedStringFromElement :: String -> SLA [NameClass] Pattern String
createFormatedStringFromElement name
= ( arr getNameClassFromPattern
&&&
( listA (arrL getChildrenPattern >>> patternToFormatedString)
>>^
formatStringListId
)
)
>>>
arr2 (\ nc rl -> name ++ " " ++ nameClassToString nc ++ " (" ++ rl ++ ")")
mapping2String :: String -> [(Prefix, Uri)] -> String
mapping2String name mapping
= name ++ ": " ++
formatStringList id ", " (map (\(a, b) -> a ++ " = " ++ b) mapping)
datatype2String :: Datatype -> String
datatype2String (lib, localName)
= "datatypelibrary = " ++ getLib ++ ", type = " ++ localName
where
getLib = if lib == "" then relaxNamespace else lib
context2String :: Context -> String
context2String (base, mapping)
= "context (base-uri = " ++ base ++ ", " ++
mapping2String "namespace environment" mapping ++ ")"