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
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
|
{-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-}
module Database.ERD.FromXML ( convert ) where
import Data.Char
import Data.List
import Data.Maybe
import Database.ERD
import Data.Time
import XML
findElements :: [XmlExp] -> [String] -> [XmlExp]
findElements [] _ = []
findElements (x@(XElem t _ _) : xs) [s]
| t == s = (x : findElements xs [s])
| otherwise = findElements xs [s]
findElements ((XElem t _ content) : xs) (z:y:ys)
| t == z = findElements content (y:ys)
| otherwise = findElements xs (z:y:ys)
getContent :: XmlExp -> [XmlExp]
getContent (XElem _ _ content) = content
getContent (XText _) = []
getUMLModel :: [XmlExp] -> String -> [XmlExp]
getUMLModel [] _ = []
getUMLModel (x@(XElem tag _ _):xs) name
| tag == "UML:Model" = case (lookup "name" (getAttrs x)) of
Just d -> if d == name then getContent x
else getUMLModel xs name
Nothing -> getUMLModel xs name
| otherwise = getUMLModel xs name
convert :: XmlExp -> ERD
convert xml =
let contentxml = getContent
(head
(findElements
[xml]
["XMI","XMI.content","UML:Model",
"UML:Namespace.ownedElement"]))
logicalView = getContent
(head
(findElements
(getUMLModel contentxml "Logical View")
["UML:Namespace.ownedElement"]))
erm = getUMLModel contentxml "Entity Relationship Model"
exml = findElements erm ["UML:Namespace.ownedElement",
"UML:Entity"]
rxml = findElements erm ["UML:Namespace.ownedElement",
"UML:Association"]
idlist = (iddata logicalView) ++ (identities exml)
name = fromJust
(lookup "name"
(getAttrs
(head (findElements
erm
["XMI.extension","diagrams",
"diagram"]))))
es = map (convertE idlist) exml
rs = map (convertR idlist) rxml
in
if uniqueNames es rs
then ERD name es rs
else error "names (entity, relationship, role) in er-diagramm not unique"
uniqueNames :: [Entity] -> [Relationship] -> Bool
uniqueNames es rs =
length es + length rs == length (nub ((map eName es)++(concatMap rNames rs)))
eName :: Entity -> String
eName (Entity n _) = n
rNames :: Relationship -> [String]
rNames (Relationship rn [REnd r1 _ _, REnd r2 _ _]) = [rn, r1, r2]
iddata :: [XmlExp] -> [(String,String)]
iddata [] = []
iddata (x@(XElem t attrs _):elems)
| t == "UML:DataType" || t == "UML:Class" =
let id = fromJust (lookup "xmi.id" attrs)
name = fromJust (lookup "name" attrs)
in
(id,name) : iddata elems
| t == "UML:Package" =
(iddata (findElements [x]
["UML:Package","UML:Namespace.ownedElement",
"UML:DataType"]))
++ (iddata elems)
| otherwise = iddata elems
identities :: [XmlExp] -> [(String,String)]
identities [] = []
identities ((XElem t attrs _):elems)
| t == "UML:Entity" =
let id = fromJust (lookup "xmi.id" attrs)
name = fromJust (lookup "name" attrs)
in
(id,name) : identities elems
| otherwise = identities elems
getAttrs :: XmlExp -> [(String, String)]
getAttrs (XElem _ attrs _) = attrs
convertE :: [(String, String)] -> XmlExp -> Entity
convertE idlist (XElem "UML:Entity" attrs alist) =
let name = fromJust (lookup "name" attrs)
attributes = map (convertAttr idlist) alist
in
if null alist
then error ("Entity " ++ name ++ " without attributes")
else Entity name (map (checkAttr name) attributes)
checkAttr :: String -> Attribute -> Attribute
checkAttr ename (Attribute name domain key null) =
let n = if (isLower (head name))
then (toUpper (head name)):(tail name)
else name
v = getValue domain
in
if n == "Key"
then error ("attribute name Key is not allowed in entity "++ename)
else if v
then
if null
then error ("attribute "++name
++" with default value should not be null in entity "++ename)
else if key==Unique
then error ("attribute "++name
++" with unique value should not be null in entity "
++ename)
else Attribute n domain key null
else Attribute n domain key null
getValue :: Domain -> Bool
getValue (IntDom Nothing) = False
getValue (IntDom (Just _)) = True
getValue (FloatDom Nothing) = False
getValue (FloatDom (Just _)) = True
getValue (CharDom Nothing) = False
getValue (CharDom (Just _)) = True
getValue (StringDom Nothing) = False
getValue (StringDom (Just _)) = True
getValue (BoolDom Nothing) = False
getValue (BoolDom (Just _)) = True
getValue (DateDom Nothing) = False
getValue (DateDom (Just _)) = True
getValue (UserDefined _ Nothing) = False
getValue (UserDefined _ (Just _)) = True
convertR :: [(String, String)] -> XmlExp -> Relationship
convertR idlist
(XElem "UML:Association" attrs
[(XElem "UML:Association.connection" _ [end1, end2])]) =
let name = fromJust (lookup "name" attrs)
rends = [convertREnd idlist end1,
convertREnd idlist end2]
in
if twoMin rends
then error ("relationship " ++ name ++ " has two minima")
else if name==""
then error "relationship without name"
else Relationship (toUpper (head name) : tail name) rends
where
convertREnd :: [(String, String)] -> XmlExp -> REnd
convertREnd idl (XElem "UML:AssociationEnd" alist _) =
let t = fromJust (lookup "type" alist)
name = fromJust (lookup "name" alist)
mult = lookup "multiplicity" alist
in
if name==""
then error "role without name"
else REnd (fromJust (lookup t idl))
(toLower (head name) : tail name)
(convertCard mult)
twoMin [REnd _ _ c1, REnd _ _ c2] = case c1 of
Between i _ -> if i > 0
then case c2 of Between j _ -> j > 0
Exactly _ -> False
else False
Exactly _ -> case c2 of Between m _ -> m > 0
Exactly _ -> True
convertCard :: Maybe String -> Cardinality
convertCard c = case c of
Nothing -> error "cardinality missing"
Just "m" -> Between 0 Infinite
Just "n" -> Between 0 Infinite
Just ('(':m:ms) -> let (min, (_:max')) = break (== ',') (m:ms)
max = fst (break (== ')') max')
in
if all isDigit min
then let minimum = read min
in
if all isDigit max
then if minimum == read max then Exactly minimum
else if minimum < read max
then Between minimum (Max (read max))
else error "wrong cardinality"
else Between minimum Infinite
else error "wrong cardinality (min)"
Just i -> if all isDigit i
then let e = read i
in
if e > 0 then Exactly e else error "cardinality <= 0"
else error "wrong cardinality"
convertAttr :: [(String, String)] -> XmlExp -> Attribute
convertAttr idlist (XElem "UML:EntityAttribute" alist _) =
let t = fromJust (lookup "type" alist)
name = fromJust (lookup "name" alist)
init = lookup "initialValue" alist
d = convertDomain (lookup t idlist) init
dbindex_type = fromJust (lookup "dbindex_type" alist)
pkey = if dbindex_type == "1101"
then PKey
else if dbindex_type == "1103"
then Unique
else NoKey
allow_null = fromJust (lookup "allow_null" alist)
null = if allow_null == "0"
then False
else True
in
Attribute name d pkey null
int :: [String]
int = ["Int","int"]
char :: [String]
char = ["Char", "char"]
string :: [String]
string = ["String","string", "text", "varchar"]
float :: [String]
float = ["Float", "float", "Double", "double"]
bool :: [String]
bool = ["Bool", "bool"]
date :: [String]
date = ["Date", "date"]
convertDomain :: Maybe String -> Maybe String -> Domain
convertDomain Nothing _ = error "domain missing"
convertDomain (Just t) Nothing
| elem t int = IntDom Nothing
| elem t float = FloatDom Nothing
| elem t char = CharDom Nothing
| elem t string = StringDom Nothing
| elem t bool = BoolDom Nothing
| elem t date = DateDom Nothing
| otherwise = UserDefined t Nothing
convertDomain (Just t) (Just d) =
if d == ""
then convertDomain (Just t) Nothing
else convertD t d
where
convertD :: String -> String -> Domain
convertD typ dom
| elem typ int = IntDom (Just (read dom))
| elem typ float = FloatDom (Just (read dom))
| elem typ char = CharDom (Just (head dom))
| elem typ string = StringDom (Just dom)
| elem typ bool = if dom == "true"
then BoolDom (Just True)
else BoolDom (Just False)
| elem t date = DateDom (Just (parseDate dom))
| otherwise = UserDefined t (Just d)
parseDate :: String -> CalendarTime
parseDate s =
let (ts,_:cs) = break (== ' ') s
d1 = break (== '.') ts
day = read (fst d1)
d2 = break (== '.') (tail (snd d1))
month = read (fst d2)
year = read (tail (snd d2))
c1 = break (== ':') cs
hour = read (fst c1)
c2 = break (== ':') (tail (snd c1))
minute = read (fst c2)
second = read (tail (snd c2))
in
CalendarTime year month day hour minute second 0
|