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

A full example of using most of Dyre's major features is as follows:

>    -- DyreExample.hs --
>    module 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) <- restoreTextState $ State []
>        case errorMsg of
>             Nothing -> return ()
>             Just em -> putStrLn $ "Error: " ++ em
>        putStrLn message
>        mapM putStrLn . reverse $ buffer
>        putStr "> " >> hFlush stdout
>        input <- getLine
>        case input of
>             "exit" -> return ()
>             "quit" -> return ()
>             other  -> relaunchWithTextState (State $ other:buffer) Nothing
>
>    dyreExample = Dyre.wrapMain $ Dyre.defaultParams
>        { Dyre.projectName = "dyreExample"
>        , Dyre.realMain    = realMain
>        , Dyre.showError   = showError
>        }

Notice that all of the program logic is contained in the 'DyreExample'
module. The main module of the program is absolutely trivial, being
essentially just the default configuration for the program:

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

The user can then create a custom configuration file, which
overrides some or all of the default configuration:

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

When reading the above program, notice that the majority of the
code is simply *program logic*. Dyre is designed to intelligently
handle recompilation with a minimum of programmer work.

Some mention should be made of Dyre's defaults. The 'defaultParams'
structure used in the example defines reasonable default values for
most configuration items. The three elements defined above are the
only elements that must be overridden. For documentation of the
parameters, consult the 'Config.Dyre.Params' module.

In the absence of any customization, Dyre will search for configuration
files in '$XDG_CONFIG_HOME/<appName>/<appName>.hs', and will store
cache files in '$XDG_CACHE_HOME/<appName>/' directory. The module
'System.Environment.XDG' is used for this purpose, which also provides
analogous behaviour on Windows.

The above example can be tested by running Main.hs with 'runhaskell',
and will detect custom configurations and recompile correctly even when
the library isn't installed, so long as it is in the current directory
when run.
-}
module Config.Dyre ( wrapMain, Params(..), defaultParams ) where

import System.IO           ( hPutStrLn, stderr )
import System.Directory    ( doesFileExist, removeFile, canonicalizePath
                           , getDirectoryContents, doesDirectoryExist )
import System.FilePath     ( (</>) )
import System.Environment  (getArgs)
import GHC.Environment     (getFullArgs)
import Control.Exception   (assert)

import Control.Monad       ( when, filterM )

import Config.Dyre.Params  ( Params(..), RTSOptionHandling(..) )
import Config.Dyre.Compile ( customCompile, getErrorPath, getErrorString )
import Config.Dyre.Compat  ( customExec )
import Config.Dyre.Options ( getForceReconf, getDenyReconf, getDebug
                           , withDyreOptions )
import Config.Dyre.Paths   ( getPaths, maybeModTime )

-- | A set of reasonable defaults for configuring Dyre. The fields that
--   have to be filled are 'projectName', 'realMain', and 'showError'.
defaultParams :: Params cfgType
defaultParams :: Params cfgType
defaultParams = Params :: forall cfgType.
String
-> Bool
-> Maybe (IO String)
-> Maybe (IO String)
-> (cfgType -> IO ())
-> (cfgType -> String -> cfgType)
-> [String]
-> [String]
-> Bool
-> (String -> IO ())
-> RTSOptionHandling
-> Bool
-> Params cfgType
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 ()
realMain     = cfgType -> IO ()
forall a. HasCallStack => a
undefined
    , showError :: cfgType -> String -> cfgType
showError    = cfgType -> String -> cfgType
forall a. HasCallStack => a
undefined
    , 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
    }

-- | 'wrapMain' is how Dyre recieves 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 :: Params cfgType -> cfgType -> IO ()
wrapMain :: Params cfgType -> cfgType -> IO ()
wrapMain params :: Params cfgType
params@Params{projectName :: forall cfgType. Params cfgType -> String
projectName = String
pName} cfg :: cfgType
cfg = Params cfgType -> IO () -> IO ()
forall c a. Params c -> IO a -> IO a
withDyreOptions Params cfgType
params (IO () -> IO ()) -> IO () -> IO ()
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 -> Bool
forall cfgType. Params cfgType -> Bool
configCheck Params cfgType
params
       then Params cfgType -> cfgType -> IO ()
forall cfgType. Params cfgType -> cfgType -> IO ()
realMain Params cfgType
params cfgType
cfg
       else do
        -- Get the important paths
        (thisBinary :: String
thisBinary,tempBinary :: String
tempBinary,configFile :: String
configFile,cacheDir :: String
cacheDir,libsDir :: String
libsDir) <- Params cfgType -> IO (String, String, String, String, String)
forall c. Params c -> IO (String, String, String, String, String)
getPaths Params cfgType
params
        [String]
libFiles <- String -> IO [String]
recFiles String
libsDir
        [Maybe UTCTime]
libTimes <- (String -> IO (Maybe UTCTime)) -> [String] -> IO [Maybe UTCTime]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO (Maybe UTCTime)
maybeModTime [String]
libFiles

        -- Check their modification times
        Maybe UTCTime
thisTime <- String -> IO (Maybe UTCTime)
maybeModTime String
thisBinary
        Maybe UTCTime
tempTime <- String -> IO (Maybe UTCTime)
maybeModTime String
tempBinary
        Maybe UTCTime
confTime <- String -> IO (Maybe UTCTime)
maybeModTime String
configFile
        let confExists :: Bool
confExists = Maybe UTCTime
confTime Maybe UTCTime -> Maybe UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe UTCTime
forall a. Maybe a
Nothing

        Bool
denyReconf  <- IO Bool
getDenyReconf
        Bool
forceReconf <- IO Bool
getForceReconf
        -- Either the user or timestamps indicate we need to recompile
        let needReconf :: Bool
