{-# LANGUAGE PatternGuards #-}
module Text.XML.HaXml.Schema.TypeConversion
  ( module Text.XML.HaXml.Schema.TypeConversion
  ) where

import Text.XML.HaXml.Types (QName(..),Name(..),Namespace(..))
import Text.XML.HaXml.Namespaces (printableName,localName)
import Text.XML.HaXml.Schema.Environment
import Text.XML.HaXml.Schema.XSDTypeModel     as XSD
import Text.XML.HaXml.Schema.HaskellTypeModel as Haskell
import Text.XML.HaXml.Schema.NameConversion
import Text.XML.HaXml.Schema.Parse (xsd)

import qualified Data.Map as Map
import Data.Semigroup (Semigroup (..))
import Data.Map (Map)
import Data.List (foldl')
import Data.Maybe (fromMaybe,fromJust,isNothing,isJust)
import Data.Monoid (Monoid (..))

-- | Transform a Schema by lifting all locally-defined anonymous types to
--   the top-level, naming them, and planting a referend at their original
--   location.
typeLift :: Schema -> Schema
typeLift :: Schema -> Schema
typeLift Schema
s = Schema
s{ schema_items :: [SchemaItem]
schema_items =
                    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ ElementDecl -> [SchemaItem]
hoist ElementDecl
e | SchemaElement ElementDecl
e <- Schema -> [SchemaItem]
schema_items Schema
s ]
                    forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map SchemaItem -> SchemaItem
renameLocals (Schema -> [SchemaItem]
schema_items Schema
s) }
  where
    hoist :: ElementDecl -> [SchemaItem]
    hoist :: ElementDecl -> [SchemaItem]
hoist ElementDecl
e = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ElementDecl -> [ElementDecl]
findE ElementDecl
e) forall a b. (a -> b) -> a -> b
$
              \e :: ElementDecl
e@ElementDecl{elem_nameOrRef :: ElementDecl -> Either NameAndType QName
elem_nameOrRef=Left (NT{ theName :: NameAndType -> String
theName=String
n
                                                  {-, theType=Nothing-}})}->
                  String -> Maybe (Either SimpleType ComplexType) -> [SchemaItem]
localType String
n (ElementDecl -> Maybe (Either SimpleType ComplexType)
elem_content ElementDecl
e)

    findE :: ElementDecl -> [ElementDecl]
    findE :: ElementDecl -> [ElementDecl]
