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 QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== TargetNamespace -> QName
xsd TargetNamespace
tag Bool -> Bool -> Bool
|| QName
qn QName -> QName -> Bool
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
    { c <- Parser (Content Posn) (Content Posn)
forall t. Parser t t
next Parser (Content Posn) (Content Posn)
-> (TargetNamespace -> TargetNamespace)
-> Parser (Content Posn) (Content Posn)
forall a.
Parser (Content Posn) a
-> (TargetNamespace -> TargetNamespace) -> Parser (Content Posn) a
forall (p :: * -> *) a.
Commitment p =>
p a -> (TargetNamespace -> TargetNamespace) -> p a
`adjustErr` (TargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++TargetNamespace
" when expecting "TargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++[TargetNamespace] -> TargetNamespace
formatted [TargetNamespace]
tags)
    ; case c of
        CElem Element Posn
e Posn
pos
            | Content Posn -> Bool
match Content Posn
c   -> (Posn, Element Posn) -> XsdParser (Posn, Element Posn)
forall a. a -> Parser (Content Posn) a
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 -> TargetNamespace -> XsdParser (Posn, Element Posn)
forall a. TargetNamespace -> Parser (Content Posn) a
forall (m :: * -> *) a. MonadFail m => TargetNamespace -> m a
fail (TargetNamespace
"Found a <"TargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++QName -> TargetNamespace
printableName QName
t
                                 TargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++TargetNamespace
">, but expected "
                                 TargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++[TargetNamespace] -> TargetNamespace
formatted [TargetNamespace]
tagsTargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++TargetNamespace
"\nat "TargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++Posn -> TargetNamespace
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
&& (Char -> Bool) -> TargetNamespace -> 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 -> TargetNamespace -> XsdParser (Posn, Element Posn)
forall a. TargetNamespace -> Parser (Content Posn) a
forall (m :: * -> *) a. MonadFail m => TargetNamespace -> m a
fail (TargetNamespace
"Found text content, but expected "
                                 TargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++[TargetNamespace] -> TargetNamespace
formatted [TargetNamespace]
tagsTargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++TargetNamespace
"\ntext is: "TargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++TargetNamespace
s
                                 TargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++TargetNamespace
"\nat "TargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++Posn -> TargetNamespace
forall a. Show a => a -> TargetNamespace
show Posn
pos)
        CRef Reference
r Posn
pos -> TargetNamespace -> XsdParser (Posn, Element Posn)
forall a. TargetNamespace -> Parser (Content Posn) a
forall (m :: * -> *) a. MonadFail m => TargetNamespace -> m a
fail (TargetNamespace
"Found reference, but expected "
                            TargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++[TargetNamespace] -> TargetNamespace
formatted [TargetNamespace]
tagsTargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++TargetNamespace
"\nreference is: "TargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++Reference -> TargetNamespace
forall a. Verbatim a => a -> TargetNamespace
verbatim Reference
r
                            TargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++TargetNamespace
"\nat "TargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++Posn -> TargetNamespace
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 <"TargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++TargetNamespace
tTargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++TargetNamespace
">"
    formatted [TargetNamespace]
tgs = TargetNamespace
"one of"TargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++ (TargetNamespace -> TargetNamespace)
-> [TargetNamespace] -> TargetNamespace
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\TargetNamespace
t->TargetNamespace
" <"TargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++TargetNamespace
tTargetNamespace -> TargetNamespace -> TargetNamespace
forall 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 = ((Posn, Element Posn) -> Element Posn)
-> XsdParser (Posn, Element Posn) -> XsdParser (Element Posn)
forall a b.
(a -> b) -> Parser (Content Posn) a -> Parser (Content Posn) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Posn, Element Posn) -> Element Posn
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:"TargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++TargetNamespace
n])

