Changes FactColumn to use GADTs for better type safety.

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"

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

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 =

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

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

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

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{..} =

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

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
-
-  return $ for countDistinctCols $ \(FactCountDistinct scName cName) ->
-      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")
-            ]
-
-          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" ]
-              }
-
-          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 ]
+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 $ 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")
+                ]
+
+              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" ]
+                  }
+
+              aggSelectClause  =
+                sia (app "json_object_agg" [ ei (cName <> "_bnum"), ei (cName <> "_bhash") ]) (nmc cName)
+
+          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

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)
-
-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)
+            } deriving (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)
 

src/Ringo/Utils.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE CPP #-}
 module Ringo.Utils where
 

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
+      _                                  -> []

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: