diff --git a/DSH.cabal b/DSH.cabal --- a/DSH.cabal +++ b/DSH.cabal @@ -1,5 +1,5 @@ Name: DSH -Version: 0.7.2 +Version: 0.7.3 Synopsis: Database Supported Haskell Description: This is a Haskell library for database-supported program execution. Using @@ -43,6 +43,7 @@ Build-type: Simple Extra-source-files: examples/Example01.hs + examples/Example02.hs examples/Makefile tests/Main.hs tests/Makefile diff --git a/examples/Example01.hs b/examples/Example01.hs --- a/examples/Example01.hs +++ b/examples/Example01.hs @@ -2,7 +2,7 @@ module Main where -import qualified Prelude as P +import qualified Prelude as P import Database.DSH import Database.DSH.Compiler @@ -22,7 +22,7 @@ | (view -> (i1,i2)) <- query1 , i1 == i2 ] - + getConn :: IO Connection getConn = connectPostgreSQL "user = 'giorgidz' password = '' host = 'localhost' dbname = 'giorgidz'" diff --git a/examples/Example02.hs b/examples/Example02.hs new file mode 100644 --- /dev/null +++ b/examples/Example02.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TemplateHaskell, FlexibleInstances, MultiParamTypeClasses #-} + +module Main where + +import qualified Prelude as P +import Database.DSH + +import Database.HDBC.PostgreSQL + +$(generateDatabaseRecordInstances (connectPostgreSQL "user = 'giorgidz' password = '' host = 'localhost' dbname = 'giorgidz'")) +$(generateTableDeclarations (connectPostgreSQL "user = 'giorgidz' password = '' host = 'localhost' dbname = 'giorgidz'")) + +main :: IO () +main = P.return () diff --git a/examples/Makefile b/examples/Makefile --- a/examples/Makefile +++ b/examples/Makefile @@ -1,6 +1,7 @@ all: clean ghc -Wall -O3 --make Example01.hs + ghc -Wall -O3 --make Example02.hs rm -rf *.hi *.o clean: - rm -rf *.hi *.o Example01 + rm -rf *.hi *.o Example01 Example02 diff --git a/src/Database/DSH.hs b/src/Database/DSH.hs --- a/src/Database/DSH.hs +++ b/src/Database/DSH.hs @@ -26,8 +26,10 @@ , View, view, fromView, tuple, record -- * Template Haskell: Creating Table Representations - , generateRecords - , generateInstances + , generateDatabaseRecordInstances + , generateTableRecordInstances + , generateRecordInstances + , generateTableDeclarations , module Database.DSH.CSV @@ -39,7 +41,7 @@ where import Database.DSH.Data (Q, QA, TA, table, tableDB, tableCSV, tableWithKeys, BasicType, View, view, fromView, tuple, record) -import Database.DSH.TH (generateRecords, generateInstances) +import Database.DSH.TH (generateDatabaseRecordInstances, generateTableRecordInstances, generateRecordInstances, generateTableDeclarations) import Database.DSH.CSV (csvExport) import Database.DSH.Combinators diff --git a/src/Database/DSH/Combinators.hs b/src/Database/DSH/Combinators.hs --- a/src/Database/DSH/Combinators.hs +++ b/src/Database/DSH/Combinators.hs @@ -352,9 +352,9 @@ -- 'QA', 'TA' and 'View' instances for tuples up to the defined length. -$(generateDeriveTupleQARange 3 8) -$(generateDeriveTupleTARange 3 8) -$(generateDeriveTupleViewRange 3 8) +$(generateDeriveTupleQARange 3 16) +$(generateDeriveTupleTARange 3 16) +$(generateDeriveTupleViewRange 3 16) -- * Missing Combinators diff --git a/src/Database/DSH/TH.hs b/src/Database/DSH/TH.hs --- a/src/Database/DSH/TH.hs +++ b/src/Database/DSH/TH.hs @@ -16,8 +16,10 @@ , deriveTAForRecord , deriveTAForRecord' - , generateRecords - , generateInstances + , generateDatabaseRecordInstances + , generateTableRecordInstances + , generateRecordInstances + , generateTableDeclarations ) where @@ -27,6 +29,7 @@ import Control.Applicative import Control.Monad import Data.Convertible +import Data.Char import Data.List import Database.HDBC import Data.Text (Text) @@ -443,25 +446,80 @@ -- * Exported enduser functions -- +-- | Generate table declarations for all tables in the database. This function +-- should be used in conjunction with generateDatabaseRecordInstances. For +-- example, this function generates the following code for the table 'users': +-- +-- > users :: Q [User] +-- > users = table "users" +-- +generateTableDeclarations :: (IConnection conn) + => (IO conn) -- ^ Database connection + -> TH.Q [Dec] +generateTableDeclarations conn = do + tables <- runIO $ do c <- conn + r <- getTables c + disconnect c + return r + declss <- mapM generateTableDeclaration tables + return (concat declss) + +generateTableDeclaration :: String -> TH.Q [Dec] +generateTableDeclaration s = return + [ TH.SigD (mkName s) (TH.AppT (TH.ConT ''Q) (TH.AppT TH.ListT (TH.ConT (mkName (dataTypeName s))))) + , TH.FunD (mkName s) [TH.Clause [] (TH.NormalB (TH.AppE (TH.VarE (mkName "table")) (TH.LitE (TH.StringL s)))) []] + ] + +-- | Create corresponding Haskell record data types and generate QA and View +-- instances for all tables in the database (except for system tables). +-- +-- Example usage: +-- +-- > $(generateDatabaseRecordInstances myConnection) +-- +-- Note that the database information is queried at compile time, not at run time! +generateDatabaseRecordInstances :: (IConnection conn) + => (IO conn) -- ^ Database connection + -> TH.Q [Dec] +generateDatabaseRecordInstances conn = do + tables <- runIO $ do c <- conn + r <- getTables c + disconnect c + return r + decss <- mapM (\t -> generateTableRecordInstances conn t (dataTypeName t) [''Show,''Eq]) tables + return (concat decss) + +dataTypeName :: String -> String +dataTypeName [] = [] +dataTypeName [c] = map toUpper (cleanUnderscores [c]) +dataTypeName (c : cs) = toUpper c : cleanUnderscores (init cs) + +cleanUnderscores :: String -> String +cleanUnderscores [] = [] +cleanUnderscores ['_'] = [] +cleanUnderscores ('_' : c : cs) = toUpper c : cleanUnderscores cs +cleanUnderscores (c : cs) = c : cleanUnderscores cs + -- | Lookup a database table, create corresponding Haskell record data types -- and generate QA and View instances -- -- Example usage: -- --- > $(generateRecords myConnection "users" "User" [''Show,''Eq]) +-- > $(generateTableRecordInstances myConnection "users" "User" [''Show,''Eq]) -- --- Note that the da is created at compile time, not at run time! -generateRecords :: (IConnection conn) - => (IO conn) -- ^ Database connection - -> String -- ^ Table name - -> String -- ^ Data type name for each row of the table - -> [Name] -- ^ Default deriving instances - -> TH.Q [Dec] -generateRecords conn t dname dnames = do - tdesc <- runIO $ do - c <- conn - describeTable c t - generateInstances (createDataType (sortWith fst tdesc)) +-- Note that the table information is queried at compile time, not at run time! +generateTableRecordInstances :: (IConnection conn) + => (IO conn) -- ^ Database connection + -> String -- ^ Table name + -> String -- ^ Data type name for each row of the table + -> [Name] -- ^ Default deriving instances + -> TH.Q [Dec] +generateTableRecordInstances conn t dname dnames = do + tdesc <- runIO $ do c <- conn + r <- describeTable c t + disconnect c + return r + generateRecordInstances (createDataType (sortWith fst tdesc)) where createDataType :: [(String, SqlColDesc)] -> TH.Q [Dec] @@ -495,7 +553,7 @@ -- -- Example usage: -- --- > $(generateInstances [d| +-- > $(generateRecordInstances [d| -- > -- > data User = User -- > { userId :: Int @@ -517,11 +575,11 @@ -- -- > userIdQ :: Q User -> Q Int -- > userNameQ :: Q User -> Q String -generateInstances :: TH.Q [Dec] -> TH.Q [Dec] -generateInstances q = do +generateRecordInstances :: TH.Q [Dec] -> TH.Q [Dec] +generateRecordInstances q = do d <- q qa <- deriveQAForRecord' q v <- deriveViewForRecord' q ta <- deriveTAForRecord' q rs <- recordQSelectors' q - return $ d ++ qa ++ v ++ ta ++ rs + return (d ++ qa ++ v ++ ta ++ rs)