context.hs 2.54 KB
Newer Older
Henrik Tramberend's avatar
Henrik Tramberend committed
1 2
{-- Author: Henrik Tramberend <henrik@tramberend.de> --} 

3 4 5 6
{-# LANGUAGE DeriveDataTypeable #-}

module Context
       (ActionContext(..), makeActionContext, setActionContext, getFilesToWatch,
7 8
        setFilesToWatch, getServerHandle, setServerHandle, getProjectDirs,
        actionContextKey, getActionContext)
9 10
       where

11
import Control.Monad ()
12 13
import Development.Shake
import Data.Dynamic
14
import Data.Maybe ()
15
import Data.IORef
16
import Data.Typeable ()
17 18
import qualified Data.HashMap.Lazy as HashMap
import System.Process
19
import Project
20 21 22 23

data ActionContext =
  ActionContext {ctxFilesToWatch :: IORef [FilePath]
                ,ctxServerHandle :: IORef (Maybe ProcessHandle)
24 25
                ,ctxDirs :: ProjectDirs}
  deriving (Typeable, Show)
26

27 28
instance Show (IORef a) where
  show _ = "IORef"
29 30 31 32 33

defaultActionContext :: IO ActionContext
defaultActionContext = do
  files <- newIORef []
  server <- newIORef Nothing
34
  return $ ActionContext files server (ProjectDirs "" "" "" "")
35 36 37 38 39 40

actionContextKey :: IO TypeRep
actionContextKey = do
  ctx <- liftIO $ defaultActionContext
  return $ typeOf ctx

41 42
makeActionContext :: ProjectDirs -> IO ActionContext
makeActionContext dirs =
43 44
  do ctx <- defaultActionContext
     return $
45
       ctx { ctxDirs = dirs }
46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84

setActionContext :: ActionContext -> ShakeOptions -> IO ShakeOptions
setActionContext ctx options =
  do key <- liftIO $ actionContextKey
     let extra = HashMap.insert key (toDyn ctx) $ HashMap.empty
     return options {shakeExtra = extra}

getActionContext :: Action ActionContext
getActionContext = do
  options <- getShakeOptions
  key <- liftIO $ actionContextKey
  let extra = shakeExtra options
  let dyn = case HashMap.lookup key extra of
              Just d -> d
              Nothing -> error "Error looking up action context"
  return $ case fromDynamic dyn of
             Just d -> d
             Nothing -> error "Error upcasting action context"

getFilesToWatch :: Action [FilePath]
getFilesToWatch = do
  ctx <- getActionContext
  liftIO $ readIORef $ ctxFilesToWatch ctx

setFilesToWatch :: [FilePath] -> Action ()
setFilesToWatch files = do
  ctx <- getActionContext
  liftIO $ writeIORef (ctxFilesToWatch ctx) files

getServerHandle :: Action (Maybe ProcessHandle)
getServerHandle = do
  ctx <- getActionContext
  liftIO $ readIORef $ ctxServerHandle ctx

setServerHandle :: Maybe ProcessHandle -> Action ()
setServerHandle handle = do
  ctx <- getActionContext
  liftIO $ writeIORef (ctxServerHandle ctx) handle

85 86
getProjectDirs :: Action ProjectDirs
getProjectDirs =
87
  do ctx <- getActionContext
88
     return $ ctxDirs ctx
89