|
sourcecode:
|
{-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-}
module Database.ERD.Goodies
( erdName, entityName, isEntityNamed, entityAttributes
, hasForeignKey, foreignKeyAttributes
, attributeName, attributeDomain, hasDefault
, isForeignKey, isNullAttribute
, cardMinimum, cardMaximum
, showERD, combineIds
, readERDFromProgram, storeERDFromProgram
) where
import Curry.Compiler.Distribution ( installDir )
import Data.Char ( isUpper )
import Data.List ( intersperse )
import Data.Maybe
import System.Environment ( getEnv )
import Database.ERD
import FlatCurry.Types
import FlatCurry.Files
import FlatCurry.Goodies
import System.CurryPath ( runModuleActionQuiet, stripCurrySuffix )
import System.Directory ( getAbsolutePath, removeFile )
import System.FilePath ( (</>) )
import System.IOExts ( evalCmd, readCompleteFile )
import System.Process ( 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 :: Int -> Entity -> String
showEs n (Entity en attrs) = "Entity " ++ showString en ++ lb (n+7) ++
"[" ++ concat (intersperse ("," ++ lb (n+8)) (map showWOBrackets attrs)) ++"]"
showRs :: Int -> Relationship -> String
showRs n (Relationship rn ends) =
"Relationship " ++ showString rn ++ lb (n+13) ++
"[" ++ concat (intersperse ("," ++ lb (n+14)) (map showWOBrackets ends)) ++"]"
showWOBrackets :: Show a => a -> String
showWOBrackets t = stripBrackets (show t)
where
stripBrackets (c:cs) = if c=='(' then reverse (tail (reverse cs)) else c:cs
showString :: String -> String
showString s = "\"" ++ s ++ "\""
lb :: Int -> String
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 read ERD definition given in a Curry program.
--- Reads the ERD defined in a Curry program (as a top-level operation
--- of type `Database.ERD.ERD`).
--- This is done by compiling the Curry program with an auxiliary
--- operation and processing the output of the program.
readERDFromProgram :: String -> IO ERD
readERDFromProgram progfile = do
putStr $ "Processing ERD in program `" ++ progfile ++ "'..."
let progname = stripCurrySuffix progfile
prog <- runModuleActionQuiet 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 <- getEnv "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 writeFileWithERDTerm " ++
show tmpfile ++ snd (funcName fd)
, ":quit"]
(ecode,_,errstr) <- evalCmd cmd args input
putStrLn "done"
if ecode > 0
then error $ "ERROR in program defining ERD:\n" ++ errstr
else do erdtermfile <- readCompleteFile tmpfile
removeFile tmpfile
return (read erdtermfile)
_ -> error $ "Multiple ER model definitions found in program " ++ progfile
--- 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
erd <- readERDFromProgram progfile
fname <- writeERDTermFile erd
putStrLn $ "ERD term file '" ++ fname ++ "' written."
return fname
hasERDType :: FuncDecl -> Bool
hasERDType fdecl = funcType fdecl == TCons ("Database.ERD","ERD") []
------------------------------------------------------------------------------
|