BrowserPage.hs

{-
 *  Programmer:	Piotr Borek
 *  E-mail:     piotrborek@op.pl
 *  Copyright 2018 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
-}
{-# LANGUAGE MultiWayIf      #-}
{-# LANGUAGE TemplateHaskell #-}

module Mp.UI.BrowserPage (
    BrowserPageClass,
    BrowserPage,
    castToBrowserPage,
    browserPageNew
) where

import           Control.Lens           (ix, makeLensesFor, (.=), (^.), (^?))
import           Control.Monad
import           Control.Monad.IO.Class
import           Data.List              (elemIndex, isPrefixOf, isSuffixOf,
                                         sort)
import qualified Graphics.Vty           as Vty
import           Simple.UI.All
import           System.Directory       (doesDirectoryExist, doesFileExist,
                                         getCurrentDirectory,
                                         getDirectoryContents,
                                         setCurrentDirectory)
import           System.FilePath.Posix  ((</>))

import           Mp.Player.Client
import           Mp.UI.MpData

newtype BrowserPage = BrowserPage
        { _browserPageParent     :: Widget
        }

makeLensesFor [("_browserPageParent", "browserPageParent")] ''BrowserPage

data FileAttr = FileAttrFile
              | FileAttrDirectory

class BrowserPageClass w where
    castToBrowserPage :: w -> BrowserPage

instance BrowserPageClass BrowserPage where
    castToBrowserPage = id

instance WidgetClass BrowserPage where
    castToWidget = _browserPageParent

    overrideWidget = overrideWidgetHelper browserPageParent

browserPageNew :: UIApp MpData BrowserPage
browserPageNew = do
    mpData <- view appUserData

    let rootMusicDir = mpData ^. mpMusicDirectory
    liftIO $ setCurrentDirectory rootMusicDir

    content <- directoryList rootMusicDir
    attrContent <- attributeNew content

    textListView <- textListViewNew $ \item index -> do
        cont <- readAttr attrContent

        case cont ^? ix index of
            Just (fileAttr, file) -> do
                dir <- liftIO getCurrentDirectory
                set item text $ Just file
                set item itemData $ Just (dir </> file)
                case fileAttr of
                    FileAttrFile      -> do
                        songExists <- liftUIApp mpData $ mpSongExists (dir </> file)
                        if songExists
                            then set item colorForeground $ mpData ^. mpColors . browserSelectedForeground
                            else set item colorForeground $ mpData ^. mpColors . browserFileForeground
                        set item colorStyle DrawStyleNormal
                    FileAttrDirectory -> do
                        set item colorForeground $ mpData ^. mpColors . browserDirForeground
                        set item colorStyle DrawStyleBold
            Nothing -> do
                set item text Nothing
                set item itemData Nothing

    on_ textListView textItemActivated $ \item -> do
        (Just dir) <- get item itemData
        isDir <- liftIO $ doesDirectoryExist dir
        when isDir $
            goToDirectory attrContent textListView dir

    let browser = overrideWidget
                      BrowserPage { _browserPageParent = castToWidget textListView }
                      $ virtualWidgetName .= "browserpage"

    set browser colorForeground $ mpData ^. mpColors . browserFileForeground
    set browser colorBackground $ mpData ^. mpColors . browserBackground
    set browser colorBackgroundSelected $ mpData ^. mpColors . browserActiveBackground

    on_ browser keyPressed $ \key _ ->
        case key of
            Vty.KChar '!' ->
                goToDirectory attrContent textListView rootMusicDir

            Vty.KChar '@' -> do
                dir <- liftIO getCurrentDirectory
                goToDirectory attrContent textListView (dir </> "..")

            Vty.KChar ' ' -> do
                index <- textListViewGetPos textListView
                files <- readAttr attrContent
                dir <- liftIO getCurrentDirectory
                liftUIApp mpData $ browserPageAddSong dir (files !! index)
                textListViewGoDown textListView

            Vty.KChar 'd' -> do
                index <- textListViewGetPos textListView
                files <- readAttr attrContent
                dir <- liftIO getCurrentDirectory
                liftUIApp mpData $ browserPageRemoveSong dir (files !! index)
                textListViewGoDown textListView

            _ ->
                return ()

    return browser
  where
    directoryList currentDir = liftIO $ do
        content <- getDirectoryContents currentDir

        directories <- sort <$> filterM (isDirectory currentDir) content
        files <- sort <$> filterM (isFile currentDir) content

        return $ map (\d -> (FileAttrDirectory, d)) directories ++
                 map (\f -> (FileAttrFile, f)) files

    isDirectory dir file = do
        exists <- doesDirectoryExist $ dir </> file
        return $ exists && file /= "." && (dir </> file /= "/..")

    isFile dir file = doesFileExist $ dir </> file

    goToDirectory attrContent textListView dir = do
        liftIO $ setCurrentDirectory dir
        dir' <- liftIO getCurrentDirectory
        files <- directoryList dir'
        writeAttr attrContent files
        if ".." `isSuffixOf` dir
            then do
                let _selDir = drop (length dir') (take (length dir - 3) dir)
                let selDir = if "/" `isPrefixOf` _selDir then drop 1 _selDir else _selDir
                case elemIndex selDir (fmap snd files) of
                    Nothing    -> return ()
                    Just index -> textListViewCenterAt textListView index (length files)
            else
                textListViewCenterAt textListView 0 (length files)

    browserPageAddSong _ (_, "..") = return ()
    browserPageAddSong dir (fileAttr, file) =
        case fileAttr of
            FileAttrDirectory -> do
                let newDir = dir </> file
                content <- directoryList newDir
                forM_ content $ \f -> browserPageAddSong newDir f

            FileAttrFile -> do
                mpSongAdd (dir </> file)
                clientSendAddFile (dir </> file)

    browserPageRemoveSong _ (_, "..") = return ()
    browserPageRemoveSong dir (fileAttr, file) =
        case fileAttr of
            FileAttrDirectory -> do
                let newDir = dir </> file
                content <- directoryList newDir
                forM_ content $ \f -> browserPageRemoveSong newDir f

            FileAttrFile      -> do
                songInList <- mpSongExists (dir </> file)
                when songInList $ do
                    listIndex <- mpSongRemove (dir </> file)
                    clientSendRemove listIndex