File.hs

{-# LANGUAGE CPP #-}

-- | Description : Read and write to the Preferences file
-- Copyright     : (c) Dennis Gosnell, 2023
-- License       : BSD3
-- Stability     : experimental
-- Portability   : POSIX
--
-- This module contains functions for reading and writing to the preferences file.
--
-- The preferences file is generally stored in
-- @~/.config/termonad/termonad.yaml@.  It stores run-time preferences that
-- have been set through the Preferences dialog.  Preferences are loaded on
-- app startup, but only if the @termonad.hs@ configuration file doesn't exist.

module Termonad.Preferences.File 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.ByteString as ByteString
import qualified Data.HashMap.Strict as HashMap
import Data.Text (pack)
import Data.Yaml (ParseException, ToJSON (toJSON), decodeFileEither, encode, prettyPrintParseException)
import Data.Yaml.Aeson (Value(..))
import System.Directory
  ( XdgDirectory(XdgConfig)
  , createDirectoryIfMissing
  , doesFileExist
  , getXdgDirectory
  )
import System.FilePath ((</>))
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 = do
  -- Get the termonad config directory
  confDir <- getXdgDirectory XdgConfig "termonad"
  createDirectoryIfMissing True confDir
  pure $ confDir </> "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 = do
  confFile <- getPreferencesFile
  -- If there is no preferences file we create it with the default values
  exists <- doesFileExist confFile
  unless exists $ writePreferencesFile confFile defaultConfigOptions
  -- Read the configuration file
  eitherOptions <- readFileWithDefaults confFile
  options <-
    case eitherOptions of
      Left err -> do
        hPutStrLn stderr $ "Error parsing file " <> pack confFile <> ": " <> err
        pure defaultConfigOptions
      Right options -> pure options
  pure TMConfig { options = options, hooks = 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 file = runExceptT $ do
  -- Read the configuration file as a JSON object
  optsFromFile :: Value <-
    withExceptT parseExceptionToText . ExceptT $ decodeFileEither file
  let optsDefault :: Value = toJSON defaultConfigOptions
  -- Then merge it with the default options in JSON before converting it to
  -- a 'ConfigOptions'
  resultToExcept . fromJSON $ mergeObjVals optsFromFile optsDefault
  where
    parseExceptionToText :: ParseException -> Text
    parseExceptionToText = pack . prettyPrintParseException

    resultToExcept :: Result a -> ExceptT Text IO a
    resultToExcept (Success v) = pure v
    resultToExcept (Error str) = throwE (pack 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 optsFromFile optsDefault =
  case (optsFromFile, optsDefault) of
    -- Both the options from the file and the default options are an Object
    -- here.  Recursively merge the keys and values.
    (Object optsFromFileKeyMap, Object optsDefaultKeyMap) ->
      let
#if MIN_VERSION_aeson(2, 0, 0)
          hashMapFromKeyMap = KeyMap.toHashMap
          keyMapFromHashMap = KeyMap.fromHashMap
#else
          hashMapFromKeyMap = id
          keyMapFromHashMap = id
#endif
          optsFromFileHashMap = hashMapFromKeyMap optsFromFileKeyMap
          optsDefaultHashMap = hashMapFromKeyMap optsDefaultKeyMap
          optsResultHashMap = HashMap.unionWith mergeObjVals
                                optsFromFileHashMap
                                optsDefaultHashMap
          optsResultKeyMap = keyMapFromHashMap optsResultHashMap
      in 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 fromFile, Array _) -> Array fromFile
    (String fromFile, String _) -> String fromFile
    (Number fromFile, Number _) -> Number fromFile
    (Bool fromFile, Bool _) -> Bool fromFile
    (Null, Null) -> Null
    -- The value from the file and the default value are different types. Just
    -- use the default value.
    (_, defVal) -> defVal

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

-- | Save the configuration to the preferences file
-- @~\/.config\/termonad\/termonad.yaml@
saveToPreferencesFile :: TMConfig -> IO ()
saveToPreferencesFile TMConfig { options = options } = do
  confFile <- getPreferencesFile
  writePreferencesFile confFile options