nptools (empty) → 0.1

raw patch · 22 files changed

+680/−0 lines, 22 filesdep +FileManipdep +HSHdep +SHAsetup-changed

Dependencies added: FileManip, HSH, SHA, ansi-terminal, base, bytestring, filepath, old-locale, process, split, time

Files

• LICENSE +30/−0
• Setup.lhs +3/−0
• archive.hs +8/−0
• bufferize.hs +7/−0
• color-diff.hs +10/−0
• events-to-timelog.hs +29/−0
• extract-non-ascii.hs +13/−0
• git-prompt.hs +36/−0
• iter-lines.hs +22/−0
• label.hs +168/−0
• loopback.hs +31/−0
• mh-gen-message-id-mapping.hs +22/−0
• myrev.hs +5/−0
• nptools.cabal +113/−0
• pad.hs +6/−0
• rot.hs +30/−0
• show-non-ascii.hs +19/−0
• show-pollbox.hs +31/−0
• summ.hs +7/−0
• tac.hs +10/−0
• what-I-have-done-today.hs +47/−0
• x-printable.hs +33/−0

@@ -0,0 +1,30 @@+Copyright (c) 2009, Nicolas Pouillard+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of the copyright holders nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

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

@@ -0,0 +1,8 @@+import System.Environment+import HSH+import Data.Time.Clock+import Data.Time.Calendar+main :: IO ()+main = do args <- getArgs+          (year, _, _) <- (toGregorian . utctDay) `fmap` getCurrentTime+          run $ ("refile", ["+archive-"++show year, "-src", "+inbox"] ++ args)

@@ -0,0 +1,7 @@+import System.Environment (getArgs)+import Control.Monad+import qualified Data.ByteString as B+main :: IO ()+main = do args  <- getArgs+          when (null args)  $ B.putStr =<< B.getContents+          forM_ args        $ B.putStr <=< B.readFile

@@ -0,0 +1,10 @@+color :: Int -> String -> String+color n = ("\^[["++) . shows n . ('m':) . (++ "\^[[m")++colorDiffLine :: String -> String+colorDiffLine xs@('+':_) = color 36 xs+colorDiffLine xs@('-':_) = color 35 xs+colorDiffLine xs         = xs++main :: IO ()+main = interact (unlines . map colorDiffLine . lines)

@@ -0,0 +1,29 @@+import System.Locale+import Data.Time+import Data.Time.LocalTime+import Data.Time.Format+import Control.Monad+import Control.Monad.Instances ()+import Data.List++readMyTime :: String -> UTCTime+readMyTime = readTime defaultTimeLocale "%F %T%Q %Z"++timelogFormat :: TimeZone -> UTCTime -> String+timelogFormat tz = formatTime defaultTimeLocale "%Y/%m/%d %T" . utcToLocalTime tz++splitEvent :: String -> (UTCTime, [String])+splitEvent event =+   case words event of+     date : time : tz : "tags:" : tags -> (readMyTime (unwords [date, time, init tz]), tags)+     _ -> error ("splitEvent: " ++ event)++work :: TimeZone -> [String] -> [String]+work tz = concat . (zipWith f `ap` (tail . map fst)) . map splitEvent+  where f (a, b) c = [ unwords ["i", timelogFormat tz a, intercalate "," b]+                     , unwords ["o", timelogFormat tz c]+                     ]++main :: IO ()+main = do tz <- getCurrentTimeZone+          interact $ unlines . work tz . lines

@@ -0,0 +1,13 @@+import Data.Char+import Data.List+import Control.Applicative+import System.Environment+import Control.Monad++analyseLine :: String -> [String]+analyseLine = map pure . filter (not . isAscii)++main :: IO ()+main = do args <- getArgs+          when (not . null $ args) $ putStrLn "Reading from stdin"+          putStrLn =<< unlines . concatMap analyseLine . lines <$> getContents

