{-# 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
       , modifyProject
       ) 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 System.Directory (setCurrentDirectory, getHomeDirectory, makeAbsolute)
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 XPConfig 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 c DirMode _) =
    let xpt = directoryMultipleModes' (complCaseSensitivity c) "" (const $ return ())
    in completionFunction xpt
  completionFunction (ProjectPrompt c _ ns) = mkComplFunFromList' c 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
    dir <- io $ makeAbsolute dir'
    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 <$> 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 <$> gets (W.workspaces . windowset)
  ps <- XS.gets projects

  let names = sort (Map.keys ps `union` ws)
      modes = map (\m -> XPT $ ProjectPrompt c 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