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)

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