Adds dimension table insert SQL generation.

Moves some private functions from Extractor to Extractor.Internal for reuse.

src/Ringo/Extractor.hs

@@ -5,30 +5,15 @@ module Ringo.Extractor
        , extractFactTable
        ) where
 
-import qualified Data.Map  as Map
 import qualified Data.Text as Text
 
 import Control.Monad.Reader (Reader, asks)
 import Data.Maybe           (mapMaybe, fromMaybe, fromJust)
 import Data.Monoid          ((<>))
-import Data.List            (nub, find)
 
+import Ringo.Extractor.Internal
 import Ringo.Types
 
-findTable :: TableName -> [Table] -> Maybe Table
-findTable tName = find ((== tName) . tableName)
-
-findFact :: TableName -> [Fact] -> Maybe Fact
-findFact fName = find ((== fName) . factName)
-
-findColumn :: ColumnName -> [Column] -> Maybe Column
-findColumn cName = find ((== cName) . columnName)
-
-checkTableForCol :: Table -> ColumnName -> [ValidationError]
-checkTableForCol tab colName =
-  [ MissingColumn (tableName tab) colName |
-      not . any ((colName ==) . columnName) . tableColumns $ tab ]
-
 validateTable :: Table -> Reader ExtractorEnv [ValidationError]
 validateTable table = do
   tables <- asks eeTables
@@ -72,54 +57,9 @@ withFactValidation fact func = do
     then return $ Left errors
     else fmap Right . func . fromJust . findTable (factTableName fact) $ tables
 
-extractDimensions' :: Fact -> Table -> Reader ExtractorEnv [Table]
-extractDimensions' fact Table {..} = do
-  tables <- asks eeTables
-  prefix <- settingDimPrefix <$> asks eeSettings
-  return $ dimsFromIds tables ++ dimsFromVals prefix
-  where
-    dimsFromIds tables =
-      flip mapMaybe (factColumns fact) $ \fcol -> case fcol of
-        DimId d _ -> findTable d tables
-        _         -> Nothing
-
-    dimsFromVals prefix =
-      map (\(dim, cols) -> Table { tableName        = prefix <> dim
-                                 , tableColumns     = Column "id" "serial" NotNull : cols
-                                 , tableConstraints = [ PrimaryKey "id"
-                                                      , UniqueKey (map columnName cols)
-                                                      ]
-                                 })
-      . Map.toList
-      . Map.mapWithKey (\dim -> map (cleanColumn dim) . nub)
-      . Map.fromListWith (flip (++))
-      . mapMaybe (\fcol -> do
-                    DimVal d col <- fcol
-                    column       <- findColumn col tableColumns
-                    return (d, [ column ]))
-      . map Just
-      . factColumns
-      $ fact
-
-    cleanColumn dim col@Column {..} =
-      col { columnName = fromMaybe columnName . Text.stripPrefix (dim <> "_") $ columnName }
-
 extractDimensions :: Fact -> Reader ExtractorEnv (Either [ValidationError] [Table])
 extractDimensions fact = withFactValidation fact $ extractDimensions' fact
 
-extractAllDimensions' :: Fact -> Table -> Reader ExtractorEnv [Table]
-extractAllDimensions' fact table = do
-  myDims     <- extractDimensions' fact table
-  parentDims <- concat <$> mapM extract (factParentNames fact)
-  return . nub $ myDims ++ parentDims
-  where
-    extract fName = do
-      tables <- asks eeTables
-      facts  <- asks eeFacts
-      let pFact      = fromJust . findFact fName $ facts
-          pFactTable = fromJust . findTable (factTableName pFact) $ tables
-      extractAllDimensions' pFact pFactTable
-
 extractFactTable ::  Fact -> Reader ExtractorEnv (Either [ValidationError] Table)
 extractFactTable fact  =
   withFactValidation fact $ \table -> do

src/Ringo/Extractor/Internal.hs

