summaryrefslogtreecommitdiff
path: root/src/Text/XML/HaXml/Schema/Parse.hs
blob: d3acfc29bac8a5d6283a8c5633ea01c07032cb73 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
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)
p ||| q = \v -> p v || q v

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

-- | 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 tag (CElem (Elem qn _ _) _)  =  qn == xsd tag || qn == (N tag)
xsdTag _   _                        =  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 match tags = do
    { c <- next `adjustErr` (++" when expecting "++formatted tags)
    ; case c of
        CElem e pos
            | match c   -> return (pos,e)
        CElem (Elem t _ _) pos
            | otherwise -> fail ("Found a <"++printableName t
                                 ++">, but expected "
                                 ++formatted tags++"\nat "++show pos)
        CString b s pos  -- ignore blank space
            | not b && all isSpace s -> posnElementWith match tags
            | otherwise -> fail ("Found text content, but expected "
                                 ++formatted tags++"\ntext is: "++s
                                 ++"\nat "++show pos)
        CRef r pos -> fail ("Found reference, but expected "
                            ++formatted tags++"\nreference is: "++verbatim r
                            ++"\nat "++show pos)
        CMisc _ _ -> posnElementWith match tags  -- skip comments, PIs, etc.
    }
  where
    formatted [t]  = "a <"++t++">"
    formatted tgs = "one of"++ concatMap (\t->" <"++t++">") tgs

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

-- | Get the next content element, whatever it is.
anyElement :: XsdParser (Element Posn)
anyElement = fmap snd (posnElementWith (const True) ["any element"])

-- | Grab and parse any and all children of the next element.
allChildren :: XsdParser a -> XsdParser a
allChildren p = do e <- 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 keep (P p) (Elem e _ cs) = P $ \inp->
    tidy inp $
    case p (filter keep cs) of
        Committed r        -> r
        f@(Failure _ _)    -> f
        s@(Success [] _)   -> s
        Success ds@(d:_) a
            | all onlyMisc ds -> Success [] a
            | otherwise       -> Committed $
                                 Failure ds ("Too many elements inside <"
                                             ++printableName e++"> at\n"
                                             ++show (info d)++"\n\n"
                                             ++"Found excess: "
                                             ++verbatim (take 5 ds))
  where onlyMisc (CMisc _ _) = True
        onlyMisc (CString False s _) | all isSpace s = True
        onlyMisc _ = 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 qn (P p) (Elem n as _) = P $ \inp->
    case lookup qn as of
        Nothing  -> Failure inp $ "attribute "++printableName qn
                                  ++" not present in <"++printableName n++">"
        Just atv -> tidy inp $
                    case p (show atv) of
                      Committed r   -> r
                      Failure z msg -> Failure z $
                                             "Attribute parsing failure: "
                                             ++printableName qn++"=\""
                                             ++show atv++"\": "++msg
                      Success [] v  -> Success [] v
                      Success xs _  -> Committed $ 
                                       Failure xs $
                                             "Attribute parsing excess text: "
                                             ++printableName qn++"=\""
                                             ++show atv++"\":\n  Excess is: "
                                             ++xs

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

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

-- | Tidy up the parsing context.
tidy :: t -> Result x a -> Result t a
tidy inp (Committed r) = tidy inp r
tidy inp (Failure _ m) = Failure inp m
tidy inp (Success _ v) = Success inp 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 Nothing    _   = Nothing
targetPrefix (Just uri) nss = fmap nsPrefix $ lookupBy ((==uri).nsURI) nss

-- | An auxiliary you might expect to find in Data.List
lookupBy :: (a->Bool) -> [a] -> Maybe a
lookupBy p []     = Nothing
lookupBy p (y:ys) | p y       = Just y
                  | otherwise = lookupBy p 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 tn nss pre nm = case targetPrefix tn nss of
                         Nothing             -> QN thisNS nm
                         Just p  | p/=pre    -> QN thisNS nm
                                 | otherwise -> N nm
    where thisNS = Namespace{ nsPrefix = pre
                            , nsURI = maybe "" nsURI $
                                      lookupBy ((==pre).nsPrefix) nss
                            }

