improve yesod devel

yesod/Build.hs

@@ -1,62 +1,100 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Build
-    ( touch
+    ( copySources
     , getDeps
-    , touchDeps
+    , copyDeps
+    , 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 System.Directory (getDirectoryContents, doesDirectoryExist, doesFileExist)
+import System.FilePath (takeFileName, takeDirectory, (</>))
+import System.Directory
 import Data.List (isSuffixOf)
 import qualified Data.Attoparsec.Text.Lazy as A
 import qualified Data.Text.Lazy.IO as TIO
 import Control.Applicative ((<|>))
+import Control.Monad (when)
 import Data.Char (isSpace)
 import Data.Monoid (mappend)
 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 System.PosixCompat.Files (setFileTimes, getFileStatus,
+                                             accessTime, modificationTime)
+import Control.Monad (filterM, forM, forM_)
 import Control.Exception (SomeException, try)
 
--- | Touch any files with altered dependencies but do not build
 touch :: IO ()
-touch = do
+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 "."
-    deps' <- mapM determineHamletDeps hss
+    forM_ hss $ \hs -> do
-    let deps = fixDeps $ zip hss deps'
+        n <- hs `isNewerThan` (develSrcDir </> hs)
-    touchDeps deps
+        when n (copyToDev hs)
 
 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'
 
-touchDeps :: Deps -> IO ()
+copyDeps :: Deps -> IO ()
-touchDeps =
+copyDeps deps = (mapM_ go . Map.toList) deps >> copySources'
-    mapM_ go . Map.toList
   where
-    go (x, ys) = do
+    go (x, ys) =
-        (_, mod1) <- getFileStatus' x
+        forM_ (Set.toList ys) $ \y -> do
-        flip mapM_ (Set.toList ys) $ \y -> do
+                  n <- x `isNewerThan` (develSrcDir </> y)
-            (access, mod2) <- getFileStatus' y
+                  when n $ do
-            if mod2 < mod1
+                    putStrLn ("Copying " ++ y ++ " because of " ++ x)
-                then do
+                    copyToDev y
-                    putStrLn $ "Touching " ++ y ++ " because of " ++ x
+
-                    _ <- try' $ setFileTimes y access mod1
+copyToDev :: FilePath -> IO ()
-                    return ()
+copyToDev file = do
-                else return ()
+  createDirectoryIfMissing True targetDir
+  copyFile file (targetDir </> takeFileName file)
+  where
+   dir = takeDirectory file
+   targetDir = develSrcDir </> dir
+
+cleanDev :: IO ()
+cleanDev = do
+  exists <- doesDirectoryExist develSrcDir
+  when exists (removeDirectoryRecursive develSrcDir)
 
 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
@@ -75,10 +113,11 @@ findHaskellFiles path = do
     contents <- getDirectoryContents path
     fmap concat $ mapM go contents
   where
-    go ('.':_) = return []
+    go ('.':_)     = return []
-    go "dist" = return []
+    go "cabal-dev" = return []
+    go "dist"      = return []
     go x = do
-        let y = path ++ '/' : x
+        let y = path </> x
         d <- doesDirectoryExist y
         if d
             then findHaskellFiles y

yesod/Devel.hs

@@ -1,127 +1,98 @@
-{-# 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 qualified Distribution.Simple.Utils as D
-import Distribution.Simple (defaultMainArgs)
+import qualified Distribution.Verbosity as D
--- import Distribution.Simple.Setup (defaultConfigFlags, configConfigurationsFlags, configUserInstall, Flag (..), defaultBuildFlags, defaultCopyFlags, defaultRegisterFlags)
+import qualified Distribution.Package as D
-import Distribution.Simple.Utils (defaultPackageDesc, defaultHookedPackageDesc)
+import qualified Distribution.PackageDescription.Parse as D
--- import Distribution.Simple.Program (defaultProgramConfiguration)
+import qualified Distribution.PackageDescription as D
-import Distribution.Verbosity (normal)
+
-import Distribution.PackageDescription.Parse (readPackageDescription, readHookedBuildInfo)
+import           Control.Concurrent (forkIO, threadDelay)
-import Distribution.PackageDescription (emptyHookedBuildInfo)
+import           Control.Monad (when, forever)
--- import Distribution.Simple.LocalBuildInfo (localPkgDescr)
+
-import Build (getDeps, touchDeps, findHaskellFiles)
+import qualified Data.List as L
--- 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 Data.Map as Map
-import System.Posix.Types (EpochTime)
+import           Data.Maybe (listToMaybe)
--- import Blaze.ByteString.Builder.Char.Utf8 (fromString)
+import qualified Data.Text as T
--- import Network.Wai (Application, Response (ResponseBuilder), responseLBS)
+import qualified Data.Text.IO as T
--- 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)
 
-appMessage :: L.ByteString -> IO ()
+import           System.Directory (doesFileExist, removeFile,
-appMessage _ = forever $ do
+                                                getDirectoryContents)
-    -- run 3000 . const . return $ responseLBS status500 [("Content-Type", "text/plain")] l
+import           System.Exit (exitFailure)
-    threadDelay 10000
+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 ()
+import Text.Shakespeare.Text (st)
-swapApp i f = do
-    I.readIORef i >>= killThread
-    f >>= I.writeIORef i
 
-devel :: ([String] -> IO ()) -- ^ cabal
+import Build (getDeps, copySources, copyDeps, findHaskellFiles)
-      -> IO ()
+
-devel cabalCmd = do
+devel :: Bool -> IO ()
+devel isDevel = do
     e <- doesFileExist "dist/devel-flag"
     when e $ removeFile "dist/devel-flag"
-    listenThread <- forkIO (appMessage "Initializing, please wait") >>= I.newIORef
 
-    cabal <- defaultPackageDesc normal
+    cabal <- D.findPackageDesc "."
-    _ <- readPackageDescription normal cabal
+    gpd   <- D.readPackageDescription D.normal cabal
+    let pid = (D.package . D.packageDescription) gpd
 
-    mhpd <- defaultHookedPackageDesc
+    checkCabalFile gpd
-    _ <- case mhpd of
-            Nothing -> return emptyHookedBuildInfo
-            Just fp -> readHookedBuildInfo normal fp
 
-    cabalCmd ["configure", "-fdevel"]
+    copySources
+    _ <- if isDevel
+      then rawSystem "cabal-dev" ["configure", "--cabal-install-arg=-fdevel"]
+      else rawSystem "cabal"     ["configure", "-fdevel"]
 
-    let myTry :: IO () -> IO ()
+    T.writeFile "dist/devel.hs" (develFile pid)
-        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"
 
-            deps <- getDeps
+    mainLoop isDevel
-            touchDeps deps
 
-            cabalCmd ["build"]
-            defaultMainArgs ["install"]
 
-            pi' <- getPackageName
+mainLoop :: Bool -> IO ()
-            writeFile "dist/devel.hs" $ unlines
+mainLoop isDevel = forever $ do
-                [ "{-# LANGUAGE PackageImports #-}"
+   putStrLn "Rebuilding app"
-                , 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
 
-    loop Map.empty getNewApp
+   deps <- getDeps
+   copyDeps deps
 
-sleepForever :: IO ()
+   list <- getFileList
-sleepForever = forever $ threadDelay 1000000
+   _ <- if isDevel
+     then rawSystem "cabal"     ["build"]
+     else rawSystem "cabal-dev" ["build"]
+
+   putStrLn "Starting development server..."
+   pkg <- pkgConfigs isDevel
+   ph <- runCommand $ concat ["runghc ", pkg, " dist/devel.hs"]
+   watchForChanges list
+   putStrLn "Stopping development server..."
+   _ <- forkIO $ do
+     writeFile "dist/devel-flag" ""
+     threadDelay 1000000
+     -- fixme, check whether process is still alive?
+     putStrLn "Terminating external process"
+     terminateProcess ph
+   ec <- waitForProcess ph
+   putStrLn $ "Exit code: " ++ show ec
+
+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 pkg = "packages-" `L.isPrefixOf` pkg &&
+                   ".conf"     `L.isSuffixOf` pkg
 
 type FileList = Map.Map FilePath EpochTime
 
@@ -134,25 +105,100 @@ getFileList = do
         fs <- getFileStatus f
         return (f, modificationTime fs)
 
-loop :: FileList -> IO () -> IO ()
+watchForChanges :: FileList -> IO () --  ThreadId -> IO ()
-loop oldList getNewApp = do
+watchForChanges list = do
     newList <- getFileList
-    when (newList /= oldList) getNewApp
+    if list /= newList
-    threadDelay 1000000
+      then return ()
-    loop newList getNewApp
+      else threadDelay 1000000 >> watchForChanges list
+
+showPkgName :: D.PackageId -> String
+showPkgName = (\(D.PackageName n) -> n) . D.pkgName
+
+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 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 terminateDevel else loop
+
+terminateDevel :: IO ()
+terminateDevel = do
+  removeFile "dist/devel-flag"
+  putStrLn "Terminating server"
+  exitSuccess
+|]
 
 {-
-errApp :: String -> Application
+  check whether cabal file from old scaffold needs to be updated
-errApp s _ = return $ ResponseBuilder status500 [("Content-Type", "text/plain")] $ fromString s
+  should be removed after 1.0 release?
 -}
+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
+           ["dist/src-devel"]  -> return ()
+           _                   ->
+             T.putStrLn upgradeMessage >> print gpd >> exitFailure
 
-getPackageName :: IO String
+lookupDevelLib :: D.CondTree D.ConfVar c a -> Maybe a
-getPackageName = do
+lookupDevelLib ct = listToMaybe . map (\(_,x,_) -> D.condTreeData x) .
-    xs <- getDirectoryContents "."
+                    filter isDevelLib . D.condTreeComponents  $ ct
-    case mapMaybe (toCabal . reverse) xs of
-        [x] -> return x
-        [] -> error "No cabal files found"
-        _ -> error "Too many cabal files found"
   where
-    toCabal ('l':'a':'b':'a':'c':'.':x) = Just $ reverse x
+    isDevelLib ((D.Var (D.Flag (D.FlagName "devel"))), _, _) = True
-    toCabal _ = Nothing
+    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
+|]
+

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
 

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
@@ -33,3 +31,4 @@ main = do
             putStrLn "    touch        Touch any files with altered TH dependencies but do not build"
             putStrLn "    devel        Run project with the devel server"
             putStrLn "    version      Print the version of Yesod"
+

yesod/scaffold/project.cabal.cg

@@ -23,13 +23,14 @@ 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

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