module Text.XML.HXT.RelaxNG.DataTypes where import Text.XML.HXT.DOM.TypeDefs {- debug code import qualified Debug.Trace as T -- -} -- ------------------------------------------------------------ relaxSchemaFile :: String relaxSchemaFile = "Text/XML/HXT/RelaxNG/SpecificationSchema.rng" relaxSchemaGrammarFile :: String relaxSchemaGrammarFile = "Text/XML/HXT/RelaxNG/SpecificationSchemaGrammar.rng" -- ------------------------------------------------------------ -- datatypes for the simplification process 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)] -- | Start of a context attribute value -- (see also: 'Text.XML.HXT.RelaxNG.Simplification.simplificationStep1') -- -- The value is always followed by the original attribute name and value contextAttributes :: String contextAttributes = "RelaxContext-" contextAttributesDefault :: String contextAttributesDefault = "RelaxContextDefault" -- | Start of base uri attribute value -- (see also: 'simplificationStep1' in "Text.XML.HXT.RelaxNG.Simplification") contextBaseAttr :: String contextBaseAttr = "RelaxContextBaseURI" -- see simplificationStep5 in Text.XML.HXT.RelaxNG.Simplification type OldName = String type NewName = String type NamePair = (OldName, NewName) type RefList = [NamePair] -- ------------------------------------------------------------ -- datatype library handling -- | Type of all datatype libraries functions that tests whether -- a XML instance value matches a value-pattern. -- -- Returns Just \"errorMessage\" in case of an error else Nothing. type DatatypeEqual = DatatypeName -> String -> Context -> String -> Context -> Maybe String -- | Type of all datatype libraries functions that tests whether -- a XML instance value matches a data-pattern. -- -- Returns Just \"errorMessage\" in case of an error else Nothing. type DatatypeAllows = DatatypeName -> ParamList -> String -> Context -> Maybe String -- | List of all supported datatype libraries type DatatypeLibraries = [DatatypeLibrary] -- | Each datatype library is identified by a URI. type DatatypeLibrary = (Uri, DatatypeCheck) type DatatypeName = String type ParamName = String -- | List of all supported params for a datatype type AllowedParams = [ParamName] -- | List of all supported datatypes and there allowed params type AllowedDatatypes = [(DatatypeName, AllowedParams)] -- | The Constructor exports the list of supported datatypes for a library. -- It also exports the specialized datatype library functions to validate -- a XML instance value with respect to a datatype. data DatatypeCheck = DTC { dtAllowsFct :: DatatypeAllows -- ^ function to test whether a value matches a data-pattern , dtEqualFct :: DatatypeEqual -- ^ function to test whether a value matches a value-pattern , dtAllowedTypes :: AllowedDatatypes -- ^ list of all supported params for a datatype } -- ------------------------------------------------------------ -- datatypes for the validation process type Uri = String type LocalName = String -- | List of parameters; each parameter is a pair consisting of a local name and a value. type ParamList = [(LocalName, String)] type Prefix = String -- | A Context represents the context of an XML element. -- It consists of a base URI and a mapping from prefixes to namespace URIs. type Context = (Uri, [(Prefix, Uri)]) -- | A Datatype identifies a datatype by a datatype library name and a local name. type Datatype = (Uri, LocalName) showDatatype :: Datatype -> String showDatatype (u, ln) | null u = ln | otherwise = "{" ++ u ++ "}" ++ ln -- | Represents a name class 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 -- | Represents a pattern after simplification data Pattern = NotAllowed ErrMessage -- {} | Empty -- {epsilon} | Text -- symbol: text | Element NameClass Pattern -- symbol: element with pattern for children | Attribute NameClass Pattern -- symbol: attr with pattern for value | Choice Pattern Pattern -- binary combinator, symmetric | Interleave Pattern Pattern -- " " , symmetric | Group Pattern Pattern -- " " | After Pattern Pattern -- " " | OneOrMore Pattern -- unary combinator | Data Datatype ParamList -- value check | DataExcept Datatype ParamList Pattern | List Pattern -- value check | Value Datatype String Context -- value check 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) = "attribute " ++ show nc ++ " { " ++ show p ++ " }" show (Element nc p) = "element " ++ show nc ++ " { " ++ show p ++ " }" show (After p1 p2) = "( " ++ show p1 ++ " ; " ++ show p2 ++ " )" -- -} 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] -- deriving Show instance Show ErrMessage where show (ErrMsg _lev es) = foldr1 (\ x y -> x ++ "\n" ++ y) es type ErrLevel = Int -- ------------------------------------------------------------ -- smart constructor funtions for Pattern -- | smart constructor for NotAllowed 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]) -- | merge error messages -- -- If error levels are different, the more important is taken, -- if level is 2 (max level) both error messages are taken -- else the 1. error mesage is taken 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 -- TODO : weird error when collecting error messages errors are duplicated mergeNotAllowed _p1 _p2 = notAllowed2 "mergeNotAllowed with wrong patterns" -- | smart constructor for Choice -- -- nexted choices are transformed into a sorted list {- choice' :: Pattern -> Pattern -> Pattern choice' p1 p2 = T.trace ("choice:\np1=" ++ show p1 ++ "\np2=" ++ show p2) $ T.trace ("res=" ++ show res) $ res where res = choice p1 p2 -- -} 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 -- | smart constructor for Group 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 -- | smart constructor for OneOrMore oneOrMore :: Pattern -> Pattern oneOrMore n@(NotAllowed _) = n oneOrMore p = OneOrMore p -- | smart constructor for Interleave -- -- nested interleaves are transformed into a sorted list 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 -- | smart constructor for After 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 -- | Possible content types of a Relax NG pattern. -- (see also chapter 7.2 in Relax NG specification) data ContentType = CTEmpty | CTComplex | CTSimple | CTNone deriving (Show, Eq, Ord) -- ------------------------------------------------------------