{-# 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
  )

-- $setup
--
-- >>> import Data.Aeson(object, (.=))

-- | Get the path to the preferences file @~\/.config\/termonad\/termonad.yaml@.
getPreferencesFile :: IO FilePath
getPreferencesFile :: IO FilePath
getPreferencesFile = do
  -- Get the termonad config directory
  FilePath
confDir <- XdgDirectory -> FilePath -> IO FilePath
getXdgDirectory XdgDirectory
XdgConfig FilePath
"termonad"
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
confDir
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FilePath
confDir FilePath -> FilePath -> FilePath
</> FilePath
"termonad.yaml"

-- | Read the configuration for the preferences file
-- @~\/.config\/termonad\/termonad.yaml@. This file stores only the 'options' of
-- 'TMConfig' so 'hooks' are initialized with 'defaultConfigHooks'.  If the
-- file doesn't exist, create it with the default values.
--
-- Any options that do not exist will get initialized with values from
-- 'defaultConfigOptions'.
tmConfigFromPreferencesFile :: IO TMConfig
tmConfigFromPreferencesFile :: IO TMConfig
tmConfigFromPreferencesFile = do
  FilePath
confFile <- IO FilePath
getPreferencesFile
  -- If there is no preferences file we create it with the default values
  Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
confFile
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists forall a b. (a -> b) -> a -> b
$ FilePath -> ConfigOptions -> IO ()
writePreferencesFile FilePath
confFile ConfigOptions
defaultConfigOptions
  -- Read the configuration file
  Either Text ConfigOptions
eitherOptions <- FilePath -> IO (Either Text ConfigOptions)
readFileWithDefaults FilePath
confFile
  ConfigOptions
options <-
    case Either Text ConfigOptions
eitherOptions of
      Left Text
err -> do
        forall (m :: * -> *). MonadIO m => Handle -> Text -> m ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ Text
"Error parsing file " forall a. Semigroup a => a -> a -> a
<> forall seq. IsSequence seq => [Element seq] -> seq
pack FilePath
confFile forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
err
        forall (f :: * -> *) a. Applicative f => a -> f a
pure ConfigOptions
defaultConfigOptions
      Right ConfigOptions
options -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ConfigOptions
options
  forall (f :: * -> *) a. Applicative f => a -> f a
pure TMConfig { options :: ConfigOptions
options = ConfigOptions
options, hooks :: ConfigHooks
hooks = ConfigHooks
defaultConfigHooks }

-- | Read the 'ConfigOptions' out of a configuration file.
--
-- Merge the raw 'ConfigOptions' with 'defaultConfigOptions'.  This makes sure
-- that old versions of the configuration file will still be able to be read
-- even if new options are added to 'ConfigOptions' in new versions of
-- Termonad.
readFileWithDefaults :: FilePath -> IO (Either Text ConfigOptions)
readFileWithDefaults :: FilePath -> IO (Either Text ConfigOptions)
readFileWithDefaults FilePath
file = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
  -- Read the configuration file as a JSON object
  Value
optsFromFile :: Value <-
    forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ParseException -> Text
parseExceptionToText forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => FilePath -> IO (Either ParseException a)
decodeFileEither FilePath
file
  let Value
optsDefault :: Value = forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ ConfigOptions
defaultConfigOptions
  -- Then merge it with the default options in JSON before converting it to
  -- a 'ConfigOptions'
  forall a. Result a -> ExceptT Text IO a
resultToExcept forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. FromJSON a => Value -> Result a
fromJSON forall a b. (a -> b) -> a -> b
$ Value -> Value -> Value
mergeObjVals Value
optsFromFile Value
optsDefault
  where
    parseExceptionToText :: ParseException -> Text
    parseExceptionToText :: ParseException -> Text
parseExceptionToText = forall seq. IsSequence seq => [Element seq] -> seq
pack 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) = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v
    resultToExcept (Error FilePath
str) = forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (forall seq. IsSequence seq => [Element seq] -> seq
pack FilePath
str)

