{-# LANGUAGE BangPatterns #-}
module Text.XML.HXT.RelaxNG.Validation
( validateWithRelax
, validateDocWithRelax
, validateRelax
, validateRelax'
, readForRelax
, normalizeForRelaxValidation
, contains
)
where
import Control.Arrow.ListArrows
import Data.Char.Properties.XMLCharProps (isXmlSpaceChar)
import Data.Maybe (fromJust)
import Text.XML.HXT.DOM.Interface
import qualified Text.XML.HXT.DOM.XmlNode as XN
import Text.XML.HXT.Arrow.Edit (canonicalizeAllNodes,
collapseAllXText)
import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.Arrow.ProcessDocument (getDocumentContents,
parseXmlDocument, propagateAndValidateNamespaces)
import Text.XML.HXT.Arrow.XmlState
import Text.XML.HXT.Arrow.XmlState.TypeDefs
import Text.XML.HXT.RelaxNG.CreatePattern
import Text.XML.HXT.RelaxNG.DataTypeLibraries
import Text.XML.HXT.RelaxNG.DataTypes
import Text.XML.HXT.RelaxNG.PatternToString
import Text.XML.HXT.RelaxNG.Utils (compareURI,
formatStringListQuot)
validateWithRelax :: IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
validateWithRelax :: IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
validateWithRelax IOSArrow XmlTree XmlTree
theSchema
= Int -> String -> IOSArrow XmlTree XmlTree
forall s b. Int -> String -> IOStateArrow s b b
traceMsg Int
2 String
"normalize document for validation"
IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
IOSArrow XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
normalizeForRelaxValidation
IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
Int -> String -> IOSArrow XmlTree XmlTree
forall s b. Int -> String -> IOStateArrow s b b
traceMsg Int
2 String
"start validation"
IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
( XmlTree -> IOSArrow XmlTree XmlTree
validateRelax (XmlTree -> IOSArrow XmlTree XmlTree)
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall c b d.
(c -> IOSLA (XIOState ()) b d)
-> IOSLA (XIOState ()) b c -> IOSLA (XIOState ()) b d
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< IOSArrow XmlTree XmlTree
theSchema )
normalizeForRelaxValidation :: ArrowXml a => a XmlTree XmlTree
normalizeForRelaxValidation :: forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
normalizeForRelaxValidation
= a XmlTree XmlTree -> a XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
a XmlTree XmlTree -> a XmlTree XmlTree
processTopDownWithAttrl
(
( a XmlTree XmlTree
forall b c. a b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none a XmlTree XmlTree -> a XmlTree String -> a XmlTree XmlTree
forall b c. a b b -> a b c -> a b b
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when`
( a XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isAttr
a XmlTree XmlTree -> a XmlTree String -> a XmlTree String
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
a XmlTree String
forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
getNamespaceUri
a XmlTree String -> a String String -> a XmlTree String
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
(String -> Bool) -> a String String
forall b. (b -> Bool) -> a b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA (String -> String -> Bool
compareURI String
xmlnsNamespace)
)
)
a XmlTree XmlTree -> a XmlTree XmlTree -> a XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
(a XmlTree XmlTree
forall b c. a b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none a XmlTree XmlTree -> a XmlTree XmlTree -> a XmlTree XmlTree
forall b c. a b b -> a b c -> a b b
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when` a XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isPi)
)
a XmlTree XmlTree -> a XmlTree XmlTree -> a XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
a XmlTree XmlTree
forall (a :: * -> * -> *). ArrowList a => a XmlTree XmlTree
collapseAllXText
validateDocWithRelax :: IOSArrow XmlTree XmlTree -> SysConfigList -> String -> IOSArrow XmlTree XmlTree
validateDocWithRelax :: IOSArrow XmlTree XmlTree
-> SysConfigList -> String -> IOSArrow XmlTree XmlTree
validateDocWithRelax IOSArrow XmlTree XmlTree
theSchema SysConfigList
config String
doc
= IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall s a b. IOStateArrow s a b -> IOStateArrow s a b
localSysEnv
( SysConfigList -> IOSArrow XmlTree XmlTree
forall s c. SysConfigList -> IOStateArrow s c c
configSysVars SysConfigList
config
IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
String -> IOSArrow XmlTree XmlTree
forall b. String -> IOSArrow b XmlTree
readForRelax String
doc
IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
validateWithRelax IOSArrow XmlTree XmlTree
theSchema
)
validateRelax :: XmlTree -> IOSArrow XmlTree XmlTree
validateRelax :: XmlTree -> IOSArrow XmlTree XmlTree
validateRelax XmlTree
rngSchema
= LA XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => LA b c -> a b c
fromLA (XmlTree -> LA XmlTree XmlTree
validateRelax' XmlTree
rngSchema)
IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
IOSArrow XmlTree XmlTree
forall s. IOStateArrow s XmlTree XmlTree
filterErrorMsg
validateRelax' :: XmlTree -> LA XmlTree XmlTree
validateRelax' :: XmlTree -> LA XmlTree XmlTree
validateRelax' XmlTree
rngSchema
= ( ( ( XmlTree -> LA XmlTree XmlTree
forall c b. c -> LA b c
forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
constA XmlTree
rngSchema
LA XmlTree XmlTree -> LA XmlTree Pattern -> LA XmlTree Pattern
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
LA XmlTree Pattern
createPatternFromXmlTree
)
LA XmlTree Pattern
-> LA XmlTree XmlTree -> LA XmlTree (Pattern, XmlTree)
forall 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 XmlTree -> LA XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem
)
)
LA XmlTree (Pattern, XmlTree)
-> LA (Pattern, XmlTree) XmlTree -> LA XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
(Pattern -> XmlTree -> Pattern) -> LA (Pattern, XmlTree) Pattern
forall 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 !XmlTree
xmlDoc -> Context -> Pattern -> XmlTree -> Pattern
childDeriv (String
"", []) Pattern
pattern XmlTree
xmlDoc)
LA (Pattern, XmlTree) Pattern
-> LA Pattern XmlTree -> LA (Pattern, XmlTree) XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
(Pattern -> Bool) -> LA Pattern Pattern
forall b. (b -> Bool) -> LA b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA (Bool -> Bool
not (Bool -> Bool) -> (Pattern -> Bool) -> Pattern -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> Bool
nullable)
LA Pattern Pattern -> LA Pattern XmlTree -> LA Pattern XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
(Pattern -> String) -> LA Pattern String
forall 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]
take Int
1024
(String -> String) -> (Pattern -> String) -> Pattern -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"when validating with Relax NG schema: " String -> String -> String
forall a. [a] -> [a] -> [a]
++)
(String -> String) -> (Pattern -> String) -> Pattern -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> String
forall a. Show a => a -> String
show
)
LA Pattern String -> LA String XmlTree -> LA Pattern XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
Int -> LA String XmlTree
forall (a :: * -> * -> *). ArrowXml a => Int -> a String XmlTree
mkError Int
c_err
)
LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall 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`
LA XmlTree XmlTree
forall b. LA b b
forall (a :: * -> * -> *) b. ArrowList a => a b b
this
readForRelax :: String -> IOSArrow b XmlTree
readForRelax :: forall b. String -> IOSArrow b XmlTree
readForRelax String
schema
= String -> IOStateArrow () b XmlTree
forall s b. String -> IOStateArrow s b XmlTree
getDocumentContents String
schema
IOStateArrow () b XmlTree
-> IOSArrow XmlTree XmlTree -> IOStateArrow () b XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
Bool -> Bool -> Bool -> Bool -> IOSArrow XmlTree XmlTree
forall s.
Bool -> Bool -> Bool -> Bool -> IOStateArrow s XmlTree XmlTree
parseXmlDocument Bool
False Bool
True Bool
False Bool
True
IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
IOSArrow XmlTree XmlTree
forall (a :: * -> * -> *). ArrowList a => a XmlTree XmlTree
canonicalizeAllNodes
IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
IOSArrow XmlTree XmlTree
forall s. IOStateArrow s XmlTree XmlTree
propagateAndValidateNamespaces
contains :: NameClass -> QName -> Bool
contains :: NameClass -> QName -> Bool
contains NameClass
AnyName QName
_ = Bool
True
contains (AnyNameExcept NameClass
nc) QName
n = Bool -> Bool
not (NameClass -> QName -> Bool
contains NameClass
nc QName
n)
contains (NsName String
ns1) QName
qn = String
ns1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== QName -> String
namespaceUri QName
qn
contains (NsNameExcept String
ns1 NameClass
nc) QName
qn = String
ns1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== QName -> String
namespaceUri QName
qn Bool -> Bool -> Bool
&& Bool -> Bool
not (NameClass -> QName -> Bool
contains NameClass
nc QName
qn)
contains (Name String
ns1 String
ln1) QName
qn = (String
ns1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== QName -> String
namespaceUri QName
qn) Bool -> Bool -> Bool
&& (String
ln1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== QName -> String
localPart QName
qn)
contains (NameClassChoice NameClass
nc1 NameClass
nc2) QName
n = (NameClass -> QName -> Bool
contains NameClass
nc1 QName
n) Bool -> Bool -> Bool
|| (NameClass -> QName -> Bool
contains NameClass
nc2 QName
n)
contains (NCError String
_) QName
_ = Bool
False
nullable:: Pattern -> Bool
nullable :: Pattern -> Bool
nullable (Group Pattern
p1 Pattern
p2) = Pattern -> Bool
nullable Pattern
p1 Bool -> Bool -> Bool
&& Pattern -> Bool
nullable Pattern
p2
nullable (Interleave Pattern
p1 Pattern
p2) = Pattern -> Bool
nullable Pattern
p1 Bool -> Bool -> Bool
&& Pattern -> Bool
nullable Pattern
p2
nullable (Choice Pattern
p1 Pattern
p2) = Pattern -> Bool
nullable Pattern
p1 Bool -> Bool -> Bool
|| Pattern -> Bool
nullable Pattern
p2
nullable (OneOrMore Pattern
p) = Pattern -> Bool
nullable Pattern
p
nullable (Element NameClass
_ Pattern
_) = Bool
False
nullable (Attribute NameClass
_ Pattern
_) = Bool
False
nullable (List Pattern
_) = Bool
False
nullable (Value (String, String)
_ String
_ Context
_) = Bool
False
nullable (Data (String, String)
_ [(String, String)]
_) = Bool
False
nullable (DataExcept (String, String)
_ [(String, String)]
_ Pattern
_) = Bool
False
nullable (NotAllowed ErrMessage
_) = Bool
False
nullable Pattern
Empty = Bool
True
nullable Pattern
Text = Bool
True
nullable (After Pattern
_ Pattern
_) = Bool
False
childDeriv :: Context -> Pattern -> XmlTree -> Pattern
childDeriv :: Context -> Pattern -> XmlTree -> Pattern
childDeriv Context
cx Pattern
p XmlTree
t
| XmlTree -> Bool
forall a. XmlNode a => a -> Bool
XN.isText XmlTree
t = Context -> Pattern -> String -> Pattern
textDerivContext
cx Pattern
p (String -> Pattern) -> (XmlTree -> String) -> XmlTree -> Pattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe String -> String)
-> (XmlTree -> Maybe String) -> XmlTree -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Maybe String
forall a. XmlNode a => a -> Maybe String
XN.getText (XmlTree -> Pattern) -> XmlTree -> Pattern
forall a b. (a -> b) -> a -> b
$ XmlTree
t
| XmlTree -> Bool
forall a. XmlNode a => a -> Bool
XN.isElem XmlTree
t = Pattern -> Pattern
endTagDeriv Pattern
p4
| Bool
otherwise = String -> Pattern
notAllowed String
"Call to childDeriv with wrong arguments"
where
children :: [XmlTree]
children = XmlTree -> [XmlTree]
forall a. NTree a -> [NTree a]
forall (t :: * -> *) a. Tree t => t a -> [t a]
XN.getChildren (XmlTree -> [XmlTree]) -> XmlTree -> [XmlTree]
forall a b. (a -> b) -> a -> b
$ XmlTree
t
qn :: QName
qn = Maybe QName -> QName
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe QName -> QName)
-> (XmlTree -> Maybe QName) -> XmlTree -> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Maybe QName
forall a. XmlNode a => a -> Maybe QName
XN.getElemName (XmlTree -> QName) -> XmlTree -> QName
forall a b. (a -> b) -> a -> b
$ XmlTree
t
atts :: [XmlTree]
atts = Maybe [XmlTree] -> [XmlTree]
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe [XmlTree] -> [XmlTree])
-> (XmlTree -> Maybe [XmlTree]) -> XmlTree -> [XmlTree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Maybe [XmlTree]
forall a. XmlNode a => a -> Maybe [XmlTree]
XN.getAttrl (XmlTree -> [XmlTree]) -> XmlTree -> [XmlTree]
forall a b. (a -> b) -> a -> b
$ XmlTree
t
cx1 :: (String, [a])
cx1 = (String
"",[])
p1 :: Pattern
p1 = Pattern -> QName -> Pattern
startTagOpenDeriv Pattern
p QName
qn
p2 :: Pattern
p2 = Context -> Pattern -> [XmlTree] -> Pattern
attsDeriv Context
forall {a}. (String, [a])
cx1 Pattern
p1 [XmlTree]
atts
p3 :: Pattern
p3 = Pattern -> Pattern
startTagCloseDeriv Pattern
p2
p4 :: Pattern
p4 = Context -> Pattern -> [XmlTree] -> Pattern
childrenDeriv Context
forall {a}. (String, [a])
cx1 Pattern
p3 [XmlTree]
children
textDeriv :: Context -> Pattern -> String -> Pattern
textDeriv :: Context -> Pattern -> String -> Pattern
textDeriv Context
cx (Choice Pattern
p1 Pattern
p2) String
s
= Pattern -> Pattern -> Pattern
choice (Context -> Pattern -> String -> Pattern
textDeriv Context
cx Pattern
p1 String
s) (Context -> Pattern -> String -> Pattern
textDeriv Context
cx Pattern
p2 String
s)
textDeriv Context
cx (Interleave Pattern
p1 Pattern
p2) String
s
= Pattern -> Pattern -> Pattern
choice
(Pattern -> Pattern -> Pattern
interleave (Context -> Pattern -> String -> Pattern
textDeriv Context
cx Pattern
p1 String
s) Pattern
p2)
(Pattern -> Pattern -> Pattern
interleave Pattern
p1 (Context -> Pattern -> String -> Pattern
textDeriv Context
cx Pattern
p2 String
s))
textDeriv Context
cx (Group Pattern
p1 Pattern
p2) String
s
= let
p :: Pattern
p = Pattern -> Pattern -> Pattern
group (Context -> Pattern -> String -> Pattern
textDeriv Context
cx Pattern
p1 String
s) Pattern
p2
in
if Pattern -> Bool
nullable Pattern
p1
then Pattern -> Pattern -> Pattern
choice Pattern
p (Context -> Pattern -> String -> Pattern
textDeriv Context
cx Pattern
p2 String
s)
else Pattern
p
textDeriv Context
cx (After Pattern
p1 Pattern
p2) String
s
= Pattern -> Pattern -> Pattern
after (Context -> Pattern -> String -> Pattern
textDeriv Context
cx Pattern
p1 String
s) Pattern
p2
textDeriv Context
cx (OneOrMore Pattern
p) String
s
= Pattern -> Pattern -> Pattern
group (Context -> Pattern -> String -> Pattern
textDeriv Context
cx Pattern
p String
s) (Pattern -> Pattern -> Pattern
choice (Pattern -> Pattern
OneOrMore Pattern
p) Pattern
Empty)
textDeriv Context
_ Pattern
Text String
_
= Pattern
Text
textDeriv Context
cx1 (Value (String
uri, String
s) String
value Context
cx2) String
s1
= case String -> DatatypeEqual
datatypeEqual String
uri String
s String
value Context
cx2 String
s1 Context
cx1
of
Maybe String
Nothing -> Pattern
Empty
Just String
errStr -> String -> Pattern
notAllowed String
errStr
textDeriv Context
cx (Data (String
uri, String
s) [(String, String)]
params) String
s1
= case String -> DatatypeAllows
datatypeAllows String
uri String
s [(String, String)]
params String
s1 Context
cx
of
Maybe String
Nothing -> Pattern
Empty
Just String
errStr -> String -> Pattern
notAllowed2 String
errStr
textDeriv Context
cx (DataExcept (String
uri, String
s) [(String, String)]
params Pattern
p) String
s1
= case (String -> DatatypeAllows
datatypeAllows String
uri String
s [(String, String)]
params String
s1 Context
cx)
of
Maybe String
Nothing -> if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Pattern -> Bool
nullable (Pattern -> Bool) -> Pattern -> Bool
forall a b. (a -> b) -> a -> b
$ Context -> Pattern -> String -> Pattern
textDeriv Context
cx Pattern
p String
s1
then Pattern
Empty
else String -> Pattern
notAllowed
( String
"Any value except " String -> String -> String
forall a. [a] -> [a] -> [a]
++
String -> String
forall a. Show a => a -> String
show (Pattern -> String
forall a. Show a => a -> String
show Pattern
p) String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
" expected, but value " String -> String -> String
forall a. [a] -> [a] -> [a]
++
String -> String
forall a. Show a => a -> String
show (String -> String
forall a. Show a => a -> String
show String
s1) String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
" found"
)
Just String
errStr -> String -> Pattern
notAllowed String
errStr
textDeriv Context
cx (List Pattern
p) String
s
= if Pattern -> Bool
nullable (Context -> Pattern -> [String] -> Pattern
listDeriv Context
cx Pattern
p (String -> [String]
words String
s))
then Pattern
Empty
else String -> Pattern
notAllowed
( String
"List with value(s) " String -> String -> String
forall a. [a] -> [a] -> [a]
++
Pattern -> String
forall a. Show a => a -> String
show Pattern
p String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
" expected, but value(s) " String -> String -> String
forall a. [a] -> [a] -> [a]
++
[String] -> String
formatStringListQuot (String -> [String]
words String
s) String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
" found"
)
textDeriv Context
_ n :: Pattern
n@(NotAllowed ErrMessage
_) String
_
= Pattern
n
textDeriv Context
_ Pattern
p String
s
= String -> Pattern
notAllowed
( String
"Pattern " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (Pattern -> String
getPatternName Pattern
p) String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
" expected, but text " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" found"
)
listDeriv :: Context -> Pattern -> [String] -> Pattern
listDeriv :: Context -> Pattern -> [String] -> Pattern
listDeriv Context
_ !Pattern
p []
= Pattern
p
listDeriv Context
cx !Pattern
p (String
x:[String]
xs)
= Context -> Pattern -> [String] -> Pattern
listDeriv Context
cx (Context -> Pattern -> String -> Pattern
textDeriv Context
cx Pattern
p String
x) [String]
xs
startTagOpenDeriv :: Pattern -> QName -> Pattern
startTagOpenDeriv :: Pattern -> QName -> Pattern
startTagOpenDeriv (Choice Pattern
p1 Pattern
p2) QName
qn
= Pattern -> Pattern -> Pattern
choice (Pattern -> QName -> Pattern
startTagOpenDeriv Pattern
p1 QName
qn) (Pattern -> QName -> Pattern
startTagOpenDeriv Pattern
p2 QName
qn)
startTagOpenDeriv (Element NameClass
nc Pattern
p) QName
qn
| NameClass -> QName -> Bool
contains NameClass
nc QName
qn
= Pattern -> Pattern -> Pattern
after Pattern
p Pattern
Empty
| Bool
otherwise
= String -> Pattern
notAllowed (String -> Pattern) -> String -> Pattern
forall a b. (a -> b) -> a -> b
$
String
"Element with name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NameClass -> String
nameClassToString NameClass
nc String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
" expected, but " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
universalName QName
qn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" found"
startTagOpenDeriv (Interleave Pattern
p1 Pattern
p2) QName
qn
= Pattern -> Pattern -> Pattern
choice
((Pattern -> Pattern) -> Pattern -> Pattern
applyAfter ((Pattern -> Pattern -> Pattern) -> Pattern -> Pattern -> Pattern
forall a b c. (a -> b -> c) -> b -> a -> c
flip Pattern -> Pattern -> Pattern
interleave Pattern
p2) (Pattern -> QName -> Pattern
startTagOpenDeriv Pattern
p1 QName
qn))
((Pattern -> Pattern) -> Pattern -> Pattern
applyAfter (Pattern -> Pattern -> Pattern
interleave Pattern
p1) (Pattern -> QName -> Pattern
startTagOpenDeriv Pattern
p2 QName
qn))
startTagOpenDeriv (OneOrMore Pattern
p) QName
qn
= (Pattern -> Pattern) -> Pattern -> Pattern
applyAfter
((Pattern -> Pattern -> Pattern) -> Pattern -> Pattern -> Pattern
forall a b c. (a -> b -> c) -> b -> a -> c
flip Pattern -> Pattern -> Pattern
group (Pattern -> Pattern -> Pattern
choice (Pattern -> Pattern
OneOrMore Pattern
p) Pattern
Empty))
(Pattern -> QName -> Pattern
startTagOpenDeriv Pattern
p QName
qn)
startTagOpenDeriv (Group Pattern
p1 Pattern
p2) QName
qn
= let
x :: Pattern
x = (Pattern -> Pattern) -> Pattern -> Pattern
applyAfter ((Pattern -> Pattern -> Pattern) -> Pattern -> Pattern -> Pattern
forall a b c. (a -> b -> c) -> b -> a -> c
flip Pattern -> Pattern -> Pattern
group Pattern
p2) (Pattern -> QName -> Pattern
startTagOpenDeriv Pattern
p1 QName
qn)
in
if Pattern -> Bool
nullable Pattern
p1
then Pattern -> Pattern -> Pattern
choice Pattern
x (Pattern -> QName -> Pattern
startTagOpenDeriv Pattern
p2 QName
qn)
else Pattern
x
startTagOpenDeriv (After Pattern
p1 Pattern
p2) QName
qn
= (Pattern -> Pattern) -> Pattern -> Pattern
applyAfter ((Pattern -> Pattern -> Pattern) -> Pattern -> Pattern -> Pattern
forall a b c. (a -> b -> c) -> b -> a -> c
flip Pattern -> Pattern -> Pattern
after Pattern
p2) (Pattern -> QName -> Pattern
startTagOpenDeriv Pattern
p1 QName
qn)
startTagOpenDeriv n :: Pattern
n@(NotAllowed ErrMessage
_) QName
_
= Pattern
n
startTagOpenDeriv Pattern
p QName
qn
= String -> Pattern
notAllowed ( Pattern -> String
forall a. Show a => a -> String
show Pattern
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" expected, but Element " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
universalName QName
qn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" found" )
attsDeriv :: Context -> Pattern -> XmlTrees -> Pattern
attsDeriv :: Context -> Pattern -> [XmlTree] -> Pattern
attsDeriv Context
_ !Pattern
p []
= Pattern
p
attsDeriv Context
cx !Pattern
p (XmlTree
t : [XmlTree]
ts)
| XmlTree -> Bool
forall a. XmlNode a => a -> Bool
XN.isAttr XmlTree
t
= Context -> Pattern -> [XmlTree] -> Pattern
attsDeriv Context
cx (Context -> Pattern -> XmlTree -> Pattern
attDeriv Context
cx Pattern
p XmlTree
t) [XmlTree]
ts
| Bool
otherwise
= String -> Pattern
notAllowed String
"Call to attsDeriv with wrong arguments"
attDeriv :: Context -> Pattern -> XmlTree -> Pattern
attDeriv :: Context -> Pattern -> XmlTree -> Pattern
attDeriv Context
cx (After Pattern
p1 Pattern
p2) XmlTree
att
= Pattern -> Pattern -> Pattern
after (Context -> Pattern -> XmlTree -> Pattern
attDeriv Context
cx Pattern
p1 XmlTree
att) Pattern
p2
attDeriv Context
cx (Choice Pattern
p1 Pattern
p2) XmlTree
att
= Pattern -> Pattern -> Pattern
choice (Context -> Pattern -> XmlTree -> Pattern
attDeriv Context
cx Pattern
p1 XmlTree
att) (Context -> Pattern -> XmlTree -> Pattern
attDeriv Context
cx Pattern
p2 XmlTree
att)
attDeriv Context
cx (Group Pattern
p1 Pattern
p2) XmlTree
att
= Pattern -> Pattern -> Pattern
choice
(Pattern -> Pattern -> Pattern
group (Context -> Pattern -> XmlTree -> Pattern
attDeriv Context
cx Pattern
p1 XmlTree
att) Pattern
p2)
(Pattern -> Pattern -> Pattern
group Pattern
p1 (Context -> Pattern -> XmlTree -> Pattern
attDeriv Context
cx Pattern
p2 XmlTree
att))
attDeriv Context
cx (Interleave Pattern
p1 Pattern
p2) XmlTree
att
= Pattern -> Pattern -> Pattern
choice
(Pattern -> Pattern -> Pattern
interleave (Context -> Pattern -> XmlTree -> Pattern
attDeriv Context
cx Pattern
p1 XmlTree
att) Pattern
p2)
(Pattern -> Pattern -> Pattern
interleave Pattern
p1 (Context -> Pattern -> XmlTree -> Pattern
attDeriv Context
cx Pattern
p2 XmlTree
att))
attDeriv Context
cx (OneOrMore Pattern
p) XmlTree
att
= Pattern -> Pattern -> Pattern
group
(Context -> Pattern -> XmlTree -> Pattern
attDeriv Context
cx Pattern
p XmlTree
att)
(Pattern -> Pattern -> Pattern
choice (Pattern -> Pattern
OneOrMore Pattern
p) Pattern
Empty)
attDeriv Context
cx (Attribute NameClass
nc Pattern
p) XmlTree
att
| Bool
isa
Bool -> Bool -> Bool
&&
Bool -> Bool
not (NameClass -> QName -> Bool
contains NameClass
nc QName
qn)
= String -> Pattern
notAllowed1 (String -> Pattern) -> String -> Pattern
forall a b. (a -> b) -> a -> b
$
String
"Attribute with name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NameClass -> String
nameClassToString NameClass
nc
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" expected, but " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
universalName QName
qn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" found"
| Bool
isa
Bool -> Bool -> Bool
&&
( ( Pattern -> Bool
nullable Pattern
p
Bool -> Bool -> Bool
&&
String -> Bool
whitespace String
val
)
Bool -> Bool -> Bool
|| Pattern -> Bool
nullable Pattern
p'
)
= Pattern
Empty
| Bool
isa
= Pattern -> Pattern
err' Pattern
p'
where
isa :: Bool
isa = XmlTree -> Bool
forall a. XmlNode a => a -> Bool
XN.isAttr (XmlTree -> Bool) -> XmlTree -> Bool
forall a b. (a -> b) -> a -> b
$ XmlTree
att
qn :: QName
qn = Maybe QName -> QName
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe QName -> QName)
-> (XmlTree -> Maybe QName) -> XmlTree -> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Maybe QName
forall a. XmlNode a => a -> Maybe QName
XN.getAttrName (XmlTree -> QName) -> XmlTree -> QName
forall a b. (a -> b) -> a -> b
$ XmlTree
att
av :: [XmlTree]
av = XmlTree -> [XmlTree]
forall a. NTree a -> [NTree a]
forall (t :: * -> *) a. Tree t => t a -> [t a]
XN.getChildren (XmlTree -> [XmlTree]) -> XmlTree -> [XmlTree]
forall a b. (a -> b) -> a -> b
$ XmlTree
att
val :: String
val = [XmlTree] -> String
showXts [XmlTree]
av
p' :: Pattern
p' = Context -> Pattern -> String -> Pattern
textDeriv Context
cx Pattern
p String
val
err' :: Pattern -> Pattern
err' (NotAllowed (ErrMsg Int
_l [String]
es))
= String -> Pattern
err'' (String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. HasCallStack => [a] -> a
head [String]
es)
err' Pattern
_
= String -> Pattern
err'' String
""
err'' :: String -> Pattern
err'' String
e
= String -> Pattern
notAllowed2 (String -> Pattern) -> String -> Pattern
forall a b. (a -> b) -> a -> b
$
String
"Attribute value \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
val String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"\" does not match datatype spec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern -> String
forall a. Show a => a -> String
show Pattern
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e
attDeriv Context
_ n :: Pattern
n@(NotAllowed ErrMessage
_) XmlTree
_
= Pattern
n
attDeriv Context
_ Pattern
_p XmlTree
att
= String -> Pattern
notAllowed (String -> Pattern) -> String -> Pattern
forall a b. (a -> b) -> a -> b
$
String
"No matching pattern for attribute '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [XmlTree] -> String
showXts [XmlTree
att] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' found"
startTagCloseDeriv :: Pattern -> Pattern
startTagCloseDeriv :: Pattern -> Pattern
startTagCloseDeriv (After Pattern
p1 Pattern
p2)
= Pattern -> Pattern -> Pattern
after (Pattern -> Pattern
startTagCloseDeriv Pattern
p1) Pattern
p2
startTagCloseDeriv (Choice Pattern
p1 Pattern
p2)
= Pattern -> Pattern -> Pattern
choice
(Pattern -> Pattern
startTagCloseDeriv Pattern
p1)
(Pattern -> Pattern
startTagCloseDeriv Pattern
p2)
startTagCloseDeriv (Group Pattern
p1 Pattern
p2)
= Pattern -> Pattern -> Pattern
group
(Pattern -> Pattern
startTagCloseDeriv Pattern
p1)
(Pattern -> Pattern
startTagCloseDeriv Pattern
p2)
startTagCloseDeriv (Interleave Pattern
p1 Pattern
p2)
= Pattern -> Pattern -> Pattern
interleave
(Pattern -> Pattern
startTagCloseDeriv Pattern
p1)
(Pattern -> Pattern
startTagCloseDeriv Pattern
p2)
startTagCloseDeriv (OneOrMore Pattern
p)
= Pattern -> Pattern
oneOrMore (Pattern -> Pattern
startTagCloseDeriv Pattern
p)
startTagCloseDeriv (Attribute NameClass
nc Pattern
_)
= String -> Pattern
notAllowed1 (String -> Pattern) -> String -> Pattern
forall a b. (a -> b) -> a -> b
$
String
"Attribut with name, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NameClass -> String
forall a. Show a => a -> String
show NameClass
nc String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
" expected, but no more attributes found"
startTagCloseDeriv Pattern
p
= Pattern
p
childrenDeriv :: Context -> Pattern -> XmlTrees -> Pattern
childrenDeriv :: Context -> Pattern -> [XmlTree] -> Pattern
childrenDeriv Context
_cx p :: Pattern
p@(NotAllowed ErrMessage
_) [XmlTree]
_
= Pattern
p
childrenDeriv Context
cx Pattern
p []
= Context -> Pattern -> [XmlTree] -> Pattern
childrenDeriv Context
cx Pattern
p [String -> XmlTree
forall a. XmlNode a => String -> a
XN.mkText String
""]
childrenDeriv Context
cx Pattern
p [XmlTree
tt]
| Bool
ist
Bool -> Bool -> Bool
&&
String -> Bool
whitespace String
s
= Pattern -> Pattern -> Pattern
choice Pattern
p Pattern
p1
| Bool
ist
= Pattern
p1
where
ist :: Bool
ist = XmlTree -> Bool
forall a. XmlNode a => a -> Bool
XN.isText XmlTree
tt
s :: String
s = Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe String -> String)
-> (XmlTree -> Maybe String) -> XmlTree -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Maybe String
forall a. XmlNode a => a -> Maybe String
XN.getText (XmlTree -> String) -> XmlTree -> String
forall a b. (a -> b) -> a -> b
$ XmlTree
tt
p1 :: Pattern
p1 = Context -> Pattern -> XmlTree -> Pattern
childDeriv Context
cx Pattern
p XmlTree
tt
childrenDeriv Context
cx Pattern
p [XmlTree]
children
= Context -> Pattern -> [XmlTree] -> Pattern
stripChildrenDeriv Context
cx Pattern
p [XmlTree]
children
stripChildrenDeriv :: Context -> Pattern -> XmlTrees -> Pattern
stripChildrenDeriv :: Context -> Pattern -> [XmlTree] -> Pattern
stripChildrenDeriv Context
_ !Pattern
p []
= Pattern
p
stripChildrenDeriv Context
cx !Pattern
p (XmlTree
h:[XmlTree]
t)
= Context -> Pattern -> [XmlTree] -> Pattern
stripChildrenDeriv Context
cx
( if XmlTree -> Bool
strip XmlTree
h
then Pattern
p
else (Context -> Pattern -> XmlTree -> Pattern
childDeriv Context
cx Pattern
p XmlTree
h)
) [XmlTree]
t
endTagDeriv :: Pattern -> Pattern
endTagDeriv :: Pattern -> Pattern
endTagDeriv (Choice Pattern
p1 Pattern
p2)
= Pattern -> Pattern -> Pattern
choice (Pattern -> Pattern
endTagDeriv Pattern
p1) (Pattern -> Pattern
endTagDeriv Pattern
p2)
endTagDeriv (After Pattern
p1 Pattern
p2)
| Pattern -> Bool
nullable Pattern
p1
= Pattern
p2
| Bool
otherwise
= String -> Pattern
notAllowed (String -> Pattern) -> String -> Pattern
forall a b. (a -> b) -> a -> b
$
Pattern -> String
forall a. Show a => a -> String
show Pattern
p1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" expected"
endTagDeriv n :: Pattern
n@(NotAllowed ErrMessage
_)
= Pattern
n
endTagDeriv Pattern
_
= String -> Pattern
notAllowed String
"Call to endTagDeriv with wrong arguments"
applyAfter :: (Pattern -> Pattern) -> Pattern -> Pattern
applyAfter :: (Pattern -> Pattern) -> Pattern -> Pattern
applyAfter Pattern -> Pattern
f (After Pattern
p1 Pattern
p2) = Pattern -> Pattern -> Pattern
after Pattern
p1 (Pattern -> Pattern
f Pattern
p2)
applyAfter Pattern -> Pattern
f (Choice Pattern
p1 Pattern
p2) = Pattern -> Pattern -> Pattern
choice ((Pattern -> Pattern) -> Pattern -> Pattern
applyAfter Pattern -> Pattern
f Pattern
p1) ((Pattern -> Pattern) -> Pattern -> Pattern
applyAfter Pattern -> Pattern
f Pattern
p2)
applyAfter Pattern -> Pattern
_ n :: Pattern
n@(NotAllowed ErrMessage
_) = Pattern
n
applyAfter Pattern -> Pattern
_ Pattern
_ = String -> Pattern
notAllowed String
"Call to applyAfter with wrong arguments"
strip :: XmlTree -> Bool
strip :: XmlTree -> Bool
strip = Bool -> (String -> Bool) -> Maybe String -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False String -> Bool
whitespace (Maybe String -> Bool)
-> (XmlTree -> Maybe String) -> XmlTree -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Maybe String
forall a. XmlNode a => a -> Maybe String
XN.getText
whitespace :: String -> Bool
whitespace :: String -> Bool
whitespace = (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isXmlSpaceChar
showXts :: XmlTrees -> String
showXts :: [XmlTree] -> String
showXts = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String)
-> ([XmlTree] -> [String]) -> [XmlTree] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LA [XmlTree] String -> [XmlTree] -> [String]
forall a b. LA a b -> a -> [b]
runLA (LA [XmlTree] XmlTree -> LA [XmlTree] String
forall n. LA n XmlTree -> LA n String
forall (a :: * -> * -> *) n.
ArrowXml a =>
a n XmlTree -> a n String
xshow (LA [XmlTree] XmlTree -> LA [XmlTree] String)
-> LA [XmlTree] XmlTree -> LA [XmlTree] String
forall a b. (a -> b) -> a -> b
$ ([XmlTree] -> [XmlTree]) -> LA [XmlTree] XmlTree
forall b c. (b -> [c]) -> LA b c
forall (a :: * -> * -> *) b c. ArrowList a => (b -> [c]) -> a b c
arrL [XmlTree] -> [XmlTree]
forall a. a -> a
id)