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
|
module Database.ERD.Goodies
( erdName, entityName, isEntityNamed, entityAttributes
, hasForeignKey, foreignKeyAttributes
, attributeName, attributeDomain, hasDefault
, isForeignKey, isNullAttribute
, cardMinimum, cardMaximum
, showERD, combineIds
, storeERDFromProgram
) where
import Char (isUpper)
import Database.ERD
import Directory (getAbsolutePath)
import Distribution (installDir,stripCurrySuffix)
import FlatCurry.Types
import FlatCurry.Files
import FlatCurry.Goodies
import IOExts (evalCmd)
import List (intersperse)
import Maybe
import System (system)
erdName :: ERD -> String
erdName (ERD name _ _) = name
entityName :: Entity -> String
entityName (Entity n _) = n
isEntityNamed :: String -> Entity -> Bool
isEntityNamed n e = entityName e == n
hasForeignKey :: String -> Entity -> Bool
hasForeignKey ename (Entity _ attrs) = any isForeignKeyWithName attrs
where
isForeignKeyWithName (Attribute _ d _ _) = case d of KeyDom n -> n==ename
_ -> False
foreignKeyAttributes :: String -> [Attribute] -> [Attribute]
foreignKeyAttributes ename attrs = filter isForeignKeyWithName attrs
where
isForeignKeyWithName (Attribute _ d _ _) = case d of KeyDom n -> n==ename
_ -> False
foreignKeyAttrNames :: String -> [Attribute] -> [String]
foreignKeyAttrNames ename attrs =
map attributeName (filter isForeignKeyWithName attrs)
where
isForeignKeyWithName (Attribute _ d _ _) = case d of KeyDom n -> n==ename
_ -> False
entityAttributes :: Entity -> [Attribute]
entityAttributes (Entity _ attrs) = attrs
attributeName :: Attribute -> String
attributeName (Attribute name _ _ _) = name
attributeDomain :: Attribute -> Domain
attributeDomain (Attribute _ d _ _) = d
hasDefault :: Domain -> Bool
hasDefault (IntDom d) = isJust d
hasDefault (FloatDom d) = isJust d
hasDefault (StringDom d) = isJust d
hasDefault (BoolDom d) = isJust d
hasDefault (DateDom d) = isJust d
hasDefault (UserDefined _ d) = isJust d
isForeignKey :: Attribute -> Bool
isForeignKey (Attribute _ d _ _) = case d of KeyDom _ -> True
_ -> False
isNullAttribute :: Attribute -> Bool
isNullAttribute (Attribute _ _ _ isnull) = isnull
cardMinimum :: Cardinality -> Int
cardMinimum (Exactly i) = i
cardMinimum (Between i _) = i
cardMaximum :: Cardinality -> Int
cardMaximum (Exactly i) = i
cardMaximum (Between _ (Max i)) = i
showERD :: Int -> ERD -> String
showERD n (ERD en es rs) = "ERD " ++ showString en ++ lb n ++
" [" ++ concat (intersperse ("," ++ lb (n+2)) (map (showEs (n+2)) es)) ++ "]"
++ lb n ++
" [" ++ concat (intersperse ("," ++ lb (n+2)) (map (showRs (n+2)) rs)) ++ "]"
showEs n (Entity en attrs) = "Entity " ++ showString en ++ lb (n+7) ++
"[" ++ concat (intersperse ("," ++ lb (n+8)) (map showWOBrackets attrs)) ++"]"
showRs n (Relationship rn ends) =
"Relationship " ++ showString rn ++ lb (n+13) ++
"[" ++ concat (intersperse ("," ++ lb (n+14)) (map showWOBrackets ends)) ++"]"
showWOBrackets t = stripBrackets (show t)
where
stripBrackets (c:cs) = if c=='(' then reverse (tail (reverse cs)) else c:cs
showString s = "\""++s++"\""
lb n = "\n" ++ take n (repeat ' ')
combineIds :: [String] -> String
combineIds (name:names) = name ++ concatMap maybeAddUnderscore names
where
maybeAddUnderscore [] = "_"
maybeAddUnderscore s@(c:_) = if isUpper c then s else '_' : s
storeERDFromProgram :: String -> IO String
storeERDFromProgram progfile = do
putStrLn $ "Creating ERD term file from program `" ++ progfile ++ "'..."
let progname = stripCurrySuffix progfile
prog <- readFlatCurry progname
let funcs = progFuncs prog
erdfuncs = filter hasERDType funcs
case erdfuncs of
[] -> error $ "No definition of ER model found in program " ++ progfile
[fd] -> do let cmd = installDir++"/bin/curry"
args = ["--nocypm"
,":set","v0",":load",progname
,":add","Database.ERD"
,":eval"
,"Database.ERD.writeERDTermFile " ++
snd (funcName fd) ++ " >>= putStrLn"
,":quit"]
(ecode,outstr,errstr) <- evalCmd cmd args ""
if ecode > 0
then error $ "ERROR in ERD term file generation:\n" ++ errstr
else return (head (lines outstr))
_ -> error $ "Multiple ER model definitions found in program " ++ progfile
hasERDType fdecl = funcType fdecl == TCons ("Database.ERD","ERD") []
|