diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. 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/archive.hs b/archive.hs new file mode 100644 --- /dev/null +++ b/archive.hs @@ -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) diff --git a/bufferize.hs b/bufferize.hs new file mode 100644 --- /dev/null +++ b/bufferize.hs @@ -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 diff --git a/color-diff.hs b/color-diff.hs new file mode 100644 --- /dev/null +++ b/color-diff.hs @@ -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) diff --git a/events-to-timelog.hs b/events-to-timelog.hs new file mode 100644 --- /dev/null +++ b/events-to-timelog.hs @@ -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 diff --git a/extract-non-ascii.hs b/extract-non-ascii.hs new file mode 100644 --- /dev/null +++ b/extract-non-ascii.hs @@ -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 diff --git a/git-prompt.hs b/git-prompt.hs new file mode 100644 --- /dev/null +++ b/git-prompt.hs @@ -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] diff --git a/iter-lines.hs b/iter-lines.hs new file mode 100644 --- /dev/null +++ b/iter-lines.hs @@ -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 diff --git a/label.hs b/label.hs new file mode 100644 --- /dev/null +++ b/label.hs @@ -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" diff --git a/loopback.hs b/loopback.hs new file mode 100644 --- /dev/null +++ b/loopback.hs @@ -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++" " + ," "++me++" *"] + +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 + diff --git a/mh-gen-message-id-mapping.hs b/mh-gen-message-id-mapping.hs new file mode 100644 --- /dev/null +++ b/mh-gen-message-id-mapping.hs @@ -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 "") + . 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: " diff --git a/myrev.hs b/myrev.hs new file mode 100644 --- /dev/null +++ b/myrev.hs @@ -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 diff --git a/nptools.cabal b/nptools.cabal new file mode 100644 --- /dev/null +++ b/nptools.cabal @@ -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 +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 diff --git a/pad.hs b/pad.hs new file mode 100644 --- /dev/null +++ b/pad.hs @@ -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 diff --git a/rot.hs b/rot.hs new file mode 100644 --- /dev/null +++ b/rot.hs @@ -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++" ", "", + "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 diff --git a/show-non-ascii.hs b/show-non-ascii.hs new file mode 100644 --- /dev/null +++ b/show-non-ascii.hs @@ -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 diff --git a/show-pollbox.hs b/show-pollbox.hs new file mode 100644 --- /dev/null +++ b/show-pollbox.hs @@ -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 diff --git a/summ.hs b/summ.hs new file mode 100644 --- /dev/null +++ b/summ.hs @@ -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 diff --git a/tac.hs b/tac.hs new file mode 100644 --- /dev/null +++ b/tac.hs @@ -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" diff --git a/what-I-have-done-today.hs b/what-I-have-done-today.hs new file mode 100644 --- /dev/null +++ b/what-I-have-done-today.hs @@ -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 diff --git a/x-printable.hs b/x-printable.hs new file mode 100644 --- /dev/null +++ b/x-printable.hs @@ -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