findE ElementDecl
e = ( case ElementDecl -> Either NameAndType QName
elem_nameOrRef ElementDecl
e of
                  Left (NT{theType :: NameAndType -> Maybe QName
theType=Maybe QName
Nothing}) -> (ElementDecl
eforall a. a -> [a] -> [a]
:)
                  Left (NT{theType :: NameAndType -> Maybe QName
theType=Just QName
t})  -> case ElementDecl -> Maybe (Either SimpleType ComplexType)
elem_content ElementDecl
e of
                                                  Just (Right
                                                    (ComplexType
                                                       {complex_name :: ComplexType -> Maybe String
complex_name=Just String
t'}))
                                                 {--| t==t'-}
                                                    -> (ElementDecl
eforall a. a -> [a] -> [a]
:)
                                                  Maybe (Either SimpleType ComplexType)
_ -> forall a. a -> a
id
                  Either NameAndType QName
_                          -> forall a. a -> a
id
              )
              ( case ElementDecl -> Maybe (Either SimpleType ComplexType)
elem_content ElementDecl
e of
                  Maybe (Either SimpleType ComplexType)
Nothing        -> []
                  Just (Left  SimpleType
_) -> []
                  Just (Right ComplexType
c) ->
                    case ComplexType -> ComplexItem
complex_content ComplexType
c of
                      v :: ComplexItem
v@SimpleContent{ci_stuff :: ComplexItem -> Either Restriction1 Extension
ci_stuff=Left (Restriction1 Particle
p)} -> Particle -> [ElementDecl]
particle Particle
p
                      v :: ComplexItem
v@SimpleContent{ci_stuff :: ComplexItem -> Either Restriction1 Extension
ci_stuff=Right (Extension{extension_newstuff :: Extension -> ParticleAttrs
extension_newstuff=PA Particle
p [Either AttributeDecl AttrGroup]
_ Maybe AnyAttr
_})} -> Particle -> [ElementDecl]
particle Particle
p
                      v :: ComplexItem
v@ComplexContent{ci_stuff :: ComplexItem -> Either Restriction1 Extension
ci_stuff=Left (Restriction1 Particle
p)} -> Particle -> [ElementDecl]
particle Particle
p
                      v :: ComplexItem
v@ComplexContent{ci_stuff :: ComplexItem -> Either Restriction1 Extension
ci_stuff=Right (Extension{extension_newstuff :: Extension -> ParticleAttrs
extension_newstuff=PA Particle
p [Either AttributeDecl AttrGroup]
_ Maybe AnyAttr
_})} -> Particle -> [ElementDecl]
particle Particle
p
                      v :: ComplexItem
v@ThisType{ci_thistype :: ComplexItem -> ParticleAttrs
ci_thistype=PA Particle
p [Either AttributeDecl AttrGroup]
_ Maybe AnyAttr
_} -> Particle -> [ElementDecl]
particle Particle
p
              )
    particle :: Particle -> [ElementDecl]
particle Particle
Nothing = []
    particle (Just (Left ChoiceOrSeq
cos)) = ChoiceOrSeq -> [ElementDecl]
choiceOrSeq ChoiceOrSeq
cos
    particle (Just (Right Group
g))  = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ChoiceOrSeq -> [ElementDecl]
choiceOrSeq forall a b. (a -> b) -> a -> b
$ Group -> Maybe ChoiceOrSeq
group_stuff Group
g
    choiceOrSeq :: ChoiceOrSeq -> [ElementDecl]
choiceOrSeq (XSD.All Annotation
_ [ElementDecl]
es)        = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ElementDecl -> [ElementDecl]
findE [ElementDecl]
es
    choiceOrSeq (XSD.Choice   Annotation
_ Occurs
_ [ElementEtc]
es) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ElementEtc -> [ElementDecl]
etc [ElementEtc]
es
    choiceOrSeq (XSD.Sequence Annotation
_ Occurs
_ [ElementEtc]
es) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ElementEtc -> [ElementDecl]
etc [ElementEtc]
es
    etc :: ElementEtc -> [ElementDecl]
etc (HasElement ElementDecl
e) = ElementDecl -> [ElementDecl]
findE ElementDecl
e
    etc (HasGroup Group
g)   = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ChoiceOrSeq -> [ElementDecl]
choiceOrSeq forall a b. (a -> b) -> a -> b
$ Group -> Maybe ChoiceOrSeq
group_stuff Group
g
    etc (HasCS ChoiceOrSeq
cos)    = ChoiceOrSeq -> [ElementDecl]
choiceOrSeq ChoiceOrSeq
cos
    etc (HasAny Any
_)     = []

    localType :: String -> Maybe (Either SimpleType ComplexType) -> [SchemaItem]
localType String
n Maybe (Either SimpleType ComplexType)
Nothing          = []
    localType String
n (Just (Left SimpleType
s))  = [SimpleType -> SchemaItem
Simple  (String -> SimpleType -> SimpleType
renameSimple String
n SimpleType
s)]
    localType String
n (Just (Right ComplexType
c)) = [ComplexType -> SchemaItem
Complex ComplexType
c{ complex_name :: Maybe String
complex_name = forall a. a -> Maybe a
Just String
n }]

    renameSimple :: String -> SimpleType -> SimpleType
renameSimple String
n s :: SimpleType
s@Primitive{}  = SimpleType
s
    renameSimple String
n s :: SimpleType
s@Restricted{} = SimpleType
s{ simple_name :: Maybe String
simple_name  = forall a. a -> Maybe a
Just String
n }
    renameSimple String
n s :: SimpleType
s@ListOf{}     = SimpleType
s{ simple_name :: Maybe String
simple_name  = forall a. a -> Maybe a
Just String
n }
    renameSimple String
n s :: SimpleType
s@UnionOf{}    = SimpleType
s{ simple_name :: Maybe String
simple_name  = forall a. a -> Maybe a
Just String
n }


    -- * For now, rather than walk the tree, giving typenames to nodes that were
    --   previously locally-typed, we will instead assume in the pretty-printer
    --   that it can always replace a missing typename with the element name, and
    --   have it resolve to something sensible.
    renameLocals :: SchemaItem -> SchemaItem
    renameLocals :: SchemaItem -> SchemaItem
renameLocals SchemaItem
s = SchemaItem
s
--  renameLocals (SchemaElement e)
--                 | Left (NT{theName=n,theType=Nothing}) <- elem_nameOrRef e
--                 = SchemaElement e{ elem_nameOrRef = Left (NT{theName=n
--                                                             ,theType=Just n})
--                                  }
--            -- still gotta do the recursive search + rename


-- | Given an environment of schema type mappings, and a schema module,
--   create a bunch of Decls that describe the types in a more
--   Haskell-friendly way.
convert :: Environment -> Schema -> [Haskell.Decl]
convert :: Environment -> Schema -> [Decl]
convert Environment
env Schema
s = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SchemaItem -> [Decl]
item (Schema -> [SchemaItem]
schema_items Schema
s)
  where
    item :: SchemaItem -> [Decl]
item (Include String
loc Annotation
ann)    = [XName -> Maybe String -> Decl
XSDInclude (String -> XName
xname String
loc) (Annotation -> Maybe String
comment Annotation
ann)]
    item (Import String
uri String
loc Annotation
ann) = [XName -> Maybe XName -> Maybe String -> Decl
XSDImport  (String -> XName
xname String
loc)
                                            (String -> XName
xname forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                             forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
uri (Environment -> Map String String
env_namespace Environment
env))
                                            (Annotation -> Maybe String
comment Annotation
ann)]
    item (Redefine String
_ [SchemaItem]
_)       = [] -- ignoring redefinitions for now
    item (Annotation Annotation
ann)     = [Maybe String -> Decl
XSDComment (Annotation -> Maybe String
comment Annotation
ann)]
    item (Simple SimpleType
st)          = SimpleType -> [Decl]
simple SimpleType
st
    item (Complex ComplexType
ct)         = ComplexType -> [Decl]
complex ComplexType
ct
    item (SchemaElement ElementDecl
ed)   = ElementDecl -> [Decl]
topElementDecl ElementDecl
ed
    item (SchemaAttribute AttributeDecl
ad) = [] -- attributeDecl ad
    item (AttributeGroup AttrGroup
ag)  = [] -- attrgroup ag
    item (SchemaGroup Group
g)      = Group -> [Decl]
group Group
g

    simple :: SimpleType -> [Decl]
simple (Primitive PrimitiveType
prim)     = []
    simple s :: SimpleType
s@(Restricted Annotation
a Maybe String
n Maybe Final
f Restriction
r)
        | (Just [(XName, Maybe String)]
enums) <- SimpleType -> Maybe [(XName, Maybe String)]
isEnumeration SimpleType
s
                                = [XName -> [(XName, Maybe String)] -> Maybe String -> Decl
EnumSimpleType
                                       (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => String -> a
error String
"missing Name") String -> XName
xname Maybe String
n)
                                       [(XName, Maybe String)]
enums (Annotation -> Maybe String
comment Annotation
a) ]
        | Bool
otherwise             = [XName -> XName -> [Restrict] -> Maybe String -> Decl
RestrictSimpleType
                                       (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => String -> a
error String
"missing Name") String -> XName
xname Maybe String
n)
                                       (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> XName
xname String
"unknownSimple") QName -> XName
XName
                                                             (Restriction -> Maybe QName
restrict_base Restriction
r))
                                       (Restriction -> [Restrict]
mkRestrict Restriction
r)
                                       (Annotation -> Maybe String
comment Annotation
a)]
    simple (ListOf Annotation
a Maybe String
n Maybe Final
f Either SimpleType QName
t)     = forall a. HasCallStack => String -> a
error String
"Not yet implemented: ListOf simpleType"
                              --  [NamedSimpleType    (xname n) (nameOfSimple s)
                              --                      (comment a)]
    simple s :: SimpleType
s@(UnionOf Annotation
a Maybe String
n Maybe Final
f [SimpleType]
u [QName]
m)
        | (Just [(XName, Maybe String)]
enums) <- SimpleType -> Maybe [(XName, Maybe String)]
isEnumeration SimpleType
s
                                = [XName -> [(XName, Maybe String)] -> Maybe String -> Decl
EnumSimpleType
                                       (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => String -> a
error String
"missing Name") String -> XName
xname Maybe String
n)
                                       [(XName, Maybe String)]
enums (Annotation -> Maybe String
comment Annotation
a) ]
        | Bool
otherwise             = [XName -> [XName] -> Maybe String -> Decl
UnionSimpleTypes
                                       (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => String -> a
error String
"missing Name") String -> XName
xname Maybe String
n)
                                       (forall a b. (a -> b) -> [a] -> [b]
map (String -> XName
xname forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> String
printableName) [QName]
m) -- XXX ignores content 'u'
                                       (Annotation -> Maybe String
comment Annotation
a)]

    isEnumeration :: SimpleType -> Maybe [(XName,Comment)]
    isEnumeration :: SimpleType -> Maybe [(XName, Maybe String)]
isEnumeration (Primitive PrimitiveType
_)        = forall a. Maybe a
Nothing
    isEnumeration (ListOf Annotation
_ Maybe String
_ Maybe Final
_ Either SimpleType QName
_)     = forall a. Maybe a
Nothing
    isEnumeration (Restricted Annotation
_ Maybe String
_ Maybe Final
_ Restriction
r) =
        case Restriction
r of
            RestrictSim1 Annotation
ann Maybe QName
base Restriction1
r1  -> forall a. Maybe a
Nothing
            RestrictType Annotation
_ Maybe QName
_ Maybe SimpleType
_ [Facet]
facets ->
                let enum :: [(XName, Maybe String)]
enum = [ (String -> XName
xname String
v, Annotation -> Maybe String
comment Annotation
ann)
                           | (Facet FacetType
UnorderedEnumeration Annotation
ann String
v Bool
_) <- [Facet]
facets ]
                in if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(XName, Maybe String)]
enum then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just [(XName, Maybe String)]
enum
    isEnumeration (UnionOf Annotation
_ Maybe String
_ Maybe Final
_ [SimpleType]
u [QName]
ms) =
        forall {a}. [a] -> [Maybe [a]] -> Maybe [a]
squeeze [] ( forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map [QName]
ms (\QName
m-> case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QName
m (Environment -> Map QName (Either SimpleType ComplexType)
env_type Environment
env) of
                                         Just (Left SimpleType
s)-> SimpleType -> Maybe [(XName, Maybe String)]
isEnumeration SimpleType
s
                                         Maybe (Either SimpleType ComplexType)
_            -> forall a. Maybe a
Nothing)
                     forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map SimpleType -> Maybe [(XName, Maybe String)]
isEnumeration [SimpleType]
u )
        where squeeze :: [a] -> [Maybe [a]] -> Maybe [a]
