hmp3-ng (empty) → 2.4.2
raw patch · 18 files changed
+4260/−0 lines, 18 filesdep +arraydep +basedep +binarysetup-changed
Dependencies added: array, base, binary, bytestring, containers, directory, hscurses, mersenne-random, mtl, old-time, pcre-light, process, unix, utf8-string, zlib
Files
- Config.hs +82/−0
- Core.hs +633/−0
- FastIO.hs +184/−0
- Keymap.hs +227/−0
- Keymap.hs-boot +11/−0
- LICENSE +340/−0
- Lexer.hs +167/−0
- Lexers.hs +552/−0
- Main.hs +107/−0
- README.md +88/−0
- Setup.hs +3/−0
- State.hs +171/−0
- Style.hs +350/−0
- Syntax.hs +158/−0
- Tree.hs +241/−0
- UI.hs +730/−0
- Utils.hs +168/−0
- hmp3-ng.cabal +48/−0
+ Config.hs view
@@ -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"
+ Core.hs view
@@ -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)
+ FastIO.hs view
@@ -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
+ Keymap.hs view
@@ -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 ]
+ Keymap.hs-boot view
@@ -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
+ LICENSE view
@@ -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.++ <one line to give the program's name and a brief idea of what it does.>+ Copyright (C) <year> <name of author>++ 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.++ <signature of Ty Coon>, 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.
+ Lexer.hs view
@@ -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+
+ Lexers.hs view
@@ -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 <simonpj@microsoft.com> and Roman+-- Lechtchinsky <wolfro@cs.tu-berlin.de> 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+-- <d95mback@dtek.chalmers.se>.+--+--- 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 <Tom.Pledger@peace.com> (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 = ($[])
+ Main.hs view
@@ -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+
+ README.md view
@@ -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+```+
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ State.hs view
@@ -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+
+ Style.hs view
@@ -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
+ Syntax.hs view
@@ -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 <file>+--+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> frames forward, or backwards,+-- respectively, in the the mp3 file. If neither is specifies, jumps to+-- absolute frame <frames> 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.+-- <a>: 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.+-- <b>: layer: 1, 2, or 3. Integer.+-- <c>: Samplerate. Integer.+-- <d>: Mode string. String.+-- <e>: Mode extension. Integer.+-- <f>: Bytes per frame (estimate, particularly if the stream is VBR). Integer.+-- <g>: Number of channels (1 or 2, usually). Integer.+-- <h>: Is stream copyrighted? (1 or 0). Integer.+-- <i>: Is stream CRC protected? (1 or 0). Integer.+-- <j>: Emphasis. Integer.+-- <k>: Bitrate, in kbps. (i.e., 128.) Integer.+-- <l>: 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 <current-frame> <frames-remaining> <current-time> <time-remaining>+-- 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
+ Tree.hs view
@@ -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))
+ UI.hs view
@@ -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+
+ Utils.hs view
@@ -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"+
+ hmp3-ng.cabal view
@@ -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