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
  )

-- | 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
  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"

-- | 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
  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
  -- 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
        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 }

-- | 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 = 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
  -- Read the configuration file as a JSON object
  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
  -- Then merge it with the default options in JSON before converting it to
  -- a 'ConfigOptions'
  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)

-- | 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 $ HashMap.singleton "hello" (Number 2)
-- >>> let obj2 = Object $ HashMap.singleton "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 hash1 = HashMap.fromList [("hello", Number 1), ("bye", Number 100)]
-- >>> let hash2 = HashMap.fromList [("hello", Number 2), ("goat", String "chicken")]
-- >>> mergeObjVals (Object hash1) (Object hash2)
-- 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
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
    -- 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 = 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

-- | 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