needReconf = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Maybe UTCTime
tempTime Maybe UTCTime -> Maybe UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< Maybe UTCTime
confTime
                            , Maybe UTCTime
tempTime Maybe UTCTime -> Maybe UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< Maybe UTCTime
thisTime
                            , [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool)
-> ([Maybe UTCTime] -> [Bool]) -> [Maybe UTCTime] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe UTCTime -> Bool) -> [Maybe UTCTime] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe UTCTime
tempTime Maybe UTCTime -> Maybe UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
<) ([Maybe UTCTime] -> Bool) -> [Maybe UTCTime] -> Bool
forall a b. (a -> b) -> a -> b
$ [Maybe UTCTime]
libTimes
                            , Bool
forceReconf
                            ]

        -- If we're allowed to reconfigure, a configuration exists, and
        -- we detect a need to recompile it, then go ahead and compile.
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
denyReconf Bool -> Bool -> Bool
&& Bool
confExists Bool -> Bool -> Bool
&& Bool
needReconf)
             (Params cfgType -> IO ()
forall cfgType. Params cfgType -> IO ()
customCompile Params cfgType
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 -> IO (Maybe String)
forall cfgType. Params cfgType -> IO (Maybe String)
getErrorString Params cfgType
params
        Bool
customExists <- String -> IO Bool
doesFileExist String
tempBinary

        if Bool
confExists Bool -> Bool -> Bool
&& Bool
customExists
           then 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 ()
forall a. Maybe a -> String -> IO ()
launchSub Maybe String
errorData String
tempBinary
                  else Maybe String -> IO ()
enterMain Maybe String
errorData
           else Maybe String -> IO ()
enterMain Maybe String
errorData
  where launchSub :: Maybe a -> String -> IO ()
launchSub errorData :: Maybe a
errorData tempBinary :: String
tempBinary = do
            Params cfgType -> String -> IO ()
forall cfgType. Params cfgType -> String -> IO ()
statusOut Params cfgType
params (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Launching custom binary " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tempBinary String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n"
            [String]
givenArgs <- RTSOptionHandling -> IO [String]
handleRTSOptions (RTSOptionHandling -> IO [String])
-> RTSOptionHandling -> IO [String]
forall a b. (a -> b) -> a -> b
$ Params cfgType -> RTSOptionHandling
forall cfgType. Params cfgType -> RTSOptionHandling
rtsOptsHandling Params cfgType
params
            -- Deny reconfiguration if a compile already failed.
            let arguments :: [String]
arguments = case Maybe a
errorData of
                              Nothing -> [String]
givenArgs
                              Just _  -> "--deny-reconf"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
givenArgs
            -- Execute
            String -> Maybe [String] -> IO ()
customExec String
tempBinary (Maybe [String] -> IO ()) -> Maybe [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> Maybe [String]
forall a. a -> Maybe a
Just [String]
arguments
        enterMain :: Maybe String -> IO ()
enterMain errorData :: Maybe String
errorData = do
            -- Show the error data if necessary
            let mainConfig :: cfgType
mainConfig = case Maybe String
errorData of
                                  Nothing -> cfgType
cfg
                                  Just ed -> Params cfgType -> cfgType -> String -> cfgType
forall cfgType. Params cfgType -> cfgType -> String -> cfgType
showError Params cfgType
params cfgType
cfg String
ed
            -- Enter the main program
            Params cfgType -> cfgType -> IO ()
forall cfgType. Params cfgType -> cfgType -> IO ()
realMain Params cfgType
params cfgType
mainConfig

recFiles :: FilePath -> IO [FilePath]
recFiles :: String -> IO [String]
recFiles d :: String
d = do
    Bool
exists <- String -> IO Bool
doesDirectoryExist String
d
    if Bool
exists
       then do
           [String]
nodes <- String -> IO [String]
getDirectoryContents String
d
           let nodes' :: [String]
nodes' = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
d String -> String -> String
</>) ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [".", ".."]) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String]
nodes
           [String]
files <- (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesFileExist [String]
nodes'
           [String]
dirs  <- (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesDirectoryExist [String]
nodes'
           [String]
subfiles <- [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (String -> IO [String]) -> [String] -> IO [[String]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO [String]
recFiles [String]
dirs
           [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ [String]
files [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
subfiles
       else [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []

assertM :: Bool -> m ()
assertM b :: Bool
b = Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert Bool
b (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Filters GHC runtime system arguments:
filterRTSArgs :: [String] -> [String]
filterRTSArgs = Bool -> [String] -> [String]
filt Bool
False
  where
    filt :: Bool -> [String] -> [String]
filt _     []             = []
    filt _     ("--RTS":rest :: [String]
rest) = []
    filt False ("+RTS" :rest :: [String]
rest) = Bool -> [String] -> [String]
filt Bool
True  [String]
rest
    filt True  ("-RTS" :rest :: [String]
rest) = Bool -> [String] -> [String]
filt Bool
False [String]
rest
    filt False (_      :rest :: [String]
rest) = Bool -> [String] -> [String]
filt Bool
False [String]
rest
    filt True  (arg :: String
arg    :rest :: [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 opts :: [String]
opts (RTSReplace ls :: [String]
ls) = [String]
ls
editRTSOptions opts :: [String]
opts (RTSAppend ls :: [String]
ls)  = [String]
opts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ls

handleRTSOptions :: RTSOptionHandling -> IO [String]
handleRTSOptions h :: 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 (m :: * -> *). Monad m => Bool -> m ()
assertM (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ "--RTS" String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
rtsArgs
                        case [String]
rtsArgs of
                          [] -> if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ "+RTS" String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
args
                                  then [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
args -- cleaner output
                                  else [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ "--RTS"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
args
                          _  -> [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ ["+RTS"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
rtsArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ["--RTS"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
args