module Text.XML.HaXml.Schema.Parse
  ( module Text.XML.HaXml.Schema.Parse
  ) where

import Data.Char (isSpace)
import Data.List (isPrefixOf)
import Data.Monoid (Monoid(mappend))
-- import Text.ParserCombinators.Poly
import Text.Parse    -- for String parsers

import Text.XML.HaXml.Types      (Name,QName(..),Namespace(..),Attribute(..)
                                 ,Content(..),Element(..),info)
import Text.XML.HaXml.Namespaces
import Text.XML.HaXml.Verbatim hiding (qname)
import Text.XML.HaXml.Posn
import Text.XML.HaXml.Schema.XSDTypeModel as XSD
import Text.XML.HaXml.XmlContent.Parser (text)


-- | Lift boolean 'or' over predicates.
(|||) :: (a->Bool) -> (a->Bool) -> (a->Bool)
a -> Bool
p ||| :: forall a. (a -> Bool) -> (a -> Bool) -> a -> Bool
||| a -> Bool
q = \a
v -> a -> Bool
p a
v Bool -> Bool -> Bool
|| a -> Bool
q a
v

-- | Qualify an ordinary name with the XSD namespace.
xsd :: Name -> QName
xsd :: TargetNamespace -> QName
xsd = Namespace -> TargetNamespace -> QName
QN Namespace{nsPrefix :: TargetNamespace
nsPrefix=TargetNamespace
"xsd",nsURI :: TargetNamespace
nsURI=TargetNamespace
"http://www.w3.org/2001/XMLSchema"}

-- | Predicate for comparing against an XSD-qualified name.  (Also accepts
--   unqualified names, but this is probably a bit too lax.  Doing it right
--   would require checking to see whether the current schema module's default
--   namespace is XSD or not.)
xsdTag :: String -> Content Posn -> Bool
xsdTag :: TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
tag (CElem (Elem QName
qn [Attribute]
_ [Content Posn]
_) Posn
_)  =  QName
qn forall a. Eq a => a -> a -> Bool
== TargetNamespace -> QName
xsd TargetNamespace
tag Bool -> Bool -> Bool
|| QName
qn forall a. Eq a => a -> a -> Bool
== TargetNamespace -> QName
N TargetNamespace
tag
xsdTag TargetNamespace
_   Content Posn
_                        =  Bool
False

-- | We need a Parser monad for reading from a sequence of generic XML
--   Contents into specific datatypes that model the structure of XSD
--   descriptions.  This is a specialisation of the polyparse combinators,
--   fixing the input token type.
type XsdParser a = Parser (Content Posn) a

-- | Get the next content element, checking that it matches some criterion
--   given by the predicate.
--   (Skips over comments and whitespace, rejects text and refs.
--    Also returns position of element.)
--   The list of strings argument is for error reporting - it usually
--   represents a list of expected tags.
posnElementWith :: (Content Posn->Bool) -> [String]
                   -> XsdParser (Posn,Element Posn)
posnElementWith :: (Content Posn -> Bool)
-> [TargetNamespace] -> XsdParser (Posn, Element Posn)
posnElementWith Content Posn -> Bool
match [TargetNamespace]
tags = do
    { Content Posn
c <- forall t. Parser t t
next forall (p :: * -> *) a.
Commitment p =>
p a -> (TargetNamespace -> TargetNamespace) -> p a
`adjustErr` (forall a. [a] -> [a] -> [a]
++TargetNamespace
" when expecting "forall a. [a] -> [a] -> [a]
++[TargetNamespace] -> TargetNamespace
formatted [TargetNamespace]
tags)
    ; case Content Posn
c of
        CElem Element Posn
e Posn
pos
            | Content Posn -> Bool
match Content Posn
c   -> forall (m :: * -> *) a. Monad m => a -> m a
return (Posn
pos,Element Posn
e)
        CElem (Elem QName
t [Attribute]
_ [Content Posn]
_) Posn
pos
            | Bool
otherwise -> forall (m :: * -> *) a. MonadFail m => TargetNamespace -> m a
fail (TargetNamespace
"Found a <"forall a. [a] -> [a] -> [a]
++QName -> TargetNamespace
printableName QName
t
                                 forall a. [a] -> [a] -> [a]
++TargetNamespace
">, but expected "
                                 forall a. [a] -> [a] -> [a]
++[TargetNamespace] -> TargetNamespace
formatted [TargetNamespace]
tagsforall a. [a] -> [a] -> [a]
++TargetNamespace
"\nat "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> TargetNamespace
show Posn
pos)
        CString Bool
b TargetNamespace
s Posn
pos  -- ignore blank space
            | Bool -> Bool
not Bool
b Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace TargetNamespace
s -> (Content Posn -> Bool)
-> [TargetNamespace] -> XsdParser (Posn, Element Posn)
posnElementWith Content Posn -> Bool
match [TargetNamespace]
tags
            | Bool
otherwise -> forall (m :: * -> *) a. MonadFail m => TargetNamespace -> m a
fail (TargetNamespace
"Found text content, but expected "
                                 forall a. [a] -> [a] -> [a]
++[TargetNamespace] -> TargetNamespace
formatted [TargetNamespace]
tagsforall a. [a] -> [a] -> [a]
++TargetNamespace
"\ntext is: "forall a. [a] -> [a] -> [a]
++TargetNamespace
s
                                 forall a. [a] -> [a] -> [a]
++TargetNamespace
"\nat "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> TargetNamespace
show Posn
pos)
        CRef Reference
r Posn
pos -> forall (m :: * -> *) a. MonadFail m => TargetNamespace -> m a
fail (TargetNamespace
"Found reference, but expected "
                            forall a. [a] -> [a] -> [a]
++[TargetNamespace] -> TargetNamespace
formatted [TargetNamespace]
tagsforall a. [a] -> [a] -> [a]
++TargetNamespace
"\nreference is: "forall a. [a] -> [a] -> [a]
++forall a. Verbatim a => a -> TargetNamespace
verbatim Reference
r
                            forall a. [a] -> [a] -> [a]
++TargetNamespace
"\nat "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> TargetNamespace
show Posn
pos)
        CMisc Misc
_ Posn
_ -> (Content Posn -> Bool)
-> [TargetNamespace] -> XsdParser (Posn, Element Posn)
posnElementWith Content Posn -> Bool
match [TargetNamespace]
tags  -- skip comments, PIs, etc.
    }
  where
    formatted :: [TargetNamespace] -> TargetNamespace
formatted [TargetNamespace
t]  = TargetNamespace
"a <"forall a. [a] -> [a] -> [a]
++TargetNamespace
tforall a. [a] -> [a] -> [a]
++TargetNamespace
">"
    formatted [TargetNamespace]
tgs = TargetNamespace
"one of"forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\TargetNamespace
t->TargetNamespace
" <"forall a. [a] -> [a] -> [a]
++TargetNamespace
tforall a. [a] -> [a] -> [a]
++TargetNamespace
">") [TargetNamespace]
tgs

-- | Get the next content element, checking that it has the required tag
--   belonging to the XSD namespace.
xsdElement :: Name -> XsdParser (Element Posn)
xsdElement :: TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
n = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd ((Content Posn -> Bool)
-> [TargetNamespace] -> XsdParser (Posn, Element Posn)
posnElementWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
n) [TargetNamespace
"xsd:"forall a. [a] -> [a] -> [a]
++TargetNamespace
n])

-- | Get the next content element, whatever it is.
anyElement :: XsdParser (Element Posn)
anyElement :: XsdParser (Element Posn)
anyElement = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd ((Content Posn -> Bool)
-> [TargetNamespace] -> XsdParser (Posn, Element Posn)
posnElementWith (forall a b. a -> b -> a
const Bool
True) [TargetNamespace
"any element"])

-- | Grab and parse any and all children of the next element.
allChildren :: XsdParser a -> XsdParser a
allChildren :: forall a. XsdParser a -> XsdParser a
allChildren XsdParser a
p = do Element Posn
e <- XsdParser (Element Posn)
anyElement
                   forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (forall a b. a -> b -> a
const Bool
True) XsdParser a
p Element Posn
e

-- | Run an XsdParser on the child contents of the given element (i.e. not
--   in the current monadic content sequence), filtering the children
--   before parsing, and checking that the contents are exhausted, before
--   returning the calculated value within the current parser context.
interiorWith :: (Content Posn->Bool) -> XsdParser a
                -> Element Posn -> XsdParser a
