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,
a_output_changes,
defineOrigName :: String
a_numberOfErrors = "numberOfErrors"
a_relaxSimplificationChanges = "relaxSimplificationChanges"
a_output_changes = "output-pattern-transformations"
defineOrigName = "RelaxDefineOriginalName"
type Env = [(String, XmlTree)]
type PatternEnv = [(String, Pattern)]
contextAttributes :: String
contextAttributes = "RelaxContext-"
contextAttributesDefault :: String
contextAttributesDefault = "RelaxContextDefault"
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, Ord)
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 = NotAllowed ErrMessage
| Empty
| Text
| Element NameClass Pattern
| Attribute NameClass Pattern
| Choice Pattern Pattern
| Interleave Pattern Pattern
| Group Pattern Pattern
| After Pattern Pattern
| OneOrMore Pattern
| Data Datatype ParamList
| DataExcept Datatype ParamList Pattern
| List Pattern
| Value Datatype String Context
data Pattern' = NotAllowed'
| Empty'
| Text'
| Element'
| Attribute'
| Data'
| DataExcept'
| List'
| Value'
| OneOrMore'
| Interleave'
| Group'
| After'
| Choice'
deriving (Eq, Ord)
ord' :: Pattern -> Pattern'
ord' NotAllowed{} = NotAllowed'
ord' Empty = Empty'
ord' Text = Text'
ord' Element{} = Element'
ord' Attribute{} = Attribute'
ord' Choice{} = Choice'
ord' Interleave{} = Interleave'
ord' Group{} = Group'
ord' After{} = After'
ord' OneOrMore{} = OneOrMore'
ord' Data{} = Data'
ord' DataExcept{} = DataExcept'
ord' List{} = List'
ord' Value{} = Value'
equiv :: Pattern -> Pattern -> Bool
equiv NotAllowed{} NotAllowed{} = True
equiv Empty Empty = True
equiv Text Text = True
equiv (Element nc1 _p1) (Element nc2 _p2) = nc1 == nc2
equiv (Attribute nc1 _p1) (Attribute nc2 _p2) = nc1 == nc2
equiv (Choice p11 p12) (Choice p21 p22) = p11 `equiv` p21 && p12 `equiv` p22
equiv (Interleave p11 p12) (Interleave p21 p22) = p11 `equiv` p21 && p12 `equiv` p22
equiv (Group p11 p12) (Group p21 p22) = p11 `equiv` p21 && p12 `equiv` p22
equiv (After p11 p12) (After p21 p22) = p11 `equiv` p21 && p12 `equiv` p22
equiv (OneOrMore p1) (OneOrMore p2) = p1 `equiv` p2
equiv (Data dt1 pl1) (Data dt2 pl2) = dt1 == dt2 && pl1 == pl2
equiv (DataExcept dt1 pl1 p1) (DataExcept dt2 pl2 p2) = dt1 == dt2 && pl1 == pl2 && p1 `equiv` p2
equiv (List p1) (List p2) = p1 `equiv` p2
equiv (Value dt1 s1 cx1) (Value dt2 s2 cx2) = dt1 == dt2 && s1 == s2 && cx1 == cx2
equiv _ _ = False
gt :: Pattern -> Pattern -> Bool
gt p1 p2
| ord' p1 > ord' p2 = True
| ord' p1 < ord' p2 = False
gt (Element nc1 _p1) (Element nc2 _p2) = nc1 > nc2
gt (Attribute nc1 _p1) (Attribute nc2 _p2) = nc1 > nc2
gt (Choice p11 p12) (Choice p21 p22) = p11 `gt` p21
|| p11 `equiv` p21 && p12 `gt` p22
gt (Interleave p11 p12) (Interleave p21 p22) = p11 `gt` p21
|| p11 `equiv` p21 && p12 `gt` p22
gt (Group p11 p12) (Group p21 p22) = p11 `gt` p21
|| p11 `equiv` p21 && p12 `gt` p22
gt (After p11 p12) (After p21 p22) = p11 `gt` p21
|| p11 `equiv` p21 && p12 `gt` p22
gt (OneOrMore p1) (OneOrMore p2) = p1 `gt` p2
gt (Data dt1 pl1) (Data dt2 pl2) = dt1 > dt2
|| dt1 == dt2 && pl1 == pl2
gt (DataExcept dt1 pl1 p1) (DataExcept dt2 pl2 p2) = dt1 > dt2
|| dt1 == dt2
&& (pl1 > pl2 || pl1 == pl2 && p1 `gt` p2)
gt (List p1) (List p2) = p1 `gt` p2
gt (Value dt1 s1 cx1) (Value dt2 s2 cx2) = dt1 > dt2
|| dt1 == dt2
&& (s1 > s2 || s1 == s2 && cx1 > cx2)
gt _ _ = False
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) = "a[" ++ show nc ++ "]{...}"
show (Element nc _p) = "e[" ++ show nc ++ "]{...}"
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 (Choice p11 p12) p2 = choice p11 (choice p12 p2)
choice p1 p2@(Choice p21 p22)
| p1 `equiv` p21 = p2
| p1 `gt` p21 = choice p21 (choice p1 p22)
| otherwise = Choice p1 p2
choice p1 p2
| p1 `equiv` p2 = p2
| p1 `gt` p2 = choice p2 p1
| otherwise = 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 (Interleave p11 p12) p2 = interleave p11 (interleave p12 p2)
interleave p1 p2@(Interleave p21 p22)
| p1 `gt` p21 = interleave p21 (interleave p1 p22)
| otherwise = Interleave p1 p2
interleave p1 p2
| p1 `gt` p2 = interleave p2 p1
| otherwise = 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)