{-# 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 =
                    [[SchemaItem]] -> [SchemaItem]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ ElementDecl -> [SchemaItem]
hoist ElementDecl
e | SchemaElement ElementDecl
e <- Schema -> [SchemaItem]
schema_items Schema
s ]
                    [SchemaItem] -> [SchemaItem] -> [SchemaItem]
forall a. [a] -> [a] -> [a]
++ (SchemaItem -> SchemaItem) -> [SchemaItem] -> [SchemaItem]
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 = ((ElementDecl -> [SchemaItem]) -> [ElementDecl] -> [SchemaItem])
-> [ElementDecl] -> (ElementDecl -> [SchemaItem]) -> [SchemaItem]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ElementDecl -> [SchemaItem]) -> [ElementDecl] -> [SchemaItem]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ElementDecl -> [ElementDecl]
findE ElementDecl
e) ((ElementDecl -> [SchemaItem]) -> [SchemaItem])
-> (ElementDecl -> [SchemaItem]) -> [SchemaItem]
forall a b. (a -> b) -> a -> b
$
              \e :: ElementDecl
e@ElementDecl{elem_nameOrRef :: ElementDecl -> Either NameAndType QName
elem_nameOrRef=Left (NT{ theName :: NameAndType -> Name
theName=Name
n
                                                  {-, theType=Nothing-}})}->
                  Name -> Maybe (Either SimpleType ComplexType) -> [SchemaItem]
localType Name
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
eElementDecl -> [ElementDecl] -> [ElementDecl]
forall 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 Name
complex_name=Just Name
t'}))
                                                 {--| t==t'-}
                                                    -> (ElementDecl
eElementDecl -> [ElementDecl] -> [ElementDecl]
forall a. a -> [a] -> [a]
:)
                                                  Maybe (Either SimpleType ComplexType)
_ -> [ElementDecl] -> [ElementDecl]
forall a. a -> a
id
                  Either NameAndType QName
_                          -> [ElementDecl] -> [ElementDecl]
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))  = [ElementDecl]
-> (ChoiceOrSeq -> [ElementDecl])
-> Maybe ChoiceOrSeq
-> [ElementDecl]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ChoiceOrSeq -> [ElementDecl]
choiceOrSeq (Maybe ChoiceOrSeq -> [ElementDecl])
-> Maybe ChoiceOrSeq -> [ElementDecl]
forall a b. (a -> b) -> a -> b
$ Group -> Maybe ChoiceOrSeq
group_stuff Group
g
    choiceOrSeq :: ChoiceOrSeq -> [ElementDecl]
choiceOrSeq (XSD.All Annotation
_ [ElementDecl]
es)        = (ElementDecl -> [ElementDecl]) -> [ElementDecl] -> [ElementDecl]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ElementDecl -> [ElementDecl]
findE [ElementDecl]
es
    choiceOrSeq (XSD.Choice   Annotation
_ Occurs
_ [ElementEtc]
es) = (ElementEtc -> [ElementDecl]) -> [ElementEtc] -> [ElementDecl]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ElementEtc -> [ElementDecl]
etc [ElementEtc]
es
    choiceOrSeq (XSD.Sequence Annotation
_ Occurs
_ [ElementEtc]
es) = (ElementEtc -> [ElementDecl]) -> [ElementEtc] -> [ElementDecl]
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)   = [ElementDecl]
-> (ChoiceOrSeq -> [ElementDecl])
-> Maybe ChoiceOrSeq
-> [ElementDecl]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ChoiceOrSeq -> [ElementDecl]
choiceOrSeq (Maybe ChoiceOrSeq -> [ElementDecl])
-> Maybe ChoiceOrSeq -> [ElementDecl]
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 :: Name -> Maybe (Either SimpleType ComplexType) -> [SchemaItem]
localType Name
n Maybe (Either SimpleType ComplexType)
Nothing          = []
    localType Name
n (Just (Left SimpleType
s))  = [SimpleType -> SchemaItem
Simple  (Name -> SimpleType -> SimpleType
renameSimple Name
n SimpleType
s)]
    localType Name
n (Just (Right ComplexType
c)) = [ComplexType -> SchemaItem
Complex ComplexType
c{ complex_name :: Maybe Name
complex_name = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n }]

    renameSimple :: Name -> SimpleType -> SimpleType
renameSimple Name
n s :: SimpleType
s@Primitive{}  = SimpleType
s
    renameSimple Name
n s :: SimpleType
s@Restricted{} = SimpleType
s{ simple_name :: Maybe Name
simple_name  = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n }
    renameSimple Name
n s :: SimpleType
s@ListOf{}     = SimpleType
s{ simple_name :: Maybe Name
simple_name  = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n }
    renameSimple Name
