module Text.XML.HaXml.Validate
( validate
, partialValidate
) where
import Prelude hiding (elem,rem,mod,sequence)
import qualified Prelude (elem)
import Text.XML.HaXml.Types
import Text.XML.HaXml.Namespaces
import Text.XML.HaXml.Combinators (multi,tag,iffind,literal,none,o)
import Text.XML.HaXml.XmlContent (attr2str)
import Data.Maybe (fromMaybe,isNothing,fromJust)
import Data.List (intersperse,nub,(\\))
import Data.Char (isSpace)
#if __GLASGOW_HASKELL__ >= 604 || __NHC__ >= 118 || defined(__HUGS__)
import qualified Data.Map as Map
type FiniteMap a b = Map.Map a b
listToFM :: Ord a => [(a,b)] -> FiniteMap a b
listToFM :: [(a, b)] -> FiniteMap a b
listToFM = [(a, b)] -> FiniteMap a b
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
lookupFM :: Ord a => FiniteMap a b -> a -> Maybe b
lookupFM :: FiniteMap a b -> a -> Maybe b
lookupFM = (a -> FiniteMap a b -> Maybe b) -> FiniteMap a b -> a -> Maybe b
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> FiniteMap a b -> Maybe b
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup
#elif __GLASGOW_HASKELL__ >= 504 || __NHC__ > 114
import Data.FiniteMap
#else
type FiniteMap a b = [(a,b)]
listToFM :: Eq a => [(a,b)] -> FiniteMap a b
listToFM = id
lookupFM :: Eq a => FiniteMap a b -> a -> Maybe b
lookupFM fm k = lookup k fm
#endif
data SimpleDTD = SimpleDTD
{ SimpleDTD -> FiniteMap QName ContentSpec
elements :: FiniteMap QName ContentSpec
, SimpleDTD -> FiniteMap (QName, QName) AttType
attributes :: FiniteMap (QName,QName) AttType
, SimpleDTD -> FiniteMap QName [QName]
required :: FiniteMap QName [QName]
, SimpleDTD -> [(QName, QName)]
ids :: [(QName,QName)]
, SimpleDTD -> [(QName, QName)]
idrefs :: [(QName,QName)]
}
simplifyDTD :: DocTypeDecl -> SimpleDTD
simplifyDTD :: DocTypeDecl -> SimpleDTD
simplifyDTD (DTD _ _ decls :: [MarkupDecl]
decls) =
SimpleDTD :: FiniteMap QName ContentSpec
-> FiniteMap (QName, QName) AttType
-> FiniteMap QName [QName]
-> [(QName, QName)]
-> [(QName, QName)]
-> SimpleDTD
SimpleDTD
{ elements :: FiniteMap QName ContentSpec
elements = [(QName, ContentSpec)] -> FiniteMap QName ContentSpec
forall k a. Ord k => [(k, a)] -> Map k a
listToFM [ (QName
name,ContentSpec
content)
| Element (ElementDecl name :: QName
name content :: ContentSpec
content) <- [MarkupDecl]
decls ]
, attributes :: FiniteMap (QName, QName) AttType
attributes = [((QName, QName), AttType)] -> FiniteMap (QName, QName) AttType
forall k a. Ord k => [(k, a)] -> Map k a
listToFM [ ((QName
elem,QName
attr),AttType
typ)
| AttList (AttListDecl elem :: QName
elem attdefs :: [AttDef]
attdefs) <- [MarkupDecl]
decls
, AttDef attr :: QName
attr typ :: AttType
typ _ <- [AttDef]
attdefs ]
, required :: FiniteMap QName [QName]
required = [(QName, [QName])] -> FiniteMap QName [QName]
forall k a. Ord k => [(k, a)] -> Map k a
listToFM [ (QName
elem, [[QName]] -> [QName]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [ QName
attr | AttDef attr :: QName
attr _ REQUIRED <- [AttDef]
attdefs ]
| AttList (AttListDecl elem' :: QName
elem' attdefs :: [AttDef]
attdefs) <- [MarkupDecl]
decls
, QName
elem' QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
elem ]
)
| Element (ElementDecl elem :: QName
elem _) <- [MarkupDecl]
decls ]
, ids :: [(QName, QName)]
ids = [ (QName
elem,QName
attr)
| Element (ElementDecl elem :: QName
elem _) <- [MarkupDecl]
decls
, AttList (AttListDecl name :: QName
name attdefs :: [AttDef]
attdefs) <- [MarkupDecl]
decls
, QName
elem QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
name
, AttDef attr :: QName
attr (TokenizedType ID) _ <- [AttDef]
attdefs ]
, idrefs :: [(QName, QName)]
idrefs = []
}
gives :: Bool -> a -> [a]
True gives :: Bool -> a -> [a]
`gives` x :: a
x = [a
x]
False `gives` _ = []
validate :: DocTypeDecl -> Element i -> [String]
validate :: DocTypeDecl -> Element i -> [String]
validate dtd' :: DocTypeDecl
dtd' elem :: Element i
elem = DocTypeDecl -> Element i -> [String]
forall i. DocTypeDecl -> Element i -> [String]
root DocTypeDecl
dtd' Element i
elem [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ DocTypeDecl -> Element i -> [String]
forall i. DocTypeDecl -> Element i -> [String]
partialValidate DocTypeDecl
dtd' Element i
elem
where
root :: DocTypeDecl -> Element i -> [String]
root (DTD name :: QName
name _ _) (Elem name' :: QName
name' _ _) =
(QName
nameQName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
/=QName
name') Bool -> String -> [String]
forall a. Bool -> a -> [a]
`gives` ("Document type should be <"String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
qname QName
name
String -> String -> String
forall a. [a] -> [a] -> [a]
++"> but appears to be <"String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
qname QName
name'String -> String -> String
forall a. [a] -> [a] -> [a]
++">.")
partialValidate :: DocTypeDecl -> Element i -> [String]
partialValidate :: DocTypeDecl -> Element i -> [String]
partialValidate dtd' :: DocTypeDecl
dtd' elem :: Element i
elem = Element i -> [String]
forall i. Element i -> [String]
valid Element i
elem [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Element i -> [String]
forall i. Element i -> [String]
checkIDs Element i
elem
where
dtd :: SimpleDTD
dtd = DocTypeDecl -> SimpleDTD
simplifyDTD DocTypeDecl
dtd'
valid :: Element i -> [String]
valid (Elem name :: QName
name attrs :: [Attribute]
attrs contents :: [Content i]
contents) =
let spec :: Maybe ContentSpec
spec = FiniteMap QName ContentSpec -> QName -> Maybe ContentSpec
forall a b. Ord a => FiniteMap a b -> a -> Maybe b
lookupFM (SimpleDTD -> FiniteMap QName ContentSpec
elements SimpleDTD
dtd) QName
name in
(Maybe ContentSpec -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ContentSpec
spec) Bool -> String -> [String]
forall a. Bool -> a -> [a]
`gives` ("Element <"String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
qname QName
nameString -> String -> String
forall a. [a] -> [a] -> [a]
++"> not known.")
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (let dups :: [String]
dups = [String] -> [String]
forall a. Eq a => [a] -> [a]
duplicates ((Attribute -> String) -> [Attribute] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (QName -> String
qname (QName -> String) -> (Attribute -> QName) -> Attribute -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attribute -> QName
forall a b. (a, b) -> a
fst) [Attribute]
attrs) in
Bool -> Bool
not ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
dups) Bool -> String -> [String]
forall a. Bool -> a -> [a]
`gives`
("Element <"String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
qname QName
nameString -> String -> String
forall a. [a] -> [a] -> [a]
++"> has duplicate attributes: "
String -> String -> String
forall a. [a] -> [a] -> [a]
++[String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse "," [String]
dups)String -> String -> String
forall a. [a] -> [a] -> [a]
++"."))
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Attribute -> [String]) -> [Attribute] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (QName -> Attribute -> [String]
checkAttr QName
name) [Attribute]
attrs
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (QName -> [String]) -> [QName] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (QName -> [Attribute] -> QName -> [String]
forall b. QName -> [(QName, b)] -> QName -> [String]
checkRequired QName
name [Attribute]
attrs)
([QName] -> Maybe [QName] -> [QName]
forall a. a -> Maybe a -> a
fromMaybe [] (FiniteMap QName [QName] -> QName -> Maybe [QName]
forall a b. Ord a => FiniteMap a b -> a -> Maybe b
lookupFM (SimpleDTD -> FiniteMap QName [QName]
required SimpleDTD
dtd) QName
name))
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ QName -> ContentSpec -> [Content i] -> [String]
forall i. QName -> ContentSpec -> [Content i] -> [String]
checkContentSpec QName
name (ContentSpec -> Maybe ContentSpec -> ContentSpec
forall a. a -> Maybe a -> a
fromMaybe ContentSpec
ANY Maybe ContentSpec
spec) [Content i]
contents
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Element i -> [String]) -> [Element i] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Element i -> [String]
valid [ Element i
elm | CElem elm :: Element i
elm _ <- [Content i]
contents ]
checkAttr :: QName -> Attribute -> [String]
checkAttr elm :: QName
elm (attr :: QName
attr, val :: AttValue
val) =
let typ :: Maybe AttType
typ = FiniteMap (QName, QName) AttType -> (QName, QName) -> Maybe AttType
forall a b. Ord a => FiniteMap a b -> a -> Maybe b
lookupFM (SimpleDTD -> FiniteMap (QName, QName) AttType
attributes SimpleDTD
dtd) (QName
elm,QName
attr)
attval :: String
attval = AttValue -> String
attr2str AttValue
val in
if Maybe AttType -> Bool
forall a. Maybe a -> Bool
isNothing Maybe AttType
typ then ["Attribute \""String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
qname QName
attr
String -> String -> String
forall a. [a] -> [a] -> [a]
++"\" not known for element <"String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
qname QName
elmString -> String -> String
forall a. [a] -> [a] -> [a]
++">."]
else
case Maybe AttType -> AttType
forall a. HasCallStack => Maybe a -> a
fromJust Maybe AttType
typ of
EnumeratedType e :: EnumeratedType
e ->
case EnumeratedType
e of
Enumeration es :: [String]
es ->
(Bool -> Bool
not (String
attval String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`Prelude.elem` [String]
es)) Bool -> String -> [String]
forall a. Bool -> a -> [a]
`gives`
("Value \""String -> String -> String
forall a. [a] -> [a] -> [a]
++String
attvalString -> String -> String
forall a. [a] -> [a] -> [a]
++"\" of attribute \""
String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
qname QName
attrString -> String -> String
forall a. [a] -> [a] -> [a]
++"\" in element <"String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
qname QName
elm
String -> String -> String
forall a. [a] -> [a] -> [a]
++"> is not in the required enumeration range: "
String -> String -> String
forall a. [a] -> [a] -> [a]
++[String] -> String
unwords [String]
es)
_ -> []
_ -> []
checkRequired :: QName -> [(QName, b)] -> QName -> [String]
checkRequired elm :: QName
elm attrs :: [(QName, b)]
attrs req :: QName
req =
(Bool -> Bool
not (QName
req QName -> [QName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`Prelude.elem` ((QName, b) -> QName) -> [(QName, b)] -> [QName]
forall a b. (a -> b) -> [a] -> [b]
map (QName, b) -> QName
forall a b. (a, b) -> a
fst [(QName, b)]
attrs)) Bool -> String -> [String]
forall a. Bool -> a -> [a]
`gives`
("Element <"String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
qname QName
elmString -> String -> String
forall a. [a] -> [a] -> [a]
++"> requires the attribute \""String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
qname QName
req
String -> String -> String
forall a. [a] -> [a] -> [a]
++"\" but it is missing.")
checkContentSpec :: QName -> ContentSpec -> [Content i] -> [String]
checkContentSpec _elm :: QName
_elm ANY _ = []
checkContentSpec _elm :: QName
_elm EMPTY [] = []
checkContentSpec elm :: QName
elm EMPTY (_:_) =
["Element <"String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
qname QName
elmString -> String -> String
forall a. [a] -> [a] -> [a]
++"> is not empty but should be."]
checkContentSpec elm :: QName
elm (Mixed PCDATA) cs :: [Content i]
cs = (Content i -> [String]) -> [Content i] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (QName -> [QName] -> Content i -> [String]
forall (t :: * -> *) i.
Foldable t =>
QName -> t QName -> Content i -> [String]
checkMixed QName
elm []) [Content i]
cs
checkContentSpec elm :: QName
elm (Mixed (PCDATAplus names :: [QName]
names)) cs :: [Content i]
cs =
(Content i -> [String]) -> [Content i] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (QName -> [QName] -> Content i -> [String]
forall (t :: * -> *) i.
Foldable t =>
QName -> t QName -> Content i -> [String]
checkMixed QName
elm [QName]
names) [Content i]
cs
checkContentSpec elm :: QName
elm (ContentSpec cp :: CP
cp) cs :: [Content i]
cs = QName -> [Content i] -> [String]
forall i. QName -> [Content i] -> [String]
excludeText QName
elm [Content i]
cs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
(let (errs :: [String]
errs,rest :: [QName]
rest) = QName -> CP -> [QName] -> ([String], [QName])
checkCP QName
elm CP
cp ([Content i] -> [QName]
forall i. [Content i] -> [QName]
flatten [Content i]
cs) in
case [QName]
rest of [] -> [String]
errs
_ -> [String]
errs[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++["Element <"String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
qname QName
elmString -> String -> String
forall a. [a] -> [a] -> [a]
++"> contains extra "
String -> String -> String
forall a. [a] -> [a] -> [a]
++"elements beyond its content spec."])
checkMixed :: QName -> t QName -> Content i -> [String]
checkMixed elm :: QName
elm permitted :: t QName
permitted (CElem (Elem name :: QName
name _ _) _)
| Bool -> Bool
not (QName
name QName -> t QName -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`Prelude.elem` t QName
permitted) =
["Element <"String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
qname QName
elmString -> String -> String
forall a. [a] -> [a] -> [a]
++"> contains an element <"String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
qname QName
name
String -> String -> String
forall a. [a] -> [a] -> [a]
++"> but should not."]
checkMixed _elm :: QName
_elm _permitted :: t QName
_permitted _ = []
flatten :: [Content i] -> [QName]
flatten (CElem (Elem name :: QName
name _ _) _: cs :: [Content i]
cs) = QName
nameQName -> [QName] -> [QName]
forall a. a -> [a] -> [a]
: [Content i] -> [QName]
flatten [Content i]
cs
flatten (_: cs :: [Content i]
cs) = [Content i] -> [QName]
flatten [Content i]
cs
flatten [] = []
excludeText :: QName -> [Content i] -> [String]
excludeText elm :: QName
elm (CElem _ _: cs :: [Content i]
cs) = QName -> [Content i] -> [String]
excludeText QName
elm [Content i]
cs
excludeText elm :: QName
elm (CMisc _ _: cs :: [Content i]
cs) = QName -> [Content i] -> [String]
excludeText QName
elm [Content i]
cs
excludeText elm :: QName
elm (CString _ s :: String
s _: cs :: [Content i]
cs) | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
s = QName -> [Content i] -> [String]
excludeText QName
elm [Content i]
cs
excludeText elm :: QName
elm (_:_) =
["Element <"String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
qname QName
elmString -> String -> String
forall a. [a] -> [a] -> [a]
++"> contains text/references but should not."]
excludeText _elm :: QName
_elm [] = []
checkCP :: QName -> CP -> [QName] -> ([String],[QName])
checkCP :: QName -> CP -> [QName] -> ([String], [QName])
checkCP elm :: QName
elm cp :: CP
cp@(TagName _ None) [] = (QName -> CP -> [String]
cpError QName
elm CP
cp, [])
checkCP elm :: QName
elm cp :: CP
cp@(TagName n :: QName
n None) (n' :: QName
n':ns :: [QName]
ns)
| QName
nQName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
==QName
n' = ([], [QName]
ns)
| Bool
otherwise = (QName -> CP -> [String]
cpError QName
elm CP
cp, QName
n'QName -> [QName] -> [QName]
forall a. a -> [a] -> [a]
:[QName]
ns)
checkCP _ (TagName _ Query) [] = ([],[])
checkCP _ (TagName n :: QName
n Query) (n' :: QName
n':ns :: [QName]
ns)
| QName
nQName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
==QName
n' = ([], [QName]
ns)
| Bool
otherwise = ([], QName
n'QName -> [QName] -> [QName]
forall a. a -> [a] -> [a]
:[QName]
ns)
checkCP _ (TagName _ Star) [] = ([],[])
checkCP elm :: QName
elm (TagName n :: QName
n Star) (n' :: QName
n':ns :: [QName]
ns)
| QName
nQName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
==QName
n' = QName -> CP -> [QName] -> ([String], [QName])
checkCP QName
elm (QName -> Modifier -> CP
TagName QName
n Modifier
Star) [QName]
ns
| Bool
otherwise = ([], QName
n'QName -> [QName] -> [QName]
forall a. a -> [a] -> [a]
:[QName]
ns)
checkCP elm :: QName
elm cp :: CP
cp@(TagName _ Plus) [] = (QName -> CP -> [String]
cpError QName
elm CP
cp, [])
checkCP elm :: QName
elm cp :: CP
cp@(TagName n :: QName
n Plus) (n' :: QName
n':ns :: [QName]
ns)
| QName
nQName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
==QName
n' = QName -> CP -> [QName] -> ([String], [QName])
checkCP QName
elm (QName -> Modifier -> CP
TagName QName
n Modifier
Star) [QName]
ns
| Bool
otherwise = (QName -> CP -> [String]
cpError QName
elm CP
cp, QName
n'QName -> [QName] -> [QName]
forall a. a -> [a] -> [a]
:[QName]
ns)
checkCP elm :: QName
elm cp :: CP
cp@(Choice cps :: [CP]
cps None) ns :: [QName]
ns =
let next :: [[QName]]
next = QName -> [QName] -> [CP] -> [[QName]]
choice QName
elm [QName]
ns [CP]
cps in
if [[QName]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[QName]]
next then (QName -> CP -> [String]
cpError QName
elm CP
cp, [QName]
ns)
else ([], [[QName]] -> [QName]
forall a. [a] -> a
head [[QName]]
next)
checkCP _ (Choice _ Query) [] = ([],[])
checkCP elm :: QName
elm (Choice cps :: [CP]
cps Query) ns :: [QName]
ns =
let next :: [[QName]]
next = QName -> [QName] -> [CP] -> [[QName]]
choice QName
elm [QName]
ns [CP]
cps in
if [[QName]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[QName]]
next then ([],[QName]
ns)
else ([], [[QName]] -> [QName]
forall a. [a] -> a
head [[QName]]
next)
checkCP _ (Choice _ Star) [] = ([],[])
checkCP elm :: QName
elm (Choice cps :: [CP]
cps Star) ns :: [QName]
ns =
let next :: [[QName]]
next = QName -> [QName] -> [CP] -> [[QName]]
choice QName
elm [QName]
ns [CP]
cps in
if [[QName]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[QName]]
next then ([],[QName]
ns)
else QName -> CP -> [QName] -> ([String], [QName])
checkCP QName
elm ([CP] -> Modifier -> CP
Choice [CP]
cps Modifier
Star) ([[QName]] -> [QName]
forall a. [a] -> a
head [[QName]]
next)
checkCP elm :: QName
elm cp :: CP
cp@(Choice _ Plus) [] = (QName -> CP -> [String]
cpError QName
elm CP
cp, [])
checkCP elm :: QName
elm cp :: CP
cp@(Choice cps :: [CP]
cps Plus) ns :: [QName]
ns =
let next :: [[QName]]
next = QName -> [QName] -> [CP] -> [[QName]]
choice QName
elm [QName]
ns [CP]
cps in
if [[QName]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[QName]]
next then (QName -> CP -> [String]
cpError QName
elm CP
cp, [QName]
ns)
else QName -> CP -> [QName] -> ([String], [QName])
checkCP QName
elm ([CP] -> Modifier -> CP
Choice [CP]
cps Modifier
Star) ([[QName]] -> [QName]
forall a. [a] -> a
head [[QName]]
next)
checkCP elm :: QName
elm cp :: CP
cp@(Seq cps :: [CP]
cps None) ns :: [QName]
ns =
let (errs :: [String]
errs,next :: [QName]
next) = QName -> [QName] -> [CP] -> ([String], [QName])
forall (t :: * -> *).
Foldable t =>
QName -> [QName] -> t CP -> ([String], [QName])
sequence QName
elm [QName]
ns [CP]
cps in
if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
errs then ([],[QName]
next)
else (QName -> CP -> [String]
cpError QName
elm CP
cp[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++[String]
errs, [QName]
ns)
checkCP _ (Seq _ Query) [] = ([],[])
checkCP elm :: QName
elm (Seq cps :: [CP]
cps Query) ns :: [QName]
ns =
let (errs :: [String]
errs,next :: [QName]
next) = QName -> [QName] -> [CP] -> ([String], [QName])
forall (t :: * -> *).
Foldable t =>
QName -> [QName] -> t CP -> ([String], [QName])
sequence QName
elm [QName]
ns [CP]
cps in
if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
errs then ([],[QName]
next)
else ([], [QName]
ns)
checkCP _ (Seq _ Star) [] = ([],[])
checkCP elm :: QName
elm (Seq cps :: [CP]
cps Star) ns :: [QName]
ns =
let (errs :: [String]
errs,next :: [QName]
next) = QName -> [QName] -> [CP] -> ([String], [QName])
forall (t :: * -> *).
Foldable t =>
QName -> [QName] -> t CP -> ([String], [QName])
sequence QName
elm [QName]
ns [CP]
cps in
if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
errs then QName -> CP -> [QName] -> ([String], [QName])
checkCP QName
elm ([CP] -> Modifier -> CP
Seq [CP]
cps Modifier
Star) [QName]
next
else ([], [QName]
ns)
checkCP elm :: QName
elm cp :: CP
cp@(Seq _ Plus) [] = (QName -> CP -> [String]
cpError QName
elm CP
cp, [])
checkCP elm :: QName
elm cp :: CP
cp@(Seq cps :: [CP]
cps Plus) ns :: [QName]
ns =
let (errs :: [String]
errs,next :: [QName]
next) = QName -> [QName] -> [CP] -> ([String], [QName])
forall (t :: * -> *).
Foldable t =>
QName -> [QName] -> t CP -> ([String], [QName])
sequence QName
elm [QName]
ns [CP]
cps in
if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
errs then QName -> CP -> [QName] -> ([String], [QName])
checkCP QName
elm ([CP] -> Modifier -> CP
Seq [CP]
cps Modifier
Star) [QName]
next
else (QName -> CP -> [String]
cpError QName
elm CP
cp[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++[String]
errs, [QName]
ns)
choice :: QName -> [QName] -> [CP] -> [[QName]]
choice elm :: QName
elm ns :: [QName]
ns cps :: [CP]
cps =
[ [QName]
rem | ([],rem :: [QName]
rem) <- (CP -> ([String], [QName])) -> [CP] -> [([String], [QName])]
forall a b. (a -> b) -> [a] -> [b]
map (\cp :: CP
cp-> QName -> CP -> [QName] -> ([String], [QName])
checkCP QName
elm (CP -> CP
definite CP
cp) [QName]
ns) [CP]
cps ]
[[QName]] -> [[QName]] -> [[QName]]
forall a. [a] -> [a] -> [a]
++ [ [QName]
ns | (CP -> Bool) -> [CP] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all CP -> Bool
possEmpty [CP]
cps ]
where definite :: CP -> CP
definite (TagName n :: QName
n Query) = QName -> Modifier -> CP
TagName QName
n Modifier
None
definite (Choice cps :: [CP]
cps Query) = [CP] -> Modifier -> CP
Choice [CP]
cps Modifier
None
definite (Seq cps :: [CP]
cps Query) = [CP] -> Modifier -> CP
Seq [CP]
cps Modifier
None
definite (TagName n :: QName
n Star) = QName -> Modifier -> CP
TagName QName
n Modifier
Plus
definite (Choice cps :: [CP]
cps Star) = [CP] -> Modifier -> CP
Choice [CP]
cps Modifier
Plus
definite (Seq cps :: [CP]
cps Star) = [CP] -> Modifier -> CP
Seq [CP]
cps Modifier
Plus
definite x :: CP
x = CP
x
possEmpty :: CP -> Bool
possEmpty (TagName _ mod :: Modifier
mod) = Modifier
mod Modifier -> [Modifier] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`Prelude.elem` [Modifier
Query,Modifier
Star]
possEmpty (Choice cps :: [CP]
cps None) = (CP -> Bool) -> [CP] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all CP -> Bool
possEmpty [CP]
cps
possEmpty (Choice _ mod :: Modifier
mod) = Modifier
mod Modifier -> [Modifier] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`Prelude.elem` [Modifier
Query,Modifier
Star]
possEmpty (Seq cps :: [CP]
cps None) = (CP -> Bool) -> [CP] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all CP -> Bool
possEmpty [CP]
cps
possEmpty (Seq _ mod :: Modifier
mod) = Modifier
mod Modifier -> [Modifier] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`Prelude.elem` [Modifier
Query,Modifier
Star]
sequence :: QName -> [QName] -> t CP -> ([String], [QName])
sequence elm :: QName
elm ns :: [QName]
ns cps :: t CP
cps =
(([String], [QName]) -> CP -> ([String], [QName]))
-> ([String], [QName]) -> t CP -> ([String], [QName])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\(es :: [String]
es,ns :: [QName]
ns) cp :: CP
cp-> let (es' :: [String]
es',ns' :: [QName]
ns') = QName -> CP -> [QName] -> ([String], [QName])
checkCP QName
elm CP
cp [QName]
ns
in ([String]
es[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++[String]
es', [QName]
ns'))
([],[QName]
ns) t CP
cps
checkIDs :: Element i -> [String]
checkIDs elm :: Element i
elm =
let celem :: Content i
celem = Element i -> i -> Content i
forall i. Element i -> i -> Content i
CElem Element i
elm i
forall a. HasCallStack => a
undefined
showAttr :: QName -> CFilter i
showAttr a :: QName
a = String -> (String -> CFilter i) -> CFilter i -> CFilter i
forall i. String -> (String -> CFilter i) -> CFilter i -> CFilter i
iffind (QName -> String
printableName QName
a) String -> CFilter i
forall i. String -> CFilter i
literal CFilter i
forall a b. a -> [b]
none
idElems :: [Content i]
idElems = ((QName, QName) -> [Content i]) -> [(QName, QName)] -> [Content i]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(name :: QName
name, at :: QName
at)->
CFilter i -> CFilter i
forall i. CFilter i -> CFilter i
multi (QName -> CFilter i
forall i. QName -> CFilter i
showAttr QName
at CFilter i -> CFilter i -> CFilter i
forall i. CFilter i -> CFilter i -> CFilter i
`o`
String -> CFilter i
forall i. String -> CFilter i
tag (QName -> String
printableName QName
name))
Content i
celem)
(SimpleDTD -> [(QName, QName)]
ids SimpleDTD
dtd)
badIds :: [String]
badIds = [String] -> [String]
forall a. Eq a => [a] -> [a]
duplicates ((Content i -> String) -> [Content i] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(CString _ s :: String
s _)->String
s) [Content i]
idElems)
in Bool -> Bool
not ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
badIds) Bool -> String -> [String]
forall a. Bool -> a -> [a]
`gives`
("These attribute values of type ID are not unique: "
String -> String -> String
forall a. [a] -> [a] -> [a]
++[String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse "," [String]
badIds)String -> String -> String
forall a. [a] -> [a] -> [a]
++".")
cpError :: QName -> CP -> [String]
cpError :: QName -> CP -> [String]
cpError elm :: QName
elm cp :: CP
cp =
["Element <"String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
qname QName
elmString -> String -> String
forall a. [a] -> [a] -> [a]
++"> should contain "String -> String -> String
forall a. [a] -> [a] -> [a]
++CP -> String
display CP
cpString -> String -> String
forall a. [a] -> [a] -> [a]
++" but does not."]
display :: CP -> String
display :: CP -> String
display (TagName name :: QName
name mod :: Modifier
mod) = QName -> String
qname QName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ Modifier -> String
modifier Modifier
mod
display (Choice cps :: [CP]
cps mod :: Modifier
mod) = "(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse "|" ((CP -> String) -> [CP] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map CP -> String
display [CP]
cps))
String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Modifier -> String
modifier Modifier
mod
display (Seq cps :: [CP]
cps mod :: Modifier
mod) = "(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse "," ((CP -> String) -> [CP] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map CP -> String
display [CP]
cps))
String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Modifier -> String
modifier Modifier
mod
modifier :: Modifier -> String
modifier :: Modifier -> String
modifier None = ""
modifier Query = "?"
modifier Star = "*"
modifier Plus = "+"
duplicates :: Eq a => [a] -> [a]
duplicates :: [a] -> [a]
duplicates xs :: [a]
xs = [a]
xs [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
\\ ([a] -> [a]
forall a. Eq a => [a] -> [a]
nub [a]
xs)
qname :: QName -> String
qname :: QName -> String
qname n :: QName
n = QName -> String
printableName QName
n