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