@@ -0,0 +1,73 @@
+module Ringo.Extractor.Internal where
+
+import qualified Data.Map  as Map
+import qualified Data.Text as Text
+
+import Control.Monad.Reader (Reader, asks)
+import Data.Maybe           (mapMaybe, fromMaybe, fromJust)
+import Data.Monoid          ((<>))
+import Data.List            (nub, find)
+
+import Ringo.Types
+
+findTable :: TableName -> [Table] -> Maybe Table
+findTable tName = find ((== tName) . tableName)
+
+findFact :: TableName -> [Fact] -> Maybe Fact
+findFact fName = find ((== fName) . factName)
+
+findColumn :: ColumnName -> [Column] -> Maybe Column
+findColumn cName = find ((== cName) . columnName)
+
+checkTableForCol :: Table -> ColumnName -> [ValidationError]
+checkTableForCol tab colName =
+  [ MissingColumn (tableName tab) colName |
+      not . any ((colName ==) . columnName) . tableColumns $ tab ]
+
+extractDimensions' :: Fact -> Table -> Reader ExtractorEnv [Table]
+extractDimensions' fact Table {..} = do
+  tables <- asks eeTables
+  prefix <- settingDimPrefix <$> asks eeSettings
+  return $ dimsFromIds tables ++ dimsFromVals prefix
+  where
+    dimsFromIds tables =
+      flip mapMaybe (factColumns fact) $ \fcol -> case fcol of
+        DimId d _ -> findTable d tables
+        _         -> Nothing
+
+    dimsFromVals prefix =
+      map (\(dim, cols) -> Table { tableName        = prefix <> dim
+                                 , tableColumns     = Column "id" "serial" NotNull : cols
+                                 , tableConstraints = [ PrimaryKey "id"
+                                                      , UniqueKey (map columnName cols)
+                                                      ]
+                                 })
+      . Map.toList
+      . Map.mapWithKey (\dim ->
+                          map (\col@Column {..} -> col { columnName = dimColumnName dim columnName })
+                          . nub)
+      . Map.fromListWith (flip (++))
+      . mapMaybe (\fcol -> do
+                    DimVal d col <- fcol
+                    column       <- findColumn col tableColumns
+                    return (d, [ column ]))
+      . map Just
+      . factColumns
+      $ fact
+
+dimColumnName :: Text.Text -> ColumnName -> ColumnName
+dimColumnName dimName columnName =
+  fromMaybe columnName . Text.stripPrefix (dimName <> "_") $ columnName
+
+extractAllDimensions' :: Fact -> Table -> Reader ExtractorEnv [Table]
+extractAllDimensions' fact table = do
+  myDims     <- extractDimensions' fact table
+  parentDims <- concat <$> mapM extract (factParentNames fact)
+  return . nub $ myDims ++ parentDims
+  where
+    extract fName = do
+      tables <- asks eeTables
+      facts  <- asks eeFacts
+      let pFact      = fromJust . findFact fName $ facts
+          pFactTable = fromJust . findTable (factTableName pFact) $ tables
+      extractAllDimensions' pFact pFactTable

src/Ringo/Generator.hs

@@ -1,13 +1,16 @@
 module Ringo.Generator
        ( tableDefnSQL
+       , dimensionTableInsertSQL
        ) where
 
 import qualified Data.Text as Text
 
-import Data.List (intersperse)
+import Data.List   (intersperse)
+import Data.Maybe  (mapMaybe)
 import Data.Monoid ((<>))
-import Data.Text (Text)
+import Data.Text   (Text)
 
+import Ringo.Extractor.Internal
 import Ringo.Types
 
 nullableDefnSQL :: Nullable -> Text
@@ -18,17 +21,18 @@ columnDefnSQL :: Column -> Text
 columnDefnSQL Column {..} =
   columnName <> " " <> columnType <> " " <> nullableDefnSQL columnNullable
 
+colNamesString :: [ColumnName] -> Text
+colNamesString cNames = Text.concat (intersperse ", " cNames)
+
 constraintDefnSQL :: TableName -> TableConstraint -> Text
 constraintDefnSQL tableName constraint =
   "ALTER TABLE ONLY " <> tableName <> " ADD "
     <> case constraint of
          PrimaryKey cName -> "PRIMARY KEY (" <> cName <> ")"
-         UniqueKey cNames -> "UNIQUE (" <> colNamesStr cNames <> ")"
+         UniqueKey cNames -> "UNIQUE (" <> colNamesString cNames <> ")"
          ForeignKey oTableName cNamePairs ->
-           "FOREIGN KEY (" <> colNamesStr (map fst cNamePairs) <> ") REFERENCES "
+           "FOREIGN KEY (" <> colNamesString (map fst cNamePairs) <> ") REFERENCES "
-             <> oTableName <> " (" <> colNamesStr (map snd cNamePairs) <> ")"
+             <> oTableName <> " (" <> colNamesString (map snd cNamePairs) <> ")"
-  where
-    colNamesStr cNames = Text.concat (intersperse ", " cNames)
 
 tableDefnSQL :: Table -> [Text]
 tableDefnSQL Table {..} =
@@ -37,3 +41,14 @@ tableDefnSQL Table {..} =
     tableSQL = "CREATE TABLE " <> tableName <> " (\n"
                  <> (Text.concat . intersperse ",\n" . map columnDefnSQL $ tableColumns)
                  <> "\n)"
+
+dimensionTableInsertSQL :: Text -> Fact -> TableName -> Text
+dimensionTableInsertSQL dimPrefix fact dimTableName = let
+  colMapping = flip mapMaybe (factColumns fact) $ \fCol -> case fCol of
+    DimVal dName cName | dimPrefix <> dName == dimTableName -> Just (dimColumnName dName cName, cName)
+    _ -> Nothing
+  in "INSERT INTO " <> dimTableName <> " (\n"
+        <> colNamesString (map fst colMapping)
+        <> "\n) SELECT DISTINCT \n"
+        <> colNamesString (map snd colMapping)
+        <> "\nFROM " <> factTableName fact