-- | Validate a document against a dtd.
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__)
-- emulate older finite map interface using Data.Map, if it is available
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
-- real finite map, if it is available
import Data.FiniteMap
#else
-- otherwise, a very simple and inefficient implementation of a finite map
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

-- gather appropriate information out of the DTD
data SimpleDTD = SimpleDTD
    { SimpleDTD -> FiniteMap QName ContentSpec
elements   :: FiniteMap QName ContentSpec -- content model of elem
    , SimpleDTD -> FiniteMap (QName, QName) AttType
attributes :: FiniteMap (QName,QName) AttType -- type of (elem,attr)
    , SimpleDTD -> FiniteMap QName [QName]
required   :: FiniteMap QName [QName]     -- required attributes of elem
    , SimpleDTD -> [(QName, QName)]
ids        :: [(QName,QName)]     -- all (element,attr) with ID type
    , SimpleDTD -> [(QName, QName)]
idrefs     :: [(QName,QName)]     -- all (element,attr) with IDREF type
    }

simplifyDTD :: DocTypeDecl -> SimpleDTD
simplifyDTD :: DocTypeDecl -> SimpleDTD
simplifyDTD (DTD QName
_ Maybe ExternalID
_ [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 QName
name 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 QName
elem [AttDef]
attdefs) <- [MarkupDecl]
decls
                              , AttDef QName
attr AttType
typ DefaultDecl
_ <- [AttDef]
attdefs ]
      -- Be sure to look at all attribute declarations for each
      -- element, since we must merge them.  This implements the
      -- specification in that regard only; the specification's rules
      -- about how to merge multiple declarations for the same
      -- attribute are not considered by this implementation.
      -- See: http://www.w3.org/TR/REC-xml/#NT-AttlistDecl
      , 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 QName
attr AttType
_ DefaultDecl
REQUIRED <- [AttDef]
attdefs ]
                                              | AttList (AttListDecl QName
elem' [AttDef]
attdefs) <- [MarkupDecl]
decls
                                              , QName
elem' QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
elem ]
                                )
                              | Element (ElementDecl QName
elem ContentSpec
_) <- [MarkupDecl]
decls ]
      , ids :: [(QName, QName)]
ids        = [ (QName
elem,QName
attr)
                     | Element (ElementDecl QName
elem ContentSpec
_) <- [MarkupDecl]
decls
                     , AttList (AttListDecl QName
name [AttDef]
attdefs) <- [MarkupDecl]
decls
                     , QName
elem QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
name
                     , AttDef QName
attr (TokenizedType TokenizedType
ID) DefaultDecl
_ <- [AttDef]
attdefs ]
      , idrefs :: [(QName, QName)]
idrefs     = [] -- not implemented
      }

-- simple auxiliary to avoid lots of if-then-else with empty else clauses.
gives :: Bool -> a -> [a]
Bool
True gives :: Bool -> a -> [a]
`gives` a
x = [a
x]
Bool
False `gives` a
_ = []

-- | 'validate' takes a DTD and a tagged element, and returns a list of
--   errors in the document with respect to its DTD.
--
--   If you have several documents to validate against a single DTD,
--   then you will gain efficiency by freezing-in the DTD through partial
--   application, e.g. @checkMyDTD = validate myDTD@.
validate :: DocTypeDecl -> Element i -> [String]
validate :: DocTypeDecl -> Element i -> [String]
validate DocTypeDecl
dtd' 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 QName
name Maybe ExternalID
_ [MarkupDecl]
_) (Elem QName
name' [Attribute]
_ [Content i]
_) =
        (QName
nameQName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
/=QName
name') Bool -> String -> [String]
forall a. Bool -> a -> [a]
`gives` (String
"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]
++String
"> 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]
++String
">.")

-- | 'partialValidate' is like validate, except that it does not check that
--   the element type matches that of the DTD's root element.
partialValidate :: DocTypeDecl -> Element i -> [String]
partialValidate :: DocTypeDecl -> Element i -> [String]
partialValidate DocTypeDecl
dtd' 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 QName
name [Attribute]
attrs [Content i]
contents) =
        -- is the element defined in the DTD?
        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` (String
"Element <"String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
qname QName
nameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"> not known.")
        -- is each attribute mentioned only once?
        [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`
               (String
"Element <"String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
qname QName
nameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"> 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
"," [String]
dups)String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"."))
        -- does each attribute belong to this element?  value is in range?
        [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
        -- are all required attributes present?
        [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))
        -- are its children in a permissible sequence?
        [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
        -- now recursively check the element children
        [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 Element i
elm i
_ <- [Content i]
contents ]

    checkAttr :: QName -> Attribute -> [String]
checkAttr QName
elm (QName
attr, 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 [String
"Attribute \""String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
qname QName
attr
                               String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\" not known for element <"String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
qname QName
elmString -> String -> String
forall a. [a] -> [a] -> [a]
++String
">."]
        else
          case Maybe AttType -> AttType
forall a. HasCallStack => Maybe a -> a
fromJust Maybe AttType
typ of
            EnumeratedType EnumeratedType
e ->
              case EnumeratedType
e of
                Enumeration [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`
                          (String
"Value \""String -> String -> String
forall a. [a] -> [a] -> [a]
++String
attvalString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\" of attribute \""
                           String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
qname QName
attrString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\" in element <"String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
qname QName
elm
                           String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"> is not in the required enumeration range: "
                           String -> String -> String
forall a. [a] -> [a] -> [a]
++[String] -> String
unwords [String]
es)
                EnumeratedType
_ -> []
            AttType
_ -> []

    checkRequired :: QName -> [(QName, b)] -> QName -> [String]
checkRequired QName
elm [(QName, b)]
attrs 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`
            (String
"Element <"String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
qname QName
elmString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"> requires the attribute \""String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
qname QName
req
             String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\" but it is missing.")

    checkContentSpec :: QName -> ContentSpec -> [Content i] -> [String]
checkContentSpec QName
_elm ContentSpec
ANY   [Content i]
_     = []
    checkContentSpec QName
_elm ContentSpec
EMPTY []    = []
    checkContentSpec  QName
elm ContentSpec
EMPTY (Content i
_:[Content i]
_) =
        [String
"Element <"String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
qname QName
elmString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"> is not empty but should be."]
    checkContentSpec  QName
elm (Mixed Mixed
PCDATA) [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  QName
elm (Mixed (PCDATAplus [QName]
names)) [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  QName
elm (ContentSpec CP
cp) [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 ([String]
errs,[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
                      [QName]
_  -> [String]
errs[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++[String
"Element <"String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
qname QName
elmString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"> contains extra "
                                  String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"elements beyond its content spec."])

    checkMixed :: QName -> t QName -> Content i -> [String]
checkMixed  QName
elm  t QName
permitted (CElem (Elem QName
name [Attribute]
_ [Content i]
_) i
_)
        | 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) =
            [String
"Element <"String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
qname QName
elmString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"> contains an element <"String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
qname QName
name
             String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"> but should not."]
    checkMixed QName
_elm t QName
_permitted Content i
_ = []

    flatten :: [Content i] -> [QName]
flatten (CElem (Elem QName
name [Attribute]
_ [Content i]
_) i
_: [Content i]
cs) = QName
nameQName -> [QName] -> [QName]
forall a. a -> [a] -> [a]
: [Content i] -> [QName]
flatten [Content i]
cs
    flatten (Content i
_: [Content i]
cs)                       = [Content i] -> [QName]
flatten [Content i]
cs
    flatten []                            = []

    excludeText :: QName -> [Content i] -> [String]
excludeText  QName
elm (CElem Element i
_ i
_: [Content i]
cs) = QName -> [Content i] -> [String]
excludeText QName
elm [Content i]
cs
    excludeText  QName
elm (CMisc Misc
_ i
_: [Content i]
cs) = QName -> [Content i] -> [String]
excludeText QName
elm [Content i]
cs
    excludeText  QName
elm (CString Bool
_ String
s i
_: [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  QName
elm (Content i
_:[Content i]
_) =
        [String
"Element <"String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
qname QName
elmString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"> contains text/references but should not."]
    excludeText QName
_elm [] = []

    -- This is a little parser really.  Returns any errors, plus the remainder
    -- of the input string.
    checkCP :: QName -> CP -> [QName] -> ([String],[QName])
    checkCP :: QName -> CP -> [QName] -> ([String], [QName])
checkCP QName
elm cp :: CP
cp@(TagName QName
_ Modifier
None) []       = (QName -> CP -> [String]
cpError QName
elm CP
cp, [])
    checkCP QName
elm cp :: CP
cp@(TagName QName
n Modifier
None) (QName
n':[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  QName
_     (TagName QName
_ Modifier
Query) []      = ([],[])
    checkCP  QName
_     (TagName QName
n Modifier
Query) (QName
n':[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  QName
_     (TagName QName
_ Modifier
Star) []       = ([],[])
    checkCP QName
elm    (TagName QName
n Modifier
Star) (QName
n':[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 QName
elm cp :: CP
cp@(TagName QName
_ Modifier
Plus) []       = (QName -> CP -> [String]
cpError QName
elm CP
cp, [])
    checkCP QName
elm cp :: CP
cp@(TagName QName
n Modifier
Plus) (QName
n':[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)
 -- omit this clause, to permit (a?|b?) as a valid but empty choice
 -- checkCP elem cp@(Choice cps None) [] = (cpError elem cp, [])
    checkCP QName
elm cp :: CP
cp@(Choice [CP]
cps Modifier
None) [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)    -- choose the first alternative with no errors
    checkCP QName
_      (Choice [CP]
_   Modifier
Query) [] = ([],[])
    checkCP QName
elm    (Choice [CP]
cps Modifier
Query) [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 QName
_      (Choice [CP]
_   Modifier
Star) [] = ([],[])
    checkCP QName
elm    (Choice [CP]
cps Modifier
Star) [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 QName
elm cp :: CP
cp@(Choice [CP]
_   Modifier
Plus) [] = (QName -> CP -> [String]
cpError QName
elm CP
cp, [])
    checkCP QName
elm cp :: CP
cp@(Choice [CP]
cps Modifier
Plus) [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)
 -- omit this clause, to permit (a?,b?) as a valid but empty sequence
 -- checkCP elem cp@(Seq cps None) [] = (cpError elem cp, [])
    checkCP QName
elm cp :: CP
cp@(Seq [CP]
cps Modifier
None) [QName]
ns =
        let ([String]
errs,[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 QName
_      (Seq [CP]
_   Modifier
Query) [] = ([],[])
    checkCP QName
elm    (Seq [CP]
cps Modifier
Query) [QName]
ns =
        let ([String]
errs,[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 QName
_      (Seq [CP]
_   Modifier
Star) [] = ([],[])
    checkCP QName
elm    (Seq [CP]
cps Modifier
Star) [QName]
ns =
        let ([String]
errs,[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 QName
elm cp :: CP
cp@(Seq [CP]
_   Modifier
Plus) [] = (QName -> CP -> [String]
cpError QName
elm CP
cp, [])
    checkCP QName
elm cp :: CP
cp@(Seq [CP]
cps Modifier
Plus) [QName]
ns =
        let ([String]
errs,[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 QName
elm [QName]
ns [CP]
cps =  -- return only those parses that don't give any errors
        [ [QName]
rem | ([],[QName]
rem) <- (CP -> ([String], [QName])) -> [CP] -> [([String], [QName])]
forall a b. (a -> b) -> [a] -> [b]
map (\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 QName
n Modifier
Query)  = QName -> Modifier -> CP
TagName QName
n Modifier
None
              definite (Choice [CP]
cps Modifier
Query) = [CP] -> Modifier -> CP
Choice [CP]
cps Modifier
None
              definite (Seq [CP]
cps Modifier
Query)    = [CP] -> Modifier -> CP
Seq [CP]
cps Modifier
None
              definite (TagName QName
n Modifier
Star)   = QName -> Modifier -> CP
TagName QName
n Modifier
Plus
              definite (Choice [CP]
cps Modifier
Star)  = [CP] -> Modifier -> CP
Choice [CP]
cps Modifier
Plus
              definite (Seq [CP]
cps Modifier
Star)     = [CP] -> Modifier -> CP
Seq [CP]
cps Modifier
Plus
              definite CP
x                  = CP
x
              possEmpty :: CP -> Bool
possEmpty (TagName QName
_ 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 [CP]
cps Modifier
None) = (CP -> Bool) -> [CP] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all CP -> Bool
possEmpty [CP]
cps
              possEmpty (Choice [CP]
_ 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 [CP]
cps Modifier
None)    = (CP -> Bool) -> [CP] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all CP -> Bool
possEmpty [CP]
cps
              possEmpty (Seq [CP]
_ 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 QName
elm [QName]
ns t CP
cps =  -- accumulate errors down the sequence
        (([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 (\([String]
es,[QName]
ns) CP
cp-> let ([String]
es',[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 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 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 (\(QName
name, 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 Bool
_ String
s i
_)->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`
               (String
"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
"," [String]
badIds)String -> String -> String
forall a. [a] -> [a] -> [a]
++String
".")


cpError :: QName -> CP -> [String]
cpError :: QName -> CP -> [String]
cpError QName
elm CP
cp =
    [String
"Element <"String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
qname QName
elmString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"> should contain "String -> String -> String
forall a. [a] -> [a] -> [a]
++CP -> String
display CP
cpString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" but does not."]


display :: CP -> String
display :: CP -> String
display (TagName QName
name Modifier
mod) = QName -> String
qname QName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ Modifier -> String
modifier Modifier
mod
display (Choice [CP]
cps Modifier
mod)   = String
"(" 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
"|" ((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 -> String
forall a. [a] -> [a] -> [a]
++ Modifier -> String
modifier Modifier
mod
display (Seq [CP]
cps Modifier
mod)      = String
"(" 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
"," ((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 -> String
forall a. [a] -> [a] -> [a]
++ Modifier -> String
modifier Modifier
mod

modifier :: Modifier -> String
modifier :: Modifier -> String
modifier Modifier
None  = String
""
modifier Modifier
Query = String
"?"
modifier Modifier
Star  = String
"*"
modifier Modifier
Plus  = String
"+"

duplicates :: Eq a => [a] -> [a]
duplicates :: [a] -> [a]
duplicates [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 QName
n = QName -> String
printableName QName
n