-- Now for the real parsers.

-- | Parse a Schema declaration
schema = do
    e <- xsdElement "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 = do
    definiteAnnotation `onFail` return (NoAnnotation "missing")

-- | Parse a definitely-occurring <xsd:annotation> element.
definiteAnnotation :: XsdParser Annotation
definiteAnnotation = do
    e <- xsdElement "annotation"
    ( fmap Documentation $ interiorWith (xsdTag "documentation")
                                        (allChildren text)  e
      ) `onFail` (
      fmap AppInfo $ interiorWith (xsdTag "documentation")
                                        (allChildren text)  e
      ) `onFail` (
      return (NoAnnotation "failed to parse")
      )

-- | Parse a FormDefault attribute.
qform :: TextParser QForm
qform = do
    w <- word
    case w of
        "qualified"   -> return Qualified
        "unqualified" -> return Unqualified
        _             -> failBad "Expected \"qualified\" or \"unqualified\""

-- | Parse a Final or Block attribute.
final :: TextParser Final
final = do
    w <- word
    case w of
        "restriction" -> return NoRestriction
        "extension"   -> return NoExtension
        "#all"        -> return AllFinal
        _             -> failBad $ "Expected \"restriction\" or \"extension\""
                                   ++" or \"#all\""
block :: TextParser Block
block = final

-- | Parse a schema item (just under the toplevel <xsd:schema>)
schemaItem :: (String->String->QName) -> XsdParser SchemaItem
schemaItem qual = oneOf'
       [ ("xsd:include",        include)
       , ("xsd:import",         import_)
       , ("xsd:redefine",       (redefine qual))
       , ("xsd:annotation",     fmap Annotation     definiteAnnotation)
         --
       , ("xsd:simpleType",     fmap Simple           (simpleType qual))
       , ("xsd:complexType",    fmap Complex          (complexType qual))
       , ("xsd:element",        fmap SchemaElement    (elementDecl qual))
       , ("xsd:attribute",      fmap SchemaAttribute  (attributeDecl qual))
       , ("xsd:attributeGroup", fmap AttributeGroup   (attributeGroup qual))
       , ("xsd:group",          fmap SchemaGroup      (group_ qual))
   --  , ("xsd:notation",       notation)
       ]

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

