diff --git a/Config.hs b/Config.hs --- a/Config.hs +++ b/Config.hs @@ -1,5 +1,5 @@ -- --- Copyright (c) 2005 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- Copyright (c) 2005-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons -- -- This program is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as @@ -29,13 +29,13 @@ , cursors = Style black cyan , combined = Style brightwhite cyan , warnings = Style red defaultbg - , helpscreen = Style black white + , 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 = +lightBgStyle = defaultStyle { selected = Style darkblue defaultbg , warnings = Style darkred defaultbg } @@ -53,7 +53,7 @@ , blockcursor= Style black darkred , progress = Style cyan white } -bwStyle :: UIStyle +bwStyle :: UIStyle bwStyle = UIStyle { window = Style defaultfg defaultbg ,titlebar = Style reversefg reversebg @@ -65,7 +65,7 @@ ,blockcursor = Style reversefg reversebg ,progress = Style reversefg reversebg } - + ------------------------------------------------------------------------ package :: String @@ -73,9 +73,9 @@ versinfo :: String versinfo = package++" "++ version - where + where version :: String - version = "1.1" ++ if (not . null) (PATCH_COUNT :: String) && (PATCH_COUNT /= "1") + version = "1.4" ++ if (not . null) (PATCH_COUNT :: String) && (PATCH_COUNT /= "1") then "p" ++ PATCH_COUNT else "" @@ -83,4 +83,4 @@ help = "- curses-based MP3 player" darcsinfo :: String -darcsinfo = "darcs get --partial http://www.cse.unsw.edu.au/~dons/code/hmp3" +darcsinfo = "darcs get http://code.haskell.org/~dons/code/hmp3" diff --git a/Core.hs b/Core.hs --- a/Core.hs +++ b/Core.hs @@ -1,5 +1,5 @@ -- --- Copyright (c) 2005 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- Copyright (c) 2005-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons -- -- This program is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as @@ -41,13 +41,12 @@ import FastIO (send,fdToCFile,forceNextPacket) import Tree hiding (File,Dir) import qualified Tree (File,Dir) -import Regex import qualified UI +import Text.Regex.PCRE.Light import {-# SOURCE #-} Keymap (keymap) -import qualified Data.ByteString.Char8 as P (pack,empty,ByteString,join,singleton) -import Data.ByteString (useAsCString) +import qualified Data.ByteString.Char8 as P (ByteString,pack,empty,intercalate,singleton) import Data.Array ((!), bounds, Array) import Data.Maybe (isJust,fromJust) @@ -82,7 +81,7 @@ (ds,fs,i,m) -- construct the state <- case ms of - Right roots -> do (a,b) <- buildTree roots + Right roots -> do (a,b) <- buildTree roots return (a,b,0,Normal) Left st -> return (ser_darr st @@ -99,7 +98,7 @@ t4 <- forkIO uptimeLoop t5 <- forkIO errorLoop - silentlyModifyST $ \s -> s + silentlyModifyST $ \s -> s { music = fs , folders = ds , size = 1 + (snd . bounds $ fs) @@ -107,7 +106,7 @@ , current = i , mode = m , uptime = drawUptime now now - , boottime = now + , boottime = now , config = c , threads = [t0,t1,t2,t3,t4,t5] } @@ -150,7 +149,7 @@ mmpg <- findExecutable (MPG321 :: String) case mmpg of Nothing -> quit (Just $ "Cannot find " ++ MPG321 ++ " in path") - Just mpg321 -> do + Just mpg321 -> do -- if we're never able to start mpg321, do something sensible mv <- catch (popen (mpg321 :: String) ["-R","-"] >>= return . Just) @@ -160,8 +159,8 @@ Nothing -> threadDelay (1000 * 500) >> mpgLoop Just (r,w,e,pid) -> do - hw <- fdToHandle (fdToInt w) -- so we can use Haskell IO - ew <- fdToHandle (fdToInt e) -- so we can use Haskell IO + hw <- fdToHandle (fromIntegral w) -- so we can use Haskell IO + ew <- fdToHandle (fromIntegral e) -- so we can use Haskell IO filep <- fdToCFile r -- so we can use C IO mhw <- newMVar hw mew <- newMVar ew @@ -171,11 +170,11 @@ st { mp3pid = Just pid , writeh = mhw , errh = mew - , readf = mfilep + , readf = mfilep , status = Stopped , info = Nothing , id3 = Nothing } - + catch (waitForProcess (pid2phdl pid)) (\_ -> return ExitSuccess) stop <- getsST doNotResuscitate when (stop) $ exitWith ExitSuccess @@ -193,8 +192,8 @@ -- | Once a minute read the clock time uptimeLoop :: IO () uptimeLoop = forever $ do - threadDelay delay - now <- getClockTime + threadDelay delay + now <- getClockTime modifyST $ \st -> st { uptime = drawUptime (boottime st) now } where delay = 60 * 1000 * 1000 -- 1 minute @@ -247,7 +246,7 @@ -- | Close most things. Important to do all the jobs: shutdown :: Maybe String -> IO () -shutdown ms = +shutdown ms = (do silentlyModifyST $ \st -> st { doNotResuscitate = True } catch writeSt (\_ -> return ()) withST $ \st -> do @@ -259,12 +258,14 @@ waitForProcess $ pid2phdl pid return ()) - `finally` + `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 + exitImmediately ExitSuccess) + -- race. a thread might touch the screen + -- gets in the way of profiling -- return ()) ------------------------------------------------------------------------ @@ -307,7 +308,7 @@ seek :: (Frame -> Int) -> IO () seek fn = do f <- getsST clock - case f of + case f of Nothing -> return () Just g -> do withST $ \st -> do @@ -384,7 +385,8 @@ let m = music st i = current st fe = m ! (fn i) - f = P.join (P.singleton '/') [(dname $ folders st ! fdir fe),(fbase fe)] + f = P.intercalate (P.singleton '/') + [(dname $ folders st ! fdir fe),(fbase fe)] j = cursor st st' = st { current = fn i , status = Playing @@ -452,12 +454,14 @@ genericJumpToMatch re k sel = do found <- modifySTM_ $ \st -> do - mre <- case re of -- work out if we have no pattern, a cached pattern, or a new pattern - Nothing -> case regex st of - Nothing -> return Nothing - Just (r,d) -> return $ Just (r,d) - Just (s,d) -> do v <- regcomp s (regExtended + regIgnoreCase + regNewline) - return $ Just (v,d) + 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) + Just (s,d) -> case compileM (P.pack s) [caseless] of + Nothing -> Nothing + Just v -> Just (v,d) case mre of Nothing -> return (st,False) -- no pattern Just (p,forwards) -> do @@ -466,9 +470,9 @@ loop fn inc n | fn n = return Nothing - | otherwise = useAsCString (extract (fs ! n)) $ \s -> do - v <- regexec p s 0 - case v of + | otherwise = do + let s = extract (fs ! n) + case match p s [] of Nothing -> loop fn inc $! inc n Just _ -> return $ Just n @@ -529,21 +533,21 @@ -- | Find a user's home in a canonical sort of way getHome :: IO String -getHome = Control.Exception.catch +getHome = Control.Exception.catch (getRealUserID >>= getUserEntryForID >>= (return . homeDirectory)) (\_ -> getEnv "HOME") ------------------------------------------------------------------------ -- Read styles from ~/.hmp3 -- -loadConfig :: IO () +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) + msty <- catch (readM str >>= return . Just) (const $ warnA "Parse error in ~/.hmp3" >> return Nothing) case msty of Nothing -> return () @@ -565,6 +569,6 @@ -- warnA :: String -> IO () -warnA x = do +warnA x = do sty <- getsST config putmsg $ Fast (P.pack x) (warnings sty) diff --git a/Curses.hsc b/Curses.hsc --- a/Curses.hsc +++ b/Curses.hsc @@ -1,6 +1,6 @@ -- -- Copyright (c) 2002-2004 John Meacham (john at repetae dot net) --- Copyright (c) 2004-2005 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- Copyright (c) 2004-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons -- -- Permission is hereby granted, free of charge, to any person obtaining a -- copy of this software and associated documentation files (the @@ -86,7 +86,7 @@ -- * error handling throwIfErr_, -- :: Num a => String -> IO a -> IO () - + ) where #if HAVE_SIGNAL_H @@ -213,7 +213,7 @@ -- > to stdscr. -- initScr :: IO Window -initScr = throwPackedIfNull (P.packAddress "initscr"##) c_initscr +initScr = throwPackedIfNull (P.pack "initscr") c_initscr foreign import ccall unsafe "initscr" c_initscr :: IO Window @@ -227,8 +227,8 @@ -- > the terminal to normal (cooked) mode. -- cBreak :: Bool -> IO () -cBreak True = throwIfErr_ (P.packAddress "cbreak"##) cbreak -cBreak False = throwIfErr_ (P.packAddress "nocbreak"##) nocbreak +cBreak True = throwIfErr_ (P.pack "cbreak") cbreak +cBreak False = throwIfErr_ (P.pack "nocbreak") nocbreak foreign import ccall unsafe "cbreak" cbreak :: IO CInt foreign import ccall unsafe "nocbreak" nocbreak :: IO CInt @@ -245,8 +245,8 @@ -- > routines interact with cbreak and nocbreak.] -- echo :: Bool -> IO () -echo False = throwIfErr_ (P.packAddress "noecho"##) noecho -echo True = throwIfErr_ (P.packAddress "echo"##) echo_c +echo False = throwIfErr_ (P.pack "noecho") noecho +echo True = throwIfErr_ (P.pack "echo") echo_c foreign import ccall unsafe "noecho" noecho :: IO CInt foreign import ccall unsafe "echo" echo_c :: IO CInt @@ -264,8 +264,8 @@ -- > the return key. -- > nl :: Bool -> IO () -nl True = throwIfErr_ (P.packAddress "nl"##) nl_c -nl False = throwIfErr_ (P.packAddress "nonl"##) nonl +nl True = throwIfErr_ (P.pack "nl") nl_c +nl False = throwIfErr_ (P.pack "nonl") nonl foreign import ccall unsafe "nl" nl_c :: IO CInt foreign import ccall unsafe "nonl" nonl :: IO CInt @@ -274,7 +274,7 @@ -- | Enable the keypad of the user's terminal. -- keypad :: Window -> Bool -> IO () -keypad win bf = throwIfErr_ (P.packAddress "keypad"##) $ +keypad win bf = throwIfErr_ (P.pack "keypad") $ keypad_c win (if bf then 1 else 0) foreign import ccall unsafe "keypad" @@ -285,7 +285,7 @@ -- > is FALSE), getch waits until a key is pressed. -- noDelay :: Window -> Bool -> IO () -noDelay win bf = throwIfErr_ (P.packAddress "nodelay"##) $ +noDelay win bf = throwIfErr_ (P.pack "nodelay") $ nodelay win (if bf then 1 else 0) foreign import ccall unsafe nodelay @@ -330,7 +330,7 @@ -- > exiting from curses. -- endWin :: IO () -endWin = throwIfErr_ (P.packAddress "endwin"##) endwin +endWin = throwIfErr_ (P.pack "endwin") endwin foreign import ccall unsafe "endwin" endwin :: IO CInt @@ -353,7 +353,7 @@ -- | refresh curses windows and lines. curs_refresh(3) -- refresh :: IO () -refresh = throwIfErr_ (P.packAddress "refresh"##) refresh_c +refresh = throwIfErr_ (P.pack "refresh") refresh_c foreign import ccall unsafe "refresh" refresh_c :: IO CInt @@ -371,7 +371,7 @@ -- default colors (white on black) -- startColor :: IO () -startColor = throwIfErr_ (P.packAddress "start_color"##) start_color +startColor = throwIfErr_ (P.pack "start_color") start_color foreign import ccall unsafe start_color :: IO CInt @@ -423,7 +423,7 @@ -- initPair :: Pair -> Color -> Color -> IO () initPair (Pair p) (Color f) (Color b) = - throwIfErr_ (P.packAddress "init_pair"##) $ + throwIfErr_ (P.pack "init_pair") $ init_pair (fi p) (fi f) (fi b) foreign import ccall unsafe @@ -437,7 +437,7 @@ attrSet :: Attr -> Pair -> IO () attrSet (Attr attr) (Pair p) = do - throwIfErr_ (P.packAddress "attrset"##) $ c_attrset (attr .|. fi (colorPair p)) + throwIfErr_ (P.pack "attrset") $ c_attrset (attr .|. fi (colorPair p)) ------------------------------------------------------------------------ @@ -491,7 +491,7 @@ waddnstr :: Window -> CString -> CInt -> IO CInt clrToEol :: IO () -clrToEol = throwIfErr_ (P.packAddress "clrtoeol"##) c_clrtoeol +clrToEol = throwIfErr_ (P.pack "clrtoeol") c_clrtoeol foreign import ccall unsafe "clrtoeol" c_clrtoeol :: IO CInt @@ -503,7 +503,7 @@ -- > corner of the window, which is (0,0). -- wMove :: Window -> Int -> Int -> IO () -wMove w y x = throwIfErr_ (P.packAddress "wmove"##) $ wmove w (fi y) (fi x) +wMove w y x = throwIfErr_ (P.pack "wmove") $ wmove w (fi y) (fi x) foreign import ccall unsafe wmove :: Window -> CInt -> CInt -> IO CInt @@ -602,7 +602,7 @@ -- try to set the upper bits meta :: Window -> Bool -> IO () -meta win bf = throwIfErr_ (P.packAddress "meta"##) $ +meta win bf = throwIfErr_ (P.pack "meta") $ c_meta win (if bf then 1 else 0) foreign import ccall unsafe "meta" diff --git a/FastIO.hs b/FastIO.hs --- a/FastIO.hs +++ b/FastIO.hs @@ -1,5 +1,5 @@ -- --- Copyright (c) 2005-6 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- Copyright (c) 2005-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons -- -- This program is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as @@ -25,7 +25,8 @@ import qualified Data.ByteString.Char8 as P import qualified Data.ByteString as B -import qualified Data.ByteString.Base as B +import qualified Data.ByteString.Internal as B +--import qualified Data.ByteString.Unsafe as B import Data.Word (Word8) import Foreign.C.Error @@ -85,7 +86,7 @@ if (dEnt == nullPtr) then return [] else do -- copy entry out before we free: - entry <- B.copyCString =<< d_name dEnt + entry <- B.packCString =<< d_name dEnt P.length entry `seq` return () -- strictify freeDirEnt dEnt entries <- loop ptr_dEnt dir @@ -102,7 +103,7 @@ -- packed version: doesFileExist :: P.ByteString -> IO Bool doesFileExist name = Control.Exception.catch - (packedWithFileStatus "Utils.doesFileExist" name $ \st -> do + (packedWithFileStatus "Utils.doesFileExist" name $ \st -> do b <- isDirectory st; return (not b)) (\ _ -> return False) @@ -141,9 +142,9 @@ -- Returning a ByteString. Note that the underlying C code is dropping -- redundant \@F frames for us. getFilteredPacket :: Ptr CFile -> IO P.ByteString -getFilteredPacket fp = B.createAndTrim size $ \p -> do +getFilteredPacket fp = B.createAndTrim size $ \p -> do i <- c_getline p fp - if i == -1 + if i == -1 then throwErrno "FastIO.packedHGetLine" else return i where diff --git a/Keymap.hs b/Keymap.hs --- a/Keymap.hs +++ b/Keymap.hs @@ -1,5 +1,5 @@ -- --- Copyright (c) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- Copyright (c) 2004-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons -- -- This program is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as @@ -44,7 +44,7 @@ import Data.List ((\\)) -import qualified Data.ByteString.Char8 as P (packAddress,ByteString,pack) +import qualified Data.ByteString.Char8 as P (ByteString, pack) import qualified Data.Map as M (fromList, lookup, Map) data Search = SearchFile | SearchDir @@ -141,64 +141,64 @@ keyTable :: [(P.ByteString, [Char], IO ())] keyTable = [ - (p "Move up"#, + (p "Move up", ['k',keyUp], up) - ,(p "Move down"#, + ,(p "Move down", ['j',keyDown], down) - ,(p "Next directory down"#, + ,(p "Next directory down", [keyNPage], jumpToNextDir) - ,(p "Next directory up"#, + ,(p "Next directory up", [keyPPage], jumpToPrevDir) - ,(p "Jump to start of list"#, + ,(p "Jump to start of list", [keyHome,'1'], jump 0) - ,(p "Jump to end of list"#, + ,(p "Jump to end of list", [keyEnd,'G'], jump maxBound) - ,(p "Seek left within song"#, + ,(p "Seek left within song", [keyLeft], seekLeft) - ,(p "Seek right within song"#, + ,(p "Seek right within song", [keyRight], seekRight) - ,(p "Toggle pause"#, + ,(p "Toggle pause", ['p'], pause) - ,(p "Play song under cursor"#, + ,(p "Play song under cursor", ['\n',' '], play) - ,(p "Play previous track"#, + ,(p "Play previous track", ['K'], playPrev) - ,(p "Play next track"#, + ,(p "Play next track", ['J'], playNext) - ,(p "Toggle the help screen"#, + ,(p "Toggle the help screen", ['h'], toggleHelp) - ,(p "Jump to currently playing song"#, + ,(p "Jump to currently playing song", ['t'], jumpToPlaying) - ,(p "Quit (or close help screen)"#, + ,(p "Quit (or close help screen)", ['q'], do b <- helpIsVisible ; if b then toggleHelp else quit Nothing) - ,(p "Select and play next track"#, + ,(p "Select and play next track", ['d'], playNext >> jumpToPlaying) - ,(p "Cycle through normal, random and loop modes"#, + ,(p "Cycle through normal, random and loop modes", ['m'], nextMode) - ,(p "Refresh the display"#, + ,(p "Refresh the display", ['\^L'], UI.resetui) - ,(p "Repeat last regex search"#, + ,(p "Repeat last regex search", ['n'], jumpToMatch Nothing) - ,(p "Repeat last regex search on files"#, + ,(p "Repeat last regex search on files", ['N'], jumpToMatchFile Nothing) - ,(p "Load config file"#, + ,(p "Load config file", ['l'], loadConfig) ] where -- Keep as Addr#. If we try the pack/packAddress rule, ghc seems to get -- confused and want to *unpack* the strings :/ - p = P.packAddress + p = P.pack {-# INLINE p #-} extraTable :: [(P.ByteString, [Char])] -extraTable = [(p "Search for directory matching regex"#, ['/']) - ,(p "Search backwards for directory"#, ['?']) - ,(p "Search for file matching regex"#, ['\\']) - ,(p "Search backwards for file"#, ['|']) ] +extraTable = [(p "Search for directory matching regex", ['/']) + ,(p "Search backwards for directory", ['?']) + ,(p "Search for file matching regex", ['\\']) + ,(p "Search backwards for file", ['|']) ] where -- Keep as Addr#. If we try the pack/packAddress rule, ghc seems to get -- confused and want to *unpack* the strings :/ - p = P.packAddress + p = P.pack {-# INLINE p #-} diff --git a/Lexer.hs b/Lexer.hs --- a/Lexer.hs +++ b/Lexer.hs @@ -1,5 +1,5 @@ -- --- Copyright (c) 2005 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- Copyright (c) 2005-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons -- -- This program is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as @@ -51,8 +51,8 @@ where fs = P.split ' ' . P.tail $ s - f n = case P.split '.' (fs !! n) of { [x,y] -> - case readPS x of { rx -> + 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" } @@ -77,7 +77,7 @@ , bitrate = read $ P.unpack $ fs !! 10 , extension = read $ P.unpack $ fs !! 11 -} - userinfo = P.concat + userinfo = P.concat [P.pack "mpeg " ,fs !! 0 ,P.pack " " @@ -103,14 +103,14 @@ splitUp :: P.ByteString -> [P.ByteString] splitUp f | f == P.empty = [] - | otherwise + | 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 = + toId i ls = let j = case length ls of 0 -> i @@ -148,7 +148,7 @@ -- normalise the packet let (s,m) = let a = P.dropWhile (== ' ') x -- drop any leading whitespace (b,d)= P.break (== ' ') a -- split into header and body - b' = if '@' `P.elem` b + b' = if '@' `P.elem` b then P.dropWhile (/= '@') b -- make sure '@' is first char else b in (P.dropWhile (== '@') b', d) diff --git a/Lexers.hs b/Lexers.hs --- a/Lexers.hs +++ b/Lexers.hs @@ -6,7 +6,7 @@ -- Version $Revision: 1.1 $ from $Date: 2002/07/28 03:35:20 $ -- -- Copyright (c) [1995..2000] Manuel M. T. Chakravarty --- Copyright (c) 2004-5 Don Stewart +-- 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 diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,5 +1,5 @@ -- --- Copyright (c) Don Stewart 2004-5. +-- Copyright (c) Don Stewart 2004-2008. -- Copyright (c) Tuomo Valkonen 2004. -- -- This program is free software; you can redistribute it and/or @@ -78,7 +78,7 @@ -- | Parse the args do_args :: [P.ByteString] -> IO (Either SerialT [P.ByteString]) do_args [] = do -- attempt to read db - x <- readSt + x <- readSt case x of Nothing -> do mapM_ putStrLn usage; exitWith ExitSuccess Just st -> return $ Left st @@ -99,7 +99,7 @@ -- handlers, then jump to ui event loop with the state. -- main :: IO () -main = do +main = do args <- return . map P.pack =<< getArgs files <- do_args args initSignals diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,10 @@ +all: conf build + +conf: + ./Setup.hs configure + +build: + ./Setup.hs build + +clean: + ./Setup.hs clean diff --git a/README b/README --- a/README +++ b/README @@ -3,12 +3,7 @@ --------------------------------------------------- Dependencies: - The Glasgow Haskell Compiler >= 6.4.2 http://haskell.org/ghc - mpg321 http://mpg321.sourceforge.net/ - A version of FPS >= 0.7 http://www.cse.unsw.edu.au/~dons/fps.html - A Cabal newer than 1.0 http://haskell.org/cabal - curses - binary >= 0.2 http://darcs.haskell.org/binary/ + mpg321 http://mpg321.sourceforge.net/ Building: $ chmod +x configure Setup.hs @@ -89,7 +84,7 @@ GPL Author: - Don Stewart, Tue Jun 27 17:11:03 EST 2006 + Don Stewart, Tue Jan 15 15:16:55 PST 2008 Contributors: Samuel Bronson diff --git a/Regex.hsc b/Regex.hsc deleted file mode 100644 --- a/Regex.hsc +++ /dev/null @@ -1,133 +0,0 @@ --- --- --- Module : Text.Regex.Posix --- --- Copyright : (c) The University of Glasgow 2002 --- (c) Don Stewart 2004 --- --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : portable --- - --- --- | Interface to the POSIX regular expression library. --- - -module Regex ( - - -- * The @Regex@ type - Regex, -- abstract - - -- * Compiling a regular expression - regcomp, -- :: String -> Int -> IO Regex - - -- ** Flags for regcomp - regExtended, -- (flag to regcomp) use extended regex syntax - regIgnoreCase, -- (flag to regcomp) ignore case when matching - regNewline, -- (flag to regcomp) '.' doesn't match newline - regNosub, -- unused - - -- * Matching a regular expression - regexec, -- :: Regex -> Ptr CChar -> Int - -- -> IO (Maybe ((Int,Int), [(Int,Int)])) - - ) where - -#include "config.h" - -#if HAVE_SYS_TYPES_H -# include -#endif - -#if HAVE_REGEX_H -# include -#endif - -import Foreign.C -import Foreign - -type CRegex = () - --- | A compiled regular expression -newtype Regex = Regex (ForeignPtr CRegex) - --- --------------------------------------------------------------------- --- | Compiles a regular expression --- -regcomp :: String -- ^ The regular expression to compile - -> Int -- ^ Flags (summed together) - -> IO Regex -- ^ Returns: the compiled regular expression - -regcomp pattern flags = do - regex_fptr <- mallocForeignPtrBytes (#const sizeof(regex_t)) - r <- withCString pattern $ \cstr -> - withForeignPtr regex_fptr $ \p -> - c_regcomp p cstr (fromIntegral flags) - if (r == 0) - then do - addForeignPtrFinalizer ptr_regfree regex_fptr - return (Regex regex_fptr) - else ioError $ userError $ "Error in pattern: " ++ pattern - --- --------------------------------------------------------------------- --- | Matches a regular expression against a buffer, returning the buffer --- indicies of the match, and any submatches --- -regexec :: Regex -- ^ Compiled regular expression - -> Ptr CChar -- ^ The buffer to match against - -> Int -- ^ Offset in buffer to start searching from - -> IO (Maybe ((Int,Int), [(Int,Int)])) - -- ^ Returns: 'Nothing' if the regex did not match the - -- or Just the start and end indicies of the match and submatches - -regexec (Regex regex_fptr) ptr i = do - withForeignPtr regex_fptr $ \regex_ptr -> do - nsub <- (#peek regex_t, re_nsub) regex_ptr - let nsub_int = fromIntegral (nsub :: CSize) - allocaBytes ((1 + nsub_int)*(#const sizeof(regmatch_t))) $ \p_match-> do - -- add one because index zero covers the whole match - r <- cregexec regex_ptr (ptr `plusPtr` i) - (1 + nsub) p_match 0{-no flags -} - - if (r /= 0) then return Nothing else do - match <- indexOfMatch p_match - sub_matches <- mapM (indexOfMatch) $ take nsub_int $ tail $ - iterate (`plusPtr` (#const sizeof(regmatch_t))) p_match - - return (Just (match, sub_matches)) - -indexOfMatch :: Ptr CRegMatch -> IO (Int, Int) -indexOfMatch p_match = do - start <- (#peek regmatch_t, rm_so) p_match :: IO (#type regoff_t) - end <- (#peek regmatch_t, rm_eo) p_match :: IO (#type regoff_t) - let s = fromIntegral start; e = fromIntegral end - return (s, e) - --- ----------------------------------------------------------------------------- --- The POSIX regex C interface - -regExtended :: Int -regExtended = 1 -regIgnoreCase :: Int -regIgnoreCase = 2 -regNosub :: Int -regNosub = 4 -regNewline :: Int -regNewline = 8 - -type CRegMatch = () - -foreign import ccall unsafe "regex.h regcomp" - c_regcomp :: Ptr CRegex -> CString -> CInt -> IO CInt - -foreign import ccall unsafe "regex.h ®free" - ptr_regfree :: FunPtr (Ptr CRegex -> IO ()) - -foreign import ccall unsafe "regex.h regexec" - cregexec :: Ptr CRegex - -> Ptr CChar - -> CSize -> Ptr CRegMatch -> CInt -> IO CInt - diff --git a/State.hs b/State.hs --- a/State.hs +++ b/State.hs @@ -1,5 +1,5 @@ -- --- Copyright (c) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- Copyright (c) 2004-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons -- -- This program is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as @@ -25,10 +25,10 @@ import Syntax (Status(Stopped), Mode(..), Frame, Info,Id3) import Tree (FileArray, DirArray) import Style (StringA(Fast), defaultSty, UIStyle) -import Regex (Regex) 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) diff --git a/Style.hs b/Style.hs --- a/Style.hs +++ b/Style.hs @@ -1,5 +1,5 @@ -- --- Copyright (c) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- Copyright (c) 2004-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons -- -- This program is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as @@ -42,7 +42,7 @@ -- | User-configurable colours -- Each component of this structure corresponds to a fg\/bg colour pair -- for an item in the ui -data UIStyle = UIStyle { +data UIStyle = UIStyle { window :: !Style -- default window colour , helpscreen :: !Style -- help screen , titlebar :: !Style -- titlebar of window @@ -165,12 +165,12 @@ 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 diff --git a/Syntax.hs b/Syntax.hs --- a/Syntax.hs +++ b/Syntax.hs @@ -1,5 +1,5 @@ -- --- Copyright (c) 2005 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- Copyright (c) 2005-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons -- -- This program is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as @@ -26,7 +26,7 @@ module Syntax where -import qualified Data.ByteString.Char8 as P (packAddress,concat,pack,ByteString) +import qualified Data.ByteString.Char8 as P (concat,pack,ByteString) ------------------------------------------------------------------------ -- @@ -37,7 +37,7 @@ data Load = Load {-# UNPACK #-} !P.ByteString instance Pretty Load where - ppr (Load f) = P.concat [P.packAddress "LOAD "#, f] + ppr (Load f) = P.concat [P.pack "LOAD ", f] -- If '+' or '-' is specified, jumps frames forward, or backwards, -- respectively, in the the mp3 file. If neither is specifies, jumps to @@ -45,19 +45,19 @@ data Jump = Jump {-# UNPACK #-} !Int instance Pretty Jump where - ppr (Jump i) = P.concat [P.packAddress "JUMP "#, P.pack . show $ i] + 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.packAddress "PAUSE"# + ppr Pause = P.pack "PAUSE" -- Quits mpg321. data Quit = Quit instance Pretty Quit where - ppr Quit = P.packAddress "QUIT"# + ppr Quit = P.pack "QUIT" ------------------------------------------------------------------------ -- @@ -70,10 +70,10 @@ data File = File {-# UNPACK #-} !(Either P.ByteString Id3) -- ID3 info -data Id3 = Id3 - { id3title :: !P.ByteString - , id3artist :: !P.ByteString - , id3album :: !P.ByteString +data Id3 = Id3 + { id3title :: !P.ByteString + , id3artist :: !P.ByteString + , id3album :: !P.ByteString , id3str :: !P.ByteString } -- cache screen string to draw -- , year :: Maybe P.ByteString diff --git a/Tree.hs b/Tree.hs --- a/Tree.hs +++ b/Tree.hs @@ -124,7 +124,7 @@ expandDir f = do ls_raw <- Control.Exception.handle (\e -> hPutStrLn stderr (show e) >> return []) $ packedGetDirectoryContents f - let ls = map (\s -> P.join (P.singleton '/') [f,s]) . sort . filter validFiles $! ls_raw + 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' diff --git a/UI.hs b/UI.hs --- a/UI.hs +++ b/UI.hs @@ -647,7 +647,7 @@ Curses.throwIfErr_ msg $ Curses.waddnstr Curses.stdScr cstr (fromIntegral . P.length $ ps) where - msg = P.packAddress "drawPackedString"# + msg = P.pack "drawPackedString" ------------------------------------------------------------------------ diff --git a/Utils.hs b/Utils.hs --- a/Utils.hs +++ b/Utils.hs @@ -1,5 +1,5 @@ -- --- Copyright (c) 2003-5 Don Stewart - http://www.cse.unsw.edu.au/~dons +-- Copyright (c) 2003-2008 Don Stewart - http://www.cse.unsw.edu.au/~dons -- -- This program is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as @@ -33,7 +33,8 @@ module Utils where import FastIO (printfPS) -import qualified Data.ByteString.Base as P (packAddress,ByteString) +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) @@ -73,9 +74,9 @@ m = quot sr 60 in printfPS fmt h m where - fmt = P.packAddress "%3d:%02d"# -- sometimes ghc doesn't want to fire a RULE here, why? + fmt = P.pack "%3d:%02d" -- 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 @@ -111,8 +112,8 @@ popen :: FilePath -> [String] -> IO (Fd, Fd, Fd, ProcessID) popen cmd args = do (pr, pw) <- createPipe - (cr, cw) <- createPipe - (cre, cwe) <- createPipe + (cr, cw) <- createPipe + (cre, cwe) <- createPipe -- parent -- let parent = do closeFd cw @@ -120,7 +121,7 @@ closeFd pr -- child -- let child = do closeFd pw - closeFd cr + closeFd cr closeFd cre exec cmd args (pr,cw,cwe) error "exec cmd failed!" -- typing only diff --git a/hmp3.cabal b/hmp3.cabal --- a/hmp3.cabal +++ b/hmp3.cabal @@ -1,28 +1,38 @@ name: hmp3 -version: 1.3 +version: 1.4 +homepage: http://code.haskell.org/~dons/code/hmp3 license: GPL license-file: LICENSE author: Don Stewart -maintainer: dons@cse.unsw.edu.au -build-depends: base, unix, binary >= 0.2 -synopsis: An ncurses mp3 player written in Haskell +maintainer: dons@galois.com category: Sound +synopsis: 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. + . +cabal-version: >= 1.2 extra-source-files: Keymap.hs-boot README TODO configure configure.ac -executable: hmp3 -main-is: Main.hs -extensions: CPP, ForeignFunctionInterface -extra-libraries: curses -include-dirs: cbits -c-sources: cbits/utils.c -other-modules: Curses Regex -ghc-options: -Wall -fglasgow-exts -O2 -funbox-strict-fields -fasm -optl-Wl,-s -Icbits -threaded - --- ghc-options: -Wall -fglasgow-exts -O2 -funbox-strict-fields -fvia-C -optc-O3 -optl-Wl,-s -Icbits -threaded -lncurses --- ghc-options: -prof -auto-all -Wall -fglasgow-exts -O2 -optc-O3 -funbox-strict-fields -Icbits -threaded -lncurses --- ghc-options: -Wall -fglasgow-exts -Onot -Icbits -threaded -lncurses +flag small_base + description: Choose the new smaller, split-up base package. + +executable hmp3 + build-depends: unix, binary >= 0.4, pcre-light >=0.2.1 + if flag(small_base) + build-depends: base >= 3, bytestring >= 0.9, containers, + array, old-time, directory, process, random + else + build-depends: base < 3 + + ghc-options: -Wall -O2 -funbox-strict-fields -optl-Wl,-s -threaded + main-is: Main.hs + other-modules: Curses Config Core FastIO Keymap + Lexer Lexers State Style Syntax Tree UI Utils + + extensions: CPP, ForeignFunctionInterface + extra-libraries: curses + include-dirs: cbits + c-sources: cbits/utils.c