Permalink
Browse files

Adding functional ORM

  • Loading branch information...
1 parent 421e3c0 commit 4e7b9730d243b9b181be485b78d18608e2b311fb alson committed Nov 26, 2008
@@ -1,41 +1,46 @@
module Turbinado.Database.ORM.Generator where
+import Control.Monad
+import Data.List
import qualified Data.Map as M
+import Data.Maybe
+import Database.HDBC
import Config.Master
-
-type TableName = String
-type ColumnName = String
-type Column = (SqlColDesc, DependentKeys, Boolean) -- Boolean == isPrimaryKey
-type DependentKeys = [((ColumnName, (TableName, ColumnName))] -- all columns which are targets of foreign keys
-
-type TableColumn = (TableName, ColumnName)
-type TableColumns = M.Map TableColumn Column
-
-generateModels :: FilePath -> IO ()
-generateModels cs fp = do conn <- databaseConnection
- ts <- Database.HDBC.getTables conn
- ds <- zip ts $ mapM (describeTable conn) ts
- let tcs = combineTablesColumns ts ds
- -- TODO: Pull in indices
- pks <- getPrimaryKeys conn ts
- let tcs' = combinePrimaryKeys pks tcs
- fks <- getForeignKeys t
- let tcs'' = combineForeignKeys fks tcs'
+import Turbinado.Database.ORM.Types
+import Turbinado.Database.ORM.Output
+import Turbinado.Database.ORM.PostgreSQL
+
+generateModels :: IO ()
+generateModels = do conn <- fromJust databaseConnection
+ ts <- getTables conn
+ -- TODO: Pull in indices
+ tcs <- foldM (buildTable conn) (M.empty) ts
+ writeModels tcs
-combineTablesColumns :: [TableName] -> [(ColumnName, SqlColDesc)] -> TableColumns
-combineTablesColumsn ts cs =
- M.fromList $ zipWith (\t (c, d) -> ((t,c), (d, [], False)) ) ts cs
-
-combinePrimaryKeys :: [(TableName, [ColumnName])] -> TableColumns -> TableColumns
-combinePrimaryKeys pks tcs =
- foldl (\tcs (t, cs) -> foldl (\c -> M.adjust (\(d,k,_) -> (d, k, True)) (t, c) ) tcs cs) tcs pks
-
-combineForeignKeys :: [(TableColumn, TableColumn)] -> TableColumns -> TableColumns
-combineForeignKeys fks tcs = foldl (\tcs' fk -> combineForeignKey fk tcs') tcs fks
-
-combineForeignKey :: (TableColumn, TableColumn) -> TableColumns -> TableColumns
-combineForeignKey (parTable, parColumn), ((depTable, depColumn)) tcs =
- let c@(d, k, i) = M.lookup (parTable, parColumn) tcs in
- M.insert (parTable, parColumn) (d, k `union` (parColumn, (depTable, depColumn)), i) t
+buildTable conn tcs t = do ds <- describeTable conn t
+ let tcs' = combineDescription t ds tcs
+ pks <- getPrimaryKeys conn t
+ let tcs'' = combinePrimaryKeys t pks tcs'
+ fks <- getForeignKeyReferences conn t
+ return $ combineForeignKeyReferences t fks tcs''
+
+combineDescription t ds tcs = M.insert t (cols, []) tcs
+ where cols = M.fromList $
+ map (\(columnName, columnDescription) -> (columnName, (columnDescription,[]))) ds
+
+combinePrimaryKeys :: TableName -> [ColumnName] -> Tables -> Tables
+combinePrimaryKeys t pks tcs = M.adjust (\(c, _) -> (c,pks)) t tcs
+
+combineForeignKeyReferences :: TableName -> [(ColumnName, TableName, ColumnName)] -> Tables -> Tables
+combineForeignKeyReferences t fks tcs =
+ M.adjust
+ (\(cs, pks) -> (foldl (worker) cs fks, pks))
+ t tcs
+ where worker cs (c, tt, tc) = M.adjust (\(cd, deps) -> (cd, [(tt, tc)] `union` deps)) c cs
+{-
+ - combineTablesColumns :: [TableName] -> [(ColumnName, SqlColDesc)] -> Tables
+ - combineTablesColumsn ts cs =
+ - M.fromList $ zipWith (\t (c, d) -> (t, (c, [])) ) ts cs
+ -}
@@ -1,117 +1,83 @@
-module Database.HDBC.Generator where
+module Turbinado.Database.ORM.Output where
+
import qualified Data.Char
import Control.Monad
import Data.Dynamic
+import qualified Data.Map as M
+import Data.Maybe
import Data.List
import Database.HDBC
import System.Directory
+import System.FilePath
--- TODO: This file needs to be completely torn up and generalized.
+import Turbinado.Database.ORM.Types
-type TableName = String
-type ParentName = String
type TypeName = String
-type PrimaryKeyColumnNames = [String]
-type PrimaryKeyTypeNames = [String]
-
-data TableSpec = TableSpec {
- tableName :: String,
- primaryKey :: (PrimaryKeyColumnNames, PrimaryKeyTypeNames),
- columnDescriptions :: [(String, SqlColDesc)]
- }
-
-generateModels conn path parentName =
- do writeFile (joinPath [path, "Bases/ModelBase.hs"]) generateModelBase
- mapM (\t -> let typeName = (capitalizeName t)
- fullName = typeName ++ "Model" in
- do desc <- describeTable conn t
- writeFile (joinPath [path, "Bases/", fullName ++ "Base.hs"]) (generateModel parentName typeName (TableSpec t (getPrimaryKeysFromDesc desc) desc))
- e <- doesFileExist (joinPath [path, fullName ++ ".hs"])
- when (not e) (writeFile (joinPath [path, fullName++".hs"]) (generateModelFile parentName typeName) )
- )
- =<< (getTables conn)
-
-getPrimaryKeysFromDesc:: [(String, SqlColDesc)] -> (PrimaryKeyColumnNames, PrimaryKeyTypeNames)
-getPrimaryKeysFromDesc desc =
- worker ([],[]) desc
- where worker (c,t) [] = (c,t)
- worker (c,t) (d:ds) = worker (if ((colIsPrimaryKey $ snd d) == True) then (c++[fst d], t++[getHaskellTypeString $ colType $ snd d]) else (c,t)) ds
-
-
-{-------------------------------------------------------------------------}
-columnToFieldLabel :: (String, SqlColDesc) -> String
-columnToFieldLabel (name, desc) =
- " " ++ partiallyCapitalizeName name ++ " :: " ++
- (if ((colNullable desc) == Just True) then "Maybe " else "") ++
- getHaskellTypeString (colType desc)
-
-{-------------------------------------------------------------------------}
-generateFindByPrimaryKey :: TypeName -> TableSpec -> [String]
-generateFindByPrimaryKey typeName tspec =
- case (length $ fst $ primaryKey tspec) of
- 0 -> [""]
- _ -> ["instance HasFindByPrimaryKey " ++ typeName ++ " " ++ " (" ++ unwords (intersperse "," (snd $ primaryKey tspec)) ++ ") " ++ " where"
- ," find conn pk@(" ++ (concat $ intersperse ", " $ map (\i -> "pk"++(show i)) [1..(length $ fst $ primaryKey tspec)]) ++ ") = do"
- ," res <- quickQuery' conn (\"SELECT * FROM " ++ tableName tspec ++ " WHERE (" ++ generatePrimaryKeyWhere (fst $ primaryKey tspec) ++ "++ \")\") []"
- ," case res of"
- ," [] -> throwDyn $ SqlError"
- ," {seState = \"\","
- ," seNativeError = (-1),"
- ," seErrorMsg = \"No record found when finding by Primary Key:" ++ (tableName tspec) ++ " : \" ++ (show pk)"
- ," }"
- ," r:[] -> return $ " ++ (generateConstructor typeName tspec)
- ," _ -> throwDyn $ SqlError"
- ," {seState = \"\","
- ," seNativeError = (-1),"
- ," seErrorMsg = \"Too many records found when finding by Primary Key:" ++ (tableName tspec) ++ " : \" ++ (show pk)"
- ," }"
- ]
-
-generateFinders :: TypeName -> TableSpec -> [String]
-generateFinders typeName tspec =
- ["instance HasFinders " ++ typeName ++ " where"
- ," findAll conn = do"
- ," res <- quickQuery' conn \"SELECT * FROM " ++ tableName tspec ++ "\" []"
- ," return $ map (\\r -> " ++ generateConstructor typeName tspec ++ ") res"
- ," findAllBy conn ss sp = do"
- ," res <- quickQuery' conn (\"SELECT * FROM " ++ tableName tspec ++ " WHERE (\" ++ ss ++ \") \") sp"
- ," return $ map (\\r -> " ++ generateConstructor typeName tspec ++ ") res"
- ," findOneBy conn ss sp = do"
- ," res <- quickQuery' conn (\"SELECT * FROM " ++ tableName tspec ++ " WHERE (\" ++ ss ++ \") LIMIT 1\") sp"
- ," return $ (\\r -> " ++ generateConstructor typeName tspec ++ ") (head res)"
- ]
-{-----------------------------------------------------------------------}
-generatePrimaryKeyWhere cnames =
- unwords $
- intersperse "++ \" AND \" ++ \"" $
- map (\(c,i) -> c ++ " = \" ++ (show pk" ++ (show i) ++ ")") (zip cnames [1..])
+-- TODO: This file needs to be completely torn up and generalized.
-generateConstructor typeName tspec =
- typeName ++ " " ++ (unwords $
- map (\i -> "(fromSql (r !! " ++ (show i) ++ "))") [0..((length $ columnDescriptions tspec)-1)])
+writeModels ts =
+ do writeFile "App/Models/Bases/ModelBase.hs" generateModelBase
+ mapM_ (\(t, (cs, pk)) ->
+ let typeName = (capitalizeName t)
+ fullName = typeName ++ "Model" in
+ do e <- doesFileExist (joinPath ["App/Models", fullName ++ ".hs"])
+ when (not e) (writeFile (joinPath ["App/Models", fullName++".hs"]) (generateModelFile typeName) )
+ writeFile (joinPath ["App/Models/Bases", fullName ++ "Base.hs"]) (generateModel t typeName pk cs)
+ ) $ M.toList ts
---------------------------------------------------------------------------
-- File templates --
---------------------------------------------------------------------------
-generateModelFile parentName modelName =
- let fullName = (if (length parentName > 0) then parentName ++ "." else "") ++ modelName ++ "Model"
- in unlines $
- ["module " ++ fullName
- ," ( module " ++ fullName
- ," , module Bases." ++ fullName ++ "Base "
+generateModel :: TableName ->
+ TypeName ->
+ PrimaryKey ->
+ Columns ->
+ String
+generateModel t typeName pk cs =
+ unlines $
+ ["{- DO NOT EDIT THIS FILE"
+ ," THIS FILE IS AUTOMAGICALLY GENERATED AND YOUR CHANGES WILL BE EATEN BY THE GENERATOR OVERLORD"
+ ,""
+ ," All changes should go into the Model file (e.g. ExampleModel.hs) and"
+ ," not into the base file (e.g. ExampleModelBase.hs) -}"
+ ,""
+ ,"module Models.Bases." ++ typeName ++ "ModelBase ( "
+ ," module Models.Bases." ++ typeName ++ "ModelBase, "
+ ," module Models.Bases.ModelBase) where"
+ , ""
+ , "import Models.Bases.ModelBase"
+ , "import System.Time"
+ , ""
+ , "data " ++ typeName ++ " = " ++ typeName ++ " {"
+ ] ++
+ [intercalate "," (map columnToFieldLabel (M.toList cs))] ++
+ [ " } deriving (Eq, Show)"
+ , ""
+ , "instance DatabaseModel " ++ typeName ++ " where"
+ , " tableName _ = \"" ++ t ++ "\""
+ , ""
+ ] ++
+ generateFindByPrimaryKey t cs typeName pk ++
+ generateFinders t cs typeName
+
+generateModelFile typeName =
+ unlines $
+ ["module Models." ++ typeName ++ "Model"
+ ," ( module Models." ++ typeName ++ "Model"
+ ," , module Models.Bases." ++ typeName ++ "ModelBase"
," ) where"
- ,"import Bases." ++ fullName ++ "Base"
+ ,"import Models.Bases." ++ typeName ++ "ModelBase"
]
generateModelBase :: String
generateModelBase = unlines $
["{- DO NOT EDIT THIS FILE"
," THIS FILE IS AUTOMAGICALLY GENERATED AND YOUR CHANGES WILL BE EATEN BY THE GENERATOR OVERLORD -}"
,""
- ,"module ModelBase ("
- ," module ModelBase,"
+ ,"module Models.Bases.ModelBase ("
+ ," module Models.Bases.ModelBase,"
," module Control.Exception,"
," module Database.HDBC,"
," module Data.Int"
@@ -139,44 +105,69 @@ generateModelBase = unlines $
," findOneBy :: IConnection conn => conn -> SelectString -> SelectParams -> IO model"
,""
]
-{-------------------------------------------------------------------------}
-generateModel :: ParentName ->
- TypeName ->
- TableSpec ->
- String
-generateModel parentName typeName tspec =
- let cleanParentName = if (length parentName > 0) then parentName ++ "." else ""
- in unlines $
- ["{- DO NOT EDIT THIS FILE"
- ," THIS FILE IS AUTOMAGICALLY GENERATED AND YOUR CHANGES WILL BE EATEN BY THE GENERATOR OVERLORD"
- ,""
- ," All changes should go into the Model file (e.g. ExampleModel.hs) and"
- ," not into the base file (e.g. ExampleModelBase.hs) -}"
- ,""
- ,"module " ++ cleanParentName ++ typeName ++ "ModelBase ( "
- ," module Bases." ++ cleanParentName ++ typeName ++ "ModelBase, "
- ," module " ++ cleanParentName ++ "ModelBase) where"
- , ""
- , "import Bases." ++ cleanParentName ++ "ModelBase"
- , ""
- , "data " ++ typeName ++ " = " ++ typeName ++ " {"
- ] ++
- addCommas (map columnToFieldLabel (columnDescriptions tspec)) ++
- [ " } deriving (Eq, Show)"
- , ""
- , "instance DatabaseModel " ++ typeName ++ " where"
- , " tableName _ = \"" ++ tableName tspec ++ "\""
- , ""
- ] ++
- generateFindByPrimaryKey typeName tspec ++
- generateFinders typeName tspec
-
-
+
+---------------------------------------------------------------------------
+-- Generator templates --
+---------------------------------------------------------------------------
+
+generateFindByPrimaryKey :: TableName -> Columns -> TypeName -> PrimaryKey -> [String]
+generateFindByPrimaryKey t cs typeName pk =
+ case (length pk) of
+ 0 -> [""]
+ _ -> ["instance HasFindByPrimaryKey " ++ typeName ++ " " ++ " (" ++ unwords (intersperse "," (map (\c -> getHaskellTypeString $ colType $ fst $ fromJust $ M.lookup c cs) pk)) ++ ") " ++ " where"
+ ," find conn pk@(" ++ (concat $ intersperse ", " $ map (\i -> "pk"++(show i)) [1..(length pk)]) ++ ") = do"
+ ," res <- quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t ++ " WHERE (" ++ (generatePrimaryKeyWhere pk) ++ ")\") [" ++ (unwords $ intersperse "," $ map (\(c,i) -> "toSql pk" ++ (show i)) (zip pk [1..])) ++ "]"
+ ," case res of"
+ ," [] -> throwDyn $ SqlError"
+ ," {seState = \"\","
+ ," seNativeError = (-1),"
+ ," seErrorMsg = \"No record found when finding by Primary Key:" ++ t ++ " : \" ++ (show pk)"
+ ," }"
+ ," r:[] -> return $ " ++ (generateConstructor cs typeName)
+ ," _ -> throwDyn $ SqlError"
+ ," {seState = \"\","
+ ," seNativeError = (-1),"
+ ," seErrorMsg = \"Too many records found when finding by Primary Key:" ++ t ++ " : \" ++ (show pk)"
+ ," }"
+ ]
+
+generateFinders :: TableName -> Columns -> TypeName -> [String]
+generateFinders t cs typeName =
+ ["instance HasFinders " ++ typeName ++ " where"
+ ," findAll conn = do"
+ ," res <- quickQuery' conn \"SELECT " ++ cols cs ++ " FROM " ++ t ++ "\" []"
+ ," return $ map (\\r -> " ++ generateConstructor cs typeName ++ ") res"
+ ," findAllBy conn ss sp = do"
+ ," res <- quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t++ " WHERE (\" ++ ss ++ \") \") sp"
+ ," return $ map (\\r -> " ++ generateConstructor cs typeName ++ ") res"
+ ," findOneBy conn ss sp = do"
+ ," res <- quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t++ " WHERE (\" ++ ss ++ \") LIMIT 1\") sp"
+ ," return $ (\\r -> " ++ generateConstructor cs typeName ++ ") (head res)"
+ ]
+
+{-----------------------------------------------------------------------}
+generatePrimaryKeyWhere pk =
+ unwords $
+ intersperse "++ \" AND \" ++ \"" $
+ map (\(c,i) -> c ++ " = ? ") (zip pk [1..])
+
+generateConstructor cs typeName =
+ typeName ++ " " ++ (unwords $
+ map (\i -> "(fromSql (r !! " ++ (show i) ++ "))") [0..((M.size cs) - 1)])
+
+
---------------------------------------------------------------------------
-- Utility functions --
---------------------------------------------------------------------------
-addCommas (s:[]) = [s]
-addCommas (s:ss) = (s ++ ",") : (addCommas ss)
+cols :: Columns -> String
+cols cs = unwords $ intersperse "," $ M.keys cs
+
+columnToFieldLabel :: (String, (SqlColDesc, ForeignKeyReferences)) -> String
+columnToFieldLabel (name, (desc, _)) =
+ " " ++ partiallyCapitalizeName name ++ " :: " ++
+ (if ((colNullable desc) == Just True) then "Maybe " else "") ++
+ getHaskellTypeString (colType desc)
+
getHaskellTypeString :: SqlTypeId -> String
getHaskellTypeString SqlCharT = "String"
@@ -194,11 +185,11 @@ getHaskellTypeString SqlFloatT = "Float"
getHaskellTypeString SqlDoubleT = "Double"
getHaskellTypeString SqlTinyIntT = "Int32"
getHaskellTypeString SqlBigIntT = "Int64"
-getHaskellTypeString SqlDateT = "UTCTime"
-getHaskellTypeString SqlTimeT = "UTCTime"
-getHaskellTypeString SqlTimestampT = "UTCTime"
-getHaskellTypeString SqlUTCDateTimeT = "UTCTime"
-getHaskellTypeString SqlUTCTimeT = "UTCTime"
+getHaskellTypeString SqlDateT = "ClockTime"
+getHaskellTypeString SqlTimeT = "ClockTime"
+getHaskellTypeString SqlTimestampT = "ClockTime"
+getHaskellTypeString SqlUTCDateTimeT = "ClockTime"
+getHaskellTypeString SqlUTCTimeT = "TimeDiff"
getHaskellTypeString _ = error "Don't know how to translate this SqlTypeId to a SqlValue"
Oops, something went wrong.

0 comments on commit 4e7b973

Please sign in to comment.