{-# LANGUAGE CPP, MultiParamTypeClasses, 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 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
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 err :: String
err, _) -> String -> XMLParser t
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
(Right v :: t
v, "") -> t -> XMLParser t
forall (m :: * -> *) a. Monad m => a -> m a
return t
v
(Right v :: t
v, _) -> 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 Nothing Nothing) p :: 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 i :: Int
i) Nothing) p :: 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 Nothing (Just j :: Int
j)) p :: 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 i :: Int
i) (Just j :: Int
j)) p :: 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 aname :: String
aname (Elem t :: QName
t as :: [Attribute]
as _) pos :: Posn
pos =
case String -> [Attribute] -> Maybe AttValue
forall a. String -> [(QName, a)] -> Maybe a
qnLookup String
aname [Attribute]
as of
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
$ "attribute missing: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
aname
String -> String -> String
forall a. [a] -> [a] -> [a]
++ " in element <" String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
printableName QName
t
String -> String -> String
forall a. [a] -> [a] -> [a]
++ "> at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Posn -> String
forall a. Show a => a -> String
show Posn
pos
Just atv :: 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 val :: a
val, "") -> a -> XMLParser a
forall (m :: * -> *) a. Monad m => a -> m a
return a
val
(Right val :: a
val, rest :: 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
$
"Bad attribute value for "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
aname String -> String -> String
forall a. [a] -> [a] -> [a]
++ " in element <"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
printableName QName
t
String -> String -> String
forall a. [a] -> [a] -> [a]
++ ">: 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]
++ "\n but trailing text: "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rest String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Posn -> String
forall a. Show a => a -> String
show Posn
pos
(Left err :: String
err, rest :: 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]
++ " in attribute "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
aname String -> String -> String
forall a. [a] -> [a] -> [a]
++ " of element <"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
printableName QName
t
String -> String -> String
forall a. [a] -> [a] -> [a]
++ "> 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 s :: 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 (\(qn :: QName
qn,v :: 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 c :: Content Posn
c) = "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
a) = "ANYSchemaType "String -> String -> String
forall a. [a] -> [a] -> [a]
++a -> String
forall a. Show a => a -> String
show a
a
instance Eq AnyElement where
a :: AnyElement
a == :: AnyElement -> AnyElement -> Bool
== b :: 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 _ = XMLParser AnyElement
parseAnyElement
schemaTypeToXML :: String -> AnyElement -> [Content ()]
schemaTypeToXML _ = 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 ""
toXMLElement :: String -> [[Attribute]] -> [[Content ()]] -> [Content ()]
toXMLElement :: String -> [[Attribute]] -> [[Content ()]] -> [Content ()]
toXMLElement name :: String
name attrs :: [[Attribute]]
attrs content :: [[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 text :: 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 c :: Content Posn
c) = [(Posn -> ()) -> Content Posn -> Content ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> Posn -> ()
forall a b. a -> b -> a
const ()) Content Posn
c]
toXMLAttribute :: (SimpleType a) => String -> a -> [Attribute]
toXMLAttribute :: String -> a -> [Attribute]
toXMLAttribute name :: String
name val :: 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 extra :: [[Attribute]]
extra [CElem (Elem n :: QName
n attrs :: [Attribute]
attrs content :: [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 _ x :: [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)