mnerge new-devel (Greg made me do it)
This commit is contained in:
Luite Stegeman
commit
1f8d753300
@ -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
|
||||
|
||||
285
yesod/Devel.hs
Normal file → Executable file
285
yesod/Devel.hs
Normal file → Executable file
@ -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
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
8
yesod/main.hs
Normal file → Executable file
8
yesod/main.hs
Normal file → Executable file
@ -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"
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user