@@ -0,0 +1,36 @@+import System.Console.ANSI+import System.Exit+import HSH+import Control.Applicative+import Control.Monad+import Data.Char+import Data.Maybe++color :: Color -> String+color c = setSGRCode [SetColor Foreground Dull c]++blue, magenta, green, noColor :: String+blue      = color Blue+magenta   = color Magenta+green     = color Green+noColor  = setSGRCode []++main :: IO ()+main = do +  ref <- runSL "git symbolic-ref HEAD 2> /dev/null"+  when (null ref) exitFailure+  gitstat <-  fmap lines . runSL $ "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 "+      behind  = f "# Your branch is behind "+  putStrLn . concat $+    ["±"+    ,blue,":",magenta,drop (length "refs/heads/") ref+    ,green+    ,['!' | "# Changes to be committed:"  `elem` gitstat]+    ,['?' | "# Untracked files:"          `elem` gitstat+         || "# Changed but not updated:"  `elem` gitstat]+    ,maybe "" ((blue++":"++green++"-")++) behind+    ,maybe "" ((blue++":"++green++"+")++) ahead+    ,noColor]

@@ -0,0 +1,22 @@+{-# LANGUAGE ScopedTypeVariables #-}+import Control.Exception+import System.Environment (getArgs)+import System.Exit (ExitCode)+import System.IO+import qualified System.Process as P+import qualified Data.ByteString.Lazy.Char8 as L8+import qualified Data.ByteString.Lazy as L++main :: IO ()+main = do+  cmd:args <- getArgs+  mapM_ (processWithStdin (P.proc cmd args) . flip L8.snoc '\n') . L8.lines =<< L.getContents++processWithStdin :: P.CreateProcess -> L.ByteString -> IO ExitCode+processWithStdin process input = do+  (Just stdinHdl, _, _, pHdl) <-+     P.createProcess process { P.std_in = P.CreatePipe }+  handle (\(_ :: IOException) -> return ()) $ do+    L.hPut stdinHdl input+    hClose stdinHdl+  P.waitForProcess pHdl

@@ -0,0 +1,168 @@+{-# LANGUAGE OverloadedStrings #-}+import System.Environment+import HSH+import Control.Monad+import Control.Applicative+import Control.Arrow+import Data.Char+-- import Data.Time.Clock+-- import Data.Time.Calendar+import Data.Either+import Data.List+import Data.List.Split (chunk)+import Data.Monoid+import qualified Data.ByteString.Char8 as C+import Data.ByteString (ByteString)+import System.Cmd+import System.IO++(<>) :: Monoid m => m -> m -> m+(<>) = mappend++type Folder   = ByteString+type MsgLabel = ByteString+type MsgID    = ByteString+data Msg = MsgPath     FilePath+         | MsgInFolder Folder Int+         | MsgByID     MsgID+data Labeling a = Label   a+                | Unlabel a+type MsgLabeling = Labeling MsgLabel++parseLabeling :: String -> Either String (Labeling ByteString)+parseLabeling ('+':lbl) = Right . Label   . C.pack $ lbl+parseLabeling ('-':lbl) = Right . Unlabel . C.pack $ lbl+parseLabeling s         = Left s++maybeRead :: Read a => String -> Maybe a+maybeRead s = case reads s of+                [(x, s')] | all isSpace s' -> Just x+                _                          -> Nothing++parseMsg :: String -> Either String Msg+parseMsg ('<':s) = fmap MsgByID . dropEndThis '>' . C.pack $ s+parseMsg ('@':s) = MsgInFolder (C.pack ('+':folder)) <$> maybe err return (maybeRead ix)+  where (folder,ix) = cutOn '/' s+        err         = Left $ "parseMsg: cannot parse message spec: @" ++ s+parseMsg s         = return (MsgPath s)++folderFromMsgLabel :: MsgLabel -> Folder+folderFromMsgLabel = C.cons '+'++cutOnC :: Char -> ByteString -> (ByteString, ByteString)+cutOnC c = second (C.drop 1) . C.break (==c)++cutOn :: Eq a => a -> [a] -> ([a], [a])+cutOn c = second (drop 1) . break (==c)++dropEndThis :: Char -> ByteString -> Either String ByteString+dropEndThis c s | C.last s == c = Right $ C.init s+                | otherwise     = Left $ unwords [ "dropEndThis: unexpected"+                                                 , show (C.last s) ++ ","+                                                 , show c, "was expected" ]++-- dropIt :: Eq a => a -> [a] -> Maybe [a]+-- dropIt x (y:ys) | x == y = Just ys+-- dropIt _ _               = Nothing++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 :: 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])++cp :: [Msg] -> [Folder] -> IO ()+cp msgs dsts | null msgs || null dsts = return ()+cp msgs dsts = do+  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))+  when (not . null $ errs) $ hPutStr stderr $ unlines errs++-- rm :: [Msg] -> [Folder] -> IO ()+-- rm msgs  = do+--   msgsargs <- concat <$> mapM cmdSpecFromMsg msgs+--   run ("rmm", "-unlink" : (msgsargs ++ dsts))++-- archive :: ArchiveFolder -> [Msg] -> IO ()+-- archive archiveFolder = mv "+inbox" archiveFolder++-- unarchive :: ArchiveFolder -> [Msg] -> IO ()+-- unarchive archiveFolder = mv archiveFolder "+inbox"++addLabels :: [MsgLabel] -> [Msg] -> IO ()+addLabels lbls msgs = cp msgs (map folderFromMsgLabel lbls)+  +remLabels :: [MsgLabel] -> [Msg] -> IO ()+remLabels _lbls _msgs = fail "remLabels: not yet implemented"+  +label :: [MsgLabeling] -> [Msg] -> IO ()+label labels msgs = sequence_ [ labelOne lbl msgs | lbl <- labels ]+  where+    labelOne (Label   lbl) = addLabels [lbl]+    labelOne (Unlabel lbl) = remLabels [lbl]+ +applyLabelMap :: [(MsgID, [MsgLabel])] -> IO ()+applyLabelMap lblMap =+  sequence_+  [ addLabels lbls [MsgByID msgID]+  | (msgID, lbls) <- lblMap ]++applyLabelMapForMIDs :: [(MsgID, [MsgLabel])] -> [MsgID] -> IO ()+applyLabelMapForMIDs lmap mids =+  sequence_+  [ maybe (err msgID) (flip addLabels [MsgByID msgID]) lbls+  | msgID <- mids+  , let lbls = lookup msgID lmap+  ]+  where err msgID = C.hPutStrLn stderr $ "not found: " <> msgID++parseEntries :: ByteString -> [(MsgID,[MsgLabel])]+parseEntries = map (second (C.words . C.takeWhile (/=')') . C.dropWhile (=='(') . C.tail)+                  . C.break (==' ')) . C.lines++++--   if "+inbox" `elem` labelsToAdd+--     then unarchive archiveFolder msgs+--     else if "-inbox" `elem` labelsToRem+--            then archive archiveFolder msgs+--            else fail "Error: both -inbox and +inbox on the command line"+--   cp archiveFolder (delete "+inbox" labelsToAdd)+--   refile ["-nolink"] (delete "-inbox" labelsToRem)+--   where (labelsToAdd, labelsToRem) = partition isAddLabel labels++--         refile _       []   = return ()+--         refile options lbls =+--           run $ ("refile", msgs ++ ["-src", archiveFolder] ++ options ++ map folderFromMsgLabel lbls)++-- -src is excluded on purpose+-- validOptions :: [Option]+-- validOptions = words "draft link nolink preserve nopreserve unlink nounlink file rmmproc normmproc version help"++main :: IO ()+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+                                        applyLabelMapForMIDs lmap . C.lines =<< C.getContents+            ([], _) ->+              let (msgs, lbls) = partitionEithers $ map parseLabeling args in+              label lbls =<< either fail return (mapM parseMsg msgs)+--           (year, _, _) <- (toGregorian . utctDay) `fmap` getCurrentTime+--           let archiveFolder = "+archive-"++show year+--               (labels, msgs) = partition isLabel args+--           label archiveFolder labels msgs+            (_, _) -> fail "Bad arguments"

@@ -0,0 +1,31 @@+import qualified Data.ByteString.Lazy.Char8 as L+import System.IO+import System.Environment+import System.Process+import System.Exit++me :: String+me = "loopback"++loopBack :: CreateProcess -> IO ProcessHandle+loopBack prc = do+  (Just inp,Just out,_,pid) <- createProcess prc{std_in=CreatePipe,std_out=CreatePipe}+  hSetBuffering inp LineBuffering+  mapM_ (hPutLnF inp) . L.split '\n' =<< L.hGetContents out+  return pid+  where hPutLnF h x = L.hPut h x >> hPutChar h '\n'++usage :: String -> IO a+usage msg = hPutStr stderr (unlines ls) >> exitFailure+  where ls = [msg+             ,"Usage: "++me++" <shell-command>"+             ,"       "++me++" <executable-path> <argument> <arguments>*"]++main :: IO ()+main = do args  <- getArgs+          prc   <- case args of+                     [arg]      -> return $ shell arg+                     exe:args'  -> return $ proc exe args'+                     []         -> usage "Not enough arguments"+          exitWith =<< waitForProcess =<< loopBack prc+

@@ -0,0 +1,22 @@+import HSH+import Data.Char+import Data.Maybe+import Data.List+import qualified Data.ByteString.Lazy.Char8 as B+import Control.Monad+import Control.Applicative+import System.Environment++main :: IO ()+main =+  do [arg] <- getArgs+     path  <- runSL ("mhpath", [arg])+     paths <- glob $ path ++ "/[0-9]*"+     mapM_ f paths+  where+    f i = B.putStrLn . (`B.append` (B.pack (' ':i))) =<< mid i+    mid fp = fromMaybe (B.pack "<NO-VALID-MESSAGE-ID>")+                . fmap (B.dropWhile isSpace . B.drop (B.length message_id))+                . find isMessageIDline . B.lines <$> B.readFile fp+    isMessageIDline = (message_id `B.isPrefixOf`) . B.map toLower+    message_id = B.pack "message-id: "

@@ -0,0 +1,5 @@+import qualified Data.ByteString.Lazy.Char8 as L+import System.IO+main :: IO ()+main = mapM_ (hPutLn stdout) . map L.reverse . L.lines =<< L.getContents+  where hPutLn h x = L.hPut h x >> hPutChar h '\n' >> hFlush h

@@ -0,0 +1,113 @@+Name:           nptools+Cabal-Version:  >=1.4+Version:        0.1+License:        BSD3+License-File:   LICENSE+Copyright:      (c) Nicolas Pouillard+Author:         Nicolas Pouillard+Maintainer:     Nicolas Pouillard <nicolas.pouillard@gmail.com>+Category:       Development, System, Text, Utils+Synopsis:       A collection of random tools+Description:    A collection of random tools+Stability:      Experimental+Build-Type:     Simple++executable archive+    main-is: archive.hs+    Build-depends: base>=3&&<5, time, HSH+    ghc-options: -Wall -Odph++executable color-diff+    main-is: color-diff.hs+    Build-depends: base>=3&&<5+    ghc-options: -Wall -Odph++executable events-to-timelog+    main-is: events-to-timelog.hs+    Build-depends: base>=3&&<5, time, old-locale+    ghc-options: -Wall -Odph++executable extract-non-ascii+    main-is: extract-non-ascii.hs+    Build-depends: base>=3&&<5+    ghc-options: -Wall -Odph++executable git-prompt+    main-is: git-prompt.hs+    Build-depends: base>=3&&<5, ansi-terminal, HSH+    ghc-options: -Wall -Odph++executable iter-lines+    main-is: iter-lines.hs+    Build-depends: base>=3&&<5, process, bytestring+    ghc-options: -Wall -Odph++executable label+    main-is: label.hs+    Build-depends: base>=3&&<5, HSH, split, process+    ghc-options: -Wall -Odph++executable bufferize+    main-is: bufferize.hs+    Build-depends: base>=3&&<5+    ghc-options: -Wall -Odph++executable mh-gen-message-id-mapping+    main-is: mh-gen-message-id-mapping.hs+    Build-depends: base>=3&&<5+    ghc-options: -Wall -Odph++-- executable refile-with-lmap+--     main-is: refile-with-lmap.hs+--     Build-depends: base>=3&&<5+--     ghc-options: -Wall -Odph++executable show-non-ascii+    main-is: show-non-ascii.hs+    Build-depends: base>=3&&<5+    ghc-options: -Wall -Odph++executable show-pollbox+    main-is: show-pollbox.hs+    Build-depends: base>=3&&<5, filepath, SHA, FileManip+    ghc-options: -Wall -Odph++executable summ+    main-is: summ.hs+    Build-depends: base>=3&&<5+    ghc-options: -Wall -Odph++executable tac+    main-is: tac.hs+    Build-depends: base>=3&&<5+    ghc-options: -Wall -Odph++executable rot+    main-is: rot.hs+    Build-depends: base>=3&&<5+    ghc-options: -Wall -Odph++executable pad+    main-is: pad.hs+    Build-depends: base>=3&&<5+    ghc-options: -Wall -Odph++executable myrev+    main-is: myrev.hs+    Build-depends: base>=3&&<5+    ghc-options: -Wall -Odph++executable loopback+    main-is: loopback.hs+    Build-depends: base>=3&&<5+    ghc-options: -Wall -Odph++executable what-I-have-done-today+    main-is: what-I-have-done-today.hs+    Build-depends: base>=3&&<5+    ghc-options: -Wall -Odph++executable x-printable+    main-is: x-printable.hs+    Build-depends: base>=3&&<5+    ghc-options: -Wall -Odph

@@ -0,0 +1,6 @@+import qualified Data.ByteString as S+import System.Environment+main :: IO ()+main = do [i,inp,outp] <- getArgs+          s <- S.readFile inp+          S.writeFile outp $ S.append s $ S.replicate (read i - S.length s) 0

@@ -0,0 +1,30 @@+import qualified Data.ByteString.Char8       as S+import qualified Data.ByteString.Lazy.Char8  as L+import System.IO+import System.Exit+import System.Environment+import Data.Char++me :: String+me = "rot"++usage :: String -> IO a+usage msg = do hPutStr stderr . unlines $ msg : ls+               exitFailure+  where ls = ["Usage: "++me++" <shifting>", "",+              "A positive integer rotate each line by one character to the right.",+              "Use negatives to go to the left"]++main :: IO ()+main = do args <- getArgs+          rot <- case args of+                   [arg]      | all isDigit arg -> return (rotLeft   $ read arg)+                   ['-':arg]  | all isDigit arg -> return (rotRight  $ read arg)+                   [_]  -> usage "Malformed number"+                   []   -> usage "Not enough arguments"+                   _    -> usage "Too much arguments"+          mapM_ (hPutLn stdout) . map (rot . toS) . L.lines =<< L.getContents+  where hPutLn    h x  = S.hPutStrLn h x >> hFlush h+        toS            = foldr S.append S.empty . L.toChunks+        rotLeft   n s  = rotRight (S.length s - n) s+        rotRight  n s  = b `S.append` a where (a,b) = S.splitAt n s

@@ -0,0 +1,19 @@+import Data.Char+import Data.List+import Control.Applicative++bool :: a -> a -> Bool -> a+bool t e b = if b then t else e++analyseLine :: (Int, String) -> [String]+analyseLine (line, xs) | any (not . isAscii) xs = ["Line " ++ show line,+                                                   "  Orig: " ++ xs,+                                                   "  Mark: " ++ marks xs,+                                                   "  Char: " ++ chars xs]+                       | otherwise              = []+  where marks = reverse . dropWhile isSpace . reverse . map (bool ' ' '^' . isAscii)+        chars = intercalate ", " . map show . filter (not . isAscii)++main :: IO ()+main = do putStrLn "Reading from stdin"+          putStrLn =<< unlines . concatMap analyseLine . zip [1..] . lines <$> getContents

@@ -0,0 +1,31 @@+#!/usr/bin/env runhaskell+{-# LANGUAGE OverloadedStrings #-}+import Control.Applicative+import Data.Digest.Pure.SHA (sha1)+import qualified Data.ByteString.Lazy.Char8 as L+import Data.List+import Data.Monoid+import System.FilePath.Glob (namesMatching)+import System.FilePath ( (</>) )+import System.Environment++(<>) :: Monoid m => m -> m -> m+(<>) = mappend++nest :: Int -> L.ByteString -> L.ByteString+nest n = L.unlines . map (L.replicate (fromIntegral n) ' ' <>) . L.lines++onFiles :: [L.ByteString] -> L.ByteString+onFiles []  = "Missing file!"+onFiles [x] = x+onFiles xs  = "Too many files!\n\n" <> L.intercalate "\n---\n\n" (map (nest 2) xs)++onDir :: FilePath -> IO ()+onDir dir = L.putStrLn . (("\n" <> L.pack dir <> ":\n") <>) . nest 2 <$>+              onFiles =<< mapM L.readFile =<< namesMatching (dir </> "*")++main :: IO ()+main = do [arg] <- getArgs+          dirs <- sort <$> namesMatching (arg </> "*/")+          print . sha1 . L.pack . show $ dirs+          mapM_ onDir dirs

@@ -0,0 +1,7 @@+import System.Environment+import Control.Monad+main :: IO ()+main = do+  argc <- length `fmap` getArgs+  when (argc /= 0) $ fail "summ does not expect arguments, it is reading from stdin"+  putStrLn . show . sum . map (read :: String -> Integer) . lines =<< getContents

@@ -0,0 +1,10 @@+import qualified Data.ByteString.Char8 as S+import System.Environment+import Control.Monad++main :: IO ()+main = do args <- getArgs+          when (null args)  $ tac =<< S.getContents+          forM_ args        $ tac <=< S.readFile+  where tac  = S.putStr . S.intercalate nl . reverse . S.split '\n'+        nl   = S.pack "\n"

@@ -0,0 +1,47 @@+{-# LANGUAGE PatternGuards #-}+import System.Locale (defaultTimeLocale)+import Data.Time.Clock (DiffTime, UTCTime(..), getCurrentTime)+import Data.Time.LocalTime+import Data.Time.Format (readTime, formatTime)+import Control.Monad+import Control.Applicative+import Control.Arrow+import Data.Maybe+import Data.List+import Data.Function+import Data.Ord++readMyTime :: String -> UTCTime+readMyTime = readTime defaultTimeLocale "%T%Q"++splitEvent :: String -> String -> Maybe (String, UTCTime)+splitEvent today event =+   case words event of+     date : time : _ : "tags:" : tags | [tag] <- tags ->+                                          guard (date == today) >> Just (tag, readMyTime time)+                                      | otherwise -> Nothing+     _ -> error ("splitEvent: " ++ event)++formatDiffTime :: DiffTime -> String+formatDiffTime = formatTime defaultTimeLocale "%T%Q" . timeToTimeOfDay++pack :: (Ord a) => [(a, b)] -> [(a, [b])]+pack = map ((fst . head) &&& map snd)+     . groupBy ((==) `on` fst)+     . sortBy (comparing fst)+++work :: String -> [String] -> String+work today = unlines . map (uncurry (++) . second ((": "++) . formatDiffTime))+           . sortBy (comparing snd)+           . map (second sum) . pack . uncurry zip+           . second ((map (uncurry (flip (-)))) . (zip`ap`tail) . map utctDayTime)+           . unzip . catMaybes . map (splitEvent today)++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

@@ -0,0 +1,33 @@+-- module XPrintable where+import Numeric+import Data.Char+import System.Environment++main :: IO ()+main = do+  args <- getArgs+  case args of+    ["encode"] -> interact encode+    ["decode"] -> interact decode+    _          -> error "Usage: x-printable [encode|decode]"++encode, decode :: String -> String++encode = concatMap (f . ord)+  where f x | x > 255      = error "impossible"+            | x > 128      = 'x' : showHex x []+            | x == ord 'x' = "xx"+            | otherwise    = [chr x]++decode = f+  where f [] = []+        f ('x' : i : j : xs)+          | isHexDigit i && isHexDigit j =+                case readHex [i, j] of+                  [(n, [])] -> chr n : f xs+                  _ -> 'x' : i : j : f xs+        f ('x' : 'x' : xs) = 'x' : f xs+        f (x : xs) = x : f xs++-- decode_encode_prop x = x == decode (encode x)+-- quickCheckWith stdArgs{maxSuccess=1000,maxSize=1000} decode_encode_prop