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

-- Some things we probably want to do.
-- * Build Maps from :
--       typename        to definition
--       element name    to definition
--       attribute name  to definition
--       (element) group to definition
--       attribute group to definition
--       abstract complextype to its extension types
--       substitution group to its substitutable elements
--       abstract/substGroup to defining module
-- * XSD types become top-level types in Haskell.
-- * XSD element decls also become top-level types in Haskell.
-- * Element groups get their own Haskell types too.
-- * Attributes and attribute groups do not become types, they are
--   simply constituent parts of an element.
-- * Resolve element/attribute references by inlining their names.

-- If a complextype definition includes nested in-line decls of other
-- types, we need to be able to lift them out to the top-level, then
-- refer to them by name only at the nested position(?)

-- When dealing with sub/supertype relationships, we often need to know all
-- of the subtypes of a supertype before some of the subtypes are actually
-- available in scope.  The environment must therefore first be closed
-- over all modules: the resulting type mapping (env_type) should be _copied_
-- across to (env_allTypes) in a fresh initial environment, which latter is
-- then used to rebuild the local scope from scratch.
-- Likewise, the mappings from supertype->subtype (env_extendty) and for
-- substitution groups (env_substGrp) also need to be global.

data Environment =  Environment
    { Environment -> Map QName (Either SimpleType ComplexType)
env_type      :: Map QName (Either SimpleType ComplexType)
                                 -- ^ type definitions in scope
    , Environment -> Map QName (Either SimpleType ComplexType)
env_allTypes  :: Map QName (Either SimpleType ComplexType)
                                 -- ^ all type definitions, regardless of scope
    , 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{-URI-} String{-Prefix-}
    , Environment -> Map QName [(QName, String)]
env_extendty  :: Map QName [(QName,FilePath)] -- ^ supertype -> subtypes
    , Environment -> Map QName [(QName, String)]
env_substGrp  :: Map QName [(QName,FilePath)] -- ^ substitution groups
    , Environment -> Map QName String
env_typeloc   :: Map QName FilePath           -- ^ where type is defined
    }

-- | An empty environment of XSD type mappings.
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 forall k a. Map k a
Map.empty forall k a. Map k a
Map.empty forall k a. Map k a
Map.empty forall k a. Map k a
Map.empty forall k a. Map k a
Map.empty
                       forall k a. Map k a
Map.empty forall k a. Map k a
Map.empty forall k a. Map k a
Map.empty forall k a. Map k a
Map.empty forall k a. Map k a
Map.empty

-- | Combine two environments (e.g. read from different interface files)
combineEnv :: Environment -> Environment -> Environment
combineEnv :: Environment -> Environment -> Environment
combineEnv Environment
e1 Environment
e0 = Environment
    { env_type :: Map QName (Either SimpleType ComplexType)
env_type      = 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  = 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   = 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 = 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     = 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 = 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 = 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  = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith 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  = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith 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   = 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)
    }

-- | Build an environment of XSD type mappings from a schema module.
mkEnvironment :: FilePath -> Schema -> Environment -> Environment
mkEnvironment :: String -> Schema -> Environment -> Environment
mkEnvironment String
fp Schema
s Environment
init = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Environment -> SchemaItem -> Environment
item (forall {t :: * -> *}.
Foldable t =>
Environment -> t Namespace -> Environment
addNS Environment
init (Schema -> [Namespace]
schema_namespaces Schema
s))
                                      (Schema -> [SchemaItem]
schema_items Schema
s)
  where
    -- think about qualification, w.r.t targetNamespace, elementFormDefault, etc
    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  -- revisit this
    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=forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (String -> QName
mkN String
n) (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=forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (String -> QName
mkN String
n) (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=forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (String -> QName
mkN String
n) (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

    -- Only toplevel names have global scope.
    -- Should we lift local names to toplevel with prefixed names?
    -- Or thread the environment explicitly through every tree-walker?
    -- Or resolve every reference to its referent in a single resolution pass?
    -- (Latter not good, because it potentially duplicates exprs?)
    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 =
              forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. a -> a
id)
                     (\Extension
extn Environment
env->
                        Environment
env{env_extendty :: Map QName [(QName, String)]
env_extendty = forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith 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))
              forall a b. (a -> b) -> a -> b
$ (if ComplexType -> Bool
complex_abstract ComplexType
c then \Environment
env->
              -- because an abstract type might have no concrete instantiations!
                        Environment
env{env_extendty :: Map QName [(QName, String)]
env_extendty = forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith forall a. [a] -> [a] -> [a]
(++)
                                               (String -> QName
mkN String
n)
                                               []
                                               (Environment -> Map QName [(QName, String)]
env_extendty Environment
env)}
                 else forall a. a -> a
id)
              forall a b. (a -> b) -> a -> b
$ Environment
env{env_type :: Map QName (Either SimpleType ComplexType)
env_type=forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (String -> QName
mkN String
n) (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=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{}       = forall a b. a -> Either a b
Left forall a. HasCallStack => a
undefined
{-
      | Nothing <- complex_name c = env
      | Right extn <- isExtn $ complex_content c
      , Just n  <- complex_name c = env{env_extendty =
                                            Map.insertWith (++)
                                                (extension_base extn)
                                                [(mkN n, isFwd)]
                                                (env_extendty env)
                                       ,env_type=Map.insert (mkN n) (Right c)
                                                            (env_type env)}
      | Just n  <- complex_name c = env{env_type=Map.insert (mkN n) (Right c)
                                                            (env_type env)}
          where isExtn x@SimpleContent{}  = ci_stuff x
                isExtn x@ComplexContent{} = ci_stuff x
                isExtn x@ThisType{}       = Left undefined
                isFwd = case Map.lookup (extension_base extn) (env_typeloc env) of
                          Nothing  -> error $ "unknown supertype of "++show c
                          Just mod -> mod /= fp
-}
    elementDecl :: Environment -> ElementDecl -> Environment
elementDecl Environment
env ElementDecl
e
      | Right QName
r <- ElementDecl -> Either NameAndType QName
elem_nameOrRef ElementDecl
e = Environment
env
--    | Just sg <- elem_substGroup e
--    , Left nt <- elem_nameOrRef e = env{env_substGrp=Map.insertWith (++) sg
--                                                [(mkN $ theName nt, isFwd sg)]
--                                                        (env_substGrp env)
--                                       ,env_element=Map.insert
--                                                        (mkN $ theName nt) e
--                                                        (env_element env)}
      | Left NameAndType
nt <- ElementDecl -> Either NameAndType QName
elem_nameOrRef ElementDecl
e =
              forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (\QName
sg Environment
env-> Environment
env{env_substGrp :: Map QName [(QName, String)]
env_substGrp=forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith forall a. [a] -> [a] -> [a]
(++) QName
sg
                                          [(String -> QName
mkN 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)
              forall a b. (a -> b) -> a -> b
$ Environment
env{env_element :: Map QName ElementDecl
env_element=forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (String -> QName
mkN 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=forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (String -> QName
mkN 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=
                                            forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (String -> QName
mkN 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=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=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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
last forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [[a]]
wordsBy (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 = 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 = 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

-- | Find all direct module dependencies.
gatherImports :: Schema -> [(FilePath, Maybe String)]
gatherImports :: Schema -> [(String, Maybe String)]
gatherImports Schema
s =
    [ (String
f,forall a. Maybe a
Nothing)  | (Include String
f Annotation
_)    <- Schema -> [SchemaItem]
schema_items Schema
s ] 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 (forall a. a -> Maybe a
Just String
uri) (Schema -> [Namespace]
schema_namespaces Schema
s) ]