-- | Get the next content element, whatever it is.
anyElement :: XsdParser (Element Posn)
anyElement :: XsdParser (Element Posn)
anyElement = ((Posn, Element Posn) -> Element Posn)
-> XsdParser (Posn, Element Posn) -> XsdParser (Element Posn)
forall a b.
(a -> b) -> Parser (Content Posn) a -> Parser (Content Posn) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Posn, Element Posn) -> Element Posn
forall a b. (a, b) -> b
snd ((Content Posn -> Bool)
-> [TargetNamespace] -> XsdParser (Posn, Element Posn)
posnElementWith (Bool -> Content Posn -> Bool
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 e <- XsdParser (Element Posn)
anyElement
                   interiorWith (const True) p 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) = ([Content Posn] -> Result [Content Posn] a)
-> Parser (Content Posn) a
forall t a. ([t] -> Result [t] a) -> Parser t a
P (([Content Posn] -> Result [Content Posn] a)
 -> Parser (Content Posn) a)
-> ([Content Posn] -> Result [Content Posn] a)
-> Parser (Content Posn) a
forall a b. (a -> b) -> a -> b
$ \[Content Posn]
inp->
    [Content Posn]
-> Result [Content Posn] a -> Result [Content Posn] a
forall t x a. t -> Result x a -> Result t a
tidy [Content Posn]
inp (Result [Content Posn] a -> Result [Content Posn] a)
-> Result [Content Posn] a -> Result [Content Posn] a
forall a b. (a -> b) -> a -> b
$
    case [Content Posn] -> Result [Content Posn] a
p ((Content Posn -> Bool) -> [Content Posn] -> [Content Posn]
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
            | (Content Posn -> Bool) -> [Content Posn] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Content Posn -> Bool
forall {i}. Content i -> Bool
onlyMisc [Content Posn]
ds -> [Content Posn] -> a -> Result [Content Posn] a
forall z a. z -> a -> Result z a
Success [] a
a
            | Bool
otherwise       -> Result [Content Posn] a -> Result [Content Posn] a
forall z a. Result z a -> Result z a
Committed (Result [Content Posn] a -> Result [Content Posn] a)
-> Result [Content Posn] a -> Result [Content Posn] a
forall a b. (a -> b) -> a -> b
$
                                 [Content Posn] -> TargetNamespace -> Result [Content Posn] a
forall z a. z -> TargetNamespace -> Result z a
Failure [Content Posn]
ds (TargetNamespace
"Too many elements inside <"
                                             TargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++QName -> TargetNamespace
printableName QName
eTargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++TargetNamespace
"> at\n"
                                             TargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++Posn -> TargetNamespace
forall a. Show a => a -> TargetNamespace
show (Content Posn -> Posn
forall t. Content t -> t
info Content Posn
d)TargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++TargetNamespace
"\n\n"
                                             TargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++TargetNamespace
"Found excess: "
                                             TargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++[Content Posn] -> TargetNamespace
forall a. Verbatim a => a -> TargetNamespace
verbatim (Int -> [Content Posn] -> [Content Posn]
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
_) | (Char -> Bool) -> TargetNamespace -> Bool
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]
_) = ([Content Posn] -> Result [Content Posn] a)
-> Parser (Content Posn) a
forall t a. ([t] -> Result [t] a) -> Parser t a
P (([Content Posn] -> Result [Content Posn] a)
 -> Parser (Content Posn) a)
-> ([Content Posn] -> Result [Content Posn] a)
-> Parser (Content Posn) a
forall a b. (a -> b) -> a -> b
$ \[Content Posn]
inp->
    case QName -> [Attribute] -> Maybe AttValue
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup QName
qn [Attribute]
as of
        Maybe AttValue
Nothing  -> [Content Posn] -> TargetNamespace -> Result [Content Posn] a
forall z a. z -> TargetNamespace -> Result z a
Failure [Content Posn]
inp (TargetNamespace -> Result [Content Posn] a)
-> TargetNamespace -> Result [Content Posn] a
forall a b. (a -> b) -> a -> b
$ TargetNamespace
"attribute "TargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++QName -> TargetNamespace
printableName QName
qn
                                  TargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++TargetNamespace
" not present in <"TargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++QName -> TargetNamespace
printableName QName
nTargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++TargetNamespace
">"
        Just AttValue
atv -> [Content Posn]
-> Result TargetNamespace a -> Result [Content Posn] a
forall t x a. t -> Result x a -> Result t a
tidy [Content Posn]
inp (Result TargetNamespace a -> Result [Content Posn] a)
-> Result TargetNamespace a -> Result [Content Posn] a
forall a b. (a -> b) -> a -> b
$
                    case TargetNamespace -> Result TargetNamespace a
p (AttValue -> TargetNamespace
forall a. Show a => a -> TargetNamespace
show AttValue
atv) of
                      Committed Result TargetNamespace a
r   -> Result TargetNamespace a
r
                      Failure TargetNamespace
z TargetNamespace
msg -> TargetNamespace -> TargetNamespace -> Result TargetNamespace a
forall z a. z -> TargetNamespace -> Result z a
Failure TargetNamespace
z (TargetNamespace -> Result TargetNamespace a)
-> TargetNamespace -> Result TargetNamespace a
forall a b. (a -> b) -> a -> b
$
                                             TargetNamespace
"Attribute parsing failure: "
                                             TargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++QName -> TargetNamespace
printableName QName
qnTargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++TargetNamespace
"=\""
                                             TargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++AttValue -> TargetNamespace
forall a. Show a => a -> TargetNamespace
show AttValue
atvTargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++TargetNamespace
"\": "TargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++TargetNamespace
msg
                      Success [] a
v  -> TargetNamespace -> a -> Result TargetNamespace a
forall z a. z -> a -> Result z a
Success [] a
v
                      Success TargetNamespace
xs a
_  -> Result TargetNamespace a -> Result TargetNamespace a
forall z a. Result z a -> Result z a
Committed (Result TargetNamespace a -> Result TargetNamespace a)
-> Result TargetNamespace a -> Result TargetNamespace a
forall a b. (a -> b) -> a -> b
$
                                       TargetNamespace -> TargetNamespace -> Result TargetNamespace a
forall z a. z -> TargetNamespace -> Result z a
Failure TargetNamespace
xs (TargetNamespace -> Result TargetNamespace a)
-> TargetNamespace -> Result TargetNamespace a
forall a b. (a -> b) -> a -> b
$
                                             TargetNamespace
"Attribute parsing excess text: "
                                             TargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++QName -> TargetNamespace
printableName QName
qnTargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++TargetNamespace
"=\""
                                             TargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++AttValue -> TargetNamespace
forall a. Show a => a -> TargetNamespace
show AttValue
atvTargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++TargetNamespace
"\":\n  Excess is: "
                                             TargetNamespace -> TargetNamespace -> TargetNamespace
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]
_) =
    [Namespace] -> XsdParser [Namespace]
