From f2d7b0bda05e9fc7c763ca57c27e80af154a07bd Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Sat, 11 Feb 2012 03:56:07 +0100 Subject: [PATCH] Bugfixes and better error reporting for yesod devel --- yesod/Devel.hs | 148 +++++++++++++++++++++++++++++++------------------ 1 file changed, 93 insertions(+), 55 deletions(-) diff --git a/yesod/Devel.hs b/yesod/Devel.hs index 007cbbbf..984c8917 100644 --- a/yesod/Devel.hs +++ b/yesod/Devel.hs @@ -12,31 +12,27 @@ import qualified Distribution.Simple.Utils as D import qualified Distribution.Verbosity as D import qualified Distribution.PackageDescription.Parse as D import qualified Distribution.PackageDescription as D +import qualified Distribution.ModuleName as D import Control.Concurrent (forkIO, threadDelay) import qualified Control.Exception as Ex -import Control.Monad (forever) +import Control.Monad (forever, when) +import Data.Char (isUpper, isNumber) import qualified Data.List as L import qualified Data.Map as Map -import Data.Maybe (listToMaybe) +import qualified Data.Set as Set -import System.Directory (createDirectoryIfMissing, removeFile, - getDirectoryContents) +import System.Directory import System.Exit (exitFailure, exitSuccess) +import System.FilePath (splitDirectories, dropExtension, takeExtension) import System.Posix.Types (EpochTime) import System.PosixCompat.Files (modificationTime, getFileStatus) -import System.Process (runCommand, terminateProcess, +import System.Process (runCommand, terminateProcess, readProcess, waitForProcess, rawSystem) import Build (recompDeps, getDeps,findHaskellFiles) -#if __GLASGOW_HASKELL__ >= 700 -#define ST st -#else -#define ST $st -#endif - lockFile :: FilePath lockFile = "dist/devel-terminate" @@ -50,6 +46,9 @@ removeLock = try_ (removeFile lockFile) devel :: Bool -> IO () devel isCabalDev = do + + checkDevelFile + writeLock putStrLn "Yesod devel server. Press ENTER to quit" @@ -79,51 +78,46 @@ devel isCabalDev = do writeLock exitSuccess - - mainLoop :: Bool -> IO () -mainLoop isCabalDev = forever $ do - putStrLn "Rebuilding application..." +mainLoop isCabalDev = do + ghcVer <- ghcVersion + forever $ do + putStrLn "Rebuilding application..." - recompDeps + recompDeps - list <- getFileList - _ <- if isCabalDev - then rawSystem "cabal-dev" ["build"] - else rawSystem "cabal" ["build"] + list <- getFileList + _ <- if isCabalDev + then rawSystem "cabal-dev" ["build"] + else rawSystem "cabal" ["build"] - removeLock - pkg <- pkgConfigs isCabalDev - let start = concat ["runghc ", pkg, " devel.hs"] - putStrLn $ "Starting development server: " ++ start - ph <- runCommand start - watchTid <- forkIO . try_ $ do - watchForChanges list - putStrLn "Stopping development server..." - writeLock - threadDelay 1000000 - putStrLn "Terminating development server..." - terminateProcess ph - ec <- waitForProcess ph - putStrLn $ "Exit code: " ++ show ec - Ex.throwTo watchTid (userError "process finished") - watchForChanges list + removeLock + let pkg = pkgConfigs isCabalDev ghcVer + let start = concat ["runghc ", pkg, " devel.hs"] + putStrLn $ "Starting development server: " ++ start + ph <- runCommand start + watchTid <- forkIO . try_ $ do + watchForChanges list + putStrLn "Stopping development server..." + writeLock + threadDelay 1000000 + putStrLn "Terminating development server..." + terminateProcess ph + ec <- waitForProcess ph + putStrLn $ "Exit code: " ++ show ec + Ex.throwTo watchTid (userError "process finished") + watchForChanges list try_ :: forall a. IO a -> IO () try_ x = (Ex.try x :: IO (Either Ex.SomeException a)) >> return () -pkgConfigs :: Bool -> IO String -pkgConfigs isDev - | isDev = do - devContents <- getDirectoryContents "cabal-dev" - let confs = filter isConfig devContents - return . unwords $ inplacePkg : - map ("-package-confcabal-dev/"++) confs - | otherwise = return inplacePkg +pkgConfigs :: Bool -> String -> String +pkgConfigs isCabalDev ghcVer + | isCabalDev = unwords ["-package-confcabal-dev/packages-" ++ ghcVer ++ ".conf", inplacePkg] + | otherwise = inplacePkg where inplacePkg = "-package-confdist/package.conf.inplace" - isConfig dir = "packages-" `L.isPrefixOf` dir && - ".conf" `L.isSuffixOf` dir + type FileList = Map.Map FilePath EpochTime @@ -143,29 +137,73 @@ watchForChanges list = do then return () else threadDelay 1000000 >> watchForChanges list +checkDevelFile :: IO () +checkDevelFile = do + e <- doesFileExist "devel.hs" + when (not e) $ failWith "file devel.hs not found" + checkCabalFile :: D.GenericPackageDescription -> IO () checkCabalFile gpd = case D.condLibrary gpd of - Nothing -> do - putStrLn "Error: incorrect cabal file, no library" - exitFailure + Nothing -> failWith "incorrect cabal file, no library" Just ct -> case lookupDevelLib ct of - Nothing -> do - putStrLn "Error: no development flag found in your configuration file. Expected a 'library-only' flag or the older 'devel' flag" - exitFailure - Just dLib -> + Nothing -> + failWith "no development flag found in your configuration file. Expected a 'library-only' flag or the older 'devel' flag" + Just dLib -> do case (D.hsSourceDirs . D.libBuildInfo) dLib of [] -> return () ["."] -> return () _ -> putStrLn $ "WARNING: yesod devel may not work correctly with " ++ "custom hs-source-dirs" + fl <- getFileList + print (allModules dLib) + let unlisted = checkFileList fl dLib + print fl + when (not . null $ unlisted) $ do + putStrLn "WARNING: the following source files are not listed in exposed-modules or other-modules:" + mapM_ putStrLn unlisted + when (D.fromString "Application" `notElem` D.exposedModules dLib) $ do + putStrLn "WARNING: no exposed module Application" + print (D.exposedModules dLib) + print dLib + +failWith :: String -> IO a +failWith msg = do + putStrLn $ "ERROR: " ++ msg + exitFailure + +checkFileList :: FileList -> D.Library -> [FilePath] +checkFileList fl lib = filter isUnlisted . filter isSrcFile $ sourceFiles + where + al = allModules lib + -- a file is only a possible 'module file' if all path pieces start with a capital letter + sourceFiles = filter isSrcFile . map fst . Map.toList $ fl + isSrcFile file = let dirs = filter (/=".") $ splitDirectories file + in all (isUpper . head) dirs && (takeExtension file `elem` [".hs", ".lhs"]) + isUnlisted file = not (toModuleName file `Set.member` al) + toModuleName = L.intercalate "." . filter (/=".") . splitDirectories . dropExtension + +allModules :: D.Library -> Set.Set String +allModules lib = Set.fromList $ map toString $ D.exposedModules lib ++ (D.otherModules . D.libBuildInfo) lib + where + toString = L.intercalate "." . D.components + +ghcVersion :: IO String +ghcVersion = fmap getNumber $ readProcess "runghc" ["--numeric-version", "0"] [] + where + getNumber = filter (\x -> isNumber x || x == '.') + lookupDevelLib :: D.CondTree D.ConfVar c a -> Maybe a -lookupDevelLib ct = listToMaybe . map (\(_,x,_) -> D.condTreeData x) . - filter isDevelLib . D.condTreeComponents $ ct +lookupDevelLib ct | found = Just (D.condTreeData ct) + | otherwise = Nothing where + found = not . null . map (\(_,x,_) -> D.condTreeData x) . + filter isDevelLib . D.condTreeComponents $ ct isDevelLib ((D.Var (D.Flag (D.FlagName f))), _, _) = f `elem` ["library-only", "devel"] isDevelLib _ = False + +