{-# LANGUAGE OverloadedStrings, OverloadedLabels, PatternSynonyms #-}
-- |
-- Module: WildBind.Indicator
-- Description: Graphical indicator for WildBind
-- Maintainer: Toshio Ito <debug.ito@gmail.com>
-- 
-- This module exports the 'Indicator', a graphical interface that
-- explains the current bindings to the user. The 'Indicator' uses
-- 'optBindingHook' in 'Option' to receive the current bindings from
-- wild-bind.
module WildBind.Indicator
       ( -- * Construction
         withNumPadIndicator,
         -- * Execution
         wildBindWithIndicator,
         -- * Low-level function
         bindingHook,
         -- * Indicator type and its actions
         Indicator,
         updateDescription,
         getPresence,
         setPresence,
         togglePresence,
         quit,
         -- ** Conversion
         adaptIndicator,
         -- ** Binding
         toggleBinding,
         -- * Generalization of number pad types
         NumPadPosition(..)
       ) where

import Control.Applicative ((<$>))
import Control.Concurrent
  (rtsSupportsBoundThreads, newEmptyMVar, putMVar, takeMVar)
import Control.Concurrent.Async (withAsync)
import Control.Exception (throwIO, finally)
import Control.Monad (void, forM_)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask)
import Data.IORef (newIORef, readIORef)
import qualified Data.Map as M
import Data.Monoid (mconcat, First(First))
import Data.Text (Text, pack)
import Data.Word (Word32)
import System.IO (stderr, hPutStrLn)
import System.Environment (getArgs)

import WildBind ( ActionDescription, Option(optBindingHook),
                  FrontEnd(frontDefaultDescription), Binding, Binding',
                  binding, Action(Action),
                  wildBind', defOption
                )
import WildBind.Input.NumPad (NumPadUnlocked(..), NumPadLocked(..))

import Paths_wild_bind_indicator (getDataFileName)


---- Imports about Gtk
import GI.Gdk.Functions (threadsAddIdle)
import GI.GLib.Constants (pattern PRIORITY_DEFAULT)
import GI.Gtk 
  ( -- Data.GI.Base.Attributes
    AttrOp((:=))
  )
import qualified GI.Gtk as GIAttr (set, get, on)
import GI.Gtk.Enums (WindowType(..), Justification(..))
import qualified GI.Gtk.Functions as GIFunc
import GI.Gtk.Objects.Button (buttonNew, buttonSetAlignment)
import GI.Gtk.Objects.CheckMenuItem (checkMenuItemNewWithMnemonic, checkMenuItemSetActive)
import GI.Gtk.Objects.Container (containerAdd)
import GI.Gtk.Objects.Label (Label, labelNew, labelSetLineWrap, labelSetJustify, labelSetText)
import GI.Gtk.Objects.Menu (Menu, menuNew, menuPopup)
import GI.Gtk.Objects.MenuItem (menuItemNewWithMnemonic)
import GI.Gtk.Objects.Misc (miscSetAlignment)
import GI.Gtk.Objects.StatusIcon (statusIconNewFromFile)
import GI.Gtk.Objects.Table (Table, tableNew, tableAttachDefaults)
import GI.Gtk.Objects.Widget (Widget, widgetSetSizeRequest, widgetShowAll, widgetHide)
import GI.Gtk.Objects.Window
  ( Window, windowNew, windowSetKeepAbove, windowSetTitle, windowMove
  )


-- | Indicator interface. @s@ is the front-end state, @i@ is the input
-- type.
data Indicator s i =
  Indicator
  { updateDescription :: i -> ActionDescription -> IO (),
    -- ^ Update and show the description for the current binding.
    
    getPresence :: IO Bool,
    
    -- ^ Get the current presence of the indicator. Returns 'True' if
    -- it's present.
    
    setPresence :: Bool -> IO (),
    -- ^ Set the presence of the indicator.

    quit :: IO (),
    -- ^ Destroy the indicator. This usually means quitting the entire
    -- application.

    allButtons :: [i]
    -- ^ list of all buttons on which the indicator displays
    -- descriptions.
  }

-- | Toggle the presence of the indicator.
togglePresence :: Indicator s i -> IO ()
togglePresence ind = (setPresence ind . not) =<< getPresence ind

-- | Convert actions in the input 'Indicator' so that those actions
-- can be executed from a non-GTK-main thread.
transportIndicator :: Indicator s i -> Indicator s i
transportIndicator ind = ind { updateDescription = \i d -> postGUIAsync $ updateDescription ind i d,
                               getPresence = postGUISync $ getPresence ind,
                               setPresence = \visible -> postGUIAsync $ setPresence ind visible,
                               quit = postGUISync $ quit ind
                             }


-- | Something that can be mapped to number pad's key positions.
class NumPadPosition a where
  toNumPad :: a -> NumPadLocked

instance NumPadPosition NumPadLocked where
  toNumPad = id

instance NumPadPosition NumPadUnlocked where
  toNumPad input = case input of
    NumInsert -> NumL0
    NumEnd -> NumL1
    NumDown -> NumL2
    NumPageDown -> NumL3
    NumLeft -> NumL4
    NumCenter -> NumL5
    NumRight -> NumL6
    NumHome -> NumL7
    NumUp -> NumL8
    NumPageUp -> NumL9
    NumDivide -> NumLDivide
    NumMulti -> NumLMulti
    NumMinus -> NumLMinus
    NumPlus -> NumLPlus
    NumEnter -> NumLEnter
    NumDelete -> NumLPeriod

-- | Data type keeping read-only config for NumPadIndicator.
data NumPadConfig =
  NumPadConfig { confButtonWidth, confButtonHeight :: Int,
                 confWindowX, confWindowY :: Int,
                 confIconPath :: FilePath
               }

numPadConfig :: IO NumPadConfig
numPadConfig = do
  icon <- getDataFileName "icon.svg"
  return NumPadConfig
    { confButtonWidth = 70,
      confButtonHeight = 45,
      confWindowX = 0,
      confWindowY = 0,
      confIconPath = icon
    }

-- | Contextual monad for creating NumPadIndicator
type NumPadContext = ReaderT NumPadConfig IO

-- | Initialize the indicator and run the given action.
-- 
-- The executable must be compiled by ghc with __@-threaded@ option enabled.__
-- Otherwise, it aborts.
withNumPadIndicator :: (NumPadPosition i, Enum i, Bounded i) => (Indicator s i -> IO ()) -> IO ()
withNumPadIndicator action = if rtsSupportsBoundThreads then impl else error_impl where
  error_impl = throwIO $ userError "You need to build with -threaded option when you use WildBind.Indicator.withNumPadIndicator function."
  textArgs = fmap (map pack) $ getArgs
  impl = do
    void $ (GIFunc.init . Just) =<< textArgs
    conf <- numPadConfig
    indicator <- createMainWinAndIndicator conf
    status_icon <- createStatusIcon conf indicator
    status_icon_ref <- newIORef status_icon
    withAsync (asyncAction indicator) $ \_ -> do
      GIFunc.main
      void $ readIORef status_icon_ref -- to prevent status_icon from being garbage-collected. See https://github.com/gtk2hs/gtk2hs/issues/60
  createMainWinAndIndicator conf = flip runReaderT conf $ do
    win <- newNumPadWindow
    (tab, updater) <- newNumPadTable
    containerAdd win tab
    let indicator = Indicator
          { updateDescription = \i d -> updater i d,
            getPresence = GIAttr.get win #visible,
            setPresence = \visible -> if visible then widgetShowAll win else widgetHide win,
            quit = GIFunc.mainQuit,
            allButtons = enumFromTo minBound maxBound
          }
    void $ GIAttr.on win #deleteEvent $ \_ -> do
      widgetHide win
      return True -- Do not emit 'destroy' signal
    return indicator
  asyncAction indicator =
    (action $ transportIndicator indicator) `finally` (postGUIAsync GIFunc.mainQuit) 
  createStatusIcon conf indicator = do
    status_icon <- statusIconNewFromFile $ confIconPath conf
    void $ GIAttr.on status_icon #popupMenu $ \button time -> do
      menu <- makeStatusMenu indicator
      menuPopup menu (Nothing :: Maybe Widget) (Nothing :: Maybe Widget) Nothing button time
    return status_icon


-- | Run 'WildBind.wildBind' with the given 'Indicator'. 'ActionDescription's
-- are shown by the 'Indicator'.
wildBindWithIndicator :: Ord i => Indicator s i -> Binding s i -> FrontEnd s i -> IO ()
wildBindWithIndicator ind b front = wildBind' (defOption { optBindingHook = bindingHook ind front }) b front

-- | Create an action appropriate for 'optBindingHook' in 'Option'
-- from 'Indicator' and 'FrontEnd'.
bindingHook :: Ord i => Indicator s1 i -> FrontEnd s2 i -> [(i, ActionDescription)] -> IO ()
bindingHook ind front bind_list = forM_ (allButtons ind) $ \input -> do
  let desc = M.findWithDefault (frontDefaultDescription front input) input (M.fromList bind_list)
  updateDescription ind input desc
                       
  
newNumPadWindow :: NumPadContext Window
newNumPadWindow = do
  win <- windowNew WindowTypeToplevel
  windowSetKeepAbove win True
  GIAttr.set win [ #skipPagerHint := True,
                   #skipTaskbarHint := True,
                   #acceptFocus := False,
                   #focusOnMap := False
                 ]
  windowSetTitle win "WildBind Description"
  win_x <- (fromIntegral . confWindowX) <$> ask
  win_y <- (fromIntegral . confWindowY) <$> ask
  windowMove win win_x win_y
  return win

-- | Get the action to describe @i@, if that @i@ is supported. This is
-- a 'Monoid', so we can build up the getter by 'mconcat'.
type DescriptActionGetter i = i -> First (ActionDescription -> IO ())

newNumPadTable :: NumPadPosition i => NumPadContext (Table, (i -> ActionDescription -> IO ()))
newNumPadTable = do
  tab <- tableNew 5 4 False
  -- NumLock is unboundable, so it's treatd in a different way from others.
  (\label -> labelSetText label "NumLock") =<< addButton tab 0 1 0 1
  descript_action_getter <-
    fmap mconcat $ sequence $
      [ getter NumLDivide $ addButton tab 1 2 0 1,
        getter NumLMulti $ addButton tab 2 3 0 1,
        getter NumLMinus $ addButton tab 3 4 0 1,
        getter NumL7 $ addButton tab 0 1 1 2,
        getter NumL8 $ addButton tab 1 2 1 2,
        getter NumL9 $ addButton tab 2 3 1 2,
        getter NumLPlus $ addButton tab 3 4 1 3,
        getter NumL4 $ addButton tab 0 1 2 3,
        getter NumL5 $ addButton tab 1 2 2 3,
        getter NumL6 $ addButton tab 2 3 2 3,
        getter NumL1 $ addButton tab 0 1 3 4,
        getter NumL2 $ addButton tab 1 2 3 4,
        getter NumL3 $ addButton tab 2 3 3 4,
        getter NumLEnter $ addButton tab 3 4 3 5,
        getter NumL0 $ addButton tab 0 2 4 5,
        getter NumLPeriod $ addButton tab 2 3 4 5
      ]
  let description_updater = \input -> case descript_action_getter $ toNumPad input of
        First (Just act) -> act
        First Nothing -> const $ return ()
  return (tab, description_updater)
  where
    getter :: Eq i => i -> NumPadContext Label -> NumPadContext (DescriptActionGetter i)
    getter bound_key get_label = do
      label <- get_label
      return $ \in_key -> First (if in_key == bound_key then Just $ labelSetText label else Nothing)

addButton :: Table -> Word32 -> Word32 -> Word32 -> Word32 -> NumPadContext Label
addButton tab left right top bottom = do
  lab <- labelNew Nothing
  labelSetLineWrap lab True
  miscSetAlignment lab 0 0.5
  labelSetJustify lab JustificationLeft
  button <- buttonNew
  buttonSetAlignment button 0 0.5
  containerAdd button lab
  tableAttachDefaults tab button left right top bottom
  bw <- (fromIntegral . confButtonWidth) <$> ask
  bh <- (fromIntegral . confButtonHeight) <$> ask
  widgetSetSizeRequest lab (bw * fromIntegral (right - left)) (bh * fromIntegral (bottom - top))
  return lab

makeStatusMenu :: Indicator s i -> IO Menu
makeStatusMenu ind = impl where
  impl = do
    menu <- menuNew
    containerAdd menu =<< makeQuitItem
    containerAdd menu =<< makeToggler
    return menu
  makeQuitItem = do
    quit_item <- menuItemNewWithMnemonic "_Quit"
    widgetShowAll quit_item
    void $ GIAttr.on quit_item #activate (quit ind)
    return quit_item
  makeToggler = do
    toggler <- checkMenuItemNewWithMnemonic "_Toggle description"
    widgetShowAll toggler
    checkMenuItemSetActive toggler =<< getPresence ind
    void $ GIAttr.on toggler #toggled (togglePresence ind)
    return toggler

-- | Map input type of 'Indicator', so that it can adapt to the new
-- input type @i'@.
--
-- If the contra-mapper function returns 'Nothing', those input
-- symbols are ignored by the 'Indicator'.
--
-- @since 0.2.0.0
adaptIndicator :: (i -> i') -- ^ mapper function
               -> (i' -> Maybe i) -- ^ contra-mapper function
               -> Indicator s i -- ^ original
               -> Indicator s i' -- ^ adapted indicator
adaptIndicator mapper cmapper ind =
  ind { updateDescription = newDesc,
        allButtons = map mapper $ allButtons ind
      }
  where
    newDesc input = case cmapper input of
      Nothing -> const $ return ()
      Just orig_input -> updateDescription ind orig_input

-- | A binding that toggles presence of the 'Indicator'.
--
-- @since 0.2.0.0
toggleBinding :: (NumPadPosition i, Ord i, Enum i, Bounded i)
              => Indicator s i
              -> NumPadLocked -- ^ the button to bind the 'togglePresence' action
              -> Binding' bs fs i
toggleBinding ind button = binding $ map (\input -> (input, Action "Toggle description" $ togglePresence ind)) help_likes
  where
    help_likes = filter ((== button) . toNumPad) $ enumFromTo minBound maxBound


-- | Schedule the given action to be executed by Gdk. The given action
-- can include manipulation of Gtk+ objects. This function can be
-- called by a thread that is different from the Gtk+ main loop
-- thread. This function doesn't wait for the given action to finish.
--
-- See https://github.com/haskell-gi/haskell-gi/wiki/Using-threads-in-Gdk-and-Gtk--programs
postGUIAsync :: IO () -> IO ()
postGUIAsync action = void $ threadsAddIdle PRIORITY_DEFAULT (action >> return False)

-- | Similar to 'postGUIAsync', but this function waits for the action
-- to finish.
postGUISync :: IO a -> IO a
postGUISync action = do
  mret <- newEmptyMVar
  postGUIAsync $ do
    ret <- action
    putMVar mret ret
  takeMVar mret