{- |
Dyre is a library for configuring your Haskell programs. Like Xmonad,
programs configured with Dyre will look for a configuration file written
in Haskell, which essentially defines a custom program configured exactly
as the user wishes it to be. And since the configuration is written in
Haskell, the user is free to do anything they might wish in the context
of configuring the program.

Dyre places emphasis on elegance of operation and ease of integration
with existing applications. The 'wrapMain' function is the sole entry
point for Dyre. When partially applied with a parameter structure, it
wraps around the 'realMain' value from that structure, yielding an almost
identical function which has been augmented with dynamic recompilation
functionality.

The "Config.Dyre.Relaunch" module provides the ability to restart the
program (recompiling if applicable), and persist state across restarts,
but it has no impact whatsoever on the rest of the library whether it
is used or not.

= Writing a program that uses Dyre

The following example program uses most of Dyre's major features:

@
-- DyreExample.hs --
module DyreExample
  ( Config(..)
  , defaultConfig
  , dyreExample
  )
where

import qualified "Config.Dyre" as Dyre
import "Config.Dyre.Relaunch"

import System.IO

data Config = Config { message :: String, errorMsg :: Maybe String }
data State  = State { bufferLines :: [String] } deriving (Read, Show)

defaultConfig :: Config
defaultConfig = Config "Dyre Example v0.1" Nothing

showError :: Config -> String -> Config
showError cfg msg = cfg { errorMsg = Just msg }

realMain Config{message = message, errorMsg = errorMsg } = do
    (State buffer) <- 'Config.Dyre.Relaunch.restoreTextState' $ State []
    case errorMsg of
         Nothing -> return ()
         Just em -> putStrLn $ "Error: " ++ em
    putStrLn message
    traverse putStrLn . reverse $ buffer
    putStr "> " *> hFlush stdout
    input <- getLine
    case input of
         "exit" -> return ()
         "quit" -> return ()
         other  -> 'Config.Dyre.Relaunch.relaunchWithTextState' (State $ other:buffer) Nothing

dyreExample = Dyre.'Config.Dyre.wrapMain' $ Dyre.'Config.Dyre.newParams' "dyreExample" realMain showError
@

All of the program logic is contained in the @DyreExample@ module.
The module exports the 'Config' data type, a @defaultConfig@, and
the @dyreExample@ function which, when applied to a 'Config',
returns an @(IO a)@ value to be used as @main@.

The @Main@ module of the program is trivial.  All that is required
is to apply @dyreExample@ to the default configuration:

@
-- Main.hs --
import DyreExample
main = dyreExample defaultConfig
@

= Custom program configuration

Users can create a custom configuration file that overrides some or
all of the default configuration:

@
-- ~\/.config\/dyreExample\/dyreExample.hs --
import DyreExample
main = dyreExample $ defaultConfig { message = "Dyre Example v0.1 (Modified)" }
@

When a program that uses Dyre starts, Dyre checks to see if a custom
configuration exists.  If so, it runs a custom executable.  Dyre
(re)compiles and caches the custom executable the first time it sees
the custom config or whenever the custom config has changed.

If a custom configuration grows large, you can extract parts of it
into one or more files under @lib/@.  For example:

@
-- ~\/.config\/dyreExample\/dyreExample.hs --
import DyreExample
import Message
main = dyreExample $ defaultConfig { message = Message.msg }
@

@
-- ~\/.config\/dyreExample\/lib/Message.hs --
module Message where
msg = "Dyre Example v0.1 (Modified)"
@

== Working with the Cabal store

For a Dyre-enabled program to work when installed via @cabal
install@, it needs to add its library directory as an extra include
directory for compilation.  The library /package name/ __must__
match the Dyre 'projectName' for this to work.  For example:

@
import Paths_dyreExample (getLibDir)

dyreExample cfg = do
  libdir <- getLibDir
  let params = (Dyre.'Config.Dyre.newParams' "dyreExample" realMain showError)
        { Dyre.'Config.Dyre.includeDirs' = [libdir] }
  Dyre.'Config.Dyre.wrapMain' params cfg
@

See also the Cabal
<https://cabal.readthedocs.io/en/3.2/developing-packages.html#accessing-data-files-from-package-code Paths_pkgname feature documentation>.

== Specifying the compiler

If the compiler that Dyre should use is not available as @ghc@, set
the @HC@ environment variable when running the main program:

@
export HC=\/opt\/ghc\/$GHC_VERSION\/bin\/ghc
dyreExample  # Dyre will use $HC for recompilation
@


= Configuring Dyre

Program authors configure Dyre using the 'Params' type.  This type
controls Dyre's behaviour, not the main program logic (the example
uses the @Config@ type for that).

