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

------------------------------------------------------------------------------
--- This module contains the definition of data types to represent
--- entity/relationship diagrams and an I/O operation to read them
--- from a term file.
---
--- @author Michael Hanus, Marion Mueller
--- @version May 2017
--- @category database
------------------------------------------------------------------------------

module Database.ERD
  ( ERD(..), ERDName, Entity(..), EName, Entity(..)
  , Attribute(..), AName, Key(..), Null, Domain(..)
  , Relationship(..), REnd(..), RName, Role, Cardinality(..), MaxValue(..)
  , readERDTermFile, writeERDTermFile
  ) where

import Char         (isSpace)
import Directory    (getAbsolutePath)
import IO
import ReadShowTerm (readUnqualifiedTerm)
import Time

--- Data type to represent entity/relationship diagrams.
data ERD = ERD ERDName [Entity] [Relationship]
  deriving Show

type ERDName = String -- used as the name of the generated module


data Entity = Entity EName [Attribute]
  deriving Show

type EName = String

data Attribute = Attribute AName Domain Key Null
  deriving Show

type AName = String

data Key = NoKey
         | PKey
         | Unique
  deriving (Eq, Show)

type Null = Bool

data Domain = IntDom      (Maybe Int)
            | FloatDom    (Maybe Float)
            | CharDom     (Maybe Char)
            | StringDom   (Maybe String)
            | BoolDom     (Maybe Bool)
            | DateDom     (Maybe CalendarTime)
            | UserDefined String (Maybe String)
            | KeyDom      String  -- for foreign keys
  deriving Show


data Relationship = Relationship RName [REnd]
  deriving Show

type RName = String

data REnd = REnd EName Role Cardinality
  deriving Show

type Role = String

--- Cardinality of a relationship w.r.t. some entity.
--- The cardinality is either a fixed number (e.g., (Exactly 1)
--- representing the cardinality (1,1))
--- or an interval (e.g., (Between 1 (Max 4)) representing the
--- cardinality (1,4), or (Between 0 Infinite) representing the
--- cardinality (0,n)).
data Cardinality = Exactly Int
                 | Between Int MaxValue
  deriving Show

--- The upper bound of a cardinality which is either a finite number
--- or infinite.
data MaxValue = Max Int | Infinite
  deriving Show


--- Read an ERD specification from a file containing a single ERD term.
readERDTermFile :: String -> IO ERD
readERDTermFile termfilename = do
  putStrLn $ "Reading ERD term from file '" ++ termfilename ++ "'..."
  handle <- openFile termfilename ReadMode
  line <- skipCommentLines handle
  termstring <- hGetContents handle
  return (updateERDTerm (readUnqualifiedTerm ["Database.ERD","Prelude"]
                                             (unlines [line,termstring])))
 where
  skipCommentLines h = do
    line <- hGetLine h >>= return . dropWhile isSpace
    if null line || take 2 line == "--"
     then skipCommentLines h
     else if take 2 line == "{-" -- -}
          then skipBracketComment h (drop 2 line)
          else return line

  skipBracketComment h [] = hGetLine h >>= skipBracketComment h
  skipBracketComment h [_] = hGetLine h >>= skipBracketComment h
  skipBracketComment h (c1:c2:cs) =
   if c1=='-' && c2=='}' then return cs
                         else skipBracketComment h (c2:cs)

--- Transforms an ERD term possible containing old, outdated, information.
--- In particular, translate (Range ...) into (Between ...).
updateERDTerm :: ERD -> ERD
updateERDTerm (ERD name es rs) = ERD name es (map updateRel rs)
 where
   updateRel (Relationship r ends) = Relationship r (map updateEnd ends)

   updateEnd (REnd n r c) = REnd n r (updateCard c)

   updateCard (Exactly n) = Exactly n
   updateCard (Between min (Max m)) =
     if min<=m
     then Between min (Max m)
     else error ("ERD: Illegal cardinality " ++ show (Between min (Max m)))
   updateCard (Between min Infinite) = Between min Infinite

--- Writes an ERD term into a file with name `ERDMODELNAME.erdterm`
--- and returns the absolute path name of the generated term file.
writeERDTermFile :: ERD -> IO String
writeERDTermFile erd@(ERD name _ _) = do
  let termfile = name ++ ".erdterm"
  writeFile termfile (show erd)
  getAbsolutePath termfile

{-
-- Example ERD term:
(ERD "Uni"
 [Entity "Student" [Attribute "MatNum"    (IntDom Nothing) PKey False,
                    Attribute "Name"      (StringDom Nothing) NoKey False,
                    Attribute "Firstname" (StringDom Nothing) NoKey False,
                    Attribute "Email"     (UserDefined "MyModule.Email" Nothing)
                                          NoKey True],
  Entity "Lecture" [Attribute "Id"    (IntDom Nothing) PKey False,
                    Attribute "Title" (StringDom Nothing) Unique False,
                    Attribute "Hours" (IntDom (Just 4)) NoKey False],
  Entity "Lecturer" [Attribute "Id"        (IntDom Nothing) PKey False,
                     Attribute "Name"      (StringDom Nothing) NoKey False,
                     Attribute "Firstname" (StringDom Nothing) NoKey False],
  Entity "Group" [Attribute "Time" (StringDom Nothing) NoKey False]]
 [Relationship "Teaching"
               [REnd "Lecturer" "taught_by" (Exactly 1),
                REnd "Lecture"  "teaches"   (Between 0 Infinite)],
  Relationship "Participation"
               [REnd "Student" "participated_by" (Between 0 Infinite),
                REnd "Lecture" "participates"    (Between 0 Infinite)],
  Relationship "Membership"
               [REnd "Student" "consists_of" (Exactly 3),
                REnd "Group" "member_of"     (Between 0 Infinite)]])

-}