{-# 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
       , changeProjectDirPrompt

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

--------------------------------------------------------------------------------
import Control.Applicative ((<|>))
import Control.Monad (when, unless)
import Data.Char (isSpace)
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
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

--------------------------------------------------------------------------------
-- Internal types for working with XPrompt.
data ProjectPrompt = ProjectPrompt ProjectMode [ProjectName]
data ProjectMode = SwitchMode | ShiftMode | RenameMode | DirMode

instance XPrompt ProjectPrompt where
  showXPrompt (ProjectPrompt submode _) =
    case submode of
      SwitchMode -> "Switch or Create Project: "
      ShiftMode  -> "Send Window to Project: "
      RenameMode -> "New Project Name: "
      DirMode    -> "Change Project Directory: "

  completionFunction (ProjectPrompt RenameMode _) = return . (:[])
  completionFunction (ProjectPrompt DirMode _) =
    let xpt = directoryMultipleModes "" (const $ return ())
    in completionFunction xpt
  completionFunction (ProjectPrompt _ ns) = mkComplFunFromList' ns

  modeAction (ProjectPrompt SwitchMode _) buf auto = do
    let name = if null auto then buf else auto
    ps <- XS.gets projects

    case Map.lookup name ps of
      Just p              -> switchProject p
      Nothing | null name -> return ()
              | otherwise -> switchProject (defProject name)

  modeAction (ProjectPrompt ShiftMode _) buf auto = do
    let name = if null auto then buf else auto
    ps <- XS.gets projects
    shiftToProject . fromMaybe (defProject name) $ Map.lookup name ps

  modeAction (ProjectPrompt RenameMode _) name _ =
    when (not (null name) && not (all isSpace name)) $ do
      renameWorkspaceByName name
      modifyProject (\p -> p { projectName = name })

  modeAction (ProjectPrompt DirMode _) buf auto = do
    let dir = if null auto then buf else auto
    modifyProject (\p -> p { projectDirectory = dir })

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

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

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

--------------------------------------------------------------------------------
-- | 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

--------------------------------------------------------------------------------
-- | Modify the current project using a pure function.
modifyProject :: (Project -> Project) -> X ()
modifyProject f = do
  p  <- currentProject
  ps <- XS.gets projects

  -- If a project is renamed to match another project, the old project
  -- will be removed and replaced with this one.
  let new = f p
      ps' = Map.insert (projectName new) new $ Map.delete (projectName p) ps

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

--------------------------------------------------------------------------------
-- | 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)) $ do
    removeWorkspaceByTag name -- also remove the old workspace
    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 = projectPrompt [ SwitchMode
                                    , ShiftMode
                                    , RenameMode
                                    , DirMode
                                    ]

--------------------------------------------------------------------------------
-- | 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 = projectPrompt [ ShiftMode
                                     , RenameMode
                                     , SwitchMode
                                     , DirMode
                                     ]

--------------------------------------------------------------------------------
-- | Rename the current project.
renameProjectPrompt :: XPConfig -> X ()
renameProjectPrompt = projectPrompt [ RenameMode
                                    , DirMode
                                    , SwitchMode
                                    , ShiftMode
                                    ]

--------------------------------------------------------------------------------
-- | Change the working directory used for the current project.
--
-- NOTE: This will only affect new processed started in this project.
-- Existing processes will maintain the previous working directory.
changeProjectDirPrompt :: XPConfig -> X ()
changeProjectDirPrompt = projectPrompt [ DirMode
                                       , SwitchMode
                                       , ShiftMode
                                       , RenameMode
                                       ]

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

  let names = sort (Map.keys ps `union` ws)
      modes = map (\m -> XPT $ ProjectPrompt m names) submodes

  mkXPromptWithModes modes c

--------------------------------------------------------------------------------
-- | 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