module Termonad.PreferencesFile where
import Termonad.Prelude
import Control.Monad.Trans.Except (ExceptT(..), runExceptT, throwE, withExceptT)
import Data.Aeson (Result(..), fromJSON)
import qualified Data.HashMap.Strict as HashMap
import Data.Yaml (ParseException, ToJSON (toJSON), decodeFileEither, encode, prettyPrintParseException)
import Data.Yaml.Aeson (Value(..))
import System.Directory
( XdgDirectory(XdgConfig)
, createDirectoryIfMissing
, doesFileExist
, getXdgDirectory
)
import Termonad.Types
( ConfigOptions
, TMConfig(TMConfig, hooks, options)
, defaultConfigHooks
, defaultConfigOptions
)
getPreferencesFile :: IO FilePath
getPreferencesFile :: IO FilePath
getPreferencesFile = do
FilePath
confDir <- XdgDirectory -> FilePath -> IO FilePath
getXdgDirectory XdgDirectory
XdgConfig FilePath
"termonad"
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
confDir
FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
confDir FilePath -> FilePath -> FilePath
</> FilePath
"termonad.yaml"
tmConfigFromPreferencesFile :: IO TMConfig
tmConfigFromPreferencesFile :: IO TMConfig
tmConfigFromPreferencesFile = do
FilePath
confFile <- IO FilePath
getPreferencesFile
Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
confFile
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ConfigOptions -> IO ()
writePreferencesFile FilePath
confFile ConfigOptions
defaultConfigOptions
Either Text ConfigOptions
eitherOptions <- FilePath -> IO (Either Text ConfigOptions)
readFileWithDefaults FilePath
confFile
ConfigOptions
options <-
case Either Text ConfigOptions
eitherOptions of
Left Text
err -> do
Handle -> Text -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> Text -> m ()
hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Error parsing file " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Element Text] -> Text
forall seq. IsSequence seq => [Element seq] -> seq
pack FilePath
[Element Text]
confFile Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
ConfigOptions -> IO ConfigOptions
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConfigOptions
defaultConfigOptions
Right ConfigOptions
options -> ConfigOptions -> IO ConfigOptions
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConfigOptions
options
TMConfig -> IO TMConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure TMConfig :: ConfigOptions -> ConfigHooks -> TMConfig
TMConfig { options :: ConfigOptions
options = ConfigOptions
options, hooks :: ConfigHooks
hooks = ConfigHooks
defaultConfigHooks }
readFileWithDefaults :: FilePath -> IO (Either Text ConfigOptions)
readFileWithDefaults :: FilePath -> IO (Either Text ConfigOptions)
readFileWithDefaults FilePath
file = ExceptT Text IO ConfigOptions -> IO (Either Text ConfigOptions)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO ConfigOptions -> IO (Either Text ConfigOptions))
-> ExceptT Text IO ConfigOptions -> IO (Either Text ConfigOptions)
forall a b. (a -> b) -> a -> b
$ do
Value
optsFromFile :: Value <-
(ParseException -> Text)
-> ExceptT ParseException IO Value -> ExceptT Text IO Value
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ParseException -> Text
parseExceptionToText (ExceptT ParseException IO Value -> ExceptT Text IO Value)
-> (IO (Either ParseException Value)
-> ExceptT ParseException IO Value)
-> IO (Either ParseException Value)
-> ExceptT Text IO Value
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. IO (Either ParseException Value) -> ExceptT ParseException IO Value
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ParseException Value) -> ExceptT Text IO Value)
-> IO (Either ParseException Value) -> ExceptT Text IO Value
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Either ParseException Value)
forall a. FromJSON a => FilePath -> IO (Either ParseException a)
decodeFileEither FilePath
file
let Value
optsDefault :: Value = ConfigOptions -> Value
forall a. ToJSON a => a -> Value
toJSON (ConfigOptions -> Value) -> ConfigOptions -> Value
forall a b. (a -> b) -> a -> b
$ ConfigOptions
defaultConfigOptions
Result ConfigOptions -> ExceptT Text IO ConfigOptions
forall a. Result a -> ExceptT Text IO a
resultToExcept (Result ConfigOptions -> ExceptT Text IO ConfigOptions)
-> (Value -> Result ConfigOptions)
-> Value
-> ExceptT Text IO ConfigOptions
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Value -> Result ConfigOptions
forall a. FromJSON a => Value -> Result a
fromJSON (Value -> ExceptT Text IO ConfigOptions)
-> Value -> ExceptT Text IO ConfigOptions
forall a b. (a -> b) -> a -> b
$ Value -> Value -> Value
mergeObjVals Value
optsFromFile Value
optsDefault
where
parseExceptionToText :: ParseException -> Text
parseExceptionToText :: ParseException -> Text
parseExceptionToText = FilePath -> Text
forall seq. IsSequence seq => [Element seq] -> seq
pack (FilePath -> Text)
-> (ParseException -> FilePath) -> ParseException -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ParseException -> FilePath
prettyPrintParseException
resultToExcept :: Result a -> ExceptT Text IO a
resultToExcept :: Result a -> ExceptT Text IO a
resultToExcept (Success a
v) = a -> ExceptT Text IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v
resultToExcept (Error FilePath
str) = Text -> ExceptT Text IO a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ([Element Text] -> Text
forall seq. IsSequence seq => [Element seq] -> seq
pack FilePath
[Element Text]
str)
mergeObjVals
:: Value
-> Value
-> Value
mergeObjVals :: Value -> Value -> Value
mergeObjVals Value
optsFromFile Value
optsDefault =
case (Value
optsFromFile, Value
optsDefault) of
(Object Object
optsFromFileHashMap, Object Object
optsDefaultHashMap) ->
Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ (Value -> Value -> Value) -> Object -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
HashMap.unionWith Value -> Value -> Value
mergeObjVals Object
optsFromFileHashMap Object
optsDefaultHashMap
(Array Array
fromFile, Array Array
_) -> Array -> Value
Array Array
fromFile
(String Text
fromFile, String Text
_) -> Text -> Value
String Text
fromFile
(Number Scientific
fromFile, Number Scientific
_) -> Scientific -> Value
Number Scientific
fromFile
(Bool Bool
fromFile, Bool Bool
_) -> Bool -> Value
Bool Bool
fromFile
(Value
Null, Value
Null) -> Value
Null
(Value
_, Value
defVal) -> Value
defVal
writePreferencesFile :: FilePath -> ConfigOptions -> IO ()
writePreferencesFile :: FilePath -> ConfigOptions -> IO ()
writePreferencesFile FilePath
confFile ConfigOptions
options = do
let yaml :: ByteString
yaml = ConfigOptions -> ByteString
forall a. ToJSON a => a -> ByteString
encode ConfigOptions
options
yamlWithComment :: ByteString
yamlWithComment =
ByteString
"# DO NOT EDIT THIS FILE BY HAND!\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>
ByteString
"#\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>
ByteString
"# This file is generated automatically by the Preferences dialog\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>
ByteString
"# in Termonad. Please open the Preferences dialog if you wish to\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>
ByteString
"# modify this file.\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>
ByteString
"#\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>
ByteString
"# The settings in this file will be ignored if you have a\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>
ByteString
"# termonad.hs file in this same directory.\n\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>
ByteString
yaml
FilePath -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => FilePath -> ByteString -> m ()
writeFile FilePath
confFile ByteString
yamlWithComment
saveToPreferencesFile :: TMConfig -> IO ()
saveToPreferencesFile :: TMConfig -> IO ()
saveToPreferencesFile TMConfig { options :: TMConfig -> ConfigOptions
options = ConfigOptions
options } = do
FilePath
confFile <- IO FilePath
getPreferencesFile
FilePath -> ConfigOptions -> IO ()
writePreferencesFile FilePath
confFile ConfigOptions
options