diff --git a/yesod/Build.hs b/yesod/Build.hs index 501613d7..cee68401 100644 --- a/yesod/Build.hs +++ b/yesod/Build.hs @@ -1,34 +1,34 @@ {-# LANGUAGE OverloadedStrings #-} module Build - ( touch - , getDeps + ( getDeps , touchDeps + , touch , findHaskellFiles ) where --- FIXME there's a bug when getFileStatus applies to a file temporary deleted (e.g., Vim saving a file) +-- FIXME there's a bug when getFileStatus applies to a file +-- temporary deleted (e.g., Vim saving a file) + +import Control.Applicative ((<|>)) +import Control.Exception (SomeException, try) +import Control.Monad (when, filterM, forM, forM_) -import System.Directory (getDirectoryContents, doesDirectoryExist, doesFileExist) -import Data.List (isSuffixOf) import qualified Data.Attoparsec.Text.Lazy as A -import qualified Data.Text.Lazy.IO as TIO -import Control.Applicative ((<|>)) -import Data.Char (isSpace) -import Data.Monoid (mappend) +import Data.Char (isSpace) +import Data.Monoid (mappend) +import Data.List (isSuffixOf) import qualified Data.Map as Map import qualified Data.Set as Set -import System.PosixCompat.Files (accessTime, modificationTime, getFileStatus, setFileTimes) -import qualified System.Posix.Types -import Control.Monad (filterM, forM) -import Control.Exception (SomeException, try) +import qualified Data.Text.Lazy.IO as TIO + +import qualified System.Posix.Types +import System.Directory +import System.FilePath (replaceExtension, ()) +import System.PosixCompat.Files (getFileStatus, + accessTime, modificationTime) --- | Touch any files with altered dependencies but do not build touch :: IO () -touch = do - hss <- findHaskellFiles "." - deps' <- mapM determineHamletDeps hss - let deps = fixDeps $ zip hss deps' - touchDeps deps +touch = touchDeps =<< getDeps type Deps = Map.Map FilePath (Set.Set FilePath) @@ -39,24 +39,37 @@ getDeps = do return $ fixDeps $ zip hss deps' touchDeps :: Deps -> IO () -touchDeps = - mapM_ go . Map.toList +touchDeps deps = (mapM_ go . Map.toList) deps where - go (x, ys) = do - (_, mod1) <- getFileStatus' x - flip mapM_ (Set.toList ys) $ \y -> do - (access, mod2) <- getFileStatus' y - if mod2 < mod1 - then do - putStrLn $ "Touching " ++ y ++ " because of " ++ x - _ <- try' $ setFileTimes y access mod1 - return () - else return () + go (x, ys) = + forM_ (Set.toList ys) $ \y -> do + n <- x `isNewerThan` (hiFile y) + when n $ do + putStrLn ("Forcing recompile for " ++ y ++ " because of " ++ x) + removeHi y + +-- | remove the .hi files for a .hs file, thereby forcing a recompile +removeHi :: FilePath -> IO () +removeHi hs = mapM_ removeFile' hiFiles + where + removeFile' file = try' (removeFile file) >> return () + hiFiles = map (\e -> "dist/build" replaceExtension hs e) + ["hi", "p_hi"] + +hiFile :: FilePath -> FilePath +hiFile hs = "dist/build" replaceExtension hs "hi" try' :: IO x -> IO (Either SomeException x) try' = try -getFileStatus' :: FilePath -> IO (System.Posix.Types.EpochTime, System.Posix.Types.EpochTime) +isNewerThan :: FilePath -> FilePath -> IO Bool +isNewerThan f1 f2 = do + (_, mod1) <- getFileStatus' f1 + (_, mod2) <- getFileStatus' f2 + return (mod1 > mod2) + +getFileStatus' :: FilePath -> + IO (System.Posix.Types.EpochTime, System.Posix.Types.EpochTime) getFileStatus' fp = do efs <- try' $ getFileStatus fp case efs of @@ -76,9 +89,10 @@ findHaskellFiles path = do fmap concat $ mapM go contents where go ('.':_) = return [] - go ('d':"ist") = return [] + go ('c':"abal-dev" = return [] + go ('d':"ist") = return [] go x = do - let y = path ++ '/' : x + let y = path x d <- doesDirectoryExist y if d then findHaskellFiles y diff --git a/yesod/Devel.hs b/yesod/Devel.hs old mode 100644 new mode 100755 index 4a19652e..b1a7a6ee --- a/yesod/Devel.hs +++ b/yesod/Devel.hs @@ -1,127 +1,119 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} module Devel ( devel ) where --- import qualified Distribution.Simple.Build as B --- import Distribution.Simple.Configure (configure) -import Distribution.Simple (defaultMainArgs) --- import Distribution.Simple.Setup (defaultConfigFlags, configConfigurationsFlags, configUserInstall, Flag (..), defaultBuildFlags, defaultCopyFlags, defaultRegisterFlags) -import Distribution.Simple.Utils (defaultPackageDesc, defaultHookedPackageDesc) --- import Distribution.Simple.Program (defaultProgramConfiguration) -import Distribution.Verbosity (normal) -import Distribution.PackageDescription.Parse (readPackageDescription, readHookedBuildInfo) -import Distribution.PackageDescription (emptyHookedBuildInfo) --- import Distribution.Simple.LocalBuildInfo (localPkgDescr) -import Build (getDeps, touchDeps, findHaskellFiles) --- import Network.Wai.Handler.Warp (run) --- import Network.Wai.Middleware.Debug (debug) --- import Distribution.Text (display) --- import Distribution.Simple.Install (install) --- import Distribution.Simple.Register (register) -import Control.Concurrent (forkIO, threadDelay, ThreadId, killThread) -import Control.Exception (try, SomeException) -import System.PosixCompat.Files (modificationTime, getFileStatus) + +import qualified Distribution.Simple.Utils as D +import qualified Distribution.Verbosity as D +import qualified Distribution.Package as D +import qualified Distribution.PackageDescription.Parse as D +import qualified Distribution.PackageDescription as D + +import Control.Concurrent (forkIO, threadDelay) +import qualified Control.Exception as Ex +import Control.Monad (forever) + +import qualified Data.List as L import qualified Data.Map as Map -import System.Posix.Types (EpochTime) --- import Blaze.ByteString.Builder.Char.Utf8 (fromString) --- import Network.Wai (Application, Response (ResponseBuilder), responseLBS) --- import Network.HTTP.Types (status500) -import Control.Monad (when, forever) -import System.Process (runCommand, terminateProcess, waitForProcess) -import qualified Data.IORef as I -import qualified Data.ByteString.Lazy.Char8 as L -import System.Directory (doesFileExist, removeFile, getDirectoryContents) --- import Distribution.Package (PackageName (..), pkgName) -import Data.Maybe (mapMaybe) +import Data.Maybe (listToMaybe) +import qualified Data.Text as T +import qualified Data.Text.IO as T -appMessage :: L.ByteString -> IO () -appMessage _ = forever $ do - -- run 3000 . const . return $ responseLBS status500 [("Content-Type", "text/plain")] l - threadDelay 10000 +import System.Directory (createDirectoryIfMissing, removeFile, + getDirectoryContents) +import System.Exit (exitFailure, exitSuccess) +import System.Posix.Types (EpochTime) +import System.PosixCompat.Files (modificationTime, getFileStatus) +import System.Process (runCommand, terminateProcess, + waitForProcess, rawSystem) -swapApp :: I.IORef ThreadId -> IO ThreadId -> IO () -swapApp i f = do - I.readIORef i >>= killThread - f >>= I.writeIORef i +import Text.Shakespeare.Text (st) -devel :: ([String] -> IO ()) -- ^ cabal - -> IO () -devel cabalCmd = do - e <- doesFileExist "dist/devel-flag" - when e $ removeFile "dist/devel-flag" - listenThread <- forkIO (appMessage "Initializing, please wait") >>= I.newIORef +import Build (touch, getDeps, findHaskellFiles) - cabal <- defaultPackageDesc normal - _ <- readPackageDescription normal cabal +lockFile :: FilePath +lockFile = "dist/devel-terminate" - mhpd <- defaultHookedPackageDesc - _ <- case mhpd of - Nothing -> return emptyHookedBuildInfo - Just fp -> readHookedBuildInfo normal fp +writeLock :: IO () +writeLock = do + createDirectoryIfMissing True "dist" + writeFile lockFile "" - cabalCmd ["configure", "-fdevel"] +removeLock :: IO () +removeLock = try_ (removeFile lockFile) - let myTry :: IO () -> IO () - myTry f = try f >>= \x -> case x of - Left err -> swapApp listenThread $ forkIO $ appMessage $ L.pack $ show (err :: SomeException) - Right y -> return y - let getNewApp :: IO () - getNewApp = myTry $ do - putStrLn "Rebuilding app" - swapApp listenThread $ forkIO $ appMessage "Rebuilding your app, please wait" +devel :: Bool -> IO () +devel isDevel = do + writeLock + + putStrLn "Yesod devel server. Pres ENTER to quit" + _ <- forkIO $ do + cabal <- D.findPackageDesc "." + gpd <- D.readPackageDescription D.normal cabal + let pid = (D.package . D.packageDescription) gpd - deps <- getDeps - touchDeps deps + checkCabalFile gpd - cabalCmd ["build"] - defaultMainArgs ["install"] + _ <- if isDevel + then rawSystem "cabal-dev" ["configure", "--cabal-install-arg=-fdevel"] + else rawSystem "cabal" ["configure", "-fdevel"] - pi' <- getPackageName - writeFile "dist/devel.hs" $ unlines - [ "{-# LANGUAGE PackageImports #-}" - , concat - [ "import \"" - , pi' - , "\" Application (withDevelAppPort)" - ] - , "import Data.Dynamic (fromDynamic)" - , "import Network.Wai.Handler.Warp (run)" - , "import Data.Maybe (fromJust)" - , "import Control.Concurrent (forkIO)" - , "import System.Directory (doesFileExist, removeFile)" - , "import Control.Concurrent (threadDelay)" - , "" - , "main :: IO ()" - , "main = do" - , " putStrLn \"Starting app\"" - , " wdap <- return $ fromJust $ fromDynamic withDevelAppPort" - , " forkIO $ wdap $ \\(port, app) -> run port app" - , " loop" - , "" - , "loop :: IO ()" - , "loop = do" - , " threadDelay 100000" - , " e <- doesFileExist \"dist/devel-flag\"" - , " if e then removeFile \"dist/devel-flag\" else loop" - ] - swapApp listenThread $ forkIO $ do - putStrLn "Calling runghc..." - ph <- runCommand "runghc dist/devel.hs" - let forceType :: Either SomeException () -> () - forceType = const () - fmap forceType $ try sleepForever - writeFile "dist/devel-flag" "" - putStrLn "Terminating external process" - terminateProcess ph - putStrLn "Process terminated" - ec <- waitForProcess ph - putStrLn $ "Exit code: " ++ show ec + T.writeFile "dist/devel.hs" (develFile pid) - loop Map.empty getNewApp + mainLoop isDevel + + _ <- getLine + writeLock + exitSuccess -sleepForever :: IO () -sleepForever = forever $ threadDelay 1000000 + + +mainLoop :: Bool -> IO () +mainLoop isDevel = forever $ do + putStrLn "Rebuilding application..." + + touch + + list <- getFileList + _ <- if isDevel + then rawSystem "cabal-dev" ["build"] + else rawSystem "cabal" ["build"] + + removeLock + putStrLn "Starting development server..." + pkg <- pkgConfigs isDevel + ph <- runCommand $ concat ["runghc ", pkg, " dist/devel.hs"] + 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 + where + inplacePkg = "-package-confdist/package.conf.inplace" + isConfig dir = "packages-" `L.isPrefixOf` dir && + ".conf" `L.isSuffixOf` dir type FileList = Map.Map FilePath EpochTime @@ -134,25 +126,68 @@ getFileList = do fs <- getFileStatus f return (f, modificationTime fs) -loop :: FileList -> IO () -> IO () -loop oldList getNewApp = do +watchForChanges :: FileList -> IO () +watchForChanges list = do newList <- getFileList - when (newList /= oldList) getNewApp - threadDelay 1000000 - loop newList getNewApp + if list /= newList + then return () + else threadDelay 1000000 >> watchForChanges list -{- -errApp :: String -> Application -errApp s _ = return $ ResponseBuilder status500 [("Content-Type", "text/plain")] $ fromString s --} +showPkgName :: D.PackageId -> String +showPkgName = (\(D.PackageName n) -> n) . D.pkgName -getPackageName :: IO String -getPackageName = do - xs <- getDirectoryContents "." - case mapMaybe (toCabal . reverse) xs of - [x] -> return x - [] -> error "No cabal files found" - _ -> error "Too many cabal files found" +develFile :: D.PackageId -> T.Text +develFile pid = [st| +{-# LANGUAGE PackageImports #-} +import "#{showPkgName pid}" Application (withDevelAppPort) +import Data.Dynamic (fromDynamic) +import Network.Wai.Handler.Warp (run) +import Data.Maybe (fromJust) +import Control.Concurrent (forkIO) +import System.Directory (doesFileExist, removeFile) +import System.Exit (exitSuccess) +import Control.Concurrent (threadDelay) + +main :: IO () +main = do + putStrLn "Starting devel application" + wdap <- (return . fromJust . fromDynamic) withDevelAppPort + forkIO . wdap $ \(port, app) -> run port app + loop + +loop :: IO () +loop = do + threadDelay 100000 + e <- doesFileExist "dist/devel-terminate" + if e then terminateDevel else loop + +terminateDevel :: IO () +terminateDevel = exitSuccess +|] + +checkCabalFile :: D.GenericPackageDescription -> IO () +checkCabalFile gpd = case D.condLibrary gpd of + Nothing -> do + putStrLn "Error: incorrect cabal file, no library" + exitFailure + Just ct -> + case lookupDevelLib ct of + Nothing -> do + putStrLn "Error: no library configuration for -fdevel" + exitFailure + Just dLib -> + case (D.hsSourceDirs . D.libBuildInfo) dLib of + [] -> return () + ["."] -> return () + _ -> + putStrLn $ "WARNING: yesod devel may not work correctly with " ++ + "custom hs-source-dirs" + +lookupDevelLib :: D.CondTree D.ConfVar c a -> Maybe a +lookupDevelLib ct = listToMaybe . map (\(_,x,_) -> D.condTreeData x) . + filter isDevelLib . D.condTreeComponents $ ct where - toCabal ('l':'a':'b':'a':'c':'.':x) = Just $ reverse x - toCabal _ = Nothing + isDevelLib ((D.Var (D.Flag (D.FlagName "devel"))), _, _) = True + isDevelLib _ = False + + diff --git a/yesod/input/done.cg b/yesod/input/done.cg index 8021c266..0e6066c9 100644 --- a/yesod/input/done.cg +++ b/yesod/input/done.cg @@ -26,4 +26,7 @@ Start your project: cd ~project~ && cabal install && yesod devel +or if you use cabal-dev: + + cd ~project~ && cabal-dev install && yesod --dev devel diff --git a/yesod/main.hs b/yesod/main.hs old mode 100644 new mode 100755 index 0c6f19b9..c2c17275 --- a/yesod/main.hs +++ b/yesod/main.hs @@ -1,12 +1,11 @@ import Scaffolding.Scaffolder import System.Environment (getArgs) import System.Exit (exitWith) +import System.Process (rawSystem) import Build (touch) import Devel (devel) -import System.Process (rawSystem) - main :: IO () main = do args' <- getArgs @@ -15,13 +14,12 @@ main = do "--dev":rest -> (True, rest) _ -> (False, args') let cmd = if isDev then "cabal-dev" else "cabal" - let cabal rest = rawSystem cmd rest >> return () let build rest = rawSystem cmd $ "build":rest case args of ["init"] -> scaffold "build":rest -> touch >> build rest >>= exitWith ["touch"] -> touch - ["devel"] -> devel cabal + ["devel"] -> devel isDev ["version"] -> putStrLn "0.9" "configure":rest -> rawSystem cmd ("configure":rest) >>= exitWith _ -> do @@ -32,4 +30,6 @@ main = do putStrLn " build Build project (performs TH dependency analysis)" putStrLn " touch Touch any files with altered TH dependencies but do not build" putStrLn " devel Run project with the devel server" + putStrLn " use --dev devel to build with cabal-dev" putStrLn " version Print the version of Yesod" + diff --git a/yesod/yesod.cabal b/yesod/yesod.cabal index 6b999915..cad486f3 100644 --- a/yesod/yesod.cabal +++ b/yesod/yesod.cabal @@ -87,6 +87,7 @@ executable yesod build-depends: base >= 4 && < 4.3 build-depends: parsec >= 2.1 && < 4 , text >= 0.11 && < 0.12 + , shakespeare-text >= 0.10 && < 0.11 , bytestring >= 0.9 && < 0.10 , time >= 1.1.4 && < 1.3 , template-haskell @@ -97,6 +98,7 @@ executable yesod , attoparsec-text >= 0.8.5 && < 0.9 , http-types >= 0.6.1 && < 0.7 , blaze-builder >= 0.2 && < 0.4 + , filepath >= 1.2 && < 1.3 , process ghc-options: -Wall -threaded main-is: main.hs