module Text.XML.HXT.RelaxNG.DataTypes
where
import Text.XML.HXT.DOM.TypeDefs
relaxSchemaFile :: String
relaxSchemaFile = "Text/XML/HXT/RelaxNG/SpecificationSchema.rng"
relaxSchemaGrammarFile :: String
relaxSchemaGrammarFile = "Text/XML/HXT/RelaxNG/SpecificationSchemaGrammar.rng"
a_numberOfErrors,
a_relaxSimplificationChanges,
defineOrigName :: String
a_numberOfErrors = "numberOfErrors"
a_relaxSimplificationChanges = "relaxSimplificationChanges"
defineOrigName = "RelaxDefineOriginalName"
type Env = [(String, XmlTree)]
contextAttributes :: String
contextAttributes = "RelaxContext:"
contextBaseAttr :: String
contextBaseAttr = "RelaxContextBaseURI"
type OldName = String
type NewName = String
type NamePair = (OldName, NewName)
type RefList = [NamePair]
type DatatypeEqual = DatatypeName -> String -> Context -> String -> Context -> Maybe String
type DatatypeAllows = DatatypeName -> ParamList -> String -> Context -> Maybe String
type DatatypeLibraries = [DatatypeLibrary]
type DatatypeLibrary = (Uri, DatatypeCheck)
type DatatypeName = String
type ParamName = String
type AllowedParams = [ParamName]
type AllowedDatatypes = [(DatatypeName, AllowedParams)]
data DatatypeCheck
= DTC { dtAllowsFct :: DatatypeAllows
, dtEqualFct :: DatatypeEqual
, dtAllowedTypes :: AllowedDatatypes
}
type Uri = String
type LocalName = String
type ParamList = [(LocalName, String)]
type Prefix = String
type Context = (Uri, [(Prefix, Uri)])
type Datatype = (Uri, LocalName)
showDatatype :: Datatype -> String
showDatatype (u, ln)
| null u = ln
| otherwise = "{" ++ u ++ "}" ++ ln
data NameClass = AnyName
| AnyNameExcept NameClass
| Name Uri LocalName
| NsName Uri
| NsNameExcept Uri NameClass
| NameClassChoice NameClass NameClass
| NCError String
deriving Eq
instance Show NameClass
where
show AnyName = "AnyName"
show (AnyNameExcept nameClass)
= "AnyNameExcept: " ++ show nameClass
show (Name uri localName)
| null uri = localName
| otherwise = "{" ++ uri ++ "}" ++ localName
show (NsName uri) = "{" ++ uri ++ "}AnyName"
show (NsNameExcept uri nameClass)
= "NsNameExcept: {" ++ uri ++ "}" ++ show nameClass
show (NameClassChoice nameClass1 nameClass2)
= "NameClassChoice: " ++ show nameClass1 ++ "|" ++ show nameClass2
show (NCError string)
= "NCError: " ++ string
data Pattern = Empty
| NotAllowed ErrMessage
| Text
| Choice Pattern Pattern
| Interleave Pattern Pattern
| Group Pattern Pattern
| OneOrMore Pattern
| List Pattern
| Data Datatype ParamList
| DataExcept Datatype ParamList Pattern
| Value Datatype String Context
| Attribute NameClass Pattern
| Element NameClass Pattern
| After Pattern Pattern
instance Show Pattern where
show Empty = "empty"
show (NotAllowed e) = show e
show Text = "text"
show (Choice p1 p2) = "( " ++ show p1 ++ " | " ++ show p2 ++ " )"
show (Interleave p1 p2) = "( " ++ show p1 ++ " & " ++ show p2 ++ " )"
show (Group p1 p2) = "( " ++ show p1 ++ " , " ++ show p2 ++ " )"
show (OneOrMore p) = show p ++ "+"
show (List p) = "list { " ++ show p ++ " }"
show (Data dt pl) = showDatatype dt ++ showPL pl
where
showPL [] = ""
showPL l = " {" ++ concatMap showP l ++ " }"
showP (ln, v) = " " ++ ln ++ " = " ++ show v
show (DataExcept dt pl p) = show (Data dt pl) ++ " - (" ++ show p ++ " )"
show (Value dt v _cx) = showDatatype dt ++ " " ++ show v
show (Attribute nc p) = "attribute " ++ show nc ++ " { " ++ show p ++ " }"
show (Element nc p) = "element " ++ show nc ++ " { " ++ show p ++ " }"
show (After p1 p2) = "( " ++ show p1 ++ " ; " ++ show p2 ++ " )"
data ErrMessage = ErrMsg ErrLevel [String]
instance Show ErrMessage where
show (ErrMsg _lev es) = foldr1 (\ x y -> x ++ "\n" ++ y) es
type ErrLevel = Int
notAllowed :: String -> Pattern
notAllowed = notAllowedN 0
notAllowed1 :: String -> Pattern
notAllowed1 = notAllowedN 1
notAllowed2 :: String -> Pattern
notAllowed2 = notAllowedN 2
notAllowedN :: ErrLevel -> String -> Pattern
notAllowedN l s = NotAllowed (ErrMsg l [s])
mergeNotAllowed :: Pattern -> Pattern -> Pattern
mergeNotAllowed p1@(NotAllowed (ErrMsg l1 s1)) p2@(NotAllowed (ErrMsg l2 s2))
| l1 < l2 = p2
| l1 > l2 = p1
| l1 == 2 = NotAllowed $ ErrMsg 2 (s1 ++ s2)
| otherwise = p1
mergeNotAllowed _p1 _p2
= notAllowed2 "mergeNotAllowed with wrong patterns"
choice :: Pattern -> Pattern -> Pattern
choice p1@(NotAllowed _) p2@(NotAllowed _) = mergeNotAllowed p1 p2
choice p1 (NotAllowed _) = p1
choice (NotAllowed _) p2 = p2
choice p1 p2 = Choice p1 p2
group :: Pattern -> Pattern -> Pattern
group p1@(NotAllowed _) p2@(NotAllowed _) = mergeNotAllowed p1 p2
group _ n@(NotAllowed _) = n
group n@(NotAllowed _) _ = n
group p Empty = p
group Empty p = p
group p1 p2 = Group p1 p2
oneOrMore :: Pattern -> Pattern
oneOrMore n@(NotAllowed _) = n
oneOrMore p = OneOrMore p
interleave :: Pattern -> Pattern -> Pattern
interleave p1@(NotAllowed _) p2@(NotAllowed _) = mergeNotAllowed p1 p2
interleave _ p2@(NotAllowed _) = p2
interleave p1@(NotAllowed _) _ = p1
interleave p1 Empty = p1
interleave Empty p2 = p2
interleave p1 p2 = Interleave p1 p2
after :: Pattern -> Pattern -> Pattern
after p1@(NotAllowed _) p2@(NotAllowed _) = mergeNotAllowed p1 p2
after _ p2@(NotAllowed _) = p2
after p1@(NotAllowed _) _ = p1
after p1 p2 = After p1 p2
data ContentType = CTEmpty
| CTComplex
| CTSimple
| CTNone
deriving (Show, Eq, Ord)