summaryrefslogtreecommitdiff
path: root/src/Text/XML/HaXml/Schema/TypeConversion.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Text/XML/HaXml/Schema/TypeConversion.hs')
-rw-r--r--src/Text/XML/HaXml/Schema/TypeConversion.hs148
1 files changed, 112 insertions, 36 deletions
diff --git a/src/Text/XML/HaXml/Schema/TypeConversion.hs b/src/Text/XML/HaXml/Schema/TypeConversion.hs
index 62d2efd..5cbd8ff 100644
--- a/src/Text/XML/HaXml/Schema/TypeConversion.hs
+++ b/src/Text/XML/HaXml/Schema/TypeConversion.hs
@@ -17,6 +17,78 @@ import Data.List (foldl')
import Data.Maybe (fromMaybe,fromJust,isNothing,isJust)
import Data.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 s = s{ schema_items =
+ concat [ hoist e | SchemaElement e <- schema_items s ]
+ ++ map renameLocals (schema_items s) }
+ where
+ hoist :: ElementDecl -> [SchemaItem]
+ hoist e = flip concatMap (findE e) $
+ \e@ElementDecl{elem_nameOrRef=Left (NT{ theName=n
+ {-, theType=Nothing-}})}->
+ localType n (elem_content e)
+
+ findE :: ElementDecl -> [ElementDecl]
+ findE e = ( case elem_nameOrRef e of
+ Left (NT{theType=Nothing}) -> (e:)
+ Left (NT{theType=Just t}) -> case elem_content e of
+ Just (Right
+ (ComplexType
+ {complex_name=Just t'}))
+ {-| t==t'-}
+ -> (e:)
+ _ -> id
+ _ -> id
+ ) $
+ ( case elem_content e of
+ Nothing -> []
+ Just (Left _) -> []
+ Just (Right c) ->
+ case complex_content c of
+ v@SimpleContent{ci_stuff=Left (Restriction1 p)} -> particle p
+ v@SimpleContent{ci_stuff=Right (Extension{extension_newstuff=PA p _ _})} -> particle p
+ v@ComplexContent{ci_stuff=Left (Restriction1 p)} -> particle p
+ v@ComplexContent{ci_stuff=Right (Extension{extension_newstuff=PA p _ _})} -> particle p
+ v@ThisType{ci_thistype=PA p _ _} -> particle p
+ )
+ particle Nothing = []
+ particle (Just (Left cos)) = choiceOrSeq cos
+ particle (Just (Right g)) = maybe [] choiceOrSeq $ group_stuff g
+ choiceOrSeq (XSD.All _ es) = concatMap findE es
+ choiceOrSeq (XSD.Choice _ _ es) = concatMap etc es
+ choiceOrSeq (XSD.Sequence _ _ es) = concatMap etc es
+ etc (HasElement e) = findE e
+ etc (HasGroup g) = maybe [] choiceOrSeq $ group_stuff g
+ etc (HasCS cos) = choiceOrSeq cos
+ etc (HasAny _) = []
+
+ localType n Nothing = []
+ localType n (Just (Left s)) = [Simple (renameSimple n s)]
+ localType n (Just (Right c)) = [Complex c{ complex_name = Just n }]
+
+ renameSimple n s@Primitive{} = s
+ renameSimple n s@Restricted{} = s{ simple_name = Just n }
+ renameSimple n s@ListOf{} = s{ simple_name = Just n }
+ renameSimple n s@UnionOf{} = 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 s = 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.
@@ -186,17 +258,17 @@ convert env s = concatMap item (schema_items s)
({-elems-}es)
({-attrs-}as)
(comment (elem_annotation ed))
- , ElementOfType
- Element{ elem_name = xname (theName n)
- , elem_type = checkXName s (N $ theName n)
- , elem_modifier =
- Haskell.Range (elem_occurs ed)
- , elem_byRef = False
- , elem_locals = []
- , elem_substs = Nothing
- , elem_comment =
- (comment (elem_annotation ed))
- }
+ , ElementOfType $ elementDecl ed
+ -- Element{ elem_name = xname (theName n)
+ -- , elem_type = checkXName s (N $ theName n)
+ -- , elem_modifier =
+ -- Haskell.Range (elem_occurs ed)
+ -- , elem_byRef = False
+ -- , elem_locals = []
+ -- , elem_substs = Nothing
+ -- , elem_comment =
+ -- (comment (elem_annotation ed))
+ -- }
]
Just t | elem_abstract ed ->
let nm = N $ theName n
@@ -213,20 +285,15 @@ convert env s = concatMap item (schema_items s)
$ Map.lookup nm (env_substGrp env))
(comment (elem_annotation ed))
Just t | otherwise ->
- singleton $ ElementOfType $
- Element{ elem_name = xname $ theName n
- , elem_type = checkXName s t
- , elem_modifier= Haskell.Range (elem_occurs ed)
- , elem_byRef = False
- , elem_locals = []
- , elem_substs = Nothing
- -- , elem_substs = if elem_abstract ed
- -- then fmap (map XName) $
- -- Map.lookup (N $ theName n)
- -- (env_substGrp env)
- -- else Nothing
- , elem_comment = comment (elem_annotation ed)
- }
+ singleton $ ElementOfType $ elementDecl ed
+ -- Element{ elem_name = xname $ theName n
+ -- , elem_type = checkXName s t
+ -- , elem_modifier= Haskell.Range (elem_occurs ed)
+ -- , elem_byRef = False
+ -- , elem_locals = []
+ -- , elem_substs = Nothing
+ -- , elem_comment = comment (elem_annotation ed)
+ -- }
Right ref -> case Map.lookup ref (env_element env) of
Nothing -> error $ "<topElementDecl> unknown element reference "
++printableName ref
@@ -234,15 +301,21 @@ convert env s = concatMap item (schema_items s)
elementDecl :: XSD.ElementDecl -> Haskell.Element
elementDecl ed = case elem_nameOrRef ed of
- Left n -> Element ({-name-}xname $ theName n)
- ({-type-}maybe (localTypeExp ed)
- XName
- (theType n))
- ({-modifier-}Haskell.Range $ elem_occurs ed)
- False -- by reference
- [] -- internal Decl
- Nothing -- substitution group
- (comment (elem_annotation ed))
+ Left n -> Element { elem_name = xname $ theName n
+ , elem_type = maybe (localTypeExp ed)
+ (checkXName s)
+ (theType n)
+ , elem_modifier = Haskell.Range $ elem_occurs ed
+ , elem_byRef = False -- by reference
+ , elem_locals = [] -- internal Decl
+ , elem_substs = 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 = comment $ elem_annotation ed
+ }
Right ref -> case Map.lookup ref (env_element env) of
Just e' -> (elementDecl e')
{ elem_modifier =
@@ -273,7 +346,8 @@ convert env s = concatMap item (schema_items s)
simple_restriction st)
Left st@ListOf{} -> xname "SomethingListy"
Left st@UnionOf{} -> xname "SomethingUnionLike"
- Right c@ComplexType{} -> xname $ fromMaybe "unknown"
+ Right c@ComplexType{} -> maybe (localTypeExp ed{elem_content=Nothing})
+ xname
$ complex_name c
| otherwise =
case elem_nameOrRef ed of
@@ -284,7 +358,9 @@ convert env s = concatMap item (schema_items s)
attributeDecl ad = case attr_nameOrRef ad of
Left n -> singleton $
Attribute (xname $ theName n)
- (maybe (maybe (error "XSD.attributeDecl->")
+ (maybe (maybe (xname $ "String")
+ -- guess at an attribute typename?
+ --(error "XSD.attributeDecl->")
nameOfSimple
(attr_simpleType ad))
XName