squeeze [a]
_  (Maybe [a]
Nothing:[Maybe [a]]
_)    = forall a. Maybe a
Nothing
              squeeze [a]
xs (Just [a]
ys:[Maybe [a]]
rest) = [a] -> [Maybe [a]] -> Maybe [a]
squeeze ([a]
xsforall a. [a] -> [a] -> [a]
++[a]
ys) [Maybe [a]]
rest
              squeeze [a]
xs []             = forall a. a -> Maybe a
Just [a]
xs

    complex :: ComplexType -> [Decl]
complex ComplexType
ct =
      let nx :: QName
nx  = String -> QName
N forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe String
"errorMissingName" (ComplexType -> Maybe String
complex_name ComplexType
ct)
          n :: XName
n   = QName -> XName
XName QName
nx
      in forall a. a -> [a]
singleton forall a b. (a -> b) -> a -> b
$
      case ComplexType -> ComplexItem
complex_content ComplexType
ct of
        c :: ComplexItem
c@SimpleContent{}  ->
            case ComplexItem -> Either Restriction1 Extension
ci_stuff ComplexItem
c of
                Left Restriction1
r  ->
                    XName -> XName -> [Restrict] -> Maybe String -> Decl
RestrictSimpleType XName
n ({-simple-}String -> XName
xname String
"Unimplemented") []
                                     (Annotation -> Maybe String
comment (ComplexType -> Annotation
complex_annotation ComplexType
ct
                                              forall a. Monoid a => a -> a -> a
`mappend` ComplexItem -> Annotation
ci_annotation ComplexItem
c))
                Right Extension
e ->
                    XName -> XName -> [Attribute] -> Maybe String -> Decl
ExtendSimpleType XName
n
                                     ({-supertype-}QName -> XName
XName forall a b. (a -> b) -> a -> b
$ Extension -> QName
extension_base Extension
e)
                                     ({-attrs-}forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$
                                      ParticleAttrs -> ([Element], [Attribute])
particleAttrs forall a b. (a -> b) -> a -> b
$ Extension -> ParticleAttrs
extension_newstuff Extension
e)
                                     (Annotation -> Maybe String
comment (ComplexType -> Annotation
complex_annotation ComplexType
ct
                                              forall a. Monoid a => a -> a -> a
`mappend` ComplexItem -> Annotation
ci_annotation ComplexItem
c
                                              forall a. Monoid a => a -> a -> a
`mappend` Extension -> Annotation
extension_annotation Extension
e))
        c :: ComplexItem
c@ComplexContent{} ->
            case ComplexItem -> Either Restriction1 Extension
ci_stuff ComplexItem
c of
                Left Restriction1
r  ->
                    XName -> XName -> Maybe String -> Decl
RestrictComplexType XName
n ({-complex-}String -> XName
xname String
"Can'tBeRight")
                                     (Annotation -> Maybe String
comment (ComplexType -> Annotation
complex_annotation ComplexType
ct
                                              forall a. Monoid a => a -> a -> a
`mappend` ComplexItem -> Annotation
ci_annotation ComplexItem
c))
                Right Extension
e ->
                    let myLoc :: String
myLoc  = forall a. a -> Maybe a -> a
fromMaybe String
"NUL" (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QName
nx
                                                             (Environment -> Map QName String
env_typeloc Environment
env))
                        supLoc :: String
supLoc = forall a. a -> Maybe a -> a
fromMaybe String
"NUL" (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Extension -> QName
extension_base Extension
e)
                                                             (Environment -> Map QName String
env_typeloc Environment
env))
                    in
                    if ComplexType -> Bool
complex_abstract ComplexType
ct then
                        XName
-> XName
-> [(XName, Maybe XName)]
-> Maybe XName
-> [XName]
-> Maybe String
-> Decl
ExtendComplexTypeAbstract XName
n
                             ({-supertype-}QName -> XName
XName forall a b. (a -> b) -> a -> b
$ Extension -> QName
extension_base Extension
e)
                             ({-subtypes-}
                              forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => String -> a
error (String
"ExtendComplexTypeAbstract "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show QName
nx))
                                    (forall a b. (a -> b) -> [a] -> [b]
map (\(QName
t,String
l)->(QName -> XName
XName QName
t,if String
lforall a. Eq a => a -> a -> Bool
/=String
myLoc
                                                           then forall a. a -> Maybe a
Just (String -> XName
xname String
l)
                                                           else forall a. Maybe a
Nothing)))
                                    (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QName
nx (Environment -> Map QName [(QName, String)]
env_extendty Environment
env)))
                             ({-fwddecl-}if String
myLocforall a. Eq a => a -> a -> Bool
/=String
supLoc
                                         then forall a. a -> Maybe a
Just (String -> XName
xname String
supLoc) else forall a. Maybe a
Nothing)
                             ({-grandsupers-}
                              forall a b. (a -> b) -> [a] -> [b]
map QName -> XName
XName forall a b. (a -> b) -> a -> b
$ forall a. (a -> Maybe a) -> a -> [a]
repeatedly (Environment -> QName -> Maybe QName
supertypeOf Environment
env) QName
nx)
                             (Annotation -> Maybe String
comment (ComplexType -> Annotation
complex_annotation ComplexType
ct
                                      forall a. Monoid a => a -> a -> a
`mappend` ComplexItem -> Annotation
ci_annotation ComplexItem
c
                                      forall a. Monoid a => a -> a -> a
`mappend` Extension -> Annotation
extension_annotation Extension
e))
                    else
                    let ([Element]
es,[Attribute]
as) = ParticleAttrs -> ([Element], [Attribute])
particleAttrs (Extension -> ParticleAttrs
extension_newstuff Extension
e)
                        es' :: [Element]
es'     | ComplexItem -> Bool
ci_mixed ComplexItem
c = [Element] -> [Element]
mkMixedContent [Element]
es
                                | Bool
otherwise  = [Element]
es
                        ([Element]
oldEs,[Attribute]
oldAs) = Maybe (Either SimpleType ComplexType) -> ([Element], [Attribute])
contentInfo forall a b. (a -> b) -> a -> b
$
                                            forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Extension -> QName
extension_base Extension
e)
                                                       (Environment -> Map QName (Either SimpleType ComplexType)
env_type Environment
env)
                    in
                    XName
-> XName
-> [Element]
-> [Attribute]
-> [Element]
-> [Attribute]
-> Maybe XName
-> Bool
-> [XName]
-> Maybe String
-> Decl
ExtendComplexType XName
n
                        ({-supertype-}QName -> XName
XName forall a b. (a -> b) -> a -> b
$ Extension -> QName
extension_base Extension
e)
                        {-supertype elems-}[Element]
oldEs
                        {-supertype attrs-}[Attribute]
oldAs
                        {-elems-}[Element]
es
                        {-attrs-}[Attribute]
