    {-# LANGUAGE BangPatterns #-}

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

    {- |
       Module     : Text.XML.HXT.RelaxNG.Validation
       Copyright  : Copyright (C) 2008 Torben Kuseler, Uwe Schmidt
       License    : MIT

       Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
       Stability  : stable
       Portability: portable

       Validation of a XML document with respect to a valid Relax NG schema in simple form.
       Copied and modified from \"An algorithm for RELAX NG validation\" by James Clark
       (<http://www.thaiopensource.com/relaxng/derivative.html>).

    -}

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

    module Text.XML.HXT.RelaxNG.Validation
        ( validateWithRelax
        , validateDocWithRelax
        , validateRelax
        , validateRelax'
        , readForRelax
        , normalizeForRelaxValidation
        , contains
        )
    where

    import           Control.Arrow.ListArrows

    import           Data.Char.Properties.XMLCharProps      (isXmlSpaceChar)
    import           Data.Maybe                             (fromJust)

    import           Text.XML.HXT.DOM.Interface
    import qualified Text.XML.HXT.DOM.XmlNode               as XN

    import           Text.XML.HXT.Arrow.Edit                (canonicalizeAllNodes,
                                                             collapseAllXText)
    import           Text.XML.HXT.Arrow.XmlArrow

    import           Text.XML.HXT.Arrow.ProcessDocument     (getDocumentContents,
                                                             parseXmlDocument, propagateAndValidateNamespaces)
    import           Text.XML.HXT.Arrow.XmlState
    import           Text.XML.HXT.Arrow.XmlState.TypeDefs

    import           Text.XML.HXT.RelaxNG.CreatePattern
    import           Text.XML.HXT.RelaxNG.DataTypeLibraries
    import           Text.XML.HXT.RelaxNG.DataTypes
    import           Text.XML.HXT.RelaxNG.PatternToString
    import           Text.XML.HXT.RelaxNG.Utils             (compareURI,
                                                             formatStringListQuot)

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

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

    validateWithRelax       :: IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
    validateWithRelax theSchema
        = traceMsg 2 "normalize document for validation"
          >>>
          normalizeForRelaxValidation             -- prepare the document for validation
          >>>
          traceMsg 2 "start validation"
          >>>
          ( validateRelax $< theSchema )          -- compute and issue validation errors

    {- |
       normalize a document for validation with Relax NG: remove all namespace declaration attributes,
       remove all processing instructions and merge all sequences of text nodes into a single text node
    -}

    normalizeForRelaxValidation :: ArrowXml a => a XmlTree XmlTree
    normalizeForRelaxValidation
      = processTopDownWithAttrl
        (
         ( none `when`                      -- remove all namespace attributes
           ( isAttr
             >>>
             getNamespaceUri
             >>>
             isA (compareURI xmlnsNamespace)
           )
         )
         >>>
         (none `when` isPi)                 -- processing instructions
        )
        >>>
        collapseAllXText                    -- all text node sequences are merged into a single text node

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

    {- | Validates a xml document with respect to a Relax NG schema

       * 1.parameter  :  the arrow for computing the Relax NG schema

       - 2.parameter  :  list of configuration options for reading and validating

       - 3.parameter  :  XML document URI

       - arrow-input  :  ignored

       - arrow-output :  list of errors or 'none'
    -}

    validateDocWithRelax :: IOSArrow XmlTree XmlTree -> SysConfigList -> String -> IOSArrow XmlTree XmlTree
    validateDocWithRelax theSchema config doc
        = localSysEnv
          ( configSysVars config
            >>>
            readForRelax doc
            >>>
            validateWithRelax theSchema
          )

    {- | Validates an XML document with respect to a Relax NG schema
       and issues error messages.

       See also: `validateRelax'`

       * 1.parameter  :  Relax NG schema

       - arrow-input  :  XML document

       - arrow-output :  the document or in case of errors none
    -}

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

    validateRelax :: XmlTree -> IOSArrow XmlTree XmlTree
    validateRelax rngSchema
        = fromLA (validateRelax' rngSchema)
          >>>
          filterErrorMsg

    {- | Validates an XML document with respect to a Relax NG schema
       This arrow is pure. It does not need IO or any configuration parameters.

       * 1.parameter  :  Relax NG schema

       - arrow-input  :  XML document

       - arrow-output :  the unchanged document or an error message
    -}

    validateRelax' :: XmlTree -> LA XmlTree XmlTree
    validateRelax' rngSchema
        = ( ( ( constA rngSchema
                >>>
                createPatternFromXmlTree
              )
              &&&
              ( getChildren                       -- remove the root node
                >>>
                isElem                            -- and select the root element
              )
            )
            >>>
            arr2 (\ !pattern !xmlDoc -> childDeriv ("", []) pattern xmlDoc)
            >>>
            isA (not . nullable)
            >>>
            arr ( take 1024                      -- pattern may be recursive, so the string representation
                                                 -- is truncated to 1024 chars to assure termination
                  . ("when validating with Relax NG schema: " ++)
                  . show
                )
            >>>
            mkError c_err
          )
          `orElse`
          this

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

    readForRelax    :: String -> IOSArrow b XmlTree
    readForRelax schema
        = getDocumentContents schema
          >>>
          parseXmlDocument False True False True
          >>>
          canonicalizeAllNodes
          >>>
          propagateAndValidateNamespaces

    -- ------------------------------------------------------------
    --
    -- | tests whether a 'NameClass' contains a particular 'QName'

    contains :: NameClass -> QName -> Bool
    contains AnyName _                      = True
    contains (AnyNameExcept nc)    n        = not (contains nc n)
    contains (NsName ns1)          qn       = ns1 == namespaceUri qn
    contains (NsNameExcept ns1 nc) qn       = ns1 == namespaceUri qn && not (contains nc qn)
    contains (Name ns1 ln1)        qn       = (ns1 == namespaceUri qn) && (ln1 == localPart qn)
    contains (NameClassChoice nc1 nc2) n    = (contains nc1 n) || (contains nc2 n)
    contains (NCError _) _                  = False

    -- ------------------------------------------------------------
    --
    -- | tests whether a pattern matches the empty sequence
    nullable:: Pattern -> Bool
    nullable (Group p1 p2)          = nullable p1 && nullable p2
    nullable (Interleave p1 p2)     = nullable p1 && nullable p2
    nullable (Choice p1 p2)         = nullable p1 || nullable p2
    nullable (OneOrMore p)          = nullable p
    nullable (Element _ _)          = False
    nullable (Attribute _ _)        = False
    nullable (List _)               = False
    nullable (Value _ _ _)          = False
    nullable (Data _ _)             = False
    nullable (DataExcept _ _ _)     = False
    nullable (NotAllowed _)         = False
    nullable Empty                  = True
    nullable Text                   = True
    nullable (After _ _)            = False

    -- ------------------------------------------------------------
    --
    -- | computes the derivative of a pattern with respect to a XML-Child and a 'Context'

    childDeriv :: Context -> Pattern -> XmlTree -> Pattern

    childDeriv cx p t
        | XN.isText t       = textDeriv{- ' -}cx p . fromJust . XN.getText $ t
        | XN.isElem t       = endTagDeriv{- ' -} p4
        | otherwise         = notAllowed "Call to childDeriv with wrong arguments"
        where
        children    =            XN.getChildren $ t
        qn          = fromJust . XN.getElemName $ t
        atts        = fromJust . XN.getAttrl    $ t
        cx1         = ("",[])
        p1          = startTagOpenDeriv p qn
        p2          = attsDeriv{- ' -} cx1 p1 atts
        p3          = startTagCloseDeriv p2
        p4          = childrenDeriv cx1 p3 children

    -- ------------------------------------------------------------
    --
    -- | computes the derivative of a pattern with respect to a text node

    {-
    textDeriv' cx p t
        = T.trace ("textDeriv: p=\n" ++ (take 10000 . show) p ++ ", t=\n" ++ t) $
          T.trace ("res=\n" ++ (take 10000 . show) res) res
        where
        res = textDeriv cx p t
    -- -}

    textDeriv :: Context -> Pattern -> String -> Pattern

    textDeriv cx (Choice p1 p2) s
        = choice (textDeriv cx p1 s) (textDeriv cx p2 s)

    textDeriv cx (Interleave p1 p2) s
        = choice
          (interleave (textDeriv cx p1 s) p2)
          (interleave p1 (textDeriv cx p2 s))

    textDeriv cx (Group p1 p2) s
        = let
          p = group (textDeriv cx p1 s) p2
          in
          if nullable p1
          then choice p (textDeriv cx p2 s)
          else p

    textDeriv cx (After p1 p2) s
        = after (textDeriv cx p1 s) p2

    textDeriv cx (OneOrMore p) s
        = group (textDeriv cx p s) (choice (OneOrMore p) Empty)

    textDeriv _ Text _
        = Text

    textDeriv cx1 (Value (uri, s) value cx2) s1
        = case datatypeEqual uri s value cx2 s1 cx1
          of
          Nothing     -> Empty
          Just errStr -> notAllowed errStr

    textDeriv cx (Data (uri, s) params) s1
        = case datatypeAllows uri s params s1 cx
          of
          Nothing     -> Empty
          Just errStr -> notAllowed2 errStr

    textDeriv cx (DataExcept (uri, s) params p) s1
        = case (datatypeAllows uri s params s1 cx)
          of
          Nothing     -> if not $ nullable $ textDeriv cx p s1
                         then Empty
                         else notAllowed
                                  ( "Any value except " ++
                                    show (show p) ++
                                    " expected, but value " ++
                                    show (show s1) ++
                                    " found"
                                  )
          Just errStr -> notAllowed errStr

    textDeriv cx (List p) s
        = if nullable (listDeriv cx p (words s))
          then Empty
          else notAllowed
                   ( "List with value(s) " ++
                     show p ++
                     " expected, but value(s) " ++
                     formatStringListQuot (words s) ++
                     " found"
                   )

    textDeriv _ n@(NotAllowed _) _
        = n

    textDeriv _ p s
        = notAllowed
          ( "Pattern " ++ show (getPatternName p) ++
            " expected, but text " ++ show s ++ " found"
          )

    -- ------------------------------------------------------------
    --
    -- | To compute the derivative of a pattern with respect to a list of strings,
    -- simply compute the derivative with respect to each member of the list in turn.

    listDeriv :: Context -> Pattern -> [String] -> Pattern

    listDeriv _ !p []
        = p

    listDeriv cx !p (x:xs)
        = listDeriv cx (textDeriv cx p x) xs

    -- ------------------------------------------------------------
    --
    -- | computes the derivative of a pattern with respect to a start tag open

    startTagOpenDeriv :: Pattern -> QName -> Pattern

    startTagOpenDeriv (Choice p1 p2) qn
        = choice (startTagOpenDeriv p1 qn) (startTagOpenDeriv p2 qn)

    startTagOpenDeriv (Element nc p) qn
        | contains nc qn
            = after p Empty
        | otherwise
            = notAllowed $
              "Element with name " ++ nameClassToString nc ++
                " expected, but " ++ universalName qn ++ " found"

    startTagOpenDeriv (Interleave p1 p2) qn
        = choice
          (applyAfter (flip interleave p2) (startTagOpenDeriv p1 qn))
          (applyAfter (interleave p1) (startTagOpenDeriv p2 qn))

    startTagOpenDeriv (OneOrMore p) qn
        = applyAfter
          (flip group (choice (OneOrMore p) Empty))
          (startTagOpenDeriv p qn)

    startTagOpenDeriv (Group p1 p2) qn
        = let
          x = applyAfter (flip group p2) (startTagOpenDeriv p1 qn)
          in
          if nullable p1
          then choice x (startTagOpenDeriv p2 qn)
          else x

    startTagOpenDeriv (After p1 p2) qn
        = applyAfter (flip after p2) (startTagOpenDeriv p1 qn)

    startTagOpenDeriv n@(NotAllowed _) _
        = n

    startTagOpenDeriv p qn
        = notAllowed ( show p ++ " expected, but Element " ++ universalName qn ++ " found" )

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

    -- auxiliary functions for tracing

    {-
    attsDeriv' cx p ts
        = T.trace ("attsDeriv: p=" ++ (take 1000 . show) p ++ ", t=" ++ showXts ts) $
          T.trace ("res= " ++ (take 1000 . show) res) res
        where
        res = attsDeriv cx p ts
    -- -}

    {-
    attDeriv' cx p t
        = T.trace ("attDeriv: p=\n" ++ (take 10000 . show) p ++ ", t=\n" ++ showXts [t]) $
          T.trace ("res=\n" ++ (take 1000 . show) res) res
        where
        res = attDeriv cx p t
    -- -}

    -- | To compute the derivative of a pattern with respect to a sequence of attributes,
    -- simply compute the derivative with respect to each attribute in turn.

    attsDeriv :: Context -> Pattern -> XmlTrees -> Pattern

    attsDeriv _ !p []
        = p
    attsDeriv cx !p (t : ts)
        | XN.isAttr t
            = attsDeriv cx (attDeriv{- ' -} cx p t) ts
        | otherwise
            = notAllowed "Call to attsDeriv with wrong arguments"

    attDeriv :: Context -> Pattern -> XmlTree -> Pattern

    attDeriv cx (After p1 p2) att
        = after (attDeriv cx p1 att) p2

    attDeriv cx (Choice p1 p2) att
        = choice (attDeriv cx p1 att) (attDeriv cx p2 att)

    attDeriv cx (Group p1 p2) att
        = choice
          (group (attDeriv cx p1 att) p2)
          (group p1 (attDeriv cx p2 att))

    attDeriv cx (Interleave p1 p2) att
        = choice
          (interleave (attDeriv cx p1 att) p2)
          (interleave p1 (attDeriv cx p2 att))

    attDeriv cx (OneOrMore p) att
        = group
          (attDeriv cx p att)
          (choice (OneOrMore p) Empty)

    attDeriv cx (Attribute nc p) att
        | isa
          &&
          not (contains nc qn)
            = notAllowed1 $
              "Attribute with name " ++ nameClassToString nc
              ++ " expected, but " ++ universalName qn ++ " found"
        | isa
          &&
          ( ( nullable p
              &&
              whitespace val
            )
            || nullable p'
          )
            = Empty
        | isa
            = err' p'
        where
        isa =            XN.isAttr      $ att
        qn  = fromJust . XN.getAttrName $ att
        av  =            XN.getChildren $ att
        val = showXts av
        p'  = textDeriv cx p val

        err' (NotAllowed (ErrMsg _l es))
            = err'' (": " ++ head es)
        err' _
            = err'' ""
        err'' e
            = notAllowed2 $
              "Attribute value \"" ++ val ++
              "\" does not match datatype spec " ++ show p ++ e

    attDeriv _ n@(NotAllowed _) _
        = n

    attDeriv _ _p att
        = notAllowed $
          "No matching pattern for attribute '" ++  showXts [att] ++ "' found"

    -- ------------------------------------------------------------
    --
    -- | computes the derivative of a pattern with respect to a start tag close

    startTagCloseDeriv :: Pattern -> Pattern

    startTagCloseDeriv (After p1 p2)
        = after (startTagCloseDeriv p1) p2

    startTagCloseDeriv (Choice p1 p2)
        = choice
          (startTagCloseDeriv p1)
          (startTagCloseDeriv p2)

    startTagCloseDeriv (Group p1 p2)
        = group
          (startTagCloseDeriv p1)
          (startTagCloseDeriv p2)

    startTagCloseDeriv (Interleave p1 p2)
        = interleave
          (startTagCloseDeriv p1)
          (startTagCloseDeriv p2)

    startTagCloseDeriv (OneOrMore p)
        = oneOrMore (startTagCloseDeriv p)

    startTagCloseDeriv (Attribute nc _)
        = notAllowed1 $
          "Attribut with name, " ++ show nc ++
          " expected, but no more attributes found"

    startTagCloseDeriv p
        = p

    -- ------------------------------------------------------------
    --
    -- | Computing the derivative of a pattern with respect to a list of children involves
    -- computing the derivative with respect to each pattern in turn, except
    -- that whitespace requires special treatment.

    childrenDeriv :: Context -> Pattern -> XmlTrees -> Pattern
    childrenDeriv _cx p@(NotAllowed _) _
        = p

    childrenDeriv cx p []
        = childrenDeriv cx p [XN.mkText ""]

    childrenDeriv cx p [tt]
        | ist
          &&
          whitespace s
            = choice p p1
        | ist
            = p1
        where
        ist =            XN.isText    tt
        s   = fromJust . XN.getText $ tt
        p1  = childDeriv cx p tt

    childrenDeriv cx p children
        = stripChildrenDeriv cx p children

    stripChildrenDeriv :: Context -> Pattern -> XmlTrees -> Pattern
    stripChildrenDeriv _ !p []
        = p

    stripChildrenDeriv cx !p (h:t)
        = stripChildrenDeriv cx
          ( if strip h
            then p
            else (childDeriv cx p h)
          ) t

    -- ------------------------------------------------------------
    --
    -- | computes the derivative of a pattern with respect to a end tag

    {-
    endTagDeriv' p
        = T.trace ("endTagDeriv: p=\n" ++ (take 10000 . show) p) $
          T.trace ("res=\n" ++ (take 10000 . show) res) res
        where
        res = endTagDeriv p
    -- -}

    endTagDeriv :: Pattern -> Pattern
    endTagDeriv (Choice p1 p2)
        = choice (endTagDeriv p1) (endTagDeriv p2)

    endTagDeriv (After p1 p2)
        | nullable p1
            = p2
        | otherwise
            = notAllowed $
              show p1 ++ " expected"

    endTagDeriv n@(NotAllowed _)
        = n

    endTagDeriv _
        = notAllowed "Call to endTagDeriv with wrong arguments"

    -- ------------------------------------------------------------
    --
    -- | applies a function (first parameter) to the second part of a after pattern

    applyAfter :: (Pattern -> Pattern) -> Pattern -> Pattern

    applyAfter f (After p1 p2)      = after p1 (f p2)
    applyAfter f (Choice p1 p2)     = choice (applyAfter f p1) (applyAfter f p2)
    applyAfter _ n@(NotAllowed _)   = n
    applyAfter _ _                  = notAllowed "Call to applyAfter with wrong arguments"

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

    -- mothers little helpers

    strip           :: XmlTree -> Bool
    strip           = maybe False whitespace . XN.getText

    whitespace      :: String -> Bool
    whitespace      = all isXmlSpaceChar

    showXts         :: XmlTrees -> String
    showXts         = concat . runLA (xshow $ arrL id)

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