module Text.XML.HXT.RelaxNG.DataTypes
where

import           Text.XML.HXT.DOM.TypeDefs

{- debug code
import qualified Debug.Trace               as T
-- -}

-- ------------------------------------------------------------

relaxSchemaFile :: String
relaxSchemaFile :: String
relaxSchemaFile = String
"Text/XML/HXT/RelaxNG/SpecificationSchema.rng"


relaxSchemaGrammarFile :: String
relaxSchemaGrammarFile :: String
relaxSchemaGrammarFile = String
"Text/XML/HXT/RelaxNG/SpecificationSchemaGrammar.rng"

-- ------------------------------------------------------------
-- datatypes for the simplification process

a_numberOfErrors,
 a_relaxSimplificationChanges,
 a_output_changes,
 defineOrigName :: String

a_numberOfErrors :: String
a_numberOfErrors             = String
"numberOfErrors"
a_relaxSimplificationChanges :: String
a_relaxSimplificationChanges = String
"relaxSimplificationChanges"
a_output_changes :: String
a_output_changes             = String
"output-pattern-transformations"
defineOrigName :: String
defineOrigName               = String
"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 :: String
contextAttributes               = String
"RelaxContext-"

contextAttributesDefault        :: String
contextAttributesDefault :: String
contextAttributesDefault        = String
"RelaxContextDefault"

-- | Start of base uri attribute value
-- (see also: 'simplificationStep1' in "Text.XML.HXT.RelaxNG.Simplification")

contextBaseAttr :: String
contextBaseAttr :: String
contextBaseAttr = String
"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 { DatatypeCheck -> DatatypeAllows
dtAllowsFct    :: DatatypeAllows -- ^ function to test whether a value matches a data-pattern
        , DatatypeCheck -> DatatypeEqual
dtEqualFct     :: DatatypeEqual -- ^ function to test whether a value matches a value-pattern
        , DatatypeCheck -> AllowedDatatypes
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 :: Datatype -> String
showDatatype (String
u, String
ln)
         | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
u       = String
ln
         | Bool
otherwise    = String
"{" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
u String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"}" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ln

-- | Represents a name class

data NameClass = AnyName
               | AnyNameExcept NameClass
               | Name Uri LocalName
               | NsName Uri
               | NsNameExcept Uri NameClass
               | NameClassChoice NameClass NameClass
               | NCError String
               deriving (NameClass -> NameClass -> Bool
(NameClass -> NameClass -> Bool)
-> (NameClass -> NameClass -> Bool) -> Eq NameClass
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NameClass -> NameClass -> Bool
== :: NameClass -> NameClass -> Bool
$c/= :: NameClass -> NameClass -> Bool
/= :: NameClass -> NameClass -> Bool
Eq, Eq NameClass
Eq NameClass
-> (NameClass -> NameClass -> Ordering)
-> (NameClass -> NameClass -> Bool)
-> (NameClass -> NameClass -> Bool)
-> (NameClass -> NameClass -> Bool)
-> (NameClass -> NameClass -> Bool)
-> (NameClass -> NameClass -> NameClass)
-> (NameClass -> NameClass -> NameClass)
-> Ord NameClass
NameClass -> NameClass -> Bool
NameClass -> NameClass -> Ordering
NameClass -> NameClass -> NameClass
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: NameClass -> NameClass -> Ordering
compare :: NameClass -> NameClass -> Ordering
$c< :: NameClass -> NameClass -> Bool
< :: NameClass -> NameClass -> Bool
$c<= :: NameClass -> NameClass -> Bool
<= :: NameClass -> NameClass -> Bool
$c> :: NameClass -> NameClass -> Bool
> :: NameClass -> NameClass -> Bool
$c>= :: NameClass -> NameClass -> Bool
>= :: NameClass -> NameClass -> Bool
$cmax :: NameClass -> NameClass -> NameClass
max :: NameClass -> NameClass -> NameClass
$cmin :: NameClass -> NameClass -> NameClass
min :: NameClass -> NameClass -> NameClass
Ord)