as
                        ({-fwddecl-}if String
myLocforall a. Eq a => a -> a -> Bool
/=String
supLoc then forall a. a -> Maybe a
Just (String -> XName
xname String
supLoc)
                                                     else forall a. Maybe a
Nothing)
                        ({-abstract supertype-}
                         forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const Bool
False) ComplexType -> Bool
complex_abstract)
                                     (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Extension -> QName
extension_base Extension
e)
                                                 (Environment -> Map QName (Either SimpleType ComplexType)
env_type Environment
env)))
                        ({-grandsupers-}
                         forall a b. (a -> b) -> [a] -> [b]
map QName -> XName
XName forall a b. (a -> b) -> a -> b
$ forall a. (a -> Maybe a) -> a -> [a]
repeatedly (Environment -> QName -> Maybe QName
supertypeOf Environment
env)
                                   forall a b. (a -> b) -> a -> b
$ Extension -> QName
extension_base Extension
e)
                        (Annotation -> Maybe String
comment (ComplexType -> Annotation
complex_annotation ComplexType
ct
                                 forall a. Monoid a => a -> a -> a
`mappend` ComplexItem -> Annotation
ci_annotation ComplexItem
c
                                 forall a. Monoid a => a -> a -> a
`mappend` Extension -> Annotation
extension_annotation Extension
e))
        c :: ComplexItem
c@ThisType{} | ComplexType -> Bool
complex_abstract ComplexType
ct ->
            let myLoc :: String
myLoc  = forall a. a -> Maybe a -> a
fromMaybe String
"NUL"
                         (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QName
nx (Environment -> Map QName String
env_typeloc Environment
env)) in
            XName -> [(XName, Maybe XName)] -> Maybe String -> Decl
ElementsAttrsAbstract XName
n
                          {-all instance types: -}
                          (case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QName
nx (Environment -> Map QName [(QName, String)]
env_extendty Environment
env) of
                             Maybe [(QName, String)]
Nothing -> []
                             Just [(QName, String)]
xs -> forall a b. (a -> b) -> [a] -> [b]
map (\ (QName
x,String
loc)->(QName -> XName
XName QName
x,if String
locforall a. Eq a => a -> a -> Bool
/=String
myLoc
                                                          then forall a. a -> Maybe a
Just (String -> XName
xname String
loc)
                                                          else forall a. Maybe a
Nothing)) [(QName, String)]
xs
                          )
                          (Annotation -> Maybe String
comment (ComplexType -> Annotation
complex_annotation ComplexType
ct))
        c :: ComplexItem
c@ThisType{} | Bool
otherwise ->
            let ([Element]
es,[Attribute]
as) = ParticleAttrs -> ([Element], [Attribute])
particleAttrs (ComplexItem -> ParticleAttrs
ci_thistype ComplexItem
c)
                es' :: [Element]
es'     | ComplexType -> Bool
complex_mixed ComplexType
ct = [Element] -> [Element]
mkMixedContent [Element]
es
                        | Bool
otherwise        = [Element]
es
            in
            XName -> [Element] -> [Attribute] -> Maybe String -> Decl
ElementsAttrs XName
n [Element]
es' [Attribute]
as (Annotation -> Maybe String
comment (ComplexType -> Annotation
complex_annotation ComplexType
ct))

    mkMixedContent :: [Element] -> [Element]
mkMixedContent [e :: Element
e@OneOf{}] = [Element
e{ elem_oneOf :: [[Element]]
elem_oneOf = [Element
Text]forall a. a -> [a] -> [a]
: Element -> [[Element]]
elem_oneOf Element
e }]
    mkMixedContent [Element]
es          = Element
Textforall a. a -> [a] -> [a]
: forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Element
e->[Element
e,Element
Text]) [Element]
es

    topElementDecl :: XSD.ElementDecl -> [Haskell.Decl]
    topElementDecl :: ElementDecl -> [Decl]
topElementDecl ElementDecl
ed = case ElementDecl -> Either NameAndType QName
elem_nameOrRef ElementDecl
ed of
        Left  NameAndType
n   -> case NameAndType -> Maybe QName
theType NameAndType
n of
                       Maybe QName
Nothing ->
                       --error "Not implemented: contentInfo on topElementDecl"
                       --I'm pretty sure a topElementDecl can't be abstract...
                         let ([Element]
es,[Attribute]
as) = Maybe (Either SimpleType ComplexType) -> ([Element], [Attribute])
contentInfo (ElementDecl -> Maybe (Either SimpleType ComplexType)
elem_content ElementDecl
ed) in
                         [ XName -> [Element] -> [Attribute] -> Maybe String -> Decl
ElementsAttrs ({-name-}String -> XName
xname forall a b. (a -> b) -> a -> b
$ NameAndType -> String
theName NameAndType
n)
                                         {-elems-}[Element]
es
                                         {-attrs-}[Attribute]
as
                                         (Annotation -> Maybe String
comment (ElementDecl -> Annotation
elem_annotation ElementDecl
ed))
                         , Element -> Decl
ElementOfType forall a b. (a -> b) -> a -> b
$ ElementDecl -> Element
elementDecl ElementDecl
ed
                           --  Element{ elem_name = xname (theName n)
                           --         , elem_type = checkXName s (N $ theName n)
                           --         , elem_modifier =
                           --                 occursToModifier (elem_occurs ed)
                           --         , elem_byRef   = False
                           --         , elem_locals  = []
                           --         , elem_substs  = Nothing
                           --         , elem_comment =
                           --                     (comment (elem_annotation ed))
                           --         }
                         ]
                       Just QName
t | ElementDecl -> Bool
elem_abstract ElementDecl
ed ->
                         let nm :: QName
nm     = String -> QName
N forall a b. (a -> b) -> a -> b
$ NameAndType -> String
theName NameAndType
n
                             myLoc :: String
myLoc  = forall a. a -> Maybe a -> a
fromMaybe String
"NUL"
                                          (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QName
nm (Environment -> Map QName String
env_typeloc Environment
env)) in
                         forall a. a -> [a]
singleton forall a b. (a -> b) -> a -> b
$
                         XName -> XName -> [(XName, Maybe XName)] -> Maybe String -> Decl
ElementAbstractOfType
                                 (QName -> XName
XName QName
nm)
                                 (Schema -> QName -> XName
checkXName Schema
s QName
t)
                                 (case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QName
nm (Environment -> Map QName [(QName, String)]
env_substGrp Environment
env) of
                                    Maybe [(QName, String)]
Nothing -> []
                                    Just [(QName, String)]
xs ->
                                      forall a b. (a -> b) -> [a] -> [b]
map (\ (QName
x,String
loc)->(QName -> XName
XName QName
x,
                                                       if String
locforall a. Eq a => a -> a -> Bool
/=String
myLoc
                                                       then forall a. a -> Maybe a
Just (String -> XName
xname String
loc)
                                                       else forall a. Maybe a
Nothing)) [(QName, String)]
xs)
                                 (Annotation -> Maybe String
comment (ElementDecl -> Annotation
elem_annotation ElementDecl
ed))
                       Just QName
t | Bool
otherwise ->
                         forall a. a -> [a]
singleton forall a b. (a -> b) -> a -> b
$ Element -> Decl
ElementOfType forall a b. (a -> b) -> a -> b
$ ElementDecl -> Element
elementDecl ElementDecl
ed
                     --  Element{ elem_name    = xname $ theName n
                     --         , elem_type    = checkXName s t
                     --         , elem_modifier=
                     --                       occursToModifier (elem_occurs ed)
                     --         , elem_byRef   = False
                     --         , elem_locals  = []
                     --         , elem_substs  = Nothing
                     --         , elem_comment = comment (elem_annotation ed)
                     --         }
        Right QName
ref -> case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QName
ref (Environment -> Map QName ElementDecl
env_element Environment
env) of
           Maybe ElementDecl
Nothing -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"<topElementDecl> unknown element reference "
                            forall a. [a] -> [a] -> [a]
