    -- |
    --
    -- Creates the 'Pattern' datastructure from a simplified Relax NG schema.
    -- The created datastructure is used in the validation algorithm
    -- (see also: "Text.XML.HXT.RelaxNG.Validation")

    module Text.XML.HXT.RelaxNG.CreatePattern
      ( createPatternFromXmlTree
      , createNameClass
      , firstChild
      , lastChild
      , module Text.XML.HXT.RelaxNG.PatternFunctions
      )
    where

    import Control.Arrow.ListArrows

    import Text.XML.HXT.DOM.Interface

    import Text.XML.HXT.Arrow.XmlArrow

    import Text.XML.HXT.RelaxNG.DataTypes
    import Text.XML.HXT.RelaxNG.BasicArrows
    import Text.XML.HXT.RelaxNG.PatternFunctions

    import Data.Maybe
        ( fromMaybe )

    import Data.List
        ( isPrefixOf )
    {-
    import qualified Debug.Trace as T
    -}
    -- ------------------------------------------------------------

    -- | Creates the 'Pattern' datastructure from a simplified Relax NG schema.

    createPatternFromXmlTree :: LA XmlTree Pattern
    createPatternFromXmlTree :: LA XmlTree Pattern
    createPatternFromXmlTree = (XmlTree -> Pattern) -> LA XmlTree Pattern
    forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
    arr XmlTree -> Pattern
    patternFromXmlTree

    patternFromXmlTree :: XmlTree -> Pattern
    patternFromXmlTree :: XmlTree -> Pattern
    patternFromXmlTree t :: XmlTree
    t = PatternEnv -> XmlTree -> Pattern
    patternFromXml PatternEnv
    env XmlTree
    t
       where env :: PatternEnv
    env = ((String, XmlTree) -> (String, Pattern))
    -> [(String, XmlTree)] -> PatternEnv
    forall a b. (a -> b) -> [a] -> [b]
    map ((XmlTree -> Pattern) -> (String, XmlTree) -> (String, Pattern)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap ((XmlTree -> Pattern) -> (String, XmlTree) -> (String, Pattern))
    -> (XmlTree -> Pattern) -> (String, XmlTree) -> (String, Pattern)
    forall a b. (a -> b) -> a -> b
    $ PatternEnv -> XmlTree -> Pattern
    patternFromXml PatternEnv
    env) [(String, XmlTree)]
    definitions
             definitions :: [(String, XmlTree)]
    definitions = LA XmlTree (String, XmlTree) -> XmlTree -> [(String, XmlTree)]
    forall a b. LA a b -> a -> [b]
    runLA LA XmlTree (String, XmlTree)
    createDefinitionList XmlTree
    t
             createDefinitionList :: LA XmlTree (String, XmlTree)
             createDefinitionList :: LA XmlTree (String, XmlTree)
    createDefinitionList = LA XmlTree XmlTree -> LA XmlTree XmlTree
    forall (a :: * -> * -> *) (t :: * -> *) b c.
    (ArrowTree a, Tree t) =>
    a (t b) c -> a (t b) c
    deep LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isRngDefine
                                    LA XmlTree XmlTree
    -> LA XmlTree (String, XmlTree) -> LA XmlTree (String, 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 String
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
    getRngAttrName LA XmlTree String
    -> LA XmlTree XmlTree -> LA XmlTree (String, 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)

    patternFromXml :: PatternEnv -> XmlTree -> Pattern
    patternFromXml :: PatternEnv -> XmlTree -> Pattern
    patternFromXml env :: PatternEnv
    env = [Pattern] -> Pattern
    forall a. [a] -> a
    head ([Pattern] -> Pattern)
    -> (XmlTree -> [Pattern]) -> XmlTree -> Pattern
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . LA XmlTree Pattern -> XmlTree -> [Pattern]
    forall a b. LA a b -> a -> [b]
    runLA (PatternEnv -> LA XmlTree Pattern
    createPatternFromXml PatternEnv
    env)

    -- | Transforms each XML-element to the corresponding pattern

    createPatternFromXml :: PatternEnv -> LA XmlTree Pattern
    createPatternFromXml :: PatternEnv -> LA XmlTree Pattern
    createPatternFromXml env :: PatternEnv
    env
     = [IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)]
    -> LA XmlTree Pattern
    forall (a :: * -> * -> *) b c d.
    ArrowIf a =>
    [IfThen (a b c) (a b d)] -> a b d
    choiceA
       [ LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isRoot          LA XmlTree XmlTree
    -> LA XmlTree Pattern
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)
    forall a b. a -> b -> IfThen a b
    :-> PatternEnv -> LA XmlTree Pattern
    processRoot PatternEnv
    env
       , LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isRngEmpty      LA XmlTree XmlTree
    -> LA XmlTree Pattern
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)
    forall a b. a -> b -> IfThen a b
    :-> Pattern -> LA XmlTree Pattern
    forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
    constA Pattern
    Empty
       , LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isRngNotAllowed LA XmlTree XmlTree
    -> LA XmlTree Pattern
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)
    forall a b. a -> b -> IfThen a b
    :-> LA XmlTree Pattern
    mkNotAllowed
       , LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isRngText       LA XmlTree XmlTree
    -> LA XmlTree Pattern
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)
    forall a b. a -> b -> IfThen a b
    :-> Pattern -> LA XmlTree Pattern
    forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
    constA Pattern
    Text
       , LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isRngChoice     LA XmlTree XmlTree
    -> LA XmlTree Pattern
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)
    forall a b. a -> b -> IfThen a b
    :-> PatternEnv -> LA XmlTree Pattern
    mkRelaxChoice PatternEnv
    env
       , LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isRngInterleave LA XmlTree XmlTree
    -> LA XmlTree Pattern
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)
    forall a b. a -> b -> IfThen a b
    :-> PatternEnv -> LA XmlTree Pattern
    mkRelaxInterleave PatternEnv
    env
       , LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isRngGroup      LA XmlTree XmlTree
    -> LA XmlTree Pattern
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)
    forall a b. a -> b -> IfThen a b
    :-> PatternEnv -> LA XmlTree Pattern
    mkRelaxGroup PatternEnv
    env
       , LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isRngOneOrMore  LA XmlTree XmlTree
    -> LA XmlTree Pattern
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)
    forall a b. a -> b -> IfThen a b
    :-> PatternEnv -> LA XmlTree Pattern
    mkRelaxOneOrMore PatternEnv
    env
       , LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isRngList       LA XmlTree XmlTree
    -> LA XmlTree Pattern
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)
    forall a b. a -> b -> IfThen a b
    :-> PatternEnv -> LA XmlTree Pattern
    mkRelaxList PatternEnv
    env
       , LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isRngData       LA XmlTree XmlTree
    -> LA XmlTree Pattern
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)
    forall a b. a -> b -> IfThen a b
    :-> PatternEnv -> LA XmlTree Pattern
    mkRelaxData PatternEnv
    env
       , LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isRngValue      LA XmlTree XmlTree
    -> LA XmlTree Pattern
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)
    forall a b. a -> b -> IfThen a b
    :-> LA XmlTree Pattern
    mkRelaxValue
       , LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isRngAttribute  LA XmlTree XmlTree
    -> LA XmlTree Pattern
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)
    forall a b. a -> b -> IfThen a b
    :-> PatternEnv -> LA XmlTree Pattern
    mkRelaxAttribute PatternEnv
    env
       , LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isRngElement    LA XmlTree XmlTree
    -> LA XmlTree Pattern
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)
    forall a b. a -> b -> IfThen a b
    :-> PatternEnv -> LA XmlTree Pattern
    mkRelaxElement PatternEnv
    env
       , LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isRngRef        LA XmlTree XmlTree
    -> LA XmlTree Pattern
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)
    forall a b. a -> b -> IfThen a b
    :-> PatternEnv -> LA XmlTree Pattern
    mkRelaxRef PatternEnv
    env
       , LA XmlTree XmlTree
    forall (a :: * -> * -> *) b. ArrowList a => a b b
    this            LA XmlTree XmlTree
    -> LA XmlTree Pattern
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)
    forall a b. a -> b -> IfThen a b
    :-> String -> LA XmlTree Pattern
    mkRelaxError "internal HXT RelaxNG error"
       ]

    processRoot :: PatternEnv -> LA XmlTree Pattern
    processRoot :: PatternEnv -> LA XmlTree Pattern
    processRoot env :: PatternEnv
    env
      = LA XmlTree XmlTree
    forall (a :: * -> * -> *) (t :: * -> *) b.
    (ArrowTree a, Tree t) =>
    a (t b) (t b)
    getChildren
        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
    >>>
        [IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)]
    -> LA XmlTree Pattern
    forall (a :: * -> * -> *) b c d.
    ArrowIf a =>
    [IfThen (a b c) (a b d)] -> a b d
    choiceA [
          LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isRngRelaxError LA XmlTree XmlTree
    -> LA XmlTree Pattern
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)
    forall a b. a -> b -> IfThen a b
    :-> (String -> LA XmlTree Pattern
    mkRelaxError (String -> LA XmlTree Pattern)
    -> LA XmlTree String -> LA XmlTree Pattern
    forall (a :: * -> * -> *) c b d.
    ArrowList a =>
    (c -> a b d) -> a b c -> a b d
    $< LA XmlTree String
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
    getRngAttrDescr),
          LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isRngGrammar    LA XmlTree XmlTree
    -> LA XmlTree Pattern
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)
    forall a b. a -> b -> IfThen a b
    :-> (PatternEnv -> LA XmlTree Pattern
    processGrammar PatternEnv
    env),
          LA XmlTree XmlTree
    forall (a :: * -> * -> *) b. ArrowList a => a b b
    this            LA XmlTree XmlTree
    -> LA XmlTree Pattern
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)
    forall a b. a -> b -> IfThen a b
    :-> (String -> LA XmlTree Pattern
    mkRelaxError "no grammar-pattern in schema")
        ]

    processGrammar :: PatternEnv -> LA XmlTree Pattern
    processGrammar :: PatternEnv -> LA XmlTree Pattern
    processGrammar env :: PatternEnv
    env
      = LA XmlTree XmlTree
    forall (a :: * -> * -> *) (t :: * -> *) b.
    (ArrowTree a, Tree t) =>
    a (t b) (t b)
    getChildren
        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
    >>>
        [IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)]
    -> LA XmlTree Pattern
    forall (a :: * -> * -> *) b c d.
    ArrowIf a =>
    [IfThen (a b c) (a b d)] -> a b d
    choiceA
        [ LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isRngDefine     LA XmlTree XmlTree
    -> LA XmlTree Pattern
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)
    forall a b. a -> b -> IfThen a b
    :-> LA XmlTree Pattern
    forall (a :: * -> * -> *) b c. ArrowList a => a b c
    none
        , LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isRngRelaxError LA XmlTree XmlTree
    -> LA XmlTree Pattern
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)
    forall a b. a -> b -> IfThen a b
    :-> (String -> LA XmlTree Pattern
    mkRelaxError (String -> LA XmlTree Pattern)
    -> LA XmlTree String -> LA XmlTree Pattern
    forall (a :: * -> * -> *) c b d.
    ArrowList a =>
    (c -> a b d) -> a b c -> a b d
    $< String -> LA XmlTree String
    forall (a :: * -> * -> *). ArrowXml a => String -> a XmlTree String
    getAttrValue "desc")
        , LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isRngStart      LA XmlTree XmlTree
    -> LA XmlTree Pattern
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)
    forall a b. a -> b -> IfThen a b
    :-> (LA XmlTree XmlTree
    forall (a :: * -> * -> *) (t :: * -> *) b.
    (ArrowTree a, Tree t) =>
    a (t b) (t b)
    getChildren 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
    >>> PatternEnv -> LA XmlTree Pattern
    createPatternFromXml PatternEnv
    env)
        , LA XmlTree XmlTree
    forall (a :: * -> * -> *) b. ArrowList a => a b b
    this            LA XmlTree XmlTree
    -> LA XmlTree Pattern
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)
    forall a b. a -> b -> IfThen a b
    :-> (String -> LA XmlTree Pattern
    mkRelaxError "no start-pattern in schema")
        ]

    {- |
      Transforms a ref-element.
      The value of the name-attribute is looked up in the environment list
      to find the corresponding define-pattern.
      Haskells lazy-evaluation is used to transform circular structures.
    -}
    mkRelaxRef :: PatternEnv -> LA XmlTree Pattern
    mkRelaxRef :: PatternEnv -> LA XmlTree Pattern
    mkRelaxRef e :: PatternEnv
    e
     = LA XmlTree String
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
    getRngAttrName
       LA XmlTree String -> LA String 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
    >>>
       (String -> Pattern) -> LA String Pattern
    forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
    arr (\n :: String
    n -> Pattern -> Maybe Pattern -> Pattern
    forall a. a -> Maybe a -> a
    fromMaybe (String -> Pattern
    notAllowed (String -> Pattern) -> String -> Pattern
    forall a b. (a -> b) -> a -> b
    $ "define-pattern with name " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    n String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " not found")
                  (Maybe Pattern -> Pattern) -> Maybe Pattern -> Pattern
    forall a b. (a -> b) -> a -> b
    $ String -> PatternEnv -> Maybe Pattern
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup String
    n PatternEnv
    e
           )
    {-
       where
     transformEnv :: [(String, XmlTree)] -> [(String, Pattern)]
     transformEnv env = [ (treeName, (transformEnvElem tree env)) | (treeName, tree) <- env]
     transformEnvElem :: XmlTree -> [(String, XmlTree)] -> Pattern
     transformEnvElem tree env = head $ runLA (createPatternFromXml env) tree
    -}

    -- | Transforms a notAllowed-element.
    mkNotAllowed :: LA XmlTree Pattern
    mkNotAllowed :: LA XmlTree Pattern
    mkNotAllowed = Pattern -> LA XmlTree Pattern
    forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
    constA (Pattern -> LA XmlTree Pattern) -> Pattern -> LA XmlTree Pattern
    forall a b. (a -> b) -> a -> b
    $ String -> Pattern
    notAllowed "notAllowed-pattern in Relax NG schema definition"

    -- | Creates an error message.
    mkRelaxError :: String -> LA XmlTree Pattern
    mkRelaxError :: String -> LA XmlTree Pattern
    mkRelaxError errStr :: String
    errStr
     = [IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)]
    -> LA XmlTree Pattern
    forall (a :: * -> * -> *) b c d.
    ArrowIf a =>
    [IfThen (a b c) (a b d)] -> a b d
    choiceA
       [ LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isRngRelaxError LA XmlTree XmlTree
    -> LA XmlTree Pattern
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)
    forall a b. a -> b -> IfThen a b
    :-> (LA XmlTree String
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
    getRngAttrDescr LA XmlTree String -> LA String 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
    >>> (String -> Pattern) -> LA String Pattern
    forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
    arr String -> Pattern
    notAllowed)
       , LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isElem  LA XmlTree XmlTree
    -> LA XmlTree Pattern
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)
    forall a b. a -> b -> IfThen a b
    :-> ( LA XmlTree String
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
    getName
                       LA XmlTree String -> LA String 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
    >>>
                       (String -> Pattern) -> LA String Pattern
    forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
    arr (\n :: String
    n -> String -> Pattern
    notAllowed (String -> Pattern) -> String -> Pattern
    forall a b. (a -> b) -> a -> b
    $ "Pattern " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    n String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                                               " is not allowed in Relax NG schema" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                                               " (" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    errStr String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ ")"
                           )
                     )
       , LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isAttr  LA XmlTree XmlTree
    -> LA XmlTree Pattern
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)
    forall a b. a -> b -> IfThen a b
    :-> ( LA XmlTree String
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
    getName
                       LA XmlTree String -> LA String 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
    >>>
                       (String -> Pattern) -> LA String Pattern
    forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
    arr (\n :: String
    n -> String -> Pattern
    notAllowed (String -> Pattern) -> String -> Pattern
    forall a b. (a -> b) -> a -> b
    $ "Attribute " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    n String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                                               " is not allowed in Relax NG schema"
                           )
                     )
       , LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isError LA XmlTree XmlTree
    -> LA XmlTree Pattern
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)
    forall a b. a -> b -> IfThen a b
    :-> ( LA XmlTree String
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
    getErrorMsg LA XmlTree String -> LA String 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
    >>> (String -> Pattern) -> LA String Pattern
    forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
    arr String -> Pattern
    notAllowed )

       , LA XmlTree XmlTree
    forall (a :: * -> * -> *) b. ArrowList a => a b b
    this    LA XmlTree XmlTree
    -> LA XmlTree Pattern
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)
    forall a b. a -> b -> IfThen a b
    :-> (XmlTree -> Pattern) -> LA XmlTree Pattern
    forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
    arr ( \e :: XmlTree
    e -> String -> Pattern
    notAllowed (String -> Pattern) -> String -> Pattern
    forall a b. (a -> b) -> a -> b
    $ if String
    errStr String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    /= ""
                                              then String
    errStr
                                              else "Can't create pattern from " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ XmlTree -> String
    forall a. Show a => a -> String
    show XmlTree
    e)
       ]

    -- | Transforms a choice-element.
    mkRelaxChoice :: PatternEnv -> LA XmlTree Pattern
    mkRelaxChoice :: PatternEnv -> LA XmlTree Pattern
    mkRelaxChoice env :: PatternEnv
    env
        = LA XmlTree XmlTree
    -> LA XmlTree Pattern -> LA XmlTree Pattern -> LA XmlTree Pattern
    forall (a :: * -> * -> *) b c d.
    ArrowIf a =>
    a b c -> a b d -> a b d -> a b d
    ifA ( LA XmlTree XmlTree
    forall (a :: * -> * -> *) (t :: * -> *) b.
    (ArrowTree a, Tree t) =>
    a (t b) (t b)
    getChildren LA XmlTree XmlTree
    -> ([XmlTree] -> [XmlTree]) -> LA XmlTree XmlTree
    forall (a :: * -> * -> *) b c d.
    ArrowList a =>
    a b c -> ([c] -> [d]) -> a b d
    >>.
                ( \ l :: [XmlTree]
    l -> if [XmlTree] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [XmlTree]
    l Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == 1 then [XmlTree]
    l else [] )
              )
          ( PatternEnv -> LA XmlTree Pattern
    createPatternFromXml PatternEnv
    env )
          ( PatternEnv -> LA XmlTree (Pattern, Pattern)
    getTwoChildrenPattern PatternEnv
    env LA XmlTree (Pattern, Pattern)
    -> LA (Pattern, Pattern) 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
    >>> (Pattern -> Pattern -> Pattern) -> LA (Pattern, Pattern) Pattern
    forall (a :: * -> * -> *) b1 b2 c.
    ArrowList a =>
    (b1 -> b2 -> c) -> a (b1, b2) c
    arr2 Pattern -> Pattern -> Pattern
    Choice )

    -- | Transforms a interleave-element.
    mkRelaxInterleave :: PatternEnv -> LA XmlTree Pattern
    mkRelaxInterleave :: PatternEnv -> LA XmlTree Pattern
    mkRelaxInterleave env :: PatternEnv
    env
        = PatternEnv -> LA XmlTree (Pattern, Pattern)
    getTwoChildrenPattern PatternEnv
    env
          LA XmlTree (Pattern, Pattern)
    -> LA (Pattern, Pattern) 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
    >>>
          (Pattern -> Pattern -> Pattern) -> LA (Pattern, Pattern) Pattern
    forall (a :: * -> * -> *) b1 b2 c.
    ArrowList a =>
    (b1 -> b2 -> c) -> a (b1, b2) c
    arr2 Pattern -> Pattern -> Pattern
    Interleave

    -- | Transforms a group-element.
    mkRelaxGroup :: PatternEnv -> LA XmlTree Pattern
    mkRelaxGroup :: PatternEnv -> LA XmlTree Pattern
    mkRelaxGroup env :: PatternEnv
    env
        = PatternEnv -> LA XmlTree (Pattern, Pattern)
    getTwoChildrenPattern PatternEnv
    env
          LA XmlTree (Pattern, Pattern)
    -> LA (Pattern, Pattern) 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
    >>>
          (Pattern -> Pattern -> Pattern) -> LA (Pattern, Pattern) Pattern
    forall (a :: * -> * -> *) b1 b2 c.
    ArrowList a =>
    (b1 -> b2 -> c) -> a (b1, b2) c
    arr2 Pattern -> Pattern -> Pattern
    Group

    -- | Transforms a oneOrMore-element.
    mkRelaxOneOrMore :: PatternEnv -> LA XmlTree Pattern
    mkRelaxOneOrMore :: PatternEnv -> LA XmlTree Pattern
    mkRelaxOneOrMore env :: PatternEnv
    env
        = PatternEnv -> LA XmlTree Pattern
    getOneChildPattern PatternEnv
    env
          LA XmlTree Pattern -> LA Pattern 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
    >>>
          (Pattern -> Pattern) -> LA Pattern Pattern
    forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
    arr Pattern -> Pattern
    OneOrMore

    -- | Transforms a list-element.
    mkRelaxList :: PatternEnv -> LA XmlTree Pattern
    mkRelaxList :: PatternEnv -> LA XmlTree Pattern
    mkRelaxList env :: PatternEnv
    env
        = PatternEnv -> LA XmlTree Pattern
    getOneChildPattern PatternEnv
    env
          LA XmlTree Pattern -> LA Pattern 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
    >>>
          (Pattern -> Pattern) -> LA Pattern Pattern
    forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
    arr Pattern -> Pattern
    List

    -- | Transforms a data- or dataExcept-element.
    mkRelaxData :: PatternEnv -> LA XmlTree Pattern
    mkRelaxData :: PatternEnv -> LA XmlTree Pattern
    mkRelaxData env :: PatternEnv
    env
      = LA XmlTree XmlTree
    -> LA XmlTree Pattern -> LA XmlTree Pattern -> LA XmlTree Pattern
    forall (a :: * -> * -> *) b c d.
    ArrowIf a =>
    a b c -> a b d -> a b d -> a b d
    ifA (LA XmlTree XmlTree
    forall (a :: * -> * -> *) (t :: * -> *) b.
    (ArrowTree a, Tree t) =>
    a (t b) (t b)
    getChildren 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
    isRngExcept)
         (LA XmlTree (Datatype, (ParamList, Pattern))
    processDataExcept LA XmlTree (Datatype, (ParamList, Pattern))
    -> LA (Datatype, (ParamList, Pattern)) 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
    >>> (Datatype -> ParamList -> Pattern -> Pattern)
    -> LA (Datatype, (ParamList, Pattern)) Pattern
    forall (a :: * -> * -> *) b1 b2 b3 c.
    ArrowList a =>
    (b1 -> b2 -> b3 -> c) -> a (b1, (b2, b3)) c
    arr3 Datatype -> ParamList -> Pattern -> Pattern
    DataExcept)
         (LA XmlTree (Datatype, ParamList)
    processData LA XmlTree (Datatype, ParamList)
    -> LA (Datatype, ParamList) 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
    >>> (Datatype -> ParamList -> Pattern)
    -> LA (Datatype, ParamList) Pattern
    forall (a :: * -> * -> *) b1 b2 c.
    ArrowList a =>
    (b1 -> b2 -> c) -> a (b1, b2) c
    arr2 Datatype -> ParamList -> Pattern
    Data)
      where
      processDataExcept :: LA XmlTree (Datatype, (ParamList, Pattern))
      processDataExcept :: LA XmlTree (Datatype, (ParamList, Pattern))
    processDataExcept = LA XmlTree Datatype
    getDatatype LA XmlTree Datatype
    -> LA XmlTree (ParamList, Pattern)
    -> LA XmlTree (Datatype, (ParamList, Pattern))
    forall (a :: * -> * -> *) b c c'.
    Arrow a =>
    a b c -> a b c' -> a b (c, c')
    &&& LA XmlTree ParamList
    getParamList LA XmlTree ParamList
    -> LA XmlTree Pattern -> LA XmlTree (ParamList, Pattern)
    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
                            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 XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isRngExcept
                            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 XmlTree
    forall (a :: * -> * -> *) (t :: * -> *) b.
    (ArrowTree a, Tree t) =>
    a (t b) (t b)
    getChildren
                            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
    >>>
                            PatternEnv -> LA XmlTree Pattern
    createPatternFromXml PatternEnv
    env
                          )
      processData :: LA XmlTree (Datatype, ParamList)
      processData :: LA XmlTree (Datatype, ParamList)
    processData = LA XmlTree Datatype
    getDatatype LA XmlTree Datatype
    -> LA XmlTree ParamList -> LA XmlTree (Datatype, ParamList)
    forall (a :: * -> * -> *) b c c'.
    Arrow a =>
    a b c -> a b c' -> a b (c, c')
    &&& LA XmlTree ParamList
    getParamList
      getParamList :: LA XmlTree ParamList
      getParamList :: LA XmlTree ParamList
    getParamList = LA XmlTree Datatype -> LA XmlTree ParamList
    forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
    listA (LA XmlTree Datatype -> LA XmlTree ParamList)
    -> LA XmlTree Datatype -> LA XmlTree ParamList
    forall a b. (a -> b) -> a -> b
    $ LA XmlTree XmlTree
    forall (a :: * -> * -> *) (t :: * -> *) b.
    (ArrowTree a, Tree t) =>
    a (t b) (t b)
    getChildren
                             LA XmlTree XmlTree -> LA XmlTree Datatype -> LA XmlTree Datatype
    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
    isRngParam
                             LA XmlTree XmlTree -> LA XmlTree Datatype -> LA XmlTree Datatype
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                             (LA XmlTree String
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
    getRngAttrName LA XmlTree String -> LA XmlTree String -> LA XmlTree Datatype
    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 LA XmlTree XmlTree -> LA XmlTree String -> LA XmlTree String
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>> LA XmlTree String
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
    getText))

    -- | Transforms a value-element.
    mkRelaxValue :: LA XmlTree Pattern
    mkRelaxValue :: LA XmlTree Pattern
    mkRelaxValue = LA XmlTree Datatype
    getDatatype LA XmlTree Datatype
    -> LA XmlTree (String, Context)
    -> LA XmlTree (Datatype, (String, Context))
    forall (a :: * -> * -> *) b c c'.
    Arrow a =>
    a b c -> a b c' -> a b (c, c')
    &&& LA XmlTree String
    getValue LA XmlTree String
    -> LA XmlTree Context -> LA XmlTree (String, Context)
    forall (a :: * -> * -> *) b c c'.
    Arrow a =>
    a b c -> a b c' -> a b (c, c')
    &&& LA XmlTree Context
    getContext
                   LA XmlTree (Datatype, (String, Context))
    -> LA (Datatype, (String, Context)) 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
    >>>
                   (Datatype -> String -> Context -> Pattern)
    -> LA (Datatype, (String, Context)) Pattern
    forall (a :: * -> * -> *) b1 b2 b3 c.
    ArrowList a =>
    (b1 -> b2 -> b3 -> c) -> a (b1, (b2, b3)) c
    arr3 Datatype -> String -> Context -> Pattern
    Value
      where
      getContext :: LA XmlTree Context
      getContext :: LA XmlTree Context
    getContext = String -> LA XmlTree String
    forall (a :: * -> * -> *). ArrowXml a => String -> a XmlTree String
    getAttrValue String
    contextBaseAttr LA XmlTree String -> LA XmlTree ParamList -> LA XmlTree Context
    forall (a :: * -> * -> *) b c c'.
    Arrow a =>
    a b c -> a b c' -> a b (c, c')
    &&& LA XmlTree ParamList
    getMapping

      getMapping :: LA XmlTree [(Prefix, Uri)]
      getMapping :: LA XmlTree ParamList
    getMapping = LA XmlTree Datatype -> LA XmlTree ParamList
    forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
    listA (LA XmlTree Datatype -> LA XmlTree ParamList)
    -> LA XmlTree Datatype -> LA XmlTree ParamList
    forall a b. (a -> b) -> a -> b
    $ LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    getAttrl LA XmlTree XmlTree -> LA XmlTree Datatype -> LA XmlTree Datatype
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                           ( (LA XmlTree String
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
    getName LA XmlTree String -> LA String String -> LA 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) -> LA String String
    forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
    isA (String
    contextAttributes String -> String -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isPrefixOf`))
                             LA XmlTree String -> LA XmlTree Datatype -> LA XmlTree Datatype
    forall (a :: * -> * -> *) b c d.
    ArrowIf a =>
    a b c -> a b d -> a b d
    `guards`
                             ( (LA XmlTree String
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
    getName LA XmlTree String -> LA String String -> LA 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 -> String) -> LA String String
    forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
    arr (Int -> String -> String
    forall a. Int -> [a] -> [a]
    drop (Int -> String -> String) -> Int -> String -> String
    forall a b. (a -> b) -> a -> b
    $ String -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length String
    contextAttributes))
                               LA XmlTree String -> LA XmlTree String -> LA XmlTree Datatype
    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 LA XmlTree XmlTree -> LA XmlTree String -> LA XmlTree String
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>> LA XmlTree String
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
    getText)
                             )
                           )

      getValue :: LA XmlTree String
      getValue :: LA XmlTree String
    getValue = (LA XmlTree XmlTree
    forall (a :: * -> * -> *) (t :: * -> *) b.
    (ArrowTree a, Tree t) =>
    a (t b) (t b)
    getChildren LA XmlTree XmlTree -> LA XmlTree String -> LA XmlTree String
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>> LA XmlTree String
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
    getText) LA XmlTree String -> LA XmlTree String -> LA XmlTree String
    forall (a :: * -> * -> *) b c. ArrowIf a => a b c -> a b c -> a b c
    `orElse` (String -> LA XmlTree String
    forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
    constA "")

    getDatatype :: LA XmlTree Datatype
    getDatatype :: LA XmlTree Datatype
    getDatatype = LA XmlTree String
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
    getRngAttrDatatypeLibrary
                  LA XmlTree String -> LA XmlTree String -> LA XmlTree Datatype
    forall (a :: * -> * -> *) b c c'.
    Arrow a =>
    a b c -> a b c' -> a b (c, c')
    &&&
                  LA XmlTree String
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
    getRngAttrType

    -- | Transforms a attribute-element.
    -- The first child is a 'NameClass', the second (the last) one a pattern.

    mkRelaxAttribute :: PatternEnv -> LA XmlTree Pattern
    mkRelaxAttribute :: PatternEnv -> LA XmlTree Pattern
    mkRelaxAttribute env :: PatternEnv
    env
        = ( ( LA XmlTree XmlTree
    forall (a :: * -> * -> *) (t :: * -> *) b.
    (ArrowTree a, Tree t) =>
    a (t b) (t b)
    firstChild LA XmlTree XmlTree -> LA XmlTree NameClass -> LA XmlTree NameClass
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>> LA XmlTree NameClass
    createNameClass )
            LA XmlTree NameClass
    -> LA XmlTree Pattern -> LA XmlTree (NameClass, Pattern)
    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)
    lastChild 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
    >>> PatternEnv -> LA XmlTree Pattern
    createPatternFromXml PatternEnv
    env )
          )
          LA XmlTree (NameClass, Pattern)
    -> LA (NameClass, Pattern) 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
    >>>
          (NameClass -> Pattern -> Pattern)
    -> LA (NameClass, Pattern) Pattern
    forall (a :: * -> * -> *) b1 b2 c.
    ArrowList a =>
    (b1 -> b2 -> c) -> a (b1, b2) c
    arr2 NameClass -> Pattern -> Pattern
    Attribute

    -- | Transforms a element-element.
    -- The first child is a 'NameClass', the second (the last) one a pattern.
    mkRelaxElement :: PatternEnv -> LA XmlTree Pattern
    mkRelaxElement :: PatternEnv -> LA XmlTree Pattern
    mkRelaxElement env :: PatternEnv
    env
        = ( ( LA XmlTree XmlTree
    forall (a :: * -> * -> *) (t :: * -> *) b.
    (ArrowTree a, Tree t) =>
    a (t b) (t b)
    firstChild LA XmlTree XmlTree -> LA XmlTree NameClass -> LA XmlTree NameClass
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>> LA XmlTree NameClass
    createNameClass )
            LA XmlTree NameClass
    -> LA XmlTree Pattern -> LA XmlTree (NameClass, Pattern)
    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)
    lastChild 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
    >>> PatternEnv -> LA XmlTree Pattern
    createPatternFromXml PatternEnv
    env )
          )
          LA XmlTree (NameClass, Pattern)
    -> LA (NameClass, Pattern) 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
    >>>
          (NameClass -> Pattern -> Pattern)
    -> LA (NameClass, Pattern) Pattern
    forall (a :: * -> * -> *) b1 b2 c.
    ArrowList a =>
    (b1 -> b2 -> c) -> a (b1, b2) c
    arr2 NameClass -> Pattern -> Pattern
    Element

    -- | Creates a 'NameClass' from an \"anyName\"-, \"nsName\"- or  \"name\"-Pattern,
    createNameClass :: LA XmlTree NameClass
    createNameClass :: LA XmlTree NameClass
    createNameClass
        = [IfThen (LA XmlTree XmlTree) (LA XmlTree NameClass)]
    -> LA XmlTree NameClass
    forall (a :: * -> * -> *) b c d.
    ArrowIf a =>
    [IfThen (a b c) (a b d)] -> a b d
    choiceA
          [ LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isRngAnyName LA XmlTree XmlTree
    -> LA XmlTree NameClass
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree NameClass)
    forall a b. a -> b -> IfThen a b
    :-> LA XmlTree NameClass
    processAnyName
          , LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isRngNsName  LA XmlTree XmlTree
    -> LA XmlTree NameClass
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree NameClass)
    forall a b. a -> b -> IfThen a b
    :-> LA XmlTree NameClass
    processNsName
          , LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isRngName    LA XmlTree XmlTree
    -> LA XmlTree NameClass
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree NameClass)
    forall a b. a -> b -> IfThen a b
    :-> LA XmlTree NameClass
    processName
          , LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isRngChoice  LA XmlTree XmlTree
    -> LA XmlTree NameClass
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree NameClass)
    forall a b. a -> b -> IfThen a b
    :-> LA XmlTree NameClass
    processChoice
          , LA XmlTree XmlTree
    forall (a :: * -> * -> *) b. ArrowList a => a b b
    this         LA XmlTree XmlTree
    -> LA XmlTree NameClass
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree NameClass)
    forall a b. a -> b -> IfThen a b
    :-> LA XmlTree NameClass
    mkNameClassError
          ]
        where
        processAnyName :: LA XmlTree NameClass
        processAnyName :: LA XmlTree NameClass
    processAnyName
            = LA XmlTree XmlTree
    -> LA XmlTree NameClass
    -> LA XmlTree NameClass
    -> LA XmlTree NameClass
    forall (a :: * -> * -> *) b c d.
    ArrowIf a =>
    a b c -> a b d -> a b d -> a b d
    ifA (LA XmlTree XmlTree
    forall (a :: * -> * -> *) (t :: * -> *) b.
    (ArrowTree a, Tree t) =>
    a (t b) (t b)
    getChildren 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
    isRngExcept)
              ( LA XmlTree XmlTree
    forall (a :: * -> * -> *) (t :: * -> *) b.
    (ArrowTree a, Tree t) =>
    a (t b) (t b)
    getChildren
                LA XmlTree XmlTree -> LA XmlTree NameClass -> LA XmlTree NameClass
    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 :: * -> * -> *) (t :: * -> *) b.
    (ArrowTree a, Tree t) =>
    a (t b) (t b)
    getChildren
                LA XmlTree XmlTree -> LA XmlTree NameClass -> LA XmlTree NameClass
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>> LA XmlTree NameClass
    createNameClass
                LA XmlTree NameClass
    -> LA NameClass NameClass -> LA XmlTree NameClass
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>> (NameClass -> NameClass) -> LA NameClass NameClass
    forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
    arr NameClass -> NameClass
    AnyNameExcept
              )
             ( NameClass -> LA XmlTree NameClass
    forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
    constA NameClass
    AnyName )

        processNsName :: LA XmlTree NameClass
        processNsName :: LA XmlTree NameClass
    processNsName
            = LA XmlTree XmlTree
    -> LA XmlTree NameClass
    -> LA XmlTree NameClass
    -> LA XmlTree NameClass
    forall (a :: * -> * -> *) b c d.
    ArrowIf a =>
    a b c -> a b d -> a b d -> a b d
    ifA (LA XmlTree XmlTree
    forall (a :: * -> * -> *) (t :: * -> *) b.
    (ArrowTree a, Tree t) =>
    a (t b) (t b)
    getChildren 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
    isRngExcept)
              ( ( LA XmlTree String
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
    getRngAttrNs
                  LA XmlTree String
    -> LA XmlTree NameClass -> LA XmlTree (String, NameClass)
    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 LA XmlTree XmlTree -> LA XmlTree NameClass -> LA XmlTree NameClass
    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 :: * -> * -> *) (t :: * -> *) b.
    (ArrowTree a, Tree t) =>
    a (t b) (t b)
    getChildren LA XmlTree XmlTree -> LA XmlTree NameClass -> LA XmlTree NameClass
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>> LA XmlTree NameClass
    createNameClass )
                )
                LA XmlTree (String, NameClass)
    -> LA (String, NameClass) NameClass -> LA XmlTree NameClass
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                (String -> NameClass -> NameClass)
    -> LA (String, NameClass) NameClass
    forall (a :: * -> * -> *) b1 b2 c.
    ArrowList a =>
    (b1 -> b2 -> c) -> a (b1, b2) c
    arr2 String -> NameClass -> NameClass
    NsNameExcept
              )
              ( LA XmlTree String
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
    getRngAttrNs LA XmlTree String -> LA String NameClass -> LA XmlTree NameClass
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>> (String -> NameClass) -> LA String NameClass
    forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
    arr String -> NameClass
    NsName )

        processName :: LA XmlTree NameClass
        processName :: LA XmlTree NameClass
    processName
            = (LA XmlTree String
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
    getRngAttrNs LA XmlTree String -> LA XmlTree String -> LA XmlTree Datatype
    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 LA XmlTree XmlTree -> LA XmlTree String -> LA XmlTree String
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>> LA XmlTree String
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
    getText)) LA XmlTree Datatype
    -> LA Datatype NameClass -> LA XmlTree NameClass
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>> (String -> String -> NameClass) -> LA Datatype NameClass
    forall (a :: * -> * -> *) b1 b2 c.
    ArrowList a =>
    (b1 -> b2 -> c) -> a (b1, b2) c
    arr2 String -> String -> NameClass
    Name

        processChoice :: LA XmlTree NameClass
        processChoice :: LA XmlTree NameClass
    processChoice
            = ( ( LA XmlTree XmlTree
    forall (a :: * -> * -> *) (t :: * -> *) b.
    (ArrowTree a, Tree t) =>
    a (t b) (t b)
    firstChild LA XmlTree XmlTree -> LA XmlTree NameClass -> LA XmlTree NameClass
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>> LA XmlTree NameClass
    createNameClass )
                LA XmlTree NameClass
    -> LA XmlTree NameClass -> LA XmlTree (NameClass, NameClass)
    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)
    lastChild  LA XmlTree XmlTree -> LA XmlTree NameClass -> LA XmlTree NameClass
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>> LA XmlTree NameClass
    createNameClass )
              )
              LA XmlTree (NameClass, NameClass)
    -> LA (NameClass, NameClass) NameClass -> LA XmlTree NameClass
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
              (NameClass -> NameClass -> NameClass)
    -> LA (NameClass, NameClass) NameClass
    forall (a :: * -> * -> *) b1 b2 c.
    ArrowList a =>
    (b1 -> b2 -> c) -> a (b1, b2) c
    arr2 NameClass -> NameClass -> NameClass
    NameClassChoice

    mkNameClassError :: LA XmlTree NameClass
    mkNameClassError :: LA XmlTree NameClass
    mkNameClassError
        = [IfThen (LA XmlTree XmlTree) (LA XmlTree NameClass)]
    -> LA XmlTree NameClass
    forall (a :: * -> * -> *) b c d.
    ArrowIf a =>
    [IfThen (a b c) (a b d)] -> a b d
    choiceA [ LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isRngRelaxError
                            LA XmlTree XmlTree
    -> LA XmlTree NameClass
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree NameClass)
    forall a b. a -> b -> IfThen a b
    :-> ( LA XmlTree String
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
    getRngAttrDescr
                                  LA XmlTree String -> LA String NameClass -> LA XmlTree NameClass
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                                  (String -> NameClass) -> LA String NameClass
    forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
    arr String -> NameClass
    NCError
                             )
                  , LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isElem  LA XmlTree XmlTree
    -> LA XmlTree NameClass
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree NameClass)
    forall a b. a -> b -> IfThen a b
    :-> ( LA XmlTree String
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
    getName
                                  LA XmlTree String -> LA String NameClass -> LA XmlTree NameClass
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                                  (String -> NameClass) -> LA String NameClass
    forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
    arr (\n :: String
    n -> String -> NameClass
    NCError ("Can't create name class from element " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    n))
                                )
                  , LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isAttr  LA XmlTree XmlTree
    -> LA XmlTree NameClass
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree NameClass)
    forall a b. a -> b -> IfThen a b
    :-> ( LA XmlTree String
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
    getName
                                  LA XmlTree String -> LA String NameClass -> LA XmlTree NameClass
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                                  (String -> NameClass) -> LA String NameClass
    forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
    arr (\n :: String
    n -> String -> NameClass
    NCError ("Can't create name class from attribute: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    n))
                                )
                  , LA XmlTree XmlTree
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
    isError LA XmlTree XmlTree
    -> LA XmlTree NameClass
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree NameClass)
    forall a b. a -> b -> IfThen a b
    :-> ( LA XmlTree String
    forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
    getErrorMsg
                                  LA XmlTree String -> LA String NameClass -> LA XmlTree NameClass
    forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
    Category cat =>
    cat a b -> cat b c -> cat a c
    >>>
                                  (String -> NameClass) -> LA String NameClass
    forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
    arr String -> NameClass
    NCError
                                )
                  , LA XmlTree XmlTree
    forall (a :: * -> * -> *) b. ArrowList a => a b b
    this    LA XmlTree XmlTree
    -> LA XmlTree NameClass
    -> IfThen (LA XmlTree XmlTree) (LA XmlTree NameClass)
    forall a b. a -> b -> IfThen a b
    :-> ( (XmlTree -> NameClass) -> LA XmlTree NameClass
    forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
    arr (\e :: XmlTree
    e ->  String -> NameClass
    NCError (String -> NameClass) -> String -> NameClass
    forall a b. (a -> b) -> a -> b
    $ "Can't create name class from " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ XmlTree -> String
    forall a. Show a => a -> String
    show XmlTree
    e) )
                  ]

    getOneChildPattern :: PatternEnv -> LA XmlTree Pattern
    getOneChildPattern :: PatternEnv -> LA XmlTree Pattern
    getOneChildPattern env :: PatternEnv
    env
        = LA XmlTree XmlTree
    forall (a :: * -> * -> *) (t :: * -> *) b.
    (ArrowTree a, Tree t) =>
    a (t b) (t b)
    firstChild 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
    >>> PatternEnv -> LA XmlTree Pattern
    createPatternFromXml PatternEnv
    env

    getTwoChildrenPattern :: PatternEnv -> LA XmlTree (Pattern, Pattern)
    getTwoChildrenPattern :: PatternEnv -> LA XmlTree (Pattern, Pattern)
    getTwoChildrenPattern env :: PatternEnv
    env
        = ( PatternEnv -> LA XmlTree Pattern
    getOneChildPattern PatternEnv
    env )
            LA XmlTree Pattern
    -> LA XmlTree Pattern -> LA XmlTree (Pattern, Pattern)
    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)
    lastChild  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
    >>> PatternEnv -> LA XmlTree Pattern
    createPatternFromXml PatternEnv
    env )

    -- | Simple access arrows

    firstChild      :: (ArrowTree a, Tree t) => a (t b) (t b)
    firstChild :: a (t b) (t b)
    firstChild      = a (t b) (t b) -> a (t b) (t b)
    forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b c
    single a (t b) (t b)
    forall (a :: * -> * -> *) (t :: * -> *) b.
    (ArrowTree a, Tree t) =>
    a (t b) (t b)
    getChildren

    lastChild       :: (ArrowTree a, Tree t) => a (t b) (t b)
    lastChild :: a (t b) (t b)
    lastChild       = a (t b) (t b)
    forall (a :: * -> * -> *) (t :: * -> *) b.
    (ArrowTree a, Tree t) =>
    a (t b) (t b)
    getChildren a (t b) (t b) -> ([t b] -> [t b]) -> a (t b) (t b)
    forall (a :: * -> * -> *) b c d.
    ArrowList a =>
    a b c -> ([c] -> [d]) -> a b d
    >>. (Int -> [t b] -> [t b]
    forall a. Int -> [a] -> [a]
    take 1 ([t b] -> [t b]) -> ([t b] -> [t b]) -> [t b] -> [t b]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [t b] -> [t b]
    forall a. [a] -> [a]
    reverse)