Refactors ringo app to simplify the code.

ringo-app/src/Distribution/CurrentPackageDescription.hs

@@ -1,8 +1,11 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
 module Distribution.CurrentPackageDescription
   ( currentPackageDescription
   , getField
   ) where
 
+import Prelude.Compat
 import Distribution.PackageDescription
 import Distribution.PackageDescription.Parse
 import Distribution.Verbosity
@@ -18,12 +21,10 @@ getField f = runIO currentPackageDescription >>= stringE . f
 currentPackageDescription :: IO PackageDescription
 currentPackageDescription = fmap packageDescription $ do
   dir <- getCurrentDirectory
-  cs <- cabalFiles dir
+  cs  <- cabalFiles dir
   case cs of
     (c:_) -> readPackageDescription silent c
-    [] -> error $ "Couldn't find a cabal file in the current working directory (" ++ dir ++ ")"
+    []    -> error $ "Couldn't find a cabal file in the current working directory (" ++ dir ++ ")"
 
 cabalFiles :: FilePath -> IO [FilePath]
-cabalFiles dir = do
-  files <- getDirectoryContents dir
-  return $ filter (".cabal" `isSuffixOf`) files
+cabalFiles dir = filter (".cabal" `isSuffixOf`) <$> getDirectoryContents dir

ringo-app/src/Main.hs

@@ -35,7 +35,7 @@ writeFiles :: FilePath -> Env -> IO ()
 writeFiles outputDir env = do
   let Settings{..} = envSettings env
 
-  forM_ sqls $ \(sqlType, table, sql) -> do
+  forM_ (makeSQLs env dimTables factTables) $ \(sqlType, table, sql) -> do
     let dirName = outputDir </> map toLower (show sqlType)
     createDirectoryIfMissing True dirName
     writeFile (dirName </> Text.unpack table <.> "sql") sql
@@ -50,7 +50,6 @@ writeFiles outputDir env = do
 
   BS.writeFile (outputDir </> Text.unpack settingFactsJSONFileName) . encode $
     [ tableName table | (_, table) <- factTables ]
-
   where
     facts      = envFacts env
     tables     = envTables env
@@ -58,13 +57,17 @@ writeFiles outputDir env = do
     dimTables  = [ (fact, extractDimensionTables env fact) | fact <- facts ]
     factTables = [ (fact, extractFactTable env fact)       | fact <- facts, factTablePersistent fact ]
 
-    dimTableDefinitionSQLs = [ (Create, tableName table, unlines . map sqlStr $ dimensionTableDefinitionSQL env table)
-                               | (_, tabs) <- dimTables
-                               , table     <- tabs
-                               , table `notElem` tables ]
+makeSQLs :: Env -> [(Fact, [Table])] -> [(Fact, Table)] -> [(SQLType, TableName, String)]
+makeSQLs env dimTables factTables = let
+    dimTableDefinitionSQLs =
+      [ (Create, tableName table, unlines . map sqlStr $ dimensionTableDefinitionSQL env table)
+         | (_, tabs) <- dimTables
+         , table     <- tabs
+         , table `notElem` tables ]
 
