-- | 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 _ _ 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 ]
      -- 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 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     = []	-- not implemented
      }

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

-- | '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 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' 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 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) =
        -- 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` ("Element <"String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
qname QName
nameString -> String -> String
forall a. [a] -> [a] -> [a]
++"> 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`
               ("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]
++"."))
        -- 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 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 [] = []

    -- 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 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)
 -- omit this clause, to permit (a?|b?) as a valid but empty choice
 -- checkCP elem cp@(Choice cps None) [] = (cpError elem cp, [])
    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)	-- choose the first alternative with no errors
    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)
 -- omit this clause, to permit (a?,b?) as a valid but empty sequence
 -- checkCP elem cp@(Seq cps None) [] = (cpError elem cp, [])
    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 =  -- return only those parses that don't give any errors
        [ [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 =  -- 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 (\(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