    -- | 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 (intercalate,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 :: forall a b. Ord a => [(a, b)] -> FiniteMap a b
    listToFM = [(a, b)] -> Map a b
    forall a b. Ord a => [(a, b)] -> FiniteMap a b
    Map.fromList
    lookupFM :: Ord a => FiniteMap a b -> a -> Maybe b
    lookupFM :: forall a b. Ord a => 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
          { elements :: FiniteMap QName ContentSpec
    elements   = [(QName, ContentSpec)] -> FiniteMap QName ContentSpec
    forall a b. Ord a => [(a, b)] -> FiniteMap a b
    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 a b. Ord a => [(a, b)] -> FiniteMap a b
    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 a b. Ord a => [(a, b)] -> FiniteMap a b
    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 :: forall a. 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 :: forall i. 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 :: forall i. 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 a. [a] -> 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] -> String
    forall a. [a] -> [[a]] -> [a]
    intercalate String
    "," [String]
    dupsString -> 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 ->
                        (String
    attval String -> [String] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `notElem` [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 =
            (QName
    req QName -> [QName] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `notElem` ((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
    _)
            | QName
    name QName -> t QName -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `notElem` 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 a. [a] -> 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. HasCallStack => [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 a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [[QName]]
    next then ([],[QName]
    ns)
            else ([], [[QName]] -> [QName]
    forall a. HasCallStack => [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 a. [a] -> 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. HasCallStack => [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 a. [a] -> 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. HasCallStack => [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 a. [a] -> 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 a. [a] -> 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 a. [a] -> 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 a. [a] -> 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 a. Eq a => a -> [a] -> 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 a. Eq a => a -> [a] -> 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 a. Eq a => a -> [a] -> 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 b a. (b -> a -> b) -> b -> t a -> b
    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 a. [a] -> 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] -> String
    forall a. [a] -> [[a]] -> [a]
    intercalate String
    "," [String]
    badIdsString -> 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] -> String
    forall a. [a] -> [[a]] -> [a]
    intercalate 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] -> String
    forall a. [a] -> [[a]] -> [a]
    intercalate 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 :: forall a. Eq a => [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