++QName -> String
printableName QName
ref
           Just ElementDecl
e' -> ElementDecl -> [Decl]
topElementDecl ElementDecl
e'

    elementDecl :: XSD.ElementDecl -> Haskell.Element
    elementDecl :: ElementDecl -> Element
elementDecl ElementDecl
ed = case ElementDecl -> Either NameAndType QName
elem_nameOrRef ElementDecl
ed of
        Left  NameAndType
n   -> Element { elem_name :: XName
elem_name     = String -> XName
xname forall a b. (a -> b) -> a -> b
$ NameAndType -> String
theName NameAndType
n
                             , elem_type :: XName
elem_type     = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ElementDecl -> XName
localTypeExp ElementDecl
ed)
                                                     (Schema -> QName -> XName
checkXName Schema
s)
                                                     (NameAndType -> Maybe QName
theType NameAndType
n)
                             , elem_modifier :: Modifier
elem_modifier = Occurs -> Modifier
occursToModifier forall a b. (a -> b) -> a -> b
$ ElementDecl -> Occurs
elem_occurs ElementDecl
ed
                             , elem_byRef :: Bool
elem_byRef    = Bool
False   -- by reference
                             , elem_locals :: [Decl]
elem_locals   = []      -- internal Decl
                             , elem_substs :: Maybe [XName]
elem_substs   = forall a. Maybe a
Nothing -- substitution group
                         --  , elem_substs   = if elem_abstract ed
                         --                    then fmap (map XName) $
                         --                         Map.lookup (N $ theName n)
                         --                                (env_substGrp env)
                         --                    else Nothing
                             , elem_comment :: Maybe String
elem_comment  = Annotation -> Maybe String
comment forall a b. (a -> b) -> a -> b
$ ElementDecl -> Annotation
elem_annotation ElementDecl
ed
                             }
        Right QName
ref -> case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QName
ref (Environment -> Map QName ElementDecl
env_element Environment
env) of
                       Just ElementDecl
e' -> (ElementDecl -> Element
elementDecl ElementDecl
e')
                                      { elem_modifier :: Modifier
elem_modifier =
                                              Occurs -> Modifier
occursToModifier (ElementDecl -> Occurs
elem_occurs ElementDecl
ed)
                                      , elem_byRef :: Bool
elem_byRef = Bool
True }
                       Maybe ElementDecl
Nothing -> -- possible ref is imported qualified?
                           case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (String -> QName
N forall a b. (a -> b) -> a -> b
$ QName -> String
localName QName
ref)
                                           (Environment -> Map QName ElementDecl
env_element Environment
env) of
                               Just ElementDecl
e' -> (ElementDecl -> Element
elementDecl ElementDecl
e')
                                            { elem_modifier :: Modifier
elem_modifier =
                                               Occurs -> Modifier
occursToModifier (ElementDecl -> Occurs
elem_occurs ElementDecl
ed)
                                            , elem_byRef :: Bool
elem_byRef = Bool
True }
                               Maybe ElementDecl
Nothing -> XName
-> XName
-> Modifier
-> Bool
-> [Decl]
-> Maybe [XName]
-> Maybe String
-> Element
Element ({-name-}QName -> XName
XName QName
ref)
                                              -- best guess at type
                                              ({-type-}QName -> XName
XName QName
ref)
                                              (Occurs -> Modifier
occursToModifier (ElementDecl -> Occurs
elem_occurs ElementDecl
ed))
                                              Bool
True [] forall a. Maybe a
Nothing forall a. Maybe a
Nothing

    localTypeExp :: XSD.ElementDecl -> XName
    localTypeExp :: ElementDecl -> XName
localTypeExp ElementDecl
ed | forall a. Maybe a -> Bool
isJust (ElementDecl -> Maybe (Either SimpleType ComplexType)
elem_content ElementDecl
ed) =
                          case forall a. HasCallStack => Maybe a -> a
fromJust (ElementDecl -> Maybe (Either SimpleType ComplexType)
elem_content ElementDecl
ed) of
                            Left st :: SimpleType
st@Primitive{}   -> String -> XName
xname String
"SomethingPrimitive"
                            Left st :: SimpleType
st@Restricted{}  -> (\XName
x-> forall b a. b -> (a -> b) -> Maybe a -> b
maybe XName
x String -> XName
xname
                                                          (SimpleType -> Maybe String
simple_name SimpleType
st)) forall a b. (a -> b) -> a -> b
$
                                                     forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> XName
xname String
"GiveUp")
                                                           QName -> XName
XName
                                                      (Restriction -> Maybe QName
restrict_base forall a b. (a -> b) -> a -> b
$
                                                       SimpleType -> Restriction
simple_restriction SimpleType
st)
                            Left st :: SimpleType
st@ListOf{}      -> String -> XName
xname String
"SomethingListy"
                            Left st :: SimpleType
st@UnionOf{}     -> String -> XName
xname String
"SomethingUnionLike"
                            Right c :: ComplexType
c@ComplexType{} -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ElementDecl -> XName
localTypeExp ElementDecl
ed{elem_content :: Maybe (Either SimpleType ComplexType)
elem_content=forall a. Maybe a
Nothing})
                                                           String -> XName
xname
                                                     forall a b. (a -> b) -> a -> b
$ ComplexType -> Maybe String
complex_name ComplexType
c
                    | Bool
otherwise =
                          case ElementDecl -> Either NameAndType QName
elem_nameOrRef ElementDecl
ed of
                            Left NameAndType
n  -> String -> XName
xname forall a b. (a -> b) -> a -> b
$ NameAndType -> String
theName NameAndType
n
                            Right QName
_ -> String -> XName
xname String
"unknownElement"

    attributeDecl :: XSD.AttributeDecl -> [Haskell.Attribute]
    attributeDecl :: AttributeDecl -> [Attribute]
attributeDecl AttributeDecl
ad = case AttributeDecl -> Either NameAndType QName
attr_nameOrRef AttributeDecl
ad of
        Left  NameAndType
n   -> forall a. a -> [a]
singleton forall a b. (a -> b) -> a -> b
$
                     XName -> XName -> Bool -> Maybe String -> Attribute
Attribute (String -> XName
xname forall a b. (a -> b) -> a -> b
$ NameAndType -> String
theName NameAndType
n)
                               (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> XName
xname String
"String")
                                           -- guess at an attribute typename?
                                           --(error "XSD.attributeDecl->")
                                             SimpleType -> XName
nameOfSimple
                                             (AttributeDecl -> Maybe SimpleType
attr_simpleType AttributeDecl
ad))
                                      QName -> XName
XName
                                      (NameAndType -> Maybe QName
theType NameAndType
n))
                               (AttributeDecl -> Use
attr_use AttributeDecl
ad forall a. Eq a => a -> a -> Bool
== Use
Required)
                               (Annotation -> Maybe String
comment  (AttributeDecl -> Annotation
attr_annotation AttributeDecl
ad))
        Right QName
ref -> case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QName
ref (Environment -> Map QName AttributeDecl
env_attribute Environment
env) of
                       Maybe AttributeDecl
Nothing -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"<attributeDecl> unknown attribute reference "
                                          forall a. [a] -> [a] -> [a]
++QName -> String
printableName QName
ref
                       Just AttributeDecl
a' -> AttributeDecl -> [Attribute]
attributeDecl AttributeDecl
a'

    attrgroup :: XSD.AttrGroup -> [Haskell.Attribute]
    attrgroup :: AttrGroup -> [Attribute]