instance Show NameClass
    where
    show :: NameClass -> String
show NameClass
AnyName        = String
"AnyName"
    show (AnyNameExcept NameClass
nameClass)
                        = String
"AnyNameExcept: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NameClass -> String
forall a. Show a => a -> String
show NameClass
nameClass
    show (Name String
uri String
localName)
        | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
uri      = String
localName
        | Bool
otherwise     = String
"{" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
uri String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"}" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
localName
    show (NsName String
uri)   = String
"{" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
uri String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"}AnyName"
    show (NsNameExcept String
uri NameClass
nameClass)
                        = String
"NsNameExcept: {" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
uri String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"}" String -> String -> String
forall a. [a] -> [a] -> [a]
++ NameClass -> String
forall a. Show a => a -> String
show NameClass
nameClass
    show (NameClassChoice NameClass
nameClass1 NameClass
nameClass2)
                        = String
"NameClassChoice: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NameClass -> String
forall a. Show a => a -> String
show NameClass
nameClass1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"|" String -> String -> String
forall a. [a] -> [a] -> [a]
++ NameClass -> String
forall a. Show a => a -> String
show NameClass
nameClass2
    show (NCError String
string)
                         = String
"NCError: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
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 (Pattern' -> Pattern' -> Bool
(Pattern' -> Pattern' -> Bool)
-> (Pattern' -> Pattern' -> Bool) -> Eq Pattern'
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Pattern' -> Pattern' -> Bool
== :: Pattern' -> Pattern' -> Bool
$c/= :: Pattern' -> Pattern' -> Bool
/= :: Pattern' -> Pattern' -> Bool
Eq, Eq Pattern'
Eq Pattern'
-> (Pattern' -> Pattern' -> Ordering)
-> (Pattern' -> Pattern' -> Bool)
-> (Pattern' -> Pattern' -> Bool)
-> (Pattern' -> Pattern' -> Bool)
-> (Pattern' -> Pattern' -> Bool)
-> (Pattern' -> Pattern' -> Pattern')
-> (Pattern' -> Pattern' -> Pattern')
-> Ord Pattern'
Pattern' -> Pattern' -> Bool
Pattern' -> Pattern' -> Ordering
Pattern' -> Pattern' -> Pattern'
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Pattern' -> Pattern' -> Ordering
compare :: Pattern' -> Pattern' -> Ordering
$c< :: Pattern' -> Pattern' -> Bool
< :: Pattern' -> Pattern' -> Bool
$c<= :: Pattern' -> Pattern' -> Bool
<= :: Pattern' -> Pattern' -> Bool
$c> :: Pattern' -> Pattern' -> Bool
> :: Pattern' -> Pattern' -> Bool
$c>= :: Pattern' -> Pattern' -> Bool
>= :: Pattern' -> Pattern' -> Bool
$cmax :: Pattern' -> Pattern' -> Pattern'
max :: Pattern' -> Pattern' -> Pattern'
$cmin :: Pattern' -> Pattern' -> Pattern'
min :: Pattern' -> Pattern' -> Pattern'
Ord)

ord' :: Pattern -> Pattern'
ord' :: Pattern -> Pattern'
ord' NotAllowed{}            = Pattern'
NotAllowed'
ord' Pattern
Empty                   = Pattern'
Empty'
ord' Pattern
Text                    = Pattern'
Text'
ord' Element{}               = Pattern'
Element'
ord' Attribute{}             = Pattern'
Attribute'
ord' Choice{}                = Pattern'
Choice'
ord' Interleave{}            = Pattern'
Interleave'
ord' Group{}                 = Pattern'
Group'
ord' After{}                 = Pattern'
After'
ord' OneOrMore{}             = Pattern'
OneOrMore'
ord' Data{}                  = Pattern'
Data'
ord' DataExcept{}            = Pattern'
DataExcept'
ord' List{}                  = Pattern'
List'
ord' Value{}                 = Pattern'
Value'


equiv :: Pattern -> Pattern -> Bool
equiv :: Pattern -> Pattern -> Bool
equiv NotAllowed{}            NotAllowed{}            = Bool
True
equiv Pattern
Empty                   Pattern
Empty                   = Bool
True
equiv Pattern
Text                    Pattern
Text                    = Bool
True
equiv (Element    NameClass
nc1 Pattern
_p1)    (Element NameClass
nc2 Pattern
_p2)       = NameClass
nc1 NameClass -> NameClass -> Bool
forall a. Eq a => a -> a -> Bool
== NameClass
nc2
equiv (Attribute  NameClass
nc1 Pattern
_p1)    (Attribute NameClass
nc2 Pattern
_p2)     = NameClass
nc1 NameClass -> NameClass -> Bool
forall a. Eq a => a -> a -> Bool
== NameClass
nc2
equiv (Choice     Pattern
p11 Pattern
p12)    (Choice Pattern
p21 Pattern
p22)        = Pattern
p11 Pattern -> Pattern -> Bool
`equiv` Pattern
p21 Bool -> Bool -> Bool
&& Pattern
p12 Pattern -> Pattern -> Bool
`equiv` Pattern
p22
equiv (Interleave Pattern
p11 Pattern
p12)    (Interleave Pattern
p21 Pattern
p22)    = Pattern
p11 Pattern -> Pattern -> Bool
`equiv` Pattern
p21 Bool -> Bool -> Bool
&& Pattern
p12 Pattern -> Pattern -> Bool
`equiv` Pattern
p22
equiv (Group      Pattern
p11 Pattern
p12)    (Group      Pattern
p21 Pattern
p22)    = Pattern
p11 Pattern -> Pattern -> Bool
`equiv` Pattern
p21 Bool -> Bool -> Bool
&& Pattern
p12 Pattern -> Pattern -> Bool
`equiv` Pattern
p22
equiv (After      Pattern
p11 Pattern
p12)    (After      Pattern
p21 Pattern
p22)    = Pattern
p11 Pattern -> Pattern -> Bool
`equiv` Pattern
p21 Bool -> Bool -> Bool
&& Pattern
p12 Pattern -> Pattern -> Bool
`equiv` Pattern
p22
equiv (OneOrMore  Pattern
p1)         (OneOrMore  Pattern
p2)         = Pattern
p1  Pattern -> Pattern -> Bool
`equiv` Pattern
p2
equiv (Data       Datatype
dt1 ParamList
pl1)    (Data       Datatype
dt2 ParamList
pl2)    = Datatype
dt1 Datatype -> Datatype -> Bool
forall a. Eq a => a -> a -> Bool
== Datatype
dt2 Bool -> Bool -> Bool
&& ParamList
pl1 ParamList -> ParamList -> Bool
forall a. Eq a => a -> a -> Bool
== ParamList
pl2
equiv (DataExcept Datatype
dt1 ParamList
pl1 Pattern
p1) (DataExcept Datatype
dt2 ParamList
pl2 Pattern
p2) = Datatype
dt1 Datatype -> Datatype -> Bool
forall a. Eq a => a -> a -> Bool
== Datatype
dt2 Bool -> Bool -> Bool
&& ParamList
pl1 ParamList -> ParamList -> Bool
forall a. Eq a => a -> a -> Bool
== ParamList
pl2 Bool -> Bool -> Bool
&& Pattern
p1 Pattern -> Pattern -> Bool
`equiv` Pattern
p2
equiv (List Pattern
p1)               (List Pattern
p2)               = Pattern
p1  Pattern -> Pattern -> Bool
`equiv` Pattern
p2
equiv (Value Datatype
dt1 String
s1 Context
cx1)      (Value Datatype
dt2 String
s2 Context
cx2)      = Datatype
dt1 Datatype -> Datatype -> Bool
forall a. Eq a => a -> a -> Bool
== Datatype
dt2 Bool -> Bool -> Bool
&& String
s1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
s2 Bool -> Bool -> Bool
&& Context
cx1 Context -> Context -> Bool
forall a. Eq a => a -> a -> Bool
== Context
cx2
equiv Pattern
_                       Pattern
_                       = Bool
False


gt :: Pattern -> Pattern -> Bool
gt :: Pattern -> Pattern -> Bool
gt Pattern
p1                      Pattern
p2
    | Pattern -> Pattern'
ord' Pattern
p1 Pattern' -> Pattern' -> Bool
forall a. Ord a => a -> a -> Bool
> Pattern -> Pattern'
ord' Pattern
p2                            = Bool
True
    | Pattern -> Pattern'
ord' Pattern
p1 Pattern' -> Pattern' -> Bool
forall a. Ord a => a -> a -> Bool
< Pattern -> Pattern'
ord' Pattern
p2                            = Bool
False
gt (Element    NameClass
nc1 Pattern
_p1)    (Element NameClass
nc2 Pattern
_p2)       = NameClass
nc1 NameClass -> NameClass -> Bool
forall a. Ord a => a -> a -> Bool
> NameClass
nc2
gt (Attribute  NameClass
nc1 Pattern
_p1)    (Attribute NameClass
nc2 Pattern
_p2)     = NameClass
nc1 NameClass -> NameClass -> Bool
forall a. Ord a => a -> a -> Bool
> NameClass
nc2
gt (Choice     Pattern
p11 Pattern
p12)    (Choice Pattern
p21 Pattern
p22)        = Pattern
p11 Pattern -> Pattern -> Bool
`gt` Pattern
p21
                                                     Bool -> Bool -> Bool
|| Pattern
p11 Pattern -> Pattern -> Bool
`equiv` Pattern
p21 Bool -> Bool -> Bool
&& Pattern
p12 Pattern -> Pattern -> Bool
`gt` Pattern
p22
gt (Interleave Pattern
p11 Pattern
p12)    (Interleave Pattern
p21 Pattern
p22)    = Pattern
p11 Pattern -> Pattern -> Bool
`gt` Pattern
p21
                                                     Bool -> Bool -> Bool
|| Pattern
p11 Pattern -> Pattern -> Bool
`equiv` Pattern
p21 Bool -> Bool -> Bool
&& Pattern
p12 Pattern -> Pattern -> Bool
`gt` Pattern
p22
gt (Group      Pattern
p11 Pattern
p12)    (Group      Pattern
p21 Pattern
p22)    = Pattern
p11 Pattern -> Pattern -> Bool
`gt` Pattern
p21
                                                     Bool -> Bool -> Bool
|| Pattern
p11 Pattern -> Pattern -> Bool
`equiv` Pattern
p21 Bool -> Bool -> Bool
&& Pattern
p12 Pattern -> Pattern -> Bool
`gt` Pattern
p22
gt (After      Pattern
p11 Pattern
p12)    (After      Pattern
p21 Pattern
p22)    = Pattern
p11 Pattern -> Pattern -> Bool
`gt` Pattern
p21
                                                     Bool -> Bool -> Bool
|| Pattern
p11 Pattern -> Pattern -> Bool
`equiv` Pattern
p21 Bool -> Bool -> Bool
&& Pattern
p12 Pattern -> Pattern -> Bool
`gt` Pattern
p22
gt (OneOrMore  Pattern
p1)         (OneOrMore  Pattern
p2)         = Pattern
p1  Pattern -> Pattern -> Bool
`gt` Pattern
p2
gt (Data Datatype
dt1 ParamList
pl1)          (Data Datatype
dt2 ParamList
pl2)          = Datatype
dt1 Datatype -> Datatype -> Bool
forall a. Ord a => a -> a -> Bool
> Datatype
dt2
                                                     Bool -> Bool -> Bool
|| Datatype
dt1 Datatype -> Datatype -> Bool
forall a. Eq a => a -> a -> Bool
== Datatype
dt2 Bool -> Bool -> Bool
&& ParamList
pl1 ParamList -> ParamList -> Bool
forall a. Eq a => a -> a -> Bool
== ParamList
pl2
gt (DataExcept Datatype
dt1 ParamList
pl1 Pattern
p1) (DataExcept Datatype
dt2 ParamList
pl2 Pattern
p2) = Datatype
dt1 Datatype -> Datatype -> Bool
forall a. Ord a => a -> a -> Bool
> Datatype
dt2
                                                     Bool -> Bool -> Bool
|| Datatype
dt1 Datatype -> Datatype -> Bool
forall a. Eq a => a -> a -> Bool
== Datatype
dt2
                                                        Bool -> Bool -> Bool
&& (ParamList
pl1 ParamList -> ParamList -> Bool
forall a. Ord a => a -> a -> Bool
> ParamList
pl2 Bool -> Bool -> Bool
|| ParamList
pl1 ParamList -> ParamList -> Bool
forall a. Eq a => a -> a -> Bool
== ParamList
pl2 Bool -> Bool -> Bool
&& Pattern
p1 Pattern -> Pattern -> Bool
`gt` Pattern
p2)
gt (List Pattern
p1)               (List Pattern
p2)               = Pattern
p1  Pattern -> Pattern -> Bool
`gt` Pattern
p2
gt (Value Datatype
dt1 String
s1 Context
cx1)      (Value Datatype
dt2 String
s2 Context
cx2)      = Datatype
dt1 Datatype -> Datatype -> Bool
forall a. Ord a => a -> a -> Bool
> Datatype
dt2
                                                     Bool -> Bool -> Bool
|| Datatype
dt1 Datatype -> Datatype -> Bool
forall a. Eq a => a -> a -> Bool
== Datatype
dt2
                                                        Bool -> Bool -> Bool
&& (String
s1 String -> String -> Bool
forall a. Ord a => a -> a -> Bool
> String
s2 Bool -> Bool -> Bool
|| String
s1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
s2 Bool -> Bool -> Bool
&& Context
cx1 Context -> Context -> Bool
forall a. Ord a => a -> a -> Bool
> Context
cx2)
gt Pattern
_                       Pattern
_                       = Bool
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 :: Pattern -> String
show Pattern
Empty                  = String
"empty"
    show (NotAllowed ErrMessage
e)         = ErrMessage -> String
forall a. Show a => a -> String
show ErrMessage
e
    show Pattern
Text                   = String
"text"
    show (Choice Pattern
p1 Pattern
p2)         = String
"( " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern -> String
forall a. Show a => a -> String
show Pattern
p1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" | " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern -> String
forall a. Show a => a -> String
show Pattern
p2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" )"
    show (Interleave Pattern
p1 Pattern
p2)     = String
"( " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern -> String
forall a. Show a => a -> String
show Pattern
p1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" & " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern -> String
forall a. Show a => a -> String
show Pattern
p2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" )"
    show (Group Pattern
p1 Pattern
p2)          = String
"( " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern -> String
forall a. Show a => a -> String
show Pattern
p1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" , " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern -> String
forall a. Show a => a -> String
show Pattern
p2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" )"
    show (OneOrMore Pattern
p)          = Pattern -> String
forall a. Show a => a -> String
show Pattern
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"+"
    show (List Pattern
p)               = String
"list { " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern -> String
forall a. Show a => a -> String
show Pattern
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" }"
    show (Data Datatype
dt ParamList
pl)           = Datatype -> String
showDatatype Datatype
dt String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParamList -> String
forall {a}. Show a => [(String, a)] -> String
showPL ParamList
pl
                                  where
                                  showPL :: [(String, a)] -> String
showPL []     = String
""
                                  showPL [(String, a)]
l      = String
" {" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ((String, a) -> String) -> [(String, a)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String, a) -> String
forall {a}. Show a => (String, a) -> String
showP [(String, a)]
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" }"
                                  showP :: (String, a) -> String
showP (String
ln, a
v) = String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ln String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
v
    show (DataExcept Datatype
dt ParamList
pl Pattern
p)   = Pattern -> String
forall a. Show a => a -> String
show (Datatype -> ParamList -> Pattern
Data Datatype
dt ParamList
pl) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" - (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern -> String
forall a. Show a => a -> String
show Pattern
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" )"
    show (Value Datatype
dt String
v Context
_cx)       = Datatype -> String
showDatatype Datatype
dt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
v
    show (Attribute NameClass
nc Pattern
_p)      = String
"a[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ NameClass -> String
forall a. Show a => a -> String
show NameClass
nc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]{...}"
    show (Element   NameClass
nc Pattern
_p)      = String
"e[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ NameClass -> String
forall a. Show a => a -> String
show NameClass
nc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]{...}"
    show (After Pattern
p1 Pattern
p2)          =  String
"( " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern -> String
forall a. Show a => a -> String
show Pattern
p1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ; " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern -> String
forall a. Show a => a -> String
show Pattern
p2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" )"


