Simplify loading stuff and use home directory more

app/Main.hs

@@ -39,20 +39,6 @@ data Options = Options
 noConfigFile :: ExitCode
 noConfigFile = ExitFailure 10
 
-rethrowAs :: (Exception e, Exception f) => (e -> Maybe f) -> IO a -> IO a
-rethrowAs f action = do
-  res <- tryJust f action
-  case res of
-    Right v -> return v
-    Left e  -> throwIO e
-
-rethrowAsIf :: (Exception e, Exception f) => (e -> Bool) -> f -> IO a -> IO a
-rethrowAsIf check newException action = do
-  res <- tryJust (guard . check) action
-  case res of
-    Right v -> return v
-    Left _ -> throwIO newException
-
 {-
  - Useful functions
  -}
@@ -79,7 +65,7 @@ argParser homedir = pure Options
       , O.help $ "Where to look for a config file.\
                  \ This option can be set multiple times.\
                  \ If not specified, will look in these locations:\n"
-                 ++ (intercalate "," $ map show $ TM.defaultConfigFilePaths homedir)
+                 ++ intercalate "," (map show $ TM.defaultConfigFilePaths homedir)
       , O.metavar "CONFIGFILE"
       ]
     taskDB = O.strOption $ mconcat
@@ -121,29 +107,24 @@ argParserInfo homedir = O.info (O.helper <*> argParser homedir) $ mconcat
  -}
 
 -- Kinda ugly...
-loadConfigs :: [FilePath] -> IO (Maybe TM.Config)
+loadConfigs :: TM.HomeDir -> [FilePath] -> IO (Maybe TM.Config)
-loadConfigs [] = return Nothing
+loadConfigs _ [] = return Nothing
-loadConfigs (path:paths) = do
+loadConfigs homedir (path:paths) = do
   act $ "Loading config from " ++ show path ++ "."
-  mConf <- tryLoadConfig path
+  mConf <- handleOpenFileExceptions $ tryLoadConfig path
   case mConf of
     Just conf -> return (Just conf)
     Nothing -> do
       putStrLn $ "Could not load config from " ++ show path ++ "."
-      loadConfigs paths
+      loadConfigs homedir paths
   where
     tryLoadConfig :: FilePath -> IO (Maybe TM.Config)
-    tryLoadConfig p = handleOpenFileExceptions
+    tryLoadConfig p = do
-                    $ handleCPException
+      eConf <- TM.loadConfig homedir p
-                    $ Just <$> TM.loadConfig p
+      case eConf of
-    --tryLoadConfig p = Just <$> TM.loadConfig p
+        Right conf              -> return $ Just conf
-    handleCPException :: IO (Maybe a) -> IO (Maybe a)
+        Left (C.ParseError msg) -> Nothing <$ putStrLn msg
-    handleCPException f = do
+        Left _                  -> return Nothing
-      res <- try f
-      case res of
-        Right m                                  -> return m
-        Left (TM.CPException (C.ParseError msg)) -> Nothing <$ putStrLn msg
-        Left (TM.CPException _                 ) -> putStrLn "Bleep" >> return Nothing
     handleOpenFileExceptions :: IO (Maybe a) -> IO (Maybe a)
     handleOpenFileExceptions f = do
       res <- tryJust (guard . isRelevantError) f
@@ -170,7 +151,7 @@ loadThemes :: B.Theme -> [FilePath] -> IO B.Theme
 loadThemes theme [] = return theme
 loadThemes theme (path:paths) = do
   act $ "Loading theme from " ++ show path ++ "."
-  mNewTheme <- tryLoadCustomizations path theme
+  mNewTheme <- handleOpenFileExceptions $ B.loadCustomizations path theme
   case mNewTheme of
     Nothing -> do
       putStrLn $ "Could not load theme from " ++ show path ++ "."
@@ -180,14 +161,11 @@ loadThemes theme (path:paths) = do
       putStrLn $ "Could not load theme from " ++ show path ++ ": " ++ errMsg
       loadThemes theme paths
   where
-    tryLoadCustomizations :: FilePath -> B.Theme -> IO (Maybe (Either String B.Theme))
+    handleOpenFileExceptions :: IO a -> IO (Maybe a)
-    tryLoadCustomizations p t = handleOpenFileExceptions
-                              $ Just <$> B.loadCustomizations p t
-    handleOpenFileExceptions :: IO (Maybe a) -> IO (Maybe a)
     handleOpenFileExceptions f = do
       res <- tryJust (guard . isRelevantError) f
       case res of
-        Right m -> return m
+        Right m -> return $ Just m
         Left _  -> return Nothing
     isRelevantError :: IOError -> Bool
     isRelevantError e =  isAlreadyInUseError e
@@ -202,7 +180,7 @@ main = do
   -- Export default config
   forM_ (oExportDefaultConfig options) $ \path -> do
     act $ "Exporting default config to " ++ show path ++ "."
-    TM.saveConfig path TM.defaultConfig
+    TM.saveConfig path $ TM.defaultConfig homedir
 
   -- Export default theme
   forM_ (oExportDefaultTheme options) $ \path -> do
@@ -210,7 +188,7 @@ main = do
     B.saveTheme path TM.defaultTheme
 
   -- Load config