attrgroup AttrGroup
g = case AttrGroup -> Either String QName
attrgroup_nameOrRef AttrGroup
g of
        Left  String
n   -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either AttributeDecl -> [Attribute]
attributeDecl AttrGroup -> [Attribute]
attrgroup)
                               (AttrGroup -> [Either AttributeDecl AttrGroup]
attrgroup_stuff AttrGroup
g)
        Right QName
ref -> case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QName
ref (Environment -> Map QName AttrGroup
env_attrgroup Environment
env) of
                       Maybe AttrGroup
Nothing -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"unknown attribute group reference "
                                          forall a. [a] -> [a] -> [a]
++QName -> String
printableName QName
ref
                       Just AttrGroup
g' -> AttrGroup -> [Attribute]
attrgroup AttrGroup
g'

    group :: XSD.Group -> [Haskell.Decl]
    group :: Group -> [Decl]
group Group
g = case Group -> Either String QName
group_nameOrRef Group
g of
        Left  String
n   -> let {-highs,-}es :: [Element]
es = ChoiceOrSeq -> [Element]
choiceOrSeq (forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"XSD.group")
                                                             (Group -> Maybe ChoiceOrSeq
group_stuff Group
g))
                     in {-highs ++-} forall a. a -> [a]
singleton forall a b. (a -> b) -> a -> b
$
                           XName -> [Element] -> Maybe String -> Decl
Haskell.Group (String -> XName
xname String
n)
                                         (forall a b. (a -> b) -> [a] -> [b]
map (\Element
e->Element
e{elem_modifier :: Modifier
elem_modifier=
                                                         Occurs -> Modifier -> Modifier
combineOccursModifier
                                                             (Group -> Occurs
group_occurs Group
g)
                                                             (Element -> Modifier
elem_modifier Element
e)})
                                              [Element]
es)
                                         (Annotation -> Maybe String
comment (Group -> Annotation
group_annotation Group
g))
        Right QName
ref -> case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QName
ref (Environment -> Map QName Group
env_group Environment
env) of
                  --   Nothing -> error $ "bad group reference "
                  --                      ++printableName ref
                       Maybe Group
Nothing -> forall a. a -> [a]
singleton forall a b. (a -> b) -> a -> b
$
                                  XName -> [Element] -> Maybe String -> Decl
Haskell.Group (String -> XName
xname (String
"unknown-group-"forall a. [a] -> [a] -> [a]
++QName -> String
printableName QName
ref)) []
                                                (Annotation -> Maybe String
comment (Group -> Annotation
group_annotation Group
g))
                       Just Group
g' -> Group -> [Decl]
group Group
g'{ group_occurs :: Occurs
group_occurs=Group -> Occurs
group_occurs Group
g }

    particleAttrs :: ParticleAttrs -> ([Haskell.Element],[Haskell.Attribute])
    particleAttrs :: ParticleAttrs -> ([Element], [Attribute])
particleAttrs (PA Particle
part [Either AttributeDecl AttrGroup]
attrs Maybe AnyAttr
_) = -- ignoring AnyAttr for now
        (Particle -> [Element]
particle Particle
part, forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either AttributeDecl -> [Attribute]
attributeDecl AttrGroup -> [Attribute]
attrgroup) [Either AttributeDecl AttrGroup]
attrs)

    particle :: Particle -> [Haskell.Element] -- XXX fix to ret Decls
    particle :: Particle -> [Element]
particle Particle
Nothing          = []
    particle (Just (Left ChoiceOrSeq
cs)) = {-snd $-} ChoiceOrSeq -> [Element]
choiceOrSeq ChoiceOrSeq
cs
    particle (Just (Right Group
g)) = let [Haskell.Group XName
_ [Element]
es Maybe String
_] = Group -> [Decl]
group Group
g in [Element]
es

--  choiceOrSeq :: ChoiceOrSeq -> ([Haskell.Decl],[Haskell.Element])
    choiceOrSeq :: ChoiceOrSeq -> [Haskell.Element]
    choiceOrSeq :: ChoiceOrSeq -> [Element]
choiceOrSeq (XSD.All      Annotation
ann [ElementDecl]
eds)   = forall a. HasCallStack => String -> a
error String
"not yet implemented: XSD.All"
    choiceOrSeq (XSD.Choice   Annotation
ann Occurs
o [ElementEtc]
ees) = [ [[Element]] -> Modifier -> Maybe String -> Element
OneOf ([[Element]] -> [[Element]]
anyToEnd
                                                     (forall a b. (a -> b) -> [a] -> [b]
map ElementEtc -> [Element]
elementEtc [ElementEtc]
ees))
                                                   (Occurs -> Modifier
occursToModifier Occurs
o)
                                                   (Annotation -> Maybe String
comment Annotation
ann) ]
    choiceOrSeq (XSD.Sequence Annotation
ann Occurs
_ [ElementEtc]
ees) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ElementEtc -> [Element]
elementEtc [ElementEtc]
ees

    elementEtc :: ElementEtc -> [Haskell.Element]
    elementEtc :: ElementEtc -> [Element]
elementEtc (HasElement ElementDecl
ed) = [ElementDecl -> Element
elementDecl ElementDecl
ed]
    elementEtc (HasGroup Group
g)    = let [Haskell.Group XName
_ [Element]
es Maybe String
_] = Group -> [Decl]
group Group
g in [Element]
es
    elementEtc (HasCS ChoiceOrSeq
cs)      = ChoiceOrSeq -> [Element]
choiceOrSeq ChoiceOrSeq
cs
    elementEtc (HasAny Any
a)      = Any -> [Element]
any Any
a

    any :: XSD.Any -> [Haskell.Element]
    any :: Any -> [Element]
any a :: Any
a@XSD.Any{}  = [Haskell.AnyElem
                           { elem_modifier :: Modifier
elem_modifier = Occurs -> Modifier
occursToModifier (Any -> Occurs
any_occurs Any
a)
                           , elem_comment :: Maybe String
elem_comment  = Annotation -> Maybe String
comment (Any -> Annotation
any_annotation Any
a) }]

    -- If an ANY element is part of a choice, ensure it is the last part.
    anyToEnd :: [[Haskell.Element]] -> [[Haskell.Element]]
    anyToEnd :: [[Element]] -> [[Element]]
anyToEnd = Maybe [Element] -> [[Element]] -> [[Element]]
go forall a. Maybe a
Nothing
      where go :: Maybe [Element] -> [[Element]] -> [[Element]]
go Maybe [Element]
_ [e :: [Element]
e@[AnyElem{}]] = [[Element]
e]
            go Maybe [Element]
_ (e :: [Element]
e@[AnyElem{}]:[[Element]]
es) = Maybe [Element] -> [[Element]] -> [[Element]]
go (forall a. a -> Maybe a
Just [Element]
e) [[Element]]
es
            go Maybe [Element]
Nothing  []        = []
            go (Just [Element]
e) []        = [[Element]
e]
            go Maybe [Element]
m ([Element]
e:[[Element]]
es)           = [Element]
eforall a. a -> [a] -> [a]
:Maybe [Element] -> [[Element]] -> [[Element]]
go Maybe [Element]
m [[Element]]
es

    contentInfo :: Maybe (Either SimpleType ComplexType)
                   -> ([Haskell.Element],[Haskell.Attribute])
    contentInfo :: Maybe (Either SimpleType ComplexType) -> ([Element], [Attribute])