n s :: SimpleType
s@UnionOf{}    = SimpleType
s{ simple_name :: Maybe Name
simple_name  = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
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 = (SchemaItem -> [Decl]) -> [SchemaItem] -> [Decl]
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 Name
loc Annotation
ann)    = [XName -> Maybe Name -> Decl
XSDInclude (Name -> XName
xname Name
loc) (Annotation -> Maybe Name
comment Annotation
ann)]
    item (Import Name
uri Name
loc Annotation
ann) = [XName -> Maybe XName -> Maybe Name -> Decl
XSDImport  (Name -> XName
xname Name
loc)
                                            (Name -> XName
xname (Name -> XName) -> Maybe Name -> Maybe XName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                             Name -> Map Name Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
uri (Environment -> Map Name Name
env_namespace Environment
env))
                                            (Annotation -> Maybe Name
comment Annotation
ann)]
    item (Redefine Name
_ [SchemaItem]
_)       = [] -- ignoring redefinitions for now
    item (Annotation Annotation
ann)     = [Maybe Name -> Decl
XSDComment (Annotation -> Maybe Name
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 Name
n Maybe Final
f Restriction
r)
        | (Just [(XName, Maybe Name)]
enums) <- SimpleType -> Maybe [(XName, Maybe Name)]
isEnumeration SimpleType
s
                                = [XName -> [(XName, Maybe Name)] -> Maybe Name -> Decl
EnumSimpleType
                                       (XName -> (Name -> XName) -> Maybe Name -> XName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> XName
forall a. HasCallStack => Name -> a
error Name
"missing Name") Name -> XName
xname Maybe Name
n)
                                       [(XName, Maybe Name)]
enums (Annotation -> Maybe Name
comment Annotation
a) ]
        | Bool
otherwise             = [XName -> XName -> [Restrict] -> Maybe Name -> Decl
RestrictSimpleType
                                       (XName -> (Name -> XName) -> Maybe Name -> XName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> XName
forall a. HasCallStack => Name -> a
error Name
"missing Name") Name -> XName
xname Maybe Name
n)
                                       (XName -> (QName -> XName) -> Maybe QName -> XName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> XName
xname Name
"unknownSimple") QName -> XName
XName
                                                             (Restriction -> Maybe QName
restrict_base Restriction
r))
                                       (Restriction -> [Restrict]
mkRestrict Restriction
r)
                                       (Annotation -> Maybe Name
comment Annotation
a)]
    simple (ListOf Annotation
a Maybe Name
n Maybe Final
f Either SimpleType QName
t)     = Name -> [Decl]
forall a. HasCallStack => Name -> a
error Name
"Not yet implemented: ListOf simpleType"
                              --  [NamedSimpleType    (xname n) (nameOfSimple s)
                              --                      (comment a)]
    simple s :: SimpleType
s@(UnionOf Annotation
a Maybe Name
n Maybe Final
f [SimpleType]
u [QName]
m)
        | (Just [(XName, Maybe Name)]
enums) <- SimpleType -> Maybe [(XName, Maybe Name)]
isEnumeration SimpleType
s
                                = [XName -> [(XName, Maybe Name)] -> Maybe Name -> Decl
EnumSimpleType
                                       (XName -> (Name -> XName) -> Maybe Name -> XName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> XName
forall a. HasCallStack => Name -> a
error Name
"missing Name") Name -> XName
xname Maybe Name
n)
                                       [(XName, Maybe Name)]
enums (Annotation -> Maybe Name
comment Annotation
a) ]
        | Bool
otherwise             = [XName -> [XName] -> Maybe Name -> Decl
UnionSimpleTypes
                                       (XName -> (Name -> XName) -> Maybe Name -> XName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> XName
forall a. HasCallStack => Name -> a
error Name
"missing Name") Name -> XName
xname Maybe Name
n)
                                       ((QName -> XName) -> [QName] -> [XName]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> XName
xname (Name -> XName) -> (QName -> Name) -> QName -> XName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Name
printableName) [QName]
m) -- XXX ignores content 'u'
                                       (Annotation -> Maybe Name
comment Annotation
a)]

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

    complex :: ComplexType -> [Decl]
complex ComplexType
ct =
      let nx :: QName
nx  = Name -> QName
N (Name -> QName) -> Name -> QName
forall a b. (a -> b) -> a -> b
$ Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe Name
"errorMissingName" (ComplexType -> Maybe Name
complex_name ComplexType
ct)
          n :: XName
n   = QName -> XName
XName QName
nx
      in Decl -> [Decl]
forall a. a -> [a]
singleton (Decl -> [Decl]) -> Decl -> [Decl]
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 Name -> Decl
RestrictSimpleType XName
n ({-simple-}Name -> XName
xname Name
"Unimplemented") []
                                     (Annotation -> Maybe Name
comment (ComplexType -> Annotation
complex_annotation ComplexType
ct
                                              Annotation -> Annotation -> Annotation
forall a. Monoid a => a -> a -> a
`mappend` ComplexItem -> Annotation
ci_annotation ComplexItem
c))
                Right Extension
e ->
                    XName -> XName -> [Attribute] -> Maybe Name -> Decl
