summaryrefslogtreecommitdiff
path: root/src/Text/XML/HaXml/Schema/HaskellTypeModel.hs
blob: 0c061ef3df61db24bc34b0ac30d61327f3a44299 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
-- | A type model for Haskell datatypes that bears a reasonable correspondence
--   to the XSD type model.
module Text.XML.HaXml.Schema.HaskellTypeModel
  ( module Text.XML.HaXml.Schema.HaskellTypeModel
  ) where

import Text.XML.HaXml.Schema.NameConversion
import Text.XML.HaXml.Schema.XSDTypeModel (Schema(..),Occurs)
import Text.XML.HaXml.Schema.Parse (lookupBy)
import Text.XML.HaXml.Types (QName(..),Namespace(..))
import Data.List (partition)

-- | Comments can be attached to most things, but not all of them will exist.
type Comment   = Maybe String

-- | The whole Haskell module.
data Module    = Module
                 { module_name        :: XName   -- the name of this module
                 , module_xsd_ns      :: Maybe XName -- xmlns:prefix for XSD
                 , module_re_exports  :: [Decl]  -- modules imported + exported
                 , module_import_only :: [Decl]  -- module + alias
                 , module_decls       :: [Decl]  -- the body of the module
                 }

-- | There are essentially simple types, and complex types, each of which
--   can be either restricted or extended.  There are four kinds of complex
--   type: choices, sequences, named groups, or a simple element with content.
data Decl
                 -- becomes type T = S
               = NamedSimpleType     XName XName Comment

                 -- becomes newtype T = T S
                 --       + instance Restricts T S where restricts ...
               | RestrictSimpleType  XName XName [Restrict] Comment

                 -- becomes data T  = T  S Tf
                 --       + data Tf = Tf {fields}
                 --       + instance Extension T S Tf where ...
               | ExtendSimpleType    XName XName [Attribute] Comment

                 -- becomes data T = Ta S0 | Tb S1 | Tc S2 | ...
               | UnionSimpleTypes    XName [XName] Comment

                 -- becomes data T = T_C0 | T_C1 | T_C2 | ...
               | EnumSimpleType      XName [(XName,Comment)] Comment

                 -- becomes data T  = T { singleattr, fields }
                 --   or    data T  = T { manyattr, singlefield }
                 --   or    data T  = T { t_attrs :: Ta, fields }
                 --       + data Ta = Ta { attributes }
               | ElementsAttrs XName [Element] [Attribute] Comment

                 -- or if T is abstract, it becomes
                 --         data T = T_A  A
                 --                | T_B  B
                 --                | FwdDecl fc c => T_C (fc->c) fc
                 --                | ...
                 --         data FwdC = FwdC -- because C is not yet in scope
                 --         instance FwdDecl FwdC C  -- later, at defn of C
                 --
                 -- In fact, it is better to move the declaration of type C
                 -- here, rather than use a FwdDecl proxy.  This will require
                 -- some patching later where C was originally declared.
                 --         data T = T_A  A
                 --                | T_B  B
                 --                | T_C  C -- but C not yet declared
                 --                | ...
                 --         data C = ... -- because C is not yet in scope
                 --         -- later, at true defn site of C, omit its decl.
                 --
                 -- An earlier solution was
                 --         class T a where parseT :: String -> XMLParser a
                 --         instance T A
                 --         instance T B
                 --         instance T C
                 -- but this is incorrect because the choice between A|B|C
                 -- rests with the input doc, not with the caller of the parser.
               | ElementsAttrsAbstract {-typename-}XName
                                       {-subtypes-}[(XName,Maybe XName)]
                                 -- ^ [(type name, module where declared later)]
                                       Comment

                 -- becomes function
                 --    elementE :: Parser T
                 --    elementE = parseSchemaType "E"
               | ElementOfType Element
                 -- or, if E is abstract, with substitutionGroup {Foo,Bar},
                 --    elementE = fmap T_Foo elementFoo `onFail`
                 --               fmap T_Bar elementBar `onFail` ...
               | ElementAbstractOfType {-element name-}XName
                                       {-abstract type name-}XName
                                       {-substitute elems and fwddecls-}
                                           [(XName,Maybe XName)]
                                       Comment

                 -- becomes (global) data T = E0 e0 | E1 e1 | E2 e2 | E3 e3
                 -- becomes (local)  OneOfN e0 e1 e2 e3
               | Choice XName [Element] Comment

                 -- becomes data GroupT = GT e0 e1 e2 e3
               | Group  XName [Element] Comment

      {-         -- becomes data GroupT = GT e0 e1 e2 e3
               | GroupAttrs XName [Attribute] Comment
      -}
                 -- becomes newtype T = T S
                 --       + different (more restrictive) parser
               | RestrictComplexType  XName XName Comment

                 -- becomes data T  = T  {fields}
                 --       + instance Extension T S where ...
                 -- or when T extends an _abstract_ XSDtype S, defined in an
                 -- earlier module, it additionally has
                 --        instance FwdDecl FwdT T
               | ExtendComplexType XName XName [Element] [Attribute]
                                               [Element] [Attribute]
                                               {-FwdDecl req'd-}(Maybe XName)
                                               {-supertype abstract?-}Bool
                                               {-grandsupertypes-}[XName]
                                               Comment
                 -- or when T is itself abstract, extending an abstract type S
                 --        class T a where parseT :: String -> XMLParser a
                 --        instance (T a) => S a where parseS = parseT
               | ExtendComplexTypeAbstract XName XName
                                       {-subtypes-}[(XName,Maybe XName)]
                                       {-FwdDecl instnc req'd-}(Maybe XName)
                                       {-grandsupertypes-}[XName]
                                       Comment

                 -- becomes an import and re-export
               | XSDInclude XName Comment
                 -- becomes an import only
               | XSDImport  XName (Maybe XName) Comment
                 -- a top-level annotation
               | XSDComment Comment
                 deriving (Eq,Show)

data Element   = Element { elem_name     :: XName
                         , elem_type     :: XName
                         , elem_modifier :: Modifier
                         , elem_byRef    :: Bool
                         , elem_locals   :: [Decl]
                      -- , elem_abstract :: Bool
                         , elem_substs   :: Maybe [XName] -- substitutable elems
                         , elem_comment  :: Comment
                         }
               | OneOf   { elem_oneOf    :: [[Element]]
                         , elem_modifier :: Modifier
                         , elem_comment  :: Comment
                         }
               | AnyElem { elem_modifier :: Modifier
                         , elem_comment  :: Comment
                         }
               | Text -- for mixed content
                 deriving (Eq,Show)
data Attribute = Attribute { attr_name    :: XName
                           , attr_type    :: XName
                           , attr_required:: Bool
                           , attr_comment :: Comment
                           }
                 deriving (Eq,Show)

data Modifier  = Single
               | Optional
               | Range Occurs
                 deriving (Eq,Show)

-- | Restrictions on simpleType
data Restrict  = RangeR Occurs Comment
               | Pattern String{-really Regexp-} Comment
               | Enumeration [(String,Comment)]
               | StrLength Occurs Comment
                 deriving (Eq,Show)


-- | A helper for building the formal Module structure.
mkModule :: String -> Schema -> [Decl] -> Module
mkModule name schema decls =
                      Module { module_name        = XName $ N name
                             , module_xsd_ns      = xsdQualification
                                                      (schema_namespaces schema)
                             , module_re_exports  = reexports
                             , module_import_only = imports
                             , module_decls       = theRest
                             }
    where (reexports,other)   = partition xsdinclude decls
          (imports,  theRest) = partition xsdimport  other
          xsdinclude (XSDInclude _ _)  = True
          xsdinclude _                 = False
          xsdimport  (XSDImport _ _ _) = True
          xsdimport  _                 = False
          xsdQualification nss = fmap (XName . N . nsPrefix) $
                                      lookupBy ((==xsd).nsURI) nss
              where xsd = "http://www.w3.org/2001/XMLSchema"