nptools 0.2.0 → 0.2.1

raw patch · 10 files changed

+99/−29 lines, 10 filessetup-changednew-component:exe:cp-rescue

Files

• Setup.hs +0/−2
• Setup.lhs +3/−0
• cp-rescue.hs +62/−0
• events-to-timelog.hs +0/−2
• extract-non-ascii.hs +0/−1
• git-prompt.hs +18/−8
• label.hs +9/−11
• mh-gen-message-id-mapping.hs +0/−1
• nptools.cabal +5/−1
• what-I-have-done-today.hs +2/−3

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain

@@ -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 <num>] <src> <dest>"++  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)+

@@ -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

@@ -1,5 +1,4 @@ import Data.Char-import Data.List import Control.Applicative import System.Environment import Control.Monad

@@ -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 "

@@ -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

@@ -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 

@@ -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

@@ -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