Use 'newParams' to construct a 'Params' value.  The three arguments are:

- /Application name/ (a @String@).  This affects the names of files and directories
  that Dyre uses for config, cache and logging.

- The /real main/ function of the program, which has type
  @(cfgType -> IO a)@.  @cfgType@ is the main program config type,
  and @a@ is usually @()@.

- The /show error/ function, which has type @(cfgType -> String ->
  cfgType)@.  If compiling the custom program fails, Dyre uses this
  function to set the compiler output in the main program's
  configuration.  The main program can then display the error string
  to the user, or handle it however the author sees fit.

The 'Params' type has several other fields for modifying Dyre's
behaviour.  'newParams' uses reasonable defaults, but behaviours you
can change include:

- Where to look for custom configuration ('configDir').  By default
  Dyre will look for @$XDG_CONFIG_HOME\/\<appName\>\/\<appName\>.hs@,

- Where to cache the custom executable and other files ('cacheDir').
  By default Dyre will use @$XDG_CACHE_HOME\/\<appName\>\/@.

- Extra options to pass to GHC when compiling the custom executable
  ('ghcOpts').  Default: none.

See 'Params' for descriptions of all the fields.

-}
module Config.Dyre
  (
    wrapMain
    , Params(..)
    , newParams
    , defaultParams
  ) where

import System.IO           ( hPutStrLn, stderr )
import System.Directory    ( doesFileExist, canonicalizePath )
import System.Environment  (getArgs)
import GHC.Environment     (getFullArgs)
import Control.Exception   (assert)

import Control.Monad       ( when )

import Config.Dyre.Params  ( Params(..), RTSOptionHandling(..) )
import Config.Dyre.Compile ( customCompile, getErrorString )
import Config.Dyre.Compat  ( customExec )
import Config.Dyre.Options ( getForceReconf, getDenyReconf
                           , withDyreOptions )
import Config.Dyre.Paths
  ( getPathsConfig, customExecutable, runningExecutable, configFile
  , checkFilesModified
  )

