    {-# 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 :: IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
    validateWithRelax theSchema :: IOSArrow XmlTree XmlTree
    theSchema
        = Int -> String -> IOSArrow XmlTree XmlTree
    forall s b. Int -> String -> IOStateArrow s b b
    traceMsg 2 "normalize document for validation"
          IOSArrow XmlTree XmlTree
    -> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
          IOSArrow XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    normalizeForRelaxValidation             -- prepare the document for validation
          IOSArrow XmlTree XmlTree
    -> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
          Int -> String -> IOSArrow XmlTree XmlTree
    forall s b. Int -> String -> IOStateArrow s b b
    traceMsg 2 "start validation"
          IOSArrow XmlTree XmlTree
    -> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
          ( XmlTree -> IOSArrow XmlTree XmlTree
    validateRelax (XmlTree -> IOSArrow XmlTree XmlTree)
    -> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
    forall (a :: * -> * -> *) c b d.
    ArrowList a =>
    (c -> a b d) -> a b c -> a b d
    $< IOSArrow XmlTree XmlTree
    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 :: a XmlTree XmlTree
    normalizeForRelaxValidation
      = a XmlTree XmlTree -> a XmlTree XmlTree
    forall (a :: * -> * -> *).
    ArrowXml a =>
    a XmlTree XmlTree -> a XmlTree XmlTree
    processTopDownWithAttrl
        (
         ( a XmlTree XmlTree
    forall (a :: * -> * -> *) b c. ArrowList a => a b c
    none a XmlTree XmlTree -> a XmlTree String -> a XmlTree XmlTree
    forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
    `when`                      -- remove all namespace attributes
           ( a XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isAttr
             a XmlTree XmlTree -> a XmlTree String -> a XmlTree String
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
             a XmlTree String
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
    getNamespaceUri
             a XmlTree String -> a String String -> a XmlTree String
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
             (String -> Bool) -> a String String
    forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
    isA (String -> String -> Bool
    compareURI String
    xmlnsNamespace)
           )
         )
         a XmlTree XmlTree -> a XmlTree XmlTree -> a XmlTree XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
         (a XmlTree XmlTree
    forall (a :: * -> * -> *) b c. ArrowList a => a b c
    none a XmlTree XmlTree -> a XmlTree XmlTree -> a XmlTree XmlTree
    forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
    `when` a XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isPi)                 -- processing instructions
        )
        a XmlTree XmlTree -> a XmlTree XmlTree -> a XmlTree XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
        a XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowList a => a XmlTree XmlTree
    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 :: IOSArrow XmlTree XmlTree
    -> SysConfigList -> String -> IOSArrow XmlTree XmlTree
    validateDocWithRelax theSchema :: IOSArrow XmlTree XmlTree
    theSchema config :: SysConfigList
    config doc :: String
    doc
        = IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
    forall s a b. IOStateArrow s a b -> IOStateArrow s a b
    localSysEnv
          ( SysConfigList -> IOSArrow XmlTree XmlTree
    forall s c. SysConfigList -> IOStateArrow s c c
    configSysVars SysConfigList
    config
            IOSArrow XmlTree XmlTree
    -> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
            String -> IOSArrow XmlTree XmlTree
    forall b. String -> IOSArrow b XmlTree
    readForRelax String
    doc
            IOSArrow XmlTree XmlTree
    -> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
            IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
    validateWithRelax IOSArrow XmlTree XmlTree
    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 :: XmlTree -> IOSArrow XmlTree XmlTree
    validateRelax rngSchema :: XmlTree
    rngSchema
        = LA XmlTree XmlTree -> IOSArrow XmlTree XmlTree
    forall (a :: * -> * -> *) b c. ArrowList a => LA b c -> a b c
    fromLA (XmlTree -> LA XmlTree XmlTree
    validateRelax' XmlTree
    rngSchema)
          IOSArrow XmlTree XmlTree
    -> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
          IOSArrow XmlTree XmlTree
    forall s. IOStateArrow s XmlTree XmlTree
    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' :: XmlTree -> LA XmlTree XmlTree
    validateRelax' rngSchema :: XmlTree
    rngSchema
        = ( ( ( XmlTree -> LA XmlTree XmlTree
    forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
    constA XmlTree
    rngSchema
                LA XmlTree XmlTree -> LA XmlTree Pattern -> LA XmlTree Pattern
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                LA XmlTree Pattern
    createPatternFromXmlTree
              )
              LA XmlTree Pattern
    -> LA XmlTree XmlTree -> LA XmlTree (Pattern, XmlTree)
    forall (a :: * -> * -> *) b c c'.
    Arrow a =>
    a b c -> a b c' -> a b (c, c')
    &&&
              ( LA XmlTree XmlTree
    forall (a :: * -> * -> *) (t :: * -> *) b.
    (ArrowTree a, Tree t) =>
    a (t b) (t b)
    getChildren                       -- remove the root node
                LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isElem                            -- and select the root element
              )
            )
            LA XmlTree (Pattern, XmlTree)
    -> LA (Pattern, XmlTree) XmlTree -> LA XmlTree XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
            (Pattern -> XmlTree -> Pattern) -> LA (Pattern, XmlTree) Pattern
    forall (a :: * -> * -> *) b1 b2 c.
    ArrowList a =>
    (b1 -> b2 -> c) -> a (b1, b2) c
    arr2 (\ !Pattern
    pattern !XmlTree
    xmlDoc -> Context -> Pattern -> XmlTree -> Pattern
    childDeriv ("", []) Pattern
    pattern XmlTree
    xmlDoc)
            LA (Pattern, XmlTree) Pattern
    -> LA Pattern XmlTree -> LA (Pattern, XmlTree) XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
            (Pattern -> Bool) -> LA Pattern Pattern
    forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
    isA (Bool -> Bool
    not (Bool -> Bool) -> (Pattern -> Bool) -> Pattern -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Pattern -> Bool
    nullable)
            LA Pattern Pattern -> LA Pattern XmlTree -> LA Pattern XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
            (Pattern -> String) -> LA Pattern String
    forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
    arr ( Int -> String -> String
    forall a. Int -> [a] -> [a]
    take 1024                      -- pattern may be recursive, so the string representation
                                                 -- is truncated to 1024 chars to assure termination
                  (String -> String) -> (Pattern -> String) -> Pattern -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ("when validating with Relax NG schema: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++)
                  (String -> String) -> (Pattern -> String) -> Pattern -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Pattern -> String
    forall a. Show a => a -> String
    show
                )
            LA Pattern String -> LA String XmlTree -> LA Pattern XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
            Int -> LA String XmlTree
    forall (a :: * -> * -> *). ArrowXml a => Int -> a String XmlTree
    mkError Int
    c_err
          )
          LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
    forall (a :: * -> * -> *) b c. ArrowIf a => a b c -> a b c -> a b c
    `orElse`
          LA XmlTree XmlTree
    forall (a :: * -> * -> *) b. ArrowList a => a b b
    this

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

    readForRelax    :: String -> IOSArrow b XmlTree
    readForRelax :: String -> IOSArrow b XmlTree
    readForRelax schema :: String
    schema
        = String -> IOSArrow b XmlTree
    forall s b. String -> IOStateArrow s b XmlTree
    getDocumentContents String
    schema
          IOSArrow b XmlTree
    -> IOSArrow XmlTree XmlTree -> IOSArrow b XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
          Bool -> Bool -> Bool -> Bool -> IOSArrow XmlTree XmlTree
    forall s.
    Bool -> Bool -> Bool -> Bool -> IOStateArrow s XmlTree XmlTree
    parseXmlDocument Bool
    False Bool
    True Bool
    False Bool
    True
          IOSArrow XmlTree XmlTree
    -> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
          IOSArrow XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowList a => a XmlTree XmlTree
    canonicalizeAllNodes
          IOSArrow XmlTree XmlTree
    -> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
          IOSArrow XmlTree XmlTree
    forall s. IOStateArrow s XmlTree XmlTree
    propagateAndValidateNamespaces

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

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

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

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

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

    childDeriv :: Context -> Pattern -> XmlTree -> Pattern
    childDeriv cx :: Context
    cx p :: Pattern
    p t :: XmlTree
    t
        | XmlTree -> Bool
    forall a. XmlNode a => a -> Bool
    XN.isText XmlTree
    t       = Context -> Pattern -> String -> Pattern
    textDeriv{- ' -}Context
    cx Pattern
    p (String -> Pattern) -> (XmlTree -> String) -> XmlTree -> Pattern
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Maybe String -> String
    forall a. HasCallStack => Maybe a -> a
    fromJust (Maybe String -> String)
    -> (XmlTree -> Maybe String) -> XmlTree -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . XmlTree -> Maybe String
    forall a. XmlNode a => a -> Maybe String
    XN.getText (XmlTree -> Pattern) -> XmlTree -> Pattern
    forall a b. (a -> b) -> a -> b
    $ XmlTree
    t
        | XmlTree -> Bool
    forall a. XmlNode a => a -> Bool
    XN.isElem XmlTree
    t       = Pattern -> Pattern
    endTagDeriv{- ' -} Pattern
    p4
        | Bool
    otherwise         = String -> Pattern
    notAllowed "Call to childDeriv with wrong arguments"
        where
        children :: [XmlTree]
    children    =            XmlTree -> [XmlTree]
    forall (t :: * -> *) a. Tree t => t a -> [t a]
    XN.getChildren (XmlTree -> [XmlTree]) -> XmlTree -> [XmlTree]
    forall a b. (a -> b) -> a -> b
    $ XmlTree
    t
        qn :: QName
    qn          = Maybe QName -> QName
    forall a. HasCallStack => Maybe a -> a
    fromJust (Maybe QName -> QName)
    -> (XmlTree -> Maybe QName) -> XmlTree -> QName
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . XmlTree -> Maybe QName
    forall a. XmlNode a => a -> Maybe QName
    XN.getElemName (XmlTree -> QName) -> XmlTree -> QName
    forall a b. (a -> b) -> a -> b
    $ XmlTree
    t
        atts :: [XmlTree]
    atts        = Maybe [XmlTree] -> [XmlTree]
    forall a. HasCallStack => Maybe a -> a
    fromJust (Maybe [XmlTree] -> [XmlTree])
    -> (XmlTree -> Maybe [XmlTree]) -> XmlTree -> [XmlTree]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . XmlTree -> Maybe [XmlTree]
    forall a. XmlNode a => a -> Maybe [XmlTree]
    XN.getAttrl    (XmlTree -> [XmlTree]) -> XmlTree -> [XmlTree]
    forall a b. (a -> b) -> a -> b
    $ XmlTree
    t
        cx1 :: (String, [a])
    cx1         = ("",[])
        p1 :: Pattern
    p1          = Pattern -> QName -> Pattern
    startTagOpenDeriv Pattern
    p QName
    qn
        p2 :: Pattern
    p2          = Context -> Pattern -> [XmlTree] -> Pattern
    attsDeriv{- ' -} Context
    forall a. (String, [a])
    cx1 Pattern
    p1 [XmlTree]
    atts
        p3 :: Pattern
    p3          = Pattern -> Pattern
    startTagCloseDeriv Pattern
    p2
        p4 :: Pattern
    p4          = Context -> Pattern -> [XmlTree] -> Pattern
    childrenDeriv Context
    forall a. (String, [a])
    cx1 Pattern
    p3 [XmlTree]
    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 :: Context -> Pattern -> String -> Pattern
    textDeriv cx :: Context
    cx (Choice p1 :: Pattern
    p1 p2 :: Pattern
    p2) s :: String
    s
        = Pattern -> Pattern -> Pattern
    choice (Context -> Pattern -> String -> Pattern
    textDeriv Context
    cx Pattern
    p1 String
    s) (Context -> Pattern -> String -> Pattern
    textDeriv Context
    cx Pattern
    p2 String
    s)

    textDeriv cx :: Context
    cx (Interleave p1 :: Pattern
    p1 p2 :: Pattern
    p2) s :: String
    s
        = Pattern -> Pattern -> Pattern
    choice
          (Pattern -> Pattern -> Pattern
    interleave (Context -> Pattern -> String -> Pattern
    textDeriv Context
    cx Pattern
    p1 String
    s) Pattern
    p2)
          (Pattern -> Pattern -> Pattern
    interleave Pattern
    p1 (Context -> Pattern -> String -> Pattern
    textDeriv Context
    cx Pattern
    p2 String
    s))

    textDeriv cx :: Context
    cx (Group p1 :: Pattern
    p1 p2 :: Pattern
    p2) s :: String
    s
        = let
          p :: Pattern
    p = Pattern -> Pattern -> Pattern
    group (Context -> Pattern -> String -> Pattern
    textDeriv Context
    cx Pattern
    p1 String
    s) Pattern
    p2
          in
          if Pattern -> Bool
    nullable Pattern
    p1
          then Pattern -> Pattern -> Pattern
    choice Pattern
    p (Context -> Pattern -> String -> Pattern
    textDeriv Context
    cx Pattern
    p2 String
    s)
          else Pattern
    p

    textDeriv cx :: Context
    cx (After p1 :: Pattern
    p1 p2 :: Pattern
    p2) s :: String
    s
        = Pattern -> Pattern -> Pattern
    after (Context -> Pattern -> String -> Pattern
    textDeriv Context
    cx Pattern
    p1 String
    s) Pattern
    p2

    textDeriv cx :: Context
    cx (OneOrMore p :: Pattern
    p) s :: String
    s
        = Pattern -> Pattern -> Pattern
    group (Context -> Pattern -> String -> Pattern
    textDeriv Context
    cx Pattern
    p String
    s) (Pattern -> Pattern -> Pattern
    choice (Pattern -> Pattern
    OneOrMore Pattern
    p) Pattern
    Empty)

    textDeriv _ Text _
        = Pattern
    Text

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

    textDeriv cx :: Context
    cx (Data (uri :: String
    uri, s :: String
    s) params :: ParamList
    params) s1 :: String
    s1
        = case String -> DatatypeAllows
    datatypeAllows String
    uri String
    s ParamList
    params String
    s1 Context
    cx
          of
          Nothing     -> Pattern
    Empty
          Just errStr :: String
    errStr -> String -> Pattern
    notAllowed2 String
    errStr

    textDeriv cx :: Context
    cx (DataExcept (uri :: String
    uri, s :: String
    s) params :: ParamList
    params p :: Pattern
    p) s1 :: String
    s1
        = case (String -> DatatypeAllows
    datatypeAllows String
    uri String
    s ParamList
    params String
    s1 Context
    cx)
          of
          Nothing     -> if Bool -> Bool
    not (Bool -> Bool) -> Bool -> Bool
    forall a b. (a -> b) -> a -> b
    $ Pattern -> Bool
    nullable (Pattern -> Bool) -> Pattern -> Bool
    forall a b. (a -> b) -> a -> b
    $ Context -> Pattern -> String -> Pattern
    textDeriv Context
    cx Pattern
    p String
    s1
                         then Pattern
    Empty
                         else String -> Pattern
    notAllowed
                                  ( "Any value except " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                                    String -> String
    forall a. Show a => a -> String
    show (Pattern -> String
    forall a. Show a => a -> String
    show Pattern
    p) String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                                    " expected, but value " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                                    String -> String
    forall a. Show a => a -> String
    show (String -> String
    forall a. Show a => a -> String
    show String
    s1) String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                                    " found"
                                  )
          Just errStr :: String
    errStr -> String -> Pattern
    notAllowed String
    errStr

    textDeriv cx :: Context
    cx (List p :: Pattern
    p) s :: String
    s
        = if Pattern -> Bool
    nullable (Context -> Pattern -> [String] -> Pattern
    listDeriv Context
    cx Pattern
    p (String -> [String]
    words String
    s))
          then Pattern
    Empty
          else String -> Pattern
    notAllowed
                   ( "List with value(s) " 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]
    ++
                     " expected, but value(s) " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                     [String] -> String
    formatStringListQuot (String -> [String]
    words String
    s) String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                     " found"
                   )

    textDeriv _ n :: Pattern
    n@(NotAllowed _) _
        = Pattern
    n

    textDeriv _ p :: Pattern
    p s :: String
    s
        = String -> Pattern
    notAllowed
          ( "Pattern " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    forall a. Show a => a -> String
    show (Pattern -> String
    getPatternName Pattern
    p) String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
            " expected, but text " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    forall a. Show a => a -> String
    show String
    s String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " 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 :: Context -> Pattern -> [String] -> Pattern
    listDeriv _ !Pattern
    p []
        = Pattern
    p

    listDeriv cx :: Context
    cx !Pattern
    p (x :: String
    x:xs :: [String]
    xs)
        = Context -> Pattern -> [String] -> Pattern
    listDeriv Context
    cx (Context -> Pattern -> String -> Pattern
    textDeriv Context
    cx Pattern
    p String
    x) [String]
    xs

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

    startTagOpenDeriv :: Pattern -> QName -> Pattern

    startTagOpenDeriv :: Pattern -> QName -> Pattern
    startTagOpenDeriv (Choice p1 :: Pattern
    p1 p2 :: Pattern
    p2) qn :: QName
    qn
        = Pattern -> Pattern -> Pattern
    choice (Pattern -> QName -> Pattern
    startTagOpenDeriv Pattern
    p1 QName
    qn) (Pattern -> QName -> Pattern
    startTagOpenDeriv Pattern
    p2 QName
    qn)

    startTagOpenDeriv (Element nc :: NameClass
    nc p :: Pattern
    p) qn :: QName
    qn
        | NameClass -> QName -> Bool
    contains NameClass
    nc QName
    qn
            = Pattern -> Pattern -> Pattern
    after Pattern
    p Pattern
    Empty
        | Bool
    otherwise
            = String -> Pattern
    notAllowed (String -> Pattern) -> String -> Pattern
    forall a b. (a -> b) -> a -> b
    $
              "Element with name " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ NameClass -> String
    nameClassToString NameClass
    nc String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                " expected, but " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ QName -> String
    universalName QName
    qn String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " found"

    startTagOpenDeriv (Interleave p1 :: Pattern
    p1 p2 :: Pattern
    p2) qn :: QName
    qn
        = Pattern -> Pattern -> Pattern
    choice
          ((Pattern -> Pattern) -> Pattern -> Pattern
    applyAfter ((Pattern -> Pattern -> Pattern) -> Pattern -> Pattern -> Pattern
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip Pattern -> Pattern -> Pattern
    interleave Pattern
    p2) (Pattern -> QName -> Pattern
    startTagOpenDeriv Pattern
    p1 QName
    qn))
          ((Pattern -> Pattern) -> Pattern -> Pattern
    applyAfter (Pattern -> Pattern -> Pattern
    interleave Pattern
    p1) (Pattern -> QName -> Pattern
    startTagOpenDeriv Pattern
    p2 QName
    qn))

    startTagOpenDeriv (OneOrMore p :: Pattern
    p) qn :: QName
    qn
        = (Pattern -> Pattern) -> Pattern -> Pattern
    applyAfter
          ((Pattern -> Pattern -> Pattern) -> Pattern -> Pattern -> Pattern
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip Pattern -> Pattern -> Pattern
    group (Pattern -> Pattern -> Pattern
    choice (Pattern -> Pattern
    OneOrMore Pattern
    p) Pattern
    Empty))
          (Pattern -> QName -> Pattern
    startTagOpenDeriv Pattern
    p QName
    qn)

    startTagOpenDeriv (Group p1 :: Pattern
    p1 p2 :: Pattern
    p2) qn :: QName
    qn
        = let
          x :: Pattern
    x = (Pattern -> Pattern) -> Pattern -> Pattern
    applyAfter ((Pattern -> Pattern -> Pattern) -> Pattern -> Pattern -> Pattern
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip Pattern -> Pattern -> Pattern
    group Pattern
    p2) (Pattern -> QName -> Pattern
    startTagOpenDeriv Pattern
    p1 QName
    qn)
          in
          if Pattern -> Bool
    nullable Pattern
    p1
          then Pattern -> Pattern -> Pattern
    choice Pattern
    x (Pattern -> QName -> Pattern
    startTagOpenDeriv Pattern
    p2 QName
    qn)
          else Pattern
    x

    startTagOpenDeriv (After p1 :: Pattern
    p1 p2 :: Pattern
    p2) qn :: QName
    qn
        = (Pattern -> Pattern) -> Pattern -> Pattern
    applyAfter ((Pattern -> Pattern -> Pattern) -> Pattern -> Pattern -> Pattern
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip Pattern -> Pattern -> Pattern
    after Pattern
    p2) (Pattern -> QName -> Pattern
    startTagOpenDeriv Pattern
    p1 QName
    qn)

    startTagOpenDeriv n :: Pattern
    n@(NotAllowed _) _
        = Pattern
    n

    startTagOpenDeriv p :: Pattern
    p qn :: QName
    qn
        = String -> Pattern
    notAllowed ( Pattern -> String
    forall a. Show a => a -> String
    show Pattern
    p String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " expected, but Element " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ QName -> String
    universalName QName
    qn String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " 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 :: Context -> Pattern -> [XmlTree] -> Pattern
    attsDeriv _ !Pattern
    p []
        = Pattern
    p
    attsDeriv cx :: Context
    cx !Pattern
    p (t :: XmlTree
    t : ts :: [XmlTree]
    ts)
        | XmlTree -> Bool
    forall a. XmlNode a => a -> Bool
    XN.isAttr XmlTree
    t
            = Context -> Pattern -> [XmlTree] -> Pattern
    attsDeriv Context
    cx (Context -> Pattern -> XmlTree -> Pattern
    attDeriv{- ' -} Context
    cx Pattern
    p XmlTree
    t) [XmlTree]
    ts
        | Bool
    otherwise
            = String -> Pattern
    notAllowed "Call to attsDeriv with wrong arguments"

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

    attDeriv :: Context -> Pattern -> XmlTree -> Pattern
    attDeriv cx :: Context
    cx (After p1 :: Pattern
    p1 p2 :: Pattern
    p2) att :: XmlTree
    att
        = Pattern -> Pattern -> Pattern
    after (Context -> Pattern -> XmlTree -> Pattern
    attDeriv Context
    cx Pattern
    p1 XmlTree
    att) Pattern
    p2

    attDeriv cx :: Context
    cx (Choice p1 :: Pattern
    p1 p2 :: Pattern
    p2) att :: XmlTree
    att
        = Pattern -> Pattern -> Pattern
    choice (Context -> Pattern -> XmlTree -> Pattern
    attDeriv Context
    cx Pattern
    p1 XmlTree
    att) (Context -> Pattern -> XmlTree -> Pattern
    attDeriv Context
    cx Pattern
    p2 XmlTree
    att)

    attDeriv cx :: Context
    cx (Group p1 :: Pattern
    p1 p2 :: Pattern
    p2) att :: XmlTree
    att
        = Pattern -> Pattern -> Pattern
    choice
          (Pattern -> Pattern -> Pattern
    group (Context -> Pattern -> XmlTree -> Pattern
    attDeriv Context
    cx Pattern
    p1 XmlTree
    att) Pattern
    p2)
          (Pattern -> Pattern -> Pattern
    group Pattern
    p1 (Context -> Pattern -> XmlTree -> Pattern
    attDeriv Context
    cx Pattern
    p2 XmlTree
    att))

    attDeriv cx :: Context
    cx (Interleave p1 :: Pattern
    p1 p2 :: Pattern
    p2) att :: XmlTree
    att
        = Pattern -> Pattern -> Pattern
    choice
          (Pattern -> Pattern -> Pattern
    interleave (Context -> Pattern -> XmlTree -> Pattern
    attDeriv Context
    cx Pattern
    p1 XmlTree
    att) Pattern
    p2)
          (Pattern -> Pattern -> Pattern
    interleave Pattern
    p1 (Context -> Pattern -> XmlTree -> Pattern
    attDeriv Context
    cx Pattern
    p2 XmlTree
    att))

    attDeriv cx :: Context
    cx (OneOrMore p :: Pattern
    p) att :: XmlTree
    att
        = Pattern -> Pattern -> Pattern
    group
          (Context -> Pattern -> XmlTree -> Pattern
    attDeriv Context
    cx Pattern
    p XmlTree
    att)
          (Pattern -> Pattern -> Pattern
    choice (Pattern -> Pattern
    OneOrMore Pattern
    p) Pattern
    Empty)

    attDeriv cx :: Context
    cx (Attribute nc :: NameClass
    nc p :: Pattern
    p) att :: XmlTree
    att
        | Bool
    isa
          Bool -> Bool -> Bool
    &&
          Bool -> Bool
    not (NameClass -> QName -> Bool
    contains NameClass
    nc QName
    qn)
            = String -> Pattern
    notAllowed1 (String -> Pattern) -> String -> Pattern
    forall a b. (a -> b) -> a -> b
    $
              "Attribute with name " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ NameClass -> String
    nameClassToString NameClass
    nc
              String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " expected, but " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ QName -> String
    universalName QName
    qn String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " found"
        | Bool
    isa
          Bool -> Bool -> Bool
    &&
          ( ( Pattern -> Bool
    nullable Pattern
    p
              Bool -> Bool -> Bool
    &&
              String -> Bool
    whitespace String
    val
            )
            Bool -> Bool -> Bool
    || Pattern -> Bool
    nullable Pattern
    p'
          )
            = Pattern
    Empty
        | Bool
    isa
            = Pattern -> Pattern
    err' Pattern
    p'
        where
        isa :: Bool
    isa =            XmlTree -> Bool
    forall a. XmlNode a => a -> Bool
    XN.isAttr      (XmlTree -> Bool) -> XmlTree -> Bool
    forall a b. (a -> b) -> a -> b
    $ XmlTree
    att
        qn :: QName
    qn  = Maybe QName -> QName
    forall a. HasCallStack => Maybe a -> a
    fromJust (Maybe QName -> QName)
    -> (XmlTree -> Maybe QName) -> XmlTree -> QName
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . XmlTree -> Maybe QName
    forall a. XmlNode a => a -> Maybe QName
    XN.getAttrName (XmlTree -> QName) -> XmlTree -> QName
    forall a b. (a -> b) -> a -> b
    $ XmlTree
    att
        av :: [XmlTree]
    av  =            XmlTree -> [XmlTree]
    forall (t :: * -> *) a. Tree t => t a -> [t a]
    XN.getChildren (XmlTree -> [XmlTree]) -> XmlTree -> [XmlTree]
    forall a b. (a -> b) -> a -> b
    $ XmlTree
    att
        val :: String
    val = [XmlTree] -> String
    showXts [XmlTree]
    av
        p' :: Pattern
    p'  = Context -> Pattern -> String -> Pattern
    textDeriv Context
    cx Pattern
    p String
    val

        err' :: Pattern -> Pattern
    err' (NotAllowed (ErrMsg _l :: Int
    _l es :: [String]
    es))
            = String -> Pattern
    err'' (": " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ [String] -> String
    forall a. [a] -> a
    head [String]
    es)
        err' _
            = String -> Pattern
    err'' ""
        err'' :: String -> Pattern
    err'' e :: String
    e
            = String -> Pattern
    notAllowed2 (String -> Pattern) -> String -> Pattern
    forall a b. (a -> b) -> a -> b
    $
              "Attribute value \"" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    val String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
              "\" does not match datatype spec " 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
    e

    attDeriv _ n :: Pattern
    n@(NotAllowed _) _
        = Pattern
    n

    attDeriv _ _p :: Pattern
    _p att :: XmlTree
    att
        = String -> Pattern
    notAllowed (String -> Pattern) -> String -> Pattern
    forall a b. (a -> b) -> a -> b
    $
          "No matching pattern for attribute '" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++  [XmlTree] -> String
    showXts [XmlTree
    att] String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "' found"

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

    startTagCloseDeriv :: Pattern -> Pattern

    startTagCloseDeriv :: Pattern -> Pattern
    startTagCloseDeriv (After p1 :: Pattern
    p1 p2 :: Pattern
    p2)
        = Pattern -> Pattern -> Pattern
    after (Pattern -> Pattern
    startTagCloseDeriv Pattern
    p1) Pattern
    p2

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

    startTagCloseDeriv (Group p1 :: Pattern
    p1 p2 :: Pattern
    p2)
        = Pattern -> Pattern -> Pattern
    group
          (Pattern -> Pattern
    startTagCloseDeriv Pattern
    p1)
          (Pattern -> Pattern
    startTagCloseDeriv Pattern
    p2)

    startTagCloseDeriv (Interleave p1 :: Pattern
    p1 p2 :: Pattern
    p2)
        = Pattern -> Pattern -> Pattern
    interleave
          (Pattern -> Pattern
    startTagCloseDeriv Pattern
    p1)
          (Pattern -> Pattern
    startTagCloseDeriv Pattern
    p2)

    startTagCloseDeriv (OneOrMore p :: Pattern
    p)
        = Pattern -> Pattern
    oneOrMore (Pattern -> Pattern
    startTagCloseDeriv Pattern
    p)

    startTagCloseDeriv (Attribute nc :: NameClass
    nc _)
        = String -> Pattern
    notAllowed1 (String -> Pattern) -> String -> Pattern
    forall a b. (a -> b) -> a -> b
    $
          "Attribut with name, " 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]
    ++
          " expected, but no more attributes found"

    startTagCloseDeriv p :: Pattern
    p
        = Pattern
    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 :: Context -> Pattern -> [XmlTree] -> Pattern
    childrenDeriv _cx :: Context
    _cx p :: Pattern
    p@(NotAllowed _) _
        = Pattern
    p

    childrenDeriv cx :: Context
    cx p :: Pattern
    p []
        = Context -> Pattern -> [XmlTree] -> Pattern
    childrenDeriv Context
    cx Pattern
    p [String -> XmlTree
    forall a. XmlNode a => String -> a
    XN.mkText ""]

    childrenDeriv cx :: Context
    cx p :: Pattern
    p [tt :: XmlTree
    tt]
        | Bool
    ist
          Bool -> Bool -> Bool
    &&
          String -> Bool
    whitespace String
    s
            = Pattern -> Pattern -> Pattern
    choice Pattern
    p Pattern
    p1
        | Bool
    ist
            = Pattern
    p1
        where
        ist :: Bool
    ist =            XmlTree -> Bool
    forall a. XmlNode a => a -> Bool
    XN.isText    XmlTree
    tt
        s :: String
    s   = Maybe String -> String
    forall a. HasCallStack => Maybe a -> a
    fromJust (Maybe String -> String)
    -> (XmlTree -> Maybe String) -> XmlTree -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . XmlTree -> Maybe String
    forall a. XmlNode a => a -> Maybe String
    XN.getText (XmlTree -> String) -> XmlTree -> String
    forall a b. (a -> b) -> a -> b
    $ XmlTree
    tt
        p1 :: Pattern
    p1  = Context -> Pattern -> XmlTree -> Pattern
    childDeriv Context
    cx Pattern
    p XmlTree
    tt

    childrenDeriv cx :: Context
    cx p :: Pattern
    p children :: [XmlTree]
    children
        = Context -> Pattern -> [XmlTree] -> Pattern
    stripChildrenDeriv Context
    cx Pattern
    p [XmlTree]
    children

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

    stripChildrenDeriv cx :: Context
    cx !Pattern
    p (h :: XmlTree
    h:t :: [XmlTree]
    t)
        = Context -> Pattern -> [XmlTree] -> Pattern
    stripChildrenDeriv Context
    cx
          ( if XmlTree -> Bool
    strip XmlTree
    h
            then Pattern
    p
            else (Context -> Pattern -> XmlTree -> Pattern
    childDeriv Context
    cx Pattern
    p XmlTree
    h)
          ) [XmlTree]
    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 :: Pattern -> Pattern
    endTagDeriv (Choice p1 :: Pattern
    p1 p2 :: Pattern
    p2)
        = Pattern -> Pattern -> Pattern
    choice (Pattern -> Pattern
    endTagDeriv Pattern
    p1) (Pattern -> Pattern
    endTagDeriv Pattern
    p2)

    endTagDeriv (After p1 :: Pattern
    p1 p2 :: Pattern
    p2)
        | Pattern -> Bool
    nullable Pattern
    p1
            = Pattern
    p2
        | Bool
    otherwise
            = String -> Pattern
    notAllowed (String -> Pattern) -> String -> Pattern
    forall a b. (a -> b) -> a -> b
    $
              Pattern -> String
    forall a. Show a => a -> String
    show Pattern
    p1 String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " expected"

    endTagDeriv n :: Pattern
    n@(NotAllowed _)
        = Pattern
    n

    endTagDeriv _
        = String -> Pattern
    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 :: (Pattern -> Pattern) -> Pattern -> Pattern
    applyAfter f :: Pattern -> Pattern
    f (After p1 :: Pattern
    p1 p2 :: Pattern
    p2)      = Pattern -> Pattern -> Pattern
    after Pattern
    p1 (Pattern -> Pattern
    f Pattern
    p2)
    applyAfter f :: Pattern -> Pattern
    f (Choice p1 :: Pattern
    p1 p2 :: Pattern
    p2)     = Pattern -> Pattern -> Pattern
    choice ((Pattern -> Pattern) -> Pattern -> Pattern
    applyAfter Pattern -> Pattern
    f Pattern
    p1) ((Pattern -> Pattern) -> Pattern -> Pattern
    applyAfter Pattern -> Pattern
    f Pattern
    p2)
    applyAfter _ n :: Pattern
    n@(NotAllowed _)   = Pattern
    n
    applyAfter _ _                  = String -> Pattern
    notAllowed "Call to applyAfter with wrong arguments"

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

    -- mothers little helpers

    strip           :: XmlTree -> Bool
    strip :: XmlTree -> Bool
    strip           = Bool -> (String -> Bool) -> Maybe String -> Bool
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Bool
    False String -> Bool
    whitespace (Maybe String -> Bool)
    -> (XmlTree -> Maybe String) -> XmlTree -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . XmlTree -> Maybe String
    forall a. XmlNode a => a -> Maybe String
    XN.getText

    whitespace      :: String -> Bool
    whitespace :: String -> Bool
    whitespace      = (Char -> Bool) -> String -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all Char -> Bool
    isXmlSpaceChar

    showXts         :: XmlTrees -> String
    showXts :: [XmlTree] -> String
    showXts         = [String] -> String
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat ([String] -> String)
    -> ([XmlTree] -> [String]) -> [XmlTree] -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . LA [XmlTree] String -> [XmlTree] -> [String]
    forall a b. LA a b -> a -> [b]
    runLA (LA [XmlTree] XmlTree -> LA [XmlTree] String
    forall (a :: * -> * -> *) n.
    ArrowXml a =>
    a n XmlTree -> a n String
    xshow (LA [XmlTree] XmlTree -> LA [XmlTree] String)
    -> LA [XmlTree] XmlTree -> LA [XmlTree] String
    forall a b. (a -> b) -> a -> b
    $ ([XmlTree] -> [XmlTree]) -> LA [XmlTree] XmlTree
    forall (a :: * -> * -> *) b c. ArrowList a => (b -> [c]) -> a b c
    arrL [XmlTree] -> [XmlTree]
    forall a. a -> a
    id)

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