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 = "Text/XML/HXT/RelaxNG/SpecificationSchema.rng"


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

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

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

contextBaseAttr :: String
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 { 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 (u :: String
u, ln :: String
ln)
         | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
u       = String
ln
         | Bool
otherwise    = "{" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
u String -> String -> String
forall a. [a] -> [a] -> [a]
++ "}" 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
/= :: NameClass -> NameClass -> Bool
$c/= :: NameClass -> NameClass -> Bool
== :: NameClass -> NameClass -> Bool
$c== :: 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
min :: NameClass -> NameClass -> NameClass
$cmin :: NameClass -> NameClass -> NameClass
max :: NameClass -> NameClass -> NameClass
$cmax :: NameClass -> NameClass -> NameClass
>= :: NameClass -> NameClass -> Bool
$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
compare :: NameClass -> NameClass -> Ordering
$ccompare :: NameClass -> NameClass -> Ordering
$cp1Ord :: Eq NameClass
Ord)

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

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


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


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

instance Show ErrMessage where
    show :: ErrMessage -> String
show (ErrMsg _lev :: Int
_lev es :: [String]
es) = (String -> String -> String) -> [String] -> String
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\ x :: String
x y :: String
y -> String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\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      = Int -> String -> Pattern
notAllowedN 0

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

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

notAllowedN     :: ErrLevel -> String -> Pattern
notAllowedN :: Int -> String -> Pattern
notAllowedN l :: Int
l s :: String
s = ErrMessage -> Pattern
NotAllowed (Int -> [String] -> ErrMessage
ErrMsg Int
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 l1 :: Int
l1 s1 :: [String]
s1)) p2 :: Pattern
p2@(NotAllowed (ErrMsg l2 :: Int
l2 s2 :: [String]
s2))
    | Int
l1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
l2   = Pattern
p2
    | Int
l1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
l2   = Pattern
p1
    | Int
l1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 2   = ErrMessage -> Pattern
NotAllowed (ErrMessage -> Pattern) -> ErrMessage -> Pattern
forall a b. (a -> b) -> a -> b
$ Int -> [String] -> ErrMessage
ErrMsg 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 _p1 :: Pattern
_p1 _p2 :: Pattern
_p2
    = String -> Pattern
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 :: Pattern -> Pattern -> Pattern
choice p1 :: Pattern
p1@(NotAllowed _) p2 :: Pattern
p2@(NotAllowed _)      = Pattern -> Pattern -> Pattern
mergeNotAllowed Pattern
p1 Pattern
p2
choice p1 :: Pattern
p1                   (NotAllowed _)      = Pattern
p1
choice (NotAllowed _)    p2 :: Pattern
p2                     = Pattern
p2
choice (Choice p11 :: Pattern
p11 p12 :: Pattern
p12)  p2 :: Pattern
p2                     = Pattern -> Pattern -> Pattern
choice Pattern
p11 (Pattern -> Pattern -> Pattern
choice Pattern
p12 Pattern
p2)
choice p1 :: Pattern
p1                p2 :: Pattern
p2@(Choice p21 :: Pattern
p21 p22 :: 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 p1 :: Pattern
p1                p2 :: 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 _)  p2 :: Pattern
p2@(NotAllowed _)      = Pattern -> Pattern -> Pattern
mergeNotAllowed Pattern
p1 Pattern
p2
group _                   n :: Pattern
n@(NotAllowed _)      = Pattern
n
group   n :: Pattern
n@(NotAllowed _)  _                     = Pattern
n
group p :: Pattern
p                  Empty                  = Pattern
p
group Empty              p :: Pattern
p                      = Pattern
p
group p1 :: Pattern
p1                 p2 :: 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 _) = Pattern
n
oneOrMore p :: 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 _) p2 :: Pattern
p2@(NotAllowed _)  = Pattern -> Pattern -> Pattern
mergeNotAllowed Pattern
p1 Pattern
p2
interleave _                 p2 :: Pattern
p2@(NotAllowed _)  = Pattern
p2
interleave p1 :: Pattern
p1@(NotAllowed _) _                  = Pattern
p1
interleave p1 :: Pattern
p1                Empty              = Pattern
p1
interleave Empty             p2 :: Pattern
p2                 = Pattern
p2
interleave (Interleave p11 :: Pattern
p11 p12 :: Pattern
p12) p2 :: Pattern
p2              = Pattern -> Pattern -> Pattern
interleave Pattern
p11 (Pattern -> Pattern -> Pattern
interleave Pattern
p12 Pattern
p2)
interleave p1 :: Pattern
p1                p2 :: Pattern
p2@(Interleave p21 :: Pattern
p21 p22 :: 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 p1 :: Pattern
p1                p2 :: 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 _) p2 :: Pattern
p2@(NotAllowed _)       = Pattern -> Pattern -> Pattern
mergeNotAllowed Pattern
p1 Pattern
p2
after _                 p2 :: Pattern
p2@(NotAllowed _)       = Pattern
p2
after p1 :: Pattern
p1@(NotAllowed _) _                       = Pattern
p1
after p1 :: Pattern
p1                p2 :: 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 (Int -> ContentType -> String -> String
[ContentType] -> String -> String
ContentType -> String
(Int -> ContentType -> String -> String)
-> (ContentType -> String)
-> ([ContentType] -> String -> String)
-> Show ContentType
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ContentType] -> String -> String
$cshowList :: [ContentType] -> String -> String
show :: ContentType -> String
$cshow :: ContentType -> String
showsPrec :: Int -> ContentType -> String -> String
$cshowsPrec :: Int -> 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
/= :: ContentType -> ContentType -> Bool
$c/= :: ContentType -> ContentType -> Bool
== :: ContentType -> ContentType -> Bool
$c== :: 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
min :: ContentType -> ContentType -> ContentType
$cmin :: ContentType -> ContentType -> ContentType
max :: ContentType -> ContentType -> ContentType
$cmax :: ContentType -> ContentType -> ContentType
>= :: ContentType -> ContentType -> Bool
$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
compare :: ContentType -> ContentType -> Ordering
$ccompare :: ContentType -> ContentType -> Ordering
$cp1Ord :: Eq ContentType
Ord)

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