-  mConfig <- loadConfigs $ oConfigFile options
+  mConfig <- loadConfigs homedir $ oConfigFile options
   config <- case mConfig of
     Nothing -> do
       putStrLn ""
@@ -219,31 +197,12 @@ main = do
       exitWith noConfigFile
     Just unmergedConfig -> return $ mergeWithOptions unmergedConfig options
 
-  -- According to config, load themes and initialize db
+  -- According to config, load themes
   theme <- loadThemes TM.defaultTheme $ TM.cThemes config
+
+  -- ... and initialize db
+  act $ "Using db at " ++ show (TM.cTaskDB config) ++ "."
   DB.withConnection (TM.cTaskDB config) TM.initializeNewDB
 
   -- Start the UI
   error "Implement UI" theme config
-
---import qualified Database.SQLite.Simple as DB
---import qualified TaskMachine.Database as TMD
---main = DB.withConnection "test.db" TMD.initializeNewDB
-
---data ResourceName = Asdf
---  deriving (Eq, Ord)
---
---myApp :: B.App () () ResourceName
---myApp = B.App
---  { B.appDraw         = \_ -> [myTestWidget]
---  , B.appHandleEvent  = B.resizeOrQuit
---  , B.appStartEvent   = \s -> return s
---  , B.appChooseCursor = B.neverShowCursor
---  , B.appAttrMap      = const $ B.themeToAttrMap TM.defaultTheme
---  }
---  where
---    myTestWidget = normal B.<=> urgent B.<=> veryUrgent B.<=> overdue
---    normal     = B.withAttr ("taskList"                 <> "normal") (B.str "     normal ") B.<+> B.withAttr ("taskList"                 <> "highlight") (B.str "style")
---    urgent     = B.withAttr ("taskList" <> "urgent"     <> "normal") (B.str "     urgent ") B.<+> B.withAttr ("taskList" <> "urgent"     <> "highlight") (B.str "style")
---    veryUrgent = B.withAttr ("taskList" <> "veryUrgent" <> "normal") (B.str "very urgent ") B.<+> B.withAttr ("taskList" <> "veryUrgent" <> "highlight") (B.str "style")
---    overdue    = B.withAttr ("taskList" <> "overdue"    <> "normal") (B.str "    overdue ") B.<+> B.withAttr ("taskList" <> "overdue"    <> "highlight") (B.str "style")

src/TaskMachine/Config.hs

@@ -1,51 +1,45 @@
 {-# LANGUAGE RecordWildCards #-}
 
 module TaskMachine.Config
-  ( Config(..)
+  ( HomeDir
+  , Config(..)
   , defaultConfig
   , defaultConfigFilePaths
-  , CPException(..)
   , loadConfig
   , saveConfig
   ) where
 
-import           Control.Exception
 import           Data.Either
 
 import qualified Data.ConfigFile as C
 
+type HomeDir = FilePath
+
 data Config = Config
   { cThemes :: [FilePath]
   , cTaskDB :: FilePath
   }
 
-defaultConfig :: Config
+defaultConfig :: HomeDir -> Config
-defaultConfig = Config
+defaultConfig homedir = Config
   { cThemes = []
-  , cTaskDB = "~/.taskmachine/tasks.db"
+  , cTaskDB = homedir ++ "/.taskmachine/tasks.db"
   }
 
-defaultConfigFilePaths :: FilePath ->  [FilePath]
+defaultConfigFilePaths :: HomeDir ->  [FilePath]
 defaultConfigFilePaths homedir =
   [homedir ++ "/.taskmachine/tasks.conf", "tasks.conf"]
 
-newtype CPException = CPException C.CPErrorData
+loadConfig :: HomeDir -> FilePath -> IO (Either C.CPErrorData Config)
-  deriving (Show)
+loadConfig homedir path = do
-
+  ecp <- C.readfile C.emptyCP path
-instance Exception CPException
+  case ecp of
-
+    Left (e, _) -> return $ Left e
-toCPException :: (C.CPErrorData, String) -> CPException
-toCPException (errorData, _) = CPException errorData
-
-loadConfig :: FilePath -> IO Config
-loadConfig path = do
-  mcp <- C.readfile C.emptyCP path
-  case mcp of
-    Left e -> throwIO $ toCPException e
     Right cp ->
-      let myThemes = fromRight (cThemes defaultConfig) $ C.get cp "DEFAULT" "themes"
+      let config = defaultConfig homedir
-          myTaskDB = fromRight (cTaskDB defaultConfig) $ C.get cp "DEFAULT" "taskdb"
+          myThemes = fromRight (cThemes config) $ C.get cp "DEFAULT" "themes"
-      in  return Config
+          myTaskDB = fromRight (cTaskDB config) $ C.get cp "DEFAULT" "taskdb"
+      in  return $ Right Config
             { cThemes = myThemes
             , cTaskDB = myTaskDB
             }
@@ -55,7 +49,7 @@ configToParser Config{..} = fromEither $ do
   cp1 <- C.set C.emptyCP "DEFAULT" "themes" (show cThemes)
   C.set cp1 "DEFAULT" "taskdb" cTaskDB
   where
-    fromEither (Left e)  = throw $ toCPException e
+    fromEither (Left _)  = undefined -- This should not be able to fail.
     fromEither (Right v) = v
 
 saveConfig :: FilePath -> Config -> IO ()