----------------------------------------------------------------------------- --- This module creates all datatypes to represent the entities and --- relations of a relational (SQLite) database corresponding to a --- logical ER model specified in a file `x_ERDT.term` (which is --- a transformed ER-Model that was translated by erd2curry). --- It produces a Curry program `x_CDBI.curry` and a file --- `x_SQLCODE.info` that is used when embedded SQL statements are --- translated by the Curry preprocessor `currypp`. --- --- @author Mike Tallarek, extensions by Julia Krone and Michael Hanus ------------------------------------------------------------------------------ --- TODO: generate code to check ER constraints in new/update/delete --- operations for entities (similarly to old erd2curry compiler) {-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-} module Database.ERD.ToCDBI where import Control.Monad ( when ) import Curry.Compiler.Distribution ( installDir ) import Data.Char ( toLower, toUpper ) import Data.List import System.IO import Data.Time import qualified System.FilePath as FP ( (), combine, splitFileName) import System.Directory ( doesFileExist ) import System.IOExts ( connectToCommand ) import System.Process ( system ) import AbstractCurry.Types import AbstractCurry.Pretty import AbstractCurry.Build import Database.ERD import Database.ERD.Goodies import Text.Pretty -- Write all the data so CDBI can be used, create a database (if it does -- not exist) and a `.info` file. -- The parameters are the name of the file containing the ERD term, -- the name of the file to store the Curry program, -- the module name of the generated Curry program, -- the ER model, and the name of the SQLite3 database. writeCDBI :: String -> String -> String -> ERD -> String -> IO () writeCDBI erdfname outfile cdbimod (ERD name ents rels) dbname = do let imports = [ timeMod , "Database.CDBI.ER" , "Database.CDBI.Criteria" , "Database.CDBI.Connection" , "Database.CDBI.Description"] typeDecls = foldr ((++) . (genEntityTypeDecls cdbimod)) [] ents funcDecls = genDBPathFunc cdbimod dbname : foldr ((++) . (genEntityFuncDecls cdbimod)) [] ents ++ genNewDBSchema cdbimod ents ++ genSaveDB cdbimod ents ++ genRunFuncs cdbimod writeFile outfile $ unlines $ map ("--- "++) [ "This file has been generated from" , "" , " " ++ erdfname , "" , "and contains definitions for all entities and relations" , "specified in this model.\n"] ++ [ pPrint (ppCurryProg defaultOptions (CurryProg cdbimod imports Nothing [] [] typeDecls funcDecls [])) ] putStrLn $ unlines [ "Database operations generated into file '" ++ outfile ++ "'." , "NOTE: Packages 'cdbi' and 'time' are required to compile this module." ] infofilehandle <- openFile (name ++ "_SQLCode.info") WriteMode writeParserFile infofilehandle cdbimod ents rels dbname hClose infofilehandle dbexists <- doesFileExist dbname if dbexists then do putStrLn $ "Database '" ++ dbname ++ "' exists and, thus, not modified." putStrLn $ "Please make sure that this database is conform to the ER model!" -- TODO: if the database exists, check its consistency with ER model else do putStrLn $ "CREATING NEW SQLITE3 DATABASE: " ++ dbname exsqlite3 <- system "which sqlite3 > /dev/null" when (exsqlite3>0) $ error "Database interface `sqlite3' not found. Please install package `sqlite3'!" db <- connectToCommand $ "sqlite3 " ++ dbname hPutStrLn db $ unlines (map entity2createTable ents) hClose db genDBPathFunc :: String -> String -> CFuncDecl genDBPathFunc mname dbname = stCmtFunc "The name of the SQLite database file." (mname,"sqliteDBFile") 0 Public stringType [simpleRule [] (string2ac dbname)] -- -----writing .info-file containing auxiliary data for parsing ------------- -- Auxiliary definitions for qualified names in AbstractCurry mDescr :: String mDescr = "Database.CDBI.Description" mConn :: String mConn = "Database.CDBI.Connection" mER :: String mER = "Database.CDBI.ER" -- generates an AbstractCurry expression representing the parser information -- and writes it to the file writeParserFile :: Handle -> String -> [Entity] -> [Relationship] -> String -> IO () writeParserFile infofilehandle modname ents rels dbname = do hPutStrLn infofilehandle (pPrint (ppCExpr (setNoQualification defaultOptions) (applyE (pinfoType "PInfo") [string2ac dbname, string2ac modname, relations, nullables, attributes, attrTypes]))) where relations = list2ac (foldr ((++) . getRelationTypes ents) [] rels) nullables = list2ac (foldr ((++) . getNullableAttr) [] ents) attributes = list2ac (map getAttrList ents) attrTypes = list2ac (foldr ((++) . getAttrTypes) [] ents) -- generates data term for each relationship depending on its type: getRelationTypes :: [Entity] -> Relationship -> [CExpr] getRelationTypes ents relationship = case relationship of Relationship "" [REnd e1Name _ _, REnd e2Name reName _] -> [tupleExpr [tupleExpr (map string2ac [e1Name, reName, getCorEnt ents e1Name e2Name]), applyE (pinfoType "MtoN") [string2ac e2Name]], tupleExpr [tupleExpr (map string2ac [e1Name, e2Name, (getCorEnt ents e1Name e2Name)]), applyE (pinfoType "MtoN") [string2ac e2Name]]] Relationship rName [REnd e1Name re1Name (Between 0 _), REnd e2Name re2Name (Exactly 1)] -> [tupleExpr [tupleExpr (map string2ac [e2Name, re1Name, e1Name]), applyE (pinfoType "OnetoN") [(string2ac rName)]], tupleExpr [tupleExpr (map string2ac [e1Name, re2Name, e2Name]), applyE (pinfoType "NtoOne") [string2ac rName]]] Relationship rName@(_:_) [REnd e1Name re1Name (Exactly 1), REnd e2Name re2Name (Between 0 _)] -> [tupleExpr [tupleExpr (map string2ac [e2Name, re1Name, e1Name]), applyE (pinfoType "NtoOne") [string2ac rName]], tupleExpr [tupleExpr (map string2ac [e1Name, re2Name, e2Name]), applyE (pinfoType "OnetoN") [string2ac rName]]] Relationship rName [REnd e1Name re1Name (Between _ _), REnd e2Name re2Name (Between 0 (Max 1))] -> [tupleExpr [tupleExpr (map string2ac [e2Name, re1Name, e1Name]), applyE (pinfoType "OnetoN") [string2ac rName]], tupleExpr [tupleExpr (map string2ac [e1Name, re2Name, e2Name]), applyE (pinfoType "NtoOne") [string2ac rName]]] Relationship rName [REnd e1Name re1Name (Between 0 (Max 1)), REnd e2Name re2Name (Between _ _)] -> [tupleExpr [tupleExpr (map string2ac [e2Name, re1Name, e1Name]), applyE (pinfoType "NtoOne") [string2ac rName]], tupleExpr [tupleExpr (map string2ac [e1Name, re2Name, e2Name]), applyE (pinfoType "OnetoN") [string2ac rName]]] -- find second entity belonging to an MtoN relationship getCorEnt :: [Entity] -> String -> String -> String getCorEnt [] _ _ = "" -- this should not happen getCorEnt ((Entity name attrs):ents) eName rName = if name == rName then checkAttributes attrs eName else getCorEnt ents eName rName where checkAttributes ((Attribute _ typ _ _):atts) n = case typ of KeyDom kName -> if kName == n then checkAttributes atts n else kName _ -> checkAttributes atts n checkAttributes [] _ = "" --should not happen -- generates data term providing for each attribute (name) -- if it is nullable or not getNullableAttr :: Entity -> [CExpr] getNullableAttr (Entity name attrs) = map (getNullValue name) attrs getNullValue :: String -> Attribute -> CExpr getNullValue ename (Attribute aName _ _ nullable) = tupleExpr [string2ac (firstLow ename ++ aName), CSymbol (pre (show nullable))] -- generates data term providing the type of each attribute getAttrTypes :: Entity -> [CExpr] getAttrTypes (Entity name attrs) = map (getTypeOf name) attrs getTypeOf :: String -> Attribute -> CExpr getTypeOf ename (Attribute aName domain key _) = case domain of IntDom _ -> case key of PKey -> tupleExpr [string2ac (firstLow ename ++ aName), string2ac (firstUp ename)] NoKey -> tupleExpr [string2ac (firstLow ename ++ aName), string2ac "int"] Unique -> tupleExpr [string2ac (firstLow ename ++ aName), string2ac "int"] FloatDom _ -> tupleExpr [string2ac (firstLow ename ++ aName), string2ac "float"] CharDom _ -> tupleExpr [string2ac (firstLow ename ++ aName), string2ac "char"] StringDom _ -> tupleExpr [string2ac (firstLow ename ++ aName), string2ac "string"] BoolDom _ -> tupleExpr [string2ac (firstLow ename ++ aName), string2ac "bool"] DateDom _ -> tupleExpr [string2ac (firstLow ename ++ aName), string2ac "date"] KeyDom e2Name -> tupleExpr [string2ac (firstLow ename ++ aName), string2ac e2Name] -- Generates data term providing for each tableName the list of its attributes getAttrList :: Entity -> CExpr getAttrList (Entity name attrs) = tupleExpr [string2ac (lowerCase name), tupleExpr [(string2ac name), list2ac (map (string2ac . attributeName) attrs)]] ------------------------------------------------------------------------------ -- Generating Curry program containing all type/operations needed for CDBI use -- Generates the declaration of datatype and ID-type for each entity. genEntityTypeDecls :: String -> Entity -> [CTypeDecl] genEntityTypeDecls mName ent = [genEntityType mName ent, genIDType mName ent] -- Generates a entity-datatype based on an entity. genEntityType :: String -> Entity -> CTypeDecl genEntityType mName (Entity name attrs) = CType (mName, name) Public [] [simpleCCons (mName, name) Public (map (attr2CType mName name) attrs)] [pre "Eq", pre "Show", pre "Read"] -- Generates a ID-datatype based on an entity. genIDType :: String -> Entity -> CTypeDecl genIDType mName (Entity name _) = CType (mName, (name++"ID")) Public [] [simpleCCons (mName, (name ++"ID")) Public [intType]] [pre "Eq", pre "Show", pre "Read"] -- Generates all function declarations for an entity. genEntityFuncDecls :: String -> Entity -> [CFuncDecl] genEntityFuncDecls mName ent = [genEntityDescription mName ent, genTables mName ent] ++ genColumns mName ent ++ genColumnDescriptions mName ent ++ genGetterSetters mName ent ++ genKeyTransformFuncs mName ent ++ genEntryFuncs mName ent -- Generates an entity-description based on an entity. genEntityDescription :: String -> Entity -> CFuncDecl genEntityDescription mName (Entity name attrs) = stCmtFunc ("The ER description of the `" ++ name ++ "` entity.") (mName, firstLow name ++ "_CDBI_Description" ) 0 Public (applyTC (mDescr, "EntityDescription") [baseType (mName, name)]) [(simpleRule [] (applyE (CSymbol (mDescr, "ED")) [string2ac name, list2ac (map attr2CSymbol attrs), writeTransFunOne mName name attrs, writeTransFunTwo mName name attrs, writeTransFunThree mName name attrs]))] -- Generates a table description for on an entity. genTables :: String -> Entity -> CFuncDecl genTables mName (Entity name _) = stCmtFunc ("The database table of the `" ++ name ++ "` entity.") (mName, firstLow name ++ "Table") 0 Public (baseType (mDescr, "Table")) [(simpleRule [] (string2ac name))] -- Generates Column Descriptions based on an entity. genColumnDescriptions :: String -> Entity -> [CFuncDecl] genColumnDescriptions mName (Entity name attrs) = map (genColumnDescription mName name) attrs genColumnDescription :: String -> String -> Attribute -> CFuncDecl genColumnDescription mName name a@(Attribute atr _ _ _) = stCmtFunc ("The description of the database column `" ++ atr ++ "` of the `" ++ name ++ "` entity.") (mName, firstLow name ++ atr ++ "ColDesc") 0 Public (applyTC (mDescr, "ColumnDescription") [(attr2CType mName name a)]) [simpleRule [] (applyE (CSymbol (mDescr, "ColDesc")) [string2ac ("\"" ++ name ++ "\"." ++ "\"" ++ atr ++ "\""), attr2CSymbol a, CLambda [genAttrConvLeftOneTwo mName name a] (genAttrConvRightOneTwo mName False a), CLambda [genAttrConvLeftThree a] (genAttrConvRightThree mName name a)])] -- Generates all needed column-functions based on an entity. genColumns :: String -> Entity -> [CFuncDecl] genColumns mName (Entity name attrs) = map (genColumn mName name ) attrs -- Generates a column-function from an attribute. genColumn :: String -> String -> Attribute -> CFuncDecl genColumn mName name a@(Attribute atr _ _ _) = stCmtFunc ("The database column `" ++ atr ++ "` of the `" ++ name ++ "` entity.") (mName, firstLow name ++ "Column" ++ atr) 0 Public (applyTC (mDescr, "Column") [(getAttributeType mName name a)]) [(simpleRule [] (applyE (CSymbol (mDescr, "Column")) [(string2ac ("\"" ++ atr ++ "\"")), (string2ac ("\"" ++ name ++ "\"." ++ "\"" ++ atr ++ "\"")) ]))] getAttributeType :: String -> String -> Attribute -> CTypeExpr getAttributeType mName eName (Attribute atr dom _ _) = if atr == "Key" then baseType (mName, eName ++ "ID") else getType mName dom -- Get the type of a domain as CExpr. getType :: String -> Domain -> CTypeExpr getType _ (IntDom _) = intType getType _ (FloatDom _) = floatType getType _ (CharDom _) = baseType (pre "Char") getType _ (StringDom _) = stringType getType _ (BoolDom _) = boolType getType _ (DateDom _) = baseType (inTime "ClockTime") getType mName (KeyDom name) = baseType (mName, name++"ID") -- Generates all getter and setter methods based on an entity. genGetterSetters :: String -> Entity -> [CFuncDecl] genGetterSetters mName (Entity name attrs) = let indAttrs = zip attrs [1..(length attrs)] in map (genGetter mName name (length attrs)) indAttrs ++ map (genSetter mName name (length attrs)) indAttrs -- Generates a setter method based on an attribute. genSetter :: String -> String -> Int -> (Attribute, Int) -> CFuncDecl genSetter mName eName len (att@(Attribute name _ _ _), i) = stCmtFunc ("Sets the attribute `" ++ name ++ "` of the `" ++ eName ++ "` entity.") (mName, ("set" ++ eName ++ name)) 2 Public ((baseType (mName, eName)) ~> (attr2CType mName eName att) ~> (baseType (mName, eName))) [(simpleRule [(CPComb (mName, eName) (createParametersLeft i (len-i))), (cpvar "a")] (applyE (CSymbol (mName, eName)) (createParametersRight i (len-i))))] -- Generates a getter method based on an attribute. genGetter :: String -> String -> Int -> (Attribute, Int) -> CFuncDecl genGetter mName eName len (att@(Attribute name _ _ _), i) = stCmtFunc ("Gets the attribute `" ++ name ++ "` of the `" ++ eName ++ "` entity.") (mName, ((firstLow eName) ++ name)) 1 Public ((baseType (mName, eName)) ~> (attr2CType mName eName att)) [(simpleRule [CPComb (mName, eName) (createUnderscores i (len-i))] (cvar "a"))] -- Auxiliary function for genGetterSetter that creates the needed -- amount of underscores and places the "a" at the correct position createUnderscores :: Int -> Int -> [CPattern] createUnderscores ind len = case ind of 0 -> case len of 0 -> [] n -> (cpvar "_") : (createUnderscores 0 $ n-1) 1 -> (cpvar "a") : (createUnderscores 0 len) n -> (cpvar "_") : (createUnderscores (n-1) len) -- Auxiliary function for genGetterSetter that creates the needed -- amount of parameters for setter-functions on the left side createParametersLeft :: Int -> Int -> [CPattern] createParametersLeft ind len = case ind of 0 -> case len of 0 -> [] n -> (cpvar ("b" ++ show n)):(createParametersLeft 0 $ n-1) 1 -> (cpvar "_"): (createParametersLeft 0 len) n -> (cpvar ("a" ++ show n)) : (createParametersLeft (n-1) len) -- Auxiliary function for genGetterSetter that creates the needed amount -- of parameters for setter-functions on the right side createParametersRight :: Int -> Int -> [CExpr] createParametersRight ind len = case ind of 0 -> case len of 0 -> [] n -> (cvar ("b" ++ show n)) : (createParametersRight 0 $ n-1) 1 -> (cvar "a") : (createParametersRight 0 len) n -> (cvar ("a" ++ (show n))) : (createParametersRight (n-1) len) -- Generates the first conversion function in the entity-description writeTransFunOne :: String -> String -> [Attribute] -> CExpr writeTransFunOne mName name attrs = CLambda [(CPComb (mName, name) (map (genAttrConvLeftOneTwo mName name) attrs))] (list2ac (map (genAttrConvRightOneTwo mName False) attrs)) -- Generates the second conversion function in the entity-description -- where the entity key is not used but mapped to a null value. writeTransFunTwo :: String -> String -> [Attribute] -> CExpr writeTransFunTwo mName name attrs = CLambda [(CPComb (mName, name) (if isPrimaryKeyAttribute (head attrs) then cpvar "_" : map (genAttrConvLeftOneTwo mName name) (tail attrs) else map (genAttrConvLeftOneTwo mName name) attrs))] (list2ac (map (genAttrConvRightOneTwo mName True) attrs)) isPrimaryKeyAttribute :: Attribute -> Bool isPrimaryKeyAttribute (Attribute aname adom _ anull) = case adom of IntDom _ -> aname == "Key" && not anull _ -> False -- Generates the third conversion function in the entity-description writeTransFunThree :: String -> String -> [Attribute] -> CExpr writeTransFunThree mName name attrs = CLambda [(listPattern (map genAttrConvLeftThree attrs))] (applyE (CSymbol (mName, name)) (map (genAttrConvRightThree mName name) attrs)) -- Generates left-hand-side of first and second conversion function. genAttrConvLeftOneTwo :: String -> String -> Attribute -> CPattern genAttrConvLeftOneTwo mName _ (Attribute aname dom NoKey isnull) = case dom of KeyDom c -> if isnull then cpvar (firstLow aname) else CPComb (mName, c++"ID") [cpvar (firstLow aname)] _ -> cpvar (firstLow aname) genAttrConvLeftOneTwo mName _ (Attribute aname dom Unique isnull) = case dom of KeyDom c -> if isnull then cpvar (firstLow aname) else CPComb (mName, c++"ID") [cpvar (firstLow aname)] _ -> cpvar (firstLow aname) genAttrConvLeftOneTwo mName _ (Attribute aname (KeyDom c) PKey _) = (CPComb (mName, c++"ID") [cpvar (firstLow aname)]) genAttrConvLeftOneTwo mName name (Attribute aname (IntDom _) PKey _) = (CPComb (mName, name++"ID") [cpvar (firstLow aname)]) -- Generates right-hand-side of first and second conversion function. -- If second argument is true, a Key attribute is translated into null value. genAttrConvRightOneTwo :: String -> Bool -> Attribute -> CExpr genAttrConvRightOneTwo _ False (Attribute aname (IntDom _) _ False) = applyE (CSymbol (mConn, "SQLInt")) [cvar (firstLow aname)] genAttrConvRightOneTwo _ True (Attribute aname (IntDom _) _ False) = if aname == "Key" then constF (mConn, "SQLNull") else applyE (CSymbol (mConn, "SQLInt")) [cvar (firstLow aname)] genAttrConvRightOneTwo _ _ (Attribute aname (IntDom _) _ True) = applyF (mDescr, "sqlIntOrNull") [cvar (firstLow aname)] genAttrConvRightOneTwo _ _ (Attribute aname (FloatDom _) _ False) = applyE (CSymbol (mConn, "SQLFloat")) [cvar (firstLow aname)] genAttrConvRightOneTwo _ _ (Attribute aname (FloatDom _) _ True) = applyF (mDescr, "sqlFloatOrNull") [cvar (firstLow aname)] genAttrConvRightOneTwo _ _ (Attribute aname (CharDom _) _ False) = applyE (CSymbol (mConn, "SQLChar")) [cvar (firstLow aname)] genAttrConvRightOneTwo _ _ (Attribute aname (CharDom _) _ True) = applyF (mDescr, "sqlCharOrNull") [cvar (firstLow aname)] genAttrConvRightOneTwo _ _ (Attribute aname (StringDom _) _ False) = applyE (CSymbol (mConn, "SQLString")) [cvar (firstLow aname)] genAttrConvRightOneTwo _ _ (Attribute aname (StringDom _) _ True) = applyF (mDescr, "sqlString") [cvar (firstLow aname)] genAttrConvRightOneTwo _ _ (Attribute aname (BoolDom _) _ False) = applyE (CSymbol (mConn, "SQLBool")) [cvar (firstLow aname)] genAttrConvRightOneTwo _ _ (Attribute aname (BoolDom _) _ True) = applyF (mDescr, "sqlBoolOrNull") [cvar (firstLow aname)] genAttrConvRightOneTwo _ _ (Attribute aname (DateDom _) _ False) = applyE (CSymbol (mConn, "SQLDate")) [cvar (firstLow aname)] genAttrConvRightOneTwo _ _ (Attribute aname (DateDom _) _ True) = applyF (mDescr, "sqlDateOrNull") [cvar (firstLow aname)] genAttrConvRightOneTwo _ _ (Attribute aname (KeyDom _) _ False) = applyE (CSymbol (mConn, "SQLInt")) [cvar (firstLow aname)] genAttrConvRightOneTwo mName _ (Attribute aname (KeyDom c) _ True) = applyF (mDescr, "sqlKeyOrNull") [lambdakey2int, cvar (firstLow aname)] where lambdakey2int = CLambda [CPComb (mName, c++"ID") [cpvar "k"]] (cvar "k") -- Generates left-hand-side of third conversion function. genAttrConvLeftThree :: Attribute -> CPattern genAttrConvLeftThree (Attribute aname (IntDom _) _ False) = CPComb (mConn, "SQLInt") [cpvar (firstLow aname)] genAttrConvLeftThree (Attribute aname (FloatDom _) _ False) = CPComb (mConn, "SQLFloat") [cpvar (firstLow aname)] genAttrConvLeftThree (Attribute aname (CharDom _) _ False) = CPComb (mConn, "SQLChar") [cpvar (firstLow aname)] genAttrConvLeftThree (Attribute aname (StringDom _) _ False) = CPComb (mConn, "SQLString") [cpvar (firstLow aname)] genAttrConvLeftThree (Attribute aname (BoolDom _) _ False) = CPComb (mConn, "SQLBool") [cpvar (firstLow aname)] genAttrConvLeftThree (Attribute aname (DateDom _) _ False) = CPComb (mConn, "SQLDate") [cpvar (firstLow aname)] genAttrConvLeftThree (Attribute aname (KeyDom _) _ False) = CPComb (mConn, "SQLInt") [cpvar (firstLow aname)] genAttrConvLeftThree (Attribute aname _ _ True) = cpvar (firstLow aname) -- Generates right-hand-side of third conversion function genAttrConvRightThree ::String -> String -> Attribute -> CExpr genAttrConvRightThree _ _ (Attribute aname (IntDom _) NoKey True) = applyF (mDescr, "intOrNothing") [cvar (firstLow aname)] genAttrConvRightThree _ _ (Attribute aname (FloatDom _) NoKey True) = applyF (mDescr, "floatOrNothing") [cvar (firstLow aname)] genAttrConvRightThree _ _ (Attribute aname (CharDom _) NoKey True) = applyF (mDescr, "charOrNothing") [cvar (firstLow aname)] genAttrConvRightThree _ _ (Attribute aname (StringDom _) NoKey True) = applyF (mDescr, "fromStringOrNull") [cvar (firstLow aname)] genAttrConvRightThree _ _ (Attribute aname (BoolDom _) NoKey True) = applyF (mDescr, "boolOrNothing") [cvar (firstLow aname)] genAttrConvRightThree _ _ (Attribute aname (DateDom _) NoKey True) = applyF (mDescr, "dateOrNothing") [cvar (firstLow aname)] genAttrConvRightThree mName _ (Attribute aname (KeyDom c) NoKey True) = applyF (mDescr, "keyOrNothing") [CSymbol (mName, c++"ID"), cvar (firstLow aname)] genAttrConvRightThree _ _ (Attribute aname (IntDom _) Unique True) = applyF (mDescr, "intOrNothing") [cvar (firstLow aname)] genAttrConvRightThree _ _ (Attribute aname (FloatDom _) Unique True) = applyF (mDescr, "floatOrNothing") [cvar (firstLow aname)] genAttrConvRightThree _ _ (Attribute aname (CharDom _) Unique True) = applyF (mDescr, "charOrNothing") [cvar (firstLow aname)] genAttrConvRightThree _ _ (Attribute aname (StringDom _) Unique True) = applyF (mDescr, "fromStringOrNull") [cvar (firstLow aname)] genAttrConvRightThree _ _ (Attribute aname (BoolDom _) Unique True) = applyF (mDescr, "boolOrNothing") [cvar (firstLow aname)] genAttrConvRightThree _ _ (Attribute aname (DateDom _) Unique True) = applyF (mDescr, "dateOrNothing") [cvar (firstLow aname)] genAttrConvRightThree mName _ (Attribute aname (KeyDom c) Unique True) = applyF (mDescr, "keyOrNothing") [CSymbol (mName, c++"ID"), cvar (firstLow aname)] genAttrConvRightThree mName _ (Attribute aname dom NoKey False) = case dom of (KeyDom d) -> applyE (CSymbol (mName, (d++"ID"))) [(cvar (firstLow aname))] _ -> cvar (firstLow aname) genAttrConvRightThree mName _ (Attribute aname dom Unique False) = case dom of (KeyDom d) -> applyE (CSymbol (mName, (d++"ID"))) [(cvar (firstLow aname))] _ -> cvar (firstLow aname) genAttrConvRightThree mName _ (Attribute aname (KeyDom c) PKey _) = applyE (CSymbol (mName, (c++"ID"))) [(cvar (firstLow aname))] genAttrConvRightThree mName name (Attribute aname (IntDom _) PKey _) = applyE (CSymbol (mName, (name++"ID"))) [(cvar (firstLow aname))] -- Translates an attribute into the corresponding type of entity datatype. attr2CType :: String -> String -> Attribute -> CTypeExpr attr2CType mName name (Attribute a adom _ anull) = case adom of IntDom _ -> case a of "Key" -> baseType (mName , (name++"ID")) _ -> addMaybeIfNull anull intType FloatDom _ -> addMaybeIfNull anull floatType CharDom _ -> addMaybeIfNull anull (baseType (pre "Char")) StringDom _ -> stringType BoolDom _ -> addMaybeIfNull anull boolType DateDom _ -> addMaybeIfNull anull (baseType (inTime "ClockTime")) KeyDom k -> addMaybeIfNull anull (baseType (mName ,(k++"ID"))) where addMaybeIfNull isnull texp = if isnull then maybeType texp else texp -- Translates an attribute into the corresponding type of the "new" -- operation for entities. Thus, if attributes have default values, -- they are translated into `Maybe` types. attr2NewCType :: String -> String -> Attribute -> CTypeExpr attr2NewCType mName name (Attribute a adom _ anull) = case adom of IntDom d -> case a of "Key" -> baseType (mName , (name++"ID")) _ -> addMaybeIfNullOrDflt anull d intType FloatDom d -> addMaybeIfNullOrDflt anull d floatType CharDom d -> addMaybeIfNullOrDflt anull d (baseType (pre "Char")) StringDom _ -> stringType BoolDom d -> addMaybeIfNullOrDflt anull d boolType DateDom d -> addMaybeIfNullOrDflt anull d (baseType (inTime "ClockTime")) KeyDom k -> addMaybeIfNullOrDflt anull Nothing (baseType (mName, k++"ID")) where addMaybeIfNullOrDflt _ (Just _) texp = maybeType texp addMaybeIfNullOrDflt isnull Nothing texp = if isnull then maybeType texp else texp -- Translates an attribute type into a symbol used in an entity description. attr2CSymbol :: Attribute -> CExpr attr2CSymbol (Attribute _ adom _ _) = domain2CSymbol adom where domain2CSymbol :: Domain -> CExpr domain2CSymbol (IntDom _) = CSymbol (mConn, "SQLTypeInt") domain2CSymbol (FloatDom _) = CSymbol (mConn, "SQLTypeFloat") domain2CSymbol (CharDom _) = CSymbol (mConn, "SQLTypeChar") domain2CSymbol (StringDom _) = CSymbol (mConn, "SQLTypeString") domain2CSymbol (BoolDom _) = CSymbol (mConn, "SQLTypeBool") domain2CSymbol (DateDom _) = CSymbol (mConn, "SQLTypeDate") domain2CSymbol (KeyDom _) = CSymbol (mConn, "SQLTypeInt") -- Generates operations to transform entity keys, like -- id-to-value, id-to-int, show/read functions. genKeyTransformFuncs :: String -> Entity -> [CFuncDecl] genKeyTransformFuncs mName (Entity name attrs) = case head attrs of (Attribute "Key" _ PKey _ ) -> [ stCmtFunc ("id-to-value function for entity `" ++ name ++ "`.") (mName, firstLow name ++ "ID") 1 Public (baseType (mName, name ++ "ID") ~> applyTC ("Database.CDBI.Criteria", "Value") [baseType (mName, name ++ "ID")]) [simpleRule [genAttrConvLeftOneTwo mName name (head attrs)] (applyF ("Database.CDBI.Criteria", "idVal") [cvar "key"])] , stCmtFunc ("id-to-int function for entity `" ++ name ++ "`.") (mName, toKeyToInt $ firstLow name) 1 Public (baseType (mName, name ++"ID") ~> intType) [simpleRule [genAttrConvLeftOneTwo mName name (head attrs)] (cvar "key")] , stCmtFunc (showKeyCmt name) (mName, "show" ++ name ++ "Key") 1 Public (baseType (mName, name) ~> stringType) [simpleRule [cpvar "entry"] (applyF (mER, "showDatabaseKey") [ string2ac name , constF (mName, toKeyToInt $ firstLow name) , applyF (mName, firstLow name ++ "Key") [cvar "entry"] ])] , stCmtFunc (readKeyCmt name) (mName, "read" ++ name ++ "Key") 0 Public (stringType ~> maybeType (baseType (mName, name ++ "ID"))) [simpleRule [] (applyF (mER, "readDatabaseKey") [ string2ac name, constF (mName, name ++ "ID")])] ] _ -> [] where toKeyToInt s = s ++ "KeyToInt" showKeyCmt ename = "Shows the key of a `" ++ ename ++ "` entity as a string.\n" ++ "This is useful if a textual representation of the key is necessary\n" ++ "(e.g., as URL parameters in web pages), but it should no be used\n" ++ "to store keys in other attributes!" readKeyCmt ename = "Transforms a string into a key of a `" ++ ename ++ "` entity.\n" ++ "Nothing is returned if the string does not represent a meaningful key." -- Generates operations to access and manipulate entries of entities -- (as used by the Spicey web framework) genEntryFuncs :: String -> Entity -> [CFuncDecl] genEntryFuncs mName (Entity name attrs) = case head attrs of (Attribute "Key" _ PKey _ ) -> [ stCmtFunc ("Gets all `" ++ name ++ "` entities.") (mName, "queryAll" ++ name ++ "s") 0 Public (applyTC (mConn, "DBAction") [listType (baseType (mName, name))]) [simpleRule [] (applyF (mER, "getAllEntries") [constF endescr])] , stCmtFunc ("Gets all `" ++ name ++ "` entities satisfying a given predicate.") (mName, "queryCond" ++ name) 0 Public ((baseType (mName, name) ~> boolType) ~> applyTC (mConn, "DBAction") [listType (baseType (mName, name))]) [simpleRule [] (applyF (mER, "getCondEntries") [constF endescr])] , stCmtFunc ("Gets a `" ++ name ++ "` entry by a given key.") (mName, "get" ++ name) 0 Public (baseType (mName, name ++ "ID") ~> applyTC (mConn, "DBAction") [baseType (mName, name)]) [simpleRule [] (applyF (mER, "getEntryWithKey") [ constF endescr , constF (mName, lname ++ "ColumnKey") , constF (mName, lname ++ "ID")])] , let numargs = length attrs - 1 args = map ((++"_p") . firstLow . attributeName) (tail attrs) adoms = map attributeDomain (tail attrs) in stCmtFunc ("Inserts a new `" ++ name ++ "` entity.") (mName, "new" ++ name ++ attrs2WithKeys) numargs Public (foldr (~>) (applyTC (mConn, "DBAction") [baseType (mName, name)]) (map (attr2NewCType mName name) (tail attrs))) [simpleRule (map cpvar args) (applyF (mER, "insertNewEntry") [ constF endescr , constF (mName, "set" ++ name ++ "Key") , constF (mName, name ++ "ID") , applyF (mName, name) (applyF (mName, name ++ "ID") [cInt 0] : map domVar2NewExp (zip adoms args)) ])] , stCmtFunc ("Deletes an existing `" ++ name ++ "` entry by its key.") (mName, "delete" ++ name) 0 Public (baseType (mName, name) ~> applyTC (mConn, "DBAction") [unitType]) [simpleRule [] (applyF (mER, "deleteEntry") [ constF endescr , constF (mName, lname ++ "ColumnKey") , applyF (pre ".") [constF (mName, lname ++ "ID"), constF (mName, lname ++ "Key")]])] , stCmtFunc ("Updates an existing `" ++ name ++ "` entry by its key.") (mName, "update" ++ name) 0 Public (baseType (mName, name) ~> applyTC (mConn, "DBAction") [unitType]) [simpleRule [] (applyF (mER, "updateEntry") [constF endescr ])] ] _ -> let numargs = length attrs args = map (\i -> 'k' : show i) [1 .. numargs] in [ stCmtFunc ("Inserts a new `" ++ name ++ "` relation.") (mName, "new" ++ name) numargs Public (foldr (~>) (applyTC (mConn, "DBAction") [unitType]) (map (getAttributeType mName name) attrs)) [simpleRule (map cpvar args) (applyF (mER, "insertEntry") [ constF endescr , applyF (mName, name) (map cvar args) ])] , stCmtFunc ("Deletes an existing `" ++ name ++ "` relation.") (mName, "delete" ++ name) numargs Public (foldr (~>) (applyTC (mConn, "DBAction") [unitType]) (map (getAttributeType mName name) attrs)) [simpleRule (map cpvar args) (applyF (mER, "deleteEntryR") (constF endescr : concatMap attr2args (zip attrs args)))] , case attrs of [Attribute aname1 (KeyDom adom1) _ _, Attribute aname2 (KeyDom adom2) _ _] -> stCmtFunc ("Gets the associated `" ++ adom1 ++ "` entities for a given `" ++ adom2 ++ "` entity\n" ++ "w.r.t. the `" ++ name ++ "` relation.") (mName, "get" ++ name ++ adom1 ++ adom2 ++ "s") 1 Public (baseType (mName,adom1) ~> applyTC (mConn, "DBAction") [listType (baseType (mName,adom2))]) [simpleRule [cpvar "en"] (applyF (mER,">+=") [ applyF (mER, "getEntriesWithColVal") [ constF endescr , constF (mName, lname ++ "Column" ++ aname1) , applyF (mName, firstLow adom1 ++ "ID") [applyF (mName, firstLow adom1 ++ "Key") [cvar "en"]] ] , CLambda [cpvar "vals"] (applyF (pre "mapM") [ constF (mName, "get" ++ adom2) , applyF (pre "map") [ constF (mName, lname ++ aname2) , cvar "vals"]]) ])] _ -> error $ "Non-binary relation entity " ++ name ] where lname = firstLow name endescr = (mName, lname ++ "_CDBI_Description") attr2args (Attribute aname adom _ _, arg) = [ constF (mName, lname ++ "Column" ++ aname) , case adom of KeyDom en -> applyF (mName, firstLow en ++ "ID") [cvar arg] _ -> error $ "No KeyDom attribute in relation entity " ++ name ] attrs2WithKeys = concatMap (("With"++) . attributeName) (filter isForeignKey attrs) -- Translates an attribute domain and a variable into an expression. -- If the domain has a default value, a maybe expression is generated. domVar2NewExp :: (Domain, String) -> CExpr domVar2NewExp (dom, v) = case dom of IntDom (Just x) -> genMaybeWith (cInt x) FloatDom (Just x) -> genMaybeWith (cFloat x) CharDom (Just x) -> genMaybeWith (cChar x) BoolDom (Just x) -> genMaybeWith (boolCExpr x) StringDom (Just x) -> applyF (pre "if_then_else") [applyF (pre "null") [cvar v], string2ac x, cvar v] DateDom (Just (CalendarTime yr mo dy hr mi sc tz)) -> genMaybeWith (applyF (inTime "toClockTime") [applyF (inTime "CalendarTime") [cInt yr, cInt mo, cInt dy, cInt hr, cInt mi, cInt sc, cInt tz]]) _ -> cvar v where genMaybeWith dflt = applyF (pre "maybe") [dflt, constF (pre "id"), cvar v] -- Generates operations to create a new database with its schema. genNewDBSchema :: String -> [Entity] -> [CFuncDecl] genNewDBSchema mname ents = [ stCmtFunc ("Generates a new database (name provided as the parameter) and\n" ++ "creates its schema.") (mname,"createNewDB") 1 Public (stringType ~> ioType unitType) [CRule [cpvar "dbfile"] (CSimpleRhs (CDoExpr [CSPat (cpvar "conn") (applyF (mConn,"connectSQLite") [cvar "dbfile"]), CSExpr (applyF (mConn,"writeConnection") [cvar "cstr", cvar "conn"]), CSExpr (applyF (mConn,"disconnect") [cvar "conn"])]) [CLocalPat (cpvar "cstr") (CSimpleRhs (applyF (pre "unlines") [list2ac (map (string2ac . entity2createTable) ents)]) [])])] ] -- Generates operations to save and restore the complete database. genSaveDB :: String -> [Entity] -> [CFuncDecl] genSaveDB mname ents = [ stCmtFunc ("Saves complete database as term files into an existing directory\n" ++ "provided as a parameter.") (mname,"saveDBTo") 1 Public (stringType ~> ioType unitType) [simpleRule [cpvar "dir"] (CDoExpr (map saveDBTerms ents))] , stCmtFunc ("Restores complete database from term files which are stored\n" ++ "in a directory provided as a parameter.") (mname,"restoreDBFrom") 1 Public (stringType ~> ioType unitType) [simpleRule [cpvar "dir"] (CDoExpr (map restoreDBTerms ents))] ] where saveDBTerms (Entity name _) = CSExpr $ applyF (mER,"saveDBTerms") [ constF (mname, firstLow name ++ "_CDBI_Description") , constF (mname,"sqliteDBFile") , cvar "dir"] restoreDBTerms (Entity name _) = CSExpr $ applyF (mER,"restoreDBTerms") [ constF (mname, firstLow name ++ "_CDBI_Description") , constF (mname,"sqliteDBFile") , cvar "dir"] -- Generates runQ/runT operations (used by the Spicey web framework). genRunFuncs :: String -> [CFuncDecl] genRunFuncs mname = [ stCmtFunc "Runs a DB action (typically a query)." (mname,"runQ") 0 Public (applyTC (mConn, "DBAction") [ctvar "a"] ~> ioType (ctvar "a")) [simpleRule [] (applyF (mER, "runQueryOnDB") [constF (mname,"sqliteDBFile")])] , stCmtFunc "Runs a DB action as a transaction." (mname,"runT") 0 Public (applyTC (mConn, "DBAction") [ctvar "a"] ~> ioType (applyTC (mConn,"SQLResult") [ctvar "a"])) [simpleRule [] (applyF (mER, "runTransactionOnDB") [constF (mname,"sqliteDBFile")])] , stCmtFunc "Runs a DB action as a transaction. Emits an error in case of failure." (mname,"runJustT") 0 Public (applyTC (mConn, "DBAction") [ctvar "a"] ~> ioType (ctvar "a")) [simpleRule [] (applyF (mER, "runJustTransactionOnDB") [constF (mname,"sqliteDBFile")])] ] ---------------------------------------------------------------------------- --- Generates the `CREATE TABLE` SQL command for a given entity. entity2createTable :: Entity -> String entity2createTable (Entity name (a:atr)) = case a of Attribute "Key" _ _ _ -> "create table '" ++ name ++ "'(" ++ foldl (\y x -> y ++ " ," ++ attr2colType x) (attr2colType a) atr ++ ");" _ -> "create table '" ++ name ++ "'(" ++ foldl (\y x -> y ++ " ," ++ relationship2colType x) (relationship2colType a) atr ++ ", primary key (" ++ attr2combPrimaryKey (a:atr) ++ "));" -- Transforms an attribute to the corresponding column type of the -- database table (used when the first attribute of the entity -- is named "Key" because the primary key will be that "Key" then). attr2colType :: Attribute -> String attr2colType (Attribute name ty key nullable) = "'" ++ name ++ "'" ++ (case ty of IntDom Nothing -> "" IntDom _ -> " int" FloatDom _ -> " float" CharDom _ -> " char" StringDom _ -> " string" BoolDom _ -> " string" -- " boolean" -- no boolean type in SQLite3 DateDom _ -> " string" KeyDom str -> " int " ++ "REFERENCES '" ++ str ++ "'(Key)") ++ (case key of PKey -> " integer primary key" Unique -> " unique" NoKey -> "") ++ (case nullable of True -> "" False -> if key == PKey then "" else " not null") -- Same as 'attr2colType' but for the case that the first attribute of the -- entity is not named "Key", because there will be a combined primary key -- so that the description is a little different. relationship2colType :: Attribute -> String relationship2colType (Attribute name ty key nullable) = "'" ++ name ++ "'" ++ (case ty of IntDom _ -> " int" FloatDom _ -> " float " CharDom _ -> " char " StringDom _ -> " string " BoolDom _ -> " string " -- " boolean " -- no boolean type in SQLite3 DateDom _ -> " string " KeyDom str -> " int " ++ "REFERENCES '" ++ str ++"'(Key)") ++ (case key of Unique -> " unique" _ -> "") ++ (case nullable of True -> "" False -> " not null") -- Write a combined primary key attr2combPrimaryKey :: [Attribute] -> String attr2combPrimaryKey (Attribute name _ PKey _ : atr) = "'" ++ name ++ "'" ++ (case attr2combPrimaryKey atr of "" -> "" x -> ", " ++ x) attr2combPrimaryKey (Attribute _ _ Unique _ : atr) = attr2combPrimaryKey atr attr2combPrimaryKey (Attribute _ _ NoKey _ : atr) = attr2combPrimaryKey atr attr2combPrimaryKey [] = "" ---------------------------------------------------------------------------- firstLow :: String -> String firstLow [] = [] firstLow (c:cs) = toLower c : cs firstUp :: String -> String firstUp [] = [] firstUp (c:cs) = toUpper c : cs lowerCase :: String -> String lowerCase s = map toLower s -- A Boolean as an AbstractCurry expression. boolCExpr :: Bool -> CExpr boolCExpr b = constF (pre (if b then "True" else "False")) -- The name of the Time module: timeMod :: String timeMod = "Data.Time" -- A symbol from module `Data.Time`. inTime :: String -> QName inTime f = (timeMod, f) -- A symbol from module `CPP.ICode.Parser.SQL.ParserInfoType`. pinfoType :: String -> CExpr pinfoType f = CSymbol ("CPP.ICode.Parser.SQL.ParserInfoType", f) ----------------------------------------------------------------------------