interiorWith :: forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith Content Posn -> Bool
keep (P [Content Posn] -> Result [Content Posn] a
p) (Elem QName
e [Attribute]
_ [Content Posn]
cs) = forall t a. ([t] -> Result [t] a) -> Parser t a
P forall a b. (a -> b) -> a -> b
$ \[Content Posn]
inp->
    forall t x a. t -> Result x a -> Result t a
tidy [Content Posn]
inp forall a b. (a -> b) -> a -> b
$
    case [Content Posn] -> Result [Content Posn] a
p (forall a. (a -> Bool) -> [a] -> [a]
filter Content Posn -> Bool
keep [Content Posn]
cs) of
        Committed Result [Content Posn] a
r        -> Result [Content Posn] a
r
        f :: Result [Content Posn] a
f@(Failure [Content Posn]
_ TargetNamespace
_)    -> Result [Content Posn] a
f
        s :: Result [Content Posn] a
s@(Success [] a
_)   -> Result [Content Posn] a
s
        Success ds :: [Content Posn]
ds@(Content Posn
d:[Content Posn]
_) a
a
            | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall {i}. Content i -> Bool
onlyMisc [Content Posn]
ds -> forall z a. z -> a -> Result z a
Success [] a
a
            | Bool
otherwise       -> forall z a. Result z a -> Result z a
Committed forall a b. (a -> b) -> a -> b
$
                                 forall z a. z -> TargetNamespace -> Result z a
Failure [Content Posn]
ds (TargetNamespace
"Too many elements inside <"
                                             forall a. [a] -> [a] -> [a]
++QName -> TargetNamespace
printableName QName
eforall a. [a] -> [a] -> [a]
++TargetNamespace
"> at\n"
                                             forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> TargetNamespace
show (forall t. Content t -> t
info Content Posn
d)forall a. [a] -> [a] -> [a]
++TargetNamespace
"\n\n"
                                             forall a. [a] -> [a] -> [a]
++TargetNamespace
"Found excess: "
                                             forall a. [a] -> [a] -> [a]
++forall a. Verbatim a => a -> TargetNamespace
verbatim (forall a. Int -> [a] -> [a]
take Int
5 [Content Posn]
ds))
  where onlyMisc :: Content i -> Bool
onlyMisc (CMisc Misc
_ i
_) = Bool
True
        onlyMisc (CString Bool
False TargetNamespace
s i
_) | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace TargetNamespace
s = Bool
True
        onlyMisc Content i
_ = Bool
False

-- | Check for the presence (and value) of an attribute in the given element.
--   Absence results in failure.
attribute :: QName -> TextParser a -> Element Posn -> XsdParser a
attribute :: forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute QName
qn (P TargetNamespace -> Result TargetNamespace a
p) (Elem QName
n [Attribute]
as [Content Posn]
_) = forall t a. ([t] -> Result [t] a) -> Parser t a
P forall a b. (a -> b) -> a -> b
$ \[Content Posn]
inp->
    case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup QName
qn [Attribute]
as of
        Maybe AttValue
Nothing  -> forall z a. z -> TargetNamespace -> Result z a
Failure [Content Posn]
inp forall a b. (a -> b) -> a -> b
$ TargetNamespace
"attribute "forall a. [a] -> [a] -> [a]
++QName -> TargetNamespace
printableName QName
qn
                                  forall a. [a] -> [a] -> [a]
++TargetNamespace
" not present in <"forall a. [a] -> [a] -> [a]
++QName -> TargetNamespace
printableName QName
nforall a. [a] -> [a] -> [a]
++TargetNamespace
">"
        Just AttValue
atv -> forall t x a. t -> Result x a -> Result t a
tidy [Content Posn]
inp forall a b. (a -> b) -> a -> b
$
                    case TargetNamespace -> Result TargetNamespace a
p (forall a. Show a => a -> TargetNamespace
show AttValue
atv) of
                      Committed Result TargetNamespace a
r   -> Result TargetNamespace a
r
                      Failure TargetNamespace
z TargetNamespace
msg -> forall z a. z -> TargetNamespace -> Result z a
Failure TargetNamespace
z forall a b. (a -> b) -> a -> b
$
                                             TargetNamespace
"Attribute parsing failure: "
                                             forall a. [a] -> [a] -> [a]
++QName -> TargetNamespace
printableName QName
qnforall a. [a] -> [a] -> [a]
++TargetNamespace
"=\""
                                             forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> TargetNamespace
show AttValue
atvforall a. [a] -> [a] -> [a]
++TargetNamespace
"\": "forall a. [a] -> [a] -> [a]
++TargetNamespace
msg
                      Success [] a
v  -> forall z a. z -> a -> Result z a
Success [] a
v
                      Success TargetNamespace
xs a
_  -> forall z a. Result z a -> Result z a
Committed forall a b. (a -> b) -> a -> b
$
                                       forall z a. z -> TargetNamespace -> Result z a
Failure TargetNamespace
xs forall a b. (a -> b) -> a -> b
$
                                             TargetNamespace
"Attribute parsing excess text: "
                                             forall a. [a] -> [a] -> [a]
++QName -> TargetNamespace
printableName QName
qnforall a. [a] -> [a] -> [a]
++TargetNamespace
"=\""
                                             forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> TargetNamespace
show AttValue
atvforall a. [a] -> [a] -> [a]
++TargetNamespace
"\":\n  Excess is: "
                                             forall a. [a] -> [a] -> [a]
++TargetNamespace
xs

-- | Grab any attributes that declare a locally-used prefix for a
--   specific namespace.
namespaceAttrs :: Element Posn -> XsdParser [Namespace]
namespaceAttrs :: Element Posn -> XsdParser [Namespace]
namespaceAttrs (Elem QName
_ [Attribute]
as [Content Posn]
_) =
    forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Verbatim a => (QName, a) -> Namespace
mkNamespace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (TargetNamespace -> Attribute -> Bool
matchNamespace TargetNamespace
"xmlns") forall a b. (a -> b) -> a -> b
$ [Attribute]
as
  where
    deQN :: QName -> TargetNamespace
deQN (QN Namespace
_ TargetNamespace
n) = TargetNamespace
n
    mkNamespace :: (QName, a) -> Namespace
mkNamespace (QName
attname,a
attval) = Namespace { nsPrefix :: TargetNamespace
nsPrefix = QName -> TargetNamespace
deQN QName
attname
                                             , nsURI :: TargetNamespace
nsURI    = forall a. Verbatim a => a -> TargetNamespace
verbatim a
attval
                                             }

-- | Predicate for whether an attribute belongs to a given namespace.
matchNamespace :: String -> Attribute -> Bool
matchNamespace :: TargetNamespace -> Attribute -> Bool
matchNamespace TargetNamespace
n (N TargetNamespace
m,     AttValue
_) =   Bool
False  -- (n++":") `isPrefixOf` m
matchNamespace TargetNamespace
n (QN Namespace
ns TargetNamespace
_, AttValue
_) =   TargetNamespace
n forall a. Eq a => a -> a -> Bool
== Namespace -> TargetNamespace
nsPrefix Namespace
ns

-- | Tidy up the parsing context.
tidy :: t -> Result x a -> Result t a
tidy :: forall t x a. t -> Result x a -> Result t a
tidy t
inp (Committed Result x a
r) = forall t x a. t -> Result x a -> Result t a
tidy t
inp Result x a
r
tidy t
inp (Failure x
_ TargetNamespace
m) = forall z a. z -> TargetNamespace -> Result z a
Failure t
inp TargetNamespace
m
tidy t
inp (Success x
_ a
v) = forall z a. z -> a -> Result z a
Success t
inp a
v

-- | Given a URI for a targetNamespace, and a list of Namespaces, tell
--   me the prefix corresponding to the targetNamespace.
targetPrefix :: Maybe TargetNamespace -> [Namespace] -> Maybe String
targetPrefix :: Maybe TargetNamespace -> [Namespace] -> Maybe TargetNamespace
targetPrefix Maybe TargetNamespace
Nothing    [Namespace]
_   = forall a. Maybe a
Nothing
targetPrefix (Just TargetNamespace
uri) [Namespace]
nss = Namespace -> TargetNamespace
nsPrefix forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> Maybe a
lookupBy ((forall a. Eq a => a -> a -> Bool
==TargetNamespace
uri)forall b c a. (b -> c) -> (a -> b) -> a -> c
.Namespace -> TargetNamespace
nsURI) [Namespace]
nss