forall a. a -> Parser (Content Posn) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Namespace] -> XsdParser [Namespace])
-> ([Attribute] -> [Namespace])
-> [Attribute]
-> XsdParser [Namespace]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Attribute -> Namespace) -> [Attribute] -> [Namespace]
forall a b. (a -> b) -> [a] -> [b]
map Attribute -> Namespace
forall {a}. Verbatim a => (QName, a) -> Namespace
mkNamespace ([Attribute] -> [Namespace])
-> ([Attribute] -> [Attribute]) -> [Attribute] -> [Namespace]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Attribute -> Bool) -> [Attribute] -> [Attribute]
forall a. (a -> Bool) -> [a] -> [a]
filter (TargetNamespace -> Attribute -> Bool
matchNamespace TargetNamespace
"xmlns") ([Attribute] -> XsdParser [Namespace])
-> [Attribute] -> XsdParser [Namespace]
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    = a -> TargetNamespace
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 TargetNamespace -> TargetNamespace -> Bool
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) = t -> Result x a -> Result t a
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) = t -> TargetNamespace -> Result t a
forall z a. z -> TargetNamespace -> Result z a
Failure t
inp TargetNamespace
m
tidy t
inp (Success x
_ a
v) = t -> a -> Result t a
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]
_   = Maybe TargetNamespace
forall a. Maybe a
Nothing
targetPrefix (Just TargetNamespace
uri) [Namespace]
nss = Namespace -> TargetNamespace
nsPrefix (Namespace -> TargetNamespace)
-> Maybe Namespace -> Maybe TargetNamespace
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Namespace -> Bool) -> [Namespace] -> Maybe Namespace
forall a. (a -> Bool) -> [a] -> Maybe a
lookupBy ((TargetNamespace -> TargetNamespace -> Bool
forall a. Eq a => a -> a -> Bool
==TargetNamespace
uri)(TargetNamespace -> Bool)
-> (Namespace -> TargetNamespace) -> Namespace -> Bool
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 []     = Maybe a
forall a. Maybe a
Nothing
lookupBy a -> Bool
p (a
y:[a]
ys) | a -> Bool
p a
y       = a -> Maybe a
forall a. a -> Maybe a
Just a
y
                  | Bool
otherwise = (a -> Bool) -> [a] -> Maybe a
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
pTargetNamespace -> TargetNamespace -> Bool
forall 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 = TargetNamespace
-> (Namespace -> TargetNamespace)
-> Maybe Namespace
-> TargetNamespace
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TargetNamespace
"" Namespace -> TargetNamespace
nsURI (Maybe Namespace -> TargetNamespace)
-> Maybe Namespace -> TargetNamespace
forall a b. (a -> b) -> a -> b
$
                                      (Namespace -> Bool) -> [Namespace] -> Maybe Namespace
forall a. (a -> Bool) -> [a] -> Maybe a
lookupBy ((TargetNamespace -> TargetNamespace -> Bool
forall a. Eq a => a -> a -> Bool
==TargetNamespace
pre)(TargetNamespace -> Bool)
-> (Namespace -> TargetNamespace) -> Namespace -> Bool
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
    e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"schema"
    commit $ do
        tn  <- optional (attribute (N "targetNamespace") uri e)
        nss <- namespaceAttrs e
        return Schema
          `apply` (attribute (N "elementFormDefault")    qform e
                   `onFail` return Unqualified)
          `apply` (attribute (N "attributeFormDefault")  qform e
                   `onFail` return Unqualified)
          `apply` optional (attribute (xsd "finalDefault") final e)
          `apply` optional (attribute (xsd "blockDefault") block e)
          `apply` return tn
          `apply` optional (attribute (N "version")       string e)
          `apply` return nss
          `apply` interiorWith (const True) (many (schemaItem (qual tn nss))) e

-- | Parse a (possibly missing) <xsd:annotation> element.
annotation :: XsdParser Annotation
annotation :: XsdParser Annotation
annotation = do
    XsdParser Annotation
definiteAnnotation XsdParser Annotation
-> XsdParser Annotation -> XsdParser Annotation
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` Annotation -> XsdParser Annotation
forall a. a -> Parser (Content Posn) a
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
    e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"annotation"
    ( Documentation <$> interiorWith (xsdTag "documentation")
                                        (allChildren text)  e)
      `onFail`
      (AppInfo <$> interiorWith (xsdTag "documentation")
                                        (allChildren text)  e)
      `onFail`
      return (NoAnnotation "failed to parse")

-- | Parse a FormDefault attribute.
qform :: TextParser QForm
qform :: TextParser QForm
qform = do
    w <- TextParser TargetNamespace
word
    case w of
        TargetNamespace
"qualified"   -> QForm -> TextParser QForm
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return QForm
Qualified
        TargetNamespace
"unqualified" -> QForm -> TextParser QForm
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return QForm
Unqualified
        TargetNamespace
_             -> TargetNamespace -> TextParser QForm
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 Final
final = do
    w <- TextParser TargetNamespace
word
    case w of
        TargetNamespace
"restriction" -> Final -> TextParser Final
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Final
NoRestriction
        TargetNamespace
"extension"   -> Final -> TextParser Final
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Final
NoExtension
        TargetNamespace
"#all"        -> Final -> TextParser Final
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Final
AllFinal
        TargetNamespace
_             -> TargetNamespace -> TextParser Final
forall (p :: * -> *) a. PolyParse p => TargetNamespace -> p a
failBad (TargetNamespace -> TextParser Final)
-> TargetNamespace -> TextParser Final
forall a b. (a -> b) -> a -> b
$ TargetNamespace
"Expected \"restriction\" or \"extension\""
                                   TargetNamespace -> TargetNamespace -> TargetNamespace
forall a. [a] -> [a] -> [a]
++TargetNamespace
" or \"#all\""
block :: TextParser Block
block :: TextParser Final
block = TextParser Final
final

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

-- | Parse an <xsd:include>.
include :: XsdParser SchemaItem
include :: Parser (Content Posn) SchemaItem
include = do e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"include"
             commit $ return Include
                      `apply` attribute (N "schemaLocation") uri e
                      `apply` interiorWith (xsdTag "annotation") annotation e

-- | Parse an <xsd:import>.
import_ :: XsdParser SchemaItem
import_ :: Parser (Content Posn) SchemaItem
import_ = do e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"import"
             commit $ return Import
                      `apply` attribute (N "namespace")      uri e
                      `apply` attribute (N "schemaLocation") uri e
                      `apply` interiorWith (xsdTag "annotation") annotation e

-- | Parse a <xsd:redefine>.
redefine :: (String->String->QName) -> XsdParser SchemaItem
redefine :: (TargetNamespace -> TargetNamespace -> QName)
-> Parser (Content Posn) SchemaItem
redefine TargetNamespace -> TargetNamespace -> QName
q = do e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"redefine"
                commit $ return Redefine
                     `apply` attribute (N "schemaLocation") uri e
                     `apply` interiorWith (const True) (many (schemaItem q)) e

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

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

aFacet :: XsdParser Facet
aFacet :: Parser (Content Posn) Facet
aFacet = (Parser (Content Posn) Facet
 -> Parser (Content Posn) Facet -> Parser (Content Posn) Facet)
-> Parser (Content Posn) Facet
-> [Parser (Content Posn) Facet]
-> Parser (Content Posn) Facet
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Parser (Content Posn) Facet
-> Parser (Content Posn) Facet -> Parser (Content Posn) Facet
forall t a. Parser t a -> Parser t a -> Parser t a
onFail (TargetNamespace -> Parser (Content Posn) Facet
forall a. TargetNamespace -> Parser (Content Posn) a
forall (m :: * -> *) a. MonadFail m => TargetNamespace -> m a
fail TargetNamespace
"Could not recognise simpleType Facet")
               ((TargetNamespace -> FacetType -> Parser (Content Posn) Facet)
-> [TargetNamespace]
-> [FacetType]
-> [Parser (Content Posn) Facet]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith TargetNamespace -> FacetType -> Parser (Content Posn) 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 -> Parser (Content Posn) Facet
facet TargetNamespace
s FacetType
t = do e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
s
               v <- attribute (N "value") string e
               f <- attribute (N "fixed") bool e
                    `onFail` return False -- XXX check this
               a <- interiorWith (const True) annotation e
               return (Facet t a v f)

-- | Parse a <xsd:complexType> decl.
complexType :: (String->String->QName) -> XsdParser ComplexType
complexType :: (TargetNamespace -> TargetNamespace -> QName)
-> Parser (Content Posn) ComplexType
complexType TargetNamespace -> TargetNamespace -> QName
q =
    do e  <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"complexType"
       commit $ return ComplexType
           `apply` interiorWith (xsdTag "annotation") annotation e
           `apply` optional (attribute (N "name") string e)
           `apply` (attribute (N "abstract") bool e `onFail` return False)
           `apply` optional (attribute (N "final") final e)
           `apply` optional (attribute (N "block") block e)
           `apply` (attribute (N "mixed") bool e `onFail` return False)
           `apply` interiorWith (not . xsdTag "annotation") (complexItem q) e

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

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

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

-- | Parse an <xsd:all>, <xsd:choice>, or <xsd:sequence> decl.
choiceOrSeq :: (String->String->QName) -> XsdParser ChoiceOrSeq
choiceOrSeq :: (TargetNamespace -> TargetNamespace -> QName)
-> Parser (Content Posn) ChoiceOrSeq
choiceOrSeq TargetNamespace -> TargetNamespace -> QName
q =
    do e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"all"
       commit $ return All
           `apply` interiorWith (xsdTag "annotation") annotation e
           `apply` interiorWith (not.xsdTag "annotation")
                                (many (elementDecl q)) e
    Parser (Content Posn) ChoiceOrSeq
-> Parser (Content Posn) ChoiceOrSeq
-> Parser (Content Posn) ChoiceOrSeq
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
    do e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"choice"
       commit $ return Choice
           `apply` interiorWith (xsdTag "annotation") annotation e
           `apply` occurs e
           `apply` interiorWith (not.xsdTag "annotation")
                                (many (elementEtc q)) e
    Parser (Content Posn) ChoiceOrSeq
-> Parser (Content Posn) ChoiceOrSeq
-> Parser (Content Posn) ChoiceOrSeq
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
    do e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"sequence"
       commit $ return Sequence
           `apply` interiorWith (xsdTag "annotation") annotation e
           `apply` occurs e
           `apply` interiorWith (not.xsdTag "annotation")
                                (many (elementEtc q)) e

-- | Parse a <xsd:group> decl.
group_ :: (String->String->QName) -> XsdParser Group
group_ :: (TargetNamespace -> TargetNamespace -> QName)
-> Parser (Content Posn) Group
group_ TargetNamespace -> TargetNamespace -> QName
q = do e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"group"
              commit $ return Group
                `apply` interiorWith (xsdTag "annotation") annotation e
                `apply` (fmap Left (attribute (N "name") string e)
                         `onFail`
                         fmap Right (attribute (N "ref") (qname q) e))
                `apply` occurs e
                `apply` interiorWith (not.xsdTag "annotation")
                                     (optional (choiceOrSeq q)) 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)
-> Parser (Content Posn) ElementEtc
elementEtc TargetNamespace -> TargetNamespace -> QName
q = (ElementDecl -> ElementEtc)
-> Parser (Content Posn) ElementDecl
-> Parser (Content Posn) ElementEtc
forall a b.
(a -> b) -> Parser (Content Posn) a -> Parser (Content Posn) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ElementDecl -> ElementEtc
HasElement ((TargetNamespace -> TargetNamespace -> QName)
-> Parser (Content Posn) ElementDecl
elementDecl TargetNamespace -> TargetNamespace -> QName
q)
             Parser (Content Posn) ElementEtc
-> Parser (Content Posn) ElementEtc
-> Parser (Content Posn) ElementEtc
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
             (Group -> ElementEtc)
-> Parser (Content Posn) Group -> Parser (Content Posn) ElementEtc
forall a b.
(a -> b) -> Parser (Content Posn) a -> Parser (Content Posn) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Group -> ElementEtc
HasGroup ((TargetNamespace -> TargetNamespace -> QName)
-> Parser (Content Posn) Group
group_ TargetNamespace -> TargetNamespace -> QName
q)
             Parser (Content Posn) ElementEtc
-> Parser (Content Posn) ElementEtc
-> Parser (Content Posn) ElementEtc
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
             (ChoiceOrSeq -> ElementEtc)
-> Parser (Content Posn) ChoiceOrSeq
-> Parser (Content Posn) ElementEtc
forall a b.
(a -> b) -> Parser (Content Posn) a -> Parser (Content Posn) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ChoiceOrSeq -> ElementEtc
HasCS ((TargetNamespace -> TargetNamespace -> QName)
-> Parser (Content Posn) ChoiceOrSeq
choiceOrSeq TargetNamespace -> TargetNamespace -> QName
q)
             Parser (Content Posn) ElementEtc
-> Parser (Content Posn) ElementEtc
-> Parser (Content Posn) ElementEtc
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
             (Any -> ElementEtc)
-> Parser (Content Posn) Any -> Parser (Content Posn) ElementEtc
forall a b.
(a -> b) -> Parser (Content Posn) a -> Parser (Content Posn) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Any -> ElementEtc
HasAny Parser (Content Posn) Any
any_

-- | Parse an <xsd:any>.
any_ :: XsdParser Any
any_ :: Parser (Content Posn) Any
any_ = do e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"any"
          commit $ return Any
              `apply` interiorWith (xsdTag "annotation") annotation e
              `apply` (attribute (N "namespace") uri e
                       `onFail` return "##any")
              `apply` (attribute (N "processContents") processContents e
                       `onFail` return Strict)
              `apply` occurs e

-- | Parse an <xsd:anyAttribute>.
anyAttr :: XsdParser AnyAttr
anyAttr :: Parser (Content Posn) AnyAttr
anyAttr = do e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"anyAttribute"
             commit $ return AnyAttr
                 `apply` interiorWith (xsdTag "annotation") annotation e
                 `apply` (attribute (N "namespace") uri e
                          `onFail` return "##any")
                 `apply` (attribute (N "processContents") processContents e
                          `onFail` return Strict)

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

-- | Parse an <xsd:element> decl.
elementDecl :: (String->String->QName) -> XsdParser ElementDecl
elementDecl :: (TargetNamespace -> TargetNamespace -> QName)
-> Parser (Content Posn) ElementDecl
elementDecl TargetNamespace -> TargetNamespace -> QName
q =
    do e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"element"
       commit $ return ElementDecl
           `apply` interiorWith (xsdTag "annotation") annotation e
           `apply` (fmap Left (nameAndType q e)
                    `onFail`
                    fmap Right (attribute (N "ref") (qname q) e))
           `apply` occurs e
           `apply` (attribute (N "nillable") bool e `onFail` return False)
           `apply` optional (attribute (N "substitutionGroup") (qname q) e)
           `apply` (attribute (N "abstract") bool e `onFail` return False)
           `apply` optional (attribute (xsd "final") final e)
           `apply` optional (attribute (xsd "block") block e)
           `apply` (attribute (xsd "form") qform e `onFail` return Unqualified)
           `apply` interiorWith (xsdTag "simpleType" ||| xsdTag "complexType")
                                (optional (fmap Left (simpleType q)
                                           `onFail`
                                           fmap Right (complexType q))) e
           `apply` interiorWith (xsdTag "unique" ||| xsdTag "key"
                                                 ||| xsdTag "keyRef")
                                (many (uniqueKeyOrKeyRef q)) e

-- | Parse name and type attributes.
nameAndType :: (String->String->QName) -> Element Posn -> XsdParser NameAndType
nameAndType :: (TargetNamespace -> TargetNamespace -> QName)
-> Element Posn -> Parser (Content Posn) NameAndType
nameAndType TargetNamespace -> TargetNamespace -> QName
q Element Posn
e = (TargetNamespace -> Maybe QName -> NameAndType)
-> Parser
     (Content Posn) (TargetNamespace -> Maybe QName -> NameAndType)
forall a. a -> Parser (Content Posn) a
forall (m :: * -> *) a. Monad m => a -> m a
return TargetNamespace -> Maybe QName -> NameAndType
NT Parser
  (Content Posn) (TargetNamespace -> Maybe QName -> NameAndType)
-> Parser (Content Posn) TargetNamespace
-> Parser (Content Posn) (Maybe QName -> NameAndType)
forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` QName
-> TextParser TargetNamespace
-> Element Posn
-> Parser (Content Posn) TargetNamespace
forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"name") TextParser TargetNamespace
string Element Posn
e
                            Parser (Content Posn) (Maybe QName -> NameAndType)
-> Parser (Content Posn) (Maybe QName)
-> Parser (Content Posn) NameAndType
forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` Parser (Content Posn) QName -> Parser (Content Posn) (Maybe QName)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (QName
-> TextParser QName -> Element Posn -> Parser (Content Posn) QName
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)
-> Parser (Content Posn) AttributeDecl
attributeDecl TargetNamespace -> TargetNamespace -> QName
q =
    do e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"attribute"
       commit $ return AttributeDecl
           `apply` interiorWith (xsdTag "annotation") annotation e
           `apply` (fmap Left (nameAndType q e)
                    `onFail`
                    fmap Right (attribute (N "ref") (qname q) e))
           `apply` (attribute (N "use") use e `onFail` return Optional)
           `apply` optional (attribute (N "default") (fmap Left string) e
                              `onFail`
                              attribute (N "fixed") (fmap Right string) e)
           `apply` (attribute (xsd "form") qform e `onFail` return Unqualified)
           `apply` interiorWith (xsdTag "simpleType")
                                (optional (simpleType q)) e


-- | Parse an occurrence range from attributes of given element.
occurs :: Element Posn -> XsdParser Occurs
occurs :: Element Posn -> Parser (Content Posn) Occurs
occurs Element Posn
e = (Maybe Int -> Maybe Int -> Occurs)
-> Parser (Content Posn) (Maybe Int -> Maybe Int -> Occurs)
forall a. a -> Parser (Content Posn) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int -> Maybe Int -> Occurs
Occurs
               Parser (Content Posn) (Maybe Int -> Maybe Int -> Occurs)
-> Parser (Content Posn) (Maybe Int)
-> Parser (Content Posn) (Maybe Int -> Occurs)
forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` Parser (Content Posn) Int -> Parser (Content Posn) (Maybe Int)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (QName
-> TextParser Int -> Element Posn -> Parser (Content Posn) Int
forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"minOccurs") TextParser Int
forall a. Integral a => TextParser a
parseDec Element Posn
e)
               Parser (Content Posn) (Maybe Int -> Occurs)
