From 51eb270431d84daee507236a369d1984cf01806c Mon Sep 17 00:00:00 2001 From: Joscha Date: Thu, 22 Mar 2018 12:39:19 +0000 Subject: [PATCH] Simplify loading stuff and use home directory more --- app/Main.hs | 85 ++++++++++----------------------------- src/TaskMachine/Config.hs | 44 +++++++++----------- 2 files changed, 41 insertions(+), 88 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index a847cea..5c3f209 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -13,7 +13,7 @@ import qualified Brick.Themes as B import qualified Data.ConfigFile as C import qualified Database.SQLite.Simple as DB import qualified Options.Applicative as O -import qualified System.Posix.User as P +import qualified System.Posix.User as P import qualified TaskMachine.Config as TM import qualified TaskMachine.Database as TM @@ -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 [] = return Nothing -loadConfigs (path:paths) = do +loadConfigs :: TM.HomeDir -> [FilePath] -> IO (Maybe TM.Config) +loadConfigs _ [] = return Nothing +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 - $ handleCPException - $ Just <$> TM.loadConfig p - --tryLoadConfig p = Just <$> TM.loadConfig p - handleCPException :: IO (Maybe a) -> IO (Maybe a) - handleCPException f = do - 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 + tryLoadConfig p = do + eConf <- TM.loadConfig homedir p + case eConf of + Right conf -> return $ Just conf + Left (C.ParseError msg) -> Nothing <$ putStrLn msg + Left _ -> 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)) - tryLoadCustomizations p t = handleOpenFileExceptions - $ Just <$> B.loadCustomizations p t - handleOpenFileExceptions :: IO (Maybe a) -> IO (Maybe a) + handleOpenFileExceptions :: IO 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") diff --git a/src/TaskMachine/Config.hs b/src/TaskMachine/Config.hs index d97fe0b..c6b59cd 100644 --- a/src/TaskMachine/Config.hs +++ b/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 +import qualified Data.ConfigFile as C + +type HomeDir = FilePath data Config = Config { cThemes :: [FilePath] , cTaskDB :: FilePath } -defaultConfig :: Config -defaultConfig = Config +defaultConfig :: HomeDir -> 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 - deriving (Show) - -instance Exception CPException - -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 +loadConfig :: HomeDir -> FilePath -> IO (Either C.CPErrorData Config) +loadConfig homedir path = do + ecp <- C.readfile C.emptyCP path + case ecp of + Left (e, _) -> return $ Left e Right cp -> - let myThemes = fromRight (cThemes defaultConfig) $ C.get cp "DEFAULT" "themes" - myTaskDB = fromRight (cTaskDB defaultConfig) $ C.get cp "DEFAULT" "taskdb" - in return Config + let config = defaultConfig homedir + myThemes = fromRight (cThemes config) $ C.get cp "DEFAULT" "themes" + 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 ()