-- | An auxiliary you might expect to find in Data.List
lookupBy :: (a->Bool) -> [a] -> Maybe a
lookupBy :: forall a. (a -> Bool) -> [a] -> Maybe a
lookupBy a -> Bool
p []     = forall a. Maybe a
Nothing
lookupBy a -> Bool
p (a
y:[a]
ys) | a -> Bool
p a
y       = forall a. a -> Maybe a
Just a
y
                  | Bool
otherwise = forall a. (a -> Bool) -> [a] -> Maybe a
lookupBy a -> Bool
p [a]
ys

-- | Turn a qualified attribute value (two strings) into a qualified name
--   (QName), but excluding the case where the namespace prefix corresponds
--   to the targetNamespace of the current schema document.
qual :: Maybe TargetNamespace -> [Namespace] -> String-> String -> QName
qual :: Maybe TargetNamespace
-> [Namespace] -> TargetNamespace -> TargetNamespace -> QName
qual Maybe TargetNamespace
tn [Namespace]
nss TargetNamespace
pre TargetNamespace
nm = case Maybe TargetNamespace -> [Namespace] -> Maybe TargetNamespace
targetPrefix Maybe TargetNamespace
tn [Namespace]
nss of
                         Maybe TargetNamespace
Nothing             -> Namespace -> TargetNamespace -> QName
QN Namespace
thisNS TargetNamespace
nm
                         Just TargetNamespace
p  | TargetNamespace
pforall a. Eq a => a -> a -> Bool
/=TargetNamespace
pre    -> Namespace -> TargetNamespace -> QName
QN Namespace
thisNS TargetNamespace
nm
                                 | Bool
otherwise -> TargetNamespace -> QName
N TargetNamespace
nm
    where thisNS :: Namespace
thisNS = Namespace{ nsPrefix :: TargetNamespace
nsPrefix = TargetNamespace
pre
                            , nsURI :: TargetNamespace
nsURI = forall b a. b -> (a -> b) -> Maybe a -> b
maybe TargetNamespace
"" Namespace -> TargetNamespace
nsURI forall a b. (a -> b) -> a -> b
$
                                      forall a. (a -> Bool) -> [a] -> Maybe a
lookupBy ((forall a. Eq a => a -> a -> Bool
==TargetNamespace
pre)forall b c a. (b -> c) -> (a -> b) -> a -> c
.Namespace -> TargetNamespace
nsPrefix) [Namespace]
nss
                            }

-- Now for the real parsers.

-- | Parse a Schema declaration
schema :: Parser (Content Posn) Schema
schema = do
    Element Posn
e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"schema"
    forall (p :: * -> *) a. Commitment p => p a -> p a
commit forall a b. (a -> b) -> a -> b
$ do
        Maybe TargetNamespace
tn  <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"targetNamespace") TextParser TargetNamespace
uri Element Posn
e)
        [Namespace]
nss <- Element Posn -> XsdParser [Namespace]
namespaceAttrs Element Posn
e
        forall (m :: * -> *) a. Monad m => a -> m a
return QForm
-> QForm
-> Maybe Block
-> Maybe Block
-> Maybe TargetNamespace
-> Maybe TargetNamespace
-> [Namespace]
-> [SchemaItem]
-> Schema
Schema
          forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"elementFormDefault")    TextParser QForm
qform Element Posn
e
                   forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` forall (m :: * -> *) a. Monad m => a -> m a
return QForm
Unqualified)
          forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"attributeFormDefault")  TextParser QForm
qform Element Posn
e
                   forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` forall (m :: * -> *) a. Monad m => a -> m a
return QForm
Unqualified)
          forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
xsd TargetNamespace
"finalDefault") TextParser Block
final Element Posn
e)
          forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
xsd TargetNamespace
"blockDefault") TextParser Block
block Element Posn
e)
          forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TargetNamespace
tn
          forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"version")       TextParser TargetNamespace
string Element Posn
e)
          forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall (m :: * -> *) a. Monad m => a -> m a
return [Namespace]
nss
          forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (forall a b. a -> b -> a
const Bool
True) (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ((TargetNamespace -> TargetNamespace -> QName)
-> XsdParser SchemaItem
schemaItem (Maybe TargetNamespace
-> [Namespace] -> TargetNamespace -> TargetNamespace -> QName
qual Maybe TargetNamespace
tn [Namespace]
nss))) Element Posn
e

-- | Parse a (possibly missing) <xsd:annotation> element.
annotation :: XsdParser Annotation
annotation :: XsdParser Annotation
annotation = do
    XsdParser Annotation