-- | Merge 'Value's recursively.
--
-- This merges 'Value's recursively in 'Object' values, taking values that
-- have been explicitly over the defaults.  The defaults are only used if
-- there is no value that has been explicitly set.
--
-- For 'Array', 'String', 'Number', 'Bool', and 'Null', take the first 'Value'
-- (the one that has been explicitly set in the user's config file):
--
-- >>> mergeObjVals (Array [Number 1, Number 2]) (Array [String "hello"])
-- Array [Number 1.0,Number 2.0]
-- >>> mergeObjVals (String "hello") (String "bye")
-- String "hello"
-- >>> mergeObjVals (Number 1) (Number 2)
-- Number 1.0
-- >>> mergeObjVals (Bool True) (Bool False)
-- Bool True
-- >>> mergeObjVals Null Null
-- Null
--
-- Note that 'Value's in 'Array's are not recursed into:
--
-- >>> let obj1 = object ["hello" .= Number 2]
-- >>> let obj2 = object ["hello" .= String "bye"]
-- >>> mergeObjVals (Array [obj1]) (Array [obj2])
-- Array [Object (fromList [("hello",Number 2.0)])]
--
-- 'Object's are recursed into.  Unique keys from both Maps will be used.
-- Keys that are in both Maps will be merged according to the rules above:
--
-- >>> let object1 = object ["hello" .= Number 1, "bye" .= Number 100]
-- >>> let object2 = object ["hello" .= Number 2, "goat" .= String "chicken"]
-- >>> mergeObjVals object1 object2
-- Object (fromList [("bye",Number 100.0),("goat",String "chicken"),("hello",Number 1.0)])
--
-- 'Value's of different types will use the second 'Value':
--
-- >>> mergeObjVals Null (String "bye")
-- String "bye"
-- >>> mergeObjVals (Bool True) (Number 2)
-- Number 2.0
-- >>> mergeObjVals (Object mempty) (Bool False)
-- Bool False
--
mergeObjVals
  :: Value
     -- ^ Value that has been set explicitly in the User's configuration
     -- file.
  -> Value
     -- ^ Default value that will be used if no explicitly set value.
  -> Value
     -- ^ Merged values.
mergeObjVals :: Value -> Value -> Value
mergeObjVals Value
optsFromFile Value
optsDefault =
  case (Value
optsFromFile, Value
optsDefault) of
    -- Both the options from the file and the default options are an Object
    -- here.  Recursively merge the keys and values.
    (Object Object
optsFromFileKeyMap, Object Object
optsDefaultKeyMap) ->
      let
#if MIN_VERSION_aeson(2, 0, 0)
          hashMapFromKeyMap :: KeyMap v -> HashMap Key v
hashMapFromKeyMap = forall v. KeyMap v -> HashMap Key v
KeyMap.toHashMap
          keyMapFromHashMap :: HashMap Key v -> KeyMap v
keyMapFromHashMap = forall v. HashMap Key v -> KeyMap v
KeyMap.fromHashMap
#else
          hashMapFromKeyMap = id
          keyMapFromHashMap = id
#endif
          optsFromFileHashMap :: HashMap Key Value
optsFromFileHashMap = forall v. KeyMap v -> HashMap Key v
hashMapFromKeyMap Object
optsFromFileKeyMap
          optsDefaultHashMap :: HashMap Key Value
optsDefaultHashMap = forall v. KeyMap v -> HashMap Key v
hashMapFromKeyMap Object
optsDefaultKeyMap
          optsResultHashMap :: HashMap Key Value
optsResultHashMap = 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 = forall v. HashMap Key v -> KeyMap v
keyMapFromHashMap HashMap Key Value
optsResultHashMap
      in Object -> Value
Object Object
optsResultKeyMap
    -- Both the value from the file and the default value are the same type.
    -- Use the value from the file.
    --
    -- XXX: This will end up causing readFileWithDefaults to fail if the value
    -- from the file is old and can no longer properly be decoded into a value
    -- expected by ConfigOptions.
    (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
    -- The value from the file and the default value are different types. Just
    -- use the default value.
    (Value
_, Value
defVal) -> Value
defVal

writePreferencesFile :: FilePath -> ConfigOptions -> IO ()
writePreferencesFile :: FilePath -> ConfigOptions -> IO ()
writePreferencesFile FilePath
confFile ConfigOptions
options = do
  let yaml :: ByteString
yaml = forall a. ToJSON a => a -> ByteString
encode ConfigOptions
options
      yamlWithComment :: ByteString
yamlWithComment =
        ByteString
"# DO NOT EDIT THIS FILE BY HAND!\n" forall a. Semigroup a => a -> a -> a
<>
        ByteString
"#\n" forall a. Semigroup a => a -> a -> a
<>
        ByteString
"# This file is generated automatically by the Preferences dialog\n" forall a. Semigroup a => a -> a -> a
<>
        ByteString
"# in Termonad.  Please open the Preferences dialog if you wish to\n" forall a. Semigroup a => a -> a -> a
<>
        ByteString
"# modify this file.\n" forall a. Semigroup a => a -> a -> a
<>
        ByteString
"#\n" forall a. Semigroup a => a -> a -> a
<>
        ByteString
"# The settings in this file will be ignored if you have a\n" forall a. Semigroup a => a -> a -> a
<>
        ByteString
"# termonad.hs file in this same directory.\n\n" forall a. Semigroup a => a -> a -> a
<>
        ByteString
yaml
  forall (m :: * -> *). MonadIO m => FilePath -> ByteString -> m ()
writeFile FilePath
confFile ByteString
yamlWithComment

-- | Save the configuration to the preferences file
-- @~\/.config\/termonad\/termonad.yaml@
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