change recompile method, revert scaffold changes
This commit is contained in:
Luite Stegeman
parent
611bb89e83
commit
7a1629eaba
@ -1,8 +1,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Build
|
||||
( copySources
|
||||
, getDeps
|
||||
, copyDeps
|
||||
( getDeps
|
||||
, touchDeps
|
||||
, touch
|
||||
, findHaskellFiles
|
||||
) where
|
||||
@ -10,79 +9,55 @@ module Build
|
||||
-- FIXME there's a bug when getFileStatus applies to a file
|
||||
-- temporary deleted (e.g., Vim saving a file)
|
||||
|
||||
import System.FilePath (takeFileName, takeDirectory, (</>))
|
||||
import System.Directory
|
||||
import Data.List (isSuffixOf)
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Exception (SomeException, try)
|
||||
import Control.Monad (when, filterM, forM, forM_)
|
||||
|
||||
import qualified Data.Attoparsec.Text.Lazy as A
|
||||
import qualified Data.Text.Lazy.IO as TIO
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Exception (SomeException, try)
|
||||
import Control.Monad (when, filterM, forM, forM_)
|
||||
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 qualified Data.Text.Lazy.IO as TIO
|
||||
|
||||
import qualified System.Posix.Types
|
||||
import System.PosixCompat.Files (setFileTimes, getFileStatus,
|
||||
import System.Directory
|
||||
import System.FilePath (replaceExtension, (</>))
|
||||
import System.PosixCompat.Files (setFileTimes, getFileStatus,
|
||||
accessTime, modificationTime)
|
||||
|
||||
|
||||
touch :: IO ()
|
||||
touch = mapM_ go . Map.toList =<< getDeps
|
||||
where
|
||||
go (x, ys) = do
|
||||
(_, mod1) <- getFileStatus' x
|
||||
forM_ (Set.toList ys) $ \y -> do
|
||||
(access, mod2) <- getFileStatus' y
|
||||
when (mod2 < mod1) $ do
|
||||
putStrLn ("Touching " ++ y ++ " because of " ++ x)
|
||||
setFileTimes y access mod1
|
||||
|
||||
|
||||
-- | Copy all .hs files to the devel src dir
|
||||
copySources :: IO ()
|
||||
copySources = cleanDev >> copySources'
|
||||
|
||||
copySources' :: IO ()
|
||||
copySources' = do
|
||||
hss <- findHaskellFiles "."
|
||||
forM_ hss $ \hs -> do
|
||||
n <- hs `isNewerThan` (develSrcDir </> hs)
|
||||
when n (copyToDev hs)
|
||||
touch = touchDeps =<< getDeps
|
||||
|
||||
type Deps = Map.Map FilePath (Set.Set FilePath)
|
||||
|
||||
develSrcDir :: FilePath
|
||||
develSrcDir = "dist/src-devel"
|
||||
|
||||
getDeps :: IO Deps
|
||||
getDeps = do
|
||||
hss <- findHaskellFiles "."
|
||||
deps' <- mapM determineHamletDeps hss
|
||||
return $ fixDeps $ zip hss deps'
|
||||
|
||||
copyDeps :: Deps -> IO ()
|
||||
copyDeps deps = (mapM_ go . Map.toList) deps >> copySources'
|
||||
touchDeps :: Deps -> IO ()
|
||||
touchDeps deps = (mapM_ go . Map.toList) deps
|
||||
where
|
||||
go (x, ys) =
|
||||
forM_ (Set.toList ys) $ \y -> do
|
||||
n <- x `isNewerThan` (develSrcDir </> y)
|
||||
when n $ do
|
||||
putStrLn ("Copying " ++ y ++ " because of " ++ x)
|
||||
copyToDev y
|
||||
n <- x `isNewerThan` (hiFile y)
|
||||
when n $ do
|
||||
putStrLn ("Forcing recompile for " ++ y ++ " because of " ++ x)
|
||||
removeHi y
|
||||
|
||||
copyToDev :: FilePath -> IO ()
|
||||
copyToDev file = do
|
||||
createDirectoryIfMissing True targetDir
|
||||
copyFile file (targetDir </> takeFileName file)
|
||||
where
|
||||
dir = takeDirectory file
|
||||
targetDir = develSrcDir </> dir
|
||||
-- | 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"]
|
||||
|
||||
cleanDev :: IO ()
|
||||
cleanDev = do
|
||||
try' $ removeDirectoryRecursive develSrcDir
|
||||
return ()
|
||||
hiFile :: FilePath -> FilePath
|
||||
hiFile hs = "dist/build" </> replaceExtension hs "hi"
|
||||
|
||||
try' :: IO x -> IO (Either SomeException x)
|
||||
try' = try
|
||||
|
||||
@ -27,12 +27,12 @@ import System.Directory (doesFileExist, removeFile,
|
||||
import System.Exit (exitFailure)
|
||||
import System.Posix.Types (EpochTime)
|
||||
import System.PosixCompat.Files (modificationTime, getFileStatus)
|
||||
import System.Process (runCommand, terminateProcess,
|
||||
import System.Process (runCommand, terminateProcess,
|
||||
waitForProcess, rawSystem)
|
||||
|
||||
import Text.Shakespeare.Text (st)
|
||||
|
||||
import Build (getDeps, copySources, copyDeps, findHaskellFiles)
|
||||
import Build (touch, getDeps, findHaskellFiles)
|
||||
|
||||
devel :: Bool -> IO ()
|
||||
devel isDevel = do
|
||||
@ -45,7 +45,6 @@ devel isDevel = do
|
||||
|
||||
checkCabalFile gpd
|
||||
|
||||
copySources
|
||||
_ <- if isDevel
|
||||
then rawSystem "cabal-dev" ["configure", "--cabal-install-arg=-fdevel"]
|
||||
else rawSystem "cabal" ["configure", "-fdevel"]
|
||||
@ -59,8 +58,7 @@ mainLoop :: Bool -> IO ()
|
||||
mainLoop isDevel = forever $ do
|
||||
putStrLn "Rebuilding app"
|
||||
|
||||
deps <- getDeps
|
||||
copyDeps deps
|
||||
touch
|
||||
|
||||
list <- getFileList
|
||||
_ <- if isDevel
|
||||
@ -105,7 +103,7 @@ getFileList = do
|
||||
fs <- getFileStatus f
|
||||
return (f, modificationTime fs)
|
||||
|
||||
watchForChanges :: FileList -> IO () -- ThreadId -> IO ()
|
||||
watchForChanges :: FileList -> IO ()
|
||||
watchForChanges list = do
|
||||
newList <- getFileList
|
||||
if list /= newList
|
||||
@ -147,10 +145,6 @@ terminateDevel = do
|
||||
exitSuccess
|
||||
|]
|
||||
|
||||
{-
|
||||
check whether cabal file from old scaffold needs to be updated
|
||||
should be removed after 1.0 release?
|
||||
-}
|
||||
checkCabalFile :: D.GenericPackageDescription -> IO ()
|
||||
checkCabalFile gpd = case D.condLibrary gpd of
|
||||
Nothing -> do
|
||||
@ -163,9 +157,11 @@ checkCabalFile gpd = case D.condLibrary gpd of
|
||||
exitFailure
|
||||
Just dLib ->
|
||||
case (D.hsSourceDirs . D.libBuildInfo) dLib of
|
||||
["dist/src-devel"] -> return ()
|
||||
_ ->
|
||||
T.putStrLn upgradeMessage >> exitFailure
|
||||
[] -> 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) .
|
||||
@ -174,31 +170,4 @@ lookupDevelLib ct = listToMaybe . map (\(_,x,_) -> D.condTreeData x) .
|
||||
isDevelLib ((D.Var (D.Flag (D.FlagName "devel"))), _, _) = True
|
||||
isDevelLib _ = False
|
||||
|
||||
upgradeMessage :: T.Text
|
||||
upgradeMessage = [st|
|
||||
Your cabal file needs to be updated for this version of yesod devel.
|
||||
Find the lines:
|
||||
library
|
||||
if flag(devel)
|
||||
Buildable: True
|
||||
else
|
||||
Buildable: False
|
||||
|
||||
if os(windows)
|
||||
cpp-options: -DWINDOWS
|
||||
|
||||
hs-source-dirs: .
|
||||
|
||||
And replace them with:
|
||||
library
|
||||
if flag(devel)
|
||||
Buildable: True
|
||||
hs-source-dirs: dist/src-devel
|
||||
else
|
||||
Buildable: False
|
||||
hs-source-dirs: .
|
||||
|
||||
if os(windows)
|
||||
cpp-options: -DWINDOWS
|
||||
|]
|
||||
|
||||
|
||||
@ -23,14 +23,13 @@ Flag devel
|
||||
library
|
||||
if flag(devel)
|
||||
Buildable: True
|
||||
hs-source-dirs: dist/src-devel
|
||||
else
|
||||
Buildable: False
|
||||
hs-source-dirs: .
|
||||
|
||||
if os(windows)
|
||||
cpp-options: -DWINDOWS
|
||||
|
||||
hs-source-dirs: .
|
||||
exposed-modules: Application
|
||||
other-modules: Foundation
|
||||
Model
|
||||
|
||||
Loading…
Reference in New Issue
Block a user