data ErrMessage = ErrMsg ErrLevel [String]
                  -- deriving Show

instance Show ErrMessage where
    show :: ErrMessage -> String
show (ErrMsg ErrLevel
_lev [String]
es) = (String -> String -> String) -> [String] -> String
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\ String
x String
y -> String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
y) [String]
es

type ErrLevel   = Int

-- ------------------------------------------------------------

-- smart constructor funtions for Pattern

-- | smart constructor for NotAllowed

notAllowed      :: String -> Pattern
notAllowed :: String -> Pattern
notAllowed      = ErrLevel -> String -> Pattern
notAllowedN ErrLevel
0

notAllowed1     :: String -> Pattern
notAllowed1 :: String -> Pattern
notAllowed1     = ErrLevel -> String -> Pattern
notAllowedN ErrLevel
1

notAllowed2     :: String -> Pattern
notAllowed2 :: String -> Pattern
notAllowed2     = ErrLevel -> String -> Pattern
notAllowedN ErrLevel
2

notAllowedN     :: ErrLevel -> String -> Pattern
notAllowedN :: ErrLevel -> String -> Pattern
notAllowedN ErrLevel
l String
s = ErrMessage -> Pattern
NotAllowed (ErrLevel -> [String] -> ErrMessage
ErrMsg ErrLevel
l [String
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 :: Pattern -> Pattern -> Pattern
mergeNotAllowed p1 :: Pattern
p1@(NotAllowed (ErrMsg ErrLevel
l1 [String]
s1)) p2 :: Pattern
p2@(NotAllowed (ErrMsg ErrLevel
l2 [String]
s2))
    | ErrLevel
l1 ErrLevel -> ErrLevel -> Bool
forall a. Ord a => a -> a -> Bool
< ErrLevel
l2   = Pattern
p2
    | ErrLevel
l1 ErrLevel -> ErrLevel -> Bool
forall a. Ord a => a -> a -> Bool
> ErrLevel
l2   = Pattern
p1
    | ErrLevel
l1 ErrLevel -> ErrLevel -> Bool
forall a. Eq a => a -> a -> Bool
== ErrLevel
2   = ErrMessage -> Pattern
NotAllowed (ErrMessage -> Pattern) -> ErrMessage -> Pattern
forall a b. (a -> b) -> a -> b
$ ErrLevel -> [String] -> ErrMessage
ErrMsg ErrLevel
2 ([String]
s1 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
s2)
    | Bool
otherwise = Pattern
p1

-- TODO : weird error when collecting error messages errors are duplicated

mergeNotAllowed Pattern
_p1 Pattern
_p2
    = String -> Pattern
notAllowed2 String
"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 :: Pattern -> Pattern -> Pattern
choice p1 :: Pattern
p1@(NotAllowed ErrMessage
_) p2 :: Pattern
p2@(NotAllowed ErrMessage
_)      = Pattern -> Pattern -> Pattern
mergeNotAllowed Pattern
p1 Pattern
p2
choice Pattern
p1                   (NotAllowed ErrMessage
_)      = Pattern
p1
choice (NotAllowed ErrMessage
_)    Pattern
p2                     = Pattern
p2
choice (Choice Pattern
p11 Pattern
p12)  Pattern
p2                     = Pattern -> Pattern -> Pattern
choice Pattern
p11 (Pattern -> Pattern -> Pattern
choice Pattern
p12 Pattern
p2)
choice Pattern
p1                p2 :: Pattern
p2@(Choice Pattern
p21 Pattern
p22)
    | Pattern
p1 Pattern -> Pattern -> Bool
`equiv` Pattern
p21                            = Pattern
p2
    | Pattern
p1 Pattern -> Pattern -> Bool
`gt`    Pattern
p21                            = Pattern -> Pattern -> Pattern
choice Pattern
p21 (Pattern -> Pattern -> Pattern
choice Pattern
p1 Pattern
p22)
    | Bool
otherwise                                 = Pattern -> Pattern -> Pattern
Choice Pattern
p1 Pattern
p2
choice Pattern
p1                Pattern
p2
    | Pattern
p1 Pattern -> Pattern -> Bool
`equiv` Pattern
p2                             = Pattern
p2
    | Pattern
p1 Pattern -> Pattern -> Bool
`gt`    Pattern
p2                             = Pattern -> Pattern -> Pattern
choice Pattern
p2 Pattern
p1
    | Bool
otherwise                                 = Pattern -> Pattern -> Pattern
Choice Pattern
p1 Pattern
p2

-- | smart constructor for Group

group :: Pattern -> Pattern -> Pattern
group :: Pattern -> Pattern -> Pattern
group p1 :: Pattern
p1@(NotAllowed ErrMessage
_)  p2 :: Pattern
p2@(NotAllowed ErrMessage
_)      = Pattern -> Pattern -> Pattern
mergeNotAllowed Pattern
p1 Pattern
p2
group Pattern
_                   n :: Pattern
n@(NotAllowed ErrMessage
_)      = Pattern
n
group   n :: Pattern
n@(NotAllowed ErrMessage
_)  Pattern
_                     = Pattern
n
group Pattern
p                  Pattern
Empty                  = Pattern
p
group Pattern
Empty              Pattern
p                      = Pattern
p
group Pattern
p1                 Pattern
p2                     = Pattern -> Pattern -> Pattern
Group Pattern
p1 Pattern
p2

-- | smart constructor for OneOrMore

oneOrMore :: Pattern -> Pattern
oneOrMore :: Pattern -> Pattern
oneOrMore n :: Pattern
n@(NotAllowed ErrMessage
_) = Pattern
n
oneOrMore Pattern
p                = Pattern -> Pattern
OneOrMore Pattern
p

-- | smart constructor for Interleave
--
-- nested interleaves are transformed into a sorted list

interleave :: Pattern -> Pattern -> Pattern
interleave :: Pattern -> Pattern -> Pattern
interleave p1 :: Pattern
p1@(NotAllowed ErrMessage
_) p2 :: Pattern
p2@(NotAllowed ErrMessage
_)  = Pattern -> Pattern -> Pattern
mergeNotAllowed Pattern
p1 Pattern
p2
interleave Pattern
_                 p2 :: Pattern
p2@(NotAllowed ErrMessage
_)  = Pattern
p2
interleave p1 :: Pattern
p1@(NotAllowed ErrMessage
_) Pattern
_                  = Pattern
p1
interleave Pattern
p1                Pattern
Empty              = Pattern
p1
interleave Pattern
Empty             Pattern
p2                 = Pattern
p2
interleave (Interleave Pattern
p11 Pattern
p12) Pattern
p2              = Pattern -> Pattern -> Pattern
interleave Pattern
p11 (Pattern -> Pattern -> Pattern
interleave Pattern
p12 Pattern
p2)
interleave Pattern
p1                p2 :: Pattern
p2@(Interleave Pattern
p21 Pattern
p22)
    | Pattern
p1 Pattern -> Pattern -> Bool
`gt` Pattern
p21                               = Pattern -> Pattern -> Pattern
interleave Pattern
p21 (Pattern -> Pattern -> Pattern
interleave Pattern
p1 Pattern
p22)
    | Bool
otherwise                                 = Pattern -> Pattern -> Pattern
Interleave Pattern
p1 Pattern
p2
interleave Pattern
p1                Pattern
p2
    | Pattern
p1 Pattern -> Pattern -> Bool
`gt` Pattern
p2                                = Pattern -> Pattern -> Pattern
interleave Pattern
p2 Pattern
p1
    | Bool
otherwise                                 = Pattern -> Pattern -> Pattern
Interleave Pattern
p1 Pattern
p2

-- | smart constructor for After

after :: Pattern -> Pattern -> Pattern
after :: Pattern -> Pattern -> Pattern
after p1 :: Pattern
p1@(NotAllowed ErrMessage
_) p2 :: Pattern
p2@(NotAllowed ErrMessage
_)       = Pattern -> Pattern -> Pattern
mergeNotAllowed Pattern
p1 Pattern
p2
after Pattern
_                 p2 :: Pattern
p2@(NotAllowed ErrMessage
_)       = Pattern
p2
after p1 :: Pattern
p1@(NotAllowed ErrMessage
_) Pattern
_                       = Pattern
p1
after Pattern
p1                Pattern
p2                      = Pattern -> Pattern -> Pattern
After Pattern
p1 Pattern
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 (ErrLevel -> ContentType -> String -> String
[ContentType] -> String -> String
ContentType -> String
(ErrLevel -> ContentType -> String -> String)
-> (ContentType -> String)
-> ([ContentType] -> String -> String)
-> Show ContentType
forall a.
(ErrLevel -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: ErrLevel -> ContentType -> String -> String
showsPrec :: ErrLevel -> ContentType -> String -> String
$cshow :: ContentType -> String
show :: ContentType -> String
$cshowList :: [ContentType] -> String -> String
showList :: [ContentType] -> String -> String
Show, ContentType -> ContentType -> Bool
(ContentType -> ContentType -> Bool)
-> (ContentType -> ContentType -> Bool) -> Eq ContentType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ContentType -> ContentType -> Bool
== :: ContentType -> ContentType -> Bool
$c/= :: ContentType -> ContentType -> Bool
/= :: ContentType -> ContentType -> Bool
Eq, Eq ContentType
Eq ContentType
-> (ContentType -> ContentType -> Ordering)
-> (ContentType -> ContentType -> Bool)
-> (ContentType -> ContentType -> Bool)
-> (ContentType -> ContentType -> Bool)
-> (ContentType -> ContentType -> Bool)
-> (ContentType -> ContentType -> ContentType)
-> (ContentType -> ContentType -> ContentType)
-> Ord ContentType
ContentType -> ContentType -> Bool
ContentType -> ContentType -> Ordering
ContentType -> ContentType -> ContentType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ContentType -> ContentType -> Ordering
compare :: ContentType -> ContentType -> Ordering
$c< :: ContentType -> ContentType -> Bool
< :: ContentType -> ContentType -> Bool
$c<= :: ContentType -> ContentType -> Bool
<= :: ContentType -> ContentType -> Bool
$c> :: ContentType -> ContentType -> Bool
> :: ContentType -> ContentType -> Bool
$c>= :: ContentType -> ContentType -> Bool
>= :: ContentType -> ContentType -> Bool
$cmax :: ContentType -> ContentType -> ContentType
max :: ContentType -> ContentType -> ContentType
$cmin :: ContentType -> ContentType -> ContentType
min :: ContentType -> ContentType -> ContentType
Ord)

-- ------------------------------------------------------------