contentInfo Maybe (Either SimpleType ComplexType)
Nothing  = ([],[])
    contentInfo (Just Either SimpleType ComplexType
e) = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SimpleType -> ([Element], [Attribute])
simple ComplexType -> ([Element], [Attribute])
complex Either SimpleType ComplexType
e
      where
        simple  :: SimpleType  -> ([Element],[Attribute])
        complex :: ComplexType -> ([Element],[Attribute])
        simple :: SimpleType -> ([Element], [Attribute])
simple SimpleType
_         = ([], [])  -- XXX clearly wrong
     -- simple (Primitive p)        = ([], [])  -- XXX clearly wrong
     -- simple (Restricted n _ _ _) =
        complex :: ComplexType -> ([Element], [Attribute])
complex ComplexType
ct = case ComplexType -> ComplexItem
complex_content ComplexType
ct of
                       SimpleContent{}     -> ([],[]) -- XXX clearly wrong
                       ci :: ComplexItem
ci@ComplexContent{} -> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Restriction1 -> ([Element], [Attribute])
restr Extension -> ([Element], [Attribute])
exten (ComplexItem -> Either Restriction1 Extension
ci_stuff ComplexItem
ci)
                       ThisType ParticleAttrs
pa         -> ParticleAttrs -> ([Element], [Attribute])
particleAttrs ParticleAttrs
pa
        restr :: Restriction1 -> ([Element],[Attribute])
        exten :: Extension    -> ([Element],[Attribute])
        restr :: Restriction1 -> ([Element], [Attribute])
restr (Restriction1 Particle
p)  = (Particle -> [Element]
particle Particle
p,[])
        exten :: Extension -> ([Element], [Attribute])
exten Extension
e = let ([Element]
oes,[Attribute]
oas) = Maybe (Either SimpleType ComplexType) -> ([Element], [Attribute])
contentInfo (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Extension -> QName
extension_base Extension
e)
                                                          (Environment -> Map QName (Either SimpleType ComplexType)
env_type Environment
env))
                      ([Element]
nes,[Attribute]
nas) = ParticleAttrs -> ([Element], [Attribute])
particleAttrs (Extension -> ParticleAttrs
extension_newstuff Extension
e)
                  in ([Element]
oesforall a. [a] -> [a] -> [a]
++[Element]
nes, [Attribute]
oasforall a. [a] -> [a] -> [a]
++[Attribute]
nas)


comment :: Annotation -> Comment
comment :: Annotation -> Maybe String
comment (Documentation String
s) = forall a. a -> Maybe a
Just String
s
comment (AppInfo String
s)       = forall a. a -> Maybe a
Just String
s
comment (NoAnnotation String
_)  = forall a. Maybe a
Nothing

xname :: String -> XName
xname :: String -> XName
xname = QName -> XName
XName forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> QName
N

checkXName :: Schema -> QName -> XName
checkXName :: Schema -> QName -> XName
checkXName Schema
s n :: QName
n@(N String
_)     = QName -> XName
XName QName
n
checkXName Schema
s n :: QName
n@(QN Namespace
ns String
m) | (Just String
uri) <- Schema -> Maybe String
schema_targetNamespace Schema
s
                         , Namespace -> String
nsURI Namespace
ns forall a. Eq a => a -> a -> Bool
== String
uri = QName -> XName
XName forall a b. (a -> b) -> a -> b
$ String -> QName
N String
m
                         | Bool
otherwise       = QName -> XName
XName QName
n

nameOfSimple :: SimpleType -> XName
nameOfSimple :: SimpleType -> XName
nameOfSimple (Primitive PrimitiveType
prim)            = QName -> XName
XName forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> QName
xsd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ PrimitiveType
prim
nameOfSimple (Restricted Annotation
_ (Just String
n) Maybe Final
_ Restriction
_) = String -> XName
xname String
n
nameOfSimple (ListOf Annotation
_ (Just String
n) Maybe Final
_ Either SimpleType QName
_)     = String -> XName
xname String
n -- ("["++n++"]")
nameOfSimple (UnionOf Annotation
_ (Just String
n) Maybe Final
_ [SimpleType]
_ [QName]
_)  = String -> XName
xname String
n -- return to this
nameOfSimple SimpleType
s                           = String -> XName
xname String
"String" -- anonymous simple

mkRestrict :: XSD.Restriction -> [Haskell.Restrict]
mkRestrict :: Restriction -> [Restrict]
mkRestrict (RestrictSim1 Annotation
ann Maybe QName
base Restriction1
r1) = []
--      = error "Not yet implemented: Restriction1 on simpletype"
--      ^ This branch is not strictly correct.  There ought to be some
--        restrictions.
mkRestrict (RestrictType Annotation
_ Maybe QName
_ Maybe SimpleType
_ [Facet]
facets) =
    (let occurs :: [(FacetType, Annotation, String)]
occurs = [ (FacetType
f,Annotation
ann,String
v)  | (Facet FacetType
f Annotation
ann String
v Bool
_) <- [Facet]
facets
                               , FacetType
f forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FacetType
OrderedBoundsMinIncl
                                          ,FacetType
OrderedBoundsMinExcl
                                          ,FacetType
OrderedBoundsMaxIncl
                                          ,FacetType
OrderedBoundsMaxExcl] ]
     in [Occurs -> Maybe String -> Restrict
Haskell.RangeR (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Occurs -> (FacetType, Annotation, String) -> Occurs
consolidate (Maybe Int -> Maybe Int -> Occurs
Occurs forall a. Maybe a
Nothing forall a. Maybe a
Nothing) [(FacetType, Annotation, String)]
occurs)
          (Annotation -> Maybe String
comment forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [ Annotation
ann | (FacetType
_,Annotation
ann,String
_) <- [(FacetType, Annotation, String)]
occurs]) | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FacetType, Annotation, String)]
occurs]
    ) forall a. [a] -> [a] -> [a]
++
    [ String -> Maybe String -> Restrict
Haskell.Pattern String
v (Annotation -> Maybe String
comment Annotation
ann)
              | (Facet FacetType
UnorderedPattern Annotation
ann String
v Bool
_) <- [Facet]
facets ]
    forall a. [a] -> [a] -> [a]
++
    (let enum :: [(String, Maybe String)]
enum = [ (String
v,Annotation -> Maybe String
comment Annotation
ann)
                | (Facet FacetType
UnorderedEnumeration Annotation
ann String
v Bool
_) <- [Facet]
facets ]
     in [[(String, Maybe String)] -> Restrict
Haskell.Enumeration [(String, Maybe String)]
enum | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, Maybe String)]
enum]
    ) forall a. [a] -> [a] -> [a]
++
    (let occurs :: [(FacetType, Annotation, String)]
occurs = [ (FacetType
f,Annotation
ann,String
v)  | (Facet FacetType
f Annotation
ann String
v Bool
_) <- [Facet]
facets
                               , FacetType
f forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FacetType
UnorderedLength
                                          ,FacetType
UnorderedMaxLength
                                          ,FacetType
UnorderedMinLength] ]
     in [Occurs -> Maybe String -> Restrict
Haskell.StrLength
          (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Occurs -> (FacetType, Annotation, String) -> Occurs
consolidate (Maybe Int -> Maybe Int -> Occurs
Occurs forall a. Maybe a
Nothing forall a. Maybe a
Nothing) [(FacetType, Annotation, String)]
occurs)
          (Annotation -> Maybe String
comment forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [ Annotation
ann | (FacetType
_,Annotation
ann,String
_) <- [(FacetType, Annotation, String)]
occurs]) | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FacetType, Annotation, String)]
occurs]
    )