definiteAnnotation forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` forall (m :: * -> *) a. Monad m => a -> m a
return (TargetNamespace -> Annotation
NoAnnotation TargetNamespace
"missing")

-- | Parse a definitely-occurring <xsd:annotation> element.
definiteAnnotation :: XsdParser Annotation
definiteAnnotation :: XsdParser Annotation
definiteAnnotation = do
    Element Posn
e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"annotation"
    ( TargetNamespace -> Annotation
Documentation forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"documentation")
                                        (forall a. XsdParser a -> XsdParser a
allChildren XMLParser TargetNamespace
text)  Element Posn
e)
      forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
      (TargetNamespace -> Annotation
AppInfo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"documentation")
                                        (forall a. XsdParser a -> XsdParser a
allChildren XMLParser TargetNamespace
text)  Element Posn
e)
      forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
      forall (m :: * -> *) a. Monad m => a -> m a
return (TargetNamespace -> Annotation
NoAnnotation TargetNamespace
"failed to parse")

-- | Parse a FormDefault attribute.
qform :: TextParser QForm
qform :: TextParser QForm
qform = do
    TargetNamespace
w <- TextParser TargetNamespace
word
    case TargetNamespace
w of
        TargetNamespace
"qualified"   -> forall (m :: * -> *) a. Monad m => a -> m a
return QForm
Qualified
        TargetNamespace
"unqualified" -> forall (m :: * -> *) a. Monad m => a -> m a
return QForm
Unqualified
        TargetNamespace
_             -> forall (p :: * -> *) a. PolyParse p => TargetNamespace -> p a
failBad TargetNamespace
"Expected \"qualified\" or \"unqualified\""

-- | Parse a Final or Block attribute.
final :: TextParser Final
final :: TextParser Block
final = do
    TargetNamespace
w <- TextParser TargetNamespace
word
    case TargetNamespace
w of
        TargetNamespace
"restriction" -> forall (m :: * -> *) a. Monad m => a -> m a
return Block
NoRestriction
        TargetNamespace
"extension"   -> forall (m :: * -> *) a. Monad m => a -> m a
return Block
NoExtension
        TargetNamespace
"#all"        -> forall (m :: * -> *) a. Monad m => a -> m a
return Block
AllFinal
        TargetNamespace
_             -> forall (p :: * -> *) a. PolyParse p => TargetNamespace -> p a
failBad forall a b. (a -> b) -> a -> b
$ TargetNamespace
"Expected \"restriction\" or \"extension\""
                                   forall a. [a] -> [a] -> [a]
++TargetNamespace
" or \"#all\""
block :: TextParser Block
block :: TextParser Block
block = TextParser Block
final

-- | Parse a schema item (just under the toplevel <xsd:schema>)
schemaItem :: (String->String->QName) -> XsdParser SchemaItem
schemaItem :: (TargetNamespace -> TargetNamespace -> QName)
-> XsdParser SchemaItem
schemaItem TargetNamespace -> TargetNamespace -> QName
qual = forall (p :: * -> *) a.
Commitment p =>
[(TargetNamespace, p a)] -> p a
oneOf'
       [ (TargetNamespace
"xsd:include",        XsdParser SchemaItem
include)
       , (TargetNamespace
"xsd:import",         XsdParser SchemaItem
import_)
       , (TargetNamespace
"xsd:redefine",       (TargetNamespace -> TargetNamespace -> QName)
-> XsdParser SchemaItem
redefine TargetNamespace -> TargetNamespace -> QName
qual)
       , (TargetNamespace
"xsd:annotation",     forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Annotation -> SchemaItem
Annotation     XsdParser Annotation
definiteAnnotation)
         --
       , (TargetNamespace
"xsd:simpleType",     forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SimpleType -> SchemaItem
Simple           ((TargetNamespace -> TargetNamespace -> QName)
-> XsdParser SimpleType
simpleType TargetNamespace -> TargetNamespace -> QName
qual))
       , (TargetNamespace
"xsd:complexType",    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ComplexType -> SchemaItem
Complex          ((TargetNamespace -> TargetNamespace -> QName)
-> XsdParser ComplexType
complexType TargetNamespace -> TargetNamespace -> QName
qual))
       , (TargetNamespace
"xsd:element",        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ElementDecl -> SchemaItem
SchemaElement    ((TargetNamespace -> TargetNamespace -> QName)
-> XsdParser ElementDecl
elementDecl TargetNamespace -> TargetNamespace -> QName
qual))
       , (TargetNamespace
"xsd:attribute",      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AttributeDecl -> SchemaItem
SchemaAttribute  ((TargetNamespace -> TargetNamespace -> QName)
-> XsdParser AttributeDecl
attributeDecl TargetNamespace -> TargetNamespace -> QName
qual))
       , (TargetNamespace
"xsd:attributeGroup", forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AttrGroup -> SchemaItem
AttributeGroup   ((TargetNamespace -> TargetNamespace -> QName)
-> XsdParser AttrGroup
attributeGroup TargetNamespace -> TargetNamespace -> QName
qual))
       , (TargetNamespace
"xsd:group",          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Group -> SchemaItem
SchemaGroup      ((TargetNamespace -> TargetNamespace -> QName) -> XsdParser Group
group_ TargetNamespace -> TargetNamespace -> QName
qual))
   --  , ("xsd:notation",       notation)
-- sigh
       , (TargetNamespace
"xs:include",        XsdParser SchemaItem
include)
       , (TargetNamespace
"xs:import",         XsdParser SchemaItem
import_)
       , (TargetNamespace
"xs:redefine",       (TargetNamespace -> TargetNamespace -> QName)
-> XsdParser SchemaItem
redefine TargetNamespace -> TargetNamespace -> QName
qual)
       , (TargetNamespace
"xs:annotation",     forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Annotation -> SchemaItem
Annotation     XsdParser Annotation
definiteAnnotation)
         --
       , (TargetNamespace
"xs:simpleType",     forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SimpleType -> SchemaItem
Simple           ((TargetNamespace -> TargetNamespace -> QName)
-> XsdParser SimpleType
simpleType TargetNamespace -> TargetNamespace -> QName
qual))
       , (TargetNamespace
"xs:complexType",    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ComplexType -> SchemaItem
Complex          ((TargetNamespace -> TargetNamespace -> QName)
-> XsdParser ComplexType
complexType TargetNamespace -> TargetNamespace -> QName
qual))
       , (TargetNamespace
"xs:element",        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ElementDecl -> SchemaItem
SchemaElement    ((TargetNamespace -> TargetNamespace -> QName)
-> XsdParser ElementDecl
elementDecl TargetNamespace -> TargetNamespace -> QName
qual))
       , (TargetNamespace
"xs:attribute",      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AttributeDecl -> SchemaItem
SchemaAttribute  ((TargetNamespace -> TargetNamespace -> QName)
-> XsdParser AttributeDecl
attributeDecl TargetNamespace -> TargetNamespace -> QName
qual))
       , (TargetNamespace
"xs:attributeGroup", forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AttrGroup -> SchemaItem
AttributeGroup   ((TargetNamespace -> TargetNamespace -> QName)
-> XsdParser AttrGroup
attributeGroup TargetNamespace -> TargetNamespace -> QName
qual))
       , (TargetNamespace
"xs:group",          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Group -> SchemaItem
SchemaGroup      ((TargetNamespace -> TargetNamespace -> QName) -> XsdParser Group
group_ TargetNamespace -> TargetNamespace -> QName
qual))
   --  , ("xs:notation",       notation)
       ]

-- | Parse an <xsd:include>.
include :: XsdParser SchemaItem
include :: XsdParser SchemaItem
include = do Element Posn
e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"include"
             forall (p :: * -> *) a. Commitment p => p a -> p a
commit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return TargetNamespace -> Annotation -> SchemaItem
Include
                      forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"schemaLocation") TextParser TargetNamespace
uri Element Posn
e
                      forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation") XsdParser Annotation
annotation Element Posn
e

-- | Parse an <xsd:import>.
import_ :: XsdParser SchemaItem
import_ :: XsdParser SchemaItem
import_ = do Element Posn
e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"import"
             forall (p :: * -> *) a. Commitment p => p a -> p a
commit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return TargetNamespace -> TargetNamespace -> Annotation -> SchemaItem
Import
                      forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"namespace")      TextParser TargetNamespace
uri Element Posn
e
                      forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"schemaLocation") TextParser TargetNamespace
uri Element Posn
e
                      forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation") XsdParser Annotation
annotation Element Posn
e

-- | Parse a <xsd:redefine>.
redefine :: (String->String->QName) -> XsdParser SchemaItem
redefine :: (TargetNamespace -> TargetNamespace -> QName)
-> XsdParser SchemaItem
redefine TargetNamespace -> TargetNamespace -> QName
q = do Element Posn
e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"redefine"
                forall (p :: * -> *) a. Commitment p => p a -> p a
commit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return TargetNamespace -> [SchemaItem] -> SchemaItem
Redefine
                     forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"schemaLocation") TextParser TargetNamespace
uri Element Posn
e
                     forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (forall a b. a -> b -> a
const Bool
True) (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ((TargetNamespace -> TargetNamespace -> QName)
-> XsdParser SchemaItem
schemaItem TargetNamespace -> TargetNamespace -> QName
q)) Element Posn
e

-- | Parse a <xsd:simpleType> decl.
simpleType :: (String->String->QName) -> XsdParser SimpleType
simpleType :: (TargetNamespace -> TargetNamespace -> QName)
-> XsdParser SimpleType
simpleType TargetNamespace -> TargetNamespace -> QName
q = do
    Element Posn
e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"simpleType"
    Maybe TargetNamespace
n <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"name") TextParser TargetNamespace
name Element Posn
e)
    Maybe Block
f <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"final") TextParser Block
final Element Posn
e)
    Annotation
a <- forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation") XsdParser Annotation
annotation Element Posn
e
    forall (p :: * -> *) a. Commitment p => p a -> p a
commit forall a b. (a -> b) -> a -> b
$ forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation") (Maybe TargetNamespace
-> Maybe Block -> Annotation -> XsdParser SimpleType
simpleItem Maybe TargetNamespace
n Maybe Block
f Annotation
a) Element Posn
e
  where
    simpleItem :: Maybe TargetNamespace
-> Maybe Block -> Annotation -> XsdParser SimpleType
simpleItem Maybe TargetNamespace
n Maybe Block
f Annotation
a =
        do Element Posn
e  <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"restriction"
           forall (p :: * -> *) a. Commitment p => p a -> p a
commit forall a b. (a -> b) -> a -> b
$ do
             Annotation
a1 <- forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation") XsdParser Annotation
annotation Element Posn
e
             Maybe QName
b  <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"base") ((TargetNamespace -> TargetNamespace -> QName) -> TextParser QName
qname TargetNamespace -> TargetNamespace -> QName
q) Element Posn
e)
             Restriction
r  <- forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation")
                                (Annotation -> Maybe QName -> Parser (Content Posn) Restriction
restrictType Annotation
a1 Maybe QName
b forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` Annotation -> Maybe QName -> Parser (Content Posn) Restriction
restriction1 Annotation
a1 Maybe QName
b) Element Posn
e
             forall (m :: * -> *) a. Monad m => a -> m a
return (Annotation
-> Maybe TargetNamespace
-> Maybe Block
-> Restriction
-> SimpleType
Restricted Annotation
a Maybe TargetNamespace
n Maybe Block
f Restriction
r)
        forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
        do Element Posn
e  <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"list"
           forall (p :: * -> *) a. Commitment p => p a -> p a
commit forall a b. (a -> b) -> a -> b
$ do
             Annotation
a1 <- forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation") XsdParser Annotation
annotation Element Posn
e
             Either SimpleType QName
t  <- forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"itemType") (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right ((TargetNamespace -> TargetNamespace -> QName) -> TextParser QName
qname TargetNamespace -> TargetNamespace -> QName
q)) Element Posn
e
                     forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                   forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"simpleType")
                                (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left ((TargetNamespace -> TargetNamespace -> QName)
-> XsdParser SimpleType
simpleType TargetNamespace -> TargetNamespace -> QName
q)) Element Posn
e
                     forall (p :: * -> *) a.
