BrowserPage.hs

{-  
 *  Programmer:	Piotr Borek
 *  E-mail:     piotrborek@op.pl
 *  Copyright 2014 Piotr Borek
 *
 *  Distributed under the terms of the GPL (GNU Public License)
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, write to the Free Software
 *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
-}

module Mp.UI.BrowserPage (
    BrowserPage (..),
    BrowserPageWidget,
    makeUIBrowserPage
) where

import Graphics.Vty.Widgets.All
import Graphics.Vty hiding (Button)

import qualified Data.HashMap.Strict as Map
import qualified Data.Text as T
import Data.ConfigFile
import Data.List
import Data.Maybe
import Data.Functor
import System.Directory
import System.FilePath.Posix
import Control.Monad
import Control.Concurrent

import Mp.Utils.Colors
import Mp.Utils.Exception
import Mp.Utils.Utils
import Mp.Configuration.Configuration
import Mp.UI.QueuePage

type BrowserPageWidget = Widget (List String FormattedText)

data BrowserPage = BrowserPage {
    browserPageWidget     :: BrowserPageWidget,
    browserPageFocusGroup :: Widget FocusGroup,
    browserPageReset      :: IO ()
}

data BrowserState = BrowserState {
    topDir   :: !String,
    dirCache :: Map.HashMap String String
}

makeUIBrowserPage :: ConfigParser -> QueuePage -> IO BrowserPage
makeUIBrowserPage conf queuePage = do
    fg <- newFocusGroup

    lst <- newList (browserActiveAttribute conf ) 1
           >>= withBrowserBgAttribute conf

    let musicDir = getMusicDirectory conf
    setCurrentDirectory musicDir

    browserState <- newMVar BrowserState {
        topDir = musicDir,
        dirCache = Map.empty
    }
    addAllFilesToList lst musicDir

    _ <- addToFocusGroup fg lst
    _ <- addToFocusGroup fg lst

    let keyHandler = \_ k _ ->
            case k of
                KEnter -> do
                    maybeSel <- getSelected lst
                    let (_, (value, _)) = fromJust maybeSel 
                    modifyMVar_ browserState $ changeDirectory lst value
                    return True

                KASCII '!' -> do
                    modifyMVar_ browserState $ changeDirectory lst musicDir
                    return True

                KASCII '@' -> do
                    modifyMVar_ browserState $ changeDirectory lst ".."
                    return True

                KASCII ' ' -> do
                    selectCurrentFile lst
                    return True

                KASCII 'd' -> do
                    removeCurrentFile lst
                    return True

                _ -> return False

    lst `onKeyPressed` keyHandler

    return BrowserPage {
        browserPageWidget     = lst,
        browserPageFocusGroup = fg,
        browserPageReset      = resetBrowser lst browserState
    }
    where
        addFileToList list text = addToList list text =<< (plainText (T.pack text) >>= withBrowserFileAttribute conf)
        addDirToList list text = addToList list text =<< (plainText (T.pack text) >>= withBrowserDirectoryAttribute conf)

        addAllFilesToList list dir = do
            clearList list

            files <- sort <$> getDirectoryContents dir

            forM_ files $ \file -> do
                exists <- doesDirectoryExist $ dir </> file
                when (and [exists, file /= "."]) $ addDirToList list file

            forM_ files $ \file -> do
                exists <- doesFileExist $ dir </> file
                when exists $ addFileToList list file

        changeDirectory list dir st = do
            let oldDir = topDir st
            ok <- try' $ setCurrentDirectory $ oldDir </> dir
            if (isJust ok)
                then do
                    newDir <- getCurrentDirectory
                    let newSt = if dir == ".."
                                    then
                                        st {
                                            topDir = newDir
                                        }
                                    else
                                        st {
                                            topDir   = newDir,
                                            dirCache = Map.insert oldDir dir $ dirCache st
                                        }
                    addAllFilesToList list newDir
                    when (dir == "..") $ do
                        let maybeVal = Map.lookup newDir $ dirCache newSt
                        when (isJust maybeVal) $ do
                            maybeIndex <- listFindFirst list $ fromJust maybeVal
                            case maybeIndex of
                                Just index -> setSelected list index
                                Nothing    -> return ()
                    return newSt
                else
                    return st

        selectCurrentFile list = do
            maybeSel <- getSelected list
            when (isJust maybeSel) $ do
                let (index, (file, item)) = fromJust maybeSel
                currDir <- getCurrentDirectory
                when (currDir /= "..") $ do
                    _ <- withBrowserSelectedAttribute conf item
                    setSelected list $ succ index
                    addAllFiles currDir file
                    return ()

        addAllFiles dir file
            | file == "."  = return ()
            | file == ".." = return ()
            | otherwise    = do
                exists <- doesDirectoryExist $ dir </> file
                if exists
                    then do
                        let newDir = dir </> file
                        files <- try' (sort <$> getDirectoryContents newDir)
                        when (isJust files) $ do
                            forM_ (fromJust files) $ \f -> do
                                addAllFiles newDir f
                    else
                        queuePageAdd queuePage dir file

        removeCurrentFile list = do
            maybeSel <- getSelected list
            when (isJust maybeSel) $ do
                let (index, (file, item)) = fromJust maybeSel
                currDir <- getCurrentDirectory
                when (currDir /= "..") $ do
                    whenM (doesDirectoryExist $ currDir </> file) $ do
                        _ <- withBrowserDirectoryAttribute conf item
                        return ()

                    whenM (doesFileExist $ currDir </> file) $ do
                        _ <- withBrowserFileAttribute conf item
                        return ()

                    setSelected list $ succ index
                    removeAllFiles currDir file
                    return ()

        removeAllFiles dir file
            | file == "."  = return ()
            | file == ".." = return ()
            | otherwise    = do
                exists <- doesDirectoryExist $ dir </> file
                if exists
                    then do
                        let newDir = dir </> file
                        files <- try' (sort <$> getDirectoryContents newDir)
                        when (isJust files) $ do
                            forM_ (fromJust files) $ \f -> do
                                removeAllFiles newDir f
                    else
                        queuePageRemove queuePage dir file

        resetBrowser widget browserState = do
            st       <- readMVar browserState
            maybeSel <- getSelected widget
            addAllFilesToList widget $ topDir st
            when (isJust maybeSel) $ do
                let (sel, _) = fromJust maybeSel
                setSelected widget sel