singleton :: a -> [a]
singleton :: forall a. a -> [a]
singleton = (forall a. a -> [a] -> [a]
:[])

-- | Consolidate a Facet occurrence into a single Occurs value.
consolidate :: Occurs -> (FacetType,Annotation,String) -> Occurs
consolidate :: Occurs -> (FacetType, Annotation, String) -> Occurs
consolidate (Occurs Maybe Int
min Maybe Int
max) (FacetType
OrderedBoundsMinIncl,Annotation
_,String
n) =
             Maybe Int -> Maybe Int -> Occurs
Occurs (forall a. a -> Maybe a
Just (forall a. Read a => String -> a
read String
n)) Maybe Int
max
consolidate (Occurs Maybe Int
min Maybe Int
max) (FacetType
OrderedBoundsMinExcl,Annotation
_,String
n) =
             Maybe Int -> Maybe Int -> Occurs
Occurs (forall a. a -> Maybe a
Just (forall a. Read a => String -> a
read String
n forall a. Num a => a -> a -> a
+Int
1)) Maybe Int
max
consolidate (Occurs Maybe Int
min Maybe Int
max) (FacetType
OrderedBoundsMaxIncl,Annotation
_,String
n) =
             Maybe Int -> Maybe Int -> Occurs
Occurs Maybe Int
min (forall a. a -> Maybe a
Just (forall a. Read a => String -> a
read String
n))
consolidate (Occurs Maybe Int
min Maybe Int
max) (FacetType
OrderedBoundsMaxExcl,Annotation
_,String
n) =
             Maybe Int -> Maybe Int -> Occurs
Occurs Maybe Int
min (forall a. a -> Maybe a
Just (forall a. Read a => String -> a
read String
n forall a. Num a => a -> a -> a
-Int
1))
consolidate (Occurs Maybe Int
min Maybe Int
max) (FacetType
UnorderedLength,Annotation
_,String
n) =
             Maybe Int -> Maybe Int -> Occurs
Occurs (forall a. a -> Maybe a
Just (forall a. Read a => String -> a
read String
n)) (forall a. a -> Maybe a
Just (forall a. Read a => String -> a
read String
n))
consolidate (Occurs Maybe Int
min Maybe Int
max) (FacetType
UnorderedMinLength,Annotation
_,String
n) =
             Maybe Int -> Maybe Int -> Occurs
Occurs (forall a. a -> Maybe a
Just (forall a. Read a => String -> a
read String
n)) Maybe Int
max
consolidate (Occurs Maybe Int
min Maybe Int
max) (FacetType
UnorderedMaxLength,Annotation
_,String
n) =
             Maybe Int -> Maybe Int -> Occurs
Occurs Maybe Int
min (forall a. a -> Maybe a
Just (forall a. Read a => String -> a
read String
n))

instance Monoid Occurs where
    mempty :: Occurs
mempty = Maybe Int -> Maybe Int -> Occurs
Occurs forall a. Maybe a
Nothing forall a. Maybe a
Nothing
    mappend :: Occurs -> Occurs -> Occurs
mappend = forall a. Semigroup a => a -> a -> a
(<>)

instance Semigroup Occurs where
    (Occurs Maybe Int
Nothing  Maybe Int
Nothing)  <> :: Occurs -> Occurs -> Occurs
<> Occurs
o  = Occurs
o
    (Occurs (Just Int
z) Maybe Int
Nothing)  <> (Occurs Maybe Int
min Maybe Int
max)
                                        = Maybe Int -> Maybe Int -> Occurs
Occurs (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
z (forall a. Num a => a -> a -> a
*Int
z) Maybe Int
min) Maybe Int
max
    (Occurs Maybe Int
Nothing  (Just Int
x)) <> (Occurs Maybe Int
min Maybe Int
max)
                                        = Maybe Int -> Maybe Int -> Occurs
Occurs Maybe Int
min (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
x (forall a. Num a => a -> a -> a
*Int
x) Maybe Int
max)
    (Occurs (Just Int
z) (Just Int
x)) <> (Occurs Maybe Int
min Maybe Int
max)
                                        = Maybe Int -> Maybe Int -> Occurs
Occurs (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
z (forall a. Num a => a -> a -> a
*Int
z) Maybe Int
min)
                                                 (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
x (forall a. Num a => a -> a -> a
*Int
x) Maybe Int
max)

-- | Push another Occurs value inside an existing Modifier.
combineOccursModifier :: Occurs -> Modifier -> Modifier
combineOccursModifier :: Occurs -> Modifier -> Modifier
combineOccursModifier Occurs
o Modifier
Haskell.Single     = Occurs -> Modifier
occursToModifier forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a -> a -> a
mappend Occurs
o
                                                    forall a b. (a -> b) -> a -> b
$ Maybe Int -> Maybe Int -> Occurs
Occurs (forall a. a -> Maybe a
Just Int
1) (forall a. a -> Maybe a
Just Int
1)
combineOccursModifier Occurs
o Modifier
Haskell.Optional   = Occurs -> Modifier
occursToModifier forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a -> a -> a
mappend Occurs
o
                                                    forall a b. (a -> b) -> a -> b
$ Maybe Int -> Maybe Int -> Occurs
Occurs (forall a. a -> Maybe a
Just Int
0) (forall a. a -> Maybe a
Just Int
1)
combineOccursModifier Occurs
o (Haskell.Range Occurs
o') = Occurs -> Modifier
occursToModifier forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a -> a -> a
mappend Occurs
o Occurs
o'

-- | Convert an occurs range to a Haskell-style type modifier (Maybe, List, Id)
occursToModifier :: Occurs -> Modifier
occursToModifier :: Occurs -> Modifier
occursToModifier (Occurs Maybe Int
Nothing  Maybe Int
Nothing)  = Modifier
Haskell.Single
occursToModifier (Occurs (Just Int
0) Maybe Int
Nothing)  = Modifier
Haskell.Optional
occursToModifier (Occurs (Just Int
0) (Just Int
1)) = Modifier
Haskell.Optional
occursToModifier (Occurs (Just Int
1) (Just Int
1)) = Modifier
Haskell.Single
occursToModifier Occurs
o                          = Occurs -> Modifier
Haskell.Range Occurs
o


-- | Find the supertype (if it exists) of a given type name.
supertypeOf :: Environment -> QName -> Maybe QName
supertypeOf :: Environment -> QName -> Maybe QName
supertypeOf Environment
env QName
t =
    do Either SimpleType ComplexType
typ <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QName
t (Environment -> Map QName (Either SimpleType ComplexType)
env_type Environment
env)
       ComplexItem
a <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComplexType -> ComplexItem
complex_content) Either SimpleType ComplexType
typ
       Either Restriction1 Extension
b <- case ComplexItem
a of ComplexContent{} -> forall a. a -> Maybe a
Just (ComplexItem -> Either Restriction1 Extension
ci_stuff ComplexItem
a)
                      ComplexItem
_ -> forall a. Maybe a
Nothing
       forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Extension -> QName
extension_base) Either Restriction1 Extension
b

-- | Keep applying the function to transform the value, until it yields
--   Nothing.  Returns the sequence of transformed values.
repeatedly :: (a->Maybe a) -> a -> [a]
repeatedly :: forall a. (a -> Maybe a) -> a -> [a]
repeatedly a -> Maybe a
f a
x = case a -> Maybe a
f a
x of Maybe a
Nothing -> []
                             Just a
y  -> a
y forall a. a -> [a] -> [a]
: forall a. (a -> Maybe a) -> a -> [a]
repeatedly a -> Maybe a
f a
y