Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Tree: ec79feee16
Fetching contributors…

Cannot retrieve contributors at this time

396 lines (355 sloc) 18.787 kB
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
import Turbinado.Database.ORM.Types
type TypeName = String
-- TODO: This file needs to be completely torn up and generalized.
writeModels ts =
do writeFile "App/Models/Bases/Common.hs" generateCommon
mapM_ (\(t, (cs, pk)) ->
let typeName = (capitalizeName t) in
do e <- doesFileExist (joinPath ["App/Models", typeName ++ ".hs"])
when (not e) (writeFile (joinPath ["App/Models", typeName++".hs"]) (generateModelFile typeName) )
writeFile (joinPath ["App/Models/Bases", typeName ++ "Type.hs"]) (generateType t typeName pk ts cs)
writeFile (joinPath ["App/Models/Bases", typeName ++ "Functions.hs"]) (generateFunctions t typeName pk ts cs)
writeFile (joinPath ["App/Models/Bases", typeName ++ "Relations.hs"]) (generateRelations t typeName pk ts cs)
) $ M.toList ts
---------------------------------------------------------------------------
-- File templates --
---------------------------------------------------------------------------
generateType :: TableName ->
TypeName ->
PrimaryKey ->
Tables ->
Columns ->
String
generateType t typeName pk ts 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. App/Models/ExampleModel.hs)"
,"-}"
,""
,"module App.Models.Bases." ++ typeName ++ "Type where"
, ""
, "import App.Models.Bases.Common"
, "import Data.Maybe"
, "import System.Time"
, ""
] ++
["-- The data type for this model"] ++
[ "data " ++ typeName ++ " = " ++ typeName ++ " {"
] ++
[intercalate ",\n" (map columnToFieldLabel (M.toList cs))] ++
[ " } deriving (Eq, Show)"
, ""
, "instance DatabaseModel " ++ typeName ++ " where"
, " tableName _ = \"" ++ t ++ "\""
, ""
]
generateFunctions :: TableName ->
TypeName ->
PrimaryKey ->
Tables ->
Columns ->
String
generateFunctions t typeName pk ts 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. App/Models/ExampleModel.hs)"
,"-}"
,""
,"module App.Models.Bases." ++ typeName ++ "Functions where"
, ""
, "import App.Models.Bases.Common"
, "import qualified Database.HDBC as HDBC"
, "import Data.Maybe"
, "import System.Time"
, ""
, " -- My type"
, "import App.Models.Bases." ++ typeName ++ "Type"
, ""
, "import Turbinado.Environment.Types"
, "import Turbinado.Environment.Database"
, ""
] ++
[""] ++
generateHasFindByPrimaryKey t cs typeName pk ++
[""] ++
generateIsModel t cs typeName
generateRelations :: TableName ->
TypeName ->
PrimaryKey ->
Tables ->
Columns ->
String
generateRelations t typeName pk ts 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. App/Models/ExampleModel.hs)"
,"-}"
,""
,"module App.Models.Bases." ++ typeName ++ "Relations where"
, ""
, "import App.Models.Bases.Common"
, "import qualified Database.HDBC as HDBC"
, "import Data.Maybe"
, "import System.Time"
, ""
, " -- Model imports"
, "import App.Models.Bases." ++ typeName ++ "Type"
, unlines $ generateChildModelImports cs
, unlines $ generateParentModelImports t ts
, ""
, "import Turbinado.Environment.Types"
, "import Turbinado.Environment.Database"
, ""
] ++
[""] ++
[""] ++
generateHasChildren t cs typeName ++
[""] ++
[""] ++
generateHasParents t ts
generateChildModelImports cs =
map (\ctn -> "import qualified App.Models.Bases." ++ capitalizeName ctn ++ "Type as " ++ capitalizeName ctn ++ "Type\nimport qualified App.Models.Bases." ++ capitalizeName ctn ++ "Functions as " ++ capitalizeName ctn ++ "Functions") $
nub $
map fst $ concat $
map (\(_, fks, _) -> fks) $ M.elems cs
generateParentModelImports t ts =
map (\ptn -> "import qualified App.Models." ++ capitalizeName ptn ++ "Type as " ++ capitalizeName ptn ++ "Type\nimport qualified App.Models." ++ capitalizeName ptn ++ "Functions as " ++ capitalizeName ptn ++ "Functions") $
nub $ filter (not . null) $
map parentFilter $ M.assocs ts
where parentFilter (ptn, (cs, _)) =
case (filter (\(tn, _) -> t == tn) $ concat $ map (\(_, fks, _) -> fks) $ M.elems cs) of
[] -> []
_ -> ptn
generateModelFile typeName =
unlines $
["module App.Models." ++ typeName ++ "Model"
," ( module App.Models." ++ typeName ++ "Model"
," , module App.Models.Bases." ++ typeName ++ "Type"
," , module App.Models.Bases." ++ typeName ++ "Finders"
," , module App.Models.Bases." ++ typeName ++ "Relations"
," , module App.Models.Bases.Common"
," ) where"
,"import App.Models.Bases." ++ typeName ++ "Type"
,"import App.Models.Bases." ++ typeName ++ "Functions"
,"import App.Models.Bases." ++ typeName ++ "Relations"
,"import App.Models.Bases.Common"
]
generateCommon:: String
generateCommon = unlines $
["{- DO NOT EDIT THIS FILE"
," THIS FILE IS AUTOMAGICALLY GENERATED AND YOUR CHANGES WILL BE EATEN BY THE GENERATOR OVERLORD -}"
,""
,"module App.Models.Bases.Common("
," module App.Models.Bases.Common,"
," module Control.Exception,"
," module Control.Monad.Trans,"
," module Data.Int"
," ) where"
,""
,"import Control.Monad.Trans"
,"import Control.Exception"
,"import Database.HDBC"
,"import Data.Int"
,""
,"import Turbinado.Environment.Types"
,""
,"-- Using phantom types here "
,"class DatabaseModel m where"
," tableName :: m -> String"
,""
,"type SelectString = String"
,"type SelectParams = [SqlValue]"
,"type OrderByParams = String"
,""
,"class (DatabaseModel model) =>"
," IsModel model where"
," insert :: (HasEnvironment m) => model -> Bool -> m (Maybe Integer)"
," findAll :: (HasEnvironment m) => m [model]"
," findAllWhere :: (HasEnvironment m) => SelectString -> SelectParams -> m [model]"
," findAllOrderBy :: (HasEnvironment m) => OrderByParams -> m [model]"
," findAllWhereOrderBy :: (HasEnvironment m) => SelectString -> SelectParams -> OrderByParams -> m [model]"
," findOneWhere :: (HasEnvironment m) => SelectString -> SelectParams -> m model"
," findOneOrderBy :: (HasEnvironment m) => OrderByParams -> m model"
," findOneWhereOrderBy :: (HasEnvironment m) => SelectString -> SelectParams -> OrderByParams -> m model"
,""
,"class (DatabaseModel model) =>"
," HasFindByPrimaryKey model primaryKey | model -> primaryKey where"
," find :: (HasEnvironment m) => primaryKey -> m model"
," update :: (HasEnvironment m) => model -> m () "
,""
]
---------------------------------------------------------------------------
-- Generator templates --
---------------------------------------------------------------------------
generateIsModel :: TableName -> Columns -> TypeName -> [String]
generateIsModel t cs typeName =
["instance IsModel " ++ typeName ++ " where"
," insert m returnId = do"
," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
," res <- liftIO $ HDBC.handleSqlError $ HDBC.run conn \" INSERT INTO " ++ t ++ " (" ++ (concat $ intersperse "," $ M.keys cs) ++") VALUES (" ++ (intercalate "," (take (M.size cs) (repeat "?"))) ++ ")\""
," [" ++ (unwords $ intersperse "," $ map (\c -> "HDBC.toSql $ " ++ partiallyCapitalizeName c ++ " m") (M.keys cs) ) ++ "]"
," liftIO $ HDBC.handleSqlError $ HDBC.commit conn"
," if returnId"
," then do i <- liftIO $ HDBC.catchSql (HDBC.handleSqlError $ HDBC.quickQuery' conn \"SELECT lastval()\" []) (\\_ -> HDBC.commit conn >> (return $ [[HDBC.toSql (0 :: Int)]]) ) "
," return $ HDBC.fromSql $ head $ head i"
," else return Nothing"
," findAll = do"
," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
," res <- liftIO $ HDBC.handleSqlError $ HDBC.quickQuery' conn \"SELECT " ++ cols cs ++ " FROM " ++ t ++ "\" []"
," return $ map (\\r -> " ++ generateConstructor cs typeName ++ ") res"
," findAllWhere ss sp = do"
," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
," res <- liftIO $ HDBC.handleSqlError $ HDBC.quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t++ " WHERE (\" ++ ss ++ \") \") sp"
," return $ map (\\r -> " ++ generateConstructor cs typeName ++ ") res"
," findAllOrderBy op = do"
," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
," res <- liftIO $ HDBC.handleSqlError $ HDBC.quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t++ " ORDER BY ?\") [HDBC.toSql op]"
," return $ map (\\r -> " ++ generateConstructor cs typeName ++ ") res"
," findAllWhereOrderBy ss sp op = do"
," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
," res <- liftIO $ HDBC.handleSqlError $ HDBC.quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t++ " WHERE (\" ++ ss ++ \") ORDER BY ? \") (sp ++ [HDBC.toSql op])"
," return $ map (\\r -> " ++ generateConstructor cs typeName ++ ") res"
," findOneWhere ss sp = do"
," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
," res <- liftIO $ HDBC.handleSqlError $ HDBC.quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t++ " WHERE (\" ++ ss ++ \") LIMIT 1\") sp"
," return $ (\\r -> " ++ generateConstructor cs typeName ++ ") (head res)"
," findOneOrderBy op = do"
," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
," res <- liftIO $ HDBC.handleSqlError $ HDBC.quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t++ " ORDER BY ? LIMIT 1\") [HDBC.toSql op]"
," return $ (\\r -> " ++ generateConstructor cs typeName ++ ") (head res)"
," findOneWhereOrderBy ss sp op = do"
," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
," res <- liftIO $ HDBC.handleSqlError $ HDBC.quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t++ " WHERE (\" ++ ss ++ \") ORDER BY ? LIMIT 1\") (sp ++ [HDBC.toSql op])"
," return $ (\\r -> " ++ generateConstructor cs typeName ++ ") (head res)"
]
generateHasFindByPrimaryKey :: TableName -> Columns -> TypeName -> PrimaryKey -> [String]
generateHasFindByPrimaryKey t cs typeName pk =
case (length pk) of
0 -> [""]
_ -> ["instance HasFindByPrimaryKey " ++ typeName ++ " " ++ " (" ++ unwords (intersperse "," (map (\c -> getHaskellTypeString $ colType $ (\(c',_,_) -> c') $ fromJust $ M.lookup c cs) pk)) ++ ") " ++ " where"
," find pk@(" ++ (concat $ intersperse ", " $ map (\i -> "pk"++(show i)) [1..(length pk)]) ++ ") = do"
," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
," res <- liftIO $ HDBC.handleSqlError $ HDBC.quickQuery' conn (\"SELECT " ++ cols cs ++ " FROM " ++ t ++ " WHERE (" ++ (generatePrimaryKeyWhere pk) ++ ")\") [" ++ (unwords $ intersperse "," $ map (\(c,i) -> "HDBC.toSql pk" ++ (show i)) (zip pk [1..])) ++ "]"
," case res of"
," [] -> throwDyn $ HDBC.SqlError"
," {HDBC.seState = \"\","
," HDBC.seNativeError = (-1),"
," HDBC.seErrorMsg = \"No record found when finding by Primary Key:" ++ t ++ " : \" ++ (show pk)"
," }"
," r:[] -> return $ " ++ (generateConstructor cs typeName)
," _ -> throwDyn $ HDBC.SqlError"
," {HDBC.seState = \"\","
," HDBC.seNativeError = (-1),"
," HDBC.seErrorMsg = \"Too many records found when finding by Primary Key:" ++ t ++ " : \" ++ (show pk)"
," }"
,""
," update m = do"
," conn <- getEnvironment >>= (return . fromJust . getDatabase )"
," res <- liftIO $ HDBC.handleSqlError $ HDBC.run conn \"UPDATE " ++ t ++ " SET (" ++ (unwords $ intersperse "," $ M.keys cs) ++ ") = (" ++ (intercalate "," $ (take (M.size cs) (repeat "?"))) ++ ") WHERE (" ++ (generatePrimaryKeyWhere pk) ++")\""
," [" ++ (unwords $ intersperse "," $ map (\c -> "HDBC.toSql $ " ++ partiallyCapitalizeName c ++ " m") (M.keys cs) ) ++ ", " ++ (unwords $ intersperse "," $ map (\c -> "HDBC.toSql $ " ++ partiallyCapitalizeName c ++ " m") pk ) ++ "]"
," liftIO $ HDBC.handleSqlError $ HDBC.commit conn"
," return ()"
]
generateHasChildren :: TableName -> Columns -> TypeName -> [String]
generateHasChildren t cs typeName = map (\(cn, cd) -> generateHasChildren_t t cn cd typeName) $ M.assocs cs
generateHasChildren_t :: TableName -> ColumnName -> ColumnDesc -> TypeName -> String
generateHasChildren_t t cn (_, fks, _) typeName = unlines $ map (\(fkt, fkc) -> generateHasChildren_t_k t cn fkt fkc typeName) fks
generateHasChildren_t_k :: TableName -> ColumnName -> TableName -> ColumnName -> TypeName -> String
generateHasChildren_t_k t cn fkt fkc typeName =
unlines $
["class " ++ capitalizeName t ++ "Has" ++ capitalizeName fkt ++ "ForeignKey parent where"
," findAllChild" ++ capitalizeName fkt ++ " :: (HasEnvironment m) => parent -> m [" ++ capitalizeName fkt ++ "Type." ++ capitalizeName fkt ++ "]"
,""
,"instance " ++ capitalizeName t ++ "Has" ++ capitalizeName fkt ++ "ForeignKey (" ++ capitalizeName t ++ ") where"
," findAllChild" ++ capitalizeName fkt ++ " p = " ++ capitalizeName fkt ++ "Functions.findAllWhere \"" ++ fkc ++ " = ?\" [HDBC.toSql $ " ++ partiallyCapitalizeName cn ++ " p]"
]
generateHasParents :: TableName -> Tables -> [String]
generateHasParents ctn ts =
map (\(tname, cname, ptname, pcname) -> generateHasParent_t tname cname ptname pcname) $
nub $ concat $
map parentFilter $ M.assocs ts
where parentFilter (tn, (cs', _)) = filter (\(_, _, tn', _) -> ctn == tn') $ concat $ map (\(cn, (_, fks, _)) -> map (\(ptn, pcn) -> (tn, cn, ptn, pcn)) fks) $ M.assocs cs'
generateHasParent_t :: TableName -> ColumnName -> TableName -> ColumnName -> String
generateHasParent_t ptn pcn ctn ccn =
unlines $
["parent" ++ capitalizeName ptn ++ " :: (HasEnvironment m) => " ++ capitalizeName ctn ++ " -> m " ++ capitalizeName ptn ++ "Type." ++ capitalizeName ptn
,"parent" ++ capitalizeName ptn ++ " self = " ++ capitalizeName ptn ++ "Functions.findAllWhere \"" ++ pcn ++ " = ?\" [HDBC.toSql $ " ++ partiallyCapitalizeName ccn ++ " self]"
]
{-----------------------------------------------------------------------}
generatePrimaryKeyWhere pk =
unwords $
intersperse "++ \" AND \" ++ \"" $
map (\(c,i) -> c ++ " = ? ") (zip pk [1..])
generateConstructor cs typeName =
typeName ++ " " ++ (unwords $
map (\i -> "(HDBC.fromSql (r !! " ++ (show i) ++ "))") [0..((M.size cs) - 1)])
---------------------------------------------------------------------------
-- Utility functions --
---------------------------------------------------------------------------
cols :: Columns -> String
cols cs = unwords $ intersperse "," $ M.keys cs
columnToFieldLabel :: (String, (SqlColDesc, ForeignKeyReferences, HasDefault)) -> String
columnToFieldLabel cd@(name, (desc, _, _)) =
" " ++ partiallyCapitalizeName name ++ " :: " ++
maybeColumnLabel cd ++
getHaskellTypeString (colType desc)
maybeColumnLabel :: (String, (SqlColDesc, ForeignKeyReferences, HasDefault)) -> String
maybeColumnLabel (_, (_, _, True)) = "Maybe " -- Does the column have a default
maybeColumnLabel (_, (desc, _, _)) = if ((colNullable desc) == Just True) then "Maybe " else ""
getHaskellTypeString :: SqlTypeId -> String
getHaskellTypeString SqlCharT = "String"
getHaskellTypeString SqlVarCharT = "String"
getHaskellTypeString SqlLongVarCharT = "String"
getHaskellTypeString SqlWCharT = "String"
getHaskellTypeString SqlWVarCharT = "String"
getHaskellTypeString SqlWLongVarCharT = "String"
getHaskellTypeString SqlDecimalT = "Rational"
getHaskellTypeString SqlNumericT = "Rational"
getHaskellTypeString SqlSmallIntT ="Int32"
getHaskellTypeString SqlIntegerT = "Int32"
getHaskellTypeString SqlRealT = "Rational"
getHaskellTypeString SqlFloatT = "Float"
getHaskellTypeString SqlDoubleT = "Double"
getHaskellTypeString SqlTinyIntT = "Int32"
getHaskellTypeString SqlBigIntT = "Int64"
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"
--type SelectParameters = String
--class TableType a where
-- find :: (IConnection conn) => conn -> Int -> a
-- findBy :: (IConnection conn) => conn -> SelectParameters -> [a]
--
-- Converts "column_name" to "ColumnName" (for types)
--
capitalizeName [] = error "capitalizeName passed an empty string"
capitalizeName (colname':colname) =
concat
(map (\(s:ss) -> (Data.Char.toUpper s) : ss) $
words $ (Data.Char.toUpper colname') :
map (\c -> if (c=='_') then ' ' else c) colname)
--
-- Converts "column_name" to "columnName" (for functions)
--
partiallyCapitalizeName colname =
(\(s:ss) -> (Data.Char.toLower s) : ss) $
capitalizeName colname
Jump to Line
Something went wrong with that request. Please try again.