Commitment p =>
p a -> (TargetNamespace -> TargetNamespace) -> p a
`adjustErr`
                   ((TargetNamespace
"Expected attribute 'itemType' or element <simpleType>\n"
                    forall a. [a] -> [a] -> [a]
++TargetNamespace
"  inside <list> decl.\n")forall a. [a] -> [a] -> [a]
++)
             forall (m :: * -> *) a. Monad m => a -> m a
return (Annotation
-> Maybe TargetNamespace
-> Maybe Block
-> Either SimpleType QName
-> SimpleType
ListOf (Annotation
aforall a. Monoid a => a -> a -> a
`mappend`Annotation
a1) Maybe TargetNamespace
n Maybe Block
f Either SimpleType QName
t)
        forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
        do Element Posn
e  <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"union"
           forall (p :: * -> *) a. Commitment p => p a -> p a
commit forall a b. (a -> b) -> a -> b
$ do
             Annotation
a1 <- forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation") XsdParser Annotation
annotation Element Posn
e
             [SimpleType]
ts <- forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"simpleType") (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ((TargetNamespace -> TargetNamespace -> QName)
-> XsdParser SimpleType
simpleType TargetNamespace -> TargetNamespace -> QName
q)) Element Posn
e
             [QName]
ms <- forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"memberTypes") (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ((TargetNamespace -> TargetNamespace -> QName) -> TextParser QName
qname TargetNamespace -> TargetNamespace -> QName
q)) Element Posn
e
                   forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` forall (m :: * -> *) a. Monad m => a -> m a
return []
             forall (m :: * -> *) a. Monad m => a -> m a
return (Annotation
-> Maybe TargetNamespace
-> Maybe Block
-> [SimpleType]
-> [QName]
-> SimpleType
UnionOf (Annotation
aforall a. Monoid a => a -> a -> a
`mappend`Annotation
a1) Maybe TargetNamespace
n Maybe Block
f [SimpleType]
ts [QName]
ms)
        forall (p :: * -> *) a.
Commitment p =>
p a -> (TargetNamespace -> TargetNamespace) -> p a
`adjustErr`
        (TargetNamespace
"xsd:simpleType does not contain a restriction, list, or union\n"forall a. [a] -> [a] -> [a]
++)

    restriction1 :: Annotation -> Maybe QName -> Parser (Content Posn) Restriction
restriction1 Annotation
a Maybe QName
b = forall (m :: * -> *) a. Monad m => a -> m a
return (Annotation -> Maybe QName -> Restriction1 -> Restriction
RestrictSim1 Annotation
a Maybe QName
b)
                            forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` (forall (m :: * -> *) a. Monad m => a -> m a
return Particle -> Restriction1
Restriction1 forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` (TargetNamespace -> TargetNamespace -> QName) -> XsdParser Particle
particle TargetNamespace -> TargetNamespace -> QName
q)
    restrictType :: Annotation -> Maybe QName -> Parser (Content Posn) Restriction
restrictType Annotation
a Maybe QName
b = forall (m :: * -> *) a. Monad m => a -> m a
return (Annotation
-> Maybe QName -> Maybe SimpleType -> [Facet] -> Restriction
RestrictType Annotation
a Maybe QName
b)
                            forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ((TargetNamespace -> TargetNamespace -> QName)
-> XsdParser SimpleType
simpleType TargetNamespace -> TargetNamespace -> QName
q)
                            forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall (p :: * -> *) a. PolyParse p => p a -> p [a]
many1 XsdParser Facet
aFacet

aFacet :: XsdParser Facet
aFacet :: XsdParser Facet
aFacet = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall t a. Parser t a -> Parser t a -> Parser t a
onFail (forall (m :: * -> *) a. MonadFail m => TargetNamespace -> m a
fail TargetNamespace
"Could not recognise simpleType Facet")
               (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith TargetNamespace -> FacetType -> XsdParser Facet
facet [TargetNamespace
"minInclusive",TargetNamespace
"minExclusive",TargetNamespace
"maxInclusive"
                              ,TargetNamespace
"maxExclusive",TargetNamespace
"totalDigits",TargetNamespace
"fractionDigits"
                              ,TargetNamespace
"length",TargetNamespace
"minLength",TargetNamespace
"maxLength"
                              ,TargetNamespace
"enumeration",TargetNamespace
"whiteSpace",TargetNamespace
"pattern"]
                              [FacetType
OrderedBoundsMinIncl,FacetType
OrderedBoundsMinExcl
                              ,FacetType
OrderedBoundsMaxIncl,FacetType
OrderedBoundsMaxExcl
                              ,FacetType
OrderedNumericTotalDigits
                              ,FacetType
OrderedNumericFractionDigits
                              ,FacetType
UnorderedLength,FacetType
UnorderedMinLength
                              ,FacetType
UnorderedMaxLength,FacetType
UnorderedEnumeration
                              ,FacetType
UnorderedWhitespace,FacetType
UnorderedPattern])

facet :: String -> FacetType -> XsdParser Facet
facet :: TargetNamespace -> FacetType -> XsdParser Facet
facet TargetNamespace
s FacetType
t = do Element Posn
e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
s
               TargetNamespace
v <- forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"value") TextParser TargetNamespace
string Element Posn
e
               Bool
f <- forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"fixed") TextParser Bool
bool Element Posn
e
                    forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False -- XXX check this
               Annotation
a <- forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (forall a b. a -> b -> a
const Bool
True) XsdParser Annotation
annotation Element Posn
e
               forall (m :: * -> *) a. Monad m => a -> m a
return (FacetType -> Annotation -> TargetNamespace -> Bool -> Facet
Facet FacetType
t Annotation
a TargetNamespace
v Bool
f)

-- | Parse a <xsd:complexType> decl.
complexType :: (String->String->QName) -> XsdParser ComplexType
complexType :: (TargetNamespace -> TargetNamespace -> QName)
-> XsdParser ComplexType
complexType TargetNamespace -> TargetNamespace -> QName
q =
    do Element Posn
e  <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"complexType"
       forall (p :: * -> *) a. Commitment p => p a -> p a
commit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Annotation
-> Maybe TargetNamespace
-> Bool
-> Maybe Block
-> Maybe Block
-> Bool
-> ComplexItem
-> ComplexType
ComplexType
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation") XsdParser Annotation
annotation Element Posn
e
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"name") TextParser TargetNamespace
string Element Posn
e)
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"abstract") TextParser Bool
bool Element Posn
e forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"final") TextParser Block
final Element Posn
e)
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"block") TextParser Block
block Element Posn
e)
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"mixed") TextParser Bool
bool Element Posn
e forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation") ((TargetNamespace -> TargetNamespace -> QName)
-> XsdParser ComplexItem
complexItem TargetNamespace -> TargetNamespace -> QName
q) Element Posn
e

-- | Parse the alternative contents of a <xsd:complexType> decl.
complexItem :: (String->String->QName) -> XsdParser ComplexItem
complexItem :: (TargetNamespace -> TargetNamespace -> QName)
-> XsdParser ComplexItem
complexItem TargetNamespace -> TargetNamespace -> QName
q =
    ( do Element Posn
e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"simpleContent"
         forall (p :: * -> *) a. Commitment p => p a -> p a
commit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Annotation -> Either Restriction1 Extension -> ComplexItem
SimpleContent
                forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation") XsdParser Annotation
annotation Element Posn
e
                forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (Bool -> Bool
notforall b c a. (b -> c) -> (a -> b) -> a -> c
.TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation") XsdParser (Either Restriction1 Extension)
stuff Element Posn
e
    ) forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` (
      do Element Posn
e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"complexContent"
         forall (p :: * -> *) a. Commitment p => p a -> p a
commit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Annotation -> Bool -> Either Restriction1 Extension -> ComplexItem
ComplexContent
                forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation") XsdParser Annotation
annotation Element Posn
e
                forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"mixed") TextParser Bool
bool Element Posn
e forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
                forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (Bool -> Bool
notforall b c a. (b -> c) -> (a -> b) -> a -> c
.TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation") XsdParser (Either Restriction1 Extension)
stuff Element Posn
e
    ) forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` (
      do ParticleAttrs -> ComplexItem
ThisType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TargetNamespace -> TargetNamespace -> QName)
-> XsdParser ParticleAttrs
particleAttrs TargetNamespace -> TargetNamespace -> QName
q
    )
  where
    stuff :: XsdParser (Either Restriction1 Extension)
    stuff :: XsdParser (Either Restriction1 Extension)
stuff =
      ( do Element Posn
e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"restriction"
           forall (p :: * -> *) a. Commitment p => p a -> p a
commit forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Particle -> Restriction1
Restriction1 forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` (TargetNamespace -> TargetNamespace -> QName) -> XsdParser Particle
particle TargetNamespace -> TargetNamespace -> QName
q
      ) forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` (
        do Element Posn
e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"extension"
           forall (p :: * -> *) a. Commitment p => p a -> p a
commit forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Annotation -> QName -> ParticleAttrs -> Extension
Extension
               forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation") XsdParser Annotation
annotation Element Posn
e
               forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"base") ((TargetNamespace -> TargetNamespace -> QName) -> TextParser QName
qname TargetNamespace -> TargetNamespace -> QName
q) Element Posn
e
               forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (Bool -> Bool
notforall b c a. (b -> c) -> (a -> b) -> a -> c
.TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation")
                                    ((TargetNamespace -> TargetNamespace -> QName)
-> XsdParser ParticleAttrs
particleAttrs TargetNamespace -> TargetNamespace -> QName
q) Element Posn
e
      )

-- | Parse a particle decl.
particle :: (String->String->QName) -> XsdParser Particle
particle :: (TargetNamespace -> TargetNamespace -> QName) -> XsdParser Particle
particle TargetNamespace -> TargetNamespace -> QName
q = forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left ((TargetNamespace -> TargetNamespace -> QName)
-> XsdParser ChoiceOrSeq
choiceOrSeq TargetNamespace -> TargetNamespace -> QName
q) forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right ((TargetNamespace -> TargetNamespace -> QName) -> XsdParser Group
group_ TargetNamespace -> TargetNamespace -> QName
q))

-- | Parse a particle decl with optional attributes.
particleAttrs :: (String->String->QName) -> XsdParser ParticleAttrs
particleAttrs :: (TargetNamespace -> TargetNamespace -> QName)
-> XsdParser ParticleAttrs
particleAttrs TargetNamespace -> TargetNamespace -> QName
q = forall (m :: * -> *) a. Monad m => a -> m a
return Particle
-> [Either AttributeDecl AttrGroup]
-> Maybe AnyAttr
-> ParticleAttrs
PA forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` (TargetNamespace -> TargetNamespace -> QName) -> XsdParser Particle
particle TargetNamespace -> TargetNamespace -> QName
q
                            forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left ((TargetNamespace -> TargetNamespace -> QName)
-> XsdParser AttributeDecl
attributeDecl TargetNamespace -> TargetNamespace -> QName
q)
                                          forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                                          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right ((TargetNamespace -> TargetNamespace -> QName)
-> XsdParser AttrGroup
attributeGroup TargetNamespace -> TargetNamespace -> QName
q))
                            forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional XsdParser AnyAttr
