    {-# LANGUAGE CPP, FunctionalDependencies,
                 TypeSynonymInstances, ExistentialQuantification #-}
    module Text.XML.HaXml.Schema.Schema
      ( SchemaType(..)
      , SimpleType(..) -- already exported by PrimitiveTypes
      , Extension(..)
      , Restricts(..)
      , FwdDecl(..)
      , getAttribute
      , between
      , Occurs(..)
      , parseSimpleType
      , parseText
      , AnyElement(..)
      , parseAnyElement
    --  , module Text.XML.HaXml.XmlContent.Parser -- no, just the things below
      , Content(..)
      , XMLParser(..)
      , posnElement
      , posnElementWith
      , element
      , interior
      , text
      , module Text.ParserCombinators.Poly
      , module Text.Parse
    --  , module Text.XML.HaXml.Schema.PrimitiveTypes
      , module Text.XML.HaXml.OneOfN
      , toXMLElement
      , toXMLText
      , toXMLAnyElement
      , toXMLAttribute
      , addXMLAttributes
      ) where

    import Control.Monad (void)
    import Text.ParserCombinators.Poly
    import Text.Parse

    import Text.XML.HaXml.Types
    import Text.XML.HaXml.Posn
    import Text.XML.HaXml.Namespaces (printableName)
    import Text.XML.HaXml.XmlContent.Parser hiding (Document,Reference)
    import Text.XML.HaXml.Schema.XSDTypeModel (Occurs(..))
    import Text.XML.HaXml.Schema.PrimitiveTypes as Prim
    import Text.XML.HaXml.OneOfN
    import Text.XML.HaXml.Verbatim

    -- | A SchemaType promises to interconvert between a generic XML
    --   content tree and a Haskell value, according to the rules of XSD.
    class SchemaType a where
        parseSchemaType :: String -> XMLParser a
        schemaTypeToXML :: String -> a -> [Content ()]

    -- | A type t can extend another type s by the addition of extra elements
    --   and/or attributes.  s is therefore the supertype of t.
    class Extension t s {- - | t -> s -} where  -- fundep ill-advised.
        supertype :: t -> s

    -- | A type t can restrict another type s, that is, t admits fewer values
    --   than s, but all the values t does admit also belong to the type s.
    class Restricts t s | t -> s where
        restricts :: t -> s

    -- | A trick to enable forward-declaration of a type that will be defined
    --   properly in another module, higher in the dependency graph. 'fd' is
    --   a dummy type e.g. the empty @data FwdA@, where 'a' is the proper
    --   @data A@, not yet available.
    class FwdDecl fd a | fd -> a

    -- | Given a TextParser for a SimpleType, make it into an XMLParser, i.e.
    --   consuming textual XML content as input rather than a String.
    parseSimpleType :: SimpleType t => XMLParser t
    parseSimpleType :: forall t. SimpleType t => XMLParser t
    parseSimpleType = do s <- XMLParser String
    text XMLParser String -> XMLParser String -> XMLParser String
    forall t a. Parser t a -> Parser t a -> Parser t a
    `onFail` String -> XMLParser String
    forall a. a -> Parser (Content Posn) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return String
    ""
                         case runParser acceptingParser s of
                           (Left String
    err, String
    _) -> String -> Parser (Content Posn) t
    forall a. String -> Parser (Content Posn) a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    err
                           (Right t
    v, String
    "") -> t -> Parser (Content Posn) t
    forall a. a -> Parser (Content Posn) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return t
    v
                           (Right t
    v, String
    _)  -> t -> Parser (Content Posn) t
    forall a. a -> Parser (Content Posn) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return t
    v -- ignore trailing text

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

    -- | Between is a list parser that tries to ensure that any range
    --   specification (min and max elements) is obeyed when parsing.
    between :: PolyParse p => Occurs -> p a -> p [a]
    between :: forall (p :: * -> *) a. PolyParse p => Occurs -> p a -> p [a]
    between (Occurs Maybe Int
    Nothing  Maybe Int
    Nothing)  p a
    p = (a -> [a]) -> p a -> p [a]
    forall a b. (a -> b) -> p a -> p b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (a -> [a] -> [a]
    forall a. a -> [a] -> [a]
    :[]) p a
    p
    between (Occurs (Just Int
    i) Maybe Int
    Nothing)  p a
    p = ([a] -> [a] -> [a]) -> p ([a] -> [a] -> [a])
    forall a. a -> p a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [a] -> [a] -> [a]
    forall a. [a] -> [a] -> [a]
    (++) p ([a] -> [a] -> [a]) -> p [a] -> p ([a] -> [a])
    forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
    `apply` Int -> p a -> p [a]
    forall (p :: * -> *) a. PolyParse p => Int -> p a -> p [a]
    exactly Int
    i p a
    p
                                                       p ([a] -> [a]) -> p [a] -> p [a]
    forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
    `apply` p a -> p [a]
    forall a. p a -> p [a]
    forall (f :: * -> *) a. Alternative f => f a -> f [a]
    many p a
    p
    between (Occurs Maybe Int
    Nothing  (Just Int
    j)) p a
    p = Int -> p a -> p [a]
    forall (p :: * -> *) a. PolyParse p => Int -> p a -> p [a]
    upto Int
    j p a
    p
    between (Occurs (Just Int
    i) (Just Int
    j)) p a
    p = ([a] -> [a] -> [a]) -> p ([a] -> [a] -> [a])
    forall a. a -> p a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [a] -> [a] -> [a]
    forall a. [a] -> [a] -> [a]
    (++) p ([a] -> [a] -> [a]) -> p [a] -> p ([a] -> [a])
    forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
    `apply` Int -> p a -> p [a]
    forall (p :: * -> *) a. PolyParse p => Int -> p a -> p [a]
    exactly Int
    i p a
    p
                                                       p ([a] -> [a]) -> p [a] -> p [a]
    forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
    `apply` Int -> p a -> p [a]
    forall (p :: * -> *) a. PolyParse p => Int -> p a -> p [a]
    upto (Int
    jInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    i) p a
    p

    -- | Generated parsers will use 'getAttribute' as a convenient wrapper
    --   to lift a SchemaAttribute parser into an XMLParser.
    getAttribute :: (SimpleType a, Show a) =>
                    String -> Element Posn -> Posn -> XMLParser a
    getAttribute :: forall a.
    (SimpleType a, Show a) =>
    String -> Element Posn -> Posn -> XMLParser a
    getAttribute String
    aname (Elem QName
    t [Attribute]
    as [Content Posn]
    _) Posn
    pos =
        case String -> [Attribute] -> Maybe AttValue
    forall a. String -> [(QName, a)] -> Maybe a
    qnLookup String
    aname [Attribute]
    as of
            Maybe AttValue
    Nothing  -> String -> XMLParser a
    forall a. String -> Parser (Content Posn) a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> XMLParser a) -> String -> XMLParser a
    forall a b. (a -> b) -> a -> b
    $ String
    "attribute missing: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    aname
                               String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " in element <" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ QName -> String
    printableName QName
    t
                               String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "> at " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Posn -> String
    forall a. Show a => a -> String
    show Posn
    pos
            Just AttValue
    atv -> case Parser Char a -> String -> (Either String a, String)
    forall t a. Parser t a -> [t] -> (Either String a, [t])
    runParser Parser Char a
    forall a. SimpleType a => TextParser a
    acceptingParser (AttValue -> String
    attr2str AttValue
    atv) of
                            (Right a
    val, String
    "")   -> a -> XMLParser a
    forall a. a -> Parser (Content Posn) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return a
    val
                            (Right a
    val, String
    rest) -> String -> XMLParser a
    forall (p :: * -> *) a. PolyParse p => String -> p a
    failBad (String -> XMLParser a) -> String -> XMLParser a
    forall a b. (a -> b) -> a -> b
    $
                                                   String
    "Bad attribute value for "
                                                   String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    aname String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " in element <"
                                                   String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ QName -> String
    printableName QName
    t
                                                   String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ">:  got "String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++a -> String
    forall a. Show a => a -> String
    show a
    val
                                                   String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "\n but trailing text: "
                                                   String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    rest String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "\n at " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Posn -> String
    forall a. Show a => a -> String
    show Posn
    pos
                            (Left String
    err,  String
    rest) -> String -> XMLParser a
    forall (p :: * -> *) a. PolyParse p => String -> p a
    failBad (String -> XMLParser a) -> String -> XMLParser a
    forall a b. (a -> b) -> a -> b
    $ String
    err String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " in attribute "
                                                   String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    aname  String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " of element <"
                                                   String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ QName -> String
    printableName QName
    t
                                                   String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "> at " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Posn -> String
    forall a. Show a => a -> String
    show Posn
    pos
      where
        qnLookup :: String -> [(QName,a)] -> Maybe a
        qnLookup :: forall a. String -> [(QName, a)] -> Maybe a
    qnLookup String
    s = String -> [(String, a)] -> Maybe a
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    Prelude.lookup String
    s ([(String, a)] -> Maybe a)
    -> ([(QName, a)] -> [(String, a)]) -> [(QName, a)] -> Maybe a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ((QName, a) -> (String, a)) -> [(QName, a)] -> [(String, a)]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(QName
    qn,a
    v)-> (QName -> String
    printableName QName
    qn, a
    v))

    -- | The <xsd:any> type.  Parsing will always produce an "UnconvertedANY".
    data AnyElement = forall a . (SchemaType a, Show a) => ANYSchemaType a
                    | UnconvertedANY (Content Posn)

    instance Show AnyElement where
        show :: AnyElement -> String
    show (UnconvertedANY Content Posn
    c) = String
    "Unconverted "String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    forall a. Show a => a -> String
    show (Content Posn -> String
    forall a. Verbatim a => a -> String
    verbatim Content Posn
    c)
        show (ANYSchemaType a
    a)  = String
    "ANYSchemaType "String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++a -> String
    forall a. Show a => a -> String
    show a
    a
    instance Eq AnyElement where
        AnyElement
    a == :: AnyElement -> AnyElement -> Bool
    == AnyElement
    b  =  AnyElement -> String
    forall a. Show a => a -> String
    show AnyElement
    a String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    == AnyElement -> String
    forall a. Show a => a -> String
    show AnyElement
    b
    instance SchemaType AnyElement where
        parseSchemaType :: String -> XMLParser AnyElement
    parseSchemaType String
    _ = XMLParser AnyElement
    parseAnyElement
        schemaTypeToXML :: String -> AnyElement -> [Content ()]
    schemaTypeToXML String
    _ = AnyElement -> [Content ()]
    toXMLAnyElement

    parseAnyElement :: XMLParser AnyElement
    parseAnyElement :: XMLParser AnyElement
    parseAnyElement = (Content Posn -> AnyElement)
    -> Parser (Content Posn) (Content Posn) -> XMLParser AnyElement
    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 Content Posn -> AnyElement
    UnconvertedANY Parser (Content Posn) (Content Posn)
    forall t. Parser t t
    next

    -- | Parse the textual part of mixed content
    parseText :: XMLParser String
    parseText :: XMLParser String
    parseText = XMLParser String
    text  -- from XmlContent.Parser
                XMLParser String -> XMLParser String -> XMLParser String
    forall t a. Parser t a -> Parser t a -> Parser t a
    `onFail` String -> XMLParser String
    forall a. a -> Parser (Content Posn) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return String
    ""

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

    toXMLElement :: String -> [[Attribute]] -> [[Content ()]] -> [Content ()]
    toXMLElement :: String -> [[Attribute]] -> [[Content ()]] -> [Content ()]
    toXMLElement String
    name [[Attribute]]
    attrs [[Content ()]]
    content =
        [Element () -> () -> Content ()
    forall i. Element i -> i -> Content i
    CElem (QName -> [Attribute] -> [Content ()] -> Element ()
    forall i. QName -> [Attribute] -> [Content i] -> Element i
    Elem (String -> QName
    N String
    name) ([[Attribute]] -> [Attribute]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [[Attribute]]
    attrs) ([[Content ()]] -> [Content ()]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [[Content ()]]
    content)) ()]

    toXMLText :: String -> [Content ()]
    toXMLText :: String -> [Content ()]
    toXMLText String
    text =
        [Bool -> String -> () -> Content ()
    forall i. Bool -> String -> i -> Content i
    CString Bool
    False String
    text ()]

    toXMLAnyElement :: AnyElement -> [Content ()]
    toXMLAnyElement :: AnyElement -> [Content ()]
    toXMLAnyElement (UnconvertedANY Content Posn
    c) = [Content Posn -> Content ()
    forall (f :: * -> *) a. Functor f => f a -> f ()
    void Content Posn
    c]
    --toXMLAnyElement (ANYSchemaType x)  = [c]

    toXMLAttribute :: (SimpleType a) => String -> a -> [Attribute]
    toXMLAttribute :: forall a. SimpleType a => String -> a -> [Attribute]
    toXMLAttribute String
    name a
    val = [ (String -> QName
    N String
    name, [Either String Reference] -> AttValue
    AttValue [String -> Either String Reference
    forall a b. a -> Either a b
    Left (a -> String
    forall a. SimpleType a => a -> String
    simpleTypeText a
    val)]) ]

    -- | For a ComplexType that is an extension of a SimpleType, it is necessary to
    --   convert the value to XML first, then add in the extra attributes that
    --   constitute the extension.
    addXMLAttributes :: [[Attribute]] -> [Content ()] -> [Content ()]
    addXMLAttributes :: [[Attribute]] -> [Content ()] -> [Content ()]
    addXMLAttributes [[Attribute]]
    extra [CElem (Elem QName
    n [Attribute]
    attrs [Content ()]
    content) ()] =
                           [Element () -> () -> Content ()
    forall i. Element i -> i -> Content i
    CElem (QName -> [Attribute] -> [Content ()] -> Element ()
    forall i. QName -> [Attribute] -> [Content i] -> Element i
    Elem QName
    n ([Attribute]
    attrs[Attribute] -> [Attribute] -> [Attribute]
    forall a. [a] -> [a] -> [a]
    ++[[Attribute]] -> [Attribute]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [[Attribute]]
    extra) [Content ()]
    content) ()]
    addXMLAttributes [[Attribute]]
    _ [Content ()]
    x = [Content ()]
    x

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

    {- examples
       --------

    instance SchemaType FpMLSomething where
      parseSchemaType s = do (pos,e) <- posnElement [s]
                             commit $ do
                               a0 <- getAttribute "flirble" e pos
                               a1 <- getAttribute "binky" e pos
                               interior e $ do
                                 c0 <- parseSchemaType "foobar"
                                 c1 <- many $ parseSchemaType "quux"
                                 c2 <- optional $ parseSchemaType "doodad"
                                 c3 <- between (Occurs (Just 3) (Just 5))
                                                $ parseSchemaType "rinta"
                                 c4 <- fmap OneOf2 (parseSchemaType "left")
                                       `onFail`
                                       fmap TwoOf2 (parseSchemaType "right")
                                 return $ FpMLSomething a0 a1 c0 c1 c2 c3 c4
      schemaTypeToXML s x@FPMLSomething{} =
          toXMLElement s [ mkAttribute "flirble" (something_flirble x)
                         , mkAttribute "binky"   (something_binky x)
                         ]
              [             schemaTypeToXML "foobar"  (something_foobar x)
              , concatMap  (schemaTypeToXML "quux")   (something_quux x)
              , maybe []   (schemaTypeToXML "doodad") (something_doodad x)
              , concatMap  (schemaTypeToXML "rinta")  (something_rinta x)
              , foldOneOf2 (schemaTypeToXML "left")
                           (schemaTypeToXML "right")  (something_choice4 x)
              ]

    instance SimpleType FpMLNumber where
        acceptingParser = ...
        simpleTypeText  = ...
    -}

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

    -- Ensure that all primitive/simple types can also be used as elements.

    #define SchemaInstance(TYPE)  instance SchemaType TYPE where { parseSchemaType s = do { e <- element [s]; interior e parseSimpleType; }; schemaTypeToXML s x = toXMLElement s [] [toXMLText (simpleTypeText x)] }

    SchemaInstance(XsdString)
    SchemaInstance(Prim.Boolean)
    SchemaInstance(Prim.Base64Binary)
    SchemaInstance(Prim.HexBinary)
    SchemaInstance(Float)
    SchemaInstance(Decimal)
    SchemaInstance(Double)
    SchemaInstance(Prim.AnyURI)
    SchemaInstance(Prim.NOTATION)
    SchemaInstance(Prim.Duration)
    SchemaInstance(Prim.DateTime)
    SchemaInstance(Prim.Time)
    SchemaInstance(Prim.Date)
    SchemaInstance(Prim.GYearMonth)
    SchemaInstance(Prim.GYear)
    SchemaInstance(Prim.GMonthDay)
    SchemaInstance(Prim.GDay)
    SchemaInstance(Prim.GMonth)
    SchemaInstance(Prim.NormalizedString)
    SchemaInstance(Prim.Token)
    SchemaInstance(Prim.Language)
    SchemaInstance(Prim.Name)
    SchemaInstance(Prim.NCName)
    SchemaInstance(Prim.ID)
    SchemaInstance(Prim.IDREF)
    SchemaInstance(Prim.IDREFS)
    SchemaInstance(Prim.ENTITY)
    SchemaInstance(Prim.ENTITIES)
    SchemaInstance(Prim.NMTOKEN)
    SchemaInstance(Prim.NMTOKENS)
    SchemaInstance(Integer)
    SchemaInstance(Prim.NonPositiveInteger)
    SchemaInstance(Prim.NegativeInteger)
    SchemaInstance(Prim.Long)
    SchemaInstance(Int)
    SchemaInstance(Prim.Short)
    SchemaInstance(Prim.Byte)
    SchemaInstance(Prim.NonNegativeInteger)
    SchemaInstance(Prim.UnsignedLong)
    SchemaInstance(Prim.UnsignedInt)
    SchemaInstance(Prim.UnsignedShort)
    SchemaInstance(Prim.UnsignedByte)
    SchemaInstance(Prim.PositiveInteger)