-- |
--
-- 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)