    {-# 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
      FilePath -> IO FilePath
    forall a. a -> IO a
    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 a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ConfigOptions
    defaultConfigOptions
          Right ConfigOptions
    options -> ConfigOptions -> IO ConfigOptions
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ConfigOptions
    options
      TMConfig -> IO TMConfig
    forall a. a -> IO a
    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 = 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 b c a. (b -> c) -> (a -> b) -> a -> c
    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 b c a. (b -> c) -> (a -> b) -> a -> c
    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
    [Element Text] -> Text
    forall seq. IsSequence seq => [Element seq] -> seq
    pack (FilePath -> Text)
    -> (ParseException -> FilePath) -> ParseException -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    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 a. 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 ["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 = 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 =>
    (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
        -- 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