    {-# 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
        }
        deriving (Int -> Environment -> ShowS
    [Environment] -> ShowS
    Environment -> String
    (Int -> Environment -> ShowS)
    -> (Environment -> String)
    -> ([Environment] -> ShowS)
    -> Show Environment
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> Environment -> ShowS
    showsPrec :: Int -> Environment -> ShowS
    $cshow :: Environment -> String
    show :: Environment -> String
    $cshowList :: [Environment] -> ShowS
    showList :: [Environment] -> ShowS
    Show, Environment -> Environment -> Bool
    (Environment -> Environment -> Bool)
    -> (Environment -> Environment -> Bool) -> Eq Environment
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: Environment -> Environment -> Bool
    == :: Environment -> Environment -> Bool
    $c/= :: Environment -> Environment -> Bool
    /= :: Environment -> Environment -> Bool
    Eq)

    -- | 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 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

    -- | 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      = 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)
        }

    -- | 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 = (Environment -> SchemaItem -> Environment)
    -> Environment -> [SchemaItem] -> Environment
    forall b a. (b -> a -> b) -> b -> [a] -> b
    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
        -- 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.insert (mkN n) (Left s)
                                                               (env_type env)}
        simple Environment
    env s :: SimpleType
    s@(ListOf Annotation
    _ (Just String
    n) Maybe Final
    _ Either SimpleType QName
    _)
                                     = Environment
    env{env_type=Map.insert (mkN n) (Left s)
                                                               (env_type env)}
        simple Environment
    env s :: SimpleType
    s@(UnionOf Annotation
    _ (Just String
    n) Maybe Final
    _ [SimpleType]
    _ [QName]
    _)
                                     = Environment
    env{env_type=Map.insert (mkN n) (Left s)
                                                               (env_type 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 =
                  (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.insertWith (++)
                                                   (extension_base extn)
                                                   [(mkN n, fp)]
                                                   (env_extendty 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->
                  -- because an abstract type might have no concrete instantiations!
                            Environment
    env{env_extendty = Map.insertWith (++)
                                                   (mkN n)
                                                   []
                                                   (env_extendty 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.insert (mkN n) (Right c) (env_type env)
                       ,env_typeloc=Map.insert (mkN n) fp (env_typeloc 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
    {-
          | 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 =
                  (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.insertWith (++) sg
                                              [(mkN $ theName nt, fp)]
                                              (env_substGrp env)})
                        (ElementDecl -> Maybe QName
    elem_substGroup ElementDecl
    e)
                  (Environment -> Environment) -> Environment -> Environment
    forall a b. (a -> b) -> a -> b
    $ Environment
    env{env_element=Map.insert (mkN $ theName nt) e
                                               (env_element env)
                       ,env_typeloc=Map.insert (mkN $ theName nt) fp
                                               (env_typeloc 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.insert (mkN $ theName nt) a
                                                           (env_attribute 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.insert
                                                               (mkN n) g
                                                               (env_attrgroup 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.insert (mkN n) g
                                                               (env_group env)}
        mkN :: String -> QName
    mkN = String -> QName
    N (String -> QName) -> ShowS -> String -> QName
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [String] -> String
    forall a. HasCallStack => [a] -> a
    last ([String] -> String) -> (String -> [String]) -> ShowS
    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 = foldr newNS (env_namespace env) 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

    -- | Find all direct module dependencies.
    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) ]