ExtendSimpleType XName
n
                                     ({-supertype-}QName -> XName
XName (QName -> XName) -> QName -> XName
forall a b. (a -> b) -> a -> b
$ Extension -> QName
extension_base Extension
e)
                                     ({-attrs-}([Element], [Attribute]) -> [Attribute]
forall a b. (a, b) -> b
snd (([Element], [Attribute]) -> [Attribute])
-> ([Element], [Attribute]) -> [Attribute]
forall a b. (a -> b) -> a -> b
$
                                      ParticleAttrs -> ([Element], [Attribute])
particleAttrs (ParticleAttrs -> ([Element], [Attribute]))
-> ParticleAttrs -> ([Element], [Attribute])
forall a b. (a -> b) -> a -> b
$ Extension -> ParticleAttrs
extension_newstuff Extension
e)
                                     (Annotation -> Maybe Name
comment (ComplexType -> Annotation
complex_annotation ComplexType
ct
                                              Annotation -> Annotation -> Annotation
forall a. Monoid a => a -> a -> a
`mappend` ComplexItem -> Annotation
ci_annotation ComplexItem
c
                                              Annotation -> Annotation -> Annotation
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 Name -> Decl
RestrictComplexType XName
n ({-complex-}Name -> XName
xname Name
"Can'tBeRight")
                                     (Annotation -> Maybe Name
comment (ComplexType -> Annotation
complex_annotation ComplexType
ct
                                              Annotation -> Annotation -> Annotation
forall a. Monoid a => a -> a -> a
`mappend` ComplexItem -> Annotation
ci_annotation ComplexItem
c))
                Right Extension
e ->
                    let myLoc :: Name
myLoc  = Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe Name
"NUL" (QName -> Map QName Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QName
nx
                                                             (Environment -> Map QName Name
env_typeloc Environment
env))
                        supLoc :: Name
supLoc = Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe Name
"NUL" (QName -> Map QName Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Extension -> QName
extension_base Extension
e)
                                                             (Environment -> Map QName Name
env_typeloc Environment
env))
                    in
                    if ComplexType -> Bool
complex_abstract ComplexType
ct then
                        XName
-> XName
-> [(XName, Maybe XName)]
-> Maybe XName
-> [XName]
-> Maybe Name
-> Decl
ExtendComplexTypeAbstract XName
n
                             ({-supertype-}QName -> XName
XName (QName -> XName) -> QName -> XName
forall a b. (a -> b) -> a -> b
$ Extension -> QName
extension_base Extension
e)
                             ({-subtypes-}
                              [(XName, Maybe XName)]
-> ([(QName, Name)] -> [(XName, Maybe XName)])
-> Maybe [(QName, Name)]
-> [(XName, Maybe XName)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> [(XName, Maybe XName)]
forall a. HasCallStack => Name -> a
error (Name
"ExtendComplexTypeAbstract "Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++QName -> Name
forall a. Show a => a -> Name
show QName
nx))
                                    (((QName, Name) -> (XName, Maybe XName))
-> [(QName, Name)] -> [(XName, Maybe XName)]
forall a b. (a -> b) -> [a] -> [b]
map (\(QName
t,Name
l)->(QName -> XName
XName QName
t,if Name
lName -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/=Name
myLoc
                                                           then XName -> Maybe XName
forall a. a -> Maybe a
Just (Name -> XName
xname Name
l)
                                                           else Maybe XName
forall a. Maybe a
Nothing)))
                                    (QName -> Map QName [(QName, Name)] -> Maybe [(QName, Name)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QName
nx (Environment -> Map QName [(QName, Name)]
env_extendty Environment
env)))
                             ({-fwddecl-}if Name
myLocName -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/=Name
supLoc
                                         then XName -> Maybe XName
forall a. a -> Maybe a
Just (Name -> XName
xname Name
supLoc) else Maybe XName
forall a. Maybe a
Nothing)
                             ({-grandsupers-}
                              (QName -> XName) -> [QName] -> [XName]
forall a b. (a -> b) -> [a] -> [b]
map QName -> XName
XName ([QName] -> [XName]) -> [QName] -> [XName]
forall a b. (a -> b) -> a -> b
$ (QName -> Maybe QName) -> QName -> [QName]
forall a. (a -> Maybe a) -> a -> [a]
repeatedly (Environment -> QName -> Maybe QName
supertypeOf Environment
env) QName
nx)
                             (Annotation -> Maybe Name
comment (ComplexType -> Annotation
complex_annotation ComplexType
ct
                                      Annotation -> Annotation -> Annotation
forall a. Monoid a => a -> a -> a
`mappend` ComplexItem -> Annotation
ci_annotation ComplexItem
c
                                      Annotation -> Annotation -> Annotation
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 (Maybe (Either SimpleType ComplexType) -> ([Element], [Attribute]))
-> Maybe (Either SimpleType ComplexType)
-> ([Element], [Attribute])
forall a b. (a -> b) -> a -> b
$
                                            QName
-> Map QName (Either SimpleType ComplexType)
-> Maybe (Either SimpleType ComplexType)
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 Name
-> Decl
ExtendComplexType XName
n
                        ({-supertype-}QName -> XName
XName (QName -> XName) -> QName -> 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 Name
myLocName -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/=Name
supLoc then XName -> Maybe XName
forall a. a -> Maybe a
Just (Name -> XName
xname Name
supLoc)
                                                     else Maybe XName
forall a. Maybe a
Nothing)
                        ({-abstract supertype-}
                         Bool
-> (Either SimpleType ComplexType -> Bool)
-> Maybe (Either SimpleType ComplexType)
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((SimpleType -> Bool)
-> (ComplexType -> Bool) -> Either SimpleType ComplexType -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> SimpleType -> Bool
forall a b. a -> b -> a
const Bool
False) ComplexType -> Bool
complex_abstract)
                                     (QName
-> Map QName (Either SimpleType ComplexType)
-> Maybe (Either SimpleType ComplexType)
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-}
                         (QName -> XName) -> [QName] -> [XName]
forall a b. (a -> b) -> [a] -> [b]
map QName -> XName
XName ([QName] -> [XName]) -> [QName] -> [XName]
forall a b. (a -> b) -> a -> b
$ (QName -> Maybe QName) -> QName -> [QName]
forall a. (a -> Maybe a) -> a -> [a]
repeatedly (Environment -> QName -> Maybe QName
supertypeOf Environment
env)
                                   (QName -> [QName]) -> QName -> [QName]
forall a b. (a -> b) -> a -> b
$ Extension -> QName
extension_base Extension
e)
                        (Annotation -> Maybe Name
comment (ComplexType -> Annotation
complex_annotation ComplexType
ct
                                 Annotation -> Annotation -> Annotation
forall a. Monoid a => a -> a -> a
`mappend` ComplexItem -> Annotation
ci_annotation ComplexItem
c
                                 Annotation -> Annotation -> Annotation
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 :: Name
myLoc  = Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe Name
"NUL"
                         (QName -> Map QName Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QName
nx (Environment -> Map QName Name
env_typeloc Environment
env)) in
            XName -> [(XName, Maybe XName)] -> Maybe Name -> Decl
ElementsAttrsAbstract XName
n
                          {-all instance types: -}
                          (case QName -> Map QName [(QName, Name)] -> Maybe [(QName, Name)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QName
nx (Environment -> Map QName [(QName, Name)]
env_extendty Environment
env) of
                             Maybe [(QName, Name)]
Nothing -> []
                             Just [(QName, Name)]
xs -> ((QName, Name) -> (XName, Maybe XName))
-> [(QName, Name)] -> [(XName, Maybe XName)]
forall a b. (a -> b) -> [a] -> [b]
map (\ (QName
x,Name
loc)->(QName -> XName
XName QName
x,if Name
locName -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/=Name
myLoc
                                                          then XName -> Maybe XName
forall a. a -> Maybe a
Just (Name -> XName
xname Name
loc)
                                                          else Maybe XName
forall a. Maybe a
Nothing)) [(QName, Name)]
xs
                          )
                          (Annotation -> Maybe Name
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 Name -> Decl
ElementsAttrs XName
n [Element]
es' [Attribute]
as (Annotation -> Maybe Name
comment (ComplexType -> Annotation
complex_annotation ComplexType
ct))

    mkMixedContent :: [Element] -> [Element]
mkMixedContent [e :: Element
e@OneOf{}] = [Element
e{ elem_oneOf :: [[Element]]
elem_oneOf = [Element
Text][Element] -> [[Element]] -> [[Element]]
forall a. a -> [a] -> [a]
: Element -> [[Element]]
elem_oneOf Element
e }]
    mkMixedContent [Element]
es          = Element
TextElement -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: (Element -> [Element]) -> [Element] -> [Element]
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 Name -> Decl
ElementsAttrs ({-name-}Name -> XName
xname (Name -> XName) -> Name -> XName
forall a b. (a -> b) -> a -> b
$ NameAndType -> Name
theName NameAndType
n)
                                         {-elems-}[Element]
es
                                         {-attrs-}[Attribute]
as
                                         (Annotation -> Maybe Name
comment (ElementDecl -> Annotation
elem_annotation ElementDecl
ed))
                         , Element -> Decl
ElementOfType (Element -> Decl) -> Element -> Decl
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     = Name -> QName
N (Name -> QName) -> Name -> QName
forall a b. (a -> b) -> a -> b
$ NameAndType -> Name
theName NameAndType
n
                             myLoc :: Name
myLoc  = Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe Name
"NUL"
                                          (QName -> Map QName Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QName
nm (Environment -> Map QName Name
env_typeloc Environment
env)) in
                         Decl -> [Decl]
forall a. a -> [a]
singleton (Decl -> [Decl]) -> Decl -> [Decl]
forall a b. (a -> b) -> a -> b
$
                         XName -> XName -> [(XName, Maybe XName)] -> Maybe Name -> Decl
ElementAbstractOfType
                                 (QName -> XName
XName QName
nm)
                                 (Schema -> QName -> XName
checkXName Schema
s QName
t)
                                 (case QName -> Map QName [(QName, Name)] -> Maybe [(QName, Name)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QName
nm (Environment -> Map QName [(QName, Name)]
env_substGrp Environment
env) of
                                    Maybe [(QName, Name)]
Nothing -> []
                                    Just [(QName, Name)]
xs ->
                                      ((QName, Name) -> (XName, Maybe XName))
-> [(QName, Name)] -> [(XName, Maybe XName)]
forall a b. (a -> b) -> [a] -> [b]
map (\ (QName
x,Name
loc)->(QName -> XName
XName QName
x,
                                                       if Name
locName -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/=Name
myLoc
                                                       then XName -> Maybe XName
forall a. a -> Maybe a
Just (Name -> XName
xname Name
loc)
                                                       else Maybe XName
forall a. Maybe a
Nothing)) [(QName, Name)]
xs)
                                 (Annotation -> Maybe Name
comment (ElementDecl -> Annotation
elem_annotation ElementDecl
ed))
                       Just QName
t | Bool
otherwise ->
                         Decl -> [Decl]
forall a. a -> [a]
singleton (Decl -> [Decl]) -> Decl -> [Decl]
forall a b. (a -> b) -> a -> b
$ Element -> Decl
ElementOfType (Element -> Decl) -> Element -> Decl
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 QName -> Map QName ElementDecl -> Maybe ElementDecl
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 -> Name -> [Decl]
forall a. HasCallStack => Name -> a
error (Name -> [Decl]) -> Name -> [Decl]
forall a b. (a -> b) -> a -> b
$ Name
"<topElementDecl> unknown element reference "
                            Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++QName -> Name
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 :: XName
-> XName
-> Modifier
-> Bool
-> [Decl]
-> Maybe [XName]
-> Maybe Name
-> Element
Element { elem_name :: XName
elem_name     = Name -> XName
xname (Name -> XName) -> Name -> XName
forall a b. (a -> b) -> a -> b
$ NameAndType -> Name
theName NameAndType
n
                             , elem_type :: XName
elem_type     = XName -> (QName -> XName) -> Maybe QName -> XName
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 (Occurs -> Modifier) -> Occurs -> Modifier
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   = Maybe [XName]
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 Name
elem_comment  = Annotation -> Maybe Name
comment (Annotation -> Maybe Name) -> Annotation -> Maybe Name
forall a b. (a -> b) -> a -> b
$ ElementDecl -> Annotation
elem_annotation ElementDecl
ed
                             }
        Right QName
ref -> case QName -> Map QName ElementDecl -> Maybe ElementDecl
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 QName -> Map QName ElementDecl -> Maybe ElementDecl
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Name -> QName
N (Name -> QName) -> Name -> QName
forall a b. (a -> b) -> a -> b
$ QName -> Name
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 Name
-> 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 [] Maybe [XName]
forall a. Maybe a
Nothing Maybe Name
forall a. Maybe a
Nothing

    localTypeExp :: XSD.ElementDecl -> XName
    localTypeExp :: ElementDecl -> XName
localTypeExp ElementDecl
ed | Maybe (Either SimpleType ComplexType) -> Bool
forall a. Maybe a -> Bool
isJust (ElementDecl -> Maybe (Either SimpleType ComplexType)
elem_content ElementDecl
ed) =
                          case Maybe (Either SimpleType ComplexType)
-> Either SimpleType ComplexType
forall a. HasCallStack => Maybe a -> a
fromJust (ElementDecl -> Maybe (Either SimpleType ComplexType)
elem_content ElementDecl
ed) of
                            Left st :: SimpleType
st@Primitive{}   -> Name -> XName
xname Name
"SomethingPrimitive"
                            Left st :: SimpleType
st@Restricted{}  -> (\XName
x-> XName -> (Name -> XName) -> Maybe Name -> XName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe XName
x Name -> XName
xname
                                                          (SimpleType -> Maybe Name
simple_name SimpleType
st)) (XName -> XName) -> XName -> XName
forall a b. (a -> b) -> a -> b
$
                                                     XName -> (QName -> XName) -> Maybe QName -> XName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> XName
xname Name
"GiveUp")
                                                           QName -> XName
XName
                                                      (Restriction -> Maybe QName
restrict_base (Restriction -> Maybe QName) -> Restriction -> Maybe QName
forall a b. (a -> b) -> a -> b
$
                                                       SimpleType -> Restriction
simple_restriction SimpleType
st)
                            Left st :: SimpleType
st@ListOf{}      -> Name -> XName
xname Name
"SomethingListy"
                            Left st :: SimpleType
st@UnionOf{}     -> Name -> XName
xname Name
"SomethingUnionLike"
                            Right c :: ComplexType
c@ComplexType{} -> XName -> (Name -> XName) -> Maybe Name -> XName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ElementDecl -> XName
localTypeExp ElementDecl
ed{elem_content :: Maybe (Either SimpleType ComplexType)
elem_content=Maybe (Either SimpleType ComplexType)
forall a. Maybe a
Nothing})
                                                           Name -> XName
xname
                                                     (Maybe Name -> XName) -> Maybe Name -> XName
forall a b. (a -> b) -> a -> b
$ ComplexType -> Maybe Name
complex_name ComplexType
c
                    | Bool
otherwise =
                          case ElementDecl -> Either NameAndType QName
elem_nameOrRef ElementDecl
ed of
                            Left NameAndType
n  -> Name -> XName
xname (Name -> XName) -> Name -> XName
forall a b. (a -> b) -> a -> b
$ NameAndType -> Name
theName NameAndType
n
                            Right QName
_ -> Name -> XName
xname Name
"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   -> Attribute -> [Attribute]
forall a. a -> [a]
singleton (Attribute -> [Attribute]) -> Attribute -> [Attribute]
forall a b. (a -> b) -> a -> b
$
                     XName -> XName -> Bool -> Maybe Name -> Attribute
Attribute (Name -> XName
xname (Name -> XName) -> Name -> XName
forall a b. (a -> b) -> a -> b
$ NameAndType -> Name
theName NameAndType
n)
                               (XName -> (QName -> XName) -> Maybe QName -> XName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (XName -> (SimpleType -> XName) -> Maybe SimpleType -> XName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> XName
xname Name
"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 Use -> Use -> Bool
forall a. Eq a => a -> a -> Bool
== Use
Required)
                               (Annotation -> Maybe Name
comment  (AttributeDecl -> Annotation
attr_annotation AttributeDecl
ad))
        Right QName
ref -> case QName -> Map QName AttributeDecl -> Maybe AttributeDecl
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 -> Name -> [Attribute]
forall a. HasCallStack => Name -> a
error (Name -> [Attribute]) -> Name -> [Attribute]
forall a b. (a -> b) -> a -> b
$ Name
"<attributeDecl> unknown attribute reference "
                                          Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++QName -> Name
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 Name QName
attrgroup_nameOrRef AttrGroup
g of
        Left  Name
n   -> (Either AttributeDecl AttrGroup -> [Attribute])
-> [Either AttributeDecl AttrGroup] -> [Attribute]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((AttributeDecl -> [Attribute])
-> (AttrGroup -> [Attribute])
-> Either AttributeDecl AttrGroup
-> [Attribute]
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 QName -> Map QName AttrGroup -> Maybe AttrGroup
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 -> Name -> [Attribute]
forall a. HasCallStack => Name -> a
error (Name -> [Attribute]) -> Name -> [Attribute]
forall a b. (a -> b) -> a -> b
$ Name
"unknown attribute group reference "
                                          Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++QName -> Name
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 Name QName
group_nameOrRef Group
g of
        Left  Name
n   -> let {-highs,-}es :: [Element]
es = ChoiceOrSeq -> [Element]
choiceOrSeq (ChoiceOrSeq -> Maybe ChoiceOrSeq -> ChoiceOrSeq
forall a. a -> Maybe a -> a
fromMaybe (Name -> ChoiceOrSeq
forall a. HasCallStack => Name -> a
error Name
"XSD.group")
                                                             (Group -> Maybe ChoiceOrSeq
group_stuff Group
g))
                     in {-highs ++-} Decl -> [Decl]
forall a. a -> [a]
singleton (Decl -> [Decl]) -> Decl -> [Decl]
forall a b. (a -> b) -> a -> b
$
                           XName -> [Element] -> Maybe Name -> Decl
Haskell.Group (Name -> XName
xname Name
n)
                                         ((Element -> Element) -> [Element] -> [Element]
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 Name
comment (Group -> Annotation
group_annotation Group
g))
        Right QName
ref -> case QName -> Map QName Group -> Maybe Group
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 -> Decl -> [Decl]
forall a. a -> [a]
singleton (Decl -> [Decl]) -> Decl -> [Decl]
forall a b. (a -> b) -> a -> b
$
                                  XName -> [Element] -> Maybe Name -> Decl
Haskell.Group (Name -> XName
xname (Name
"unknown-group-"Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++QName -> Name
printableName QName
ref)) []
                                                (Annotation -> Maybe Name
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, (Either AttributeDecl AttrGroup -> [Attribute])
-> [Either AttributeDecl AttrGroup] -> [Attribute]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((AttributeDecl -> [Attribute])
-> (AttrGroup -> [Attribute])
-> Either AttributeDecl AttrGroup
-> [Attribute]
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 Name
_] = 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)   = Name -> [Element]
forall a. HasCallStack => Name -> a
error Name
"not yet implemented: XSD.All"
    choiceOrSeq (XSD.Choice   Annotation
ann Occurs
o [ElementEtc]
ees) = [ [[Element]] -> Modifier -> Maybe Name -> Element
OneOf ([[Element]] -> [[Element]]
anyToEnd
                                                     ((ElementEtc -> [Element]) -> [ElementEtc] -> [[Element]]
forall a b. (a -> b) -> [a] -> [b]
map ElementEtc -> [Element]
elementEtc [ElementEtc]
ees))
                                                   (Occurs -> Modifier
occursToModifier Occurs
o)
                                                   (Annotation -> Maybe Name
comment Annotation
ann) ]
    choiceOrSeq (XSD.Sequence Annotation
ann Occurs
_ [ElementEtc]
ees) = (ElementEtc -> [Element]) -> [ElementEtc] -> [Element]
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 Name
_] = 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{}  = [AnyElem :: Modifier -> Maybe Name -> Element
Haskell.AnyElem
                           { elem_modifier :: Modifier
elem_modifier = Occurs -> Modifier
occursToModifier (Any -> Occurs
any_occurs Any
a)
                           , elem_comment :: Maybe Name
elem_comment  = Annotation -> Maybe Name
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 Maybe [Element]
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 ([Element] -> Maybe [Element]
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]
e[Element] -> [[Element]] -> [[Element]]
forall 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) = (SimpleType -> ([Element], [Attribute]))
-> (ComplexType -> ([Element], [Attribute]))
-> Either SimpleType ComplexType
-> ([Element], [Attribute])
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{} -> (Restriction1 -> ([Element], [Attribute]))
-> (Extension -> ([Element], [Attribute]))
-> Either Restriction1 Extension
-> ([Element], [Attribute])
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 (QName
-> Map QName (Either SimpleType ComplexType)
-> Maybe (Either SimpleType ComplexType)
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]
oes[Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++[Element]
nes, [Attribute]
oas[Attribute] -> [Attribute] -> [Attribute]
forall a. [a] -> [a] -> [a]
++[Attribute]
nas)


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

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

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

nameOfSimple :: SimpleType -> XName
nameOfSimple :: SimpleType -> XName
nameOfSimple (Primitive PrimitiveType
prim)            = QName -> XName
XName (QName -> XName)
-> (PrimitiveType -> QName) -> PrimitiveType -> XName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> QName
xsd (Name -> QName)
-> (PrimitiveType -> Name) -> PrimitiveType -> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimitiveType -> Name
forall a. Show a => a -> Name
show (PrimitiveType -> XName) -> PrimitiveType -> XName
forall a b. (a -> b) -> a -> b
$ PrimitiveType
prim
nameOfSimple (Restricted Annotation
_ (Just Name
n) Maybe Final
_ Restriction
_) = Name -> XName
xname Name
n
nameOfSimple (ListOf Annotation
_ (Just Name
n) Maybe Final
_ Either SimpleType QName
_)     = Name -> XName
xname Name
n -- ("["++n++"]")
nameOfSimple (UnionOf Annotation
_ (Just Name
n) Maybe Final
_ [SimpleType]
_ [QName]
_)  = Name -> XName
xname Name
n -- return to this
nameOfSimple SimpleType
s                           = Name -> XName
xname Name
"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, Name)]
occurs = [ (FacetType
f,Annotation
ann,Name
v)  | (Facet FacetType
f Annotation
ann Name
v Bool
_) <- [Facet]
facets
                               , FacetType
f FacetType -> [FacetType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FacetType
OrderedBoundsMinIncl
                                          ,FacetType
OrderedBoundsMinExcl
                                          ,FacetType
OrderedBoundsMaxIncl
                                          ,FacetType
OrderedBoundsMaxExcl] ]
     in [Occurs -> Maybe Name -> Restrict
Haskell.RangeR ((Occurs -> (FacetType, Annotation, Name) -> Occurs)
-> Occurs -> [(FacetType, Annotation, Name)] -> Occurs
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Occurs -> (FacetType, Annotation, Name) -> Occurs
consolidate (Maybe Int -> Maybe Int -> Occurs
Occurs Maybe Int
forall a. Maybe a
Nothing Maybe Int
forall a. Maybe a
Nothing) [(FacetType, Annotation, Name)]
occurs)
          (Annotation -> Maybe Name
comment (Annotation -> Maybe Name) -> Annotation -> Maybe Name
forall a b. (a -> b) -> a -> b
$ [Annotation] -> Annotation
forall a. Monoid a => [a] -> a
mconcat [ Annotation
ann | (FacetType
_,Annotation
ann,Name
_) <- [(FacetType, Annotation, Name)]
occurs]) | [(FacetType, Annotation, Name)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FacetType, Annotation, Name)]
occurs]
    ) [Restrict] -> [Restrict] -> [Restrict]
forall a. [a] -> [a] -> [a]
++
    [ Name -> Maybe Name -> Restrict
Haskell.Pattern Name
v (Annotation -> Maybe Name
comment Annotation
ann)
              | (Facet FacetType
UnorderedPattern Annotation
ann Name
v Bool
_) <- [Facet]
facets ]
    [Restrict] -> [Restrict] -> [Restrict]
forall a. [a] -> [a] -> [a]
++
    (let enum :: [(Name, Maybe Name)]
enum = [ (Name
v,Annotation -> Maybe Name
comment Annotation
ann)
                | (Facet FacetType
UnorderedEnumeration Annotation
ann Name
v Bool
_) <- [Facet]
facets ]
     in [[(Name, Maybe Name)] -> Restrict
Haskell.Enumeration [(Name, Maybe Name)]
enum | [(Name, Maybe Name)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Name, Maybe Name)]
enum]
    ) [Restrict] -> [Restrict] -> [Restrict]
forall a. [a] -> [a] -> [a]
++
    (let occurs :: [(FacetType, Annotation, Name)]
occurs = [ (FacetType
f,Annotation
ann,Name
v)  | (Facet FacetType
f Annotation
ann Name
v Bool
_) <- [Facet]
facets
                               , FacetType
f FacetType -> [FacetType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FacetType
UnorderedLength
                                          ,FacetType
UnorderedMaxLength
                                          ,FacetType
UnorderedMinLength] ]
     in [Occurs -> Maybe Name -> Restrict
Haskell.StrLength
          ((Occurs -> (FacetType, Annotation, Name) -> Occurs)
-> Occurs -> [(FacetType, Annotation, Name)] -> Occurs
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Occurs -> (FacetType, Annotation, Name) -> Occurs
consolidate (Maybe Int -> Maybe Int -> Occurs
Occurs Maybe Int
forall a. Maybe a
Nothing Maybe Int
forall a. Maybe a
Nothing) [(FacetType, Annotation, Name)]
occurs)
          (Annotation -> Maybe Name
comment (Annotation -> Maybe Name) -> Annotation -> Maybe Name
forall a b. (a -> b) -> a -> b
$ [Annotation] -> Annotation
forall a. Monoid a => [a] -> a
mconcat [ Annotation
ann | (FacetType
_,Annotation
ann,Name
_) <- [(FacetType, Annotation, Name)]
occurs]) | [(FacetType, Annotation, Name)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FacetType, Annotation, Name)]
occurs]
    )

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

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

instance Monoid Occurs where
    mempty :: Occurs
mempty = Maybe Int -> Maybe Int -> Occurs
Occurs Maybe Int
forall a. Maybe a
Nothing Maybe Int
forall a. Maybe a
Nothing
    mappend :: Occurs -> Occurs -> Occurs
mappend = Occurs -> Occurs -> Occurs
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 (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
z (Int -> Int -> Int
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 (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
x (Int -> Int -> Int
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 (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
z (Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
z) Maybe Int
min)
                                                 (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
x (Int -> Int -> Int
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 (Occurs -> Modifier) -> Occurs -> Modifier
forall a b. (a -> b) -> a -> b
$ Occurs -> Occurs -> Occurs
forall a. Monoid a => a -> a -> a
mappend Occurs
o
                                                    (Occurs -> Occurs) -> Occurs -> Occurs
forall a b. (a -> b) -> a -> b
$ Maybe Int -> Maybe Int -> Occurs
Occurs (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1) (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1)
combineOccursModifier Occurs
o Modifier
Haskell.Optional   = Occurs -> Modifier
occursToModifier (Occurs -> Modifier) -> Occurs -> Modifier
forall a b. (a -> b) -> a -> b
$ Occurs -> Occurs -> Occurs
forall a. Monoid a => a -> a -> a
mappend Occurs
o
                                                    (Occurs -> Occurs) -> Occurs -> Occurs
forall a b. (a -> b) -> a -> b
$ Maybe Int -> Maybe Int -> Occurs
Occurs (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0) (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1)
combineOccursModifier Occurs
o (Haskell.Range Occurs
o') = Occurs -> Modifier
occursToModifier (Occurs -> Modifier) -> Occurs -> Modifier
forall a b. (a -> b) -> a -> b
$ Occurs -> Occurs -> Occurs
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 <- QName
-> Map QName (Either SimpleType ComplexType)
-> Maybe (Either SimpleType ComplexType)
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 <- (SimpleType -> Maybe ComplexItem)
-> (ComplexType -> Maybe ComplexItem)
-> Either SimpleType ComplexType
-> Maybe ComplexItem
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe ComplexItem -> SimpleType -> Maybe ComplexItem
forall a b. a -> b -> a
const Maybe ComplexItem
forall a. Maybe a
Nothing) (ComplexItem -> Maybe ComplexItem
forall a. a -> Maybe a
Just (ComplexItem -> Maybe ComplexItem)
-> (ComplexType -> ComplexItem) -> ComplexType -> Maybe ComplexItem
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{} -> Either Restriction1 Extension
-> Maybe (Either Restriction1 Extension)
forall a. a -> Maybe a
Just (ComplexItem -> Either Restriction1 Extension
ci_stuff ComplexItem
a)
                      ComplexItem
_ -> Maybe (Either Restriction1 Extension)
forall a. Maybe a
Nothing
       (Restriction1 -> Maybe QName)
-> (Extension -> Maybe QName)
-> Either Restriction1 Extension
-> Maybe QName
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe QName -> Restriction1 -> Maybe QName
forall a b. a -> b -> a
const Maybe QName
forall a. Maybe a
Nothing) (QName -> Maybe QName
forall a. a -> Maybe a
Just (QName -> Maybe QName)
-> (Extension -> QName) -> Extension -> Maybe QName
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 :: (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 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a -> Maybe a) -> a -> [a]
forall a. (a -> Maybe a) -> a -> [a]
repeatedly a -> Maybe a
f a
y