{-# LANGUAGE DeriveDataTypeable #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Actions.DynamicProjects
-- Copyright   :  (c) Peter J. Jones
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  Peter Jones <pjones@devalot.com>
-- Stability   :  unstable
-- Portability :  not portable
--
-- Imbues workspaces with additional features so they can be treated
-- as individual project areas.
--------------------------------------------------------------------------------
module XMonad.Actions.DynamicProjects
       ( -- * Overview
         -- $overview

         -- * Usage
         -- $usage

         -- * Types
         Project (..)
       , ProjectName

         -- * Hooks
       , dynamicProjects

         -- * Bindings
       , switchProjectPrompt
       , shiftToProjectPrompt
       , renameProjectPrompt

         -- * Helper Functions
       , switchProject
       , shiftToProject
       , lookupProject
       , currentProject
       , activateProject
       ) where

--------------------------------------------------------------------------------
import Control.Applicative ((<|>))
import Control.Monad (when, unless)
import Data.List (sort, union, stripPrefix)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe, isNothing)
import Data.Monoid ((<>))
import System.Directory (setCurrentDirectory, getHomeDirectory)
import XMonad
import XMonad.Actions.DynamicWorkspaces
import XMonad.Prompt
import XMonad.Prompt.Directory (directoryPrompt)
import XMonad.Prompt.Workspace (Wor(..))
import qualified XMonad.StackSet as W
import qualified XMonad.Util.ExtensibleState as XS

--------------------------------------------------------------------------------
-- $overview
-- Inspired by @TopicSpace@, @DynamicWorkspaces@, and @WorkspaceDir@,
-- @DynamicProjects@ treats workspaces as projects while maintaining
-- compatibility with all existing workspace-related functionality in
-- XMonad.
--
-- Instead of using generic workspace names such as @3@ or @work@,
-- @DynamicProjects@ allows you to dedicate workspaces to specific
-- projects and then switch between projects easily.
--
-- A project is made up of a name, working directory, and a start-up
-- hook.  When you switch to a workspace, @DynamicProjects@ changes
-- the working directory to the one configured for the matching
-- project.  If the workspace doesn't have any windows, the project's
-- start-up hook is executed.  This allows you to launch applications
-- or further configure the workspace/project.
--
-- When using the @switchProjectPrompt@ function, workspaces are
-- created as needed.  This means you can create new project spaces
-- (and therefore workspaces) on the fly.  (These dynamic projects are
-- not preserved across restarts.)
--
-- Additionally, frequently used projects can be configured statically
-- in your XMonad configuration.  Doing so allows you to configure the
-- per-project start-up hook.

--------------------------------------------------------------------------------
-- $usage
-- To use @DynamicProjects@ you need to add it to your XMonad
-- configuration and then configure some optional key bindings.
--
-- > import XMonad.Actions.DynamicProjects
--
-- Start by defining some projects:
--
-- > projects :: [Project]
-- > projects =
-- >   [ Project { projectName      = "scratch"
-- >             , projectDirectory = "~/"
-- >             , projectStartHook = Nothing
-- >             }
-- >
-- >   , Project { projectName      = "browser"
-- >             , projectDirectory = "~/download"
-- >             , projectStartHook = Just $ do spawn "conkeror"
-- >                                            spawn "chromium"
-- >             }
-- >   ]
--
-- Then inject @DynamicProjects@ into your XMonad configuration:
--
-- > main = xmonad $ dynamicProjects projects def
--
-- And finally, configure some optional key bindings:
--
-- >  , ((modm, xK_space), switchProjectPrompt)
-- >  , ((modm, xK_slash), shiftToProjectPrompt)
--
-- For detailed instructions on editing your key bindings, see
-- "XMonad.Doc.Extending#Editing_key_bindings".

--------------------------------------------------------------------------------
type ProjectName  = String
type ProjectTable = Map ProjectName Project

--------------------------------------------------------------------------------
-- | Details about a workspace that represents a project.
data Project = Project
  { projectName      :: !ProjectName    -- ^ Workspace name.
  , projectDirectory :: !FilePath       -- ^ Working directory.
  , projectStartHook :: !(Maybe (X ())) -- ^ Optional start-up hook.
  } deriving Typeable

--------------------------------------------------------------------------------
-- | Internal project state.
data ProjectState = ProjectState
  { projects        :: !ProjectTable
  , previousProject :: !(Maybe WorkspaceId)
  } deriving Typeable

--------------------------------------------------------------------------------
instance ExtensionClass ProjectState where
  initialValue = ProjectState Map.empty Nothing

--------------------------------------------------------------------------------
-- | Add dynamic projects support to the given config.
dynamicProjects :: [Project] -> XConfig a -> XConfig a
dynamicProjects ps c =
  c { startupHook     = startupHook c <> dynamicProjectsStartupHook ps
    , logHook         = logHook c     <> dynamicProjectsLogHook
    }

--------------------------------------------------------------------------------
-- | Log hook for tracking workspace changes.
dynamicProjectsLogHook :: X ()
dynamicProjectsLogHook = do
  name  <- gets (W.tag . W.workspace . W.current . windowset)
  state <- XS.get

  unless (Just name == previousProject state) $ do
    XS.put (state {previousProject = Just name})
    activateProject . fromMaybe (defProject name) $
      Map.lookup name (projects state)

