diff --git a/Config.hs b/Config.hs new file mode 100644 --- /dev/null +++ b/Config.hs @@ -0,0 +1,82 @@ +-- +-- Copyright (c) 2005-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- Copyright (c) 2019 Galen Huntington +-- +-- 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 Config where + +import Style +import Data.Version (showVersion) +import Paths_hmp3_ng (version) + +defaultStyle :: UIStyle +defaultStyle = UIStyle { window = Style defaultfg defaultbg + , titlebar = Style brightwhite green + , selected = Style blue defaultbg + , cursors = Style black cyan + , combined = Style brightwhite cyan + , warnings = Style red defaultbg + , helpscreen = Style black white + , blockcursor= Style black red + , progress = Style cyan white } + +-- | A style more suitable for light backgrounds (used if HMP_HAS_LIGHT_BG=true) +lightBgStyle :: UIStyle +lightBgStyle = + defaultStyle { selected = Style darkblue defaultbg + , warnings = Style darkred defaultbg } + +-- +-- | Another style for dark backgrounds, reminiscent of mutt +-- +muttStyle :: UIStyle +muttStyle = UIStyle { window = Style brightwhite black + , titlebar = Style green blue + , selected = Style brightwhite black + , cursors = Style black cyan + , combined = Style black cyan + , warnings = Style brightwhite red + , helpscreen = Style black cyan + , blockcursor= Style black darkred + , progress = Style cyan white } + +bwStyle :: UIStyle +bwStyle = UIStyle { + window = Style defaultfg defaultbg + ,titlebar = Style reversefg reversebg + ,selected = Style brightwhite defaultbg + ,cursors = Style reversefg reversebg + ,combined = Style reversefg reversebg + ,warnings = Style reversefg reversebg + ,helpscreen = Style reversefg reversebg + ,blockcursor = Style reversefg reversebg + ,progress = Style reversefg reversebg + } + +------------------------------------------------------------------------ + +package :: String +package = "hmp3-ng" + +versinfo :: String +versinfo = package ++ " v" ++ showVersion version + +help :: String +help = "- curses-based MP3 player" + +darcsinfo :: String +darcsinfo = "darcs get http://code.haskell.org/~dons/code/hmp3" diff --git a/Core.hs b/Core.hs new file mode 100644 --- /dev/null +++ b/Core.hs @@ -0,0 +1,633 @@ +-- +-- Copyright (c) 2005-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- Copyright (c) 2008, 2019 Galen Huntington +-- +-- 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. +-- + +-- +-- | Main module. +-- +module Core ( + start, + shutdown, + seekLeft, seekRight, up, down, pause, nextMode, playNext, playPrev, + quit, putmsg, clrmsg, toggleHelp, play, playCur, jumpToPlaying, jump, {-, add-} + upPage, downPage, + seekStart, + blacklist, + writeSt, readSt, + jumpToMatch, jumpToMatchFile, + toggleFocus, jumpToNextDir, jumpToPrevDir, + loadConfig, + ) where + +import Prelude + +import Syntax +import Lexer (parser) +import State +import Style +import Utils +import FastIO (send, FiltHandle(..)) +import Tree hiding (File,Dir) +import qualified Tree (File,Dir) +import qualified UI +import Data.IORef + +import Text.Regex.PCRE.Light +import {-# SOURCE #-} Keymap (keymap) + +import qualified Data.ByteString.Char8 as P (ByteString,pack,empty,intercalate,singleton,unpack) + +import Data.Array ((!), bounds, Array) +import Data.Maybe (isJust,fromJust) +import Control.Monad (liftM, when, msum) +import System.Directory (doesFileExist,findExecutable) +import System.Environment (getEnv) +import System.Exit (ExitCode(ExitSuccess),exitWith) +import System.IO (hPutStrLn, hGetLine, stderr, hFlush) +import System.IO.Unsafe (unsafeInterleaveIO) +import System.Process (waitForProcess) +import System.Time (getClockTime) +import System.Random.Mersenne + +import System.Posix.Process (exitImmediately) +import System.Posix.User (getUserEntryForID, getRealUserID, homeDirectory) + +import Control.Concurrent +import Control.Exception + +import GHC.IO.Handle.FD (fdToHandle) + +-- This can be overridden with -D. +#ifndef MPG321 +#define MPG321 "mpg123" +#endif + +------------------------------------------------------------------------ + +start :: Either SerialT [P.ByteString] -> IO () +start ms = Control.Exception.handle (\ (e :: SomeException) -> shutdown (Just (show e))) $ do + + t0 <- forkIO mpgLoop -- start this off early, to give mpg321 a time to settle + + c <- UI.start -- initialise curses + + (ds,fs,i,m) -- construct the state + <- case ms of + Right roots -> do (a,b) <- buildTree roots + return (a,b,0,Normal) + + Left st -> return (ser_darr st + ,ser_farr st + ,ser_indx st + ,ser_mode st) + + now <- getClockTime + + -- fork some threads + t1 <- forkIO mpgInput + t2 <- forkIO refreshLoop + t3 <- forkIO clockLoop + t4 <- forkIO uptimeLoop + t5 <- forkIO errorLoop + + silentlyModifyST $ \s -> s + { music = fs + , folders = ds + , size = 1 + (snd . bounds $ fs) + , cursor = i + , current = i + , mode = m + , uptime = drawUptime now now + , boottime = now + , config = c + , threads = [t0,t1,t2,t3,t4,t5] } + + loadConfig + + when (0 <= (snd . bounds $ fs)) play -- start the first song + + run -- won't restart if this fails! + +------------------------------------------------------------------------ + +-- | Uniform loop and thread handler (subtle, and requires exitImmediately) +forever :: IO () -> IO () +forever fn = catch (repeatM_ fn) handler + where + handler :: SomeException -> IO () + handler e = + when (not.exitTime $ e) $ + (warnA . show) e >> (forever fn) -- reopen the catch + +-- | Generic handler +-- For profiling, make sure to return True for anything: +exitTime :: SomeException -> Bool +-- TODO make this work with new exception hierarchy +{- +exitTime e | isJust . ioErrors $ e = False -- ignore + | isJust . errorCalls $ e = False -- ignore + | isJust . userErrors $ e = False -- ignore + | otherwise = True +-} +exitTime _ = True + +------------------------------------------------------------------------ + +-- | Process loop, launch mpg321, set the handles in the state +-- and then wait for the process to die. If it does, restart it. +-- +-- If we're unable to start at all, we should say something sensible +-- For example, if we can't start it two times in a row, perhaps give up? +-- +mpgLoop :: IO () +mpgLoop = forever $ do + mmpg <- findExecutable (MPG321 :: String) + case mmpg of + Nothing -> quit (Just $ "Cannot find " ++ MPG321 ++ " in path") + Just mpg321 -> do + + -- if we're never able to start mpg321, do something sensible + mv <- catch (popen (mpg321 :: String) ["-R","-"] >>= return . Just) + (\ (e :: SomeException) -> + do warnA ("Unable to start " ++ MPG321 ++ ": " ++ show e) + return Nothing) + case mv of + Nothing -> threadDelay (1000 * 500) >> mpgLoop + Just (r,w,e,pid) -> do + + hw <- fdToHandle (fromIntegral w) -- so we can use Haskell IO + ew <- fdToHandle (fromIntegral e) -- so we can use Haskell IO + filep <- FiltHandle <$> fdToHandle (fromIntegral r) <*> newIORef 0 + mhw <- newMVar hw + mew <- newMVar ew + mfilep <- newMVar filep + + modifyST $ \st -> + st { mp3pid = Just pid + , writeh = mhw + , errh = mew + , readf = mfilep + , status = Stopped + , info = Nothing + , id3 = Nothing } + + catch (waitForProcess (pid2phdl pid)) (\ (_ :: SomeException) -> return ExitSuccess) + stop <- getsST doNotResuscitate + when (stop) $ exitWith ExitSuccess + warnA $ "Restarting " ++ mpg321 ++ " ..." + +------------------------------------------------------------------------ + +-- | When the editor state has been modified, refresh, then wait +-- for it to be modified again. +refreshLoop :: IO () +refreshLoop = getsST modified >>= \mvar -> forever $ takeMVar mvar >> UI.refresh + +------------------------------------------------------------------------ + +-- | Once a minute read the clock time +-- TODO use a monotonic clock +uptimeLoop :: IO () +uptimeLoop = forever $ do + threadDelay delay + now <- getClockTime + modifyST $ \st -> st { uptime = drawUptime (boottime st) now } + where + delay = 60 * 1000 * 1000 -- 1 minute + +------------------------------------------------------------------------ + +-- | Once each half second, wake up a and redraw the clock +clockLoop :: IO () +clockLoop = forever $ threadDelay delay >> UI.refreshClock + where + delay = 500 * 1000 -- 0.5 second + +------------------------------------------------------------------------ + +-- | Handle, and display errors produced by mpg321 +errorLoop :: IO () +errorLoop = forever $ do + s <- getsST errh >>= readMVar >>= hGetLine + if s == "No default libao driver available." + then quit $ Just $ s ++ " Perhaps another instance of hmp3 is running?" + else warnA s + +------------------------------------------------------------------------ + +-- | Handle messages arriving over a pipe from the decoder process. When +-- shutdown kills the other end of the pipe, hGetLine will fail, so we +-- take that chance to exit. +-- +mpgInput :: IO () +mpgInput = forever $ do + mvar <- getsST readf + fp <- readMVar mvar + res <- parser fp + case res of + Right m -> handleMsg m + Left e -> (warnA.show) e -- error from pipe + +------------------------------------------------------------------------ + +-- | The main thread: handle keystrokes fed to us by curses +run :: IO () +run = forever $ sequence_ . keymap =<< getKeys + where + getKeys = unsafeInterleaveIO $ do + c <- UI.getKey + cs <- getKeys + return (c:cs) -- A lazy list of curses keys + +------------------------------------------------------------------------ + +-- | Close most things. Important to do all the jobs: +shutdown :: Maybe String -> IO () +shutdown ms = + (do silentlyModifyST $ \st -> st { doNotResuscitate = True } + catch writeSt (\ (_ :: SomeException) -> return ()) + withST $ \st -> do + case mp3pid st of + Nothing -> return () + Just pid -> do + h <- readMVar (writeh st) + send h Quit -- ask politely + waitForProcess $ pid2phdl pid + return ()) + + `finally` + + (do isXterm <- getsST xterm + UI.end isXterm + when (isJust ms) $ hPutStrLn stderr (fromJust ms) >> hFlush stderr + exitImmediately ExitSuccess) + -- race. a thread might touch the screen + -- gets in the way of profiling +-- return ()) + +------------------------------------------------------------------------ +-- +-- Write incoming messages from the encoder to the global state in the +-- right pigeon hole. +-- +handleMsg :: Msg -> IO () +handleMsg (T _) = return () +handleMsg (I i) = modifyST $ \s -> s { info = Just i } +handleMsg (F (File (Left _))) = modifyST $ \s -> s { id3 = Nothing } +handleMsg (F (File (Right i))) = modifyST $ \s -> s { id3 = Just i } + +handleMsg (S t) = do + modifyST $ \s -> s { status = t } + when (t == Stopped) $ do -- transition to next song + playNext +-- vincenz: Redundant, this is checked in playNext +-- r <- getsST mode +-- if r == Random then playRandom else playNext + +handleMsg (R f) = do + silentlyModifyST $ \st -> st { clock = Just f } + getsST clockUpdate >>= flip when UI.refreshClock + +------------------------------------------------------------------------ +-- +-- Basic operations +-- + +-- | Seek backward in song +seekLeft :: IO () +seekLeft = seek $ \g -> max 0 (currentFrame g - 400) + +-- | Seek forward in song +seekRight :: IO () +seekRight = seek $ \g -> currentFrame g + (min 400 (framesLeft g)) + +seekStart :: IO () +seekStart = seek $ const 0 + + +-- | Generic seek +seek :: (Frame -> Int) -> IO () +seek fn = do + f <- getsST clock + case f of + Nothing -> return () + Just g -> do + withST $ \st -> do + h <- readMVar (writeh st) + send h $ Jump (fn g) + forceNextPacket -- don't drop the next Frame. + silentlyModifyST $ \st -> st { clockUpdate = True } + +page :: Int -> IO () +page dir = do + (sz, _) <- UI.screenSize + modifySTM $ flip jumpTo (+ dir*(sz-5)) +upPage, downPage :: IO () +upPage = page (-1) +downPage = page ( 1) + + +------------------------------------------------------------------------ + +-- | Move cursor up or down +up, down :: IO () +up = modifySTM $ flip jumpTo (subtract 1) +down = modifySTM $ flip jumpTo (+1) + +-- | Move cursor to specified index +jump :: Int -> IO () +jump i = modifySTM $ flip jumpTo (const i) + +-- | Generic jump +jumpTo :: HState -> (Int -> Int) -> IO HState +jumpTo st fn = do + let l = max 0 (size st - 1) + i = fn (cursor st) + n = if i > l then l else if i < 0 then 0 else i + return st { cursor = n } + +------------------------------------------------------------------------ + +-- | Load and play the song under the cursor +play :: IO () +play = modifySTM $ \st -> + if current st == cursor st + then do + let g = randomGen st + n' <- random g :: IO Int + let n = abs n' `mod` (size st -1) + playAtN st (const n) + else + playAtN st (const $ cursor st) + +playCur :: IO () +playCur = modifySTM $ \st -> playAtN st (const $ cursor st) + +blacklist :: IO () +blacklist = do + st <- getsST id + appendFile ".hmp3-delete" . (++"\n") . P.unpack $ + let fe = music st ! cursor st + in (P.intercalate (P.singleton '/') [(dname $ folders st ! fdir fe),(fbase fe)]) + + +-- | Play a random song +playRandom :: IO () +playRandom = modifySTM $ \st -> do + let g = randomGen st + n' <- random g :: IO Int + let n = abs n' `mod` (size st -1) + playAtN st (const n) + +-- | Play the song before the current song, if we're not at the beginning +-- If we're at the beginning, and loop mode is on, then loop to the end +-- If we're in random mode, play the next random track +playPrev :: IO () +playPrev = do + md <- getsST mode + if md == Random then playRandom else + modifySTM $ \st -> do + let i = current st + case () of {_ + | i > 0 -> playAtN st (subtract 1) -- just the prev track + | mode st == Loop -> playAtN st (const (size st - 1)) -- maybe loop + | otherwise -> return st -- else stop at end + } + +-- | Play the song following the current song, if we're not at the end +-- If we're at the end, and loop mode is on, then loop to the start +-- If we're in random mode, play the next random track +playNext :: IO () +playNext = do + md <- getsST mode + if md == Random then playRandom else + modifySTM $ \st -> do + let i = current st + case () of {_ + | i < size st - 1 -> playAtN st (+ 1) -- just the next track + | mode st == Loop -> playAtN st (const 0) -- maybe loop + | otherwise -> return st -- else stop at end + } + +-- | Generic next song selection +-- If the cursor and current are currently the same, continue that. +playAtN :: HState -> (Int -> Int) -> IO HState +playAtN st fn = do + let m = music st + i = current st + fe = m ! (fn i) + -- unsure of this GBH (2008) + f = P.intercalate (P.singleton '/') + [(dname $ folders st ! fdir fe),(fbase fe)] + j = cursor st + st' = st { current = fn i + , status = Playing + , cursor = if i == cursor st then fn i else j } + h <- readMVar (writeh st) + send h (Load f) + return st' + +------------------------------------------------------------------------ + +-- | Toggle pause on the current song +pause :: IO () +pause = withST $ \st -> readMVar (writeh st) >>= flip send Pause + +-- | Shutdown and exit +quit :: Maybe String -> IO () +quit = shutdown + +------------------------------------------------------------------------ + +-- | Move cursor to currently playing song +jumpToPlaying :: IO () +jumpToPlaying = modifyST $ \st -> st { cursor = (current st) } + +-- | Move cursor to first song in next directory (or wrap) +jumpToNextDir, jumpToPrevDir :: IO () +jumpToNextDir = jumpToDir (\i len -> min (i+1) (len-1)) +jumpToPrevDir = jumpToDir (\i _ -> max (i-1) 0) + +-- | Generic jump to dir +jumpToDir :: (Int -> Int -> Int) -> IO () +jumpToDir fn = modifyST $ \st -> if size st == 0 then st else + let i = fdir (music st ! cursor st) + len = 1 + (snd . bounds $ folders st) + d = fn i len + in st { cursor = dlo ((folders st) ! d) } + +------------------------------------------------------------------------ + +-- +-- a bit of bounded parametric polymorphism so we can abstract over record selectors +-- in the regex search stuff below +-- +class Lookup a where extract :: a -> FilePathP +instance Lookup Tree.Dir where extract = dname +instance Lookup Tree.File where extract = fbase + +jumpToMatchFile :: Maybe String -> Bool -> IO () +jumpToMatchFile re sw = genericJumpToMatch re sw k sel + where k = \st -> (music st, if size st == 0 then -1 else cursor st, size st) + sel i _ = i + +jumpToMatch :: Maybe String -> Bool -> IO () +jumpToMatch re sw = genericJumpToMatch re sw k sel + where k = \st -> (folders st + ,if size st == 0 then -1 else fdir (music st ! cursor st) + ,1 + (snd . bounds $ folders st)) + sel i st = dlo (folders st ! i) + +genericJumpToMatch :: Lookup a + => Maybe String + -> Bool + -> (HState -> (Array Int a, Int, Int)) + -> (Int -> HState -> Int) + -> IO () + +genericJumpToMatch re sw k sel = do + found <- modifySTM_ $ \st -> do + let mre = case re of + -- work out if we have no pattern, a cached pattern, or a new pattern + Nothing -> case regex st of + Nothing -> Nothing + Just (r,d) -> Just (r,d==sw) + Just s -> case compileM (P.pack s) [caseless] of + Left _ -> Nothing + Right v -> Just (v,sw) + case mre of + Nothing -> return (st,False) -- no pattern + Just (p,forwards) -> do + + let (fs,cur,m) = k st + +{- + loop fn inc n + | fn n = return Nothing + | otherwise = do + let s = extract (fs ! n) + case match p s [] of + Nothing -> loop fn inc $! inc n +-} + + check n = let s = extract (fs ! n) in + case match p s [] of + Nothing -> return Nothing + Just _ -> return $ Just n + + -- mi <- if forwards then loop (>=m) (+1) (cur+1) + -- else loop (<0) (subtract 1) (cur-1) + mi <- liftM msum $ mapM check $ + if forwards then [cur+1..m-1] ++ [0..cur] + else [cur-1,cur-2..0] ++ [m-1,m-2..cur] + + + let st' = st { regex = Just (p,forwards==sw) } + return $ case mi of + Nothing -> (st',False) + Just i -> (st' { cursor = sel i st }, True) + + when (not found) $ putmsg (Fast (P.pack "No match found.") defaultSty) >> touchST + +------------------------------------------------------------------------ + +-- | Show\/hide the help window +toggleHelp :: IO () +toggleHelp = modifyST $ \st -> st { helpVisible = not (helpVisible st) } + +-- | Focus the minibuffer +toggleFocus :: IO () +toggleFocus = modifyST $ \st -> st { miniFocused = not (miniFocused st) } + +-- | Toggle the mode flag +nextMode :: IO () +nextMode = modifyST $ \st -> st { mode = next (mode st) } + where + next v = if v == maxBound then minBound else succ v + +------------------------------------------------------------------------ + +-- | Saving the playlist +-- Only save if there's something to save. Should preven dbs being wiped +-- if curses crashes before the state is read. +writeSt :: IO () +writeSt = do + home <- getHome + let f = home ".hmp3db" + withST $ \st -> do + let arr1 = music st + arr2 = folders st + idx = current st + mde = mode st + when (size st > 0) $ writeTree f $ SerialT { + ser_farr = arr1 + ,ser_darr = arr2 + ,ser_indx = idx + ,ser_mode = mde + } + +-- | Read the playlist back +readSt :: IO (Maybe SerialT) +readSt = do + home <- getHome + let f = home ".hmp3db" + b <- doesFileExist f + if b then liftM Just $! readTree f else return Nothing + +-- | Find a user's home in a canonical sort of way +getHome :: IO String +getHome = Control.Exception.catch + (getRealUserID >>= getUserEntryForID >>= (return . homeDirectory)) + (\ (_ :: SomeException) -> getEnv "HOME") + +------------------------------------------------------------------------ +-- Read styles from ~/.hmp3 +-- +loadConfig :: IO () +loadConfig = do + home <- getHome + let f = home ".hmp3" + b <- doesFileExist f + when b $ do -- otherwise used compiled-in values + str <- readFile f + msty <- catch (readM str >>= return . Just) + (\ (_ :: SomeException) -> warnA "Parse error in ~/.hmp3" >> return Nothing) + case msty of + Nothing -> return () + Just rsty -> do + let sty = buildStyle rsty + initcolours sty + modifyST $ \st -> st { config = sty } + UI.resetui + +------------------------------------------------------------------------ +-- Editing the minibuffer + +putmsg :: StringA -> IO () +putmsg s = silentlyModifyST $ \st -> st { minibuffer = s } + +-- | Modify without triggering a refresh +clrmsg :: IO () +clrmsg = putmsg (Fast P.empty defaultSty) + +-- +warnA :: String -> IO () +warnA x = do + sty <- getsST config + putmsg $ Fast (P.pack x) (warnings sty) diff --git a/FastIO.hs b/FastIO.hs new file mode 100644 --- /dev/null +++ b/FastIO.hs @@ -0,0 +1,184 @@ +-- +-- Copyright (c) 2005-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- Copyright (c) 2019 Galen Huntington +-- +-- 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. +-- + +-- | ByteString versions of some common IO functions + +module FastIO where + +import Syntax (Pretty(ppr)) + +import qualified Data.ByteString.Char8 as P +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as B + +import Data.Word (Word8) +import qualified Data.ByteString.UTF8 as UTF8 +import Foreign.C.Error +import Foreign.C.Types (CInt(..), CSize(..)) +import Foreign.Marshal (allocaBytes) +import Foreign.Ptr (Ptr, castPtr, plusPtr) +import Foreign.Storable (peekElemOff) +import Foreign.ForeignPtr + +import qualified System.Directory as Dir +import System.IO.Error (modifyIOError, ioeSetFileName) +import System.IO.Unsafe (unsafePerformIO) +import System.IO (Handle,hFlush) +import Data.IORef +import System.Posix.Internals + +import Control.Exception (catch, SomeException) + +------------------------------------------------------------------------ + +-- Copied from C comment: +-- * Note that mpg321 (only) provides --skip-printing-frames=N +-- * I guess we could have used that. +dropRate :: Int +dropRate = 6 -- used to be 10, but computers are faster + +-- | Packed string version of basename +basenameP :: P.ByteString -> P.ByteString +basenameP fps = case P.elemIndexEnd '/' fps of + Nothing -> fps + Just i -> P.drop (i+1) fps +{-# INLINE basenameP #-} + +dirnameP :: P.ByteString -> P.ByteString +dirnameP fps = case P.elemIndexEnd '/' fps of + Nothing -> P.pack "." + Just i -> P.take i fps +{-# INLINE dirnameP #-} + +-- +-- | Packed version of get directory contents +-- Have them just return CStrings, then pack lazily? +-- +packedGetDirectoryContents :: P.ByteString -> IO [P.ByteString] +packedGetDirectoryContents = do + fmap (map UTF8.fromString) . Dir.listDirectory . UTF8.toString + +-- packed version: +doesFileExist :: P.ByteString -> IO Bool +doesFileExist name = Control.Exception.catch + (packedWithFileStatus "Utils.doesFileExist" name $ \st -> do + b <- isDirectory st; return (not b)) + (\ (_ :: SomeException) -> return False) + +-- packed version: +doesDirectoryExist :: P.ByteString -> IO Bool +doesDirectoryExist name = Control.Exception.catch + (packedWithFileStatus "Utils.doesDirectoryExist" name $ \st -> isDirectory st) + (\ (_ :: SomeException) -> return False) + +packedWithFileStatus :: String -> P.ByteString -> (Ptr CStat -> IO a) -> IO a +packedWithFileStatus loc name f = do + modifyIOError (`ioeSetFileName` []) $ + allocaBytes sizeof_stat $ \p -> do + B.useAsCString name $ \s -> do -- i.e. every string is duplicated + throwErrnoIfMinus1Retry_ loc (c_stat s p) + f p + +packedFileNameEndClean :: P.ByteString -> P.ByteString +packedFileNameEndClean name = + if i > 0 && (ec == '\\' || ec == '/') then + packedFileNameEndClean (P.take i name) + else + name + where + i = (P.length name) - 1 + ec = name `P.index` i + +isDirectory :: Ptr CStat -> IO Bool +isDirectory stat = do + mode <- st_mode stat + return (s_isdir mode) + +-- --------------------------------------------------------------------- + +data FiltHandle = FiltHandle { filtHandle :: !Handle, frameCount :: !(IORef Int) } + +-- | Read a line from a file stream connected to an external prcoess, +-- Returning a ByteString. +getPacket :: FiltHandle -> IO P.ByteString +getPacket (FiltHandle fp _) = B.hGetLine fp + +-- | Check if it's one of every dropRate packets. +-- We don't need to process all since there are so many. +checkF :: FiltHandle -> IO Bool +checkF (FiltHandle _ ir) = do + modifyIORef' ir (\x -> (x+1) `mod` dropRate) + i <- readIORef ir + return $ (i==1) + +-- --------------------------------------------------------------------- + +getPermissions :: P.ByteString -> IO Dir.Permissions +getPermissions = Dir.getPermissions . UTF8.toString + +-- --------------------------------------------------------------------- +-- | Send a msg over the channel to the decoder +send :: Pretty a => Handle -> a -> IO () +send h m = P.hPut h (ppr m) >> P.hPut h nl >> hFlush h + where + nl = P.pack "\n" + +------------------------------------------------------------------------ + +-- | 'dropSpaceEnd' efficiently returns the 'ByteString' argument with +-- white space removed from the end. I.e. +-- +-- > reverse . (dropWhile isSpace) . reverse == dropSpaceEnd +-- +-- but it is more efficient than using multiple reverses. +-- +dropSpaceEnd :: P.ByteString -> P.ByteString +{-# INLINE dropSpaceEnd #-} +dropSpaceEnd (B.PS x s l) = unsafePerformIO $ withForeignPtr x $ \p -> do + i <- lastnonspace (p `plusPtr` s) (l-1) + return $! if i == (-1) then B.empty else B.PS x s (i+1) + where + lastnonspace :: Ptr Word8 -> Int -> IO Int + lastnonspace ptr n + | ptr `seq` n `seq` False = undefined + | n < 0 = return n + | otherwise = do w <- peekElemOff ptr n + if B.isSpaceWord8 w then lastnonspace ptr (n-1) + else return n + +------------------------------------------------------------------------ + +-- +-- A wrapper over printf for use in UI.PTimes +-- +printfPS :: P.ByteString -> Int -> Int -> P.ByteString +printfPS fmt arg1 arg2 = + unsafePerformIO $ B.createAndTrim lim $ \ptr -> + B.useAsCString fmt $ \c_fmt -> do + sz' <- c_printf2d ptr (fromIntegral lim) (castPtr c_fmt) + (fromIntegral arg1) (fromIntegral arg2) + return (min lim (fromIntegral sz')) -- snprintf might truncate + where + lim = 10 -- NB + +-- --------------------------------------------------------------------- + +foreign import ccall unsafe "static stdio.h snprintf" + c_printf2d :: Ptr Word8 -> CSize -> Ptr Word8 -> CInt -> CInt -> IO CInt diff --git a/Keymap.hs b/Keymap.hs new file mode 100644 --- /dev/null +++ b/Keymap.hs @@ -0,0 +1,227 @@ +-- +-- Copyright (c) 2004-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- Copyright (c) 2008, 2019 Galen Huntington +-- +-- 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. +-- + +-- +-- | Keymap manipulation +-- +-- The idea of using lazy lexers to implement keymaps is described in +-- the paper: +-- +-- > Dynamic Applications From the Ground Up. Don Stewart and Manuel M. +-- > T. Chakravarty. In Proceedings of the ACM SIGPLAN Workshop on +-- > Haskell, pages 27-38. ACM Press, 2005. +-- +-- See that for more info. +-- +module Keymap where + +import Prelude hiding (all) + +import Core +import State (getsST, touchST, HState(helpVisible)) +import Style (defaultSty, StringA(Fast)) +import qualified UI (resetui) +import UI.HSCurses.Curses (Key(..), decodeKey) +import Lexers ((>|<),(>||<),action,meta,execLexer + ,alt,with,char,Regexp,Lexer) + +import Data.List ((\\), find) + +import qualified Data.ByteString.Char8 as P (ByteString, pack) +import qualified Data.Map as M (fromList, lookup, Map) + +data Search = SearchFile | SearchDir + +data Direction = Forwards | Backwards + +toBool :: Direction -> Bool +toBool Forwards = True +toBool _ = False + +type LexerS = Lexer (Search, Direction, String) (IO ()) + +-- +-- The keymap +-- +keymap :: [Char] -> [IO ()] +keymap cs = map (clrmsg >>) actions + where (actions,_,_) = execLexer all (cs, defaultS) + +defaultS :: (Search, Direction, String) +defaultS = (SearchDir, Forwards, []) + +all :: LexerS +all = commands >||< search + +commands :: LexerS +commands = (alt keys) `action` \[c] -> Just $ case M.lookup c keyMap of + Nothing -> return () -- ignore + Just a -> a + +------------------------------------------------------------------------ + +search :: LexerS +search = searchDir >||< searchFile + +searchDir :: LexerS +searchDir = (char '\\' >|< char '|') `meta` \[c] _ -> + (with (toggleFocus >> putmsg (Fast (P.pack [c]) defaultSty) >> touchST) + ,(SearchDir,if c == '\\' then Forwards else Backwards,[c]) ,Just dosearch) + +searchFile :: LexerS +searchFile = (char '/' >|< char '?') `meta` \[c] _ -> + (with (toggleFocus >> putmsg (Fast (P.pack [c]) defaultSty) >> touchST) + ,(SearchFile,if c == '/' then Forwards else Backwards,[c]) ,Just dosearch) + +dosearch :: LexerS +dosearch = search_char >||< search_edit >||< search_esc >||< search_eval + +search_char :: LexerS +search_char = anyButDelNL + `meta` \c (t,d,st) -> + (with (putmsg (Fast (P.pack(st++c)) defaultSty) >> touchST), (t,d,st++c), Just dosearch) + where anyButDelNL = alt $ any' \\ (enter' ++ delete' ++ ['\ESC']) + +search_edit :: LexerS +search_edit = delete + `meta` \_ (t,d,st) -> + let st' = case st of [c] -> [c]; xs -> init xs + in (with (putmsg (Fast (P.pack st') defaultSty) >> touchST), (t,d,st'), Just dosearch) + +-- escape exits ex mode immediately +search_esc :: LexerS +search_esc = char '\ESC' + `meta` \_ _ -> wrap (clrmsg >> touchST) + where wrap a = (with (a >> toggleFocus), defaultS, Just all) + +search_eval :: LexerS +search_eval = enter + `meta` \_ (t,d,(_:pat)) -> case pat of + [] -> wrap (clrmsg >> touchST) + _ -> case t of + SearchFile -> wrap (jumpToMatchFile (Just pat) (toBool d)) + SearchDir -> wrap (jumpToMatch (Just pat) (toBool d)) + + where wrap a = (with (a >> toggleFocus), defaultS, Just all) + +------------------------------------------------------------------------ + +-- "Key"s seem to be inscrutable and incomparable. +-- Solution is to translate to chars. Really hacky! +-- TODO at least use lookup table (standalone deriving Ord) +unkey :: Key -> Char +unkey k = let Just c' = find (\c -> charToKey c == k) ['\0' .. '\500'] in c' + +charToKey :: Char -> Key +charToKey = decodeKey . toEnum . fromEnum + +enter', any', digit', delete' :: [Char] +enter' = ['\n', '\r'] +delete' = ['\BS', '\127', unkey KeyBackspace] +any' = ['\0' .. '\255'] +digit' = ['0' .. '9'] + +delete, enter :: Regexp (Search,Direction,[Char]) (IO ()) +delete = alt delete' +enter = alt enter' + +------------------------------------------------------------------------ + +-- +-- The default keymap, and its description +-- +keyTable :: [(P.ByteString, [Char], IO ())] +keyTable = + [ + (p "Move up", + ['k',unkey KeyUp], up) + ,(p "Move down", + ['j',unkey KeyDown], down) + ,(p "Page down", + [unkey KeyNPage], downPage) + ,(p "Page up", + [unkey KeyPPage], upPage) + ,(p "Jump to start of list", + [unkey KeyHome,'1'], jump 0) + ,(p "Jump to end of list", + [unkey KeyEnd,'G'], jump maxBound) + ,(p "Seek left within song", + [unkey KeyLeft], seekLeft) + ,(p "Seek right within song", + [unkey KeyRight], seekRight) + ,(p "Toggle pause", + [' '], pause) + ,(p "Play song under cursor", + ['\n'], play) + ,(p "Play previous track", + ['K'], playPrev) + ,(p "Play next track", + ['J'], playNext) + ,(p "Toggle the help screen", + ['h'], toggleHelp) + ,(p "Jump to currently playing song", + ['t'], jumpToPlaying) + ,(p "Quit (or close help screen)", + ['q'], do b <- helpIsVisible ; if b then toggleHelp else quit Nothing) + ,(p "Select and play next track", + ['d'], playNext >> jumpToPlaying) + ,(p "Cycle through normal, random and loop modes", + ['m'], nextMode) + ,(p "Refresh the display", + ['\^L'], UI.resetui) + ,(p "Repeat last regex search", + ['n'], jumpToMatchFile Nothing True) + ,(p "Repeat last regex search backwards", + ['N'], jumpToMatchFile Nothing False) + ,(p "Play", + ['p'], playCur) + ,(p "Mark as deletable", + ['d'], blacklist) + ,(p "Load config file", + ['l'], loadConfig) + ,(p "Restart song", + [unkey KeyBackspace], seekStart) + ] + where + -- Keep as Addr#. If we try the pack/packAddress rule, ghc seems to get + -- confused and want to *unpack* the strings :/ + p = P.pack + {-# INLINE p #-} + +extraTable :: [(P.ByteString, [Char])] +extraTable = [(p "Search for file matching regex", ['/']) + ,(p "Search backwards for file", ['?']) + ,(p "Search for directory matching regex", ['\\']) + ,(p "Search backwards for directory", ['|']) ] + where + -- Keep as Addr#. If we try the pack/packAddress rule, ghc seems to get + -- confused and want to *unpack* the strings :/ + p = P.pack + {-# INLINE p #-} + + +helpIsVisible :: IO Bool +helpIsVisible = getsST helpVisible + +keyMap :: M.Map Char (IO ()) +keyMap = M.fromList [ (c,a) | (_,cs,a) <- keyTable, c <- cs ] + +keys :: [Char] +keys = concat [ cs | (_,cs,_) <- keyTable ] diff --git a/Keymap.hs-boot b/Keymap.hs-boot new file mode 100644 --- /dev/null +++ b/Keymap.hs-boot @@ -0,0 +1,11 @@ +module Keymap where + +import Data.ByteString +import UI.HSCurses.Curses (Key) + +keymap :: [Char] -> [IO ()] + +keyTable :: [(ByteString, [Char], IO ())] +extraTable :: [(ByteString, [Char])] +unkey :: Key -> Char +charToKey :: Char -> Key diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,340 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Library General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + 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 + + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Library General +Public License instead of this License. diff --git a/Lexer.hs b/Lexer.hs new file mode 100644 --- /dev/null +++ b/Lexer.hs @@ -0,0 +1,167 @@ +-- +-- Copyright (c) 2005-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- Copyright (c) 2008 Galen Huntington +-- +-- 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. +-- + +-- Lexer for mpg321 messages + +module Lexer ( parser ) where + +import Syntax (Msg(..),Status(..),Frame(..),Info(..),Id3(..),File(..),Tag(..)) +import FastIO (FiltHandle(..), checkF, getPacket, dropSpaceEnd) +import Data.Char + +import Data.Maybe (fromJust) +import qualified Data.ByteString.Char8 as P +import Control.Monad.Except + +------------------------------------------------------------------------ + +pSafeHead :: P.ByteString -> Char +pSafeHead s = if P.null s then ' ' else P.head s + +doP :: P.ByteString -> Msg +doP s = S $! case pSafeHead s of + '0' -> Stopped + '1' -> Paused + '2' -> Playing + _ -> Playing + -- _ -> error "Invalid Status" + +-- Frame decoding status updates (once per frame). +doF :: P.ByteString -> Msg +doF s = R $ Frame { + currentFrame = readPS (fs !! 0) + , framesLeft = readPS (fs !! 1) + , currentTime = f 2 + , timeLeft = f 3 + } + where + + fs = P.split ' ' $ s + f n = case P.split '.' (fs !! n) of { [x,y] -> + case readPS x of { rx -> + case readPS y of { ry -> (rx,ry) }} + ; _ -> error "doF.f" } + +readPS :: P.ByteString -> Int +readPS = fst . fromJust . P.readInt + +-- Outputs information about the mp3 file after loading. +doS :: P.ByteString -> Msg +doS s = let fs = P.split ' ' $ s + in I $ Info { + {- + version = fs !! 0 + , layer = read . P.unpack $ fs !! 1 + , sampleRate = read . P.unpack $ fs !! 2 + , playMode = fs !! 3 + , modeExtns = read . P.unpack $ fs !! 4 + , bytesPerFrame = read . P.unpack $ fs !! 5 + , channelCount = read . P.unpack $ fs !! 6 + , copyrighted = toEnum (read $ P.unpack (fs !! 7)) + , checksummed = toEnum (read $ P.unpack (fs !! 8)) + , emphasis = read $ P.unpack $ fs !! 9 + , bitrate = read $ P.unpack $ fs !! 10 + , extension = read $ P.unpack $ fs !! 11 + -} + userinfo = P.concat + [P.pack "mpeg " + ,fs !! 0 + ,P.pack " " + ,fs !! 10 + ,P.pack "kbit/s " + ,(P.pack . show) ((readPS (fs !! 2)) `div` 1000 :: Int) + ,P.pack "kHz"] + } + +-- Track info if ID fields are in the file, otherwise file name. +-- 30 chars per field? +doI :: P.ByteString -> Msg +doI s = let f = dropSpaceEnd . P.dropWhile isSpace $ s + in case P.take 4 f of + cs | cs == P.pack "ID3:" -> F . File . Right . toId id3 . splitUp . P.drop 4 $ f + | otherwise -> F . File . Left $ f + where + -- a default + id3 :: Id3 + id3 = Id3 P.empty P.empty P.empty P.empty + + -- break the ID3 string up + splitUp :: P.ByteString -> [P.ByteString] + splitUp f + | f == P.empty = [] + | otherwise + = let (a,xs) = P.splitAt 30 f -- we expect it to be + xs' = splitUp xs + in a : xs' + + -- and some ugly code: + toId :: Id3 -> [P.ByteString] -> Id3 + toId i ls = + let j = case length ls of + 0 -> i + + 1 -> i { id3title = normalise $! ls !! 0 } + + 2 -> i { id3title = normalise $! ls !! 0 + , id3artist = normalise $! ls !! 1 } + + _ -> i { id3title = normalise $! ls !! 0 + , id3artist = normalise $! ls !! 1 + , id3album = normalise $! ls !! 2 } + + in j { id3str = (id3artist j) + `maybeJoin` + (id3album j) + `maybeJoin` + (id3title j) } + + maybeJoin t f = if P.null f then t `P.append` P.empty else t `gap` f + + gap x y = P.concat [ x, (P.pack " : "), y ] + + normalise = P.dropWhile isSpace . dropSpaceEnd + +------------------------------------------------------------------------ + +parser :: FiltHandle -> IO (Either String Msg) +parser h = runExceptT loop where + loop = do + x <- lift $ getPacket h + let -- badPacket :: ExceptT String IO a -- MonoLocalBinds... + badPacket = throwError $ "Bad packet: " ++ show (P.unpack x) + -- worth notifying about? most are just newlines in the ID data + + when (P.length x < 3) $ void badPacket + let (pre, m) = P.splitAt 3 x + at : code : sp : _ = P.unpack pre + when (at /= '@' || sp /= ' ') $ void badPacket + + -- TODO: make doX functions total + case code of + 'R' -> pure $ T Tag + 'I' -> pure $ doI m + 'S' -> pure $ doS m + 'F' -> do + b <- lift $ checkF h + if b then pure $ doF m else loop + 'P' -> pure $ doP m + 'E' -> throwError $ "mpg321 error: " ++ P.unpack m + _ -> badPacket + diff --git a/Lexers.hs b/Lexers.hs new file mode 100644 --- /dev/null +++ b/Lexers.hs @@ -0,0 +1,552 @@ +-- Compiler Toolkit: Self-optimizing lexers +-- +-- Author : Manuel M. T. Chakravarty +-- Created: 24 February 95, 2 March 99 +-- +-- Version $Revision: 1.1 $ from $Date: 2002/07/28 03:35:20 $ +-- +-- Copyright (c) [1995..2000] Manuel M. T. Chakravarty +-- Copyright (c) 2004-2008 Don Stewart +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Library General Public +-- License as published by the Free Software Foundation; either +-- version 2 of the License, or (at your option) any later version. +-- +-- This library 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 +-- Library General Public License for more details. +-- +--- DESCRIPTION --------------------------------------------------------------- +-- +-- Self-optimizing lexer combinators. +-- +-- For detailed information, see ``Lazy Lexing is Fast'', Manuel +-- M. T. Chakravarty, in A. Middeldorp and T. Sato, editors, Proceedings of +-- Fourth Fuji International Symposium on Functional and Logic Programming, +-- Springer-Verlag, LNCS 1722, 1999. (See my Web page for details.) +-- +-- http://www.cse.unsw.edu.au/~chak/papers/Cha99.html +-- +-- Thanks to Simon L. Peyton Jones and Roman +-- Lechtchinsky for their helpful suggestions that +-- improved the design of this library. +-- +--- DOCU ---------------------------------------------------------------------- +-- +-- language: Haskell 98 +-- +-- The idea is to combine the benefits of off-line generators with +-- combinators like in `Parsers.hs' (which builds on Swierstra/Duponcheel's +-- technique for self-optimizing parser combinators). In essence, a state +-- transition graph representing a lexer table is computed on the fly, to +-- make lexing deterministic and based on cheap table lookups. +-- +-- Regular expression map to Haskell expressions as follows. If `x' and `y' +-- are regular expressions, +-- +-- -> epsilon +-- xy -> x +> y +-- x*y -> x `star` y +-- x+y -> x `plus` y +-- x?y -> x `quest` y +-- +-- Given such a Haskelized regular expression `hre', we can use +-- +-- (1) hre `lexaction` \lexeme -> Nothing +-- (2) hre `lexaction` \lexeme -> Just token +-- (3) hre `lexmeta` \lexeme pos s -> (res, pos', s', Nothing) +-- (4) hre `lexmeta` \lexeme pos s -> (res, pos', s', Just l) +-- +-- where `epsilon' is required at the end of `hre' if it otherwise ends on +-- `star', `plus', or `quest', and then, we have +-- +-- (1) discards `lexeme' accepted by `hre', +-- (2) turns the `lexeme' accepted by `hre' into a token, +-- (3) while discarding the lexeme accepted by `hre', transforms the +-- position and/or user state, and +-- (4) while discarding the lexeme accepted by `hre', transforms the +-- position and/or user state and returns a lexer to be used for the +-- next lexeme. +-- +-- The component `res' in case of a meta action, can be `Nothing', `Just +-- (Left err)', or `Just (Right token)' to return nothing, an error, or a +-- token from a meta action, respectively. +-- +-- * This module makes essential use of graphical data structures (for +-- representing the state transition graph) and laziness (for maintaining +-- the last action in `execLexer'. +-- +-- NOTES: +-- +-- * In this implementation, the combinators `quest`, `star`, and `plus` are +-- *right* associative - this was different in the ``Lazy Lexing is Fast'' +-- paper. This change was made on a suggestion by Martin Norbäck +-- . +-- +--- TODO ---------------------------------------------------------------------- +-- +-- * error correction is missing +-- +-- * in (>||<) in the last case, `(addBoundsNum bn bn')' is too simple, as +-- the number of outgoing edges is not the sum of the numbers of the +-- individual states when there are conflicting edges, ie, ones labeled +-- with the same character; however, the number is only used to decide a +-- heuristic, so it is questionable whether it is worth spending the +-- additional effort of computing the accurate number +-- +-- * Unicode posses a problem as the character domain becomes too big for +-- using arrays to represent transition tables and even sparse structures +-- will posse a significant overhead when character ranges are naively +-- represented. So, it might be time for finite maps again. +-- +-- Regarding the character ranges, there seem to be at least two +-- possibilities. Doaitse explicitly uses ranges and avoids expanding +-- them. The problem with this approach is that we may only have +-- predicates such as `isAlphaNum' to determine whether a givne character +-- belongs to some character class. From this representation it is +-- difficult to efficiently compute a range. The second approach, as +-- proposed by Tom Pledger (on the Haskell list) +-- would be to actually use predicates directly and make the whole business +-- efficient by caching predicate queries. In other words, for any given +-- character after we have determined (in a given state) once what the +-- following state on accepting that character is, we need not consult the +-- predicates again if we memorise the successor state the first time +-- around. +-- + +module Lexers ( + + Regexp, Lexer, Action, Meta, Error, + epsilon, char, (+>), + lexaction, lexactionErr, lexmeta, action, meta, + (>|<), (>||<), + star, plus, quest, alt, string, with, LexerState, execLexer + + ) where + +import Prelude hiding (last) +import Data.Maybe (fromMaybe) +import Data.Array (Array, (!), assocs, accumArray) + +infixr 4 `quest`, `star`, `plus` +infixl 3 +>, `lexaction`, `lexmeta`, `action`, `meta` +infixl 2 >|<, >||< + +-- constants +-- --------- + +-- we use the dense representation if a table has at least the given number of +-- (non-error) elements +-- +denseMin :: Int +denseMin = 20 + + +-- data structures +-- --------------- + +-- represents the number of (non-error) elements and the bounds of a table +-- +type BoundsNum = (Int, Char, Char) + +-- empty bounds +-- +-- nullBoundsNum :: BoundsNum +-- nullBoundsNum = (0, maxBound, minBound) + +-- combine two bounds +-- +addBoundsNum :: BoundsNum -> BoundsNum -> BoundsNum +addBoundsNum (n, lc, hc) (n', lc', hc') = (n + n', min lc lc', max hc hc') + +-- check whether a character is in the bounds +-- +inBounds :: Char -> BoundsNum -> Bool +inBounds c (_, lc, hc) = c >= lc && c <= hc + +-- Lexer errors +type Error = String + +-- Lexical actions take a lexeme with its position and may return a token; in +-- a variant, an error can be returned (EXPORTED) +-- +-- * if there is no token returned, the current lexeme is discarded lexing +-- continues looking for a token +-- +type Action t = String -> Maybe t +type ActionErr t = String -> Either Error t + +-- Meta actions transform the lexeme, and a user-defined state; they +-- may return a lexer, which is then used for accepting the next token +-- (this is important to implement non-regular behaviour like nested +-- comments) (EXPORTED) +-- +type Meta s t = String -> s -> (Maybe (Either Error t), -- err/tok? + s, -- state + Maybe (Lexer s t)) -- lexer? + +-- tree structure used to represent the lexer table (EXPORTED ABSTRACTLY) +-- +-- * each node in the tree corresponds to a state of the lexer; the associated +-- actions are those that apply when the corresponding state is reached +-- +data Lexer s t = Lexer (LexAction s t) (Cont s t) + +-- represent the continuation of a lexer +-- +data Cont s t = -- on top of the tree, where entries are dense, we use arrays + -- + Dense BoundsNum (Array Char (Lexer s t)) + -- + -- further down, where the valid entries are sparse, we + -- use association lists, to save memory (the first argument + -- is the length of the list) + -- + | Sparse BoundsNum [(Char, Lexer s t)] + -- + -- end of a automaton + -- + | Done + +-- lexical action (EXPORTED ABSTRACTLY) +-- +data LexAction s t = Action (Meta s t) + | NoAction + +-- a regular expression (EXPORTED) +-- +type Regexp s t = Lexer s t -> Lexer s t + + +-- basic combinators +-- ----------------- + +-- Empty lexeme (EXPORTED) +-- +epsilon :: Regexp s t +epsilon = id + +-- One character regexp (EXPORTED) +-- +char :: Char -> Regexp s t +char c = \l -> Lexer NoAction (Sparse (1, c, c) [(c, l)]) + +-- Concatenation of regexps (EXPORTED) +-- +(+>) :: Regexp s t -> Regexp s t -> Regexp s t +(+>) = (.) + +-- Close a regular expression with an action that converts the lexeme into a +-- token (EXPORTED) +-- +-- * Note: After the application of the action, the position is advanced +-- according to the length of the lexeme. This implies that normal +-- actions should not be used in the case where a lexeme might contain +-- control characters that imply non-standard changes of the position, +-- such as newlines or tabs. +-- +action :: Regexp s t -> Action t -> Lexer s t +action = lexaction + +lexaction :: Regexp s t -> Action t -> Lexer s t +lexaction re a = re `lexmeta` a' + where + a' lexeme s = + case a lexeme of + Nothing -> (Nothing, s, Nothing) + Just t -> (Just (Right t), s, Nothing) + +-- Variant for actions that may returns an error (EXPORTED) +-- +lexactionErr :: Regexp s t -> ActionErr t -> Lexer s t +lexactionErr re a = re `lexmeta` a' + where + a' lexeme s = (Just (a lexeme), s, Nothing) + +-- Close a regular expression with a meta action (EXPORTED) +-- +-- * Note: Meta actions have to advance the position in dependence of the +-- lexeme by themselves. +-- +meta :: Regexp s t -> Meta s t -> Lexer s t +meta = lexmeta + +lexmeta :: Regexp s t -> Meta s t -> Lexer s t +lexmeta re a = re (Lexer (Action a) Done) + +-- useful for building meta actions +with :: b -> Maybe (Either a b) +with a = Just (Right a) + +-- disjunctive combination of two regexps (EXPORTED) +-- +(>|<) :: Regexp s t -> Regexp s t -> Regexp s t +re >|< re' = \l -> re l >||< re' l + +-- disjunctive combination of two lexers (EXPORTED) +-- +(>||<) :: Lexer s t -> Lexer s t -> Lexer s t +(Lexer a c) >||< (Lexer a' c') = Lexer (joinActions a a') (joinConts c c') + +-- combine two disjunctive continuations +-- +joinConts :: Cont s t -> Cont s t -> Cont s t +joinConts Done c' = c' +joinConts c Done = c +joinConts c c' = let (bn , cls ) = listify c + (bn', cls') = listify c' + in + -- note: `addsBoundsNum' can, at this point, only + -- approx. the number of *non-overlapping* cases; + -- however, the bounds are correct + -- + aggregate (addBoundsNum bn bn') (cls ++ cls') + where + listify (Dense n arr) = (n, assocs arr) + listify (Sparse n cls) = (n, cls) + listify _ = error "Lexers.listify: Impossible argument!" + +-- combine two actions. Use the latter in case of overlap (!) +-- +joinActions :: LexAction s t -> LexAction s t -> LexAction s t +joinActions NoAction a' = a' +joinActions a NoAction = a +joinActions _ a' = a' -- error "Lexers.>||<: Overlapping actions!" + +-- Note: `n' is only an upper bound of the number of non-overlapping cases +-- +aggregate :: BoundsNum -> ([(Char, Lexer s t)]) -> Cont s t +aggregate bn@(n, lc, hc) cls + | n >= denseMin = Dense bn (accumArray (>||<) noLexer (lc, hc) cls) + | otherwise = Sparse bn (accum (>||<) cls) + where + noLexer = Lexer NoAction Done + +-- combine the elements in the association list that have the same key +-- +accum :: Eq a => (b -> b -> b) -> [(a, b)] -> [(a, b)] +accum _ [] = [] +accum f ((c, el):ces) = + let (ce, ces') = gather c el ces + in ce : accum f ces' + where + gather k e [] = ((k, e), []) + gather k e (ke'@(k', e'):kes) | k == k' = gather k (f e e') kes + | otherwise = let + (ke'', kes') = gather k e kes + in + (ke'', ke':kes') + + +-- non-basic combinators +-- --------------------- + +-- x `star` y corresponds to the regular expression x*y (EXPORTED) +-- +star :: Regexp s t -> Regexp s t -> Regexp s t +-- +-- The definition used below can be obtained by equational reasoning from this +-- one (which is much easier to understand): +-- +-- star re1 re2 = let self = (re1 +> self >|< epsilon) in self +> re2 +-- +-- However, in the above, `self' is of type `Regexp s t' (ie, a functional), +-- whereas below it is of type `Lexer s t'. Thus, below we have a graphical +-- body (finite representation of an infinite structure), which doesn't grow +-- with the size of the accepted lexeme - in contrast to the definition using +-- the functional recursion. +-- +star re1 re2 = \l -> let self = re1 self >||< re2 l + in + self + +-- x `plus` y corresponds to the regular expression x+y (EXPORTED) +-- +plus :: Regexp s t -> Regexp s t -> Regexp s t +plus re1 re2 = re1 +> (re1 `star` re2) + +-- x `quest` y corresponds to the regular expression x?y (EXPORTED) +-- +quest :: Regexp s t -> Regexp s t -> Regexp s t +quest re1 re2 = (re1 +> re2) >|< re2 + +-- accepts a non-empty set of alternative characters (EXPORTED) +-- +alt :: [Char] -> Regexp s t +-- +-- Equiv. to `(foldr1 (>|<) . map char) cs', but much faster +-- +alt [] = error "Lexers.alt: Empty character set!" +alt cs = \l -> let bnds = (length cs, minimum cs, maximum cs) + in + Lexer NoAction (aggregate bnds [(c, l) | c <- cs]) + +-- accept a character sequence (EXPORTED) +-- +string :: String -> Regexp s t +string [] = error "Lexers.string: Empty character set!" +string cs = (foldr1 (+>) . map char) cs + + +-- execution of a lexer +-- -------------------- + +-- threaded top-down during lexing (current input, meta state) (EXPORTED) +-- +type LexerState s = (String, s) + +-- apply a lexer, yielding a token sequence and a list of errors (EXPORTED) +-- +-- * Currently, all errors are fatal; thus, the result is undefined in case of +-- an error (this changes when error correction is added). +-- +-- * The final lexer state is returned. +-- +-- * The order of the error messages is undefined. +-- +execLexer :: Lexer s t -> LexerState s -> ([t], LexerState s, [Error]) +-- +-- * the following is moderately tuned +-- +execLexer _ st@([], _) = ([], st, []) +execLexer l st = + case lexOne l st of + (Nothing , _ , st') -> execLexer l st' + (Just res, l', st') -> let (ts, final, allErrs) = execLexer l' st' + in case res of + (Left err) -> (ts , final, err:allErrs) + (Right t ) -> (t:ts, final, allErrs) + where + -- accept a single lexeme + -- + -- lexOne :: Lexer s t -> LexerState s t + -- -> (Either Error (Maybe t), Lexer s t, LexerState s t) + lexOne l0 st' = oneLexeme l0 st' zeroDL lexErr + + where + -- the result triple of `lexOne' that signals a lexical error; + -- the result state is advanced by one character for error correction + -- + lexErr = let (cs, s) = st' + err = "Lexical error!\n" ++ + "The character " ++ show (head cs) + ++ " does not fit here; skipping it." + in + (Just (Left err), l, (tail cs, s)) + + -- + -- we take an open list of characters down, where we accumulate the + -- lexeme; this function returns maybe a token, the next lexer to use + -- (can be altered by a meta action), the new lexer state, and a list + -- of errors + -- + -- we implement the "principle of the longest match" by taking a + -- potential result quadruple down (in the last argument); the + -- potential result quadruple is updated whenever we pass by an action + -- (different from `NoAction'); initially it is an error result + -- + + -- (dons): from the paper "we have to take the last possible + -- action before the automaton gets stuck. .. when no further + -- transition is possible, we execute the last action on the + -- associated lexeme." This means that even once all possible + -- actions have been looked at, we currently then wait till the + -- _next_ char, before returning the last action we're carrying + -- around. For interactive use, we instead need to execute the + -- last action once we encounter it, not once we've gone past + -- it. Hmm... + + -- + -- oneLexeme :: Lexer s t + -- -> LexerState + -- -> DList Char + -- -> (Maybe (Either Error t), Maybe (Lexer s t), + -- LexerState s t) + -- -> (Maybe (Either Error t), Maybe (Lexer s t), + -- LexerState s t) + -- + oneLexeme (Lexer a cont) state@(cs, s) csDL last = + let last' = doaction a csDL state last + in case cs of + [] -> last' -- at end, has to be this action + (c:cs') -> oneChar cont c (cs', s) csDL last' -- keep looking + + -- + -- There are more chars. Look at the next one + -- + -- Now, if the next tbl is Done, then there is no more + -- transition, so immediately execute our action + -- + oneChar tbl c state csDL last = + case peek tbl c of + Nothing -> last + Just (Lexer a Done) -> doaction a (csDL `snocDL` c) state last + Just l' -> continue l' c state csDL last + + -- + -- Do the lookup. + -- + peek Done _ = Nothing + peek (Dense bn arr) c | c `inBounds` bn = Just $ arr ! c + peek (Sparse bn cls) c | c `inBounds` bn = lookup c cls + peek _ _ = Nothing + + -- + -- continue within the current lexeme + -- + continue l' c state csDL last = + oneLexeme l' state (csDL `snocDL` c) last + + -- + -- execute the action if present and finalise the current lexeme + -- + doaction (Action f) csDL (cs, s) _last = + case f (closeDL csDL) s of + (Nothing, s', l') + | not . null $ cs -> lexOne (fromMaybe l0 l') (cs, s') + (res, s', l') -> (res, (fromMaybe l0 l'), (cs, s')) + + doaction NoAction _csDL _state last = last -- no change + +------------------------------------------------------------------------ +-- +-- This module provides the functional equivalent of the difference lists +-- from logic programming. They provide an O(1) append. +-- + + +-- | a difference list is a function that given a list returns the original +-- contents of the difference list prepended at the given list (EXPORTED) +type DList a = [a] -> [a] + +-- | open a list for use as a difference list (EXPORTED) +{- +openDL :: [a] -> DList a +openDL = (++) +-} + +-- | create a difference list containing no elements (EXPORTED) +zeroDL :: DList a +zeroDL = id + +-- | create difference list with given single element (EXPORTED) +{- +unitDL :: a -> DList a +unitDL = (:) +-} + +-- | append a single element at a difference list (EXPORTED) +snocDL :: DList a -> a -> DList a +snocDL dl x = \l -> dl (x:l) + +-- | appending difference lists (EXPORTED) +{- +joinDL :: DList a -> DList a -> DList a +joinDL = (.) +-} + +-- | closing a difference list into a normal list (EXPORTED) +closeDL :: DList a -> [a] +closeDL = ($[]) diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,107 @@ +-- +-- Copyright (c) Don Stewart 2004-2008. +-- Copyright (c) Tuomo Valkonen 2004. +-- Copyright (c) 2019 Galen Huntington +-- +-- 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 Main where + +import Core (start, readSt, shutdown) +import Tree (SerialT(..)) +import Utils ((<+>)) +import Config (darcsinfo, help, versinfo) + +import qualified Data.ByteString.Char8 as P (pack,ByteString) + +import Control.Exception (catch, SomeException) + +import System.IO (hPutStrLn, stderr) +import System.Exit (ExitCode(..), exitWith) +import System.Posix.Signals (installHandler, sigTERM, sigPIPE, sigINT, sigHUP + ,sigALRM, sigABRT, Handler(Ignore, Default, Catch)) + +import System.Environment (getArgs) + +-- --------------------------------------------------------------------- +-- | Set up the signal handlers + +-- +-- Notes on setStoppedChildFlag: +-- If this bit is set when installing a catching function for the SIGCHLD +-- signal, the SIGCHLD signal will be generated only when a child process +-- exits, not when a child process stops. +-- +-- setStoppedChildFlag True +-- +initSignals :: IO () +initSignals = do + + -- ignore + flip mapM_ [sigPIPE, sigALRM] + (\sig -> installHandler sig Ignore Nothing) + + -- and exit if we get the following: + flip mapM_ [sigINT, sigHUP, sigABRT, sigTERM] $ \sig -> do + installHandler sig (Catch (do + Control.Exception.catch (shutdown Nothing) (\ (f :: SomeException) -> hPutStrLn stderr (show f)) + exitWith (ExitFailure 1) )) Nothing + +releaseSignals :: IO () +releaseSignals = + flip mapM_ [sigINT, sigPIPE, sigHUP, sigABRT, sigTERM] + (\sig -> installHandler sig Default Nothing) + +------------------------------------------------------------------------ +-- | Argument parsing. + +-- usage string. +usage :: [String] +usage = ["Usage: hmp3 [-Vh] [FILE|DIR ...]" + ,"-V --version Show version information" + ,"-h --help Show this help"] + +-- | Parse the args +do_args :: [P.ByteString] -> IO (Either SerialT [P.ByteString]) +do_args [] = do -- attempt to read db + x <- readSt + case x of + Nothing -> do mapM_ putStrLn usage; exitWith ExitSuccess + Just st -> return $ Left st + +do_args [s] | s == P.pack "-V" || s == P.pack "--version" + = do putStrLn (versinfo <+> help); putStrLn darcsinfo; exitWith ExitSuccess + | s == P.pack "-h" || s == P.pack "--help" + = do putStrLn (versinfo <+> help); mapM_ putStrLn usage; exitWith ExitSuccess + +do_args xs = return $ Right xs + +-- --------------------------------------------------------------------- +-- | Static main. This is the front end to the statically linked +-- application, and the real front end, in a sense. 'dynamic_main' calls +-- this after setting preferences passed from the boot loader. +-- +-- Initialise the ui getting an initial editor state, set signal +-- handlers, then jump to ui event loop with the state. +-- +main :: IO () +main = do + args <- return . map P.pack =<< getArgs + files <- do_args args + initSignals + start files -- never returns + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,88 @@ + +## hmp3-ng + +The `hmp3` music player, written in Haskell, dates to 2005, and has a +curses-based interface which can be used in an ordinary text terminal. +But it has become abandonware: the last update was in June 2008, +and it no longer builds with today's Haskell and standard libraries. + +This repository is a work in progress to resurrect this software. + +The original Darcs repo has vanished from the Internet. However, I +have a copy I checked out in 2008 (to hack on!) with all the patches +through version 1.5.1 (the latest is 1.5.2.1, which I had at one point +but cannot find), and Hackage hosts tarballs for several versions. + +* I used [darcs-to-git](https://github.com/purcell/darcs-to-git) +to port to Git. + +* I added commits for the changes in the two later published versions. +These were fairly small, the bulk being the regeneration of the +`configure` file using a newer version of GNU `autoconf`. + +* I updated the code to compile under modern GHC (8.6.5 as of this +writing) and libraries. Some code could not be directly ported, +mainly low-level optimizations, and so was replaced. + +* There is a Github issue tracker to cover other problems and +planned changes. + +* I have added support for building with Stack. + +* All C code is removed. There is still some use of the FFI. + +* Work on other features and changes, and documentation, is ongoing. + +I have also made a few changes and additions to the key bindings per +my preference. + +I am still working out the flaws. Let me know if there are problems. + + +## Installation + +Either `cabal install` or `stack install` will build a binary. +You will need to have `mpg123` installed, which is free software and +widely available in package managers. Although `mpg321` could also +be used, support is currently poor. + +The build depends on the package `hscurses`, which in turn requires +curses dev files. In Ubuntu/Debian, for example, these can be gotten +by installing `libncurses5-dev`. + + +## Use + +The `hmp3` executable is called with arguments containing a list of mp3 +files or directories of mp3 files. With no arguments, it will use the +playlist from the last time it was run, which is stored in `~/.hmp3db`. + +``` +$ hmp3 ~/Music ~/Downloads/La-La.mp3 +$ hmp3 +``` + +Once running, `hmp3` is controlled by fairly intuitive key commands. +`h` shows a help menu, and `q` quits. + +A color scheme can be specified by writing out a `Config { .. }` +value in `~/.hmp3`. See `Style.hs` for the definition. The `l` +command reloads this configuration. + + +## Original authorship list + +``` +License: + GPL + +Author: + Don Stewart, Tue Jan 15 15:16:55 PST 2008 + +Contributors: + Samuel Bronson + Stefan Wehr + Tomasz Zielonka + David Himmelstrup +``` + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/State.hs b/State.hs new file mode 100644 --- /dev/null +++ b/State.hs @@ -0,0 +1,171 @@ +-- +-- Copyright (c) 2004-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- Copyright (c) 2019 Galen Huntington +-- +-- 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. +-- + +-- +-- | The top level application state, and operations on that value. +-- +module State where + +import FastIO (FiltHandle(..)) +import Syntax (Status(Stopped), Mode(..), Frame, Info,Id3) +import Tree (FileArray, DirArray) +import Style (StringA(Fast), defaultSty, UIStyle) +import qualified Data.ByteString as P (empty,ByteString) +import qualified Config (defaultStyle) + +import Text.Regex.PCRE.Light (Regex) +import Data.Array (listArray) +import System.IO.Unsafe (unsafePerformIO) +import System.Posix.Types (ProcessID) +import System.Time (ClockTime(..)) +import System.IO (Handle) +import System.Random.Mersenne + +import Control.Concurrent (ThreadId) +import Control.Concurrent.MVar +import Data.IORef + +-- import Control.Monad.State + +------------------------------------------------------------------------ +-- A state monad over IO would be another option. + +-- type ST = StateT HState IO + +------------------------------------------------------------------------ + +-- | The editor state type +data HState = HState { + music :: !FileArray + ,folders :: !DirArray + ,size :: !Int -- cache size of list + ,current :: !Int -- currently playing mp3 + ,cursor :: !Int -- mp3 under the cursor + ,clock :: !(Maybe Frame) -- current clock value + ,clockUpdate :: !Bool + ,mp3pid :: !(Maybe ProcessID) -- pid of decoder + ,writeh :: !(MVar Handle) -- handle to mp3 (should be MVars?) + ,errh :: !(MVar Handle) -- error handle to mp3 + ,readf :: !(MVar FiltHandle) -- r/w pipe to mp3 + ,threads :: ![ThreadId] -- all our threads + ,id3 :: !(Maybe Id3) -- maybe mp3 id3 info + ,info :: !(Maybe Info) -- mp3 info + ,status :: !Status + ,minibuffer :: !StringA -- contents of minibuffer + ,helpVisible :: !Bool -- is the help window shown + ,miniFocused :: !Bool -- is the mini buffer focused? + ,mode :: !Mode -- random mode + ,uptime :: !P.ByteString + ,boottime :: !ClockTime + ,regex :: !(Maybe (Regex,Bool)) -- most recent search pattern and direction + ,xterm :: !Bool + ,doNotResuscitate:: !Bool -- should we just let mpg321 die? + ,config :: !UIStyle -- config values + + ,modified :: !(MVar ()) -- Set when redrawable components of + -- the state are modified. The ui + -- refresh thread waits on this. + ,randomGen :: MTGen + } + +------------------------------------------------------------------------ +-- +-- | The initial state +-- +emptySt :: HState +emptySt = HState { + music = listArray (0,0) [] + ,folders = listArray (0,0) [] + + ,size = 0 + ,current = 0 + ,cursor = 0 + + ,threads = [] + ,modified = unsafePerformIO newEmptyMVar + ,writeh = unsafePerformIO newEmptyMVar + ,errh = unsafePerformIO newEmptyMVar + ,readf = unsafePerformIO newEmptyMVar + + ,mp3pid = Nothing + ,clock = Nothing + ,info = Nothing + ,id3 = Nothing + ,regex = Nothing + + ,clockUpdate = False + ,helpVisible = False + ,miniFocused = False + ,xterm = False + ,doNotResuscitate = False -- mgp321 should be be restarted + + ,config = Config.defaultStyle + ,boottime = TOD 0 0 + ,status = Stopped + ,mode = Normal + ,minibuffer = Fast P.empty defaultSty + ,uptime = P.empty + ,randomGen = unsafePerformIO (newMTGen Nothing) + } + +-- +-- | A global variable holding the state. Todo StateT +-- +state :: MVar HState +state = unsafePerformIO $ newMVar emptySt +{-# NOINLINE state #-} + +------------------------------------------------------------------------ +-- state accessor functions + +-- | Access a component of the state with a projection function +getsST :: (HState -> a) -> IO a +getsST f = withST (return . f) + +-- | Perform a (read-only) IO action on the state +withST :: (HState -> IO a) -> IO a +withST f = readMVar state >>= f + +-- | Modify the state with a pure function +silentlyModifyST :: (HState -> HState) -> IO () +silentlyModifyST f = modifyMVar_ state (return . f) + +------------------------------------------------------------------------ + +modifyST :: (HState -> HState) -> IO () +modifyST f = silentlyModifyST f >> touchST + +-- | Modify the state with an IO action, triggering a refresh +modifySTM :: (HState -> IO HState) -> IO () +modifySTM f = modifyMVar_ state f >> touchST + +-- | Modify the state with an IO action, returning a value +modifySTM_ :: (HState -> IO (HState,a)) -> IO a +modifySTM_ f = modifyMVar state f >>= \a -> touchST >> return a + +-- | Trigger a refresh. This is the only way to update the screen +touchST :: IO () +touchST = withMVar state $ \st -> tryPutMVar (modified st) () >> return () + +forceNextPacket :: IO () +forceNextPacket = do + fh <- readMVar =<< getsST readf + writeIORef (frameCount fh) 0 + diff --git a/Style.hs b/Style.hs new file mode 100644 --- /dev/null +++ b/Style.hs @@ -0,0 +1,350 @@ +-- +-- Copyright (c) 2004-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- Copyright (c) 2019 Galen Huntington +-- +-- 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. +-- + +-- +-- | Color manipulation +-- + +module Style where + +import qualified UI.HSCurses.Curses as Curses +import Data.ByteString (ByteString) + +import Data.Char (toLower) +import Data.Word (Word8) +import Data.Maybe (fromJust) +import Data.IORef (readIORef, writeIORef, newIORef, IORef) +import qualified Data.Map as M (fromList, empty, lookup, Map) + +import System.IO.Unsafe (unsafePerformIO) +import Control.Exception (handle, SomeException) + +------------------------------------------------------------------------ + +-- | User-configurable colours +-- Each component of this structure corresponds to a fg\/bg colour pair +-- for an item in the ui +data UIStyle = UIStyle { + window :: !Style -- default window colour + , helpscreen :: !Style -- help screen + , titlebar :: !Style -- titlebar of window + , selected :: !Style -- currently playing track + , cursors :: !Style -- the scrolling cursor line + , combined :: !Style -- the style to use when the cursor is on the current track + , warnings :: !Style -- style for warnings + , blockcursor :: !Style -- style for the block cursor when typing text + , progress :: !Style -- style for the progress bar + } + +------------------------------------------------------------------------ + +-- | Colors +data Color + = RGB {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 + | Default + | Reverse + deriving (Eq,Ord) + +-- | Foreground and background color pairs +data Style = Style !Color !Color + deriving (Eq,Ord) + +-- | A list of such values (the representation is optimised) +data StringA + = Fast {-# UNPACK #-} !ByteString {-# UNPACK #-} !Style + | FancyS ![(ByteString,Style)] -- one line made up of segments + +------------------------------------------------------------------------ +-- +-- | Some simple colours (derivied from proxima\/src\/common\/CommonTypes.hs) +-- +-- But we don't have a light blue? +-- +black, grey, darkred, red, darkgreen, green, brown, yellow :: Color +darkblue, blue, purple, magenta, darkcyan, cyan, white, brightwhite :: Color +black = RGB 0 0 0 +grey = RGB 128 128 128 +darkred = RGB 139 0 0 +red = RGB 255 0 0 +darkgreen = RGB 0 100 0 +green = RGB 0 128 0 +brown = RGB 165 42 42 +yellow = RGB 255 255 0 +darkblue = RGB 0 0 139 +blue = RGB 0 0 255 +purple = RGB 128 0 128 +magenta = RGB 255 0 255 +darkcyan = RGB 0 139 139 +cyan = RGB 0 255 255 +white = RGB 165 165 165 +brightwhite = RGB 255 255 255 + +defaultfg, defaultbg, reversefg, reversebg :: Color +defaultfg = Default +defaultbg = Default +reversefg = Reverse +reversebg = Reverse + +-- +-- | map strings to colors +-- +stringToColor :: String -> Maybe Color +stringToColor s = case map toLower s of + "black" -> Just black + "grey" -> Just grey + "darkred" -> Just darkred + "red" -> Just red + "darkgreen" -> Just darkgreen + "green" -> Just green + "brown" -> Just brown + "yellow" -> Just yellow + "darkblue" -> Just darkblue + "blue" -> Just blue + "purple" -> Just purple + "magenta" -> Just magenta + "darkcyan" -> Just darkcyan + "cyan" -> Just cyan + "white" -> Just white + "brightwhite" -> Just brightwhite + "default" -> Just Default + "reverse" -> Just Reverse + _ -> Nothing + +------------------------------------------------------------------------ +-- +-- | Set some colours, perform an action, and then reset the colours +-- +withStyle :: Style -> (IO ()) -> IO () +withStyle sty fn = uiAttr sty >>= setAttribute >> fn >> reset +{-# INLINE withStyle #-} + +-- +-- | manipulate the current attributes of the standard screen +-- Only set attr if it's different to the current one? +-- +setAttribute :: (Curses.Attr, Curses.Pair) -> IO () +setAttribute = uncurry Curses.attrSet +{-# INLINE setAttribute #-} + +-- +-- | Reset the screen to normal values +-- +reset :: IO () +reset = setAttribute (Curses.attr0, Curses.Pair 0) +{-# INLINE reset #-} + +-- +-- | And turn on the colours +-- +initcolours :: UIStyle -> IO () +initcolours sty = do + let ls = [helpscreen sty, warnings sty, window sty, + selected sty, titlebar sty, progress sty, + blockcursor sty, cursors sty, combined sty ] + (Style fg bg) = progress sty -- bonus style + + pairs <- initUiColors (ls ++ [Style bg bg, Style fg fg]) + writeIORef pairMap pairs + -- set the background + uiAttr (window sty) >>= \(_,p) -> Curses.bkgrndSet nullA p + +------------------------------------------------------------------------ +-- +-- | Set up the ui attributes, given a ui style record +-- +-- Returns an association list of pairs for foreground and bg colors, +-- associated with the terminal color pair that has been defined for +-- those colors. +-- +initUiColors :: [Style] -> IO PairMap +initUiColors stys = do + ls <- sequence [ uncurry fn m | m <- zip stys [1..] ] + return (M.fromList ls) + where + fn :: Style -> Int -> IO (Style, (Curses.Attr,Curses.Pair)) + fn sty p = do + let (CColor (a,fgc),CColor (b,bgc)) = style2curses sty + handle (\ (_ :: SomeException) -> return ()) $ + Curses.initPair (Curses.Pair p) fgc bgc + return (sty, (a `Curses.attrPlus` b, Curses.Pair p)) + +------------------------------------------------------------------------ +-- +-- | Getting from nice abstract colours to ncurses-settable values + +-- 20% of allocss occur here! But there's only 3 or 4 colours :/ +-- Every call to uiAttr +-- +uiAttr :: Style -> IO (Curses.Attr, Curses.Pair) +uiAttr sty = do + m <- readIORef pairMap + return $ lookupPair m sty +{-# INLINE uiAttr #-} + +-- | Given a curses color pair, find the Curses.Pair (i.e. the pair +-- curses thinks these colors map to) from the state +lookupPair :: PairMap -> Style -> (Curses.Attr, Curses.Pair) +lookupPair m s = case M.lookup s m of + Nothing -> (Curses.attr0, Curses.Pair 0) -- default settings + Just v -> v +{-# INLINE lookupPair #-} + +-- | Keep a map of nice style defs to underlying curses pairs, created at init time +type PairMap = M.Map Style (Curses.Attr, Curses.Pair) + +-- | map of Curses.Color pairs to ncurses terminal Pair settings +pairMap :: IORef PairMap +pairMap = unsafePerformIO $ newIORef M.empty +{-# NOINLINE pairMap #-} + +------------------------------------------------------------------------ +-- +-- Basic (ncurses) colours. +-- +defaultColor :: Curses.Color +defaultColor = fromJust $ Curses.color "default" + +cblack, cred, cgreen, cyellow, cblue, cmagenta, ccyan, cwhite :: Curses.Color +cblack = fromJust $ Curses.color "black" +cred = fromJust $ Curses.color "red" +cgreen = fromJust $ Curses.color "green" +cyellow = fromJust $ Curses.color "yellow" +cblue = fromJust $ Curses.color "blue" +cmagenta = fromJust $ Curses.color "magenta" +ccyan = fromJust $ Curses.color "cyan" +cwhite = fromJust $ Curses.color "white" + +-- +-- Combine attribute with another attribute +-- +setBoldA, setReverseA :: Curses.Attr -> Curses.Attr +setBoldA = flip Curses.setBold True +setReverseA = flip Curses.setReverse True + +-- +-- | Some attribute constants +-- +boldA, nullA, reverseA :: Curses.Attr +nullA = Curses.attr0 +boldA = setBoldA nullA +reverseA = setReverseA nullA + +------------------------------------------------------------------------ + +newtype CColor = CColor (Curses.Attr, Curses.Color) +-- +-- | Map Style rgb rgb colours to ncurses pairs +-- TODO a generic way to turn an rgb into the nearest curses color +-- +style2curses :: Style -> (CColor, CColor) +style2curses (Style fg bg) = (fgCursCol fg, bgCursCol bg) +{-# INLINE style2curses #-} + +fgCursCol :: Color -> CColor +fgCursCol c = case c of + RGB 0 0 0 -> CColor (nullA, cblack) + RGB 128 128 128 -> CColor (boldA, cblack) + RGB 139 0 0 -> CColor (nullA, cred) + RGB 255 0 0 -> CColor (boldA, cred) + RGB 0 100 0 -> CColor (nullA, cgreen) + RGB 0 128 0 -> CColor (boldA, cgreen) + RGB 165 42 42 -> CColor (nullA, cyellow) + RGB 255 255 0 -> CColor (boldA, cyellow) + RGB 0 0 139 -> CColor (nullA, cblue) + RGB 0 0 255 -> CColor (boldA, cblue) + RGB 128 0 128 -> CColor (nullA, cmagenta) + RGB 255 0 255 -> CColor (boldA, cmagenta) + RGB 0 139 139 -> CColor (nullA, ccyan) + RGB 0 255 255 -> CColor (boldA, ccyan) + RGB 165 165 165 -> CColor (nullA, cwhite) + RGB 255 255 255 -> CColor (boldA, cwhite) + Default -> CColor (nullA, defaultColor) + Reverse -> CColor (reverseA, defaultColor) + _ -> CColor (nullA, cblack) -- NB + +bgCursCol :: Color -> CColor +bgCursCol c = case c of + RGB 0 0 0 -> CColor (nullA, cblack) + RGB 128 128 128 -> CColor (nullA, cblack) + RGB 139 0 0 -> CColor (nullA, cred) + RGB 255 0 0 -> CColor (nullA, cred) + RGB 0 100 0 -> CColor (nullA, cgreen) + RGB 0 128 0 -> CColor (nullA, cgreen) + RGB 165 42 42 -> CColor (nullA, cyellow) + RGB 255 255 0 -> CColor (nullA, cyellow) + RGB 0 0 139 -> CColor (nullA, cblue) + RGB 0 0 255 -> CColor (nullA, cblue) + RGB 128 0 128 -> CColor (nullA, cmagenta) + RGB 255 0 255 -> CColor (nullA, cmagenta) + RGB 0 139 139 -> CColor (nullA, ccyan) + RGB 0 255 255 -> CColor (nullA, ccyan) + RGB 165 165 165 -> CColor (nullA, cwhite) + RGB 255 255 255 -> CColor (nullA, cwhite) + Default -> CColor (nullA, defaultColor) + Reverse -> CColor (reverseA, defaultColor) + _ -> CColor (nullA, cwhite) -- NB + +defaultSty :: Style +defaultSty = Style Default Default + +------------------------------------------------------------------------ +-- +-- Support for runtime configuration +-- We choose a simple strategy, read/showable record types, with strings +-- to represent colors +-- +-- The fields must map to UIStyle +-- +-- It is this data type that is stored in 'show' format in ~/.hmp3 +-- +data Config = Config { + hmp3_window :: (String,String) + , hmp3_helpscreen :: (String,String) + , hmp3_titlebar :: (String,String) + , hmp3_selected :: (String,String) + , hmp3_cursors :: (String,String) + , hmp3_combined :: (String,String) + , hmp3_warnings :: (String,String) + , hmp3_blockcursor :: (String,String) + , hmp3_progress :: (String,String) + } deriving (Show,Read) + +-- +-- | Read the ~/.hmp3 file, and construct a UIStyle from it, to insert +-- into +-- +buildStyle :: Config -> UIStyle +buildStyle bs = UIStyle { + window = f $ hmp3_window bs + , helpscreen = f $ hmp3_helpscreen bs + , titlebar = f $ hmp3_titlebar bs + , selected = f $ hmp3_selected bs + , cursors = f $ hmp3_cursors bs + , combined = f $ hmp3_combined bs + , warnings = f $ hmp3_warnings bs + , blockcursor = f $ hmp3_blockcursor bs + , progress = f $ hmp3_progress bs + } + + where + f (x,y) = Style (g x) (g y) + g x = case stringToColor x of + Nothing -> Default + Just y -> y diff --git a/Syntax.hs b/Syntax.hs new file mode 100644 --- /dev/null +++ b/Syntax.hs @@ -0,0 +1,158 @@ +-- +-- Copyright (c) 2005-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- Copyright (c) 2019 Galen Huntington +-- +-- 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. +-- + +-- +-- abstract syntax for mpg123/321 'remote control' commands, so we get +-- type safe messaging, and parsing of results +-- +-- See 'README.remote' distributed with mpg321. +-- + +module Syntax where + +import qualified Data.ByteString.Char8 as P (concat,pack,ByteString) + +------------------------------------------------------------------------ +-- +-- Values we may print out: + +-- Loads and starts playing +-- +data Load = Load {-# UNPACK #-} !P.ByteString + +instance Pretty Load where + ppr (Load f) = P.concat [P.pack "LOAD ", f] + +-- If '+' or '-' is specified, jumps frames forward, or backwards, +-- respectively, in the the mp3 file. If neither is specifies, jumps to +-- absolute frame in the mp3 file. +data Jump = Jump {-# UNPACK #-} !Int + +instance Pretty Jump where + ppr (Jump i) = P.concat [P.pack "JUMP ", P.pack . show $ i] + +-- Pauses the playback of the mp3 file; if already paused, restarts playback. +data Pause = Pause + +instance Pretty Pause where + ppr Pause = P.pack "PAUSE" + +-- Quits mpg321. +data Quit = Quit + +instance Pretty Quit where + ppr Quit = P.pack "QUIT" + +------------------------------------------------------------------------ +-- +-- Values we may have to read back in + +-- mpg123 tagline. Output at startup. +data Tag = Tag + +-- Track info if ID fields are in the file, otherwise file name. +data File = File !(Either P.ByteString Id3) + +-- ID3 info +data Id3 = Id3 + { id3title :: !P.ByteString + , id3artist :: !P.ByteString + , id3album :: !P.ByteString + , id3str :: !P.ByteString } -- cache screen string to draw + +-- , year :: Maybe P.ByteString +-- , genre :: Maybe P.ByteString } + + + +-- Outputs information about the mp3 file after loading. +-- : version of the mp3 file. Currently always 1.0 with madlib, but don't +-- depend on it, particularly if you intend portability to mpg123 as well. +-- Float/string. +-- : layer: 1, 2, or 3. Integer. +-- : Samplerate. Integer. +-- : Mode string. String. +-- : Mode extension. Integer. +-- : Bytes per frame (estimate, particularly if the stream is VBR). Integer. +-- : Number of channels (1 or 2, usually). Integer. +-- : Is stream copyrighted? (1 or 0). Integer. +-- : Is stream CRC protected? (1 or 0). Integer. +-- : Emphasis. Integer. +-- : Bitrate, in kbps. (i.e., 128.) Integer. +-- : Extension. Integer. +data Info = Info { + userinfo :: !P.ByteString -- user friendly string + -- version :: !P.ByteString, + -- layer :: !Int, -- 1,2 or 3 + -- sampleRate :: !Int, + -- playMode :: !P.ByteString, + -- modeExtns :: !Int, + -- bytesPerFrame :: !Int, + -- channelCount :: !Int, + -- copyrighted :: !Bool, + -- checksummed :: !Bool, + -- emphasis :: !Int, + -- bitrate :: !Int, + -- extension :: !Int + } + +-- @F +-- Frame decoding status updates (once per frame). +-- Current-frame and frames-remaining are integers; current-time and +-- time-remaining floating point numbers with two decimal places. +-- +-- Only 1 frame a second is actually read, so make sure it's lazy so +-- there's no need to evaluate all the others. +-- +data Frame = Frame { + currentFrame :: Int, + framesLeft :: Int, + currentTime :: (Int,Int), + timeLeft :: (Int,Int) + } + +-- @P {0, 1, 2} +-- Stop/pause status. +-- 0 - playing has stopped. When 'STOP' is entered, or the mp3 file is finished. +-- 1 - Playing is paused. Enter 'PAUSE' or 'P' to continue. +-- 2 - Playing has begun again. +data Status = Stopped + | Paused + | Playing + deriving Eq + +data Mode = Normal | Loop | Random deriving (Eq,Bounded,Enum) -- for pred,succ + +------------------------------------------------------------------------ + +-- +-- a pretty printing class +-- +class Pretty a where + ppr :: a -> P.ByteString + +-- +-- And a wrapper type +-- +data Msg = T {-# UNPACK #-} !Tag + | F {-# UNPACK #-} !File + | I {-# UNPACK #-} !Info + | R {-# UNPACK #-} !Frame + | S !Status diff --git a/Tree.hs b/Tree.hs new file mode 100644 --- /dev/null +++ b/Tree.hs @@ -0,0 +1,241 @@ +{-# OPTIONS -fno-warn-orphans #-} +-- +-- Copyright (c) 2005-8 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- Copyright (c) 2019 Galen Huntington +-- +-- 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. +-- + +-- +-- functions for manipulating file trees +-- + +module Tree where + +import FastIO +import Syntax (Mode(..)) +import qualified Data.ByteString.Char8 as P +import qualified Data.ByteString.Lazy as L +import Codec.Compression.GZip + +import Data.Binary + +import Data.Array +import Data.Maybe (catMaybes) +import Data.Char (toLower) +import Data.List (sortBy,sort,foldl',groupBy) + +import System.IO (hPutStrLn,stderr) +import System.Directory (Permissions(readable)) +import Control.Exception(handle, SomeException) +import Control.Monad (liftM) + +type FilePathP = P.ByteString + +-- | A filesystem hierarchy is flattened to just the end nodes +type DirArray = Array Int Dir + +-- | The complete list of .mp3 files +type FileArray = Array Int File + +-- | A directory entry is the directory name, and a list of bound +-- indicies into the Files array. +data Dir = + Dir { dname :: !FilePathP -- ^ directory name + , dsize :: !Int -- ^ number of file entries + , dlo :: !Int -- ^ index of first entry + , dhi :: !Int } -- ^ index of last entry + +-- Most data is allocated in this structure +data File = + File { fbase :: !FilePathP -- ^ basename of file + , fdir :: !Int } -- ^ index of Dir entry + +-- +-- | Given the start directories, populate the dirs and files arrays +-- +buildTree :: [FilePathP] -> IO (DirArray, FileArray) +buildTree fs = do + (os,dirs) <- partition fs -- note we will lose the ordering of files given on cmd line. + + let loop xs | seq xs False = undefined -- strictify + loop [] = return [] + loop (a:xs) = do + (m,ds) <- expandDir a + ms <- loop $! ds ++ xs -- add to work list + return $! m : ms + + ms' <- liftM catMaybes $! loop dirs + + let extras = merge . doOrphans $ os + ms = ms' ++ extras + + let (_,n,dirls,filels) = foldl' make (0,0,[],[]) ms + dirsArray = listArray (0,length dirls - 1) (reverse dirls) + fileArray = listArray (0, n-1) (reverse filels) + + dirsArray `seq` fileArray `seq` return $ (dirsArray, fileArray) + +-- | Create nodes based on dirname for orphan files on cmdline +doOrphans :: [FilePathP] -> [(FilePathP, [FilePathP])] +doOrphans [] = [] +doOrphans (f:xs) = (dirnameP f, [basenameP f]) : doOrphans xs + +-- | Merge entries with the same root node into a single node +merge :: [(FilePathP, [FilePathP])] -> [(FilePathP, [FilePathP])] +merge [] = [] +merge xs = + let xs' = sortBy (\a b -> fst a `compare` fst b) xs + xs''= groupBy (\a b -> fst a == fst b) xs' + in catMaybes $ map flatten xs'' + where + flatten :: [(FilePathP,[FilePathP])] -> Maybe (FilePathP, [FilePathP]) + flatten [] = Nothing -- can't happen + flatten (x:ys) = let d = fst x in Just (d, snd x ++ concatMap snd ys) + +-- | fold builder, for generating Dirs and Files +make :: (Int,Int,[Dir],[File]) -> (FilePathP,[FilePathP]) -> (Int,Int,[Dir],[File]) +make (i,n,acc1,acc2) (d,fs) = + case listToDir n d fs of + (dir,n') -> case map makeFile fs of + fs' -> (i+1, n', dir:acc1, (reverse fs') ++ acc2) + where + makeFile f = File (basenameP f) i + +------------------------------------------------------------------------ + +-- | Expand a single directory into a maybe a pair of the dir name and any files +-- Return any extra directories to search in +-- +-- Assumes no evil sym links +-- +expandDir :: FilePathP -> IO (Maybe (FilePathP, [FilePathP]), [FilePathP]) +expandDir f | seq f False = undefined -- stricitfy +expandDir f = do + ls_raw <- Control.Exception.handle (\ (e :: SomeException) -> hPutStrLn stderr (show e) >> return []) $ + packedGetDirectoryContents f + let ls = map (\s -> P.intercalate (P.singleton '/') [f,s]) . sort . filter validFiles $! ls_raw + ls `seq` return () + (fs',ds) <- partition ls + let fs = filter onlyMp3s fs' + v = if null fs then Nothing else Just (f,fs) + return (v,ds) + where + notEdge p = p /= dot && p /= dotdot + validFiles p = notEdge p + onlyMp3s p = mp3 == (P.map toLower . P.drop (P.length p -3) $ p) + + mp3 = P.pack "mp3" + dot = P.pack "." + dotdot = P.pack ".." + +-- +-- | Given an the next index into the files array, a directory name, and +-- a list of files in that dir, build a Dir and return the next index +-- into the array +-- +listToDir :: Int -> FilePathP -> [FilePathP] -> (Dir, Int) +listToDir n d fs = + let dir = Dir { dname = packedFileNameEndClean d + , dsize = len + , dlo = n + , dhi = n + len - 1 } in (dir, n') + where + len = length fs + n' = n + len + +-- | break a list of file paths into a pair of subliests corresponding +-- to the paths that point to files and to directories. +partition :: [FilePathP] -> IO ([FilePathP], [FilePathP]) +partition xs | seq xs False = undefined -- how to make `partition' strict +partition [] = return ([],[]) +partition (a:xs) = do + (fs,ds) <- partition xs + x <- doesFileExist a + if x then do y <- getPermissions a >>= return . readable + return $! if y then (a:fs, ds) else (fs, ds) + else return (fs, a:ds) + +------------------------------------------------------------------------ +-- +-- And some more Binary instances +-- + +{- +instance Binary a => Binary (Array Int a) where + put arr = do + put (bounds arr) + mapM_ put (elems arr) + get = do + ((x,y) :: (Int,Int)) <- get + (els :: [a]) <- sequence $ take (y+1) $ repeat get + return $! listArray (x,y) els +-} + +instance Binary File where + put (File nm i) = put nm >> put i + get = do + nm <- get + i <- get + return (File nm i) + +instance Binary Dir where + put (Dir nm sz lo hi) = put nm >> put sz >> put lo >> put hi + get = do + nm <- get + sz <- get + lo <- get + hi <- get + return (Dir nm sz lo hi) + +instance Binary Mode where + put = put . fromEnum + get = liftM toEnum get + +-- How we write everything out +instance Binary SerialT where + put st = do + put (ser_farr st, ser_darr st) + put (ser_indx st) + put (ser_mode st) + + get = do + (a,b)<- get + i <- get + m <- get + return $ SerialT { + ser_farr = a + ,ser_darr = b + ,ser_indx = i + ,ser_mode = m + } + +----------------------------------------------------------------------- + +-- | Wrap up the values we're going to dump to disk +data SerialT = SerialT { + ser_farr :: FileArray, + ser_darr :: DirArray, + ser_indx :: Int, + ser_mode :: Mode + } + +writeTree :: FilePath -> SerialT -> IO () +writeTree f s = L.writeFile f (compress (encode s)) + +readTree :: FilePath -> IO SerialT +readTree f = do s <- L.readFile f + return (decode (decompress s)) diff --git a/UI.hs b/UI.hs new file mode 100644 --- /dev/null +++ b/UI.hs @@ -0,0 +1,730 @@ +-- +-- Copyright (C) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- Copyright (c) 2019 Galen Huntington +-- +-- 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. +-- +-- Derived from: riot/UI.hs +-- Copyright (c) Tuomo Valkonen 2004. +-- +-- Released under the same license. +-- + +-- +-- | This module defines a user interface implemented using ncurses. +-- +-- + +module UI ( + + -- * Construction, destruction + start, end, suspend, screenSize, refresh, refreshClock, resetui, + + -- * Input + getKey + + ) where + +import Style +import Utils (isLightBg) +import FastIO (basenameP, printfPS) +import Tree (File(fdir, fbase), Dir(dname)) +import State +import Syntax +import Config +import qualified UI.HSCurses.Curses as Curses +import {-# SOURCE #-} Keymap (extraTable, keyTable, unkey, charToKey) + +import Data.List (intersperse,isPrefixOf) +import Data.Array ((!), bounds, Array, listArray) +import Data.Array.Base (unsafeAt) +import Control.Monad (when, void) +import Control.Exception (catch, handle, SomeException) +import System.IO (stderr, hFlush) +import System.Posix.Signals (raiseSignal, sigTSTP, installHandler, Handler(..)) +import System.Posix.Env (getEnv, putEnv) + +import qualified Data.ByteString.Char8 as P +import qualified Data.ByteString as B + +import Foreign.C.Types (CInt(..)) +import Foreign.C.String (CString) + +-- import qualified Data.ByteString.UTF8 as UTF8 + +------------------------------------------------------------------------ + +-- +-- | how to initialise the ui +-- +start :: IO UIStyle +start = do + Control.Exception.handle (\ (_ :: SomeException) -> return ()) $ do -- tweak for OpenBSD console + thisterm <- getEnv "TERM" + case thisterm of + Just "vt220" -> putEnv "TERM=xterm-color" + Just t | "xterm" `isPrefixOf` t + -> silentlyModifyST $ \st -> st { xterm = True } + _ -> return () + + Curses.initCurses + case Curses.cursesSigWinch of + Just wch -> void $ installHandler wch (Catch resetui) Nothing + _ -> return () -- handled elsewhere + + colorify <- Curses.hasColors + light <- isLightBg + + let sty | colorify && light = lightBgStyle + | colorify = defaultStyle + | otherwise = bwStyle + + initcolours sty + Curses.keypad Curses.stdScr True -- grab the keyboard + nocursor + + return sty + +-- | Reset +resetui :: IO () +resetui = resizeui >> nocursor >> refresh + +-- | And force invisible +nocursor :: IO () +nocursor = do + Control.Exception.catch (Curses.cursSet Curses.CursorInvisible >> return ()) + (\ (_ :: SomeException) -> return ()) + +-- +-- | Clean up and go home. Refresh is needed on linux. grr. +-- +end :: Bool -> IO () +end isXterm = do when isXterm $ setXtermTitle [P.pack "xterm"] + Curses.endWin + +-- +-- | Suspend the program +-- +suspend :: IO () +suspend = raiseSignal sigTSTP + +-- +-- | Find the current screen height and width. +-- +screenSize :: IO (Int, Int) +screenSize = Curses.scrSize + +-- +-- | Read a key. UIs need to define a method for getting events. +-- We only need to refresh if we don't have no SIGWINCH support. +-- +getKey :: IO Char +getKey = do + k <- Curses.getCh + if k == Curses.KeyResize + then do + when (Curses.cursesSigWinch == Nothing) $ + void $ redraw >> resizeui -- do we need redraw here? + getKey + else return $ unkey k + +-- | Resize the window +-- From "Writing Programs with NCURSES", by Eric S. Raymond and Zeyd M. Ben-Halim +-- +resizeui :: IO (Int,Int) +resizeui = do + Curses.endWin + Curses.resetParams + do + -- not sure I need all these... + Curses.nl True + Curses.leaveOk True + Curses.noDelay Curses.stdScr False + Curses.cBreak True + -- Curses.meta stdScr True -- not in module + -- not sure about intrFlush, raw - set in hscurses + Curses.refresh + Curses.scrSize + +refresh :: IO () +refresh = redraw >> Curses.refresh + +refreshClock :: IO () +refreshClock = redrawJustClock >> Curses.refresh + +------------------------------------------------------------------------ + +type Pos = (Int{-H-}, Int{-W-}) +type Size = (Int{-H-}, Int{-W-}) + +-- +-- | A class for renderable objects, given the application state, and +-- for printing the object as a list of strings +-- +class Element a where + draw :: Size -> Pos -> HState -> Maybe Frame -> a + +-- +-- | The elements of the play mode widget +-- +data PlayScreen = PlayScreen !PPlaying !ProgressBar !PTimes + +-- | How does this all work? Firstly, we mostly want to draw fast strings +-- directly to the screen. To break the drawing problem down, you need +-- to write an instance of Element for each element in the ui. Larger +-- and larger elements then combine these items together. +-- +-- Obviously to write the element instance, you need a new type for each +-- element, to disinguish them. As follows: + +newtype PlayList = PlayList [StringA] + +newtype PPlaying = PPlaying StringA +newtype PVersion = PVersion P.ByteString +newtype PMode = PMode P.ByteString +newtype PMode2 = PMode2 P.ByteString +newtype ProgressBar = ProgressBar StringA +newtype PTimes = PTimes StringA + +newtype PInfo = PInfo P.ByteString +newtype PId3 = PId3 P.ByteString +newtype PTime = PTime P.ByteString + +newtype PlayTitle = PlayTitle StringA +newtype PlayInfo = PlayInfo P.ByteString +newtype PlayModes = PlayModes P.ByteString +newtype HelpScreen = HelpScreen [StringA] + +------------------------------------------------------------------------ + +instance Element PlayScreen where + draw w x y z = PlayScreen a b c + where + a = draw w x y z :: PPlaying + b = draw w x y z :: ProgressBar + c = draw w x y z :: PTimes + +-- | Decode the play screen +printPlayScreen :: PlayScreen -> [StringA] +printPlayScreen (PlayScreen (PPlaying a) + (ProgressBar b) + (PTimes c)) = [a , b , c] + +------------------------------------------------------------------------ + +instance (Element a, Element b) => Element (a,b) where + draw a b c d = (draw a b c d, draw a b c d) + +------------------------------------------------------------------------ + +-- Info about the current track +instance Element PPlaying where + draw w@(_,x') x st z = PPlaying . FancyS $ + [(spc2, defaultSty) + ,(alignLR (x'-4) a b, defaultSty)] + where + (PId3 a) = draw w x st z :: PId3 + (PInfo b) = draw w x st z :: PInfo + +-- | Id3 Info +instance Element PId3 where + draw _ _ st _ = case id3 st of + Just i -> PId3 $ id3str i + Nothing -> PId3 $ case size st of + 0 -> emptyVal + _ -> fbase $ (music st) ! (current st) + +-- | mp3 information +instance Element PInfo where + draw _ _ st _ = PInfo $ case info st of + Nothing -> emptyVal + Just i -> userinfo i + +emptyVal :: P.ByteString +emptyVal = P.pack "(empty)" + +spc2 :: P.ByteString +spc2 = spaces 2 + +------------------------------------------------------------------------ + +instance Element HelpScreen where + draw (_,w) _ st _ = HelpScreen $ + [ Fast (f cs h) sty | (h,cs,_) <- keyTable ] ++ + [ Fast (f cs h) sty | (h,cs) <- extraTable ] + where + sty = helpscreen . config $ st + + f :: [Char] -> P.ByteString -> P.ByteString + f cs ps = + let p = P.pack str `P.append` ps + s = P.pack (take (tot - P.length p) (repeat ' ')) + in p `P.append` s + where + tot = round $! fromIntegral w * (0.8::Float) + len = round $! fromIntegral tot * (0.2::Float) + + -- faststringify + str = take len $ ' ' : + (concat . intersperse " " $ (map pprIt cs)) ++ repeat ' ' + + pprIt c = case c of + '\n' -> "Enter" + '\f' -> "^L" + '\\' -> "'\\'" + _ -> case charToKey c of + Curses.KeyUp -> "Up" + Curses.KeyDown -> "Down" + Curses.KeyPPage -> "PgUp" + Curses.KeyNPage -> "PgDn" + Curses.KeyLeft -> "Left" + Curses.KeyRight -> "Right" + Curses.KeyEnd -> "End" + Curses.KeyHome -> "Home" + Curses.KeyBackspace -> "Backspace" + _ -> show c + +------------------------------------------------------------------------ + +-- | The time used and time left +instance Element PTimes where + draw _ _ _ Nothing = PTimes $ Fast (spaces 5) defaultSty + draw (_,x) _ _ (Just fr) = PTimes $ FancyS $ + [(spc2, defaultSty) + ,(elapsed, defaultSty) + ,(gap, defaultSty) + ,(remaining,defaultSty)] + where + elapsed = printfPS fmt1 lm lm' + remaining = printfPS fmt2 rm rm' + fmt1 = P.pack "%01d:%02d" + fmt2 = P.pack "-%01d:%02d" + (lm,lm') = quotRem (fst . currentTime $ fr) 60 + (rm,rm') = quotRem (fst . timeLeft $ fr) 60 + gap = spaces distance + distance = x - 4 - P.length elapsed - P.length remaining + +------------------------------------------------------------------------ + +-- | A progress bar +instance Element ProgressBar where + draw (_,w) _ st Nothing = ProgressBar . FancyS $ + [(spc2,defaultSty) ,(spaces (w-4), bgs)] + where + (Style _ bg) = progress (config st) + bgs = Style bg bg + + draw (_,w) _ st (Just fr) = ProgressBar . FancyS $ + [(spc2,defaultSty) + ,((spaces distance),fgs) + ,((spaces (width - distance)),bgs)] + where + width = w - 4 + total = curr + left + distance = round ((curr / total) * fromIntegral width) + curr = toFloat (currentTime fr) + left = toFloat (timeLeft fr) + (Style fg bg) = progress (config st) + bgs = Style bg bg + fgs = Style fg fg + + toFloat (x,y) | x `seq` y `seq` False = undefined + toFloat (x,y) = (fromIntegral x :: Float) + (fromIntegral y / 100) + +------------------------------------------------------------------------ + +-- | Version info +instance Element PVersion where + draw _ _ _ _ = PVersion $ P.pack versinfo + +-- | Uptime +instance Element PTime where + draw _ _ st _ = PTime . uptime $ st + +-- | Play mode +instance Element PMode where + draw _ _ st _ = PMode $! case status st of + Stopped -> a + Paused -> b + Playing -> c + + where a = P.pack "stop" + b = P.pack "pause" + c = P.pack "play" + +-- | Loop, normal or random +instance Element PMode2 where + draw _ _ st _ = PMode2 $ case mode st of + Random -> a + Loop -> b + Normal -> c + + where a = P.pack "random" + b = P.pack "loop" + c = P.empty + +------------------------------------------------------------------------ + +instance Element PlayModes where + draw a b c d = PlayModes $ + m `P.append` if m' == P.empty then P.empty else ' ' `P.cons` m' + where + (PMode m ) = draw a b c d :: PMode + (PMode2 m') = draw a b c d :: PMode2 + +instance Element PlayInfo where + draw _ _ st _ = PlayInfo $ P.concat + [percent + ,P.pack " (" + ,P.pack (show (1 + ( snd . bounds . folders $ st))) + ,P.pack " dir" + ,if (snd . bounds $ folders st) == 1 then P.empty else plural + ,P.pack ", " + ,P.pack (show . size $ st) + ,P.pack " file" + ,if size st == 1 then P.empty else plural + ,P.pack ")"] + where + plural = P.pack "s" -- expose to inlining + pct = P.pack "%" + curr = cursor st + + percent | percent' == 0 && curr == 0 = P.pack "top" + | percent' == 100 = P.pack "all" + | otherwise = if P.length s == 2 then ' ' `P.cons` s else s + where + s = P.pack (show percent') `P.append` pct + + percent' :: Int + percent' = round $ ((fromIntegral curr) / + ((fromIntegral . size $ st) - 1) * 100.0 :: Float) + +instance Element PlayTitle where + draw a@(_,x) b c d = + PlayTitle $ flip Fast hl $ P.concat + [space + ,inf + ,spaces gapl + ,modes + ,spaces gapr + ,time + ,space + ,ver + ,space] + where + (PlayInfo inf) = draw a b c d :: PlayInfo + (PTime time) = draw a b c d :: PTime + (PlayModes modes) = draw a b c d :: PlayModes + (PVersion ver) = draw a b c d :: PVersion + + gap = x - padding - P.length inf - modlen - P.length time - P.length ver + gapl = gap `div` 2 + gapr = gap - gapl + padding = 3 + modlen = P.length modes + space = spaces 1 + hl = titlebar . config $ c + +-- | Playlist +instance Element PlayList where + draw p@(y,x) q@(o,_) st z = + PlayList $! title + : list + ++ (replicate (height - length list - 2) (Fast P.empty defaultSty)) + ++ [minibuffer st] + where + (PlayTitle title) = draw p q st z :: PlayTitle + + songs = music st + this = current st + curr = cursor st + height = y - o + + -- number of screens down, and then offset + buflen = height - 2 + (screens,select) = quotRem curr buflen -- keep cursor in screen + + playing = let top = screens * buflen + bot = (screens + 1) * buflen + in if this >= top && this < bot + then this - top -- playing song is visible + else (-1) + + -- visible slice of the playlist + visible = slice off (off + buflen) songs + where off = screens * buflen + + -- todo: put dir on its own line + visible' :: [(Maybe Int, P.ByteString)] + visible' = loop (-1) visible + where loop _ [] = [] + loop n (v:vs) = + let r = if fdir v > n then Just (fdir v) else Nothing + in (r,fbase v) : loop (fdir v) vs + + -- problem: we color *after* merging with directories + -- list = [ uncurry color n + -- | n <- zip (map drawIt visible') [0..] ] + + list = [ drawIt . color . mchop $ n | n <- zip visible' [0..] ] + + indent = (round $ (0.35 :: Float) * fromIntegral x) :: Int + + color :: ((Maybe Int,P.ByteString),Int) -> (Maybe Int, StringA) + color ((m,s),i) + | i == select && i == playing = f sty3 + | i == select = f sty2 + | i == playing = f sty1 + | otherwise = (m,Fast s defaultSty) + where + f sty = (m, Fast (s `P.append` + (spaces (x-indent-1-P.length s))) + sty) + + sty1 = selected . config $ st + sty2 = cursors . config $ st + sty3 = combined . config $ st + + -- must mchop before drawing. + drawIt :: (Maybe Int, StringA) -> StringA + drawIt (Nothing,Fast v sty) = + Fast ((spaces (1 + indent)) `P.append` v) sty + + drawIt (Just i,Fast b sty) = FancyS [pref, post] + where + pref = (d', if sty == sty2 || sty == sty3 then sty2 else sty1) + post = (b, sty) + + d = basenameP $ case size st of + 0 -> P.pack "(empty)" + _ -> dname $ folders st ! i + + spc = spaces (indent - P.length d) + + d' | P.length d > indent-1 + = P.concat [ P.take (indent+1-4) d + , (P.init ellipsis) + , spaces 1 ] + + | otherwise = P.concat [ d, spaces 1, spc ] + + drawIt _ = error "UI.drawIt: color gaves us a non-Fast StringA!" + + mchop :: ((Maybe Int,P.ByteString),Int) -> ((Maybe Int,P.ByteString),Int) + mchop a@((i,s),j) + | P.length s > (x-indent-4-1) + = ((i, P.take (x-indent-4-1) s `P.append` ellipsis),j) + | otherwise = a + +-- +-- | Decode the list of current tracks +-- +printPlayList :: PlayList -> [StringA] +printPlayList (PlayList s) = s +{-# INLINE printPlayList #-} + +------------------------------------------------------------------------ + +-- | Take two strings, and pad them in the middle +alignLR :: Int -> P.ByteString -> P.ByteString -> P.ByteString +alignLR w l r + | padding > 0 = P.concat [l, gap, r] + | otherwise = P.concat [ P.take (w - P.length r - 4 - 1) l, ellipsis, spaces 1, r] + + where padding = w - P.length l - P.length r + gap = spaces padding + +-- | Calculate whitespaces, very common, so precompute likely values +spaces :: Int -> P.ByteString +spaces n + | n > 100 = P.replicate n ' ' -- unlikely + | otherwise = arr ! n + where + arr :: Array Int P.ByteString -- precompute some whitespace strs + arr = listArray (0,100) [ P.take i s100 | i <- [0..100] ] + + s100 :: P.ByteString + s100 = P.replicate 100 ' ' -- seems reasonable + +ellipsis :: P.ByteString +ellipsis = P.pack "... " +{-# INLINE ellipsis #-} + +------------------------------------------------------------------------ +-- +-- | Now write out just the clock line +-- Speed things up a bit, just use read State. +-- +redrawJustClock :: IO () +redrawJustClock = do + Control.Exception.handle (\ (_ :: SomeException) -> return ()) $ do + + st <- getsST id + let fr = clock st + s@(_,w) <- screenSize + let (ProgressBar bar) = draw s undefined st fr :: ProgressBar + (PTimes times) = {-# SCC "redrawJustClock.times" #-} draw s undefined st fr :: PTimes + Curses.wMove Curses.stdScr 1 0 -- hardcoded! + drawLine w bar + Curses.wMove Curses.stdScr 2 0 -- hardcoded! + drawLine w times + drawHelp st fr s + +------------------------------------------------------------------------ +-- +-- work for drawing help. draw the help screen if it is up +-- +drawHelp :: HState -> Maybe Frame -> (Int,Int) -> IO () +drawHelp st fr s@(h,w) = + when (helpVisible st) $ do + let (HelpScreen help') = draw s (0,0) st fr :: HelpScreen + (Fast fps _) = head help' + offset = (w - (P.length fps)) `div` 2 + height = (h - length help') `div` 2 + when (height > 0) $ do + Curses.wMove Curses.stdScr ((h - length help') `div` 2) offset + mapM_ (\t -> do drawLine w t + (y',_) <- Curses.getYX Curses.stdScr + Curses.wMove Curses.stdScr (y'+1) offset) help' + +------------------------------------------------------------------------ +-- +-- | Draw the screen +-- +redraw :: IO () +redraw = + -- linux ncurses, in particular, seems to complain a lot. this is an easy solution + Control.Exception.handle (\ (_ :: SomeException) -> return ()) $ do + + s <- getsST id -- another refresh could be triggered? + let f = clock s + sz@(h,w) <- screenSize + + let x = printPlayScreen (draw sz (0,0) s f :: PlayScreen) + y = printPlayList (draw sz (length x,0) s f :: PlayList) + a = x ++ y + + when (xterm s) $ setXterm s sz f + + gotoTop + mapM_ (\t -> do drawLine w t + (y',x') <- Curses.getYX Curses.stdScr + fillLine + maybeLineDown t h y' x' ) + (take (h-1) (init a)) + drawHelp s f sz + + -- minibuffer + Curses.wMove Curses.stdScr (h-1) 0 + fillLine + Curses.wMove Curses.stdScr (h-1) 0 + drawLine (w-1) (last a) + when (miniFocused s) $ do -- a fake cursor + drawLine 1 (Fast (spaces 1) (blockcursor . config $ s )) + -- todo rendering bug here when deleting backwards in minibuffer + +------------------------------------------------------------------------ +-- +-- | Draw a coloured (or not) string to the screen +-- +drawLine :: Int -> StringA -> IO () +drawLine _ (Fast ps sty) = drawPackedString ps sty +drawLine _ (FancyS ls) = loop ls + where loop [] = return () + loop ((l,sty):xs) = drawPackedString l sty >> loop xs + +-- worker +drawPackedString :: P.ByteString -> Style -> IO () +drawPackedString ps sty = + withStyle sty $ B.useAsCString (P.map asAscii ps) $ \cstr -> + Curses.throwIfErr_ msg $ + waddnstr Curses.stdScr + -- Curses.wAddStr Curses.stdScr + -- UTF8.toString ps + cstr (fromIntegral . P.length $ ps) + where + msg = "drawPackedString" + asAscii x | x >= ' ' && x < '\127' = x + | otherwise = '*' + + +------------------------------------------------------------------------ + +maybeLineDown :: StringA -> Int -> Int -> Int -> IO () +maybeLineDown (Fast s _) h y _ | s == P.empty = lineDown h y +maybeLineDown _ h y x + | x == 0 = return () -- already moved down + | otherwise = lineDown h y + +------------------------------------------------------------------------ + +lineDown :: Int -> Int -> IO () +lineDown h y = Curses.wMove Curses.stdScr (min h (y+1)) 0 + +-- +-- | Fill to end of line spaces +-- +fillLine :: IO () +fillLine = Control.Exception.catch (Curses.clrToEol) (\ (_ :: SomeException) -> return ()) -- harmless? + +-- +-- | move cursor to origin of stdScr. +-- +gotoTop :: IO () +gotoTop = Curses.wMove Curses.stdScr 0 0 +{-# INLINE gotoTop #-} + +-- | Take a slice of an array efficiently +slice :: Int -> Int -> Array Int e -> [e] +slice i j arr = + let (a,b) = bounds arr + in [unsafeAt arr n | n <- [max a i .. min b j] ] +{-# INLINE slice #-} + +------------------------------------------------------------------------ + +-- +-- | magics for setting xterm titles using ansi escape sequences +-- +setXtermTitle :: [P.ByteString] -> IO () +setXtermTitle strs = do + mapM_ (P.hPut stderr) (before : strs ++ [after]) + hFlush stderr + where + before = P.pack "\ESC]0;" + after = P.pack "\007" + +------------------------------------------------------------------------ + +-- set xterm title (should have an instance Element) +-- Don't need to do this on each refresh... +setXterm :: HState -> (Int,Int) -> Maybe Frame -> IO () +setXterm s sz f = setXtermTitle $ + if status s == Playing + then case id3 s of + Nothing -> case size s of + 0 -> [P.pack "hmp3"] + _ -> [(fbase $ music s ! current s)] + Just ti -> id3artist ti : + if P.null (id3title ti) + then [] + else [P.pack ": ", id3title ti] + else let (PMode pm) = draw sz (0,0) s f :: PMode in [pm] + +-- Not exported by hscurses. +foreign import ccall safe + waddnstr :: Curses.Window -> CString -> CInt -> IO CInt + diff --git a/Utils.hs b/Utils.hs new file mode 100644 --- /dev/null +++ b/Utils.hs @@ -0,0 +1,168 @@ +-- +-- Copyright (c) 2003-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- Copyright (c) 2019 Galen Huntington +-- +-- 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. +-- + +-- miscellaneous utilites, including: +-- +-- The POpen module provides functionality to ``open'' a process by +-- creating two pipes, forking, and executing a file. *Two pipes* are +-- created for *bidirectional* communication with the subprocess, unlike +-- the popen in the library. This is really popen2. +-- +-- The return value of the popen command is a tuple of Handle for +-- reading and writing to the subprocess +-- +-- The inspiration for this code is J Petersen's hslibs/posix/POpen.hs +-- + +module Utils where + +import FastIO (printfPS) +import qualified Data.ByteString.Char8 as P (pack) +import qualified Data.ByteString as P (ByteString) + +import Data.Char (toLower) +import System.Time (diffClockTimes, TimeDiff(tdSec), ClockTime) +import System.Environment (getEnv) +import System.Posix.Types (Fd(..),ProcessID) +import System.Process.Internals (mkProcessHandle,ProcessHandle) +import System.Posix.Process (forkProcess,executeFile) +import System.Posix.IO (createPipe,stdInput,stdError + ,stdOutput,closeFd,dupTo) + +import Control.Exception (handle, SomeException) + +import System.IO.Unsafe (unsafePerformIO) + +------------------------------------------------------------------------ + +-- +-- | join two path components +-- +infixr 6 +infixr 6 <+> + +(), (<+>) :: FilePath -> FilePath -> FilePath +[] b = b +a b = a ++ "/" ++ b + +[] <+> b = b +a <+> b = a ++ " " ++ b + +------------------------------------------------------------------------ + +drawUptime :: ClockTime -> ClockTime -> P.ByteString +drawUptime before now = + let r = diffClockTimes now before + s = tdSec r + (h,sr) = quotRem s (60 * 60) + m = quot sr 60 + in printfPS fmt h m + where + fmt = P.pack "%3dh%02dm" -- sometimes ghc doesn't want to fire a RULE here, why? + -- its crucial for snprintf that this is unpacked + +------------------------------------------------------------------------ +-- | Repeat an action +-- Also known as `forever' in the Awkward squad paper +repeatM_ :: Monad m => m a -> m () +repeatM_ a = a >> repeatM_ a +{-# SPECIALIZE repeatM_ :: IO a -> IO () #-} +{-# INLINE repeatM_ #-} + +------------------------------------------------------------------------ + +-- | Convert a (newtyped) Posix Fd to an Int we can use in other places +fdToInt :: Fd -> Int +fdToInt (Fd cint) = fromIntegral cint + +-- | Wrap a CPid as a System.Process.ProcessHandle +pid2phdl :: ProcessID -> ProcessHandle +pid2phdl pid = unsafePerformIO $ mkProcessHandle pid False +{-# NOINLINE pid2phdl #-} + +------------------------------------------------------------------------ +-- +-- provide similar functionality to popen(3), +-- along with bidirectional ipc via pipes +-- return's the pid of the child process +-- +-- there are two different forkProcess functions. the pre-620 was a +-- unix-fork style function, and the modern function has semantics more +-- like the Awkward-Squad paper. We provide implementations of popen +-- using both versions, depending on which GHC the user wants to try. +-- +-- And now a third, we return stderr. +-- +popen :: FilePath -> [String] -> IO (Fd, Fd, Fd, ProcessID) +popen cmd args = do + (pr, pw) <- createPipe + (cr, cw) <- createPipe + (cre, cwe) <- createPipe + + -- parent -- + let parent = do closeFd cw + closeFd cwe + closeFd pr + -- child -- + let child = do closeFd pw + closeFd cr + closeFd cre + exec cmd args (pr,cw,cwe) + error "exec cmd failed!" -- typing only + + pid <- forkProcess child -- fork child + parent -- and run parent code + + -- hcr <- fdToHandle cr + -- hpw <- fdToHandle pw + + return (cr,pw,cre,pid) + +-- +-- execve cmd in the child process, dup'ing the file descriptors passed +-- as arguments to become the child's stdin and stdout. +-- +exec :: FilePath -> [String] -> (Fd,Fd,Fd) -> IO () +exec cmd args (pr,cw,ce) = do + dupTo pr stdInput + dupTo cw stdOutput -- dup stderr too! + dupTo ce stdError -- dup stderr too! + executeFile cmd False args Nothing + +------------------------------------------------------------------------ + +-- +-- | Some evil to work out if the background is light, or dark. Assume dark. +-- +isLightBg :: IO Bool +isLightBg = Control.Exception.handle (\ (_ :: SomeException) -> return False) $ do + e <- getEnv "HMP_HAS_LIGHT_BG" + return $ map toLower e == "true" + +------------------------------------------------------------------------ + +-- | 'readM' behaves like read, but catches failure in a monad. +readM :: (Monad m, Read a) => String -> m a +readM s = case [x | (x,t) <- {-# SCC "Serial.readM.reads" #-} reads s -- bad! + , ("","") <- lex t] of + [x] -> return x + [] -> fail "Serial.readM: no parse" + _ -> fail "Serial.readM: ambiguous parse" + diff --git a/hmp3-ng.cabal b/hmp3-ng.cabal new file mode 100644 --- /dev/null +++ b/hmp3-ng.cabal @@ -0,0 +1,48 @@ +cabal-version: >= 1.6 + +name: hmp3-ng +version: 2.4.2 +homepage: https://github.com/galenhuntington/hmp3-ng +license: GPL +license-file: LICENSE +author: Don Stewart, Galen Huntington +maintainer: Galen Huntington +category: Sound +synopsis: A 2019 fork of an ncurses mp3 player written in Haskell +description: + An mp3 player with a curses frontend. Playlists are populated by + passing directory names on the commandline, and saved to the + ~/.hmp3db database. Type 'h' to display the help page. Colours may + be configured at runtime by editing the "~/.hmp3" file. +build-type: Simple +extra-source-files: Keymap.hs-boot README.md + +source-repository head + type: git + location: https://github.com/galenhuntington/hmp3-ng + +executable hmp3 + build-depends: unix >= 2.7, + zlib >= 0.4, + binary >= 0.4, + pcre-light >= 0.3, + mersenne-random >= 1.0.0.1, + base >= 4 && < 5, + bytestring >= 0.10, + containers, + array, + old-time, + directory, + process, + utf8-string, + hscurses, + mtl + + ghc-options: -Wall -funbox-strict-fields -threaded -Wno-unused-do-bind + main-is: Main.hs + other-modules: Config Core FastIO Keymap + Lexer Lexers State Style Syntax Tree UI Utils + Paths_hmp3_ng + + extensions: CPP, ForeignFunctionInterface, ScopedTypeVariables + extra-libraries: curses