{-# LANGUAGE CPP #-}
module Termonad.PreferencesFile where
import Termonad.Prelude
import Control.Monad.Trans.Except (ExceptT(..), runExceptT, throwE, withExceptT)
import Data.Aeson (Result(..), fromJSON)
#if MIN_VERSION_aeson(2, 0, 0)
import qualified Data.Aeson.KeyMap as KeyMap
#endif
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 :: forall a. 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
optsFromFileKeyMap, Object Object
optsDefaultKeyMap) ->
let
#if MIN_VERSION_aeson(2, 0, 0)
hashMapFromKeyMap :: KeyMap v -> HashMap Key v
hashMapFromKeyMap = KeyMap v -> HashMap Key v
forall v. KeyMap v -> HashMap Key v
KeyMap.toHashMap
keyMapFromHashMap :: HashMap Key v -> KeyMap v
keyMapFromHashMap = HashMap Key v -> KeyMap v
forall v. HashMap Key v -> KeyMap v
KeyMap.fromHashMap
#else
hashMapFromKeyMap = id
keyMapFromHashMap = id
#endif
optsFromFileHashMap :: HashMap Key Value
optsFromFileHashMap = Object -> HashMap Key Value
forall v. KeyMap v -> HashMap Key v
hashMapFromKeyMap Object
optsFromFileKeyMap
optsDefaultHashMap :: HashMap Key Value
optsDefaultHashMap = Object -> HashMap Key Value
forall v. KeyMap v -> HashMap Key v
hashMapFromKeyMap Object
optsDefaultKeyMap
optsResultHashMap :: HashMap Key Value
optsResultHashMap = (Value -> Value -> Value)
-> HashMap Key Value -> HashMap Key Value -> HashMap Key Value
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
HashMap Key Value
optsFromFileHashMap
HashMap Key Value
optsDefaultHashMap
optsResultKeyMap :: Object
optsResultKeyMap = HashMap Key Value -> Object
forall v. HashMap Key v -> KeyMap v
keyMapFromHashMap HashMap Key Value
optsResultHashMap
in Object -> Value
Object Object
optsResultKeyMap
(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