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

------------------------------------------------------------------------------
--- This module contains some useful operations on the data types representing
--- entity/relationship diagrams
---
--- @author Michael Hanus
--- @version January 2018
--- @category database
------------------------------------------------------------------------------

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, removeFile )
import Distribution    ( installDir, stripCurrySuffix )
import FlatCurry.Types
import FlatCurry.Files
import FlatCurry.Goodies
import IOExts          ( evalCmd, readCompleteFile )
import List            ( intersperse )
import Maybe
import System          ( getEnviron, getPID, system )

--- The name of an ERD.
erdName :: ERD -> String
erdName (ERD name _ _) = name

--- The name of an entity.
entityName :: Entity -> String
entityName (Entity n _) = n

--- Is this an entity with a given name?
isEntityNamed :: String -> Entity -> Bool
isEntityNamed n e = entityName e == n

--- Has the entity an attribute with a foreign key for a given entity name?
hasForeignKey :: String -> Entity -> Bool
hasForeignKey ename (Entity _ attrs) = any isForeignKeyWithName attrs
 where
  isForeignKeyWithName (Attribute _ d _ _) = case d of KeyDom n -> n==ename
                                                       _        -> False

--- Returns the attributes that are a foreign key of a given entity name.
foreignKeyAttributes :: String -> [Attribute] -> [Attribute]
foreignKeyAttributes ename attrs = filter isForeignKeyWithName attrs
 where
  isForeignKeyWithName (Attribute _ d _ _) = case d of KeyDom n -> n==ename
                                                       _        -> False

--- Returns the names of the foreign key attributes for a given entity name.
foreignKeyAttrNames :: String -> [Attribute] -> [String]
foreignKeyAttrNames ename attrs =
  map attributeName (filter isForeignKeyWithName attrs)
 where
  isForeignKeyWithName (Attribute _ d _ _) = case d of KeyDom n -> n==ename
                                                       _        -> False

--- The attributes of an entity
entityAttributes :: Entity -> [Attribute]
entityAttributes (Entity _ attrs) = attrs

--- The name of an attribute.
attributeName :: Attribute -> String
attributeName (Attribute name _ _ _) = name

--- The domain of an attribute.
attributeDomain :: Attribute -> Domain
attributeDomain (Attribute _ d _ _) = d

--- Has an attribute domain a default value?
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

---- Is an attribute a (generated) foreign key?
isForeignKey :: Attribute -> Bool
isForeignKey (Attribute _ d _ _) = case d of KeyDom _ -> True
                                             _        -> False

--- Has an attribute a null value?
isNullAttribute :: Attribute -> Bool
isNullAttribute (Attribute _ _ _ isnull) = isnull

--- The minimum value of a cardinality.
cardMinimum :: Cardinality -> Int
cardMinimum (Exactly i) = i
cardMinimum (Between i _) = i

--- The maximum value of a cardinality (provided that it is not infinite).
cardMaximum :: Cardinality -> Int
cardMaximum (Exactly i) = i
cardMaximum (Between _ (Max i)) = i


--- A simple pretty printer for ERDs.
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 ' ')


--- Combines a non-empty list of identifiers into a single identifier.
--- Used in ERD transformation and code generation to create
--- names for combined objects, e.g., relationships and foreign keys.
combineIds :: [String] -> String
combineIds (name:names) = name ++ concatMap maybeAddUnderscore names
 where
  maybeAddUnderscore [] = "_"
  maybeAddUnderscore s@(c:_) = if isUpper c then s else '_' : s

------------------------------------------------------------------------------
-- Auxiliaries to generate ERD term file from a ERD definition given
-- in a Curry program.

--- Writes the ERD defined in a Curry program (as a top-level operation
--- of type `Database.ERD.ERD`) in a term file and return the name of
--- the term file.
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 currypath <- getEnviron "CURRYPATH"
               pid <- getPID
               let tmpfile = "/tmp/ERD2CURRY_tmp_" ++ show pid
               let cmd = installDir++"/bin/curry"
                   args  = [ "--nocypm"
                           , ":set","v0" ]
                   input = unlines $
                            (if null currypath
                               then []
                               else [":set path " ++ currypath] ) ++
                            [ ":load " ++ progname
                            , ":add " ++ "Database.ERD"
                            , ":eval " ++
                                "Database.ERD.writeERDTermFile " ++
                                snd (funcName fd) ++
                                " >>= writeFile " ++ show tmpfile
                            , ":quit"]
               (ecode,outstr,errstr) <- evalCmd cmd args input
               if ecode > 0
                 then error $ "ERROR in ERD term file generation:\n" ++ errstr
                 else do erdtermfile <- readCompleteFile tmpfile
                         removeFile tmpfile
                         return erdtermfile
    _ -> error $ "Multiple ER model definitions found in program " ++ progfile

hasERDType fdecl = funcType fdecl == TCons ("Database.ERD","ERD") []

------------------------------------------------------------------------------