-- | A set of reasonable defaults for configuring Dyre. The fields that
--   have to be filled are 'projectName', 'realMain', and 'showError'
--   (because their initial value is @undefined@).
--
-- Deprecated in favour of 'newParams' which takes the required
-- fields as arguments.
--
defaultParams :: Params cfgType a
defaultParams :: Params cfgType a
defaultParams = Params :: forall cfgType a.
String
-> Bool
-> Maybe (IO String)
-> Maybe (IO String)
-> (cfgType -> IO a)
-> (cfgType -> String -> cfgType)
-> [String]
-> [String]
-> [String]
-> Bool
-> (String -> IO ())
-> RTSOptionHandling
-> Bool
-> Params cfgType a
Params
    { projectName :: String
projectName  = String
forall a. HasCallStack => a
undefined
    , configCheck :: Bool
configCheck  = Bool
True
    , configDir :: Maybe (IO String)
configDir    = Maybe (IO String)
forall a. Maybe a
Nothing
    , cacheDir :: Maybe (IO String)
cacheDir     = Maybe (IO String)
forall a. Maybe a
Nothing
    , realMain :: cfgType -> IO a
realMain     = cfgType -> IO a
forall a. HasCallStack => a
undefined
    , showError :: cfgType -> String -> cfgType
showError    = cfgType -> String -> cfgType
forall a. HasCallStack => a
undefined
    , includeDirs :: [String]
includeDirs  = []
    , hidePackages :: [String]
hidePackages = []
    , ghcOpts :: [String]
ghcOpts      = []
    , forceRecomp :: Bool
forceRecomp  = Bool
True
    , statusOut :: String -> IO ()
statusOut    = Handle -> String -> IO ()
hPutStrLn Handle
stderr
    , rtsOptsHandling :: RTSOptionHandling
rtsOptsHandling = [String] -> RTSOptionHandling
RTSAppend []
    , includeCurrentDirectory :: Bool
includeCurrentDirectory = Bool
True
    }
{-# DEPRECATED defaultParams "Use 'newParams' instead" #-}

-- | Construct a 'Params' with the required values as given, and
-- reasonable defaults for everything else.
--
newParams
  :: String                  -- ^ 'projectName'
  -> (cfg -> IO a)          -- ^ 'realMain' function
  -> (cfg -> String -> cfg)  -- ^ 'showError' function
  -> Params cfg a
newParams :: String -> (cfg -> IO a) -> (cfg -> String -> cfg) -> Params cfg a
newParams String
name cfg -> IO a
main cfg -> String -> cfg
err =
  Params Any Any
forall cfgType a. Params cfgType a
defaultParams { projectName :: String
projectName = String
name, realMain :: cfg -> IO a
realMain = cfg -> IO a
main, showError :: cfg -> String -> cfg
showError = cfg -> String -> cfg
err }

-- | @wrapMain@ is how Dyre receives control of the program. It is expected
--   that it will be partially applied with its parameters to yield a @main@
--   entry point, which will then be called by the @main@ function, as well
--   as by any custom configurations.
--
-- @wrapMain@ returns whatever value is returned by the @realMain@ function
-- in the @params@ (if it returns at all).  In the common case this is @()@
-- but you can use Dyre with any @IO@ action.
--
wrapMain :: Params cfgType a -> cfgType -> IO a
wrapMain :: Params cfgType a -> cfgType -> IO a
wrapMain Params cfgType a
params cfgType
cfg = Params cfgType a -> IO a -> IO a
forall c r a. Params c r -> IO a -> IO a
withDyreOptions Params cfgType a
params (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$
    -- Allow the 'configCheck' parameter to disable all of Dyre's recompilation
    -- checks, in favor of simply proceeding ahead to the 'realMain' function.
    if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Params cfgType a -> Bool
forall cfgType a. Params cfgType a -> Bool
configCheck Params cfgType a
params
       then Params cfgType a -> cfgType -> IO a
forall cfgType a. Params cfgType a -> cfgType -> IO a
realMain Params cfgType a
params cfgType
cfg
       else do
        -- Get the important paths
        PathsConfig
paths <- Params cfgType a -> IO PathsConfig
forall cfg a. Params cfg a -> IO PathsConfig
getPathsConfig Params cfgType a
params
        let tempBinary :: String
tempBinary = PathsConfig -> String
customExecutable PathsConfig
paths
            thisBinary :: String
thisBinary = PathsConfig -> String
runningExecutable PathsConfig
paths

        Bool
confExists <- String -> IO Bool
doesFileExist (PathsConfig -> String
configFile PathsConfig
paths)

        Bool
denyReconf  <- IO Bool
getDenyReconf
        Bool
forceReconf <- IO Bool
getForceReconf

        Bool
doReconf <- case (Bool
confExists, Bool
denyReconf, Bool
forceReconf) of
          (Bool
False, Bool
_, Bool
_) -> Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False  -- no config file
          (Bool
_, Bool
True, Bool
_)  -> Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False  -- deny overrules force
          (Bool
_, Bool
_, Bool
True)  -> Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True   -- avoid timestamp/hash checks
          (Bool
_, Bool
_, Bool
False) -> PathsConfig -> IO Bool
checkFilesModified PathsConfig
paths

        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
doReconf (Params cfgType a -> IO ()
forall cfgType a. Params cfgType a -> IO ()
customCompile Params cfgType a
params)

        -- If there's a custom binary and we're not it, run it. Otherwise
        -- just launch the main function, reporting errors if appropriate.
        -- Also we don't want to use a custom binary if the conf file is
        -- gone.
        Maybe String
errorData    <- Params cfgType a -> IO (Maybe String)
forall cfgType a. Params cfgType a -> IO (Maybe String)
getErrorString Params cfgType a
params
        Bool
customExists <- String -> IO Bool
doesFileExist String
tempBinary

        case (Bool
confExists, Bool
customExists) of
          (Bool
False, Bool
_) ->
            -- There is no custom config.  Ignore custom binary if present.
            -- Run main binary and ignore errors file.
            Maybe String -> IO a
enterMain Maybe String
forall a. Maybe a
Nothing
          (Bool
True, Bool
True) -> do
               -- Canonicalize the paths for comparison to avoid symlinks
               -- throwing us off. We do it here instead of earlier because
               -- canonicalizePath throws an exception when the file is
               -- nonexistent.
               String
thisBinary' <- String -> IO String
canonicalizePath String
thisBinary
               String
tempBinary' <- String -> IO String
canonicalizePath String
tempBinary
               if String
thisBinary' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
tempBinary'
                  then Maybe String -> String -> IO a
forall a b. Maybe a -> String -> IO b
launchSub Maybe String
errorData String
tempBinary
                  else Maybe String -> IO a
enterMain Maybe String
errorData
          (Bool
True, Bool
False) ->
            -- Config exists, but no custom binary.
            -- Looks like compile failed; run main binary with error data.
           Maybe String -> IO a
enterMain Maybe String
errorData
  where launchSub :: Maybe a -> String -> IO b
launchSub Maybe a
errorData String
tempBinary = do
            Params cfgType a -> String -> IO ()
forall cfgType a. Params cfgType a -> String -> IO ()
statusOut Params cfgType a
params (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Launching custom binary " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tempBinary String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
            [String]
givenArgs <- RTSOptionHandling -> IO [String]
handleRTSOptions (RTSOptionHandling -> IO [String])
-> RTSOptionHandling -> IO [String]
forall a b. (a -> b) -> a -> b
$ Params cfgType a -> RTSOptionHandling
forall cfgType a. Params cfgType a -> RTSOptionHandling
rtsOptsHandling Params cfgType a
params
            -- Deny reconfiguration if a compile already failed.
            let arguments :: [String]
arguments = case Maybe a
errorData of
                              Maybe a
Nothing -> [String]
givenArgs
                              Just _  -> String
"--deny-reconf"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
givenArgs
            -- Execute
            String -> Maybe [String] -> IO b
forall a. String -> Maybe [String] -> IO a
customExec String
tempBinary (Maybe [String] -> IO b) -> Maybe [String] -> IO b
forall a b. (a -> b) -> a -> b
$ [String] -> Maybe [String]
forall a. a -> Maybe a
Just [String]
arguments
        enterMain :: Maybe String -> IO a
enterMain Maybe String
errorData = do
            -- Show the error data if necessary
            let mainConfig :: cfgType
mainConfig = case Maybe String
errorData of
                                  Maybe String
Nothing -> cfgType
cfg
                                  Just ed -> Params cfgType a -> cfgType -> String -> cfgType
forall cfgType a. Params cfgType a -> cfgType -> String -> cfgType
showError Params cfgType a
params cfgType
cfg String
ed
            -- Enter the main program
            Params cfgType a -> cfgType -> IO a
forall cfgType a. Params cfgType a -> cfgType -> IO a
realMain Params cfgType a
params cfgType
mainConfig

assertM :: Applicative f => Bool -> f ()
assertM :: Bool -> f ()
assertM Bool
b = Bool -> f () -> f ()
forall a. HasCallStack => Bool -> a -> a
assert Bool
b (() -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- | Extract GHC runtime system arguments
filterRTSArgs :: [String] -> [String]
filterRTSArgs :: [String] -> [String]
filterRTSArgs = Bool -> [String] -> [String]
filt Bool
False
  where
    filt :: Bool -> [String] -> [String]
filt Bool
_     []             = []
    filt Bool
_     (String
"--RTS":[String]
_)    = []
    filt Bool
False (String
"+RTS" :[String]
rest) = Bool -> [String] -> [String]
filt Bool
True  [String]
rest
    filt Bool
True  (String
"-RTS" :[String]
rest) = Bool -> [String] -> [String]
filt Bool
False [String]
rest
    filt Bool
False (String
_      :[String]
rest) = Bool -> [String] -> [String]
filt Bool
False [String]
rest
    filt Bool
True  (String
arg    :[String]
rest) = String
argString -> [String] -> [String]
forall a. a -> [a] -> [a]
:Bool -> [String] -> [String]
filt Bool
True [String]
rest
    --filt state args           = error $ "Error filtering RTS arguments in state " ++ show state ++ " remaining arguments: " ++ show args

editRTSOptions :: [String] -> RTSOptionHandling -> [String]
editRTSOptions :: [String] -> RTSOptionHandling -> [String]
editRTSOptions [String]
_ (RTSReplace [String]
ls) = [String]
ls
editRTSOptions [String]
opts (RTSAppend [String]
ls)  = [String]
opts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ls

handleRTSOptions :: RTSOptionHandling -> IO [String]
handleRTSOptions :: RTSOptionHandling -> IO [String]
handleRTSOptions RTSOptionHandling
h = do [String]
fargs <- IO [String]
getFullArgs
                        [String]
args  <- IO [String]
getArgs
                        let rtsArgs :: [String]
rtsArgs = [String] -> RTSOptionHandling -> [String]
editRTSOptions ([String] -> [String]
filterRTSArgs [String]
fargs) RTSOptionHandling
h
                        Bool -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f ()
assertM (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"--RTS" String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
rtsArgs
                        [String] -> IO [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ case [String]
rtsArgs of
                          [] | String
"+RTS" String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
args -> String
"--RTS"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
args
                             | Bool
otherwise          -> [String]
args  -- cleaner output
                          [String]
_                       -> String
"+RTS" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
rtsArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String
"--RTS" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
args