-> Parser (Content Posn) (Maybe Int)
-> Parser (Content Posn) Occurs
forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` Parser (Content Posn) Int -> Parser (Content Posn) (Maybe Int)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (QName
-> TextParser Int -> Element Posn -> Parser (Content Posn) Int
forall a. QName -> TextParser a -> Element Posn -> XsdParser a
attribute (TargetNamespace -> QName
N TargetNamespace
"maxOccurs") TextParser Int
maxDec Element Posn
e)
  where
    maxDec :: TextParser Int
maxDec = TextParser Int
forall a. Integral a => TextParser a
parseDec
             TextParser Int -> TextParser Int -> TextParser Int
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
             do TargetNamespace -> TextParser TargetNamespace
isWord TargetNamespace
"unbounded"; Int -> TextParser Int
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
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)
-> Parser (Content Posn) UniqueKeyOrKeyRef
uniqueKeyOrKeyRef TargetNamespace -> TargetNamespace -> QName
q = (Unique -> UniqueKeyOrKeyRef)
-> Parser (Content Posn) Unique
-> Parser (Content Posn) UniqueKeyOrKeyRef
forall a b.
(a -> b) -> Parser (Content Posn) a -> Parser (Content Posn) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Unique -> UniqueKeyOrKeyRef
U Parser (Content Posn) Unique
unique Parser (Content Posn) UniqueKeyOrKeyRef
-> Parser (Content Posn) UniqueKeyOrKeyRef
-> Parser (Content Posn) UniqueKeyOrKeyRef
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                      (Key -> UniqueKeyOrKeyRef)
-> Parser (Content Posn) Key
-> Parser (Content Posn) UniqueKeyOrKeyRef
forall a b.
(a -> b) -> Parser (Content Posn) a -> Parser (Content Posn) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Key -> UniqueKeyOrKeyRef
K Parser (Content Posn) Key
key Parser (Content Posn) UniqueKeyOrKeyRef
-> Parser (Content Posn) UniqueKeyOrKeyRef
-> Parser (Content Posn) UniqueKeyOrKeyRef
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail`
                      (KeyRef -> UniqueKeyOrKeyRef)