--------------------------------------------------------------------------------
-- | Start-up hook for recording configured projects.
dynamicProjectsStartupHook :: [Project] -> X ()
dynamicProjectsStartupHook ps = XS.modify go
  where
    go :: ProjectState -> ProjectState
    go s = s {projects = update $ projects s}

    update :: ProjectTable -> ProjectTable
    update = Map.union (Map.fromList $ map entry ps)

    entry :: Project -> (ProjectName, Project)
    entry p = (projectName p, addDefaultHook p)

    -- Force the hook to be a @Just@ so that it doesn't automatically
    -- get deleted when switching away from a workspace with no
    -- windows.
    addDefaultHook :: Project -> Project
    addDefaultHook p = p { projectStartHook = projectStartHook p <|>
                                              Just (return ())
                         }

--------------------------------------------------------------------------------
-- | Find a project based on its name.
lookupProject :: ProjectName -> X (Maybe Project)
lookupProject name = Map.lookup name `fmap` XS.gets projects

--------------------------------------------------------------------------------
-- | Fetch the current project (the one being used for the currently
-- active workspace).
currentProject :: X Project
currentProject = do
  name <- gets (W.tag . W.workspace . W.current . windowset)
  proj <- lookupProject name
  return $ fromMaybe (defProject name) proj

--------------------------------------------------------------------------------
-- | Switch to the given project.
switchProject :: Project -> X ()
switchProject p = do
  oldws <- gets (W.workspace . W.current . windowset)
  oldp <- currentProject

  let name = W.tag oldws
      ws   = W.integrate' (W.stack oldws)

  -- If the project we are switching away from has no windows, and
  -- it's a dynamic project, remove it from the configuration.
  when (null ws && isNothing (projectStartHook oldp)) $
    XS.modify (\s -> s {projects = Map.delete name $ projects s})

  appendWorkspace (projectName p)

--------------------------------------------------------------------------------
-- | Prompt for a project name and then switch to it.  Automatically
-- creates a project if a new name is returned from the prompt.
switchProjectPrompt :: XPConfig -> X ()
switchProjectPrompt c = projectPrompt c switch
  where
    switch :: ProjectTable -> ProjectName -> X ()
    switch ps name = case Map.lookup name ps of
      Just p              -> switchProject p
      Nothing | null name -> return ()
              | otherwise -> directoryPrompt dirC "Project Dir: " (mkProject name)

    dirC :: XPConfig
    dirC = c { alwaysHighlight = False } -- Fix broken tab completion.

    mkProject :: ProjectName -> FilePath -> X ()
    mkProject name dir = do
      let p = Project name dir Nothing
      XS.modify $ \s -> s {projects = Map.insert name p $ projects s}
      switchProject p

--------------------------------------------------------------------------------
-- | Shift the currently focused window to the given project.
shiftToProject :: Project -> X ()
shiftToProject p = do
  addHiddenWorkspace (projectName p)
  windows (W.shift $ projectName p)

--------------------------------------------------------------------------------
-- | Prompts for a project name and then shifts the currently focused
-- window to that project.
shiftToProjectPrompt :: XPConfig -> X ()
shiftToProjectPrompt c = projectPrompt c go
  where
    go :: ProjectTable -> ProjectName -> X ()
    go ps name = shiftToProject . fromMaybe (defProject name) $
                 Map.lookup name ps

--------------------------------------------------------------------------------
-- | Prompt for a project name.
projectPrompt :: XPConfig -> (ProjectTable -> ProjectName -> X ()) -> X ()
projectPrompt c f = do
  ws <- map W.tag `fmap` gets (W.workspaces . windowset)
  ps <- XS.gets projects

  let names = sort (Map.keys ps `union` ws)
      label = "Switch or Create Project: "

  mkXPrompt (Wor label) c (mkComplFunFromList' names) (f ps)

--------------------------------------------------------------------------------
-- | Rename the current project.
renameProjectPrompt :: XPConfig -> X ()
renameProjectPrompt c = mkXPrompt (Wor "New Project Name: ") c (return . (:[])) go
  where
    go :: String -> X ()
    go name = do
      p  <- currentProject
      ps <- XS.gets projects
      renameWorkspaceByName name

      let p'  = fromMaybe (p { projectName = name }) $ Map.lookup name ps
          ps' = Map.insert name p' $ Map.delete (projectName p) ps

      XS.modify $ \s -> s {projects = ps'}
      activateProject p'

--------------------------------------------------------------------------------
-- | Activate a project by updating the working directory and
-- possibly running its start-up hook.  This function is automatically
-- invoked when the workspace changes.
activateProject :: Project -> X ()
activateProject p = do
    ws   <- gets (W.integrate' . W.stack . W.workspace . W.current . windowset)
    home <- io getHomeDirectory

    -- Change to the project's directory.
    catchIO (setCurrentDirectory $ expandHome home $ projectDirectory p)

    -- Possibly run the project's startup hook.
    when (null ws) $ fromMaybe (return ()) (projectStartHook p)

  where

    -- Replace an initial @~@ character with the home directory.
    expandHome :: FilePath -> FilePath -> FilePath
    expandHome home dir = case stripPrefix "~" dir of
      Nothing -> dir
      Just xs -> home ++ xs

--------------------------------------------------------------------------------
-- | Default project.
defProject :: ProjectName -> Project
defProject name = Project name "~/" Nothing