{-# 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) ]