{-# 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 :: XMLParser t
parseSimpleType = do String
s <- XMLParser String
text
                     case Parser Char t -> String -> (Either String t, String)
forall t a. Parser t a -> [t] -> (Either String a, [t])
runParser Parser Char t
forall a. SimpleType a => TextParser a
acceptingParser String
s of
                       (Left String
err, String
_) -> String -> XMLParser t
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
                       (Right t
v, String
"") -> t -> XMLParser t
forall (m :: * -> *) a. Monad m => a -> m a
return t
v
                       (Right t
v, String
_)  -> t -> XMLParser t
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 :: Occurs -> p a -> p [a]
between (Occurs Maybe Int
Nothing  Maybe Int
Nothing)  p a
p = (a -> [a]) -> p a -> p [a]
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 (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 (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 (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 :: 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 (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 (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 :: 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 (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 (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 :: 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)