{-# 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 =
                    concat [ hoist e | SchemaElement e <- schema_items s ]
                    ++ map renameLocals (schema_items s) }
  where
    hoist :: ElementDecl -> [SchemaItem]
    hoist :: ElementDecl -> [SchemaItem]
hoist ElementDecl
e =
              let only_children :: [ElementDecl]
only_children = (ElementDecl -> Bool) -> [ElementDecl] -> [ElementDecl]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (ElementDecl -> Bool) -> ElementDecl -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ElementDecl -> ElementDecl -> Bool
forall a. Eq a => a -> a -> Bool
(==) ElementDecl
e) ([ElementDecl] -> [ElementDecl]) -> [ElementDecl] -> [ElementDecl]
forall a b. (a -> b) -> a -> b
$ ElementDecl -> [ElementDecl]
findE ElementDecl
e
              in ((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]
only_children ((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 -> 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
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 String
complex_name=Just String
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 :: 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 = Just 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  = Just n }
    renameSimple String
n s :: SimpleType
s@ListOf{}     = SimpleType
s{ simple_name  = Just n }
    renameSimple String
n s :: SimpleType
s@UnionOf{}    = SimpleType
s{ simple_name  = Just 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 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 (String -> XName) -> Maybe String -> Maybe XName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                             String -> Map String String -> Maybe String
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
                                       (XName -> (String -> XName) -> Maybe String -> XName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> XName
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
                                       (XName -> (String -> XName) -> Maybe String -> XName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> XName
forall a. HasCallStack => String -> a
error String
"missing Name") String -> XName
xname Maybe String
n)
                                       (XName -> (QName -> XName) -> Maybe QName -> XName
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)     = String -> [Decl]
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
                                       (XName -> (String -> XName) -> Maybe String -> XName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> XName
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
                                       (XName -> (String -> XName) -> Maybe String -> XName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> XName
forall a. HasCallStack => String -> a
error String
"missing Name") String -> XName
xname Maybe String
n)
                                       ((QName -> XName) -> [QName] -> [XName]
forall a b. (a -> b) -> [a] -> [b]
map (String -> XName
xname (String -> XName) -> (QName -> String) -> QName -> 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
_)        = Maybe [(XName, Maybe String)]
forall a. Maybe a
Nothing
    isEnumeration (ListOf Annotation
_ Maybe String
_ Maybe Final
_ Either SimpleType QName
_)     = Maybe [(XName, Maybe String)]
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  -> Maybe [(XName, Maybe String)]
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 [(XName, Maybe String)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(XName, Maybe String)]
enum then Maybe [(XName, Maybe String)]
forall a. Maybe a
Nothing else [(XName, Maybe String)] -> Maybe [(XName, Maybe String)]
forall a. a -> Maybe a
Just [(XName, Maybe String)]
enum
    isEnumeration (UnionOf Annotation
_ Maybe String
_ Maybe Final
_ [SimpleType]
u [QName]
ms) =
        [(XName, Maybe String)]
-> [Maybe [(XName, Maybe String)]] -> Maybe [(XName, Maybe String)]
forall {a}. [a] -> [Maybe [a]] -> Maybe [a]
squeeze [] ( ((QName -> Maybe [(XName, Maybe String)])
 -> [QName] -> [Maybe [(XName, Maybe String)]])
-> [QName]
-> (QName -> Maybe [(XName, Maybe String)])
-> [Maybe [(XName, Maybe String)]]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (QName -> Maybe [(XName, Maybe String)])
-> [QName] -> [Maybe [(XName, Maybe String)]]
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 String)]
isEnumeration SimpleType
s
                                         Maybe (Either SimpleType ComplexType)
_            -> Maybe [(XName, Maybe String)]
forall a. Maybe a
Nothing)
                     [Maybe [(XName, Maybe String)]]
-> [Maybe [(XName, Maybe String)]]
-> [Maybe [(XName, Maybe String)]]
forall a. [a] -> [a] -> [a]
++ (SimpleType -> Maybe [(XName, Maybe String)])
-> [SimpleType] -> [Maybe [(XName, Maybe String)]]
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]]
_)    = 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  = String -> QName
N (String -> QName) -> String -> QName
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
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 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 String -> Decl
RestrictSimpleType XName
n ({-simple-}String -> XName
xname String
"Unimplemented") []
                                     (Annotation -> Maybe String
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 String -> 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 String
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 String -> Decl
RestrictComplexType XName
n ({-complex-}String -> XName
xname String
"Can'tBeRight")
                                     (Annotation -> Maybe String
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 :: String
myLoc  = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"NUL" (QName -> Map QName String -> Maybe String
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 = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"NUL" (QName -> Map QName String -> Maybe String
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 (QName -> XName) -> QName -> XName
forall a b. (a -> b) -> a -> b
$ Extension -> QName
extension_base Extension
e)
                             ({-subtypes-}
                              [(XName, Maybe XName)]
-> ([(QName, String)] -> [(XName, Maybe XName)])
-> Maybe [(QName, String)]
-> [(XName, Maybe XName)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> [(XName, Maybe XName)]
forall a. HasCallStack => String -> a
error (String
"ExtendComplexTypeAbstract "String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
forall a. Show a => a -> String
show QName
nx))
                                    (((QName, String) -> (XName, Maybe XName))
-> [(QName, String)] -> [(XName, Maybe XName)]
forall a b. (a -> b) -> [a] -> [b]
map (\(QName
t,String
l)->(QName -> XName
XName QName
t,if String
lString -> String -> Bool
forall a. Eq a => a -> a -> Bool
/=String
myLoc
                                                           then XName -> Maybe XName
forall a. a -> Maybe a
Just (String -> XName
xname String
l)
                                                           else Maybe XName
forall a. Maybe a
Nothing)))
                                    (QName -> Map QName [(QName, String)] -> Maybe [(QName, String)]
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
myLocString -> String -> Bool
forall a. Eq a => a -> a -> Bool
/=String
supLoc
                                         then XName -> Maybe XName
forall a. a -> Maybe a
Just (String -> XName
xname String
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 String
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 String
-> 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 String
myLocString -> String -> Bool
forall a. Eq a => a -> a -> Bool
/=String
supLoc then XName -> Maybe XName
forall a. a -> Maybe a
Just (String -> XName
xname String
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 String
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 :: String
myLoc  = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"NUL"
                         (QName -> Map QName String -> Maybe String
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 QName -> Map QName [(QName, String)] -> Maybe [(QName, String)]
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 -> ((QName, String) -> (XName, Maybe XName))
-> [(QName, String)] -> [(XName, Maybe XName)]
forall a b. (a -> b) -> [a] -> [b]
map (\ (QName
x,String
loc)->(QName -> XName
XName QName
x,if String
locString -> String -> Bool
forall a. Eq a => a -> a -> Bool
/=String
myLoc
                                                          then XName -> Maybe XName
forall a. a -> Maybe a
Just (String -> XName
xname String
loc)
                                                          else Maybe XName
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 = [Text]: elem_oneOf 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 String -> Decl
ElementsAttrs ({-name-}String -> XName
xname (String -> XName) -> String -> 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 (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     = String -> QName
N (String -> QName) -> String -> QName
forall a b. (a -> b) -> a -> b
$ NameAndType -> String
theName NameAndType
n
                             myLoc :: String
myLoc  = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"NUL"
                                          (QName -> Map QName String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QName
nm (Environment -> Map QName String
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 String -> Decl
ElementAbstractOfType
                                 (QName -> XName
XName QName
nm)
                                 (Schema -> QName -> XName
checkXName Schema
s QName
t)
                                 (case QName -> Map QName [(QName, String)] -> Maybe [(QName, String)]
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 ->
                                      ((QName, String) -> (XName, Maybe XName))
-> [(QName, String)] -> [(XName, Maybe XName)]
forall a b. (a -> b) -> [a] -> [b]
map (\ (QName
x,String
loc)->(QName -> XName
XName QName
x,
                                                       if String
locString -> String -> Bool
forall a. Eq a => a -> a -> Bool
/=String
myLoc
                                                       then XName -> Maybe XName
forall a. a -> Maybe a
Just (String -> XName
xname String
loc)
                                                       else Maybe XName
forall a. Maybe a
Nothing)) [(QName, String)]
xs)
                                 (Annotation -> Maybe String
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 -> String -> [Decl]
forall a. HasCallStack => String -> a
error (String -> [Decl]) -> String -> [Decl]
forall a b. (a -> b) -> a -> b
$ String
"<topElementDecl> unknown element reference "
                            String -> String -> String
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 (String -> XName) -> String -> XName
forall a b. (a -> b) -> a -> b
$ NameAndType -> String
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 String
elem_comment  = Annotation -> Maybe String
comment (Annotation -> Maybe String) -> Annotation -> Maybe String
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 =
                                              occursToModifier (elem_occurs ed)
                                      , elem_byRef = 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 (String -> QName
N (String -> QName) -> String -> QName
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 =
                                               occursToModifier (elem_occurs ed)
                                            , elem_byRef = 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 [] Maybe [XName]
forall a. Maybe a
Nothing Maybe String
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{}   -> String -> XName
xname String
"SomethingPrimitive"
                            Left st :: SimpleType
st@Restricted{}  -> (\XName
x-> XName -> (String -> XName) -> Maybe String -> XName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe XName
x String -> XName
xname
                                                          (SimpleType -> Maybe String
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 (String -> XName
xname String
"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{}      -> String -> XName
xname String
"SomethingListy"
                            Left st :: SimpleType
st@UnionOf{}     -> String -> XName
xname String
"SomethingUnionLike"
                            Right c :: ComplexType
c@ComplexType{} -> XName -> (String -> XName) -> Maybe String -> XName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ElementDecl -> XName
localTypeExp ElementDecl
ed{elem_content=Nothing})
                                                           String -> XName
xname
                                                     (Maybe String -> XName) -> Maybe String -> 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 (String -> XName) -> String -> 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   -> Attribute -> [Attribute]
forall a. a -> [a]
singleton (Attribute -> [Attribute]) -> Attribute -> [Attribute]
forall a b. (a -> b) -> a -> b
$
                     XName -> XName -> Bool -> Maybe String -> Attribute
Attribute (String -> XName
xname (String -> XName) -> String -> XName
forall a b. (a -> b) -> a -> b
$ NameAndType -> String
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 (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 Use -> Use -> Bool
forall a. Eq a => a -> a -> Bool
== Use
Required)
                               (Annotation -> Maybe String
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 -> String -> [Attribute]
forall a. HasCallStack => String -> a
error (String -> [Attribute]) -> String -> [Attribute]
forall a b. (a -> b) -> a -> b
$ String
"<attributeDecl> unknown attribute reference "
                                          String -> String -> String
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   -> (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 -> String -> [Attribute]
forall a. HasCallStack => String -> a
error (String -> [Attribute]) -> String -> [Attribute]
forall a b. (a -> b) -> a -> b
$ String
"unknown attribute group reference "
                                          String -> String -> String
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 (ChoiceOrSeq -> Maybe ChoiceOrSeq -> ChoiceOrSeq
forall a. a -> Maybe a -> a
fromMaybe (String -> ChoiceOrSeq
forall a. HasCallStack => String -> a
error String
"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 String -> Decl
Haskell.Group (String -> XName
xname String
n)
                                         ((Element -> Element) -> [Element] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (\Element
e->Element
e{elem_modifier=
                                                         combineOccursModifier
                                                             (group_occurs g)
                                                             (elem_modifier e)})
                                              [Element]
es)
                                         (Annotation -> Maybe String
comment (Group -> Annotation
group_annotation Group
g))
        Right (QN Namespace
_ String
ref) -> case QName -> Map QName Group -> Maybe Group
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (String -> QName
N String
ref) (Environment -> Map QName Group
env_group Environment
env) of
                       Maybe Group
Nothing -> String -> [Decl]
forall a. HasCallStack => String -> a
error (String -> [Decl]) -> String -> [Decl]
forall a b. (a -> b) -> a -> b
$ String
"bad group reference "
                                       String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
printableName (String -> QName
N String
ref)
                       Just Group
g' -> Group -> [Decl]
group Group
g'{ group_occurs=group_occurs 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 String -> Decl
Haskell.Group (String -> XName
xname (String
"unknown-group-"String -> String -> String
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=group_occurs 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 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)   = String -> [Element]
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
                                                     ((ElementEtc -> [Element]) -> [ElementEtc] -> [[Element]]
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) = (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 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 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 String
comment (Documentation String
s) = String -> Maybe String
forall a. a -> Maybe a
Just String
s
comment (AppInfo String
s)       = String -> Maybe String
forall a. a -> Maybe a
Just String
s
comment (NoAnnotation String
_)  = Maybe String
forall a. Maybe a
Nothing

xname :: String -> XName
xname :: String -> XName
xname = QName -> XName
XName (QName -> XName) -> (String -> QName) -> String -> 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 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
uri = QName -> XName
XName (QName -> XName) -> QName -> 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 (QName -> XName)
-> (PrimitiveType -> QName) -> PrimitiveType -> XName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> QName
xsd (String -> QName)
-> (PrimitiveType -> String) -> PrimitiveType -> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimitiveType -> String
forall a. Show a => a -> String
show (PrimitiveType -> XName) -> PrimitiveType -> XName
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 FacetType -> [FacetType] -> Bool
forall a. Eq a => a -> [a] -> Bool
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 ((Occurs -> (FacetType, Annotation, String) -> Occurs)
-> Occurs -> [(FacetType, Annotation, String)] -> Occurs
forall b a. (b -> a -> b) -> b -> [a] -> b
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 Maybe Int
forall a. Maybe a
Nothing Maybe Int
forall a. Maybe a
Nothing) [(FacetType, Annotation, String)]
occurs)
          (Annotation -> Maybe String
comment (Annotation -> Maybe String) -> Annotation -> Maybe String
forall a b. (a -> b) -> a -> b
$ [Annotation] -> Annotation
forall a. Monoid a => [a] -> a
mconcat [ Annotation
ann | (FacetType
_,Annotation
ann,String
_) <- [(FacetType, Annotation, String)]
occurs]) | [(FacetType, Annotation, String)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FacetType, Annotation, String)]
occurs]
    ) [Restrict] -> [Restrict] -> [Restrict]
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 ]
    [Restrict] -> [Restrict] -> [Restrict]
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 | [(String, Maybe String)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, Maybe String)]
enum]
    ) [Restrict] -> [Restrict] -> [Restrict]
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 FacetType -> [FacetType] -> Bool
forall a. Eq a => a -> [a] -> Bool
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
          ((Occurs -> (FacetType, Annotation, String) -> Occurs)
-> Occurs -> [(FacetType, Annotation, String)] -> Occurs
forall b a. (b -> a -> b) -> b -> [a] -> b
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 Maybe Int
forall a. Maybe a
Nothing Maybe Int
forall a. Maybe a
Nothing) [(FacetType, Annotation, String)]
occurs)
          (Annotation -> Maybe String
comment (Annotation -> Maybe String) -> Annotation -> Maybe String
forall a b. (a -> b) -> a -> b
$ [Annotation] -> Annotation
forall a. Monoid a => [a] -> a
mconcat [ Annotation
ann | (FacetType
_,Annotation
ann,String
_) <- [(FacetType, Annotation, String)]
occurs]) | [(FacetType, Annotation, String)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FacetType, Annotation, String)]
occurs]
    )

singleton :: a -> [a]
singleton :: forall a. 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, String) -> Occurs
consolidate (Occurs Maybe Int
min Maybe Int
max) (FacetType
OrderedBoundsMinIncl,Annotation
_,String
n) =
             Maybe Int -> Maybe Int -> Occurs
Occurs (Int -> Maybe Int
forall a. a -> Maybe a
Just (String -> Int
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 (Int -> Maybe Int
forall a. a -> Maybe a
Just (String -> Int
forall a. Read a => String -> a
read String
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
_,String
n) =
             Maybe Int -> Maybe Int -> Occurs
Occurs Maybe Int
min (Int -> Maybe Int
forall a. a -> Maybe a
Just (String -> Int
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 (Int -> Maybe Int
forall a. a -> Maybe a
Just (String -> Int
forall a. Read a => String -> a
read String
n Int -> Int -> Int
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 (Int -> Maybe Int
forall a. a -> Maybe a
Just (String -> Int
forall a. Read a => String -> a
read String
n)) (Int -> Maybe Int
forall a. a -> Maybe a
Just (String -> Int
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 (Int -> Maybe Int
forall a. a -> Maybe a
Just (String -> Int
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 (Int -> Maybe Int
forall a. a -> Maybe a
Just (String -> Int
forall a. Read a => String -> a
read String
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 :: 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 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