-- | Parse an <xsd:import>.
import_ :: XsdParser SchemaItem
import_ = do e <- xsdElement "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 q = do e <- xsdElement "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 q = do
    e <- xsdElement "simpleType"
    n <- optional (attribute (N "name") name 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 n f a =
        do e  <- xsdElement "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)
        `onFail`
        do e  <- xsdElement "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)
        `onFail`
        do e  <- xsdElement "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)
        `adjustErr`
        ("xsd:simpleType does not contain a restriction, list, or union\n"++)

    restriction1 a b = return (RestrictSim1 a b)
                            `apply` (return Restriction1 `apply` particle q)
    restrictType a b = return (RestrictType a b)
                            `apply` (optional (simpleType q))
                            `apply` many aFacet

aFacet :: XsdParser Facet
aFacet = foldr onFail (fail "Could not recognise simpleType Facet")
               (zipWith facet ["minInclusive","minExclusive","maxInclusive"
                              ,"maxExclusive","totalDigits","fractionDigits"
                              ,"length","minLength","maxLength"
                              ,"enumeration","whiteSpace","pattern"]
                              [OrderedBoundsMinIncl,OrderedBoundsMinExcl
                              ,OrderedBoundsMaxIncl,OrderedBoundsMaxExcl
                              ,OrderedNumericTotalDigits
                              ,OrderedNumericFractionDigits
                              ,UnorderedLength,UnorderedMinLength
                              ,UnorderedMaxLength,UnorderedEnumeration
                              ,UnorderedWhitespace,UnorderedPattern])

facet :: String -> FacetType -> XsdParser Facet
facet s t = do e <- xsdElement 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 q =
    do e  <- xsdElement "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 q =
    ( do e <- xsdElement "simpleContent"
         commit $ return SimpleContent
                `apply` interiorWith (xsdTag "annotation") annotation e
                `apply` interiorWith (not.xsdTag "annotation") stuff e
    ) `onFail` (
      do e <- xsdElement "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
    ) `onFail` (
      do fmap ThisType $ particleAttrs q
    )
  where
    stuff :: XsdParser (Either Restriction1 Extension)
    stuff =
      ( do e <- xsdElement "restriction"
           commit $ fmap Left $ return Restriction1 `apply` particle q
      ) `onFail` (
        do e <- xsdElement "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 q = optional (fmap Left (choiceOrSeq q) `onFail` fmap Right (group_ q))

-- | Parse a particle decl with optional attributes.
particleAttrs :: (String->String->QName) -> XsdParser ParticleAttrs
particleAttrs q = return PA `apply` particle q
                            `apply` many (fmap Left (attributeDecl q)
                                          `onFail`
                                          fmap Right (attributeGroup q))
                            `apply` optional anyAttr

-- | Parse an <xsd:all>, <xsd:choice>, or <xsd:sequence> decl.
choiceOrSeq :: (String->String->QName) -> XsdParser ChoiceOrSeq
choiceOrSeq q =
    do e <- xsdElement "all"
       commit $ return All
           `apply` interiorWith (xsdTag "annotation") annotation e
           `apply` interiorWith (not.xsdTag "annotation")
                                (many (elementDecl q)) e
    `onFail`
    do e <- xsdElement "choice"
       commit $ return Choice
           `apply` interiorWith (xsdTag "annotation") annotation e
           `apply` occurs e
           `apply` interiorWith (not.xsdTag "annotation")
                                (many (elementEtc q)) e
    `onFail`
    do e <- xsdElement "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_ q = do e <- xsdElement "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 q = fmap HasElement (elementDecl q)
             `onFail`
             fmap HasGroup (group_ q)
             `onFail`
             fmap HasCS (choiceOrSeq q)
             `onFail`
             fmap HasAny any_

-- | Parse an <xsd:any>.
any_ :: XsdParser Any
any_ = do e <- xsdElement "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 = do e <- xsdElement "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 q =
    do e <- xsdElement "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 = fmap Left (attributeDecl q) `onFail` fmap Right (attributeGroup q)

-- | Parse an <xsd:element> decl.
elementDecl :: (String->String->QName) -> XsdParser ElementDecl
elementDecl q =
    do e <- xsdElement "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 q e = return NT `apply` attribute (N "name") string e
                            `apply` optional (attribute (N "type") (qname q) e)

-- | Parse an <xsd:attribute> decl.
attributeDecl :: (String->String->QName) -> XsdParser AttributeDecl
attributeDecl q =
    do e <- xsdElement "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 e = return Occurs
               `apply` (optional $ attribute (N "minOccurs") parseDec e)
               `apply` (optional $ attribute (N "maxOccurs") maxDec e)
  where
    maxDec = parseDec
             `onFail`
             do isWord "unbounded"; return maxBound

-- | Parse a <xsd:unique>, <xsd:key>, or <xsd:keyref>.
uniqueKeyOrKeyRef :: (String->String->QName) -> XsdParser UniqueKeyOrKeyRef
uniqueKeyOrKeyRef q = fmap U unique `onFail`
                      fmap K key `onFail`
                      fmap KR (keyRef q)

-- | Parse a <xsd:unique>.
unique :: XsdParser Unique
unique =
    do e <- xsdElement "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 =
    do e <- xsdElement "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 q =
    do e <- xsdElement "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 =
    do e <- xsdElement "selector"
       commit $ return Selector
           `apply` interiorWith (xsdTag "annotation") annotation e
           `apply` attribute (N "xpath") string e

-- | Parse a <xsd:field>.
field_ :: XsdParser Field
field_ =
    do e <- xsdElement "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 = string

-- | Text parser for an arbitrary string consisting of possibly multiple tokens.
string :: TextParser String
string = fmap concat $ many word

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

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

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

-- | Parse an attribute value that should be a QName.
qname :: (String->String->QName) -> TextParser QName
qname q = do a <- word
             ( do ":" <- word
                  b   <- many (satisfy (/=':'))
                  return (q a b)
               `onFail`
               do cs <- many next
                  return (N (a++cs)) )

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