mnerge new-devel (Greg made me do it)

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           Data.Char (isSpace)
-import Control.Applicative ((<|>))
+import           Data.Monoid (mappend)
-import Data.Char (isSpace)
+import           Data.List (isSuffixOf)
-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 Data.Text.Lazy.IO as TIO
-import qualified System.Posix.Types
+
-import Control.Monad (filterM, forM)
+import qualified System.Posix.Types
-import Control.Exception (SomeException, try)
+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
+touch = touchDeps =<< getDeps
-    hss <- findHaskellFiles "."
-    deps' <- mapM determineHamletDeps hss
-    let deps = fixDeps $ zip hss deps'
-    touchDeps deps
 
 type Deps = Map.Map FilePath (Set.Set FilePath)
 
@@ -39,24 +39,37 @@ getDeps = do
     return $ fixDeps $ zip hss deps'
 
 touchDeps :: Deps -> IO ()
-touchDeps =
+touchDeps deps = (mapM_ go . Map.toList) deps
-    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` (hiFile y)
-            (access, mod2) <- getFileStatus' y
+            when n $ do
-            if mod2 < mod1
+              putStrLn ("Forcing recompile for " ++ y ++ " because of " ++ x)
-                then do
+              removeHi y
-                    putStrLn $ "Touching " ++ y ++ " because of " ++ x
+
-                    _ <- try' $ setFileTimes y access mod1
+-- | remove the .hi files for a .hs file, thereby forcing a recompile
-                    return ()
+removeHi :: FilePath -> IO ()
-                else return ()
+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

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 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 qualified Control.Exception as Ex
--- import Distribution.Simple.LocalBuildInfo (localPkgDescr)
+import           Control.Monad (forever)
-import Build (getDeps, touchDeps, findHaskellFiles)
+
--- import Network.Wai.Handler.Warp (run)
+import qualified Data.List as L
--- 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 (createDirectoryIfMissing, removeFile,
-appMessage _ = forever $ do
+                                           getDirectoryContents)
-    -- run 3000 . const . return $ responseLBS status500 [("Content-Type", "text/plain")] l
+import           System.Exit (exitFailure, exitSuccess)
-    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 (touch, getDeps, findHaskellFiles)
-      -> IO ()
-devel cabalCmd = do
-    e <- doesFileExist "dist/devel-flag"
-    when e $ removeFile "dist/devel-flag"
-    listenThread <- forkIO (appMessage "Initializing, please wait") >>= I.newIORef
 
-    cabal <- defaultPackageDesc normal
+lockFile :: FilePath
-    _ <- readPackageDescription normal cabal
+lockFile = "dist/devel-terminate"
 
-    mhpd <- defaultHookedPackageDesc
+writeLock :: IO ()
-    _ <- case mhpd of
+writeLock = do
-            Nothing -> return emptyHookedBuildInfo
+    createDirectoryIfMissing True "dist"  
-            Just fp -> readHookedBuildInfo normal fp
+    writeFile lockFile ""
 
-    cabalCmd ["configure", "-fdevel"]
+removeLock :: IO ()
+removeLock = try_ (removeFile lockFile)
 
-    let myTry :: IO () -> IO ()
+devel :: Bool -> IO ()
-        myTry f = try f >>= \x -> case x of
+devel isDevel = do
-                                    Left err -> swapApp listenThread $ forkIO $ appMessage $ L.pack $ show (err :: SomeException)
+    writeLock
-                                    Right y -> return y
-    let getNewApp :: IO ()
-        getNewApp = myTry $ do
-            putStrLn "Rebuilding app"
-            swapApp listenThread $ forkIO $ appMessage "Rebuilding your app, please wait"
     
-            deps <- getDeps
+    putStrLn "Yesod devel server. Pres ENTER to quit"
-            touchDeps deps
+    _ <- forkIO $ do
+      cabal <- D.findPackageDesc "."
+      gpd   <- D.readPackageDescription D.normal cabal
+      let pid = (D.package . D.packageDescription) gpd
 
-            cabalCmd ["build"]
+      checkCabalFile gpd
-            defaultMainArgs ["install"]
 
-            pi' <- getPackageName
+      _ <- if isDevel
-            writeFile "dist/devel.hs" $ unlines
+        then rawSystem "cabal-dev" ["configure", "--cabal-install-arg=-fdevel"]
-                [ "{-# LANGUAGE PackageImports #-}"
+        else rawSystem "cabal"     ["configure", "-fdevel"]
-                , 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
+      T.writeFile "dist/devel.hs" (develFile pid)
 
-sleepForever :: IO ()
+      mainLoop isDevel
-sleepForever = forever $ threadDelay 1000000
+    
+    _ <- getLine
+    writeLock
+    exitSuccess
+
+
+
+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 ()
+watchForChanges :: FileList -> 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
-errApp :: String -> Application
+showPkgName = (\(D.PackageName n) -> n) . D.pkgName
-errApp s _ = return $ ResponseBuilder status500 [("Content-Type", "text/plain")] $ fromString s
--}
 
-getPackageName :: IO String
+develFile :: D.PackageId -> T.Text
-getPackageName = do
+develFile pid = [st|
-    xs <- getDirectoryContents "."
+{-# LANGUAGE PackageImports #-}
-    case mapMaybe (toCabal . reverse) xs of
+import "#{showPkgName pid}" Application (withDevelAppPort)
-        [x] -> return x
+import Data.Dynamic (fromDynamic)
-        [] -> error "No cabal files found"
+import Network.Wai.Handler.Warp (run)
-        _ -> error "Too many cabal files found"
+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
+    isDevelLib ((D.Var (D.Flag (D.FlagName "devel"))), _, _) = True
-    toCabal _ = Nothing
+    isDevelLib _                                             = False
+
+

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
@@ -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"
+

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