diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -13,15 +13,19 @@
cabal update
cabal install pgdl
-## Command line argument
-
-all arguments passed to the program become keywords to filter videos.
-
## Shortcut keys
q - quit
+
s - list files that similar with the highlighted video
+
Key Right - show the detailed information of the highlighted video
+
Key Left - go back to the previous page
+
Enter - play the video
+
+/ - open a input box to enter a keyword to search
+
+n - sort the current list by name
diff --git a/pgdl.cabal b/pgdl.cabal
--- a/pgdl.cabal
+++ b/pgdl.cabal
@@ -1,6 +1,6 @@
name: pgdl
-version: 7.77
+version: 8.0
license: PublicDomain
license-file: LICENSE
author: sifmelcara
@@ -17,7 +17,7 @@
.
The program will sort the video files and folders by date while files in nginx's download page just sort by name.
.
- For shortcut keys, please visit https://github.com/sifmelcara/pgdl
+ For shortcut keys, please visit
synopsis: pgdownloader
@@ -30,7 +30,7 @@
main-is: Main.hs
other-modules: NameAlgo, Chkcfg, FetchHtml, Getconfig,
Log, RealWorld, PrsVid, Video, GenStat,
- SortVid, CrtInf, AskScene
+ CrtInf, AskScene, UI
build-depends: base == 4.*, process,
directory, bytestring,
tagsoup, network-uri,
diff --git a/src/GenStat.hs b/src/GenStat.hs
--- a/src/GenStat.hs
+++ b/src/GenStat.hs
@@ -19,7 +19,7 @@
where spc :: Int -> T.Text
spc i = T.replicate i " "
-genStat (Folder _ _ date) = do
+genStat (Folder _ _ date) =
return $ T.concat [ spc 3
, date
, spc 5
diff --git a/src/Main.hs b/src/Main.hs
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -12,14 +12,14 @@
import GenStat
import CrtInf
import AskScene
+import UI
-import Data.IORef
-import Data.Maybe
+import qualified Data.Text as T
+import Data.Ord
import Control.Applicative
import Control.Concurrent
import Control.Monad
import System.Exit
-import System.Environment
import Graphics.Vty
import Graphics.Vty.Widgets.All
@@ -31,147 +31,133 @@
c <- newCollection
- lst <- newList 3
+ tmpLst <- newList 3
-- the main list will display on screen
- diskrd <- readVid
+ diskV <- readVid
-- read cache in the disk, if the cache do not exists, return "downloading"
- args <- getArgs
- let diskV = if null args then diskrd
- else dlnVid
- -- if user want to search a video, then don't load cache to the screen
-
- forM_ diskV $ \v -> addToList lst v =<< plainText (beaut v)
+ forM_ diskV $ \v -> addToList tmpLst v =<< plainText (beaut v)
-- add disk videos to list
- lfg <- newFocusGroup
- addToFocusGroup lfg lst
+ tmpLfg <- newFocusGroup
+ addToFocusGroup tmpLfg tmpLst
statBar <- plainText waitingBar
-- the state bar show in the bottom
setNormalAttribute statBar (black `on` green)
- ui <- centered =<< hFixed 80 =<< vBox lst statBar
+ tmpUi <- centered =<< hFixed 80 =<< vBox tmpLst statBar
-- ui consists of a list and a state bar
- chgls <- addToCollection c ui lfg
+ addToCollection c tmpUi tmpLfg
+
(dlg, dfcg) <- newAskScene
dui <- centered =<< hFixed 50 (sceneWidget dlg)
chgdl <- addToCollection c dui dfcg
-
- -- four button in ask scene's action
- onScePlay dlg $ \_ -> do
- Just (_, (itm, _)) <- getSelected lst
- justPlay itm
- onSceDown dlg $ \_ -> do
- Just (_, (itm, _)) <- getSelected lst
- playVid itm
- onSceQuit dlg $ const exitSuccess
- onSceRemv dlg $ \_ -> do
- Just (_, (itm, _)) <- getSelected lst
- removeVid itm
-
ifsfg <- newFocusGroup
-- a focus group for information page
-- this function will show the focused item's information to user
- let chgInf = do
- Just (_, (vid, _)) <- getSelected lst
- inf <- centered =<< plainText (crtInfPg vid)
- addToFocusGroup ifsfg inf
- join $ addToCollection c inf ifsfg
- -- the information scene
- onKeyPressed ifsfg $ \_ key _ -> case key of
- KLeft -> do
- chgls -- return to the list
- return True
- KUp -> do
- scrollUp lst
- chgInf
- return True
- KDown -> do
- scrollDown lst
- chgInf
- return True
- _ -> return False
-
-
- onKeyPressed lst $ \_ key _ -> case key of
- KRight -> do
- chgInf
- return True
- _ -> return False
-
- lfg `onKeyPressed` tryExit
+ tmpLfg `onKeyPressed` tryExit
dfcg `onKeyPressed` tryExit
ifsfg `onKeyPressed` tryExit
+ -- colorDecide tmpLst
+
-- let's download video from internet !
schedule $ do
forkIO $ do
- rd <- prsHtm <$> fetchHtml
+ vdlst <- prsHtm <$> fetchHtml
-- prsHtm :: Text -> [Video (whether video or folder)]
-
- let vdlst = search rd args
- when (length vdlst < 1) $ error "no search result found (or it's empty)."
-
- Just (_, (oldItm, _)) <- getSelected lst
- -- store the location before page refresh
+ forkIO . writeVid $ vdlst
+ -- write cache to the disk
+
+ vlst <- vidsVList vdlst
+ let lst = listW vlst
+
+ -- move to the selected old item
+ Just (_, (oldSeleItm, _)) <- getSelected tmpLst
+ listFindFirst lst oldSeleItm >>= \case
+ Just idx -> setSelected lst idx
+ Nothing -> return ()
- clearList lst
- forM_ vdlst $ \v -> addToList lst v =<< plainText (beaut v)
-- show new list
+ lfg <- newFocusGroup
+ lfg `onKeyPressed` tryExit
+ addToFocusGroup lfg lst
+ lui <- centered =<< hFixed 80 =<< vBox lst statBar
+ chgls <- addToCollection c lui lfg
+ chgls
+ ew <- editWidget
+ -- a widget to enter keyword
+ kfg <- newFocusGroup
+ addToFocusGroup kfg ew
+ kui <- centered =<< hFixed 80 =<< vBox lst ew
+ chgky <- addToCollection c kui kfg
+ -- create a scene presents a input box
- listFindFirst lst oldItm >>= \case
- Just ind -> setSelected lst ind
- Nothing -> return ()
+ colorDecide lst
- onSelectionChange lst $ \sle -> case sle of
- SelectionOn _ itm _ -> case isFld itm of
- True -> setFocusAttribute lst (black `on` magenta)
- -- folder's color
- _ -> fex itm >>= \case
- True -> setFocusAttribute lst (black `on` red)
- -- if video have been download, use red color
- False -> setFocusAttribute lst (black `on` cyan)
- -- if video haven't been download, use cyan
- _ -> return ()
+ -- four button in ask scene's action
+ onScePlay dlg $ \_ -> do
+ Just (_, (itm, _)) <- getSelected lst
+ justPlay itm
+ onSceDown dlg $ \_ -> do
+ Just (_, (itm, _)) <- getSelected lst
+ playVid itm
+ onSceQuit dlg $ const exitSuccess
+ onSceRemv dlg $ \_ -> do
+ Just (_, (itm, _)) <- getSelected lst
+ removeVid itm
onSelectionChange lst $ \sle -> case sle of
SelectionOn _ itm _ -> setText statBar =<< genStat itm
-- refresh state bar after any scroll
_ -> return ()
+
- astr <- newIORef []
- -- we store ancestors list element in the astr
- -- (those old list we leaved)
- let push = do
- -- store the state into astr
- sz <- getListSize lst
- Just (loc, _) <- getSelected lst
- lem <- catMaybes <$> forM [0..sz-1] (getListItem lst)
- modifyIORef astr ((lem, loc):)
- let pop = do
- -- pop a state from astr and give it to lst
- ast <- readIORef astr
- case ast of
- [] -> return ()
- ((itms, loc):_) -> do
- clearList lst
- forM_ itms $ \(v, w) -> addToList lst v w
- setSelected lst loc
- modifyIORef astr tail
-
+ let chgInf = do
+ Just (_, (vid, _)) <- getSelected lst
+ inf <- centered =<< plainText (crtInfPg vid)
+ addToFocusGroup ifsfg inf
+ join $ addToCollection c inf ifsfg
+
+ -- the information scene
+ onKeyPressed ifsfg $ \_ key _ -> case key of
+ KLeft -> do
+ chgls -- return to the list
+ return True
+ KUp -> do
+ scrollUp lst
+ chgInf
+ return True
+ KDown -> do
+ scrollDown lst
+ chgInf
+ return True
+ _ -> return False
+
+ onKeyPressed lst $ \_ key _ -> case key of
+ KRight -> do
+ chgInf
+ return True
+ _ -> return False
+
+ onActivate ew $ \e -> do
+ t <- getEditText e
+ setEditText e ""
+ filterVList vlst $ \v -> vidInfx v (T.words t)
+ chgls
+ -- return to the list
+
let openFld lnk = do
ctnt <- (map (attcLink lnk) . prsHtm) <$> fetchFld lnk
-- attach folder link to the videos in the folder
when (null ctnt) $ error "there is no video in the folder!"
- push
- clearList lst
- forM_ ctnt $ \v -> addToList lst v =<< plainText (beaut v)
+ setVList vlst ctnt
return ()
onKeyPressed lst $ \_ key _ -> case key of
@@ -186,37 +172,26 @@
return True
KLeft -> do
-- return to the old list
- pop
+ backVList vlst
return True
KChar 's' -> do
- push
+ -- filter the videos by the focused video
Just (_, (itm, _)) <- getSelected lst
- size <- getListSize lst
- let itemIdxs = reverse [0..size-1]
- isLik <- forM itemIdxs $ \idx -> do
- Just (now, _) <- getListItem lst idx
- return $ isAlike itm now
- forM_ (zip itemIdxs isLik) $ \(idx, lik) -> unless lik $ do
- removeFromList lst idx
- return ()
+ filterVList vlst (isAlike itm)
return True
+ KChar 'n' -> do
+ -- sort videos by their name
+ sortVList vlst (comparing getName)
+ return True
+ KChar '/' -> do
+ chgky
+ return True
_ -> return False
- when (null args) $ void . forkIO . writeVid $ vdlst
- -- only write cache when user didn't search video
-
return ()
return ()
runUi c $ defaultContext { normalAttr = white `on` black
, focusAttr = black `on` blue
}
-
- where tryExit _ key _ = case key of
- KChar 'q' -> exitSuccess
- _ -> return False
- fex itm
- | isVid itm = downloaded $ vidName itm
- | otherwise = return False
-
diff --git a/src/NameAlgo.hs b/src/NameAlgo.hs
--- a/src/NameAlgo.hs
+++ b/src/NameAlgo.hs
@@ -6,6 +6,9 @@
import Data.Function
import Data.Array
+import Data.List
+import Data.Ord
+import Data.Text (Text)
import qualified Data.Text as T
-- | the video name parsing is only for specific type of videos...( [subtitle][video name][episode].... )
@@ -68,11 +71,45 @@
lim = length (T.unpack vn1) `div` 2
dis = editDis vn1 vn2
+{-
search :: [Video] -> -- ^ video list
[String] -> -- ^ a list of target string
[Video]
-search vids par = filter ok vids
- where ok v = all (\tar -> T.pack tar `ifx` name) par
- where name = if isVid v then vidName v else fldName v
- ifx = T.isInfixOf `on` T.toCaseFold
+search vids par = filter (\v -> vidInfx v (map T.pack par)) vids
+-}
+
+vidInfx :: Video -> [Text] -> Bool
+vidInfx _ [] = True
+vidInfx v (x:xs) = (x `ifx` getName v) && vidInfx v xs
+ where ifx = T.isInfixOf `on` T.toCaseFold
+
+sortByName :: [Video] -> [Video]
+sortByName = sortBy (comparing getName)
+
+sortVid :: [Video] -> [Video]
+sortVid = sortBy cmpv
+ where cmpv :: Video -> Video -> Ordering
+ cmpv = cmp `on` dt
+ where dt v
+ | isVid v = vidDate v
+ | otherwise = fldDate v
+ cmp :: T.Text -> T.Text -> Ordering
+ cmp = flip compare `on` prs
+ where prs tx = [year, tranMon mon, day, time]
+ where [day, mon, year, time] = T.splitOn "-" tx
+ tranMon :: T.Text -> T.Text
+ tranMon m = case m of
+ "Jan" -> "A"
+ "Feb" -> "B"
+ "Mar" -> "C"
+ "Apr" -> "D"
+ "May" -> "E"
+ "Jun" -> "F"
+ "Jul" -> "G"
+ "Aug" -> "H"
+ "Sep" -> "I"
+ "Oct" -> "J"
+ "Nov" -> "K"
+ "Dec" -> "L"
+ _ -> " "
diff --git a/src/PrsVid.hs b/src/PrsVid.hs
--- a/src/PrsVid.hs
+++ b/src/PrsVid.hs
@@ -3,14 +3,16 @@
module PrsVid where
import Video
-import SortVid
+import NameAlgo
import Network.HTTP.Base
import Text.HTML.TagSoup
import qualified Data.Text as T
prsHtm :: T.Text -> [Video]
-prsHtm t = sortVid $ (prsVid t) ++ (prsFld t)
+prsHtm t = if null vs then [noVideo] else vs
+ where vs = sortVid $ (prsVid t) ++ (prsFld t)
+ noVideo = Video "No video in this folder." "" "" ""
prsVid :: T.Text -> [Video]
prsVid = map (genVid . filter (not . T.null) . map pullText) .
diff --git a/src/SortVid.hs b/src/SortVid.hs
deleted file mode 100644
--- a/src/SortVid.hs
+++ /dev/null
@@ -1,40 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module SortVid (sortVid) where
-
-import Video
-
-import qualified Data.Text as T
-import Data.List
-import Data.Function
-
-sortVid :: [Video] -> [Video]
-sortVid = sortBy cmpv
-
-cmpv :: Video -> Video -> Ordering
-cmpv = cmp `on` dt
- where dt v
- | isVid v = vidDate v
- | otherwise = fldDate v
-
-cmp :: T.Text -> T.Text -> Ordering
-cmp = flip compare `on` prs
- where prs tx = [year, tranMon mon, day, time]
- where [day, mon, year, time] = T.splitOn "-" tx
-
-tranMon :: T.Text -> T.Text
-tranMon m = case m of
- "Jan" -> "A"
- "Feb" -> "B"
- "Mar" -> "C"
- "Apr" -> "D"
- "May" -> "E"
- "Jun" -> "F"
- "Jul" -> "G"
- "Aug" -> "H"
- "Sep" -> "I"
- "Oct" -> "J"
- "Nov" -> "K"
- "Dec" -> "L"
- _ -> " "
-
diff --git a/src/UI.hs b/src/UI.hs
new file mode 100644
--- /dev/null
+++ b/src/UI.hs
@@ -0,0 +1,122 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+
+module UI where
+
+import Video
+import RealWorld
+import NameAlgo
+
+import Control.Monad
+import System.Exit
+import Graphics.Vty
+import Graphics.Vty.Widgets.All
+import Data.IORef
+import Data.List
+
+type WL = Widget (List Video FormattedText)
+type VidStat = ([Video], Video)
+-- videos last select video
+
+data VList = VList WL (IORef [VidStat])
+
+listW :: VList -> WL
+listW (VList lw _) = lw
+
+vidsVList :: [Video] -> IO VList
+vidsVList vs = do
+ lst <- newList 3
+ forM_ vs $ \v -> addToList lst v =<< plainText (beaut v)
+ ior <- newIORef []
+ return $ VList lst ior
+
+filterVList :: VList -> (Video -> Bool) -> IO ()
+filterVList vl@(VList wl _) ok = do
+ storeState vl
+ setListVideos wl . filter ok =<< getListVideos wl
+
+sortVList :: VList -> (Video -> Video -> Ordering) -> IO ()
+sortVList vl@(VList wl _) cmp = do
+ storeState vl
+ setListVideos wl . sortBy cmp =<< getListVideos wl
+
+storeState :: VList -> IO ()
+storeState (VList wl st) = do
+ vs <- getListVideos wl
+ idx <- getWLSelected wl
+ modifyIORef st ((vs, idx):)
+
+setVList :: VList -> [Video] -> IO ()
+setVList (VList wl st) vs = do
+ oldVs <- getListVideos wl
+ idx <- getWLSelected wl
+ modifyIORef st ((oldVs, idx):)
+ setListVideos wl vs
+
+backVList :: VList -> IO ()
+backVList (VList wl st) =
+ readIORef st >>= \case
+ [] ->
+ return ()
+ ((bvs, bloc):_) -> do
+-- putStrLn "something >////<"
+ setListVideosB wl bvs bloc
+ modifyIORef st tail
+
+tryExit :: Widget FocusGroup -> Key -> [Modifier] -> IO Bool
+tryExit _ key _ = case key of
+ KChar 'q' -> exitSuccess
+ _ -> return False
+
+fex :: Video -> IO Bool
+fex itm
+ | isVid itm = downloaded $ vidName itm
+ | otherwise = return False
+
+-- return the videos in the list
+getListVideos :: WL -> IO [Video]
+getListVideos lst = do
+ sz <- getListSize lst
+ forM [0..sz-1] $ \idx -> do
+ Just (itm, _) <- getListItem lst idx
+ return itm
+
+getWLSelected :: WL -> IO Video
+getWLSelected ls = do
+ Just (_, (idx, _)) <- getSelected ls
+ return idx
+
+-- set lst content to vs
+setListVideos :: WL -> [Video] -> IO ()
+setListVideos lst vs = do
+ oldItm <- getWLSelected lst
+ clearList lst
+ forM_ vs $ \v -> addToList lst v =<< plainText (beaut v)
+ listFindFirst lst oldItm >>= \case
+ Just ind -> setSelected lst ind
+ Nothing -> return ()
+
+setListVideosB :: WL -> [Video] -> Video -> IO ()
+setListVideosB lst vs bvid = do
+ Just (_, (oldItm, _)) <- getSelected lst
+ clearList lst
+ forM_ vs $ \v -> addToList lst v =<< plainText (beaut v)
+ listFindFirst lst oldItm >>= \case
+ Just ind -> setSelected lst ind
+ Nothing -> listFindFirst lst bvid >>= \case
+ Just ind2 -> setSelected lst ind2
+ Nothing -> return ()
+
+colorDecide :: WL -> IO ()
+colorDecide lst =
+ onSelectionChange lst $ \sle -> case sle of
+ SelectionOn _ itm _ -> if isFld itm
+ then setFocusAttribute lst (black `on` magenta)
+ -- folder's color
+ else fex itm >>= \case
+ True -> setFocusAttribute lst (black `on` red)
+ -- if video have been download, use red color
+ False -> setFocusAttribute lst (black `on` cyan)
+ -- if video haven't been download, use cyan
+ _ -> return ()
+