anyAttr

-- | Parse an <xsd:all>, <xsd:choice>, or <xsd:sequence> decl.
choiceOrSeq :: (String->String->QName) -> XsdParser ChoiceOrSeq
choiceOrSeq :: (TargetNamespace -> TargetNamespace -> QName)
-> XsdParser ChoiceOrSeq
choiceOrSeq TargetNamespace -> TargetNamespace -> QName
q =
    do Element Posn
e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"all"
       forall (p :: * -> *) a. Commitment p => p a -> p a
commit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Annotation -> [ElementDecl] -> ChoiceOrSeq
All
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation") XsdParser Annotation
annotation Element Posn
e
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (Bool -> Bool
notforall b c a. (b -> c) -> (a -> b) -> a -> c
.TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation")
                                (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ((TargetNamespace -> TargetNamespace -> QName)
-> XsdParser ElementDecl
elementDecl TargetNamespace -> TargetNamespace -> QName
q)) Element Posn
e
    forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
    do Element Posn
e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"choice"
       forall (p :: * -> *) a. Commitment p => p a -> p a
commit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Annotation -> Occurs -> [ElementEtc] -> ChoiceOrSeq
Choice
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation") XsdParser Annotation
annotation Element Posn
e
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` Element Posn -> XsdParser Occurs
occurs Element Posn
e
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (Bool -> Bool
notforall b c a. (b -> c) -> (a -> b) -> a -> c
.TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation")
                                (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ((TargetNamespace -> TargetNamespace -> QName)
-> XsdParser ElementEtc
elementEtc TargetNamespace -> TargetNamespace -> QName
q)) Element Posn
e
    forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
    do Element Posn
e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"sequence"
       forall (p :: * -> *) a. Commitment p => p a -> p a
commit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Annotation -> Occurs -> [ElementEtc] -> ChoiceOrSeq
Sequence
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation") XsdParser Annotation
annotation Element Posn
e
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` Element Posn -> XsdParser Occurs
occurs Element Posn
e
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (Bool -> Bool
notforall b c a. (b -> c) -> (a -> b) -> a -> c
.TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation")
                                (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ((TargetNamespace -> TargetNamespace -> QName)
-> XsdParser ElementEtc
elementEtc TargetNamespace -> TargetNamespace -> QName
q)) Element Posn
e

-- | Parse a <xsd:group> decl.
group_ :: (String->String->QName) -> XsdParser Group
group_ :: (TargetNamespace -> TargetNamespace -> QName) -> XsdParser Group
group_ TargetNamespace -> TargetNamespace -> QName
q = do Element Posn
e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"group"
              forall (p :: * -> *) a. Commitment p => p a -> p a
commit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Annotation
-> Either TargetNamespace QName
-> Occurs
-> Maybe ChoiceOrSeq
-> Group
Group
                forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation") XsdParser Annotation
annotation Element Posn
e
                forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"name") TextParser TargetNamespace
string Element Posn
e)
                         forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                         forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"ref") ((TargetNamespace -> TargetNamespace -> QName) -> TextParser QName
qname TargetNamespace -> TargetNamespace -> QName
q) Element Posn
e))
                forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` Element Posn -> XsdParser Occurs
occurs Element Posn
e
                forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (Bool -> Bool
notforall b c a. (b -> c) -> (a -> b) -> a -> c
.TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation")
                                     (forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ((TargetNamespace -> TargetNamespace -> QName)
-> XsdParser ChoiceOrSeq
choiceOrSeq TargetNamespace -> TargetNamespace -> QName
q)) Element Posn
e

-- | Parse an <xsd:element>, <xsd:group>, <xsd:all>, <xsd:choice>,
--   <xsd:sequence> or <xsd:any>.
elementEtc :: (String->String->QName) -> XsdParser ElementEtc
elementEtc :: (TargetNamespace -> TargetNamespace -> QName)
-> XsdParser ElementEtc
elementEtc TargetNamespace -> TargetNamespace -> QName
q = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ElementDecl -> ElementEtc
HasElement ((TargetNamespace -> TargetNamespace -> QName)
-> XsdParser ElementDecl
elementDecl TargetNamespace -> TargetNamespace -> QName
q)
             forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
             forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Group -> ElementEtc
HasGroup ((TargetNamespace -> TargetNamespace -> QName) -> XsdParser Group
group_ TargetNamespace -> TargetNamespace -> QName
q)
             forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
             forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ChoiceOrSeq -> ElementEtc
HasCS ((TargetNamespace -> TargetNamespace -> QName)
-> XsdParser ChoiceOrSeq
choiceOrSeq TargetNamespace -> TargetNamespace -> QName
q)
             forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
             forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Any -> ElementEtc
HasAny XsdParser Any
any_

-- | Parse an <xsd:any>.
any_ :: XsdParser Any
any_ :: XsdParser Any
any_ = do Element Posn
e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"any"
          forall (p :: * -> *) a. Commitment p => p a -> p a
commit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Annotation -> TargetNamespace -> ProcessContents -> Occurs -> Any
Any
              forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation") XsdParser Annotation
annotation Element Posn
e
              forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"namespace") TextParser TargetNamespace
uri Element Posn
e
                       forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` forall (m :: * -> *) a. Monad m => a -> m a
return TargetNamespace
"##any")
              forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"processContents") TextParser ProcessContents
