Permalink
Browse files

Updating ORM; adding in dependencies

  • Loading branch information...
1 parent 6ac94d0 commit 8ca1019f98cd38c2599cf16062195cd8dd353e34 @alsonkemp committed Jan 4, 2009
Showing 677 changed files with 84,698 additions and 7 deletions.
No changes.
@@ -23,7 +23,7 @@ writeModels ts =
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)
+ writeFile (joinPath ["App/Models/Bases", fullName ++ "Base.hs"]) (generateModel t typeName pk ts cs)
) $ M.toList ts
---------------------------------------------------------------------------
@@ -33,9 +33,10 @@ writeModels ts =
generateModel :: TableName ->
TypeName ->
PrimaryKey ->
+ Tables ->
Columns ->
String
-generateModel t typeName pk cs =
+generateModel 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"
@@ -55,18 +56,46 @@ generateModel t typeName pk cs =
, "import Turbinado.Environment.Types"
, "import Turbinado.Environment.Database"
, ""
- , "data " ++ typeName ++ " = " ++ typeName ++ " {"
+ , "-- Model imports (if any)"
] ++
- [intercalate "," (map columnToFieldLabel (M.toList cs))] ++
+ nub (generateParentModelImports t ts ++ generateChildModelImports cs) ++
+ [""] ++
+ ["-- 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 ++ "\""
, ""
] ++
+ [""] ++
+ generateHasFindByPrimaryKey t cs typeName pk ++
+ [""] ++
generateIsModel t cs typeName ++
- generateHasFindByPrimaryKey t cs typeName pk
-
+ [""] ++
+ [""] ++
+ generateHasChildren t cs typeName ++
+ [""] ++
+ [""] ++
+ generateHasParents t ts
+
+generateChildModelImports cs =
+ map (\ctn -> "import qualified App.Models." ++ capitalizeName ctn ++ "Model as " ++ capitalizeName ctn ++ "Model") $
+ nub $
+ map fst $ concat $
+ map (\(_, fks, _) -> fks) $ M.elems cs
+
+generateParentModelImports t ts =
+ map (\ptn -> "import qualified App.Models." ++ capitalizeName ptn ++ "Model as " ++ capitalizeName ptn ++ "Model") $
+ 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"
@@ -196,7 +225,43 @@ generateHasFindByPrimaryKey t cs typeName pk =
," 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 ++ "Model." ++ capitalizeName fkt ++ "]"
+ ,""
+ ,"instance " ++ capitalizeName t ++ "Has" ++ capitalizeName fkt ++ "ForeignKey (" ++ capitalizeName t ++ ") where"
+ ," findAllChild" ++ capitalizeName fkt ++ " p = " ++ capitalizeName fkt ++ "Model.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 ++ "Model." ++ capitalizeName ptn
+ ,"parent" ++ capitalizeName ptn ++ " self = " ++ capitalizeName ptn ++ "Model.findAllWhere \"" ++ pcn ++ " = ?\" [HDBC.toSql $ " ++ partiallyCapitalizeName ccn ++ " self]"
+ ]
+
+
{-----------------------------------------------------------------------}
+
+
generatePrimaryKeyWhere pk =
unwords $
intersperse "++ \" AND \" ++ \"" $
@@ -222,7 +287,6 @@ columnToFieldLabel cd@(name, (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 ""
-maybeColumnLabel _ = ""
getHaskellTypeString :: SqlTypeId -> String
getHaskellTypeString SqlCharT = "String"
@@ -257,6 +321,7 @@ getHaskellTypeString _ = error "Don't know how to translate this SqlTypeId to
--
-- 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) $
View
@@ -0,0 +1,4 @@
+Building turbinado requires the following libraries. It can
+be difficult to track down and install each library, so
+they are gathered here to ease installation. This is a
+temporary solution.
Oops, something went wrong.

0 comments on commit 8ca1019

Please sign in to comment.