-> Parser (Content Posn) KeyRef
-> Parser (Content Posn) UniqueKeyOrKeyRef
forall a b.
(a -> b) -> Parser (Content Posn) a -> Parser (Content Posn) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap KeyRef -> UniqueKeyOrKeyRef
KR ((TargetNamespace -> TargetNamespace -> QName)
-> Parser (Content Posn) KeyRef
keyRef TargetNamespace -> TargetNamespace -> QName
q)

-- | Parse a <xsd:unique>.
unique :: XsdParser Unique
unique :: Parser (Content Posn) Unique
unique =
    do e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"unique"
       commit $ return Unique
           `apply` interiorWith (xsdTag "annotation") annotation e
           `apply` attribute (N "name") string e
           `apply` interiorWith (xsdTag "selector") selector e
           `apply` interiorWith (xsdTag "field") (many1 field_) e

-- | Parse a <xsd:key>.
key :: XsdParser Key
key :: Parser (Content Posn) Key
key =
    do e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"key"
       commit $ return Key
           `apply` interiorWith (xsdTag "annotation") annotation e
           `apply` attribute (N "name") string e
           `apply` interiorWith (xsdTag "selector") selector e
           `apply` interiorWith (xsdTag "field") (many1 field_) e

-- | Parse a <xsd:keyref>.
keyRef :: (String->String->QName) -> XsdParser KeyRef
keyRef :: (TargetNamespace -> TargetNamespace -> QName)
-> Parser (Content Posn) KeyRef
keyRef TargetNamespace -> TargetNamespace -> QName
q =
    do e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"keyref"
       commit $ return KeyRef
           `apply` interiorWith (xsdTag "annotation") annotation e
           `apply` attribute (N "name") string e
           `apply` attribute (N "refer") (qname q) e
           `apply` interiorWith (xsdTag "selector") selector e
           `apply` interiorWith (xsdTag "field") (many1 field_) e