processContents Element Posn
e
                       forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` forall (m :: * -> *) a. Monad m => a -> m a
return ProcessContents
Strict)
              forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` Element Posn -> XsdParser Occurs
occurs Element Posn
e

-- | Parse an <xsd:anyAttribute>.
anyAttr :: XsdParser AnyAttr
anyAttr :: XsdParser AnyAttr
anyAttr = do Element Posn
e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"anyAttribute"
             forall (p :: * -> *) a. Commitment p => p a -> p a
commit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Annotation -> TargetNamespace -> ProcessContents -> AnyAttr
AnyAttr
                 forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation") XsdParser Annotation
annotation Element Posn
e
                 forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"namespace") TextParser TargetNamespace
uri Element Posn
e
                          forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` forall (m :: * -> *) a. Monad m => a -> m a
return TargetNamespace
"##any")
                 forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"processContents") TextParser ProcessContents
processContents Element Posn
e
                          forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` forall (m :: * -> *) a. Monad m => a -> m a
return ProcessContents
Strict)

-- | Parse an <xsd:attributegroup>.
attributeGroup :: (String->String->QName) -> XsdParser AttrGroup
attributeGroup :: (TargetNamespace -> TargetNamespace -> QName)
-> XsdParser AttrGroup
attributeGroup TargetNamespace -> TargetNamespace -> QName
q =
    do Element Posn
e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"attributeGroup"
       forall (p :: * -> *) a. Commitment p => p a -> p a
commit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Annotation
-> Either TargetNamespace QName
-> [Either AttributeDecl AttrGroup]
-> AttrGroup
AttrGroup
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation") XsdParser Annotation
annotation Element Posn
e
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"name") TextParser TargetNamespace
string Element Posn
e)
                    forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"ref") ((TargetNamespace -> TargetNamespace -> QName) -> TextParser QName
qname TargetNamespace -> TargetNamespace -> QName
q) Element Posn
e))
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (Bool -> Bool
notforall b c a. (b -> c) -> (a -> b) -> a -> c
.TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation") (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser (Content Posn) (Either AttributeDecl AttrGroup)
stuff) Element Posn
e
  where
    stuff :: Parser (Content Posn) (Either AttributeDecl AttrGroup)
stuff = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left ((TargetNamespace -> TargetNamespace -> QName)
-> XsdParser AttributeDecl
attributeDecl TargetNamespace -> TargetNamespace -> QName
q) forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right ((TargetNamespace -> TargetNamespace -> QName)
-> XsdParser AttrGroup
attributeGroup TargetNamespace -> TargetNamespace -> QName
q)

-- | Parse an <xsd:element> decl.
elementDecl :: (String->String->QName) -> XsdParser ElementDecl
elementDecl :: (TargetNamespace -> TargetNamespace -> QName)
-> XsdParser ElementDecl
elementDecl TargetNamespace -> TargetNamespace -> QName
q =
    do Element Posn
e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"element"
       forall (p :: * -> *) a. Commitment p => p a -> p a
commit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Annotation
-> Either NameAndType QName
-> Occurs
-> Bool
-> Maybe QName
-> Bool
-> Maybe Block
-> Maybe Block
-> QForm
-> Maybe (Either SimpleType ComplexType)
-> [UniqueKeyOrKeyRef]
-> ElementDecl
ElementDecl
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation") XsdParser Annotation
annotation Element Posn
e
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left ((TargetNamespace -> TargetNamespace -> QName)
-> Element Posn -> XsdParser NameAndType
nameAndType TargetNamespace -> TargetNamespace -> QName
q Element Posn
e)
                    forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"ref") ((TargetNamespace -> TargetNamespace -> QName) -> TextParser QName
qname TargetNamespace -> TargetNamespace -> QName
q) Element Posn
e))
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` Element Posn -> XsdParser Occurs
occurs Element Posn
e
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"nillable") TextParser Bool
bool Element Posn
e forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"substitutionGroup") ((TargetNamespace -> TargetNamespace -> QName) -> TextParser QName
qname TargetNamespace -> TargetNamespace -> QName
q) Element Posn
e)
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"abstract") TextParser Bool
bool Element Posn
e forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
xsd TargetNamespace
"final") TextParser Block
final Element Posn
e)
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
xsd TargetNamespace
"block") TextParser Block
block Element Posn
e)
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
xsd TargetNamespace
"form") TextParser QForm
qform Element Posn
e forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` forall (m :: * -> *) a. Monad m => a -> m a
return QForm
Unqualified)
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"simpleType" forall a. (a -> Bool) -> (a -> Bool) -> a -> Bool
||| TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"complexType")
                                (forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left ((TargetNamespace -> TargetNamespace -> QName)
-> XsdParser SimpleType
simpleType TargetNamespace -> TargetNamespace -> QName
q)
                                           forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                                           forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right ((TargetNamespace -> TargetNamespace -> QName)
-> XsdParser ComplexType
complexType TargetNamespace -> TargetNamespace -> QName
q))) Element Posn
e
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"unique" forall a. (a -> Bool) -> (a -> Bool) -> a -> Bool
||| TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"key"
                                                 forall a. (a -> Bool) -> (a -> Bool) -> a -> Bool
||| TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"keyRef")
                                (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ((TargetNamespace -> TargetNamespace -> QName)
-> XsdParser UniqueKeyOrKeyRef
uniqueKeyOrKeyRef TargetNamespace -> TargetNamespace -> QName
q)) Element Posn
e

-- | Parse name and type attributes.
nameAndType :: (String->String->QName) -> Element Posn -> XsdParser NameAndType
nameAndType :: (TargetNamespace -> TargetNamespace -> QName)
-> Element Posn -> XsdParser NameAndType
nameAndType TargetNamespace -> TargetNamespace -> QName
q Element Posn
e = forall (m :: * -> *) a. Monad m => a -> m a
return TargetNamespace -> Maybe QName -> NameAndType
NT forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"name") TextParser TargetNamespace
string Element Posn
e
                            forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"type") ((TargetNamespace -> TargetNamespace -> QName) -> TextParser QName
qname TargetNamespace -> TargetNamespace -> QName
q) Element Posn
e)

-- | Parse an <xsd:attribute> decl.
attributeDecl :: (String->String->QName) -> XsdParser AttributeDecl
attributeDecl :: (TargetNamespace -> TargetNamespace -> QName)
-> XsdParser AttributeDecl
attributeDecl TargetNamespace -> TargetNamespace -> QName
q =
    do Element Posn
e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"attribute"
       forall (p :: * -> *) a. Commitment p => p a -> p a
commit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Annotation
-> Either NameAndType QName
-> Use
-> Maybe (Either TargetNamespace TargetNamespace)
-> QForm
-> Maybe SimpleType
-> AttributeDecl
AttributeDecl
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation") XsdParser Annotation
annotation Element Posn
e
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left ((TargetNamespace -> TargetNamespace -> QName)
-> Element Posn -> XsdParser NameAndType
nameAndType TargetNamespace -> TargetNamespace -> QName
q Element Posn
e)
                    forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"ref") ((TargetNamespace -> TargetNamespace -> QName) -> TextParser QName
qname TargetNamespace -> TargetNamespace -> QName
q) Element Posn
e))
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"use") TextParser Use
use Element Posn
e forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` forall (m :: * -> *) a. Monad m => a -> m a
return Use
Optional)
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"default") (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left TextParser TargetNamespace
string) Element Posn
e
                              forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                              forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"fixed") (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right TextParser TargetNamespace
string) Element Posn
e)
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
xsd TargetNamespace
"form") TextParser QForm
qform Element Posn
e forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` forall (m :: * -> *) a. Monad m => a -> m a
return QForm
Unqualified)
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"simpleType")
                                (forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ((TargetNamespace -> TargetNamespace -> QName)
-> XsdParser SimpleType
simpleType TargetNamespace -> TargetNamespace -> QName
q)) Element Posn
e


-- | Parse an occurrence range from attributes of given element.
occurs :: Element Posn -> XsdParser Occurs
occurs :: Element Posn -> XsdParser Occurs
occurs Element Posn
e = forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int -> Maybe Int -> Occurs
Occurs
               forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"minOccurs") forall a. Integral a => TextParser a
parseDec Element Posn
e)
               forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"maxOccurs") Parser Char Int
maxDec Element Posn
e)
  where
    maxDec :: Parser Char Int
maxDec = forall a. Integral a => TextParser a
parseDec
             forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
             do TargetNamespace -> TextParser TargetNamespace
isWord TargetNamespace
"unbounded"; forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Bounded a => a
maxBound

-- | Parse a <xsd:unique>, <xsd:key>, or <xsd:keyref>.
uniqueKeyOrKeyRef :: (String->String->QName) -> XsdParser UniqueKeyOrKeyRef
uniqueKeyOrKeyRef :: (TargetNamespace -> TargetNamespace -> QName)
-> XsdParser UniqueKeyOrKeyRef
uniqueKeyOrKeyRef TargetNamespace -> TargetNamespace -> QName
q = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Unique -> UniqueKeyOrKeyRef
U XsdParser Unique
unique forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Key -> UniqueKeyOrKeyRef
K XsdParser Key
key forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap KeyRef -> UniqueKeyOrKeyRef
KR ((TargetNamespace -> TargetNamespace -> QName) -> XsdParser KeyRef
keyRef TargetNamespace -> TargetNamespace -> QName
q)

-- | Parse a <xsd:unique>.
unique :: XsdParser Unique
unique :: XsdParser Unique
unique =
    do Element Posn
e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"unique"
       forall (p :: * -> *) a. Commitment p => p a -> p a
commit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Annotation -> TargetNamespace -> Selector -> [Field] -> Unique
Unique
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation") XsdParser Annotation
annotation Element Posn
e
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"name") TextParser TargetNamespace
string Element Posn
e
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"selector") XsdParser Selector
selector Element Posn
e
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"field") (forall (p :: * -> *) a. PolyParse p => p a -> p [a]
many1 XsdParser Field
field_) Element Posn
e

-- | Parse a <xsd:key>.
key :: XsdParser Key
key :: XsdParser Key
key =
    do Element Posn
e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"key"
       forall (p :: * -> *) a. Commitment p => p a -> p a
commit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Annotation -> TargetNamespace -> Selector -> [Field] -> Key
Key
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation") XsdParser Annotation
annotation Element Posn
e
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"name") TextParser TargetNamespace
string Element Posn
e
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"selector") XsdParser Selector
selector Element Posn
e
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"field") (forall (p :: * -> *) a. PolyParse p => p a -> p [a]
many1 XsdParser Field
field_) Element Posn
e

-- | Parse a <xsd:keyref>.
keyRef :: (String->String->QName) -> XsdParser KeyRef
keyRef :: (TargetNamespace -> TargetNamespace -> QName) -> XsdParser KeyRef
keyRef TargetNamespace -> TargetNamespace -> QName
q =
    do Element Posn
e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"keyref"
       forall (p :: * -> *) a. Commitment p => p a -> p a
commit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Annotation
-> TargetNamespace -> QName -> Selector -> [Field] -> KeyRef
KeyRef
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation") XsdParser Annotation
annotation Element Posn
e
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"name") TextParser TargetNamespace
string Element Posn
e
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"refer") ((TargetNamespace -> TargetNamespace -> QName) -> TextParser QName
qname TargetNamespace -> TargetNamespace -> QName
q) Element Posn
e
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"selector") XsdParser Selector
selector Element Posn
e
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"field") (forall (p :: * -> *) a. PolyParse p => p a -> p [a]
many1 XsdParser Field
field_) Element Posn
e

-- | Parse a <xsd:selector>.
selector :: XsdParser Selector
selector :: XsdParser Selector
selector =
    do Element Posn
e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"selector"
       forall (p :: * -> *) a. Commitment p => p a -> p a
commit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Annotation -> TargetNamespace -> Selector
Selector
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation") XsdParser Annotation
annotation Element Posn
e
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"xpath") TextParser TargetNamespace
string Element Posn
e

-- | Parse a <xsd:field>.
field_ :: XsdParser Field
field_ :: XsdParser Field
field_ =
    do Element Posn
e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"field"
       forall (p :: * -> *) a. Commitment p => p a -> p a
commit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Annotation -> TargetNamespace -> Field
Field
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a.
(Content Posn -> Bool)
-> XsdParser a -> Element Posn -> XsdParser a
interiorWith (TargetNamespace -> Content Posn -> Bool
xsdTag TargetNamespace
"annotation") XsdParser Annotation
annotation Element Posn
e
           forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"xpath") TextParser TargetNamespace
string Element Posn
e

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

-- | Text parser for a URI (very simple, non-validating, probably incorrect).
uri :: TextParser String
uri :: TextParser TargetNamespace
uri = TextParser TargetNamespace
string

-- | Text parser for an arbitrary string consisting of possibly multiple tokens.
string :: TextParser String
string :: TextParser TargetNamespace
string = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (TextParser TargetNamespace
space forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` TextParser TargetNamespace
word)

space :: TextParser String
space :: TextParser TargetNamespace
space = forall (p :: * -> *) a. PolyParse p => p a -> p [a]
many1 forall a b. (a -> b) -> a -> b
$ forall t. (t -> Bool) -> Parser t t
satisfy Char -> Bool
isSpace

-- | Parse a textual boolean, i.e. "true", "false", "0", or "1"
bool :: TextParser Bool
bool :: TextParser Bool
bool = do TargetNamespace
w <- TextParser TargetNamespace
word
          case TargetNamespace
w of
            TargetNamespace
"true"  -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            TargetNamespace
"false" -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            TargetNamespace
"0"     -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            TargetNamespace
"1"     -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            TargetNamespace
_       -> forall (m :: * -> *) a. MonadFail m => TargetNamespace -> m a
fail TargetNamespace
"could not parse boolean value"

-- | Parse a "use" attribute value, i.e. "required", "optional", or "prohibited"
use :: TextParser Use
use :: TextParser Use
use = do TargetNamespace
w <- TextParser TargetNamespace
word
         case TargetNamespace
w of
           TargetNamespace
"required"   -> forall (m :: * -> *) a. Monad m => a -> m a
return Use
Required
           TargetNamespace
"optional"   -> forall (m :: * -> *) a. Monad m => a -> m a
return Use
Optional
           TargetNamespace
"prohibited" -> forall (m :: * -> *) a. Monad m => a -> m a
return Use
Prohibited
           TargetNamespace
_            -> forall (m :: * -> *) a. MonadFail m => TargetNamespace -> m a
fail TargetNamespace
"could not parse \"use\" attribute value"

-- | Parse a "processContents" attribute, i.e. "skip", "lax", or "strict".
processContents :: TextParser ProcessContents
processContents :: TextParser ProcessContents
processContents =
    do TargetNamespace
w <- TextParser TargetNamespace
word
       case TargetNamespace
w of
         TargetNamespace
"skip"   -> forall (m :: * -> *) a. Monad m => a -> m a
return ProcessContents
Skip
         TargetNamespace
"lax"    -> forall (m :: * -> *) a. Monad m => a -> m a
return ProcessContents
Lax
         TargetNamespace
"strict" -> forall (m :: * -> *) a. Monad m => a -> m a
return ProcessContents
Strict
         TargetNamespace
_        -> forall (m :: * -> *) a. MonadFail m => TargetNamespace -> m a
fail TargetNamespace
"could not parse \"processContents\" attribute value"

-- | Parse an attribute value that should be a QName.
qname :: (String->String->QName) -> TextParser QName
qname :: (TargetNamespace -> TargetNamespace -> QName) -> TextParser QName
qname TargetNamespace -> TargetNamespace -> QName
q = do TargetNamespace
a <- TextParser TargetNamespace
word
             do TargetNamespace
":" <- TextParser TargetNamespace
word
                TargetNamespace
b   <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (forall t. (t -> Bool) -> Parser t t
satisfy (forall a. Eq a => a -> a -> Bool
/=Char
':'))
                forall (m :: * -> *) a. Monad m => a -> m a
return (TargetNamespace -> TargetNamespace -> QName
q TargetNamespace
a TargetNamespace
b)
               forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                 do TargetNamespace
cs <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
many forall t. Parser t t
next
                    forall (m :: * -> *) a. Monad m => a -> m a
return (TargetNamespace -> QName
N (TargetNamespace
aforall a. [a] -> [a] -> [a]
++TargetNamespace
cs))

-- | Parse an attribute value that should be a simple Name.
name :: TextParser Name
name :: TextParser TargetNamespace
name = TextParser TargetNamespace
word