dyre 0.8.12 → 0.9.2
raw patch · 36 files changed
Files
- CHANGELOG.md +103/−0
- Config/Dyre.hs +228/−125
- Config/Dyre/Compat.hs +38/−26
- Config/Dyre/Compile.hs +120/−36
- Config/Dyre/Options.hs +26/−27
- Config/Dyre/Params.hs +14/−5
- Config/Dyre/Paths.hs +89/−14
- Config/Dyre/Relaunch.hs +13/−11
- Tests/allTests.sh +10/−3
- Tests/basic/BasicTest.hs +0/−28
- Tests/basic/Lib.hs +28/−0
- Tests/basic/Main.hs +1/−1
- Tests/basic/MyConfig-updated.hs +4/−0
- Tests/basic/MyConfig.hs +4/−0
- Tests/basic/badConfig.hs +1/−1
- Tests/basic/goodConfig.hs +1/−1
- Tests/basic/moduleConfig.hs +3/−0
- Tests/basic/runTest.sh +28/−11
- Tests/config-check/ConfigCheckTest.hs +0/−19
- Tests/config-check/Lib.hs +19/−0
- Tests/config-check/Main.hs +1/−1
- Tests/config-check/configCheckTestA.hs +1/−1
- Tests/config-check/configCheckTestB.hs +1/−1
- Tests/config-check/runTest.sh +4/−11
- Tests/recompile-relaunch/Lib.hs +18/−0
- Tests/recompile-relaunch/Main.hs +1/−1
- Tests/recompile-relaunch/RecompileRelaunchTest.hs +0/−18
- Tests/recompile-relaunch/recompileRelaunchTest.hs +1/−1
- Tests/recompile-relaunch/runTest.sh +4/−11
- Tests/subr.sh +14/−0
- Tests/threaded/Lib.hs +11/−0
- Tests/threaded/Main.hs +4/−0
- Tests/threaded/runTest.sh +19/−0
- Tests/threaded/threadedTest.hs +4/−0
- dyre.cabal +36/−11
- test/Main.hs +7/−0
+ CHANGELOG.md view
@@ -0,0 +1,103 @@+# 0.9.2++- Support Cabal store in `$XDG_STATE_HOME/cabal/store`, which is the+ default location since cabal-install v3.10.++- Fix Cabal store package-db detection when package name contains+ hyphen characters.++- Recognise `NIX_GHC` environment variable for better support of Nix+ environments. `HC`, if set, takes precedence.++# 0.9.1++- Tell GHC about the Cabal store package DB via the `-package-db`+ option. This fixes compilation with Cabal store-based+ executables.++# 0.9.0++- `realMain` can now **return arbitrary types**. To support this+ change, `Params` got a new type variable.++ ```haskell+ -- before+ data Params cfgType+ wrapMain :: Params cfgType -> cfgType -> IO ()++ -- after+ data Params cfgType a+ wrapMain :: Params cfgType a -> cfgType -> IO a+ ```++- `defaultParams`, which contains `undefined` fields, has been+ **deprecated** in favour of the new function `newParams`:++ ```haskell+ -- here be bottoms+ defaultParams :: Params cfg a++ -- celestial music playing+ newParams+ :: String -- ^ 'projectName'+ -> (cfg -> IO a) -- ^ 'realMain' function+ -> (cfg -> String -> cfg) -- ^ 'showError' function+ -> Params cfg a+ ```++ `newParams` takes values for the three required fields, so program+ authors can clearly see what they have to do and are less likely+ to make a mistake.++- **Cabal store support**: Users can add extra include dirs via the+ `includeDirs` field of `Params`. The program author just has to+ put the package's library directory in the new `includeDirs`+ field:++ ```haskell+ import Config.Dyre+ import Paths_myapp (getLibDir)++ realMain = …+ showError = …++ myapp cfg = do+ libdir <- getLibDir+ let params = (newParams "myapp" realMain showError)+ { includeDirs = [libdir] }+ wrapMain params cfg+ ```++ If an include dir appears to be in a Cabal store and matches the+ `projectName`, Dyre adds the corresponding `-package-id` option.+ As a result, recompilation works for programs installed via `cabal+ install`.++- **Stack support**: if Dyre detects a `stack.yaml` alongside the+ custom configuration, it will use Stack to compile the program.+ Credit to *Jaro Reinders* for this feature.++- Dyre compiles the custom executable with **`-threaded`** when the+ main executable uses the threaded RTS. This means one less thing+ for program authors to remember (or forget) to do.++- Dyre now **requires GHC >= 7.10**.++- Improved **documentation**.++- The **test suite** was expanded, and can now be executed via+ `cabal test`.++- Dyre **cleans up** better after compilation (successful or+ unsuccesful), and behaves better when the custom configuration is+ removed.++- Some versions of GHC write to standard error, even during a+ successful compilation. Dyre no longer treats this as a+ compilation failure, instead relying solely on GHC's exit status.++- Dyre recognises the **`HC` environment variable**. If set, it+ will compile the program using the specified compiler.++- Fixes for **Windows**, including working with recent versions of+ the *process* package.
Config/Dyre.hs view
@@ -13,108 +13,203 @@ identical function which has been augmented with dynamic recompilation functionality. -The 'Config.Dyre.Relaunch' module provides the ability to restart the+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:+= Writing a program that uses Dyre -> -- 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-> }+The following example program uses most of Dyre's major features: -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:+@+-- DyreExample.hs --+module DyreExample+ ( Config(..)+ , defaultConfig+ , dyreExample+ )+where -> -- Main.hs ---> import DyreExample-> main = dyreExample defaultConfig+import qualified "Config.Dyre" as Dyre+import "Config.Dyre.Relaunch" -The user can then create a custom configuration file, which-overrides some or all of the default configuration:+import System.IO -> -- ~/.config/dyreExample/dyreExample.hs ---> import DyreExample-> main = dyreExample $ defaultConfig { message = "Dyre Example v0.1 (Modified)" }+data Config = Config { message :: String, errorMsg :: Maybe String }+data State = State { bufferLines :: [String] } deriving (Read, Show) -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.+defaultConfig :: Config+defaultConfig = Config "Dyre Example v0.1" Nothing -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.+showError :: Config -> String -> Config+showError cfg msg = cfg { errorMsg = Just msg } -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.+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 -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.+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(..), defaultParams ) where+module Config.Dyre+ (+ wrapMain+ , Params(..)+ , newParams+ , defaultParams+ ) where import System.IO ( hPutStrLn, stderr )-import System.Directory ( doesFileExist, removeFile, canonicalizePath- , getDirectoryContents, doesDirectoryExist )-import System.FilePath ( (</>) )+import System.Directory ( doesFileExist, canonicalizePath ) import System.Environment (getArgs) import GHC.Environment (getFullArgs) import Control.Exception (assert) -import Control.Monad ( when, filterM )+import Control.Monad ( when ) import Config.Dyre.Params ( Params(..), RTSOptionHandling(..) )-import Config.Dyre.Compile ( customCompile, getErrorPath, getErrorString )+import Config.Dyre.Compile ( customCompile, getErrorString ) import Config.Dyre.Compat ( customExec )-import Config.Dyre.Options ( getForceReconf, getDenyReconf, getDebug+import Config.Dyre.Options ( getForceReconf, getDenyReconf , withDyreOptions )-import Config.Dyre.Paths ( getPaths, maybeModTime )+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'.-defaultParams :: Params cfgType+-- 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 { projectName = undefined , configCheck = True@@ -122,6 +217,7 @@ , cacheDir = Nothing , realMain = undefined , showError = undefined+ , includeDirs = [] , hidePackages = [] , ghcOpts = [] , forceRecomp = True@@ -129,43 +225,53 @@ , rtsOptsHandling = RTSAppend [] , includeCurrentDirectory = True }+{-# DEPRECATED defaultParams "Use 'newParams' instead" #-} --- | '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+-- | 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 name main err =+ defaultParams { projectName = name, realMain = main, showError = 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 :: Params cfgType -> cfgType -> IO ()-wrapMain params@Params{projectName = pName} cfg = withDyreOptions params $+--+-- @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 cfg = withDyreOptions params $ -- Allow the 'configCheck' parameter to disable all of Dyre's recompilation -- checks, in favor of simply proceeding ahead to the 'realMain' function. if not $ configCheck params then realMain params cfg else do -- Get the important paths- (thisBinary,tempBinary,configFile,cacheDir,libsDir) <- getPaths params- libFiles <- recFiles libsDir- libTimes <- mapM maybeModTime libFiles+ paths <- getPathsConfig params+ let tempBinary = customExecutable paths+ thisBinary = runningExecutable paths - -- Check their modification times- thisTime <- maybeModTime thisBinary- tempTime <- maybeModTime tempBinary- confTime <- maybeModTime configFile- let confExists = confTime /= Nothing+ confExists <- doesFileExist (configFile paths) denyReconf <- getDenyReconf forceReconf <- getForceReconf- -- Either the user or timestamps indicate we need to recompile- let needReconf = or [ tempTime < confTime- , tempTime < thisTime- , or . map (tempTime <) $ libTimes- , forceReconf- ] - -- If we're allowed to reconfigure, a configuration exists, and- -- we detect a need to recompile it, then go ahead and compile.- when (not denyReconf && confExists && needReconf)- (customCompile params)+ doReconf <- case (confExists, denyReconf, forceReconf) of+ (False, _, _) -> pure False -- no config file+ (_, True, _) -> pure False -- deny overrules force+ (_, _, True) -> pure True -- avoid timestamp/hash checks+ (_, _, False) -> checkFilesModified paths + when doReconf (customCompile 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@@ -173,8 +279,12 @@ errorData <- getErrorString params customExists <- doesFileExist tempBinary - if confExists && customExists- then do+ case (confExists, customExists) of+ (False, _) ->+ -- There is no custom config. Ignore custom binary if present.+ -- Run main binary and ignore errors file.+ enterMain Nothing+ (True, 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@@ -184,7 +294,10 @@ if thisBinary' /= tempBinary' then launchSub errorData tempBinary else enterMain errorData- else enterMain errorData+ (True, False) ->+ -- Config exists, but no custom binary.+ -- Looks like compile failed; run main binary with error data.+ enterMain errorData where launchSub errorData tempBinary = do statusOut params $ "Launching custom binary " ++ tempBinary ++ "\n" givenArgs <- handleRTSOptions $ rtsOptsHandling params@@ -202,42 +315,32 @@ -- Enter the main program realMain params mainConfig -recFiles :: FilePath -> IO [FilePath]-recFiles d = do- exists <- doesDirectoryExist d- if exists- then do- nodes <- getDirectoryContents d- let nodes' = map (d </>) . filter (`notElem` [".", ".."]) $ nodes- files <- filterM doesFileExist nodes'- dirs <- filterM doesDirectoryExist nodes'- subfiles <- concat `fmap` mapM recFiles dirs- return $ files ++ subfiles- else return []--assertM b = assert b $ return ()+assertM :: Applicative f => Bool -> f ()+assertM b = assert b (pure ()) --- | Filters GHC runtime system arguments:+-- | Extract GHC runtime system arguments+filterRTSArgs :: [String] -> [String] filterRTSArgs = filt False where filt _ [] = []- filt _ ("--RTS":rest) = []+ filt _ ("--RTS":_) = [] filt False ("+RTS" :rest) = filt True rest filt True ("-RTS" :rest) = filt False rest filt False (_ :rest) = filt False rest filt True (arg :rest) = arg:filt True rest --filt state args = error $ "Error filtering RTS arguments in state " ++ show state ++ " remaining arguments: " ++ show args -editRTSOptions opts (RTSReplace ls) = ls+editRTSOptions :: [String] -> RTSOptionHandling -> [String]+editRTSOptions _ (RTSReplace ls) = ls editRTSOptions opts (RTSAppend ls) = opts ++ ls +handleRTSOptions :: RTSOptionHandling -> IO [String] handleRTSOptions h = do fargs <- getFullArgs args <- getArgs let rtsArgs = editRTSOptions (filterRTSArgs fargs) h- assertM $ not $ "--RTS" `elem` rtsArgs- case rtsArgs of- [] -> if not $ "+RTS" `elem` args- then return args -- cleaner output- else return $ "--RTS":args- _ -> return $ ["+RTS"] ++ rtsArgs ++ ["--RTS"] ++ args+ assertM $ "--RTS" `notElem` rtsArgs+ pure $ case rtsArgs of+ [] | "+RTS" `elem` args -> "--RTS":args+ | otherwise -> args -- cleaner output+ _ -> "+RTS" : rtsArgs ++ "--RTS" : args
Config/Dyre/Compat.hs view
@@ -1,6 +1,20 @@ {-# LANGUAGE CPP #-}++#if defined(mingw32_HOST_OS) || defined(__MINGW32__)+ {-# LANGUAGE ForeignFunctionInterface #-} +#if defined(i386_HOST_ARCH)+#define WINDOWS_CCONV stdcall+#elif defined(x86_64_HOST_ARCH)+#define WINDOWS_CCONV ccall+#else+#error Unknown mingw32 arch+#endif++#endif++ {- | Compatibility code for things that need to be done differently on different systems.@@ -20,7 +34,7 @@ -- This can be removed as soon as a 'getProcessID' function -- gets added to 'System.Win32'-foreign import stdcall unsafe "winbase.h GetCurrentProcessId"+foreign import WINDOWS_CCONV unsafe "winbase.h GetCurrentProcessId" c_GetCurrentProcessID :: IO DWORD getPIDString = fmap show c_GetCurrentProcessID @@ -30,42 +44,37 @@ -- is too braindead to provide an exec() system call for us -- to use, we simply create a new process that inherits -- the stdio handles.- (_,_,_,child) <- createProcess $ CreateProcess- { cmdspec = RawCommand binary args- , cwd = Nothing- , env = Nothing- , std_in = Inherit- , std_out = Inherit- , std_err = Inherit- , close_fds = True- , create_group = False- }+ (_,_,_,child) <- createProcess $ proc binary args+ -- Do some garbage collection in an optimistic attempt to -- offset some of the memory we waste here. performGC+ -- And to prevent terminal apps from losing IO, we have to -- sit around waiting for the child to exit.- exitCode <- waitForProcess child- case exitCode of- ExitSuccess -> c_ExitProcess 0- ExitFailure c -> c_ExitProcess (fromIntegral c)--foreign import stdcall unsafe "winbase.h ExitProcess"- c_ExitProcess :: UINT -> IO ()+ --+ -- 'exitWith' will flush stdout and stderr+ waitForProcess child >>= exitWith #else -import System.Posix.Process ( executeFile, getProcessID, exitImmediately- , forkProcess, getProcessStatus, ProcessStatus(..) )-import System.Posix.Signals ( raiseSignal, sigTSTP )-import System.Exit ( ExitCode(..) )--getPIDString = fmap show getProcessID+import System.Posix.Process ( executeFile, getProcessID ) #ifdef darwin_HOST_OS --- OSX+import System.Posix.Process+ ( exitImmediately , forkProcess, getProcessStatus, ProcessStatus(..) )+import System.Posix.Signals ( raiseSignal, sigTSTP )+import System.Exit ( ExitCode(ExitSuccess) ) +-- OSX. In a threaded process execv fails with ENOTSUP.+-- See http://uninformed.org/index.cgi?v=1&a=1&p=16. So it+-- is necessary to fork _then_ exec.+--+-- According to https://bugs.python.org/issue6800 this was+-- fixed in OS X 10.6. But I guess we'll leave the workaround+-- in place until there is a compelling reason to remove it.+ customExec binary mArgs = do args <- customOptions mArgs childPID <- forkProcess $ executeFile binary False args Nothing@@ -92,11 +101,14 @@ #endif +getPIDString = fmap show getProcessID+ #endif + -- | Called whenever execution needs to be transferred over to -- a different binary.-customExec :: FilePath -> Maybe [String] -> IO ()+customExec :: FilePath -> Maybe [String] -> IO a -- | What it says on the tin. Gets the current PID as a string. -- Used to determine the name for the state file during restarts.
Config/Dyre/Compile.hs view
@@ -4,27 +4,32 @@ -} module Config.Dyre.Compile ( customCompile, getErrorPath, getErrorString ) where -import System.IO ( openFile, hClose, IOMode(..) )+import Control.Applicative ((<|>))+import Control.Concurrent ( rtsSupportsBoundThreads )+import Control.Monad (when)+import Data.Maybe (fromMaybe)+import Data.List (intercalate)+import System.IO ( IOMode(WriteMode), withFile )+import System.Environment (lookupEnv) import System.Exit ( ExitCode(..) ) import System.Process ( runProcess, waitForProcess )-import System.FilePath ( (</>) )+import System.FilePath+ ( (</>), dropTrailingPathSeparator, joinPath, splitPath, takeDirectory ) import System.Directory ( getCurrentDirectory, doesFileExist- , createDirectoryIfMissing )-import Control.Exception ( bracket )-import GHC.Paths ( ghc )+ , createDirectoryIfMissing+ , renameFile, removeFile ) -import Config.Dyre.Paths ( getPaths )+import Config.Dyre.Paths ( PathsConfig(..), getPathsConfig, outputExecutable ) import Config.Dyre.Params ( Params(..) ) -- | Return the path to the error file.-getErrorPath :: Params cfgType -> IO FilePath-getErrorPath params = do- (_,_,_, cacheDir, _) <- getPaths params- return $ cacheDir </> "errors.log"+getErrorPath :: Params cfgType a -> IO FilePath+getErrorPath params =+ (</> "errors.log") . cacheDirectory <$> getPathsConfig params -- | If the error file exists and actually has some contents, return -- 'Just' the error string. Otherwise return 'Nothing'.-getErrorString :: Params cfgType -> IO (Maybe String)+getErrorString :: Params cfgType a -> IO (Maybe String) getErrorString params = do errorPath <- getErrorPath params errorsExist <- doesFileExist errorPath@@ -37,39 +42,118 @@ -- | Attempts to compile the configuration file. Will return a string -- containing any compiler output.-customCompile :: Params cfgType -> IO ()+customCompile :: Params cfgType a -> IO () customCompile params@Params{statusOut = output} = do- (thisBinary, tempBinary, configFile, cacheDir, libsDir) <- getPaths params- output $ "Configuration '" ++ configFile ++ "' changed. Recompiling."- createDirectoryIfMissing True cacheDir+ paths <- getPathsConfig params+ let+ tempBinary = customExecutable paths+ outFile = outputExecutable tempBinary+ configFile' = configFile paths+ cacheDir' = cacheDirectory paths+ libsDir = libsDirectory paths + output $ "Configuration '" ++ configFile' ++ "' changed. Recompiling."+ createDirectoryIfMissing True cacheDir'+ -- Compile occurs in here errFile <- getErrorPath params- result <- bracket (openFile errFile WriteMode) hClose $ \errHandle -> do- ghcOpts <- makeFlags params configFile tempBinary cacheDir libsDir- ghcProc <- runProcess ghc ghcOpts (Just cacheDir) Nothing- Nothing Nothing (Just errHandle)+ result <- withFile errFile WriteMode $ \errHandle -> do+ flags <- makeFlags params configFile' outFile cacheDir' libsDir+ stackYaml <- do+ let stackYamlPath = takeDirectory configFile' </> "stack.yaml"+ stackYamlExists <- doesFileExist stackYamlPath+ if stackYamlExists+ then return $ Just stackYamlPath+ else return Nothing++ hc' <- lookupEnv "HC"+ nix_ghc <- lookupEnv "NIX_GHC"+ let hc = fromMaybe "ghc" (hc' <|> nix_ghc)+ ghcProc <- maybe (runProcess hc flags (Just cacheDir') Nothing+ Nothing Nothing (Just errHandle))+ (\stackYaml' -> runProcess "stack" ("ghc" : "--stack-yaml" : stackYaml' : "--" : flags)+ Nothing Nothing Nothing Nothing (Just errHandle))+ stackYaml waitForProcess ghcProc - -- Display a helpful little status message- if result /= ExitSuccess- then output "Error occurred while loading configuration file."- else output "Program reconfiguration successful."+ case result of+ ExitSuccess -> do+ renameFile outFile tempBinary + -- GHC sometimes prints to stderr, even on success.+ -- Other parts of dyre infer error if error file exists+ -- and is non-empty, so remove it.+ removeFileIfExists errFile++ output "Program reconfiguration successful."++ _ -> do+ removeFileIfExists tempBinary+ output "Error occurred while loading configuration file."+ -- | Assemble the arguments to GHC so everything compiles right.-makeFlags :: Params cfgType -> FilePath -> FilePath -> FilePath+makeFlags :: Params cfgType a -> FilePath -> FilePath -> FilePath -> FilePath -> IO [String]-makeFlags Params{ghcOpts = flags, hidePackages = hides, forceRecomp = force, includeCurrentDirectory = includeCurDir}- cfgFile tmpFile cacheDir libsDir = do- currentDir <- getCurrentDirectory- return . concat $ [ ["-v0", "-i" ++ libsDir]- , if includeCurDir- then ["-i" ++ currentDir]- else [] - , ["-outputdir", cacheDir]- , prefix "-hide-package" hides, flags- , ["--make", cfgFile, "-o", tmpFile]- , ["-fforce-recomp" | force] -- Only if force is true- ]+makeFlags params cfgFile outFile cacheDir' libsDir = do+ currentDir <- getCurrentDirectory+ pure . concat $+ [ ["-v0", "-i" ++ libsDir]+ , ["-i" ++ currentDir | includeCurrentDirectory params]+ , prefix "-hide-package" (hidePackages params)++ -- add extra include dirs+ , fmap ("-i" ++) (includeDirs params)++ , includeDirs params >>= getCabalStoreGhcArgs (projectName params)++ , ghcOpts params++ -- if the current process uses threaded RTS,+ -- also compile custom executable with -threaded+ , [ "-threaded" | rtsSupportsBoundThreads ]++ , ["--make", cfgFile, "-outputdir", cacheDir', "-o", outFile]+ , ["-fforce-recomp" | forceRecomp params] -- Only if force is true+ ] where prefix y = concatMap $ \x -> [y,x] +-- | Given a path to lib dir, if it is a package in the Cabal+-- store that matches the projectName, return GHC arguments+-- to enable the Cabal store package database and expose the+-- application's library package.+--+getCabalStoreGhcArgs :: String -> FilePath -> [String]+getCabalStoreGhcArgs proj = mkArgs . go . fmap dropTrailingPathSeparator . splitPath+ where+ go :: [String] -> Maybe (String {- unit-id -}, [String] {- package-db -})+ go (dir : "store" : hc : unit : _)+ | dir `elem` [".cabal", "cabal" {- probably under $XDG_STATE_HOME -}]+ , pkgNameFromUnitId unit == Just proj+ = Just (unit, [dir, "store", hc, "package.db"])+ go (h : t@(_cabal : _store : _hc : _unit : _))+ = fmap (h:) <$> go t+ go _+ = Nothing++ mkArgs Nothing = []+ mkArgs (Just (unitId, pkgDb)) = ["-package-db", joinPath pkgDb, "-package-id", unitId]++-- | Extract package name from a unit-id, or return @Nothing@+-- if the input does not look like a unit-id.+--+pkgNameFromUnitId :: String -> Maybe String+pkgNameFromUnitId = fmap (intercalate "-") . go . splitOn '-'+ where+ go [s,_,_] = Just [s] -- drop the version and hash+ go (s:rest) = (s:) <$> go rest+ go [] = Nothing++splitOn :: (Eq a) => a -> [a] -> [[a]]+splitOn a l = case span (/= a) l of+ (h, []) -> [h]+ (h, _ : t) -> h : splitOn a t++removeFileIfExists :: FilePath -> IO ()+removeFileIfExists path = do+ exists <- doesFileExist path+ when exists $ removeFile path
Config/Dyre/Options.hs view
@@ -1,20 +1,22 @@-{-+{- |+ Handling for the command-line options that can be used to configure Dyre. As of the last count, there are four of them, and more are unlikely to be needed. The only one that a user should ever need to-use is the '--force-reconf' option, so the others all begin with-'--dyre-<option-name>'.+use is the @--force-reconf@ option, so the others all begin with+@--dyre-<option-name>@. At the start of the program, before anything else occurs, the 'withDyreOptions' function is used to hide Dyre's command-line-options. They are loaded into the IO monad using the module-'System.IO.Storage'. This keeps them safely out of the way of+options. They are loaded into the @IO@ monad using the module+"System.IO.Storage". This keeps them safely out of the way of the user code and our own. Later, when Dyre needs to access the options, it does so through the accessor functions defined here. When it comes time to pass control over to a new binary, it gets an argument list which preserves the important flags with a call to 'customOptions'.+ -} module Config.Dyre.Options ( removeDyreOptions@@ -28,7 +30,7 @@ ) where import Data.List (isPrefixOf)-import Data.Maybe (fromJust)+import Data.Maybe (fromMaybe) import System.IO.Storage (withStore, putValue, getValue, getDefaultValue) import System.Environment (getArgs, getProgName, withArgs) import System.Environment.Executable (getExecutablePath)@@ -43,7 +45,7 @@ -- | Store Dyre's command-line options to the IO-Store "dyre", -- and then execute the provided IO action with all Dyre's -- options removed from the command-line arguments.-withDyreOptions :: Params c -> IO a -> IO a+withDyreOptions :: Params c r -> IO a -> IO a withDyreOptions Params{configCheck = check} action = withStore "dyre" $ do -- Pretty important args <- getArgs@@ -65,33 +67,33 @@ -- We filter the arguments, so now Dyre's arguments 'vanish' withArgs (removeDyreOptions args) action --- | Get the value of the '--force-reconf' flag, which is used+-- | Get the value of the @--force-reconf@ flag, which is used -- to force a recompile of the custom configuration. getForceReconf :: IO Bool getForceReconf = getDefaultValue "dyre" "forceReconf" False --- | Get the value of the '--deny-reconf' flag, which disables+-- | Get the value of the @--deny-reconf@ flag, which disables -- recompilation. This overrides "--force-reconf", too. getDenyReconf :: IO Bool getDenyReconf = getDefaultValue "dyre" "denyReconf" False --- | Get the value of the '--dyre-debug' flag, which is used+-- | Get the value of the @--dyre-debug@ flag, which is used -- to debug a program without installation. Specifically,--- it forces the application to use './cache/' as the cache--- directory, and './' as the configuration directory.+-- it forces the application to use @./cache/@ as the cache+-- directory, and @./@ as the configuration directory. getDebug :: IO Bool getDebug = getDefaultValue "dyre" "debugMode" False -- | Get the path to the master binary. This is set to the path of--- the *current* binary unless the '--dyre-master-binary=' flag--- is set. Obviously, we pass the '--dyre-master-binary=' flag to+-- the /current/ binary unless the @--dyre-master-binary=@ flag+-- is set. Obviously, we pass the @--dyre-master-binary=@ flag to -- the custom configured application from the master binary. getMasterBinary :: IO (Maybe String) getMasterBinary = getValue "dyre" "masterBinary" -- | Get the path to a persistent state file. This is set only when--- the '--dyre-state-persist=' flag is passed to the program. It--- is used internally by 'Config.Dyre.Relaunch' to save and restore+-- the @--dyre-state-persist=@ flag is passed to the program. It+-- is used internally by "Config.Dyre.Relaunch" to save and restore -- state when relaunching the program. getStatePersist :: IO (Maybe String) getStatePersist = getValue "dyre" "persistState"@@ -106,18 +108,15 @@ masterPath <- getMasterBinary stateFile <- getStatePersist debugMode <- getDebug- mainArgs <- case otherArgs of- Nothing -> getArgs- Just oa -> return oa+ mainArgs <- maybe getArgs pure otherArgs+ -- Combine the other arguments with the Dyre-specific ones- let args = mainArgs ++ (filter (not . null) $- [ if debugMode then "--dyre-debug" else ""- , case stateFile of- Nothing -> ""- Just sf -> "--dyre-state-persist=" ++ sf- , "--dyre-master-binary=" ++ fromJust masterPath- ])- return args+ pure $ mainArgs ++ concat+ [ ["--dyre-debug" | debugMode]+ , ["--dyre-state-persist=" ++ sf | Just sf <- [stateFile]]+ , [ "--dyre-master-binary="+ ++ fromMaybe (error "'dyre' data-store doesn't exist (in Config.Dyre.Options.customOptions)") masterPath]+ ] -- | Look for the given flag in the argument array, and store -- its value under the given name if it exists.
Config/Dyre/Params.hs view
@@ -8,10 +8,10 @@ -- | This structure is how all kinds of useful data is fed into Dyre. Of -- course, only the 'projectName', 'realMain', and 'showError' fields -- are really necessary. By using the set of default values provided--- as 'Config.Dyre.defaultParams', you can get all the benefits of+-- as 'Config.Dyre.newParams', you can get all the benefits of -- using Dyre to configure your program in only five or six lines of -- code.-data Params cfgType = Params+data Params cfgType a = Params { projectName :: String -- ^ The name of the project. This needs to also be the name of -- the executable, and the name of the configuration file.@@ -24,7 +24,7 @@ , cacheDir :: Maybe (IO FilePath) -- ^ The directory to store build files in, including the final -- generated executable.- , realMain :: cfgType -> IO ()+ , realMain :: cfgType -> IO a -- ^ The main function of the program. When Dyre has completed -- all of its recompilation, it passes the configuration data -- to this function and gets out of the way.@@ -32,6 +32,10 @@ -- ^ This function is used to display error messages that occur -- during recompilation, by allowing the program to modify its -- initial configuration.+ , includeDirs :: [FilePath]+ -- ^ Optional extra include dirs to use during compilation.+ -- To support installation via cabal-install, include the+ -- path returned from @Paths_\<appName\>.getLibDir@. , hidePackages :: [String] -- ^ Packages that need to be hidden during compilation , ghcOpts :: [String]@@ -51,6 +55,11 @@ -- prevent name shadowing within project directory.) -- } -data RTSOptionHandling = RTSReplace [String] -- replaces RTS options with given list- | RTSAppend [String] -- merges given list with RTS options from command line (so that nothing is lost)++-- | Specify additional or replacement GHC runtime system options+data RTSOptionHandling+ = RTSReplace [String]+ -- ^ replaces RTS options with given list+ | RTSAppend [String]+ -- ^ merges given list with RTS options from command line (so that nothing is lost)
Config/Dyre/Paths.hs view
@@ -1,8 +1,22 @@+{- |++File paths of interest to Dyre, and related values.++-} module Config.Dyre.Paths where +import Control.Monad ( filterM )+import Data.List ( isSuffixOf ) import System.Info (os, arch)-import System.FilePath ( (</>), (<.>), takeExtension )-import System.Directory (getCurrentDirectory, doesFileExist, getModificationTime)+import System.FilePath+ ( (</>), (<.>), takeExtension, splitExtension )+import System.Directory+ ( doesDirectoryExist+ , doesFileExist+ , getCurrentDirectory+ , getDirectoryContents+ , getModificationTime+ ) import System.Environment.XDG.BaseDir (getUserCacheDir, getUserConfigDir) import System.Environment.Executable (getExecutablePath) import Data.Time@@ -10,33 +24,94 @@ import Config.Dyre.Params import Config.Dyre.Options --- | Return the paths to, respectively, the current binary, the custom++-- | Data type to make it harder to confuse which path is which.+data PathsConfig = PathsConfig+ { runningExecutable :: FilePath+ , customExecutable :: FilePath+ , configFile :: FilePath+ -- ^ Where Dyre looks for the custom configuration file.+ , libsDirectory :: FilePath+ -- ^ @<configDir>/libs@. This directory gets added to the GHC+ -- include path during compilation, so use configurations can be+ -- split up into modules. Changes to files under this directory+ -- trigger recompilation.+ , cacheDirectory :: FilePath+ -- ^ Where the custom executable, object and interface files, errors+ -- file and other metadata get stored.+ }++-- | Determine a file name for the compiler to write to, based on+-- the 'customExecutable' path.+--+outputExecutable :: FilePath -> FilePath+outputExecutable path =+ let (base, ext) = splitExtension path+ in base <.> "tmp" <.> ext++-- | Return a 'PathsConfig', which records the current binary, the custom -- binary, the config file, and the cache directory.-getPaths :: Params c -> IO (FilePath, FilePath, FilePath, FilePath, FilePath)+getPaths :: Params c r -> IO (FilePath, FilePath, FilePath, FilePath, FilePath) getPaths params@Params{projectName = pName} = do thisBinary <- getExecutablePath debugMode <- getDebug cwd <- getCurrentDirectory- cacheDir <- case (debugMode, cacheDir params) of+ cacheDir' <- case (debugMode, cacheDir params) of (True, _ ) -> return $ cwd </> "cache" (False, Nothing) -> getUserCacheDir pName (False, Just cd) -> cd- configDir <- case (debugMode, configDir params) of+ confDir <- case (debugMode, configDir params) of (True, _ ) -> return cwd (False, Nothing) -> getUserConfigDir pName (False, Just cd) -> cd- let tempBinary = cacheDir </> pName ++ "-" ++ os ++ "-" ++ arch- <.> takeExtension thisBinary- let configFile = configDir </> pName ++ ".hs"- let libsDir = configDir </> "lib"- return (thisBinary, tempBinary, configFile, cacheDir, libsDir)+ let+ tempBinary =+ cacheDir' </> pName ++ "-" ++ os ++ "-" ++ arch <.> takeExtension thisBinary+ configFile' = confDir </> pName ++ ".hs"+ libsDir = confDir </> "lib"+ pure (thisBinary, tempBinary, configFile', cacheDir', libsDir) +getPathsConfig :: Params cfg a -> IO PathsConfig+getPathsConfig params = do+ (cur, custom, conf, cache, libs) <- getPaths params+ pure $ PathsConfig cur custom conf libs cache+ -- | Check if a file exists. If it exists, return Just the modification -- time. If it doesn't exist, return Nothing.+maybeModTime :: FilePath -> IO (Maybe UTCTime) maybeModTime path = do fileExists <- doesFileExist path if fileExists- then fmap Just $ getModificationTime path+ then Just <$> getModificationTime path else return Nothing--- Removed type signature because it can't satisfy GHC 7.4 and 7.6 at once--- maybeModTime :: FilePath -> IO (Maybe UTCTime)++checkFilesModified :: PathsConfig -> IO Bool+checkFilesModified paths = do+ confTime <- maybeModTime (configFile paths)+ libFiles <- findHaskellFiles (libsDirectory paths)+ libTimes <- traverse maybeModTime libFiles+ thisTime <- maybeModTime (runningExecutable paths)+ tempTime <- maybeModTime (customExecutable paths)+ pure $+ tempTime < confTime -- config newer than custom bin+ || tempTime < thisTime -- main bin newer than custom bin+ || any (tempTime <) libTimes++-- | Recursively find Haskell files (@.hs@, @.lhs@) at the given+-- location.+findHaskellFiles :: FilePath -> IO [FilePath]+findHaskellFiles d = do+ exists <- doesDirectoryExist d+ if exists+ then do+ nodes <- getDirectoryContents d+ let nodes' = map (d </>) . filter (`notElem` [".", ".."]) $ nodes+ files <- filterM isHaskellFile nodes'+ dirs <- filterM doesDirectoryExist nodes'+ subfiles <- concat <$> traverse findHaskellFiles dirs+ pure $ files ++ subfiles+ else pure []+ where+ isHaskellFile f+ | any (`isSuffixOf` f) [".hs", ".lhs"] = doesFileExist f+ | otherwise = pure False
Config/Dyre/Relaunch.hs view
@@ -1,24 +1,26 @@ {-# LANGUAGE ScopedTypeVariables #-} -{--This is the only other module aside from 'Config.Dyre' which needs+{- |++This is the only other module aside from "Config.Dyre" which needs to be imported specially. It contains functions for restarting the program (which, usefully, will cause a recompile if the config has been changed), as well as saving and restoring state across said restarts. The impossibly simple function arguments are a consequence of a-little cheating we do using the 'System.IO.Storage' library. Of+little cheating we do using the "System.IO.Storage" library. Of course, we can't use the stored data unless something else put it there, so this module will probably explode horribly if used outside of a program whose recompilation is managed by Dyre. The functions for saving and loading state come in two variants: one which uses the 'Read' and 'Show' typeclasses, and one which-uses Data.Binary to serialize it. The 'Read' and 'Show' versions+uses "Data.Binary" to serialize it. The 'Read' and 'Show' versions are much easier to use thanks to automatic deriving, but the binary versions offer more control over saving and loading, as well as probably being a bit faster.+ -} module Config.Dyre.Relaunch ( relaunchMaster@@ -30,25 +32,25 @@ , restoreBinaryState ) where -import Data.Maybe ( fromMaybe, fromJust )+import Data.Maybe ( fromMaybe ) import System.IO ( writeFile, readFile ) import Data.Binary ( Binary, encodeFile, decodeFile ) import Control.Exception ( try, SomeException ) import System.FilePath ( (</>) )-import System.Directory ( getTemporaryDirectory, removeFile )+import System.Directory ( getTemporaryDirectory ) -import System.IO.Storage ( putValue, delValue )-import Config.Dyre.Options ( customOptions, getMasterBinary, getStatePersist )+import System.IO.Storage ( putValue )+import Config.Dyre.Options ( getMasterBinary, getStatePersist ) import Config.Dyre.Compat ( customExec, getPIDString ) -- | Just relaunch the master binary. We don't have any important--- state to worry about. (Or, like when 'relaunchWith<X>State' calls+-- state to worry about. (Or, like when @relaunchWith\<X\>State@ calls -- it, we're managing state on our own). It takes an argument which -- can optionally specify a new set of arguments. If it is given a--- value of 'Nothing', the current value of 'getArgs' will be used.+-- value of 'Nothing', the current value of 'System.Environment.getArgs' will be used. relaunchMaster :: Maybe [String] -> IO () relaunchMaster otherArgs = do- masterPath <- fmap fromJust getMasterBinary+ masterPath <- fmap (fromMaybe $ error "'dyre' data-store doesn't exist (in Config.Dyre.Relaunch.relaunchMaster)") getMasterBinary customExec masterPath otherArgs -- | Relaunch the master binary, but first preserve the program
Tests/allTests.sh view
@@ -2,11 +2,18 @@ # Run all test scripts for Dyre. +if [ -z "$HC" ]; then+ export HC=ghc+fi+ for TESTDIR in `find . -mindepth 1 -type d`; do+ echo "Running $TESTDIR" cd $TESTDIR- TEST_RESULT=`./runTest.sh`- if [ "$TEST_RESULT" != 'Passed' ]; then- echo "$TEST_RESULT in test $TESTDIR"+ TEST_RESULT=`sh ./runTest.sh 2>&1`+ TEST_STATUS=$?+ if [ "$TEST_STATUS" -ne 0 ]; then+ echo "$TESTDIR failed; output:"+ echo "$TEST_RESULT"; exit 1 fi cd ..
− Tests/basic/BasicTest.hs
@@ -1,28 +0,0 @@-module BasicTest where--import qualified Config.Dyre as Dyre--import Config.Dyre.Relaunch-import Control.Monad-import System.IO--data Config = Config { message :: String, errorMsg :: Maybe String }--defaultConfig :: Config-defaultConfig = Config "Basic Test Version 1.0" Nothing--showError :: Config -> String -> Config-showError cfg msg = cfg { errorMsg = Just msg }--realMain (Config message (Just err)) = putStrLn "Compile Error"-realMain (Config message Nothing) = do- state <- restoreTextState 1- when (state < 3) $ relaunchWithTextState (state + 1) Nothing- putStrLn $ message ++ " - " ++ show state--basicTest = Dyre.wrapMain $ Dyre.defaultParams- { Dyre.projectName = "basicTest"- , Dyre.realMain = realMain- , Dyre.showError = showError- , Dyre.statusOut = const . return $ ()- }
+ Tests/basic/Lib.hs view
@@ -0,0 +1,28 @@+module Lib where++import qualified Config.Dyre as Dyre++import Config.Dyre.Relaunch+import Control.Monad+import System.IO++data Config = Config { message :: String, errorMsg :: Maybe String }++defaultConfig :: Config+defaultConfig = Config "Basic Test Version 1.0" Nothing++showError :: Config -> String -> Config+showError cfg msg = cfg { errorMsg = Just msg }++realMain (Config message (Just err)) = putStrLn "Compile Error"+realMain (Config message Nothing) = do+ state <- restoreTextState 1+ when (state < 3) $ relaunchWithTextState (state + 1) Nothing+ putStrLn $ message ++ " - " ++ show state++basicTest = Dyre.wrapMain $ Dyre.defaultParams+ { Dyre.projectName = "basicTest"+ , Dyre.realMain = realMain+ , Dyre.showError = showError+ , Dyre.statusOut = const . return $ ()+ }
Tests/basic/Main.hs view
@@ -1,2 +1,2 @@-import BasicTest+import Lib main = basicTest defaultConfig
+ Tests/basic/MyConfig-updated.hs view
@@ -0,0 +1,4 @@+module MyConfig where++message :: String+message = "Modules are still great!"
+ Tests/basic/MyConfig.hs view
@@ -0,0 +1,4 @@+module MyConfig where++message :: String+message = "Modules are great!"
Tests/basic/badConfig.hs view
@@ -1,2 +1,2 @@-import BasicTest+import Lib main = basicTest $ defaultConfig { massage = "Basic Test Version 3.0" }
Tests/basic/goodConfig.hs view
@@ -1,2 +1,2 @@-import BasicTest+import Lib main = basicTest $ defaultConfig { message = "Basic Test Version 2.0" }
+ Tests/basic/moduleConfig.hs view
@@ -0,0 +1,3 @@+import Lib+import qualified MyConfig+main = basicTest $ defaultConfig { message = MyConfig.message }
Tests/basic/runTest.sh view
@@ -6,22 +6,16 @@ # Tests restarting a custom configuration. # Tests compilation error reporting. -# Assert the equality of two strings.-function assert() {- echo "$1" >&2- if [ "$1" != "$2" ]; then- echo "Failed test $3";- exit 1;- fi-}+. ../subr.sh ### SETUP ###-mkdir working+mkdir -p working cd working ### TEST A ###-cp ../BasicTest.hs ../Main.hs .-ghc --make Main.hs -o basic 2> /dev/null+cp ../Lib.hs ../Main.hs .+echo "attempting to make"+$HC --make Main.hs -o basic || die "compilation failed" OUTPUT_A=`./basic --dyre-debug` assert "$OUTPUT_A" "Basic Test Version 1.0 - 3" "A" @@ -35,6 +29,29 @@ cp ../badConfig.hs basicTest.hs OUTPUT_C=`./basic --dyre-debug` assert "$OUTPUT_C" "Compile Error" "C"++### TEST D ###+# Now test that removing the custom config results in+# successful run of non-custom binary.+rm basicTest.hs+OUTPUT_D=`./basic --dyre-debug`+assert "$OUTPUT_D" "Basic Test Version 1.0 - 3" "D"++### TEST E ###+# Test use of modules under "$confdir/lib/"+cp ../moduleConfig.hs basicTest.hs+mkdir lib+cp ../MyConfig.hs lib/MyConfig.hs+OUTPUT_E=`./basic --dyre-debug`+assert "$OUTPUT_E" "Modules are great! - 3" "E"++### TEST F ###+# Test that changes to modules under "$confdir/lib/" trigger recompilation+cp ../moduleConfig.hs basicTest.hs+cp ../MyConfig-updated.hs lib/MyConfig.hs+OUTPUT_E=`./basic --dyre-debug`+assert "$OUTPUT_E" "Modules are still great! - 3" "E"+ ### TEARDOWN ### echo "Passed"
− Tests/config-check/ConfigCheckTest.hs
@@ -1,19 +0,0 @@-module ConfigCheckTest where--import qualified Config.Dyre as Dyre-import System.IO--configCheckMain = Dyre.wrapMain $ Dyre.defaultParams- { Dyre.projectName = "configCheckTest"- , Dyre.realMain = putStrLn- , Dyre.showError = const- , Dyre.statusOut = const . return $ ()- }--configCheckTest = Dyre.wrapMain $ Dyre.defaultParams- { Dyre.projectName = "configCheckTest"- , Dyre.realMain = putStrLn- , Dyre.showError = const- , Dyre.statusOut = const . return $ ()- , Dyre.configCheck = False- }
+ Tests/config-check/Lib.hs view
@@ -0,0 +1,19 @@+module Lib where++import qualified Config.Dyre as Dyre+import System.IO++configCheckMain = Dyre.wrapMain $ Dyre.defaultParams+ { Dyre.projectName = "configCheckTest"+ , Dyre.realMain = putStrLn+ , Dyre.showError = const+ , Dyre.statusOut = const . return $ ()+ }++configCheckTest = Dyre.wrapMain $ Dyre.defaultParams+ { Dyre.projectName = "configCheckTest"+ , Dyre.realMain = putStrLn+ , Dyre.showError = const+ , Dyre.statusOut = const . return $ ()+ , Dyre.configCheck = False+ }
Tests/config-check/Main.hs view
@@ -1,2 +1,2 @@-import ConfigCheckTest+import Lib main = configCheckMain "main"
Tests/config-check/configCheckTestA.hs view
@@ -1,2 +1,2 @@-import ConfigCheckTest+import Lib main = configCheckTest "custom-a"
Tests/config-check/configCheckTestB.hs view
@@ -1,2 +1,2 @@-import ConfigCheckTest+import Lib main = configCheckTest "custom-b"
Tests/config-check/runTest.sh view
@@ -3,22 +3,15 @@ # Tests Dyre's ability to recompile a custom configuration # upon relaunch, and restore the state again after. -# Assert the equality of two strings.-function assert() {- echo "$1" >&2- if [ "$1" != "$2" ]; then- echo "Failed test $3";- exit 1;- fi-}+. ../subr.sh -mkdir working+mkdir -p working cd working ### TEST A ###-cp ../ConfigCheckTest.hs ../Main.hs .+cp ../Lib.hs ../Main.hs . cp ../configCheckTestA.hs ./configCheckTest.hs-ghc --make Main.hs -o configCheck 2> /dev/null+$HC --make Main.hs -o configCheck || die "compilation failed" OUTPUT_A=`./configCheck --dyre-debug` assert "$OUTPUT_A" "custom-a" "A"
+ Tests/recompile-relaunch/Lib.hs view
@@ -0,0 +1,18 @@+module Lib where++import qualified Config.Dyre as Dyre+import Config.Dyre.Relaunch+import System.IO++realMain message = do+ state <- restoreTextState False+ putStr message >> hFlush stdout+ if state then putStrLn ""+ else relaunchWithTextState True Nothing++recompileRelaunchTest = Dyre.wrapMain $ Dyre.defaultParams+ { Dyre.projectName = "recompileRelaunchTest"+ , Dyre.realMain = realMain+ , Dyre.showError = const+ , Dyre.statusOut = const . return $ ()+ }
Tests/recompile-relaunch/Main.hs view
@@ -1,2 +1,2 @@-import RecompileRelaunchTest+import Lib main = recompileRelaunchTest "Testing.."
− Tests/recompile-relaunch/RecompileRelaunchTest.hs
@@ -1,18 +0,0 @@-module RecompileRelaunchTest where--import qualified Config.Dyre as Dyre-import Config.Dyre.Relaunch-import System.IO--realMain message = do- state <- restoreTextState False- putStr message >> hFlush stdout- if state then putStrLn ""- else relaunchWithTextState True Nothing--recompileRelaunchTest = Dyre.wrapMain $ Dyre.defaultParams- { Dyre.projectName = "recompileRelaunchTest"- , Dyre.realMain = realMain- , Dyre.showError = const- , Dyre.statusOut = const . return $ ()- }
Tests/recompile-relaunch/recompileRelaunchTest.hs view
@@ -1,2 +1,2 @@-import RecompileRelaunchTest+import Lib main = recompileRelaunchTest "..Successful"
Tests/recompile-relaunch/runTest.sh view
@@ -3,21 +3,14 @@ # Tests Dyre's ability to recompile a custom configuration # upon relaunch, and restore the state again after. -# Assert the equality of two strings.-function assert() {- echo "$1" >&2- if [ "$1" != "$2" ]; then- echo "Failed test $3";- exit 1;- fi-}+. ../subr.sh -mkdir working+mkdir -p working cd working ### TEST A ###-cp ../RecompileRelaunchTest.hs ../Main.hs ../recompileRelaunchTest.hs .-ghc --make Main.hs -o recompileRelaunch 2> /dev/null+cp ../Lib.hs ../Main.hs ../recompileRelaunchTest.hs .+$HC --make Main.hs -o recompileRelaunch || die "compilation failed" OUTPUT_A=`./recompileRelaunch --dyre-debug --deny-reconf` assert "$OUTPUT_A" "Testing....Successful" "A"
+ Tests/subr.sh view
@@ -0,0 +1,14 @@+# Assert the equality of two strings.+assert() {+ echo "$1" >&2+ if [ "$1" != "$2" ]; then+ echo "Failed test $3";+ echo " expected: $2"+ echo " got: $1"+ exit 1;+ fi+}++die() {+ echo "$1" ; exit 1+}
+ Tests/threaded/Lib.hs view
@@ -0,0 +1,11 @@+module Lib where++import Control.Concurrent (rtsSupportsBoundThreads)+import qualified Config.Dyre as Dyre++realMain :: String -> IO ()+realMain s = do+ putStr s *> putChar ' ' *> print rtsSupportsBoundThreads++threadedTest = Dyre.wrapMain+ $ Dyre.newParams "threadedTest" realMain const
+ Tests/threaded/Main.hs view
@@ -0,0 +1,4 @@+import Lib++main :: IO ()+main = threadedTest "main"
+ Tests/threaded/runTest.sh view
@@ -0,0 +1,19 @@+#!/bin/sh++# If the main executable was compiled with -threaded, Dyre+# should also compile the custom executable with -threaded.++. ../subr.sh++mkdir -p working+cd working++### TEST A ###+cp ../Lib.hs ../Main.hs ../threadedTest.hs .+$HC -threaded --make Main.hs -o threadedTest || die "compilation failed"+OUTPUT_A=`./threadedTest --dyre-debug`+assert "$OUTPUT_A" "custom True" "A"++echo "Passed"+cd ..+rm -r working
+ Tests/threaded/threadedTest.hs view
@@ -0,0 +1,4 @@+import Lib++main :: IO ()+main = threadedTest "custom"
dyre.cabal view
@@ -1,5 +1,5 @@ name: dyre-version: 0.8.12+version: 0.9.2 category: Development, Configuration synopsis: Dynamic reconfiguration in Haskell @@ -15,25 +15,35 @@ bug-reports: http://github.com/willdonnelly/dyre/issues stability: beta author: Will Donnelly-maintainer: Will Donnelly <will.donnelly@gmail.com>-copyright: (c) 2011 Will Donnelly+maintainer: Fraser Tweedale <frase@frase.id.au>+copyright: (c) 2011-2023 Will Donnelly, Fraser Tweedale license: BSD3 license-file: LICENSE build-type: Simple-cabal-version: >= 1.6+cabal-version: >= 1.10+tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.7 || ==9.4.5 || ==9.6.1 extra-source-files:+ CHANGELOG.md Tests/README.mkd- Tests/allTests.sh+ Tests/*.sh Tests/basic/*.hs Tests/basic/*.sh Tests/config-check/*.hs Tests/config-check/*.sh Tests/recompile-relaunch/*.hs Tests/recompile-relaunch/*.sh+ Tests/threaded/*.hs+ Tests/threaded/*.sh +source-repository head+ type: git+ location: git://github.com/willdonnelly/dyre.git+ library+ default-language: Haskell2010+ ghc-options: -Wall exposed-modules: Config.Dyre, Config.Dyre.Paths, Config.Dyre.Compat,@@ -41,15 +51,30 @@ Config.Dyre.Options, Config.Dyre.Compile, Config.Dyre.Relaunch- build-depends: base >= 4 && < 5, process, filepath,- directory, ghc-paths, time, binary,- executable-path, xdg-basedir, io-storage+ build-depends:+ base >= 4.8 && < 5+ , binary+ , directory >= 1.2.0.0+ , executable-path+ , filepath+ , io-storage+ , process+ , time+ , xdg-basedir if os(windows) build-depends: Win32 else build-depends: unix -source-repository head- type: git- location: git://github.com/willdonnelly/dyre.git+test-suite tests+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: test+ main-is: Main.hs+ ghc-options: -Wall+ build-depends:+ base+ , directory >= 1.2.0.0+ , process+ , dyre
+ test/Main.hs view
@@ -0,0 +1,7 @@+import System.Directory (setCurrentDirectory)+import System.Process (callCommand)++main :: IO ()+main = do+ setCurrentDirectory "Tests"+ callCommand "sh allTests.sh"