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 )
createPatternFromXmlTree :: LA XmlTree Pattern
createPatternFromXmlTree :: LA XmlTree Pattern
createPatternFromXmlTree = (XmlTree -> Pattern) -> LA XmlTree Pattern
forall b c. (b -> c) -> LA b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr XmlTree -> Pattern
patternFromXmlTree
patternFromXmlTree :: XmlTree -> Pattern
patternFromXmlTree :: XmlTree -> Pattern
patternFromXmlTree 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 a b. (a -> b) -> (String, a) -> (String, b)
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 (t :: * -> *) b c. Tree t => LA (t b) c -> LA (t b) c
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 b c c'. LA b c -> LA b c' -> LA b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& LA XmlTree XmlTree
forall (t :: * -> *) b. Tree t => LA (t b) (t b)
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren)
patternFromXml :: PatternEnv -> XmlTree -> Pattern
patternFromXml :: PatternEnv -> XmlTree -> Pattern
patternFromXml PatternEnv
env = [Pattern] -> Pattern
forall a. HasCallStack => [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)
createPatternFromXml :: PatternEnv -> LA XmlTree Pattern
createPatternFromXml :: PatternEnv -> LA XmlTree Pattern
createPatternFromXml PatternEnv
env
= [IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)]
-> LA XmlTree Pattern
forall b c d. [IfThen (LA b c) (LA b d)] -> LA b d
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 c b. c -> LA b c
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 c b. c -> LA b c
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 b. LA b b
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 String
"internal HXT RelaxNG error"
]
processRoot :: PatternEnv -> LA XmlTree Pattern
processRoot :: PatternEnv -> LA XmlTree Pattern
processRoot PatternEnv
env
= LA XmlTree XmlTree
forall (t :: * -> *) b. Tree t => LA (t b) (t b)
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 b c d. [IfThen (LA b c) (LA b d)] -> LA b d
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 c b d. (c -> LA b d) -> LA b c -> LA b d
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 b. LA b b
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 String
"no grammar-pattern in schema")
]
processGrammar :: PatternEnv -> LA XmlTree Pattern
processGrammar :: PatternEnv -> LA XmlTree Pattern
processGrammar PatternEnv
env
= LA XmlTree XmlTree
forall (t :: * -> *) b. Tree t => LA (t b) (t b)
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 b c d. [IfThen (LA b c) (LA b d)] -> LA b d
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 b c. LA b c
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 c b d. (c -> LA b d) -> LA b c -> LA b d
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 String
"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 (t :: * -> *) b. Tree t => LA (t b) (t b)
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 b. LA b b
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 String
"no start-pattern in schema")
]
mkRelaxRef :: PatternEnv -> LA XmlTree Pattern
mkRelaxRef :: PatternEnv -> LA XmlTree Pattern
mkRelaxRef 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 b c. (b -> c) -> LA b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\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
$ String
"define-pattern with name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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
)
mkNotAllowed :: LA XmlTree Pattern
mkNotAllowed :: LA XmlTree Pattern
mkNotAllowed = Pattern -> LA XmlTree Pattern
forall c b. c -> LA b c
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 String
"notAllowed-pattern in Relax NG schema definition"
mkRelaxError :: String -> LA XmlTree Pattern
mkRelaxError :: String -> LA XmlTree Pattern
mkRelaxError String
errStr
= [IfThen (LA XmlTree XmlTree) (LA XmlTree Pattern)]
-> LA XmlTree Pattern
forall b c d. [IfThen (LA b c) (LA b d)] -> LA b d
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 b c. (b -> c) -> LA b c
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 b c. (b -> c) -> LA b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\String
n -> String -> Pattern
notAllowed (String -> Pattern) -> String -> Pattern
forall a b. (a -> b) -> a -> b
$ String
"Pattern " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
" is not allowed in Relax NG schema" String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
errStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
)
)
, 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 b c. (b -> c) -> LA b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\String
n -> String -> Pattern
notAllowed (String -> Pattern) -> String -> Pattern
forall a b. (a -> b) -> a -> b
$ String
"Attribute " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
" 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 b c. (b -> c) -> LA b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr String -> Pattern
notAllowed )
, LA XmlTree XmlTree
forall b. LA b b
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 b c. (b -> c) -> LA b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ( \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
/= String
""
then String
errStr
else String
"Can't create pattern from " String -> String -> String
forall a. [a] -> [a] -> [a]
++ XmlTree -> String
forall a. Show a => a -> String
show XmlTree
e)
]
mkRelaxChoice :: PatternEnv -> LA XmlTree Pattern
mkRelaxChoice :: PatternEnv -> LA XmlTree Pattern
mkRelaxChoice PatternEnv
env
= LA XmlTree XmlTree
-> LA XmlTree Pattern -> LA XmlTree Pattern -> LA XmlTree Pattern
forall b c d. LA b c -> LA b d -> LA b d -> LA b d
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d -> a b d
ifA ( LA XmlTree XmlTree
forall (t :: * -> *) b. Tree t => LA (t b) (t b)
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren LA XmlTree XmlTree
-> ([XmlTree] -> [XmlTree]) -> LA XmlTree XmlTree
forall b c d. LA b c -> ([c] -> [d]) -> LA b d
forall (a :: * -> * -> *) b c d.
ArrowList a =>
a b c -> ([c] -> [d]) -> a b d
>>.
( \ [XmlTree]
l -> if [XmlTree] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [XmlTree]
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
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 b1 b2 c. (b1 -> b2 -> c) -> LA (b1, b2) c
forall (a :: * -> * -> *) b1 b2 c.
ArrowList a =>
(b1 -> b2 -> c) -> a (b1, b2) c
arr2 Pattern -> Pattern -> Pattern
Choice )
mkRelaxInterleave :: PatternEnv -> LA XmlTree Pattern
mkRelaxInterleave :: PatternEnv -> LA XmlTree Pattern
mkRelaxInterleave 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 b1 b2 c. (b1 -> b2 -> c) -> LA (b1, b2) c
forall (a :: * -> * -> *) b1 b2 c.
ArrowList a =>
(b1 -> b2 -> c) -> a (b1, b2) c
arr2 Pattern -> Pattern -> Pattern
Interleave
mkRelaxGroup :: PatternEnv -> LA XmlTree Pattern
mkRelaxGroup :: PatternEnv -> LA XmlTree Pattern
mkRelaxGroup 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 b1 b2 c. (b1 -> b2 -> c) -> LA (b1, b2) c
forall (a :: * -> * -> *) b1 b2 c.
ArrowList a =>
(b1 -> b2 -> c) -> a (b1, b2) c
arr2 Pattern -> Pattern -> Pattern
Group
mkRelaxOneOrMore :: PatternEnv -> LA XmlTree Pattern
mkRelaxOneOrMore :: PatternEnv -> LA XmlTree Pattern
mkRelaxOneOrMore 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 b c. (b -> c) -> LA b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr Pattern -> Pattern
OneOrMore
mkRelaxList :: PatternEnv -> LA XmlTree Pattern
mkRelaxList :: PatternEnv -> LA XmlTree Pattern
mkRelaxList 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 b c. (b -> c) -> LA b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr Pattern -> Pattern
List
mkRelaxData :: PatternEnv -> LA XmlTree Pattern
mkRelaxData :: PatternEnv -> LA XmlTree Pattern
mkRelaxData PatternEnv
env
= LA XmlTree XmlTree
-> LA XmlTree Pattern -> LA XmlTree Pattern -> LA XmlTree Pattern
forall b c d. LA b c -> LA b d -> LA b d -> LA b d
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d -> a b d
ifA (LA XmlTree XmlTree
forall (t :: * -> *) b. Tree t => LA (t b) (t b)
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 b1 b2 b3 c. (b1 -> b2 -> b3 -> c) -> LA (b1, (b2, b3)) c
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 b1 b2 c. (b1 -> b2 -> c) -> LA (b1, b2) c
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 b c c'. LA b c -> LA b c' -> LA b (c, c')
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 b c c'. LA b c -> LA b c' -> LA b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&&
( LA XmlTree XmlTree
forall (t :: * -> *) b. Tree t => LA (t b) (t b)
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 (t :: * -> *) b. Tree t => LA (t b) (t b)
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 b c c'. LA b c -> LA b c' -> LA b (c, c')
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 b c. LA b c -> LA b [c]
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 (t :: * -> *) b. Tree t => LA (t b) (t b)
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 b c c'. LA b c -> LA b c' -> LA b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (LA XmlTree XmlTree
forall (t :: * -> *) b. Tree t => LA (t b) (t b)
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))
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 b c c'. LA b c -> LA b c' -> LA b (c, c')
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 b c c'. LA b c -> LA b c' -> LA b (c, c')
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 b1 b2 b3 c. (b1 -> b2 -> b3 -> c) -> LA (b1, (b2, b3)) c
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 b c c'. LA b c -> LA b c' -> LA b (c, c')
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 b c. LA b c -> LA b [c]
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 b. (b -> Bool) -> LA b b
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 b c d. LA b c -> LA b d -> LA b d
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 b c. (b -> c) -> LA b c
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 a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
contextAttributes))
LA XmlTree String -> LA XmlTree String -> LA XmlTree Datatype
forall b c c'. LA b c -> LA b c' -> LA b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&&
(LA XmlTree XmlTree
forall (t :: * -> *) b. Tree t => LA (t b) (t b)
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 (t :: * -> *) b. Tree t => LA (t b) (t b)
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 b c. LA b c -> LA b c -> LA b c
forall (a :: * -> * -> *) b c. ArrowIf a => a b c -> a b c -> a b c
`orElse` (String -> LA XmlTree String
forall c b. c -> LA b c
forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
constA String
"")
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 b c c'. LA b c -> LA b c' -> LA b (c, c')
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
mkRelaxAttribute :: PatternEnv -> LA XmlTree Pattern
mkRelaxAttribute :: PatternEnv -> LA XmlTree Pattern
mkRelaxAttribute 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 b c c'. LA b c -> LA b c' -> LA b (c, c')
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 b1 b2 c. (b1 -> b2 -> c) -> LA (b1, b2) c
forall (a :: * -> * -> *) b1 b2 c.
ArrowList a =>
(b1 -> b2 -> c) -> a (b1, b2) c
arr2 NameClass -> Pattern -> Pattern
Attribute
mkRelaxElement :: PatternEnv -> LA XmlTree Pattern
mkRelaxElement :: PatternEnv -> LA XmlTree Pattern
mkRelaxElement 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 b c c'. LA b c -> LA b c' -> LA b (c, c')
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 b1 b2 c. (b1 -> b2 -> c) -> LA (b1, b2) c
forall (a :: * -> * -> *) b1 b2 c.
ArrowList a =>
(b1 -> b2 -> c) -> a (b1, b2) c
arr2 NameClass -> Pattern -> Pattern
Element
createNameClass :: LA XmlTree NameClass
createNameClass :: LA XmlTree NameClass
createNameClass
= [IfThen (LA XmlTree XmlTree) (LA XmlTree NameClass)]
-> LA XmlTree NameClass
forall b c d. [IfThen (LA b c) (LA b d)] -> LA b d
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 b. LA b b
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 b c d. LA b c -> LA b d -> LA b d -> LA b d
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d -> a b d
ifA (LA XmlTree XmlTree
forall (t :: * -> *) b. Tree t => LA (t b) (t b)
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 (t :: * -> *) b. Tree t => LA (t b) (t b)
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 (t :: * -> *) b. Tree t => LA (t b) (t b)
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 b c. (b -> c) -> LA b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr NameClass -> NameClass
AnyNameExcept
)
( NameClass -> LA XmlTree NameClass
forall c b. c -> LA b c
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 b c d. LA b c -> LA b d -> LA b d -> LA b d
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d -> a b d
ifA (LA XmlTree XmlTree
forall (t :: * -> *) b. Tree t => LA (t b) (t b)
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 b c c'. LA b c -> LA b c' -> LA b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&&
( LA XmlTree XmlTree
forall (t :: * -> *) b. Tree t => LA (t b) (t b)
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 (t :: * -> *) b. Tree t => LA (t b) (t b)
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 b1 b2 c. (b1 -> b2 -> c) -> LA (b1, b2) c
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 b c. (b -> c) -> LA b c
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 b c c'. LA b c -> LA b c' -> LA b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (LA XmlTree XmlTree
forall (t :: * -> *) b. Tree t => LA (t b) (t b)
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 b1 b2 c. (b1 -> b2 -> c) -> LA (b1, b2) c
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 b c c'. LA b c -> LA b c' -> LA b (c, c')
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 b1 b2 c. (b1 -> b2 -> c) -> LA (b1, b2) c
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 b c d. [IfThen (LA b c) (LA b d)] -> LA b d
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 b c. (b -> c) -> LA b c
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 b c. (b -> c) -> LA b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\String
n -> String -> NameClass
NCError (String
"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 b c. (b -> c) -> LA b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\String
n -> String -> NameClass
NCError (String
"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 b c. (b -> c) -> LA b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr String -> NameClass
NCError
)
, LA XmlTree XmlTree
forall b. LA b b
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 b c. (b -> c) -> LA b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\XmlTree
e -> String -> NameClass
NCError (String -> NameClass) -> String -> NameClass
forall a b. (a -> b) -> a -> b
$ String
"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 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 PatternEnv
env
= ( PatternEnv -> LA XmlTree Pattern
getOneChildPattern PatternEnv
env )
LA XmlTree Pattern
-> LA XmlTree Pattern -> LA XmlTree (Pattern, Pattern)
forall b c c'. LA b c -> LA b c' -> LA b (c, c')
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 )
firstChild :: (ArrowTree a, Tree t) => a (t b) (t b)
firstChild :: forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
firstChild = a (t b) (t b) -> a (t b) (t b)
forall b c. a b c -> a b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b c
single a (t b) (t b)
forall (t :: * -> *) b. Tree t => 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 :: forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
lastChild = a (t b) (t b)
forall (t :: * -> *) b. Tree t => 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 b c d. a b c -> ([c] -> [d]) -> a b d
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 Int
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)