-    factTableDefinitionSQLs = [ (Create , tableName table, unlines . map sqlStr $ factTableDefinitionSQL env fact table)
-                                | (fact, table) <- factTables ]
+    factTableDefinitionSQLs =
+      [ (Create , tableName table, unlines . map sqlStr $ factTableDefinitionSQL env fact table)
+        | (fact, table) <- factTables ]
 
     dimTablePopulationSQLs typ gen  =
       [ (typ , tableName table, sqlStr $ gen env fact (tableName table))
@@ -74,13 +77,13 @@ writeFiles outputDir env = do
 
     factTablePopulationSQLs typ gen = [ (typ, tableName table, unlines . map sqlStr  $ gen env fact)
                                         | (fact, table) <- factTables ]
-
-    sqls = concat [ dimTableDefinitionSQLs
-                  , factTableDefinitionSQLs
-                  , dimTablePopulationSQLs FullRefresh  $ dimensionTablePopulationSQL FullPopulation
-                  , dimTablePopulationSQLs IncRefresh   $ dimensionTablePopulationSQL IncrementalPopulation
-                  , factTablePopulationSQLs FullRefresh $ factTablePopulationSQL FullPopulation
-                  , factTablePopulationSQLs IncRefresh  $ factTablePopulationSQL IncrementalPopulation
-                  ]
-
+  in concat [ dimTableDefinitionSQLs
+            , factTableDefinitionSQLs
+            , dimTablePopulationSQLs FullRefresh  $ dimensionTablePopulationSQL FullPopulation
+            , dimTablePopulationSQLs IncRefresh   $ dimensionTablePopulationSQL IncrementalPopulation
+            , factTablePopulationSQLs FullRefresh $ factTablePopulationSQL FullPopulation
+            , factTablePopulationSQLs IncRefresh  $ factTablePopulationSQL IncrementalPopulation
+            ]
+  where
+    tables = envTables env
     sqlStr = Text.unpack

ringo-app/src/Ringo/ArgParser.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TemplateHaskell #-}
+
 module Ringo.ArgParser (ProgArgs(..), parseArgs) where
 
 import qualified Data.Text as Text

ringo-app/src/Ringo/InputParser.hs

@@ -21,14 +21,11 @@ instance FromJSON Nullable where
   parseJSON o          = fail $ "Cannot parse nullable: " ++ show o
 
 instance FromJSON Column where
-  parseJSON (Array a) = if V.length a < 2
-    then fail "Column needs at least two elements: name and type"
-    else do
-      cName <- parseJSON $ a ! 0
-      cType <- parseJSON $ a ! 1
-      cNull <- parseJSON $ fromMaybe "null" (a !? 2)
-      return $ Column cName cType cNull
-
+  parseJSON (Array a)
+    | V.length a >= 2 = Column <$> parseJSON (a ! 0)
+                               <*> parseJSON (a ! 1)
+                               <*> parseJSON (fromMaybe "null" (a !? 2))
+    | otherwise       = fail "Column needs at least two elements: name and type"
   parseJSON o         = fail $ "Cannot parse column: " ++ show o
 
 instance FromJSON TableConstraint where
@@ -47,19 +44,20 @@ instance FromJSON Table where
 
 instance FromJSON FactColumn where
   parseJSON (Object o) = do
-    cType <- o .: "type"
+    cType     <- o .: "type"
+    let cName = o .: "column"
     case cType of
-      "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")
+      "dimtime"           -> FactColumn <$> cName <*> pure DimTime
+      "nodimid"           -> FactColumn <$> cName <*> pure NoDimId
+      "tenantid"          -> FactColumn <$> cName <*> pure TenantId
+      "dimid"             -> FactColumn <$> cName <*> (DimId             <$> o .: "table")
+      "dimval"            -> FactColumn <$> cName <*> (DimVal            <$> o .: "table")
+      "factcount"         -> FactColumn <$> cName <*> (FactCount         <$> o .:? "sourcecolumn")
+      "factcountdistinct" -> FactColumn <$> cName <*> (FactCountDistinct <$> o .:? "sourcecolumn")
+      "factsum"           -> FactColumn <$> cName <*> (FactSum           <$> o .: "sourcecolumn")
+      "factaverage"       -> FactColumn <$> cName <*> (FactAverage       <$> o .: "sourcecolumn")
+      "factmax"           -> FactColumn <$> cName <*> (FactMax           <$> o .: "sourcecolumn")
+      "factmin"           -> FactColumn <$> cName <*> (FactMin           <$> o .: "sourcecolumn")
       _                   -> fail $ "Invalid fact column type: " ++ cType
   parseJSON o          = fail $ "Cannot parse fact column: " ++ show o