Changes Create generator to use hssqlppp internally.

pull/1/head
Abhinav Sarkar 2016-01-01 17:15:22 +05:30
parent e2ecfc0b9b
commit 28ff8a99fb
4 changed files with 61 additions and 25 deletions

View File

@ -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

View File

@ -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,

View File

@ -6,42 +6,53 @@ import Control.Applicative ((<$>))
#endif
import Control.Monad.Reader (Reader, asks)
import Database.HsSqlPpp.Syntax ( Statement(..), RowConstraint(..), AlterTableAction(..)
, 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"
<> (joinColumnNames . map columnDefnSQL $ tableColumns)
<> "\n)"
tableSQL = CreateTable ea (name tabName) (map columnDefnSQL tableColumns) [] Nothing
columnDefnSQL Column {..} =
columnName <> " " <> columnType <> " " <> nullableDefnSQL columnNullable
att columnName columnType $ nullableDefnSQL columnNullable
nullableDefnSQL Null = "NULL"
nullableDefnSQL NotNull = "NOT NULL"
nullableDefnSQL Null = NullConstraint ea ""
nullableDefnSQL NotNull = NotNullConstraint ea ""
constraintDefnSQL constraint =
let alterTableSQL = "ALTER TABLE ONLY " <> tabName <> " ADD "
in case constraint of
PrimaryKey cName -> [ alterTableSQL <> "PRIMARY KEY (" <> cName <> ")" ]
let constr = case constraint of
PrimaryKey cName -> PrimaryKeyConstraint ea "" [nmc cName]
ForeignKey oTableName cNamePairs ->
[ alterTableSQL <> "FOREIGN KEY (" <> joinColumnNames (map fst cNamePairs) <> ") REFERENCES "
<> oTableName <> " (" <> joinColumnNames (map snd cNamePairs) <> ")" ]
UniqueKey cNames -> ["CREATE UNIQUE INDEX ON " <> tabName <> " (" <> joinColumnNames cNames <> ")"]
ReferenceConstraint ea "" (map (nmc . fst) cNamePairs)
(name oTableName) (map (nmc . snd) cNamePairs) Restrict Restrict
UniqueKey cNames -> UniqueConstraint ea "" $ map nmc 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
<> " USING btree (" <> col <> ")"
return [ CreateIndexTSQL ea (nmc "") (name $ tableName table <> settingTableNameSuffixTemplate) [nmc col]
| col <- factCols ++ dimCols ]
(++ indexSQLs) <$> tableDefnSQL table

View File

@ -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]