{-# LANGUAGE CPP, FunctionalDependencies,
TypeSynonymInstances, ExistentialQuantification #-}
module Text.XML.HaXml.Schema.Schema
( SchemaType(..)
, SimpleType(..)
, Extension(..)
, Restricts(..)
, FwdDecl(..)
, getAttribute
, between
, Occurs(..)
, parseSimpleType
, parseText
, AnyElement(..)
, parseAnyElement
, Content(..)
, XMLParser(..)
, posnElement
, posnElementWith
, element
, interior
, text
, module Text.ParserCombinators.Poly
, module Text.Parse
, 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
class SchemaType a where
parseSchemaType :: String -> XMLParser a
schemaTypeToXML :: String -> a -> [Content ()]
class Extension t s where
supertype :: t -> s
class Restricts t s | t -> s where
restricts :: t -> s
class FwdDecl fd a | fd -> a
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
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
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))
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
parseText :: XMLParser String
parseText :: XMLParser String
parseText = 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 (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]
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)]) ]
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
#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)