{-# LANGUAGE PatternGuards #-}
module Text.XML.HaXml.Schema.Environment
( module Text.XML.HaXml.Schema.Environment
) where
import Text.XML.HaXml.Types (QName(..),Name(..),Namespace(..))
import Text.XML.HaXml.Schema.XSDTypeModel
import Text.XML.HaXml.Schema.NameConversion (wordsBy)
import Text.XML.HaXml.Schema.Parse (targetPrefix)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.List (foldl')
data Environment = Environment
{ Environment -> Map QName (Either SimpleType ComplexType)
env_type :: Map QName (Either SimpleType ComplexType)
, Environment -> Map QName (Either SimpleType ComplexType)
env_allTypes :: Map QName (Either SimpleType ComplexType)
, Environment -> Map QName ElementDecl
env_element :: Map QName ElementDecl
, Environment -> Map QName AttributeDecl
env_attribute :: Map QName AttributeDecl
, Environment -> Map QName Group
env_group :: Map QName Group
, Environment -> Map QName AttrGroup
env_attrgroup :: Map QName AttrGroup
, Environment -> Map String String
env_namespace :: Map String String
, Environment -> Map QName [(QName, String)]
env_extendty :: Map QName [(QName,FilePath)]
, Environment -> Map QName [(QName, String)]
env_substGrp :: Map QName [(QName,FilePath)]
, Environment -> Map QName String
env_typeloc :: Map QName FilePath
}
emptyEnv :: Environment
emptyEnv :: Environment
emptyEnv = Map QName (Either SimpleType ComplexType)
-> Map QName (Either SimpleType ComplexType)
-> Map QName ElementDecl
-> Map QName AttributeDecl
-> Map QName Group
-> Map QName AttrGroup
-> Map String String
-> Map QName [(QName, String)]
-> Map QName [(QName, String)]
-> Map QName String
-> Environment
Environment Map QName (Either SimpleType ComplexType)
forall k a. Map k a
Map.empty Map QName (Either SimpleType ComplexType)
forall k a. Map k a
Map.empty Map QName ElementDecl
forall k a. Map k a
Map.empty Map QName AttributeDecl
forall k a. Map k a
Map.empty Map QName Group
forall k a. Map k a
Map.empty
Map QName AttrGroup
forall k a. Map k a
Map.empty Map String String
forall k a. Map k a
Map.empty Map QName [(QName, String)]
forall k a. Map k a
Map.empty Map QName [(QName, String)]
forall k a. Map k a
Map.empty Map QName String
forall k a. Map k a
Map.empty
combineEnv :: Environment -> Environment -> Environment
combineEnv :: Environment -> Environment -> Environment
combineEnv Environment
e1 Environment
e0 = Environment :: Map QName (Either SimpleType ComplexType)
-> Map QName (Either SimpleType ComplexType)
-> Map QName ElementDecl
-> Map QName AttributeDecl
-> Map QName Group
-> Map QName AttrGroup
-> Map String String
-> Map QName [(QName, String)]
-> Map QName [(QName, String)]
-> Map QName String
-> Environment
Environment
{ env_type :: Map QName (Either SimpleType ComplexType)
env_type = Map QName (Either SimpleType ComplexType)
-> Map QName (Either SimpleType ComplexType)
-> Map QName (Either SimpleType ComplexType)
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (Environment -> Map QName (Either SimpleType ComplexType)
env_type Environment
e1) (Environment -> Map QName (Either SimpleType ComplexType)
env_type Environment
e0)
, env_allTypes :: Map QName (Either SimpleType ComplexType)
env_allTypes = Map QName (Either SimpleType ComplexType)
-> Map QName (Either SimpleType ComplexType)
-> Map QName (Either SimpleType ComplexType)
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (Environment -> Map QName (Either SimpleType ComplexType)
env_allTypes Environment
e1) (Environment -> Map QName (Either SimpleType ComplexType)
env_allTypes Environment
e0)
, env_element :: Map QName ElementDecl
env_element = Map QName ElementDecl
-> Map QName ElementDecl -> Map QName ElementDecl
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (Environment -> Map QName ElementDecl
env_element Environment
e1) (Environment -> Map QName ElementDecl
env_element Environment
e0)
, env_attribute :: Map QName AttributeDecl
env_attribute = Map QName AttributeDecl
-> Map QName AttributeDecl -> Map QName AttributeDecl
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (Environment -> Map QName AttributeDecl
env_attribute Environment
e1) (Environment -> Map QName AttributeDecl
env_attribute Environment
e0)
, env_group :: Map QName Group
env_group = Map QName Group -> Map QName Group -> Map QName Group
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (Environment -> Map QName Group
env_group Environment
e1) (Environment -> Map QName Group
env_group Environment
e0)
, env_attrgroup :: Map QName AttrGroup
env_attrgroup = Map QName AttrGroup -> Map QName AttrGroup -> Map QName AttrGroup
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (Environment -> Map QName AttrGroup
env_attrgroup Environment
e1) (Environment -> Map QName AttrGroup
env_attrgroup Environment
e0)
, env_namespace :: Map String String
env_namespace = Map String String -> Map String String -> Map String String
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (Environment -> Map String String
env_namespace Environment
e1) (Environment -> Map String String
env_namespace Environment
e0)
, env_extendty :: Map QName [(QName, String)]
env_extendty = ([(QName, String)] -> [(QName, String)] -> [(QName, String)])
-> Map QName [(QName, String)]
-> Map QName [(QName, String)]
-> Map QName [(QName, String)]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith [(QName, String)] -> [(QName, String)] -> [(QName, String)]
forall a. [a] -> [a] -> [a]
(++) (Environment -> Map QName [(QName, String)]
env_extendty Environment
e1) (Environment -> Map QName [(QName, String)]
env_extendty Environment
e0)
, env_substGrp :: Map QName [(QName, String)]
env_substGrp = ([(QName, String)] -> [(QName, String)] -> [(QName, String)])
-> Map QName [(QName, String)]
-> Map QName [(QName, String)]
-> Map QName [(QName, String)]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith [(QName, String)] -> [(QName, String)] -> [(QName, String)]
forall a. [a] -> [a] -> [a]
(++) (Environment -> Map QName [(QName, String)]
env_substGrp Environment
e1) (Environment -> Map QName [(QName, String)]
env_substGrp Environment
e0)
, env_typeloc :: Map QName String
env_typeloc = Map QName String -> Map QName String -> Map QName String
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (Environment -> Map QName String
env_typeloc Environment
e1) (Environment -> Map QName String
env_typeloc Environment
e0)
}
mkEnvironment :: FilePath -> Schema -> Environment -> Environment
mkEnvironment :: String -> Schema -> Environment -> Environment
mkEnvironment String
fp Schema
s Environment
init = (Environment -> SchemaItem -> Environment)
-> Environment -> [SchemaItem] -> Environment
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Environment -> SchemaItem -> Environment
item (Environment -> [Namespace] -> Environment
forall (t :: * -> *).
Foldable t =>
Environment -> t Namespace -> Environment
addNS Environment
init (Schema -> [Namespace]
schema_namespaces Schema
s))
(Schema -> [SchemaItem]
schema_items Schema
s)
where
item :: Environment -> SchemaItem -> Environment
item Environment
env (Include String
_ Annotation
_) = Environment
env
item Environment
env (Import String
_ String
_ Annotation
_) = Environment
env
item Environment
env (Redefine String
_ [SchemaItem]
_) = Environment
env
item Environment
env (Annotation Annotation
_) = Environment
env
item Environment
env (Simple SimpleType
st) = Environment -> SimpleType -> Environment
simple Environment
env SimpleType
st
item Environment
env (Complex ComplexType
ct) = Environment -> ComplexType -> Environment
complex Environment
env ComplexType
ct
item Environment
env (SchemaElement ElementDecl
e) = Environment -> ElementDecl -> Environment
elementDecl Environment
env ElementDecl
e
item Environment
env (SchemaAttribute AttributeDecl
a) = Environment -> AttributeDecl -> Environment
attributeDecl Environment
env AttributeDecl
a
item Environment
env (AttributeGroup AttrGroup
g) = Environment -> AttrGroup -> Environment
attrGroup Environment
env AttrGroup
g
item Environment
env (SchemaGroup Group
g) = Environment -> Group -> Environment
group Environment
env Group
g
simple :: Environment -> SimpleType -> Environment
simple Environment
env s :: SimpleType
s@(Restricted Annotation
_ (Just String
n) Maybe Final
_ Restriction
_)
= Environment
env{env_type :: Map QName (Either SimpleType ComplexType)
env_type=QName
-> Either SimpleType ComplexType
-> Map QName (Either SimpleType ComplexType)
-> Map QName (Either SimpleType ComplexType)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (String -> QName
mkN String
n) (SimpleType -> Either SimpleType ComplexType
forall a b. a -> Either a b
Left SimpleType
s)
(Environment -> Map QName (Either SimpleType ComplexType)
env_type Environment
env)}
simple Environment
env s :: SimpleType
s@(ListOf Annotation
_ (Just String
n) Maybe Final
_ Either SimpleType QName
_)
= Environment
env{env_type :: Map QName (Either SimpleType ComplexType)
env_type=QName
-> Either SimpleType ComplexType
-> Map QName (Either SimpleType ComplexType)
-> Map QName (Either SimpleType ComplexType)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (String -> QName
mkN String
n) (SimpleType -> Either SimpleType ComplexType
forall a b. a -> Either a b
Left SimpleType
s)
(Environment -> Map QName (Either SimpleType ComplexType)
env_type Environment
env)}
simple Environment
env s :: SimpleType
s@(UnionOf Annotation
_ (Just String
n) Maybe Final
_ [SimpleType]
_ [QName]
_)
= Environment
env{env_type :: Map QName (Either SimpleType ComplexType)
env_type=QName
-> Either SimpleType ComplexType
-> Map QName (Either SimpleType ComplexType)
-> Map QName (Either SimpleType ComplexType)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (String -> QName
mkN String
n) (SimpleType -> Either SimpleType ComplexType
forall a b. a -> Either a b
Left SimpleType
s)
(Environment -> Map QName (Either SimpleType ComplexType)
env_type Environment
env)}
simple Environment
env SimpleType
_ = Environment
env
complex :: Environment -> ComplexType -> Environment
complex Environment
env ComplexType
c
| Maybe String
Nothing <- ComplexType -> Maybe String
complex_name ComplexType
c = Environment
env
| Just String
n <- ComplexType -> Maybe String
complex_name ComplexType
c =
(Restriction1 -> Environment -> Environment)
-> (Extension -> Environment -> Environment)
-> Either Restriction1 Extension
-> Environment
-> Environment
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((Environment -> Environment)
-> Restriction1 -> Environment -> Environment
forall a b. a -> b -> a
const Environment -> Environment
forall a. a -> a
id)
(\Extension
extn Environment
env->
Environment
env{env_extendty :: Map QName [(QName, String)]
env_extendty = ([(QName, String)] -> [(QName, String)] -> [(QName, String)])
-> QName
-> [(QName, String)]
-> Map QName [(QName, String)]
-> Map QName [(QName, String)]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [(QName, String)] -> [(QName, String)] -> [(QName, String)]
forall a. [a] -> [a] -> [a]
(++)
(Extension -> QName
extension_base Extension
extn)
[(String -> QName
mkN String
n, String
fp)]
(Environment -> Map QName [(QName, String)]
env_extendty Environment
env)})
(ComplexItem -> Either Restriction1 Extension
isExtn (ComplexType -> ComplexItem
complex_content ComplexType
c))
(Environment -> Environment) -> Environment -> Environment
forall a b. (a -> b) -> a -> b
$ (if ComplexType -> Bool
complex_abstract ComplexType
c then \Environment
env->
Environment
env{env_extendty :: Map QName [(QName, String)]
env_extendty = ([(QName, String)] -> [(QName, String)] -> [(QName, String)])
-> QName
-> [(QName, String)]
-> Map QName [(QName, String)]
-> Map QName [(QName, String)]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [(QName, String)] -> [(QName, String)] -> [(QName, String)]
forall a. [a] -> [a] -> [a]
(++)
(String -> QName
mkN String
n)
[]
(Environment -> Map QName [(QName, String)]
env_extendty Environment
env)}
else Environment -> Environment
forall a. a -> a
id)
(Environment -> Environment) -> Environment -> Environment
forall a b. (a -> b) -> a -> b
$ Environment
env{env_type :: Map QName (Either SimpleType ComplexType)
env_type=QName
-> Either SimpleType ComplexType
-> Map QName (Either SimpleType ComplexType)
-> Map QName (Either SimpleType ComplexType)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (String -> QName
mkN String
n) (ComplexType -> Either SimpleType ComplexType
forall a b. b -> Either a b
Right ComplexType
c) (Environment -> Map QName (Either SimpleType ComplexType)
env_type Environment
env)
,env_typeloc :: Map QName String
env_typeloc=QName -> String -> Map QName String -> Map QName String
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (String -> QName
mkN String
n) String
fp (Environment -> Map QName String
env_typeloc Environment
env)}
where isExtn :: ComplexItem -> Either Restriction1 Extension
isExtn x :: ComplexItem
x@SimpleContent{} = ComplexItem -> Either Restriction1 Extension
ci_stuff ComplexItem
x
isExtn x :: ComplexItem
x@ComplexContent{} = ComplexItem -> Either Restriction1 Extension
ci_stuff ComplexItem
x
isExtn x :: ComplexItem
x@ThisType{} = Restriction1 -> Either Restriction1 Extension
forall a b. a -> Either a b
Left Restriction1
forall a. HasCallStack => a
undefined
elementDecl :: Environment -> ElementDecl -> Environment
elementDecl Environment
env ElementDecl
e
| Right QName
r <- ElementDecl -> Either NameAndType QName
elem_nameOrRef ElementDecl
e = Environment
env
| Left NameAndType
nt <- ElementDecl -> Either NameAndType QName
elem_nameOrRef ElementDecl
e =
(Environment -> Environment)
-> (QName -> Environment -> Environment)
-> Maybe QName
-> Environment
-> Environment
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Environment -> Environment
forall a. a -> a
id (\QName
sg Environment
env-> Environment
env{env_substGrp :: Map QName [(QName, String)]
env_substGrp=([(QName, String)] -> [(QName, String)] -> [(QName, String)])
-> QName
-> [(QName, String)]
-> Map QName [(QName, String)]
-> Map QName [(QName, String)]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [(QName, String)] -> [(QName, String)] -> [(QName, String)]
forall a. [a] -> [a] -> [a]
(++) QName
sg
[(String -> QName
mkN (String -> QName) -> String -> QName
forall a b. (a -> b) -> a -> b
$ NameAndType -> String
theName NameAndType
nt, String
fp)]
(Environment -> Map QName [(QName, String)]
env_substGrp Environment
env)})
(ElementDecl -> Maybe QName
elem_substGroup ElementDecl
e)
(Environment -> Environment) -> Environment -> Environment
forall a b. (a -> b) -> a -> b
$ Environment
env{env_element :: Map QName ElementDecl
env_element=QName
-> ElementDecl -> Map QName ElementDecl -> Map QName ElementDecl
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (String -> QName
mkN (String -> QName) -> String -> QName
forall a b. (a -> b) -> a -> b
$ NameAndType -> String
theName NameAndType
nt) ElementDecl
e
(Environment -> Map QName ElementDecl
env_element Environment
env)
,env_typeloc :: Map QName String
env_typeloc=QName -> String -> Map QName String -> Map QName String
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (String -> QName
mkN (String -> QName) -> String -> QName
forall a b. (a -> b) -> a -> b
$ NameAndType -> String
theName NameAndType
nt) String
fp
(Environment -> Map QName String
env_typeloc Environment
env)}
attributeDecl :: Environment -> AttributeDecl -> Environment
attributeDecl Environment
env AttributeDecl
a
| Right QName
r <- AttributeDecl -> Either NameAndType QName
attr_nameOrRef AttributeDecl
a = Environment
env
| Left NameAndType
nt <- AttributeDecl -> Either NameAndType QName
attr_nameOrRef AttributeDecl
a = Environment
env{env_attribute :: Map QName AttributeDecl
env_attribute=
QName
-> AttributeDecl
-> Map QName AttributeDecl
-> Map QName AttributeDecl
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (String -> QName
mkN (String -> QName) -> String -> QName
forall a b. (a -> b) -> a -> b
$ NameAndType -> String
theName NameAndType
nt) AttributeDecl
a
(Environment -> Map QName AttributeDecl
env_attribute Environment
env)}
attrGroup :: Environment -> AttrGroup -> Environment
attrGroup Environment
env AttrGroup
g
| Right QName
r <- AttrGroup -> Either String QName
attrgroup_nameOrRef AttrGroup
g = Environment
env
| Left String
n <- AttrGroup -> Either String QName
attrgroup_nameOrRef AttrGroup
g = Environment
env{env_attrgroup :: Map QName AttrGroup
env_attrgroup=QName -> AttrGroup -> Map QName AttrGroup -> Map QName AttrGroup
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert
(String -> QName
mkN String
n) AttrGroup
g
(Environment -> Map QName AttrGroup
env_attrgroup Environment
env)}
group :: Environment -> Group -> Environment
group Environment
env Group
g
| Right QName
r <- Group -> Either String QName
group_nameOrRef Group
g = Environment
env
| Left String
n <- Group -> Either String QName
group_nameOrRef Group
g = Environment
env{env_group :: Map QName Group
env_group=QName -> Group -> Map QName Group -> Map QName Group
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (String -> QName
mkN String
n) Group
g
(Environment -> Map QName Group
env_group Environment
env)}
mkN :: String -> QName
mkN = String -> QName
N (String -> QName) -> (String -> String) -> String -> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall a. [a] -> a
last ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> [String]
forall a. (a -> Bool) -> [a] -> [[a]]
wordsBy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
':')
addNS :: Environment -> t Namespace -> Environment
addNS Environment
env t Namespace
nss = Environment
env{env_namespace :: Map String String
env_namespace = (Namespace -> Map String String -> Map String String)
-> Map String String -> t Namespace -> Map String String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Namespace -> Map String String -> Map String String
newNS (Environment -> Map String String
env_namespace Environment
env) t Namespace
nss}
where newNS :: Namespace -> Map String String -> Map String String
newNS Namespace
ns Map String String
env = String -> String -> Map String String -> Map String String
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Namespace -> String
nsURI Namespace
ns) (Namespace -> String
nsPrefix Namespace
ns) Map String String
env
gatherImports :: Schema -> [(FilePath, Maybe String)]
gatherImports :: Schema -> [(String, Maybe String)]
gatherImports Schema
s =
[ (String
f,Maybe String
forall a. Maybe a
Nothing) | (Include String
f Annotation
_) <- Schema -> [SchemaItem]
schema_items Schema
s ] [(String, Maybe String)]
-> [(String, Maybe String)] -> [(String, Maybe String)]
forall a. [a] -> [a] -> [a]
++
[ (String
f,Maybe String
ns) | (Import String
uri String
f Annotation
_) <- Schema -> [SchemaItem]
schema_items Schema
s
, let ns :: Maybe String
ns = Maybe String -> [Namespace] -> Maybe String
targetPrefix (String -> Maybe String
forall a. a -> Maybe a
Just String
uri) (Schema -> [Namespace]
schema_namespaces Schema
s) ]