Changes Create generator to use hssqlppp internally.

app/Main.hs

@@ -7,7 +7,6 @@ import qualified Data.Text            as Text
 import Data.Aeson       (encode)
 import Data.Char        (toLower)
 import Data.List        (nub)
-import Data.Monoid      ((<>))
 import Control.Monad    (forM_)
 import System.Directory (createDirectoryIfMissing)
 import System.FilePath  ((</>), (<.>))
@@ -80,4 +79,4 @@ writeFiles outputDir env@Env{..} = do
                   , factTablePopulateSQLs IncRefresh  $ factTablePopulateSQL IncrementalPopulation
                   ]
 
-    sqlStr s = Text.unpack $ s <> ";\n"
+    sqlStr = Text.unpack

ringo.cabal

@@ -22,6 +22,7 @@ library
                        Ringo.Validator,
                        Ringo.Extractor.Internal,
                        Ringo.Generator.Internal,
+                       Ringo.Generator.Sql,
                        Ringo.Generator.Create,
                        Ringo.Generator.Populate.Dimension,
                        Ringo.Generator.Populate.Fact,

src/Ringo/Generator/Create.hs

@@ -5,43 +5,54 @@ module Ringo.Generator.Create (tableDefnSQL, factTableDefnSQL) where
 import Control.Applicative  ((<$>))
 #endif
 
-import Control.Monad.Reader (Reader, asks)
+import Control.Monad.Reader     (Reader, asks)
-import Data.Monoid          ((<>))
+import Database.HsSqlPpp.Syntax ( Statement(..), RowConstraint(..), AlterTableAction(..)
-import Data.Text            (Text)
+                                , AlterTableOperation(..), Constraint(..), Cascade(..)
+                                )
+import Data.Monoid              ((<>))
+import Data.Text                (Text)
 
 import Ringo.Extractor.Internal
-import Ringo.Generator.Internal
+import Ringo.Generator.Sql
 import Ringo.Types
 import Ringo.Utils
 
 tableDefnSQL :: Table -> Reader Env [Text]
-tableDefnSQL Table {..} = do
+tableDefnSQL table = map ppSQL <$> tableDefnSQL' table
+
+tableDefnSQL' :: Table -> Reader Env [Statement]
+tableDefnSQL' Table {..} = do
   Settings {..} <- asks envSettings
   let tabName = tableName <> settingTableNameSuffixTemplate
 
-      tableSQL = "CREATE TABLE " <> tabName <> " (\n"
+      tableSQL = CreateTable ea (name tabName) (map columnDefnSQL tableColumns) [] Nothing
-                   <> (joinColumnNames . map columnDefnSQL $ tableColumns)
-                   <> "\n)"
 
       columnDefnSQL Column {..} =
-        columnName <> " " <> columnType <> " " <> nullableDefnSQL columnNullable
+        att columnName columnType $ nullableDefnSQL columnNullable
 
-      nullableDefnSQL Null    = "NULL"
+      nullableDefnSQL Null    = NullConstraint ea ""
-      nullableDefnSQL NotNull = "NOT NULL"
+      nullableDefnSQL NotNull = NotNullConstraint ea ""
 
       constraintDefnSQL constraint =
-        let alterTableSQL = "ALTER TABLE ONLY " <> tabName <> " ADD "
+        let constr = case constraint of
-        in case constraint of
+              PrimaryKey cName -> PrimaryKeyConstraint ea "" [nmc cName]
-          PrimaryKey cName -> [ alterTableSQL <> "PRIMARY KEY (" <> cName <> ")" ]
+              ForeignKey oTableName cNamePairs ->
-          ForeignKey oTableName cNamePairs ->
+                ReferenceConstraint ea "" (map (nmc . fst) cNamePairs)
-            [ alterTableSQL <> "FOREIGN KEY (" <> joinColumnNames (map fst cNamePairs) <> ") REFERENCES "
+                  (name oTableName) (map (nmc . snd) cNamePairs) Restrict Restrict
-                <> oTableName <> " (" <> joinColumnNames (map snd cNamePairs) <> ")" ]
+              UniqueKey cNames -> UniqueConstraint ea "" $ map nmc cNames
-          UniqueKey cNames -> ["CREATE UNIQUE INDEX ON " <> tabName <> " (" <> joinColumnNames cNames <> ")"]
 
-  return $ tableSQL : concatMap constraintDefnSQL tableConstraints
+        in AlterTable ea (name tabName) $ AlterTableActions ea [AddConstraint ea constr]
+
+  return $ tableSQL : map constraintDefnSQL tableConstraints
 
 factTableDefnSQL :: Fact -> Table -> Reader Env [Text]
 factTableDefnSQL fact table = do
+  ds <- map ppSQL <$> tableDefnSQL' table
+  is <- map (\st -> ppSQL st <> ";\n") <$> factTableIndexSQL' fact table
+  return $ ds ++ is
+
+factTableIndexSQL' :: Fact -> Table -> Reader Env [Statement]
+factTableIndexSQL' fact table = do
   Settings {..} <- asks envSettings
   allDims       <- extractAllDimensionTables fact
 
@@ -53,8 +64,6 @@ factTableDefnSQL fact table = do
       dimCols   = [ factDimFKIdColumnName settingDimPrefix settingDimTableIdColumnName tableName
                     | (_, Table {..}) <- allDims ]
 
-      indexSQLs = [ "CREATE INDEX ON " <> tableName table <> settingTableNameSuffixTemplate
+  return [ CreateIndexTSQL ea (nmc "") (name $ tableName table <> settingTableNameSuffixTemplate) [nmc col]
-                      <> " USING btree (" <> col <> ")"
+           | col <- factCols ++ dimCols ]
-                    | col <- factCols ++ dimCols ]
 
-  (++ indexSQLs) <$> tableDefnSQL table

src/Ringo/Generator/Sql.hs

@@ -0,0 +1,27 @@
+module Ringo.Generator.Sql where
+
+import qualified Data.Text as Text
+import qualified Data.Text.Lazy as TL
+
+
+import Database.HsSqlPpp.Annotation
+import Database.HsSqlPpp.Dialect (postgresDialect)
+import Database.HsSqlPpp.Pretty
+import Database.HsSqlPpp.Syntax
+import Data.Text                 (Text)
+
+ea :: Annotation
+ea = emptyAnnotation
+
+name :: Text -> Name
+name n = Name ea [nmc n]
+
+nmc :: Text -> NameComponent
+nmc = Nmc . Text.unpack
+
+att :: Text -> Text -> RowConstraint -> AttributeDef
+att nam typ constr =
+  AttributeDef ea (nmc nam) (SimpleTypeName ea $ name typ) Nothing [constr]
+
+ppSQL :: Statement -> Text
+ppSQL st = TL.toStrict $ prettyStatements (PrettyFlags postgresDialect) [st]