{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
module Run (main) where

import           Prelude hiding (getChar)
import           UI.Curses hiding (err, wgetch, wget_wch, ungetch, mvaddstr)
import qualified UI.Curses as Curses
import           Control.Exception (finally)
import           Data.Maybe

import qualified Network.MPD as MPD hiding (withMPD)
import           Network.MPD (Seconds, MonadMPD)

import           Control.Monad.State.Strict (unless, lift, liftIO, forever, MonadIO)
import           Data.Foldable (forM_)
import           Data.List hiding (filter)
import           Data.IORef
import           System.Directory (doesFileExist)
import           Control.Concurrent (forkIO)
import           Text.Printf (printf)

import qualified WindowLayout
import qualified Input
import           Input (HistoryNamespace(..), noCompletion)
import           Macro
import qualified PlaybackState
import           Option (getOptions)
import           Util (expandHome)
import           Queue
import           Vimus
import qualified Command as Command
import qualified Song

------------------------------------------------------------------------
-- The main event loop
--
mainLoop :: Window -> Queue Notify -> IO Window -> Vimus ()
mainLoop window queue onResize = Input.runInputT wget_wch . forever $ do
  c <- Input.getChar
  case c of
    -- a command
    ':' -> do
      input <- Input.getInputLine_ window ":" CommandHistory Command.autoComplete
      unless (null input) $ lift $ do
        Command.runCommand input
        renderMainWindow

    -- search
    '/' -> do
      input <- Input.getInputLine searchPreview window "/" SearchHistory noCompletion
      unless (null input) $ lift $ do
        search input

      -- window has to be redrawn, even if input is Nothing, otherwise the
      -- preview will remain on the screen
      lift renderMainWindow

    -- filter
    'F' -> do
      widget <- lift getCurrentWidget
      cache  <- liftIO $ newIORef []
      input <- Input.getInputLine (filterPreview widget cache) window "filter: " SearchHistory noCompletion
      unless (null input) $ lift $ do
        filter_ input

      -- window has to be redrawn, even if input is Nothing, otherwise the
      -- preview will remain on the screen
      lift renderMainWindow

    -- macro expansion
    _   -> do
      macros <- lift getMacros
      expandMacro macros c
  where
    searchPreview term = do
      widget <- getCurrentWidget
      renderToMainWindow (searchItem widget Forward term)

    filterPreview :: AnyWidget -> IORef [(String, AnyWidget)] -> String -> Vimus ()
    filterPreview widget cache term = do
      w <- liftIO $ do
        modifyIORef cache updateCache
        -- cache now contains results for all `inits term', in reverse order
        r <- readIORef cache
        (return . snd . head) r
      renderToMainWindow w
      where
        updateCache :: [(String, AnyWidget)] -> [(String, AnyWidget)]
        updateCache old@((t, w):xs)
          | term == t           = old
          | t `isPrefixOf` term = (term, filterItem w term) : old
          | otherwise           = updateCache xs
        -- applying filterItem to widget even if term is "" is crucial,
        -- otherwise the position won't be set to 0
        updateCache []               = [(term, filterItem widget term)]

    -- |
    -- A wrapper for wget_wch, that keeps the event queue running and handles
    -- resize events.
    wget_wch = do
      handleNotifies queue
      c <- liftIO (Curses.wget_wch window)
      continue c
      where
        resize =  liftIO onResize >>= setMainWindow
        continue c
          | c == '\0'      = wget_wch
          | c == keyResize = resize >> wget_wch
          | otherwise      = return c


data Notify = NotifyEvent Event
            | NotifyError String
            | NotifyAction (Vimus ())


handleNotifies :: Queue Notify -> Vimus ()
handleNotifies q = do
  xs <- liftIO (takeAllQueue q)
  forM_ xs $ \x -> case x of
    NotifyEvent   event -> sendEvent event >> renderMainWindow
    NotifyError     err -> error err
    NotifyAction action -> action


------------------------------------------------------------------------
-- mpd status

updateStatus :: (MonadIO m) => Window -> Window -> Maybe MPD.Song -> MPD.Status -> m ()
updateStatus songWindow playWindow mSong status = do

  putString songWindow song ""
  putString playWindow playState tags
  where
    song = fromMaybe "none" (Song.title =<< mSong)

    playState = stateSymbol ++ " " ++ formatTime current ++ " / " ++ formatTime total
                ++ volume
      where
        (current, total) = PlaybackState.elapsedTime status
        stateSymbol = case MPD.stState status of
          MPD.Playing -> "|>"
          MPD.Paused  -> "||"
          MPD.Stopped -> "[]"

        volume = maybe "" ((" vol: " ++) . show) (MPD.stVolume status)

    tags = intercalate ", " . map snd . filter (($ status) . fst) $ tagList

    tagList :: [(MPD.Status -> Bool, String)]
    tagList = [
          (isJust . MPD.stUpdatingDb, "updating")
        , (MPD.stRepeat             ,   "repeat")
        , (MPD.stRandom             ,   "random")
        , (MPD.stSingle             ,   "single")
        , (MPD.stConsume            ,  "consume")
        ]

    formatTime :: Seconds -> String
    formatTime s = printf "%02d:%02d" minutes seconds
      where
        (minutes, seconds) = s `divMod` 60

    putString :: (MonadIO m) => Window -> String -> String -> m ()
    putString window string endstring = liftIO $ do
      (_, sizeX) <- getmaxyx window
      mvwaddstr window 0 0 string
      wclrtoeol window
      mvwaddstr window 0 (sizeX - length endstring) endstring
      wrefresh window
      return ()


------------------------------------------------------------------------
-- Tabs

notifyEvent :: MonadIO m => Queue Notify -> Event -> m ()
notifyEvent q e = liftIO $ q `putQueue` NotifyEvent e

notifyLibraryChanged :: (MonadIO m, MonadMPD m) => Queue Notify -> m ()
notifyLibraryChanged q = MPD.listAllInfo "" >>= notifyEvent q . EvLibraryChanged

------------------------------------------------------------------------
-- Program entry point

run :: Maybe String -> Maybe String -> Bool -> IO ()
run host port ignoreVimusrc = do

  (onResize, tw, mw, songStatusWindow, playStatusWindow, inputWindow) <- WindowLayout.create

  let initialize = do

        -- load default mappings
        Command.runCommand "runtime default-mappings"

        -- source ~/.vimusrc
        r <- liftIO (expandHome "~/.vimusrc")
        flip (either printError) r $ \vimusrc -> do
          exists  <- liftIO (doesFileExist vimusrc)
          if not ignoreVimusrc && exists
            then
              Command.source vimusrc
            else liftIO $ do
              -- only print this if .vimusrc does not exist, otherwise it would
              -- overwrite possible config errors
              mvwaddstr inputWindow 0 0 "type :quit to exit, :help for help"
              return ()

        liftIO $ do
          -- It is critical, that this is only done after sourcing .vimusrc,
          -- otherwise :color commands are not effective and the user will see an
          -- annoying flicker!
          wrefresh inputWindow
          wrefresh songStatusWindow
          wrefresh playStatusWindow

        renderTabBar
        renderMainWindow

        return ()

  queue <- newQueue
  let withMPD_notifyError = withMPD (putQueue queue . NotifyError)

  -- watch for playback and playlist changes
  forkIO $ withMPD_notifyError $ PlaybackState.onChange
    (notifyEvent queue EvPlaylistChanged)
    (notifyEvent queue . EvCurrentSongChanged)
    (\song -> putQueue queue . NotifyAction . updateStatus songStatusWindow playStatusWindow song)

  -- watch for library updates
  forkIO $ withMPD_notifyError $ do
    notifyLibraryChanged queue
    forever (MPD.idle [MPD.DatabaseS] >> notifyLibraryChanged queue)


  -- We use a timeout of 10 ms, but be aware that the actual timeout may be
  -- different due to a combination of two facts:
  --
  -- (1) ncurses getch (and related functions) returns when a signal occurs
  -- (2) the threaded GHC runtime uses signals for bookkeeping
  --     (see +RTS -V option)
  --
  -- So the effective timeout is swayed by the runtime.
  --
  -- We may workaround this in the future, as suggest here:
  -- http://www.serpentine.com/blog/2010/09/04/dealing-with-fragile-c-libraries-e-g-mysql-from-haskell/
  wtimeout inputWindow 10

  keypad inputWindow True

  withMPD error $ runVimus Command.tabs mw inputWindow tw (initialize >> mainLoop inputWindow queue onResize)
  where
    withMPD onError action = do
      result <- MPD.withMPD_ host port action
      case result of
        Left  e  -> onError (show e)
        Right () -> return ()


main :: IO ()
main = do

  (host, port, ignoreVimusrc) <- getOptions

  -- recommended in ncurses manpage
  initscr
  raw
  noecho

  -- suggested  in ncurses manpage
  -- nonl
  intrflush stdscr True

  -- enable colors
  use_default_colors
  start_color

  curs_set 0

  finally (run host port ignoreVimusrc) endwin