Simplify loading stuff and use home directory more
This commit is contained in:
Joscha
parent
bbe6cd830f
commit
51eb270431
2 changed files with 41 additions and 88 deletions
85
app/Main.hs
85
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")
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue