Reloading feature copied from yesod.

Reload.hs

{-# LANGUAGE ScopedTypeVariables #-}
--
-- Copied from Yesod
-- see http://www.yesodweb.com/
--
module Reload (main, develLoop) where

-- reload
import           Control.Concurrent (forkIO, threadDelay)
import qualified Control.Exception as Ex
import           Control.Monad (forever, when)

import qualified Data.Map as Map

import           System.Directory
import           System.Exit (exitSuccess, exitFailure, ExitCode (..))
import           System.FilePath()
import           System.Posix.Types (EpochTime)
import           System.PosixCompat.Files (modificationTime, getFileStatus)
import           System.Process (createProcess, proc, terminateProcess,
                                 waitForProcess, rawSystem)


-- build
import           Data.List (isSuffixOf)
import           System.FilePath ((</>))


-- run
main :: IO ()
main = devel

-- export for devel.hs
develLoop :: IO ()
develLoop = do
  threadDelay $ delay `div` 10
  e <- doesFileExist lockFile
  if e then terminateDevel else develLoop

terminateDevel :: IO ()
terminateDevel = exitSuccess


type FileList = Map.Map FilePath EpochTime

--
-- from Devel.hs
--
lockFile :: FilePath
lockFile = "dist/devel-terminate"

writeLock :: IO ()
writeLock = do
  createDirectoryIfMissing True "dist"
  writeFile lockFile ""

removeLock :: IO ()
removeLock = try_ (removeFile lockFile)

buildcmd :: String
buildcmd = "ghc"
buildargs :: [String]
buildargs = ["-Wall", "-outputdir", "dist", "-o", "dist/devel", "devel.hs"]

runcmd :: String
runcmd = "runghc"
runargs :: [String]
runargs = ["devel.hs"]

delay :: Int
delay = 100000

devel :: IO ()
devel = do
  checkDevelFile
  writeLock
  putStrLn "Press ENTER to quit"
  _ <- forkIO $ do
    _ <- rawSystem buildcmd buildargs
    mainLoop
  _ <- getLine
  writeLock
  exitSuccess

mainLoop :: IO ()
mainLoop =
  forever $ do
    putStrLn "Rebuilding application..."
    list <- getFileList
    exit <- rawSystem buildcmd buildargs
    case exit of
      ExitFailure _ -> putStrLn "Build failure, pausing..."
      _ -> do
        removeLock
        putStrLn $ "Starting development server: " ++
          runcmd ++ concat (" ":runargs)
        (_,_,_,ph) <- createProcess $ proc runcmd runargs
        watchTid <- forkIO . try_ $ do
          watchForChanges list
          putStrLn "Stopping development server..."
          writeLock
          threadDelay delay
          putStrLn "Terminating development server..."
          terminateProcess ph
        ec <- waitForProcess ph
        putStrLn $ "Exit code: " ++ show ec
        Ex.throwTo watchTid (userError "process finished")
    watchForChanges list



getFileList :: IO FileList
getFileList = do
    files <- findHaskellFiles "."
    fmap Map.fromList $ flip mapM files $ \f -> do
        fs <- getFileStatus f
        return (f, modificationTime fs)

watchForChanges :: FileList -> IO ()
watchForChanges list = do
    newList <- getFileList
    if list /= newList
      then return ()
      else threadDelay delay >> watchForChanges list

checkDevelFile :: IO ()
checkDevelFile = do
  e <- doesFileExist "devel.hs"
  when (not e) $ failWith "file devel.hs not found"
failWith :: String -> IO a
failWith msg = do
    putStrLn $ "ERROR: " ++ msg
    exitFailure


try_ :: forall a. IO a -> IO ()
try_ x = (Ex.try x :: IO (Either Ex.SomeException a)) >> return ()


--
-- from Build.hs
--
findHaskellFiles :: FilePath -> IO [FilePath]
findHaskellFiles path = do
    contents <- getDirectoryContents path
    fmap concat $ mapM go contents
  where
    go ('.':_)          = return []
    go ('c':"abal-dev") = return []
    go ('d':"ist")      = return []
    go x = do
        let y = path </> x
        d <- doesDirectoryExist y
        if d
            then findHaskellFiles y
            else if ".hs" `isSuffixOf` x || ".lhs" `isSuffixOf` x
                    then return [y]
                    else return []