From 0f4970d587840004ba50261d199df4db35197ab3 Mon Sep 17 00:00:00 2001 From: Abhinav Sarkar Date: Wed, 3 Feb 2016 16:00:39 +0530 Subject: [PATCH] Changes FactColumn to use GADTs for better type safety. --- app/Ringo/InputParser.hs | 24 ++-- ringo.cabal | 6 +- src/Ringo.hs | 29 +++-- src/Ringo/Extractor.hs | 53 +++++---- src/Ringo/Extractor/Internal.hs | 15 ++- src/Ringo/Generator/Create.hs | 20 ++-- src/Ringo/Generator/Internal.hs | 7 +- src/Ringo/Generator/Populate/Dimension.hs | 4 +- src/Ringo/Generator/Populate/Fact.hs | 139 ++++++++++++---------- src/Ringo/Types.hs | 85 ++++++++----- src/Ringo/Utils.hs | 1 - src/Ringo/Validator.hs | 26 ++-- stack.yaml | 2 +- 13 files changed, 235 insertions(+), 176 deletions(-) diff --git a/app/Ringo/InputParser.hs b/app/Ringo/InputParser.hs index 24bfe29..c555006 100644 --- a/app/Ringo/InputParser.hs +++ b/app/Ringo/InputParser.hs @@ -53,17 +53,17 @@ instance FromJSON FactColumn where parseJSON (Object o) = do cType <- o .: "type" case cType of - "dimtime" -> DimTime <$> o .: "column" - "nodimid" -> NoDimId <$> o .: "column" - "tenantid" -> TenantId <$> o .: "column" - "dimid" -> DimId <$> o .: "table" <*> o .: "column" - "dimval" -> DimVal <$> o .: "table" <*> o .: "column" - "factcount" -> FactCount <$> o .:? "sourcecolumn" <*> o .: "column" - "factsum" -> FactSum <$> o .: "sourcecolumn" <*> o .: "column" - "factaverage" -> FactAverage <$> o .: "sourcecolumn" <*> o .: "column" - "factcountdistinct" -> FactCountDistinct <$> o .:? "sourcecolumn" <*> o .: "column" - "factmax" -> FactMax <$> o .: "sourcecolumn" <*> o .: "column" - "factmin" -> FactMin <$> o .: "sourcecolumn" <*> o .: "column" + "dimtime" -> FactColumn <$> o .: "column" <*> pure DimTime + "nodimid" -> FactColumn <$> o .: "column" <*> pure NoDimId + "tenantid" -> FactColumn <$> o .: "column" <*> pure TenantId + "dimid" -> FactColumn <$> o .: "column" <*> (DimId <$> o .: "table") + "dimval" -> FactColumn <$> o .: "column" <*> (DimVal <$> o .: "table") + "factcount" -> FactColumn <$> o .: "column" <*> (FactCount <$> o .:? "sourcecolumn") + "factcountdistinct" -> FactColumn <$> o .: "column" <*> (FactCountDistinct <$> o .:? "sourcecolumn") + "factsum" -> FactColumn <$> o .: "column" <*> (FactSum <$> o .: "sourcecolumn") + "factaverage" -> FactColumn <$> o .: "column" <*> (FactAverage <$> o .: "sourcecolumn") + "factmax" -> FactColumn <$> o .: "column" <*> (FactMax <$> o .: "sourcecolumn") + "factmin" -> FactColumn <$> o .: "column" <*> (FactMin <$> o .: "sourcecolumn") _ -> fail $ "Invalid fact column type: " ++ cType parseJSON o = fail $ "Cannot parse fact column: " ++ show o @@ -75,7 +75,7 @@ instance FromJSON Fact where <*> o .: "columns" parseJSON o = fail $ "Cannot parse fact: " ++ show o -data Input = Input [Table] [Fact] TypeDefaults deriving (Eq, Show) +data Input = Input [Table] [Fact] TypeDefaults deriving (Show) instance FromJSON Input where parseJSON (Object o) = Input <$> o .: "tables" <*> o .: "facts" <*> o .: "defaults" diff --git a/ringo.cabal b/ringo.cabal index e205901..f98d330 100644 --- a/ringo.cabal +++ b/ringo.cabal @@ -33,7 +33,8 @@ library mtl >=2.1 && <2.3, raw-strings-qq >=1.0 && <1.2, hssqlppp ==0.5.23 - ghc-options: -Wall -fno-warn-unused-do-bind -funbox-strict-fields -fno-warn-orphans -O2 + ghc-options: -Wall -Werror -fwarn-incomplete-uni-patterns -fno-warn-unused-do-bind + -fno-warn-orphans -funbox-strict-fields -O2 default-language: Haskell2010 executable ringo @@ -52,7 +53,8 @@ executable ringo filepath >=1.3 && <1.5, aeson >=0.8 && <0.11, ringo - ghc-options: -Wall -fno-warn-unused-do-bind -funbox-strict-fields -fno-warn-orphans -O2 + ghc-options: -Wall -Werror -fwarn-incomplete-uni-patterns -fno-warn-unused-do-bind + -fno-warn-orphans -funbox-strict-fields -O2 default-language: Haskell2010 test-suite ringo-test diff --git a/src/Ringo.hs b/src/Ringo.hs index efa4003..6e30c7b 100644 --- a/src/Ringo.hs +++ b/src/Ringo.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} module Ringo ( -- | The examples in this module assume the following code has been run. -- The :{ and :} will only work in GHCi. @@ -64,15 +63,15 @@ import qualified Ringo.Validator as V -- , factTablePersistent = True -- , factParentNames = [] -- , factColumns = --- [ DimTime "created_at" --- , NoDimId "publisher_id" --- , DimVal "user_agent" "browser_name" --- , DimVal "user_agent" "os" --- , DimVal "user_agent" "user_agent_name" --- , DimVal "geo" "geo_country_name" --- , DimVal "geo" "geo_city_name" --- , DimVal "geo" "geo_continent_name" --- , FactCount Nothing "session_count" +-- [ FactColumn "created_at" $ DimTime +-- , FactColumn "publisher_id" $ NoDimId +-- , FactColumn "browser_name" $ DimVal "user_agent" +-- , FactColumn "os" $ DimVal "user_agent" +-- , FactColumn "user_agent_name" $ DimVal "user_agent" +-- , FactColumn "geo_country_name" $ DimVal "geo" +-- , FactColumn "geo_city_name" $ DimVal "geo" +-- , FactColumn "geo_continent_name" $ DimVal "geo" +-- , FactColumn "session_count" $ FactCount Nothing -- ] -- } -- pageViewEventsTable = @@ -105,11 +104,11 @@ import qualified Ringo.Validator as V -- , factTablePersistent = True -- , factParentNames = [ "session" ] -- , factColumns = --- [ DimTime "created_at" --- , NoDimId "publisher_id" --- , DimVal "page_type" "page_type" --- , DimId "referrers" "referrer_id" --- , FactCount Nothing "view_count" +-- [ FactColumn "created_at" $ DimTime +-- , FactColumn "publisher_id" $ NoDimId +-- , FactColumn "page_type" $ DimVal "page_type" +-- , FactColumn "referrer_id" $ DimId "referrers" +-- , FactColumn "view_count" $ FactCount Nothing -- ] -- } -- referrersTable = diff --git a/src/Ringo/Extractor.hs b/src/Ringo/Extractor.hs index d780ac4..192acd8 100644 --- a/src/Ringo/Extractor.hs +++ b/src/Ringo/Extractor.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GADTs #-} module Ringo.Extractor ( extractDimensionTables , extractAllDimensionTables @@ -32,21 +33,22 @@ extractFactTable fact = do notNullSourceColumnCopy cName = (sourceColumn cName) { columnNullable = NotNull } notNullSourceColumnRename scName cName = (notNullSourceColumnCopy scName) { columnName = cName } - columns = concatFor (factColumns fact) $ \col -> case col of - DimTime cName -> - [ Column (timeUnitColumnName dimIdColName cName settingTimeUnit) "bigint" NotNull ] - NoDimId cName -> [ notNullSourceColumnCopy cName ] - TenantId cName -> [ notNullSourceColumnCopy cName ] - FactCount _ cName -> [ Column cName countColType NotNull ] - FactSum scName cName -> [ notNullSourceColumnRename scName cName ] - FactMax scName cName -> [ notNullSourceColumnRename scName cName ] - FactMin scName cName -> [ notNullSourceColumnRename scName cName ] - FactAverage scName cName -> - [ Column (cName <> settingAvgCountColumSuffix) countColType NotNull - , notNullSourceColumnRename scName (cName <> settingAvgSumColumnSuffix) - ] - FactCountDistinct _ cName -> [ Column cName "json" NotNull ] - _ -> [] + columns = concatFor (factColumns fact) $ \FactColumn {factColTargetColumn = cName, ..} -> + case factColType of + DimTime -> + [ Column (timeUnitColumnName dimIdColName cName settingTimeUnit) "bigint" NotNull ] + NoDimId -> [ notNullSourceColumnCopy cName ] + TenantId -> [ notNullSourceColumnCopy cName ] + FactCount {..} -> [ Column cName countColType NotNull ] + FactCountDistinct {..} -> [ Column cName "json" NotNull ] + FactSum {..} -> [ notNullSourceColumnRename factColSourceColumn cName ] + FactMax {..} -> [ notNullSourceColumnRename factColSourceColumn cName ] + FactMin {..} -> [ notNullSourceColumnRename factColSourceColumn cName ] + FactAverage {..} -> + [ Column (cName <> settingAvgCountColumSuffix) countColType NotNull + , notNullSourceColumnRename factColSourceColumn (cName <> settingAvgSumColumnSuffix) + ] + _ -> [] fkColumns = for allDims $ \(dimFact, dimTable) -> let colName = factDimFKIdColumnName settingDimPrefix dimIdColName dimFact dimTable tables @@ -55,11 +57,12 @@ extractFactTable fact = do ukColNames = (++ map columnName fkColumns) - . forMaybe (factColumns fact) $ \col -> case col of - DimTime cName -> Just (timeUnitColumnName dimIdColName cName settingTimeUnit) - NoDimId cName -> Just cName - TenantId cName -> Just cName - _ -> Nothing + . forMaybe (factColumns fact) $ \FactColumn {factColTargetColumn = cName, ..} -> + case factColType of + DimTime -> Just $ timeUnitColumnName dimIdColName cName settingTimeUnit + NoDimId -> Just cName + TenantId -> Just cName + _ -> Nothing return Table { tableName = @@ -77,15 +80,15 @@ extractDependencies fact = do (factTableName fct, parentFacts fct facts) factDimDeps = nub . concat . Tree.flatten . flip Tree.unfoldTree fact $ \fct -> - ( forMaybe (factColumns fct) $ \col -> case col of - DimVal table _ -> Just $ settingDimPrefix <> table - DimId table _ -> Just table - _ -> Nothing + ( forMaybe (factColumns fct) $ \FactColumn {..} -> case factColType of + DimVal {..} -> Just $ settingDimPrefix <> factColTargetTable + DimId {..} -> Just factColTargetTable + _ -> Nothing , parentFacts fct facts ) dimDeps = Map.fromList [ (settingDimPrefix <> table, [factTableName fact]) - | DimVal table _ <- factColumns fact ] + | FactColumn {factColType = DimVal table} <- factColumns fact ] factDeps = Map.singleton (extractedTable settings) (factSourceDeps ++ factDimDeps) return $ Map.union dimDeps factDeps diff --git a/src/Ringo/Extractor/Internal.hs b/src/Ringo/Extractor/Internal.hs index 2b966ce..90d9690 100644 --- a/src/Ringo/Extractor/Internal.hs +++ b/src/Ringo/Extractor/Internal.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} module Ringo.Extractor.Internal where import qualified Data.Map as Map @@ -41,7 +42,9 @@ timeUnitColumnName dimIdColName colName timeUnit = factDimFKIdColumnName :: Text -> Text -> Fact -> Table -> [Table] -> ColumnName factDimFKIdColumnName dimPrefix dimIdColName dimFact dimTable@Table { .. } tables = if dimTable `elem` tables - then head [ cName | DimId tName cName <- factColumns dimFact, tName == tableName ] + then head [ factColTargetColumn + | FactColumn {factColType = DimId {..}, ..} <- factColumns dimFact + , factColTargetTable == tableName ] else fromMaybe tableName (Text.stripPrefix dimPrefix tableName) <> "_" <> dimIdColName extractedFactTableName :: Text -> Text -> TableName -> TimeUnit -> TableName @@ -62,7 +65,9 @@ extractDimensionTables fact = do let table = fromJust . findTable (factTableName fact) $ tables return $ dimsFromIds tables ++ dimsFromVals settings (tableColumns table) where - dimsFromIds tables = catMaybes [ findTable d tables | DimId d _ <- factColumns fact ] + dimsFromIds tables = + catMaybes [ findTable factColTargetTable tables + | FactColumn {factColType = DimId {..}} <- factColumns fact ] dimsFromVals Settings {..} tableColumns = map (\(dim, cols) -> @@ -81,9 +86,9 @@ extractDimensionTables fact = do . nub) . Map.fromListWith (flip (++)) . mapMaybe (\fcol -> do - DimVal d col <- fcol - column <- findColumn col tableColumns - return (d, [ column ])) + FactColumn {factColType = DimVal {..}, ..} <- fcol + column <- findColumn factColTargetColumn tableColumns + return (factColTargetTable, [ column ])) . map Just . factColumns $ fact diff --git a/src/Ringo/Generator/Create.hs b/src/Ringo/Generator/Create.hs index 5f0151c..2cc40a1 100644 --- a/src/Ringo/Generator/Create.hs +++ b/src/Ringo/Generator/Create.hs @@ -1,6 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} + module Ringo.Generator.Create (dimensionTableDefnSQL, factTableDefnSQL) where #if MIN_VERSION_base(4,8,0) @@ -73,20 +76,21 @@ factTableIndexStmts fact table = do tables <- asks envTables allDims <- extractAllDimensionTables fact - let dimTimeCol = head [ cName | DimTime cName <- factColumns fact ] - tenantIdCol = listToMaybe [ cName | TenantId cName <- factColumns fact ] + let dimTimeCol = head [ cName | DimTimeV cName <- factColumns fact ] + tenantIdCol = listToMaybe [ cName | TenantIdV cName <- factColumns fact ] tabName = tableName table <> settingTableNameSuffixTemplate dimTimeColName cName = timeUnitColumnName settingDimTableIdColumnName cName settingTimeUnit - factCols = forMaybe (factColumns fact) $ \col -> case col of - DimTime cName -> Just [dimTimeColName cName] - NoDimId cName -> Just [cName] - TenantId cName -> Just [cName] - _ -> Nothing + factCols = forMaybe (factColumns fact) $ \FactColumn {factColTargetColumn = cName, ..} -> + case factColType of + DimTime -> Just [dimTimeColName cName] + NoDimId -> Just [cName] + TenantId -> Just [cName] + _ -> Nothing dimCols = [ [ factDimFKIdColumnName settingDimPrefix settingDimTableIdColumnName dimFact dimTable tables ] | (dimFact, dimTable) <- allDims ] - return [ CreateIndexTSQL ea (nmc "") (name $ tabName) (map nmc cols) + return [ CreateIndexTSQL ea (nmc "") (name tabName) (map nmc cols) | cols <- factCols ++ dimCols ++ [ [cName, dimTimeColName dimTimeCol] | cName <- maybeToList tenantIdCol ] ] diff --git a/src/Ringo/Generator/Internal.hs b/src/Ringo/Generator/Internal.hs index 245b940..f1fdbcf 100644 --- a/src/Ringo/Generator/Internal.hs +++ b/src/Ringo/Generator/Internal.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GADTs #-} module Ringo.Generator.Internal where import qualified Data.Map as Map @@ -16,9 +17,9 @@ import Ringo.Types dimColumnMapping :: Text -> Fact -> TableName -> [(ColumnName, ColumnName)] dimColumnMapping dimPrefix fact dimTableName = - [ (dimColumnName dName cName, cName) - | DimVal dName cName <- factColumns fact - , dimPrefix <> dName == dimTableName ] + [ (dimColumnName factColTargetTable factColTargetColumn, factColTargetColumn) + | FactColumn { factColType = DimVal {..}, ..} <- factColumns fact + , dimPrefix <> factColTargetTable == dimTableName ] coalesceColumn :: TypeDefaults -> TableName -> Column -> ScalarExpr coalesceColumn defaults tName Column{..} = diff --git a/src/Ringo/Generator/Populate/Dimension.hs b/src/Ringo/Generator/Populate/Dimension.hs index f125fc9..8ba028a 100644 --- a/src/Ringo/Generator/Populate/Dimension.hs +++ b/src/Ringo/Generator/Populate/Dimension.hs @@ -1,6 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} + module Ringo.Generator.Populate.Dimension (dimensionTablePopulateSQL) where #if MIN_VERSION_base(4,8,0) @@ -32,7 +34,7 @@ dimensionTablePopulateStmt popMode fact dimTableName = do selectCols = [ flip sia (nmc cName) $ coalesceColumn defaults (factTableName fact) col | (_, cName) <- colMapping , let col = fromJust . findColumn cName $ tableColumns factTable ] - timeCol = head [ cName | DimTime cName <- factColumns fact ] + timeCol = head ([ cName | DimTimeV cName <- factColumns fact ] :: [ColumnName]) isNotNullC = parens . foldBinop "or" . map (postop "isnotnull" . ei . snd) $ colMapping selectWhereC = Just . foldBinop "and" $ [ isNotNullC, binop "<" (ei timeCol) placeholder ] ++ diff --git a/src/Ringo/Generator/Populate/Fact.hs b/src/Ringo/Generator/Populate/Fact.hs index d4e7428..494bbc4 100644 --- a/src/Ringo/Generator/Populate/Fact.hs +++ b/src/Ringo/Generator/Populate/Fact.hs @@ -4,6 +4,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} + module Ringo.Generator.Populate.Fact (factTablePopulateSQL) where import qualified Data.Text as Text @@ -55,61 +58,66 @@ LANGUAGE 'plpgsql' IMMUTABLE; |] factCountDistinctUpdateStmts :: TablePopulationMode -> Fact -> Text -> QueryExpr -> Reader Env [Statement] -factCountDistinctUpdateStmts - popMode fact groupByColPrefix ~Select {selSelectList = SelectList _ origSelectItems, ..} = do - Settings {..} <- asks envSettings - tables <- asks envTables - let countDistinctCols = [ col | col@(FactCountDistinct _ _) <- factColumns fact] - fTableName = factTableName fact - fTable = fromJust . findTable fTableName $ tables - tablePKColName = head [ cName | PrimaryKey cName <- tableConstraints fTable ] - extFactTableName = - suffixTableName popMode settingTableNameSuffixTemplate - $ extractedFactTableName settingFactPrefix settingFactInfix (factName fact) settingTimeUnit +factCountDistinctUpdateStmts popMode fact groupByColPrefix expr = case expr of + Select {selSelectList = SelectList _ origSelectItems, ..} -> do + Settings {..} <- asks envSettings + tables <- asks envTables + let fTableName = factTableName fact + fTable = fromJust . findTable fTableName $ tables + tablePKColName = head [ cName | PrimaryKey cName <- tableConstraints fTable ] + extFactTableName = + suffixTableName popMode settingTableNameSuffixTemplate + $ extractedFactTableName settingFactPrefix settingFactInfix (factName fact) settingTimeUnit - return $ for countDistinctCols $ \(FactCountDistinct scName cName) -> - let unqCol = cast (eqi fTableName (fromMaybe tablePKColName scName)) "text" + return $ forMaybe (factColumns fact) $ \FactColumn {factColTargetColumn = cName, ..} -> + case factColType of + FactCountDistinct {factColMaybeSourceColumn = scName} -> + let unqCol = cast (eqi fTableName (fromMaybe tablePKColName scName)) "text" - bucketSelectCols = - [ sia (binop "&" (app "hashtext" [ unqCol ]) - (num . Text.pack . show $ bucketCount settingFactCountDistinctErrorRate - 1)) - (nmc $ cName <> "_bnum") - , sia (binop "-" - (num "31") - (app "ilog2" - [ app "min" [ binop "&" - (app "hashtext" [ unqCol ]) - (prefop "~" (parens (binop "<<" (num "1") (num "31"))))]])) - (nmc $ cName <> "_bhash") - ] + bucketSelectCols = + [ sia (binop "&" (app "hashtext" [ unqCol ]) + (num . Text.pack . show $ bucketCount settingFactCountDistinctErrorRate - 1)) + (nmc $ cName <> "_bnum") + , sia (binop "-" + (num "31") + (app "ilog2" + [ app "min" [ binop "&" + (app "hashtext" [ unqCol ]) + (prefop "~" (parens (binop "<<" (num "1") (num "31"))))]])) + (nmc $ cName <> "_bhash") + ] - groupByCols = map ppScalarExpr selGroupBy - selectList = - [ i | i@(SelectItem _ _ a) <- origSelectItems , a `elem` map nmc groupByCols ] + groupByCols = map ppScalarExpr selGroupBy + selectList = + [ i | i@(SelectItem _ _ a) <- origSelectItems , a `elem` map nmc groupByCols ] - selectStmt = - makeSelect - { selSelectList = sl $ selectList ++ bucketSelectCols - , selTref = selTref - , selWhere = binop "and" (postop "isnotnull" unqCol) <$> selWhere - , selGroupBy = selGroupBy ++ [ ei $ cName <> "_bnum" ] - } + selectStmt = + makeSelect + { selSelectList = sl $ selectList ++ bucketSelectCols + , selTref = selTref + , selWhere = binop "and" (postop "isnotnull" unqCol) <$> selWhere + , selGroupBy = selGroupBy ++ [ ei $ cName <> "_bnum" ] + } - aggSelectClause = - sia (app "json_object_agg" [ ei (cName <> "_bnum"), ei (cName <> "_bhash") ]) (nmc cName) + aggSelectClause = + sia (app "json_object_agg" [ ei (cName <> "_bnum"), ei (cName <> "_bhash") ]) (nmc cName) - in update extFactTableName - [ (cName, eqi "xyz" cName) ] - [ subtrefa "xyz" - makeSelect - { selSelectList = sl $ map (si . ei) groupByCols ++ [ aggSelectClause ] - , selTref = [ subtrefa "zyx" selectStmt ] - , selGroupBy = selGroupBy - } ] $ - foldBinop "and" - [ binop "=" (eqi extFactTableName . fromJust . Text.stripPrefix groupByColPrefix $ col) - (eqi "xyz" col) - | col <- groupByCols ] + in Just $ update extFactTableName + [ (cName, eqi "xyz" cName) ] + [ subtrefa "xyz" + makeSelect + { selSelectList = sl $ map (si . ei) groupByCols ++ [ aggSelectClause ] + , selTref = [ subtrefa "zyx" selectStmt ] + , selGroupBy = selGroupBy + } ] $ + foldBinop "and" + [ binop "=" (eqi extFactTableName . fromJust . Text.stripPrefix groupByColPrefix $ col) + (eqi "xyz" col) + | col <- groupByCols ] + + _ -> Nothing + + _ -> return [] where bucketCount :: Double -> Integer bucketCount errorRate = @@ -143,21 +151,22 @@ factTablePopulateStmts popMode fact = do app' f cName = app f [ eqi fTableName cName ] - factColMap = concatFor (factColumns fact) $ \col -> case col of - DimTime cName -> [ timeUnitColumnInsertSQL cName ] - NoDimId cName -> [ dimIdColumnInsertSQL cName ] - TenantId cName -> [ dimIdColumnInsertSQL cName ] - FactCount scName cName -> - [ (cName, app "count" [ maybe star (eqi fTableName) scName ], False) ] - FactSum scName cName -> [ (cName, app' "sum" scName, False) ] - FactMax scName cName -> [ (cName, app' "max" scName, False) ] - FactMin scName cName -> [ (cName, app' "min" scName, False) ] - FactAverage scName cName -> - [ ( cName <> settingAvgCountColumSuffix, app' "count" scName, False ) - , ( cName <> settingAvgSumColumnSuffix , app' "sum" scName , False) - ] - FactCountDistinct _ cName -> [ (cName, cast (str "{}") "json", False) ] - _ -> [] + factColMap = concatFor (factColumns fact) $ \FactColumn {factColTargetColumn = cName, ..} -> + case factColType of + DimTime -> [ timeUnitColumnInsertSQL cName ] + NoDimId -> [ dimIdColumnInsertSQL cName ] + TenantId -> [ dimIdColumnInsertSQL cName ] + FactCount {..} -> + [ (cName, app "count" [ maybe star (eqi fTableName) factColMaybeSourceColumn ], False) ] + FactCountDistinct {..} -> [ (cName, cast (str "{}") "json", False) ] + FactSum {..} -> [ (cName, app' "sum" factColSourceColumn, False) ] + FactMax {..} -> [ (cName, app' "max" factColSourceColumn, False) ] + FactMin {..} -> [ (cName, app' "min" factColSourceColumn, False) ] + FactAverage {..} -> + [ ( cName <> settingAvgCountColumSuffix, app' "count" factColSourceColumn, False ) + , ( cName <> settingAvgSumColumnSuffix , app' "sum" factColSourceColumn , False) + ] + _ -> [] dimColMap = for allDims $ \(dimFact, factTable@Table {tableName}) -> let dimFKIdColName = @@ -191,7 +200,7 @@ factTablePopulateStmts popMode fact = do . map (factTableName . fst) $ allDims - timeCol = eqi fTableName $ head [ cName | DimTime cName <- factColumns fact ] + timeCol = eqi fTableName $ head [ cName | DimTimeV cName <- factColumns fact ] extFactTableName = suffixTableName popMode settingTableNameSuffixTemplate $ extractedFactTableName settingFactPrefix settingFactInfix (factName fact) settingTimeUnit diff --git a/src/Ringo/Types.hs b/src/Ringo/Types.hs index af99067..24138d9 100644 --- a/src/Ringo/Types.hs +++ b/src/Ringo/Types.hs @@ -1,6 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE PatternSynonyms #-} + module Ringo.Types where import qualified Data.Text as Text @@ -44,7 +48,6 @@ instance Show TableConstraint where show (UniqueKey cols) = "UniqueKey " ++ showColNames cols show (ForeignKey tName colMap) = "ForeignKey " ++ showColNames (map fst colMap) ++ " " ++ Text.unpack tName ++ " " ++ showColNames (map snd colMap) - data Table = Table { tableName :: !TableName , tableColumns :: ![Column] @@ -53,7 +56,7 @@ data Table = Table instance Show Table where show Table {..} = - unlines $ ("Table " ++ Text.unpack tableName) : (map show tableColumns) ++ (map show tableConstraints) + unlines $ ("Table " ++ Text.unpack tableName) : map show tableColumns ++ map show tableConstraints data TimeUnit = Second | Minute | Hour | Day | Week deriving (Eq, Enum, Show, Read) @@ -74,33 +77,59 @@ data Fact = Fact , factTablePersistent :: !Bool , factParentNames :: ![TableName] , factColumns :: ![FactColumn] - } deriving (Eq, Show) + } deriving (Show) -data FactColumn = DimTime !ColumnName - | NoDimId !ColumnName - | TenantId !ColumnName - | DimId !TableName !ColumnName - | DimVal !TableName !ColumnName - | FactCount !(Maybe ColumnName) !ColumnName - | FactSum !ColumnName !ColumnName - | FactAverage !ColumnName !ColumnName - | FactCountDistinct !(Maybe ColumnName) !ColumnName - | FactMax !ColumnName !ColumnName - | FactMin !ColumnName !ColumnName - deriving (Eq, Show) +data FCTNone +data FCTTargetTable +data FCTMaybeSourceColumn +data FCTSourceColumn + +data FactColumnType a where + DimTime :: FactColumnType FCTNone + NoDimId :: FactColumnType FCTNone + TenantId :: FactColumnType FCTNone + DimId :: { factColTargetTable :: !TableName } -> FactColumnType FCTTargetTable + DimVal :: { factColTargetTable :: !TableName } -> FactColumnType FCTTargetTable + FactCount :: { factColMaybeSourceColumn :: !(Maybe ColumnName) } -> FactColumnType FCTMaybeSourceColumn + FactCountDistinct :: { factColMaybeSourceColumn :: !(Maybe ColumnName) } -> FactColumnType FCTMaybeSourceColumn + FactSum :: { factColSourceColumn :: !ColumnName } -> FactColumnType FCTSourceColumn + FactAverage :: { factColSourceColumn :: !ColumnName } -> FactColumnType FCTSourceColumn + FactMax :: { factColSourceColumn :: !ColumnName } -> FactColumnType FCTSourceColumn + FactMin :: { factColSourceColumn :: !ColumnName } -> FactColumnType FCTSourceColumn + +deriving instance Show (FactColumnType a) + +pattern DimTimeV col <- FactColumn col DimTime +pattern NoDimIdV col <- FactColumn col NoDimId +pattern TenantIdV col <- FactColumn col TenantId +pattern DimIdV col <- FactColumn col DimId {..} +pattern DimValV col <- FactColumn col DimVal {..} +pattern FactCountV col <- FactColumn col FactCount {..} +pattern FactCountDistinctV col <- FactColumn col FactCountDistinct {..} +pattern FactSumV col <- FactColumn col FactSum {..} +pattern FactAverageV col <- FactColumn col FactAverage {..} +pattern FactMaxV col <- FactColumn col FactMax {..} +pattern FactMinV col <- FactColumn col FactMin {..} + +data FactColumn = forall a. FactColumn + { factColTargetColumn :: !ColumnName + , factColType :: FactColumnType a } + +deriving instance Show FactColumn factSourceColumnName :: FactColumn -> Maybe ColumnName -factSourceColumnName (DimTime cName) = Just cName -factSourceColumnName (NoDimId cName) = Just cName -factSourceColumnName (TenantId cName) = Just cName -factSourceColumnName (DimId _ cName) = Just cName -factSourceColumnName (DimVal _ cName) = Just cName -factSourceColumnName (FactCount cName _) = cName -factSourceColumnName (FactSum cName _) = Just cName -factSourceColumnName (FactAverage cName _) = Just cName -factSourceColumnName (FactCountDistinct cName _) = cName -factSourceColumnName (FactMax cName _) = Just cName -factSourceColumnName (FactMin cName _) = Just cName +factSourceColumnName FactColumn {..} = case factColType of + DimTime -> Just factColTargetColumn + NoDimId -> Just factColTargetColumn + TenantId -> Just factColTargetColumn + DimId {..} -> Just factColTargetColumn + DimVal {..} -> Just factColTargetColumn + FactCount {..} -> factColMaybeSourceColumn + FactCountDistinct {..} -> factColMaybeSourceColumn + FactSum {..} -> Just factColSourceColumn + FactAverage {..} -> Just factColSourceColumn + FactMax {..} -> Just factColSourceColumn + FactMin {..} -> Just factColSourceColumn data Settings = Settings { settingDimPrefix :: !Text @@ -154,7 +183,7 @@ data Env = Env , envFacts :: ![Fact] , envSettings :: !Settings , envTypeDefaults :: !TypeDefaults - } deriving (Eq, Show) + } deriving (Show) data TablePopulationMode = FullPopulation | IncrementalPopulation deriving (Eq, Show) diff --git a/src/Ringo/Utils.hs b/src/Ringo/Utils.hs index cc94de9..e27980d 100644 --- a/src/Ringo/Utils.hs +++ b/src/Ringo/Utils.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} module Ringo.Utils where diff --git a/src/Ringo/Validator.hs b/src/Ringo/Validator.hs index 1e75bb4..c22e083 100644 --- a/src/Ringo/Validator.hs +++ b/src/Ringo/Validator.hs @@ -1,6 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} + module Ringo.Validator ( validateTable , validateFact @@ -51,17 +54,19 @@ validateFact Fact {..} = do parentVs <- concat <$> mapM checkFactParents factParentNames let colVs = concatMap (checkColumn tables table) factColumns timeVs = [ MissingTimeColumn factTableName - | null [ c | DimTime c <- factColumns ] ] - notNullVs = [ MissingNotNullConstraint factTableName c - | DimTime c <- factColumns - , let col = findColumn c (tableColumns table) + | null ([ cName | DimTimeV cName <- factColumns ] :: [ColumnName]) ] + notNullVs = [ MissingNotNullConstraint factTableName cName + | DimTimeV cName <- factColumns + , let col = findColumn cName (tableColumns table) , isJust col , columnNullable (fromJust col) == Null ] + typeDefaultVs = [ MissingTypeDefault cType - | cName <- [ c | DimVal _ c <- factColumns ] - ++ [ c | NoDimId c <- factColumns ] - ++ [ c | TenantId c <- factColumns ] + | cName <- [ c | DimValV c <- factColumns ] + ++ [ c | NoDimIdV c <- factColumns ] + ++ [ c | TenantIdV c <- factColumns ] + ++ [ c | DimIdV c <- factColumns ] , let col = findColumn cName (tableColumns table) , isJust col , let cType = columnType $ fromJust col @@ -79,6 +84,7 @@ validateFact Fact {..} = do maybe [] (checkTableForCol table) (factSourceColumnName factCol) ++ checkColumnTable tables factCol - checkColumnTable tables factCol = case factCol of - DimId tName _ -> maybe [ MissingTable tName ] (const []) $ findTable tName tables - _ -> [] + checkColumnTable :: [Table] -> FactColumn -> [ValidationError] + checkColumnTable tables FactColumn {..} = case factColType of + DimId {factColTargetTable = tName} -> maybe [ MissingTable tName ] (const []) $ findTable tName tables + _ -> [] diff --git a/stack.yaml b/stack.yaml index 26532ef..f1930e6 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,7 +1,7 @@ # For more information, see: https://github.com/commercialhaskell/stack/blob/master/doc/yaml_configuration.md # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) -resolver: lts-5.0 +resolver: lts-5.1 # Local packages, usually specified by relative directory name packages: