Commit fabf19fd authored by Michael Hanus's avatar Michael Hanus
Browse files

erd2curry and Spicey added to currytools

parent e683575d
......@@ -19,8 +19,10 @@ all:
@cd curry2js && $(MAKE)
@cd createmakefile && $(MAKE)
@cd currytest && $(MAKE)
@cd erd2curry && $(MAKE)
@cd genint && $(MAKE)
@cd importcalls && $(MAKE)
@cd spicey && $(MAKE)
@cd typeinference && $(MAKE)
.PHONY: currydoc
......@@ -41,6 +43,8 @@ clean:
cd curry2js && $(MAKE) clean
cd createmakefile && $(MAKE) clean
cd currytest && $(MAKE) clean
cd erd2curry && $(MAKE) clean
cd genint && $(MAKE) clean
cd importcalls && $(MAKE) clean
cd spicey && $(MAKE) clean
cd typeinference && $(MAKE) clean
(ERD "Blog"
[Entity "Entry"
[Attribute "Title" (StringDom Nothing) Unique False,
Attribute "Text" (StringDom Nothing) NoKey False,
Attribute "Author" (StringDom Nothing) NoKey False,
Attribute "Date" (DateDom Nothing) NoKey False],
Entity "Comment"
[Attribute "Text" (StringDom Nothing) NoKey False,
Attribute "Author" (StringDom Nothing) NoKey False,
Attribute "Date" (DateDom Nothing) NoKey False],
Entity "Tag"
[Attribute "Name" (StringDom Nothing) Unique False]
]
[Relationship "Commenting"
[REnd "Entry" "commentsOn" (Exactly 1),
REnd "Comment" "isCommentedBy" (Between 0 Infinite)],
Relationship "Tagging"
[REnd "Entry" "tags" (Between 0 Infinite),
REnd "Tag" "tagged" (Between 0 Infinite)]
]
)
This diff is collapsed.
------------------------------------------------------------------------------
--- 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 September 2010
------------------------------------------------------------------------------
module ERD(ERD(..),ERDName,Entity(..),EName,Entity(..),
Attribute(..),AName,Key(..),Null,Domain(..),
Relationship(..),REnd(..),RName,Role,Cardinality(..),MaxValue(..),
readERDTermFile) where
import Time
import ReadShowTerm(readUnqualifiedTerm)
--- Data type to represent entity/relationship diagrams.
data ERD = ERD ERDName [Entity] [Relationship]
type ERDName = String -- used as the name of the generated module
data Entity = Entity EName [Attribute]
type EName = String
data Attribute = Attribute AName Domain Key Null
type AName = String
data Key = NoKey
| PKey
| Unique
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 -- later used for foreign keys
data Relationship = Relationship RName [REnd]
type RName = String
data REnd = REnd EName Role Cardinality
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
| Range Int (Maybe Int) -- for backward compatibility
--- The upper bound of a cardinality which is either a finite number
--- or infinite.
data MaxValue = Max Int | Infinite
--- 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 ++ "..."
termstring <- readFile termfilename
return (updateERDTerm (readUnqualifiedTerm ["ERD","Prelude"] termstring))
--- 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
updateCard (Range min max) = updateCard (Between min (maybe Infinite Max max))
{-
-- 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)]])
-}
module ERD2Curry where
import PrettyAbstract
import XML
import XML2ERD
import ERD
import ERDGoodies
import Transformation
import CodeGeneration
import System(getArgs,system)
import FileGoodies(dirName)
import ReadShowTerm(readUnqualifiedTerm)
import Time
import Directory
import ERD2Graph
import System(exitWith)
import Distribution(curryCompiler)
banner = "ERD->Curry Compiler (Version of 10/11/13)\n"
--- Main function for saved state. The argument is the directory containing
--- these sources.
main erd2currydir = do
putStrLn banner
args <- getArgs
callStart erd2currydir (parseArgs ("",False,SQLite ".",False) args)
parseArgs :: (String,Bool,Storage,Bool) -> [String]
-> Maybe (String,Bool,Storage,Bool)
parseArgs _ [] = Nothing
parseArgs (file,fromxml,storage,vis) (arg:args) = case arg of
"-t" -> parseArgs (file,False,storage,vis) args
"-x" -> parseArgs (file,True,storage,vis) args
"-l" -> parseArgs (file,fromxml,setSQLite storage,vis) args
"-f" -> if curryCompiler == "pakcs"
then parseArgs (file,fromxml,setFileDB storage,vis) args
else error "Wrong parameter -f: file-based database only available in PAKCS!"
"-d" -> parseArgs (file,fromxml,DB,vis) args
"-p" -> if null args then Nothing else
parseArgs (file,fromxml,setFilePath (head args) storage,vis)
(tail args)
"--dbpath" -> if null args then Nothing else
parseArgs (file,fromxml,setFilePath (head args) storage,vis)
(tail args)
"-v" -> parseArgs (file,fromxml,storage,True) args
f -> if null args then Just (f,fromxml,storage,vis) else Nothing
where
setFilePath path (Files _) = Files path
setFilePath path (SQLite _) = SQLite path
setFilePath _ DB = DB
setSQLite (Files p) = SQLite p
setSQLite (SQLite p) = SQLite p
setSQLite DB = SQLite "."
setFileDB (Files p) = Files p
setFileDB (SQLite p) = Files p
setFileDB DB = Files "."
helpText =
"Usage: erd2curry [-l] [-f] [-d] [-t] [-x] [-v] [--dbpath <dir>] <file>\n" ++
"Parameters:\n" ++
"-l: generate interface to SQLite3 database (default)\n" ++
"-f: generate interface to file-based database implementation (only in PAKCS)\n" ++
"-d: generate interface to SQL database (experimental)\n" ++
"-t: generate from ERD term file (default)\n" ++
"-x: generate from ERD xmi document\n" ++
"-v: show visualization of ERD term file with dotty\n" ++
"--dbpath <dir>: name of the directory where DB files are stored\n" ++
"<file>: name of file containing xmi document or ERD term\n"
callStart _ Nothing = do
putStrLn $ "ERROR: Illegal arguments\n\n" ++ helpText
exitWith 1
callStart erd2currydir (Just (file,fromxml,storage,vis)) =
if vis
then readERDTermFile file >>= viewERD
else start erd2currydir (storage,WithConsistencyTest) fromxml file "."
--- Main function to invoke the ERD->Curry translator.
start :: String -> Option -> Bool -> String -> String -> IO ()
start erd2currydir opt fromxml srcfile path = do
(erdfile,erd) <- if fromxml
then transformXmlFile srcfile path
else readERDTermFile srcfile >>= \e -> return (srcfile,e)
let transerdfile = addPath path (erdName erd ++ "_ERDT.term")
curryfile = addPath path (erdName erd ++ ".curry")
transerd = transform erd
writeFile transerdfile
("{- ERD specification transformed from "++erdfile++" -}\n\n " ++
showERD 2 transerd ++ "\n")
putStrLn $ "Transformed ERD term written into file '"++transerdfile++"'."
moveOldVersion curryfile
writeFile curryfile $ showCProg $ erd2code opt $ transform erd
copyAuxiliaryFiles
putStrLn $ "Database operations generated into file '"++curryfile++"'\n"++
"with " ++ showOption (erdName erd) opt ++ ".\n"
where
-- Copy auxiliary files ERDGeneric.curry and KeyDatabase.curry to target dir
copyAuxiliaryFiles = do
if isSQLite opt
then copyFile (erd2currydir++"/KeyDatabase.curry.sqlite")
(addPath path "KeyDatabase.curry")
else done
copyFile (erd2currydir++"/ERDGeneric.curry")
(addPath path "ERDGeneric.curry")
showOption _ (Files f,_) = "database files stored in directory '"++f++"'"
showOption ername (SQLite p,_) =
"SQLite3 database stored in file '"++p++"/"++ername++".db'"
showOption _ (DB,_) = "SQL database interface"
--- Adds a path to a file name.
addPath :: String -> String -> String
addPath path fname | path=="." = fname
| otherwise = path++"/"++fname
--- Moves a file (if it exists) to one with extension ".versYYMMDDhhmmss".
moveOldVersion :: String -> IO ()
moveOldVersion fname = do
exists <- doesFileExist fname
if exists
then do
mtime <- getModificationTime fname
cmtime <- toCalendarTime mtime
let fnamevers = fname ++ ".vers" ++ calTime2Digits cmtime
system $ "mv "++fname++" "++fnamevers
putStrLn $ "Old contents of file \""++fname++"\" saved into file \""++
fnamevers++"\"."
else done
where
calTime2Digits (CalendarTime y mo d h mi s _) =
toD (y `mod` 100) ++ toD mo ++ toD d ++ toD h ++ toD mi ++ toD s
toD i = if i<10 then '0':show i else show i
--test = start "." (Files ".", WithConsistencyTest) True "./Uni.xmi" "."
test = start "." (Files ".", WithConsistencyTest) False "./Uni_ERD.term" "."
testTransformation = do
xml <- readXmlFile "./Uni.xmi"
let erd = convert xml
putStr (showERD 0 erd)
putStr "\n\n"
putStrLn (showERD 0 (transform erd))
--- Read an ERD specification from an XML file in Umbrello format.
transformXmlFile :: String -> String -> IO (String,ERD)
transformXmlFile xmlfile path = do
putStrLn $ "Reading XML file " ++ xmlfile ++ "..."
xml <- readXmlFile xmlfile
let erd = convert xml
let erdfile = addPath path (erdName erd ++ "_ERD.term")
writeFile erdfile
("{- ERD specification read from "++xmlfile++" -}\n\n " ++
showERD 2 erd ++ "\n")
putStrLn $ "ERD term written into file \""++erdfile++"\"."
return (erdfile,erd)
{-
-- Uni.xmi -> 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))])])
-- Transformation of ERD term:
(ERD "Uni"
[(Entity "Membership"
[(Attribute "Student_Membership_Key" (KeyDom "Student") PKey False),
(Attribute "Group_Membership_Key" (KeyDom "Group") PKey False)]),
(Entity "Participation"
[(Attribute "Student_Participation_Key" (KeyDom "Student") PKey False),
(Attribute "Lecture_Participation_Key" (KeyDom "Lecture") PKey False)]),
(Entity "Student"
[(Attribute "Key" (IntDom Nothing) PKey False),
(Attribute "MatNum" (IntDom Nothing) Unique False),
(Attribute "Name" (StringDom Nothing) NoKey False),
(Attribute "Firstname" (StringDom Nothing) NoKey False),
(Attribute "Email" (UserDefined "MyModule.Email" Nothing) NoKey True)]),
(Entity "Lecture"
[(Attribute "Key" (IntDom Nothing) PKey False),
(Attribute "Lecturer_Teaching_Key" (KeyDom "Lecturer") NoKey False),
(Attribute "Id" (IntDom Nothing) Unique False),
(Attribute "Title" (StringDom Nothing) Unique False),
(Attribute "Hours" (IntDom (Just 4)) NoKey False)]),
(Entity "Lecturer"
[(Attribute "Key" (IntDom Nothing) PKey False),
(Attribute "Id" (IntDom Nothing) Unique False),
(Attribute "Name" (StringDom Nothing) NoKey False),
(Attribute "Firstname" (StringDom Nothing) NoKey False)]),
(Entity "Group"
[(Attribute "Key" (IntDom Nothing) PKey False),
(Attribute "Time" (StringDom Nothing) NoKey False)])]
[(Relationship [] [(REnd "Student" [] (Exactly 1)),
(REnd "Membership" "member_of" (Between 0 Infinite))]),
(Relationship [] [(REnd "Group" [] (Exactly 1)),
(REnd "Membership" "consists_of" (Exactly 3))]),
(Relationship [] [(REnd "Student" [] (Exactly 1)),
(REnd "Participation" "participates" (Between 0 Infinite))]),
(Relationship [] [(REnd "Lecture" [] (Exactly 1)),
(REnd "Participation" "participated_by" (Between 0 Infinite))]),
(Relationship "Teaching" [(REnd "Lecturer" "taught_by" (Exactly 1)),
(REnd "Lecture" "teaches" (Between 0 Infinite))])])
-}
---------------------------------------------------------------------
--- This module defines an operation to visualize an ERD term with dot.
---------------------------------------------------------------------
module ERD2Graph(viewERD) where
import IO
import IOExts
import Char(isAlphaNum)
import List(intersperse)
import ERD
import Distribution(getRcVar)
-- Should a relation represented as an explicit node?
-- If not, it will be represented as an arc with a label.
-- However, some graph drawing tools have problems to write the
-- labels in a good manner to the arcs.
relationAsNode = True
-- Visualize an ERD term with dot.
viewERD :: ERD -> IO ()
viewERD = viewDot . showDotGraph . erd2dot
-- translate dependencies into DOT language:
erd2dot :: ERD -> DotGraph
erd2dot (ERD erdname ens rels) =
Graph erdname (enodes++concat rnodes) (concat redges)
where
enodes = map entity2dot ens
(rnodes,redges) = unzip (map relationship2dot rels)
entity2dot (Entity ename attrs) =
Node ename [("shape","record"),("style","bold"),
("label","{"++ename ++ "|" ++
concat (intersperse ("\\n") (map showAttr attrs))++"}")]
showAttr (Attribute aname dom key isnull) =
aname ++ " :: " ++ showDomain dom ++
(if key==NoKey then "" else " / "++show key) ++
(if isnull then " / null" else "")
showDomain (IntDom _) = "Int"
showDomain (FloatDom _) = "Float"
showDomain (CharDom _) = "Char"
showDomain (StringDom _) = "String"
showDomain (BoolDom _) = "Bool"
showDomain (DateDom _) = "Date"
showDomain (UserDefined t _) = t
showDomain (KeyDom _) = "KeyDom"
relationship2dot (Relationship rname [REnd en1 r1 c1, REnd en2 r2 c2]) =
if relationAsNode
then ([Node rname [("shape","diamond"),("style","filled")],
Node (rname++r1) [("shape","plaintext"),("label",r1++"\\n"++showCard c1)],
Node (rname++r2) [("shape","plaintext"),("label",r2++"\\n"++showCard c2)]],
map (\ (n1,n2) -> Edge n1 n2 [("dir","none")])
[(rname,rname++r1),(rname++r1,en1),
(rname,rname++r2),(rname++r2,en2)])
else ([Node rname [("shape","diamond"),("style","filled")]],
[Edge rname en1 [("dir","none"),("label",r1++"\\n"++showCard c1)],
Edge rname en2 [("dir","none"),("label",r2++"\\n"++showCard c2)]])
showCard (Exactly n) = '(' : show n ++ "," ++ show n ++ ")"
showCard (Between n Infinite) = '(' : show n ++ ",n)"
showCard (Between n (Max m)) = '(' : show n ++ "," ++ show m ++ ")"
data DotGraph = Graph String [Node] [Edge]
data Node = Node String [(String,String)]
data Edge = Edge String String [(String,String)]
showDotGraph :: DotGraph -> String
showDotGraph (Graph name nodes edges) =
"digraph "++name++"{\n" ++
concatMap node2dot nodes ++ concatMap edge2dot edges ++ "}\n"
where
node2dot (Node nname attrs) =
if null attrs
then showDotID nname ++ ";\n"
else showDotID nname ++
'[':concat (intersperse ","
(map (\ (n,v)->n++"=\""++v++"\"") attrs)) ++ "]"
++ ";\n"
edge2dot (Edge i j attrs) =
showDotID i ++ " -> " ++ showDotID j ++
(if null attrs then "" else
'[':concat (intersperse ","
(map (\ (n,v)->n++"=\""++v++"\"") attrs)) ++ "]")
++ ";\n"
showDotID s | all isAlphaNum s = s
| otherwise = '"' : concatMap escapeDQ s ++ "\""
where escapeDQ c = if c=='"' then "\\\"" else [c]
-- visualize a DOT string:
viewDot :: String -> IO ()
viewDot dottxt = do
dotcmd <- getDotViewCmd
dotstr <- connectToCommand dotcmd
hPutStr dotstr dottxt
hClose dotstr
-- Read dot view command from rc file of the Curry system:
getDotViewCmd :: IO String
getDotViewCmd = getRcVar "dotviewcommand" >>= return . maybe "" id
--dotCmd = "dot -Tps | kghostview -"
--dotCmd = "neato -Tps | kghostview -"
--dotCmd = "circo -Tps | kghostview -"
--dotCmd = "fdp -Tps | kghostview -"
------------------------------------------------------------------------------
--- Generic operations and integrity tests
--- to support the database code generated from ERDs
------------------------------------------------------------------------------
module ERDGeneric where
import KeyDatabase
import List
import ReadShowTerm
import Read
import Char(isDigit)
------------------------------------------------------------------------------
-- Handling of database keys
--- The general type of database keys.
type Key = Int
--- Shows a database key for an entity name as a string.
--- Useful if a textual representation of a database key is necessary,
--- e.g., as URL parameters in web pages. This textual representation
--- should not be used to store database keys in attributes!
showDatabaseKey :: String -> (enkey -> Key) -> enkey -> String
showDatabaseKey en fromenkey enkey = en ++ show (fromenkey enkey)
--- Transforms a string into a key for an entity name.
--- Nothing is returned if the string does not represent a reasonable key.
readDatabaseKey :: String -> (Key -> enkey) -> String -> Maybe enkey
readDatabaseKey en toenkey s =
let (ens,ks) = splitAt (length en) s
in if ens==en && all isDigit ks then Just (toenkey (readNat ks))
else Nothing
------------------------------------------------------------------------------
-- Generic operations to modify the database
--- Insert a new entity and assign a new key for it.
newEntry :: (Key -> t -> Dynamic) -> (Key -> t -> en) -> t -> Transaction en
newEntry pred info2entry info =
newDBEntry pred info |>>= \k -> returnT (info2entry k info)
-- Insert new relationship represented as an entity.
newEntryR :: (Key -> (a,b) -> Dynamic) -> a -> b -> Transaction ()
newEntryR entrypred key1 key2 = newDBEntry entrypred (key1,key2) |>> doneT
getEntry :: (Key -> t -> Dynamic) -> (Key -> t -> en) -> Key -> Transaction en
getEntry pred info2entry key = seq pred $ seq key $
getDB (getDBInfo pred key) |>>=
maybe (errorT (TError KeyNotExistsError
("database contains no entry for key: "++show key)))
(\info -> returnT (info2entry key info))
-- Delete a relationship represented as an entity.
-- If the relationship does not exist, a NoRelationshipError is raised.
deleteEntryR :: (Key -> (a,b) -> Dynamic) -> a -> b -> Transaction ()
deleteEntryR entrypred key1 key2 =
getDB (transformQ (map fst . filter (\ (_,i) -> i==(key1,key2)))
(allDBKeyInfos entrypred)) |>>= \kis ->
if null kis
then errorT (TError NoRelationshipError
("relationship for deletion not found for keys: "
++show key1++" "++show key2))
else deleteDBEntries entrypred kis
------------------------------------------------------------------------------
-- Generic integrity tests for keys.
-- If there is no entry with a given key, raise a transaction error.
existsEntryWithDBKey :: String -> (Key -> t -> Dynamic) -> Key -> Transaction ()
existsEntryWithDBKey ename entrypred key =
getDB (getDBInfo entrypred key) |>>=
maybe (errorT (TError KeyNotExistsError
("database contains no entry for key: "++show key
++" in table: "++ename)) )
(const doneT)
-- If a given key occurs in a (foreign key) attribute of an entity,
-- raise a transaction error.
requiredForeignDBKey :: String -> (Key -> t -> Dynamic) -> (Key -> t -> en)
-> (en -> k) -> k -> Transaction ()
requiredForeignDBKey ename entrypred info2entry keyf key =
getDB (getAllEntities entrypred info2entry) |>>= \ens ->
if null (filter (\e -> keyf e == key) ens)
then doneT
else errorT (TError KeyRequiredError
("key: "++show key ++ " required in table: " ++ ename))
getAllEntities :: (Key -> t -> Dynamic) -> (Key -> t -> en) -> Query [en]
getAllEntities entrypred info2entry =
transformQ (map (uncurry info2entry)) (allDBKeyInfos entrypred)
duplicateKeyTest :: (Key -> t -> Dynamic) -> Transaction ()
duplicateKeyTest pred =
getDB (allDBKeys pred) |>>= \keys ->
if length (nub keys) == length keys
then doneT
else errorT (TError DuplicateKeyError
("database contains duplicate key for table: "
++show pred))
duplicatePTest :: [a] -> Transaction ()
duplicatePTest xs =
if length (nub xs) == length xs
then doneT
else errorT (TError DuplicateKeyError "duplicate parameters in new-function")
-------------------------------------------------------------------------
-- Uniqueness tests.
-- Test whether an attribute value does not yet exist
unique :: String -> (Key -> t -> Dynamic) -> (Key -> t -> en) -> (en -> a) -> a
-> Transaction ()
unique ename entrypred info2entry selector attrval =
getDB (allDBKeyInfos entrypred) |>>= \kis ->
if null (filter (\e -> selector e == attrval)
(map (\(k,i) -> info2entry k i) kis))
then doneT
else errorT (TError UniqueError
(ename++" entry for unique attribute "
++show attrval++" already exists"))
uniqueUpdate :: String -> (Key -> t -> Dynamic) -> (Key -> t -> en)
-> (en -> Key) -> (en -> a) -> en -> Transaction ()
uniqueUpdate ename entrypred info2entry keyf selector obj =
let oldkey = keyf obj
in
getDB (getDBInfo entrypred oldkey) |>>=
maybe (errorT (TError KeyNotExistsError
("database contains no entry for key: "++show oldkey)))
(\oldt -> getDB (allDBKeyInfos entrypred) |>>= \kis ->
let oldentry = info2entry oldkey oldt
entries = filter (\e -> selector obj == selector e)
(map (uncurry info2entry) kis)
in if null entries ||
(length entries == 1 && selector oldentry == selector obj)
then doneT
else errorT (TError UniqueError
(ename++" entry for unique attribute "
++show (selector obj)++" already exists")))
uniqueC :: String -> (Key -> t -> Dynamic) -> (Key -> t -> en)
-> (en -> a) -> en -> Transaction ()
uniqueC ename entrypred info2entry selector obj =
getDB (allDBKeyInfos entrypred) |>>= \kis ->
let entries = filter (\e -> selector obj == selector e)
(map (uncurry info2entry) kis)
in if length entries <= 1
then doneT