diff --git a/.gitignore b/.gitignore index 1f8e248..e4e4042 100644 --- a/.gitignore +++ b/.gitignore @@ -2,6 +2,7 @@ Tables.hs tables.yaml dist cabal-dev +out .DS_STORE *.o *.hi diff --git a/app/Main.hs b/app/Main.hs index 46cb59f..f2b050a 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -2,13 +2,20 @@ module Main where import qualified Data.Text as Text -import Data.List (nub) -import System.Exit (exitFailure, exitSuccess) +import Data.Char (toLower) +import Data.List (nub) +import Data.Monoid ((<>)) +import Control.Monad (forM_) +import System.Directory (createDirectoryIfMissing) +import System.FilePath ((), (<.>)) +import System.Exit (exitFailure, exitSuccess) import Ringo import Ringo.ArgParser import Ringo.InputParser +data SQLType = Create | Populate | Update deriving (Eq, Show) + main :: IO () main = do ProgArgs {..} <- parseArgs @@ -19,21 +26,41 @@ main = do let env = Env tables facts progSettings let errors = nub $ concatMap (validateTable env) tables ++ concatMap (validateFact env) facts if not $ null errors - then mapM print errors >> exitFailure - else do - let dimTables = map (\fact -> (fact, extractDimensionTables env fact)) facts - factTables = map (\fact -> (fact, extractFactTable env fact)) facts + then mapM_ print errors >> exitFailure + else writeSQLFiles progOutputDir env >> exitSuccess - dimTableDefnSQLs = [ tabDefnSQL table | (fact, tabs) <- dimTables - , table <- tabs - , table `notElem` tables ] - factTableDefnSQLs = [ tabDefnSQL table | (fact, table) <- factTables ] - - mapM_ putStrLn dimTableDefnSQLs - mapM_ putStrLn factTableDefnSQLs - - exitSuccess +writeSQLFiles :: FilePath -> Env -> IO () +writeSQLFiles outputDir env@Env{..} = forM_ sqls $ \(sqlType, table, sql) -> do + let dirName = outputDir map toLower (show sqlType) + fileName = dirName Text.unpack table <.> "sql" + createDirectoryIfMissing True dirName + writeFile fileName sql where - toSQL = Text.unpack . flip Text.snoc ';' - tabDefnSQL = unlines . map toSQL . tableDefnSQL + dimTables = map (\fact -> (fact, extractDimensionTables env fact)) envFacts + factTables = map (\fact -> (fact, extractFactTable env fact)) envFacts + dimTableDefnSQLs = [ (Create, tableName table, tabDefnSQL table) + | (_, tabs) <- dimTables + , table <- tabs + , table `notElem` envTables ] + factTableDefnSQLs = [ (Create, tableName table, tabDefnSQL table) + | (_, table) <- factTables ] + + dimTableInsertSQLs = [ (Populate + , tableName table + , sqlStr $ dimensionTableInsertSQL env fact (tableName table)) + | (fact, tabs) <- dimTables + , table <- tabs + , table `notElem` envTables ] + + fctTableInsertSQLs = [ (Populate, tableName table, sqlStr $ factTableInsertSQL env fact) + | (fact, table) <- factTables ] + + sqls = concat [ dimTableDefnSQLs + , factTableDefnSQLs + , dimTableInsertSQLs + , fctTableInsertSQLs + ] + + sqlStr s = Text.unpack $ s <> ";\n" + tabDefnSQL = unlines . map sqlStr . tableDefnSQL diff --git a/app/Ringo/InputParser.hs b/app/Ringo/InputParser.hs index 9d99923..d119af4 100644 --- a/app/Ringo/InputParser.hs +++ b/app/Ringo/InputParser.hs @@ -3,9 +3,10 @@ module Ringo.InputParser (parseInput) where import qualified Data.Text as Text import qualified Data.Vector as V -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe) +import Data.Vector ((!), (!?)) import Data.Yaml hiding (Null) -import Data.Vector ((!), (!?)) + import Ringo.Types instance FromJSON Nullable where @@ -17,7 +18,7 @@ instance FromJSON Nullable where instance FromJSON Column where parseJSON (Array a) = if V.length a < 2 - then fail $ "Column needs at least two elements: name and type" + then fail "Column needs at least two elements: name and type" else do cName <- parseJSON $ a ! 0 cType <- parseJSON $ a ! 1 diff --git a/ringo.cabal b/ringo.cabal index 0d0c1dc..be8289f 100644 --- a/ringo.cabal +++ b/ringo.cabal @@ -1,6 +1,6 @@ name: ringo version: 0.1.0.0 -synopsis: Tool to transform OLTP database schemas to OLAP database star schemas automatically +synopsis: Tool to transform OLTP schemas to OLAP star schemas automatically description: Please see README.md homepage: http://github.com/quintype/ringo#readme license: MIT @@ -22,15 +22,13 @@ library Ringo.Types other-modules: Ringo.Extractor.Internal, Ringo.Utils - build-depends: base >=4.7 && <5, text >=1.2 && <1.3, containers >=0.5 && <0.6, mtl >=2.2 && <2.3 - ghc-options: -Wall -fno-warn-unused-do-bind -funbox-strict-fields -fno-warn-orphans - default-extensions: OverloadedStrings, RecordWildCards, ScopedTypeVariables, - BangPatterns, TupleSections, NamedFieldPuns, GeneralizedNewtypeDeriving, - DeriveDataTypeable + ghc-options: -Wall -fno-warn-unused-do-bind -funbox-strict-fields -fno-warn-orphans -O2 + default-extensions: OverloadedStrings, RecordWildCards, ScopedTypeVariables, BangPatterns, + TupleSections default-language: Haskell2010 executable ringo @@ -38,16 +36,17 @@ executable ringo other-modules: Ringo.ArgParser, Ringo.InputParser main-is: Main.hs - build-depends: base >=4.7 && <5, - text >=1.2 && <1.3, + build-depends: base >=4.7 && <5, + text >=1.2 && <1.3, optparse-applicative >=0.11 && <0.12, - yaml >=0.8 && <0.9, + yaml >=0.8 && <0.9, vector >=0.10 && <0.11, + directory >=1.2 && <1.3, + filepath >=1.4 && <1.5, ringo ghc-options: -Wall -fno-warn-unused-do-bind -funbox-strict-fields -fno-warn-orphans -O2 - default-extensions: OverloadedStrings, RecordWildCards, ScopedTypeVariables, - BangPatterns, TupleSections, NamedFieldPuns, GeneralizedNewtypeDeriving, - DeriveDataTypeable + default-extensions: OverloadedStrings, RecordWildCards, ScopedTypeVariables, BangPatterns, + TupleSections default-language: Haskell2010 test-suite ringo-test