diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/cp-rescue.hs b/cp-rescue.hs new file mode 100644 --- /dev/null +++ b/cp-rescue.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- This script is originally from Neil Mitchell's blog + +import Data.ByteString (hGet, hPut) +import Data.Char (isDigit) +import System.IO +import System.Environment +import Control.Monad +import Control.Exception + +type Offset = Integer +type Length = Integer +type ChunkLength = Length + +defaultChunkLength :: ChunkLength +defaultChunkLength = 10000000 + +main :: IO () +main = do + args <- getArgs + + (clen,src,dest) <- + case args of + [src,dest] + -> return (defaultChunkLength,src,dest) + ["--chunk-length",clen,src,dest] + | all isDigit clen + -> return (read clen,src,dest) + _ -> fail "Usage: cp-rescue [--chunk-length ] " + + withBinaryFile src ReadMode $ \hSrc -> + withBinaryFile dest WriteMode $ \hDest -> do + nSrc <- hFileSize hSrc + nDest <- hFileSize hDest + when (nSrc /= nDest) $ hSetFileSize hDest nSrc + copy hSrc hDest $ split clen 0 nSrc + +copyChunk :: Handle -> Handle -> Offset -> Length -> IO () +copyChunk hSrc hDest from len = do + hSeek hSrc AbsoluteSeek from + hSeek hDest AbsoluteSeek from + bs <- hGet hSrc $ fromIntegral len + hPut hDest bs + +copy :: Handle -> Handle -> [(Offset,Length)] -> IO () +copy _ _ [] = return () +copy hSrc hDest chunks = do + putStrLn $ "Copying " ++ show (length chunks) ++ " of at most " ++ show (snd $ head chunks) + chunks' <- forM chunks $ \(from,len) -> do + res <- Control.Exception.try $ copyChunk hSrc hDest from len + case res of + Left (_ :: IOException) -> putChar '#' >> return (split (len `div` 5) from len) + Right _ -> putChar '.' >> return [] + putChar '\n' + copy hSrc hDest $ concat chunks' + +split :: ChunkLength -> Offset -> Length -> [(Offset,Length)] +split clen off len + | clen <= 0 = [] + | clen >= len = [(off,len)] + | otherwise = (off,clen) : split clen (off+clen) (len-clen) + diff --git a/events-to-timelog.hs b/events-to-timelog.hs --- a/events-to-timelog.hs +++ b/events-to-timelog.hs @@ -1,7 +1,5 @@ import System.Locale import Data.Time -import Data.Time.LocalTime -import Data.Time.Format import Control.Monad import Control.Monad.Instances () import Data.List diff --git a/extract-non-ascii.hs b/extract-non-ascii.hs --- a/extract-non-ascii.hs +++ b/extract-non-ascii.hs @@ -1,5 +1,4 @@ import Data.Char -import Data.List import Control.Applicative import System.Environment import Control.Monad diff --git a/git-prompt.hs b/git-prompt.hs --- a/git-prompt.hs +++ b/git-prompt.hs @@ -1,25 +1,35 @@ import System.Console.ANSI import System.Exit import HSH -import Control.Applicative import Control.Monad +import Control.Applicative import Data.Char import Data.Maybe +-- tell Zsh to not count the contents for the length +noLength :: String -> String +noLength = ("%{"++) . (++"%}") + color :: Color -> String -color c = setSGRCode [SetColor Foreground Dull c] +color c + = noLength $ setSGRCode [ SetConsoleIntensity BoldIntensity + , SetColor Foreground Dull c] +-- I didn't found how to generate sgr0 from Sys.Console.ANSI +sgr0 :: String +sgr0 = "\SI" + blue, magenta, green, noColor :: String -blue = color Blue -magenta = color Magenta -green = color Green -noColor = setSGRCode [] +blue = color Blue +magenta = color Magenta +green = color Green +noColor = noLength $ setSGRCode [] ++ sgr0 main :: IO () main = do - ref <- runSL "git symbolic-ref HEAD 2> /dev/null" + ref <- head . lines <$> run "git symbolic-ref HEAD 2> /dev/null" when (null ref) exitFailure - gitstat <- fmap lines . runSL $ "git status 2>/dev/null" + gitstat <- fmap lines . run $ "git status 2> /dev/null" -|- egrep "(# Untracked|# Changes|# Changed but not updated:|# Your branch)" let f msg = listToMaybe . map (takeWhile isDigit . dropWhile (not . isDigit)) $ egrep msg gitstat ahead = f "# Your branch is ahead of " diff --git a/label.hs b/label.hs --- a/label.hs +++ b/label.hs @@ -19,9 +19,6 @@ (<>) :: Monoid m => m -> m -> m (<>) = mappend -message_ids :: String -message_ids = "/home/ertai/mailnmh/.message-ids" - type Folder = ByteString type MsgLabel = ByteString type MsgID = ByteString @@ -68,18 +65,18 @@ -- dropIt x (y:ys) | x == y = Just ys -- dropIt _ _ = Nothing -pathFromMsgID :: MsgID -> IO (Either String FilePath) -pathFromMsgID msgID +pathFromMsgID :: FilePath -> MsgID -> IO (Either String FilePath) +pathFromMsgID message_ids msgID = maybe (Left err) (return . C.unpack . snd) . find ((==msgID') . fst) . map (cutOnC ' ') . C.lines <$> C.readFile message_ids where err = C.unpack msgID ++ " not found" msgID' = '<' `C.cons` msgID `C.snoc` '>' -pathFromMsg :: Msg -> IO (Either String FilePath) -pathFromMsg (MsgPath path) = return . return $ path -pathFromMsg (MsgByID mID) = pathFromMsgID mID -pathFromMsg (MsgInFolder folder ix) = return <$> runSL ("mhpath" :: String, [C.unpack folder, show ix]) +pathFromMsg :: FilePath -> Msg -> IO (Either String FilePath) +pathFromMsg _ (MsgPath path) = return . return $ path +pathFromMsg e (MsgByID mID) = pathFromMsgID e mID +pathFromMsg _ (MsgInFolder folder ix) = return <$> runSL ("mhpath" :: String, [C.unpack folder, show ix]) -- mv :: Folder -> Folder -> [Int] -> IO () -- mv src dst msgs = run ("refile", msgs ++ [dst, "-nolink", "-src", src]) @@ -87,7 +84,8 @@ cp :: [Msg] -> [Folder] -> IO () cp msgs dsts | null msgs || null dsts = return () cp msgs dsts = do - (errs, pathss) <- second (chunk 1000) . partitionEithers <$> mapM pathFromMsg msgs + message_ids <- getEnv "NMH_MESSAGE_IDS" + (errs, pathss) <- second (chunk 1000) . partitionEithers <$> mapM (pathFromMsg message_ids) msgs forM_ pathss $ \paths -> -- runIO ("refile", "-link" : (concatMap (("-file":) . pure) paths ++ dsts)) rawSystem "refile" ("-link" : (concatMap (("-file":) . pure) paths ++ map C.unpack dsts)) @@ -155,7 +153,7 @@ -- validOptions = words "draft link nolink preserve nopreserve unlink nounlink file rmmproc normmproc version help" main :: IO () -main = do (options, args) <- partition ("--" `isPrefixOf`) <$> getArgs +main = do (options, args) <- partition ("--" `isPrefixOf`) <$> getArgs case (sort options, args) of (["--lmap"], []) -> applyLabelMap . parseEntries =<< C.getContents (["--mids"], [lmapf]) -> do lmap <- parseEntries <$> C.readFile lmapf diff --git a/mh-gen-message-id-mapping.hs b/mh-gen-message-id-mapping.hs --- a/mh-gen-message-id-mapping.hs +++ b/mh-gen-message-id-mapping.hs @@ -3,7 +3,6 @@ import Data.Maybe import Data.List import qualified Data.ByteString.Lazy.Char8 as B -import Control.Monad import Control.Applicative import System.Environment diff --git a/nptools.cabal b/nptools.cabal --- a/nptools.cabal +++ b/nptools.cabal @@ -1,6 +1,6 @@ Name: nptools Cabal-Version: >=1.4 -Version: 0.2.0 +Version: 0.2.1 License: BSD3 License-File: LICENSE Copyright: (c) Nicolas Pouillard @@ -110,4 +110,8 @@ executable x-printable main-is: x-printable.hs Build-depends: base>=3&&<5 + ghc-options: -Wall -Odph + +executable cp-rescue + main-is: cp-rescue.hs ghc-options: -Wall -Odph diff --git a/what-I-have-done-today.hs b/what-I-have-done-today.hs --- a/what-I-have-done-today.hs +++ b/what-I-have-done-today.hs @@ -1,5 +1,6 @@ {-# LANGUAGE PatternGuards #-} import System.Locale (defaultTimeLocale) +import System.Environment (getEnv) import Data.Time.Clock (DiffTime, UTCTime(..), getCurrentTime) import Data.Time.LocalTime import Data.Time.Format (readTime, formatTime) @@ -11,9 +12,6 @@ import Data.Function import Data.Ord -eventsFile :: FilePath -eventsFile = "/Users/ertai/.xmonad/events.log" - readMyTime :: String -> UTCTime readMyTime = readTime defaultTimeLocale "%T%Q" @@ -44,6 +42,7 @@ main :: IO () main = do now <- getCurrentTime + eventsFile <- getEnv "EVENTS_LOG" let today = formatTime defaultTimeLocale "%Y-%m-%d" now events <- lines <$> readFile eventsFile putStr $ work today events