-- | Parse a <xsd:selector>.
selector :: XsdParser Selector
selector :: Parser (Content Posn) Selector
selector =
    do e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"selector"
       commit $ return Selector
           `apply` interiorWith (xsdTag "annotation") annotation e
           `apply` attribute (N "xpath") string e

-- | Parse a <xsd:field>.
field_ :: XsdParser Field
field_ :: Parser (Content Posn) Field
field_ =
    do e <- TargetNamespace -> XsdParser (Element Posn)
xsdElement TargetNamespace
"field"
       commit $ return Field
           `apply` interiorWith (xsdTag "annotation") annotation e
           `apply` attribute (N "xpath") string 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 = [TargetNamespace] -> TargetNamespace
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([TargetNamespace] -> TargetNamespace)
-> Parser Char [TargetNamespace] -> TextParser TargetNamespace
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TextParser TargetNamespace -> Parser Char [TargetNamespace]
forall a. Parser Char a -> Parser Char [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (TextParser TargetNamespace
space TextParser TargetNamespace
-> TextParser TargetNamespace -> TextParser TargetNamespace
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` TextParser TargetNamespace
word)

space :: TextParser String
space :: TextParser TargetNamespace
space = Parser Char Char -> TextParser TargetNamespace
forall (p :: * -> *) a. PolyParse p => p a -> p [a]
many1 (Parser Char Char -> TextParser TargetNamespace)
-> Parser Char Char -> TextParser TargetNamespace
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser Char Char
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 w <- TextParser TargetNamespace
word
          case w of
            TargetNamespace
"true"  -> Bool -> TextParser Bool
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            TargetNamespace
"false" -> Bool -> TextParser Bool
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            TargetNamespace
"0"     -> Bool -> TextParser Bool
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            TargetNamespace
"1"     -> Bool -> TextParser Bool
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            TargetNamespace
_       -> TargetNamespace -> TextParser Bool
forall a. TargetNamespace -> Parser Char a
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 w <- TextParser TargetNamespace
word
         case w of
           TargetNamespace
"required"   -> Use -> TextParser Use
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Use
Required
           TargetNamespace
"optional"   -> Use -> TextParser Use
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Use
Optional
           TargetNamespace
"prohibited" -> Use -> TextParser Use
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return Use
Prohibited
           TargetNamespace
_            -> TargetNamespace -> TextParser Use
forall a. TargetNamespace -> Parser Char a
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 w <- TextParser TargetNamespace
word
       case w of
         TargetNamespace
"skip"   -> ProcessContents -> TextParser ProcessContents
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessContents
Skip
         TargetNamespace
"lax"    -> ProcessContents -> TextParser ProcessContents
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessContents
Lax
         TargetNamespace
"strict" -> ProcessContents -> TextParser ProcessContents
forall a. a -> Parser Char a
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessContents
Strict
         TargetNamespace
_        -> TargetNamespace -> TextParser ProcessContents
forall a. TargetNamespace -> Parser Char a
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 a <- TextParser TargetNamespace
word
             do ":" <- word
                b   <- many (satisfy (/=':'))
                return (q a b)
               `onFail`
                 do cs <- many next
                    return (N (a++cs))