nptools 0.5.0 → 0.6.0

raw patch · 9 files changed

+307/−149 lines, 9 filesdep +containersdep −MissingHdep −SHAdep −directorynew-component:exe:drop-non-asciinew-component:exe:lmaptool

Dependencies added: containers

Dependencies removed: MissingH, SHA, directory, filepath

Files

• bufferize.hs +0/−29
• color-diff.hs +0/−14
• deliver-to-pollbox.hs +0/−28
• drop-non-ascii.hs +13/−0
• git-prompt.hs +19/−15
• label.hs +3/−6
• lmaptool.hs +256/−0
• nptools.cabal +16/−26
• show-pollbox.hs +0/−31

@@ -1,29 +0,0 @@-import System.Environment (getArgs)-import Control.Arrow-import Control.Monad-import qualified Data.ByteString as B--usage :: String -> a-usage msg =-  error . unlines $-    [""-    ,"Usage: bufferize [-o <outfile>]* <infile>* -- <infile>*"-    ,""-    ,msg]--argv :: [String] -> ([String],[String])-argv ("-o":out:xs)  = first (out:) (argv xs)-argv ("-o":[])      = usage "filename expected after -o"-argv ("--":xs)      = ([], xs)-argv (('-':x):_)    = usage $ "Unpected option -" ++ x-argv (x:xs)         = second (x:) (argv xs)-argv []             = ([],[])--main :: IO ()-main = do args  <- getArgs-          let (outputs,inputs) = argv args-              write s = do-                when (null outputs) $ B.putStr s-                forM_ outputs       $ flip B.writeFile s-          when (null inputs)  $ write =<< B.getContents-          forM_ inputs        $ write <=< B.readFile

@@ -1,14 +0,0 @@-import System.IO--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 = hSetEncoding stdin latin1 >>-       hSetEncoding stdout latin1 >>-       interact (unlines . map colorDiffLine . lines)

@@ -1,28 +0,0 @@-import qualified Data.ByteString.Lazy.Char8 as L8-import Data.Char-import Data.Maybe-import Data.List-import System.Environment-import System.FilePath-import System.IO-import System.Directory--selectDestDir :: L8.ByteString -> FilePath-selectDestDir =-  fromMaybe "no-destdir-header"-    . fmap (L8.unpack . L8.drop (L8.length xdestdir))-    . find (xdestdir `L8.isPrefixOf`)-    . map (L8.map toLower) . L8.lines-  where-    xdestdir = L8.pack "x-destdir: "--main :: IO ()-main = do [arg] <- getArgs-          input <- L8.getContents-          let dir = arg </> selectDestDir input-          createDirectoryIfMissing True dir-          (_,h) <- openTempFile dir "file.log"-          L8.hPut h input-          hClose h---- vim: ft=haskell

@@ -0,0 +1,13 @@+import Data.Char+import System.IO+import System.Environment++processChar :: Char -> Char+processChar c | isAscii c = c+              | otherwise = '?'++main :: IO ()+main = do putStrLn "Reading from stdin"+          args <- getArgs+          hSetEncoding stdin (if "--latin1" `elem` args then latin1 else utf8)+          interact . map $ processChar

@@ -2,6 +2,7 @@ import System.Console.ANSI import System.Environment import System.Exit+import System.IO.Error (catchIOError) import HSH import Control.Monad import Control.Applicative@@ -55,24 +56,31 @@ statsInfo :: Colors -> IO String statsInfo Colors{..} = do   gitstat <-  fmap lines . run $ "git status 2> /dev/null"-         -|-  egrep "(# Untracked|# Changes|# Changed but not updated:|# Your branch|# and have)"-  let f msg   = listToMaybe . map digits $ egrep msg gitstat+         -|-  egrep "(# On branch|# Untracked|# Changes|# Your branch|# and have)"+  let f msg   = listToMaybe . map digits . egrep msg $ gitstat+      g msg   = fmap words . listToMaybe . egrep msg $ gitstat       ahead   = f "# Your branch is ahead of "       behind  = f "# Your branch is behind "-      diverged = parseDiverged =<< (fmap words . listToMaybe . egrep "# and have" $ gitstat)+      diverged = parseDiverged =<< g "# and have"+      branch = fromMaybe (red ++ "ERR") (parseOnBranch =<< g "# On branch")   return . concat $-    [green-    ,['!' | "# Changes to be committed:"  `elem` gitstat]-    ,['?' | "# Untracked files:"          `elem` gitstat-         || "# Changed but not updated:"  `elem` gitstat]+    ["±"+    ,blue,":"+    ,branch+    ,green+    ,['!' | "# Changes to be committed:"        `elem` gitstat]+    ,['?' | "# Untracked files:"                `elem` gitstat+         || "# Changes not staged for commit:"  `elem` gitstat]     ,maybe "" ((blue++":"++green++"-")++) behind     ,maybe "" ((blue++":"++green++"+")++) ahead     ,maybe "" (\(x,y) -> blue++":"++red++"+"++x++"-"++y) diverged-    ]+    ,noColor]   where     digits  = reverse . takeWhile isDigit . dropWhile (not . isDigit) . reverse     parseDiverged ["#", "and", "have", x, "and", y, "different", "commit(s)", "each,", "respectively."] = Just (x, y)-    parseDiverged _ = trace "git-prompt: git status message seems to have changed" Nothing+    parseDiverged _ = trace "git-prompt: git status message seems to have changed (diverged branches)" Nothing+    parseOnBranch ["#", "On", "branch", x] = Just (magenta ++ x)+    parseOnBranch _ = Nothing  isBareRepo :: IO Bool isBareRepo = readbool =<< run "git config core.bare"@@ -93,11 +101,7 @@         | "--zsh-no-length" `elem` args = mapColors noLength colors         | otherwise = colors       Colors{..} = myColors-  stats <- catch (statsInfo myColors) . const $+  stats <- catchIOError (statsInfo myColors) . const $              ((blue++":")++) . cond (green ++ "bare") (red ++ "ERR")                <$> isBareRepo-  putStrLn . concat $-    ["±"-    ,blue,":",magenta,drop (length "refs/heads/") ref-    ,stats-    ,noColor]+  putStrLn stats

@@ -9,16 +9,13 @@ -- import Data.Time.Calendar import Data.Either import Data.List-import Data.List.Split (chunk)+import Data.List.Split (chunksOf) 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@@ -71,7 +68,7 @@       <$> C.readFile message_ids       where         err = C.unpack msgID ++ " not found"-        msgID' = '<' `C.cons` msgID `C.snoc` '>'+        msgID' = '<' `C.cons` (msgID `C.snoc` '>')  pathFromMsg :: FilePath -> Msg -> IO (Either String FilePath) pathFromMsg _ (MsgPath path)          = return . return $ path@@ -85,7 +82,7 @@ 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+  (errs, pathss)  <- second (chunksOf 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))

@@ -0,0 +1,256 @@+{-# LANGUAGE PatternGuards, OverloadedStrings #-}+--------------------------------------------------------------------+-- |+-- Program    : lmaptool+-- Copyright  : (c) Nicolas Pouillard 2008, 2009+-- License    : BSD3+--+-- Maintainer : Nicolas Pouillard <nicolas.pouillard@gmail.com>+-- Stability  : provisional+-- Portability:+--+--------------------------------------------------------------------++import Control.Arrow+import Control.Applicative+import Control.Monad (ap, join)+import System.Environment+import System.IO (hPutStrLn, stderr)+import System.Exit (exitFailure)+import Data.List+import Data.ByteString.Lazy (ByteString)+import Data.Ord (comparing)+import qualified Data.ByteString.Lazy.Char8 as C+import qualified Data.Set as Set+import qualified Data.Map as Map+import Data.Map (Map)++-- General purpose functions++-- spec :: forall xs. prolongate xs == xs ++ repeat (last xs)+prolongate :: [a] -> [a]+prolongate [] = error "prolongate: empty list"+prolongate ys = foldr f [] ys+  where f x [] = repeat x+        f x xs = x : xs++sortedBy :: Ord b => (a -> b) -> (b -> b -> String) -> [a] -> [a]+sortedBy by err = map (fst . ordered) . (zip`ap`(tail . prolongate))+  where ordered xy@(x, y) | by x <= by y = xy+                          | otherwise    = error (err (by x) (by y))++both :: Arrow a => a b c -> a (b, b) (c, c)+both f = f *** f++rank :: Ord a => [a] -> [(a, Int)]+rank = sort >>> group >>> map (head &&& length) >>> sortBy (flip (comparing snd))++-- Entry, DiffEntry, and related functions.++type EntryID = ByteString+type Label = ByteString+type Entry = (EntryID, [Label])+type DiffEntry = (EntryID, ([Label], [Label]))+type EntryMap = Map EntryID [Label]++sortedEntries :: [Entry] -> [Entry]+sortedEntries = sortedBy fst err . sortBy (comparing fst)+  where err x y = unlines+           ["invalid msgid->labels mapping: the input should be sorted (use the unix sort)",+            C.unpack $ x, "should be less than", C.unpack $ y]++parseEntries :: ByteString -> [Entry]+parseEntries = map (second (C.words . C.takeWhile (/=')') . C.dropWhile (=='(') . C.tail)+                  . C.break (==' ')) . C.lines++-- mergeByWith by with xs ys+-- merge to sorted list xs and ys that are sorted according to the 'by'+-- function. When a clash occurs the 'with' function is used to determine+-- the result.+mergeByWith :: Ord b => (a -> b) -> (a -> a -> a) -> [a] -> [a] -> [a]+mergeByWith _ _ [] xs = xs+mergeByWith _ _ xs [] = xs+mergeByWith by with (x:xs) (y:ys) = case compare (by x) (by y) of+  LT -> x : mergeByWith by with xs (y:ys)+  GT -> y : mergeByWith by with (x:xs) ys+  EQ -> with x y : mergeByWith by with xs ys++mergeEntry :: String -> Entry -> Entry -> Entry+mergeEntry "union" (x, xs) (_, ys) = (x, xs `union` ys)+mergeEntry "left"  x       _       = x+mergeEntry "right" _       x       = x+mergeEntry s       _       _       = error $ "unexpected entry style: " ++ show s++showEntry :: Entry -> ByteString+showEntry (m, ls) = C.concat [m, " (", C.unwords ls, ")"]++printEntries :: [Entry] -> IO ()+printEntries = mapM_ (C.putStrLn . showEntry)++--showTags :: Char -> [ByteString] -> ByteString+--showTags c = C.unwords . map (c`C.cons`)++showEntryChange :: (Entry, Entry) -> ByteString+showEntryChange ((m, ls), (_, ls')) =+ -- C.concat [m, " (", C.unwords ls, " -> ", C.unwords ls', ")"]+    C.concat [C.unwords pls, " -- id:", m]+    where pls = polarizeLabels [(ls, ls')]+{-+    C.concat [showTags '+' added, showTags '-' removed, " -- id:", m]+  where added   = Set.difference s' s+        removed = Set.difference s  s'+        s       = Set.fromList ls+        s'      = Set.fromList ls'+-}++showEntryChangeStat :: (Label, Int) -> ByteString+showEntryChangeStat (s, count) = C.concat [C.pack $ show count, " times ", s]++readFiles :: [String] -> IO [C.ByteString]+readFiles [] = (:[]) <$> C.getContents+readFiles xs = if length (filter (=="-") xs) <= 1+               then mapM readFile' xs+               else error "Only one file can be the standard input (i.e. '-')"+      where readFile' "-" = C.getContents+            readFile' s   = C.readFile s++readSortedEntriesFiles :: [FilePath] -> IO [[Entry]]+readSortedEntriesFiles+  = fmap (map (map (second sort) . sortedEntries . parseEntries)) . readFiles++readDiffEntriesFiles :: [FilePath] -> IO [[DiffEntry]]+readDiffEntriesFiles+  = (fmap . fmap) (fmap entryToDiffEntry . parseEntries) . readFiles++entryToDiffEntry :: Entry -> DiffEntry+entryToDiffEntry = second (second (drop 1) . break (=="->"))++applyDiffEntries :: [DiffEntry] -> [Entry] -> [Entry]+applyDiffEntries diffEntries+  = Map.toList . flip (foldl (flip applyDiffEntry)) diffEntries . Map.fromList++applyDiffEntry :: DiffEntry -> EntryMap -> EntryMap+applyDiffEntry (ident, (_old, new)) = Map.insert ident new++data Diff a = Add a+            | Remove a+            | Change a a -- ^ Old value, then new value++-- ! diffSortedBy compare oldList newList+diffSortedBy :: Eq a => (a -> a -> Ordering) -> [a] -> [a] -> [Diff a]+diffSortedBy _ [] ys = map Remove ys+diffSortedBy _ xs [] = map Add xs+diffSortedBy cmp (x:xs) (y:ys) = case cmp x y of+  LT             -> Remove x : diffSortedBy cmp xs (y:ys)+  GT             -> Add y : diffSortedBy cmp (x:xs) ys+  EQ | x == y    -> diffSortedBy cmp xs ys+     | otherwise -> Change x y : diffSortedBy cmp xs ys++-- ! diffLab (old, new) = (added, removed)+diffLab :: Ord a => ([a], [a]) -> ([a], [a])+diffLab oldnew = both Set.toList (added, removed)+  where (old, new) = both Set.fromList oldnew+        added      = new `Set.difference` old+        removed    = old `Set.difference` new++{-+prop_diffSortedBy cmp xs ys = regen $ diffSortedBy cmp xs ys == (xs, ys)+  where regen (Remove x : ds)   = first (x:) . regen ds+        regen (Add x : ds)      = second (x:) . regen ds+        regen (Change x y : ds) = ((x:) *** (y:)) . regen ds+-}++partitionDiffs :: [Diff a] -> ([a], [a], [(a,a)])+partitionDiffs = go [] [] []+  where go a r c []              = (a,r,c)+        go a r c (Add x:xs)      = go (x:a) r c xs+        go a r c (Remove x:xs)   = go a (x:r) c xs+        go a r c (Change x y:xs) = go a r ((x,y):c) xs++polarizeLabels :: [([Label], [Label])] -> [Label]+polarizeLabels =+  map diffLab                           >>> -- [([Label], [Label])]+  unzip                                 >>> -- ([[Label]], [[Label]])+  both join                             >>> -- ([Label], [Label])+  map (C.cons '+') *** map (C.cons '-') >>> -- ...+  uncurry (++)                              -- [Label]++collectLabelStats :: [(Entry, Entry)] -> [(Label, Int)]+collectLabelStats = map (both snd) >>> polarizeLabels >>> rank++diffCommand :: FilePath -> FilePath -> IO ()+diffCommand arg1' arg2' = do+  [arg1,arg2] <- readSortedEntriesFiles [arg1', arg2']+  let diff = diffSortedBy (comparing fst) arg1 arg2+  if null diff+    then putStrLn "OK given files are equal"+    else do let (new, losts, changed) = partitionDiffs diff+            C.putStrLn "### New entries ###"+            printEntries new+            C.putStrLn "### Lost entries ###"+            printEntries losts+            C.putStrLn "### Changed entries ###"+            mapM_ (C.putStrLn . showEntryChange) changed+            C.putStrLn "### Label Stats ###"+            mapM_ (C.putStrLn . showEntryChangeStat) $ collectLabelStats changed+            C.putStrLn "### Stats ###"+            putStrLn $ "New: " ++ show (length new)+            putStrLn $ "Lost: " ++ show (length losts)+            putStrLn $ "Changed: " ++ show (length changed)+            exitFailure++main :: IO ()+main = do+  args <- getArgs+  case args of+    ("labels":args') ->+        mapM_ C.putStrLn =<<+          (sort . foldr1 union . map snd . concatMap parseEntries) <$>+             readFiles args'+    ("merge":style:args') | style `elem` ["union", "left", "right"] ->+        printEntries =<< foldr1 (mergeByWith fst (mergeEntry style)) <$>+          readSortedEntriesFiles args'+    ["diff",arg1,arg2] ->+        diffCommand arg1 arg2+    ["ordered",arg1',arg2'] -> do+        [arg1,arg2] <- readSortedEntriesFiles [arg1', arg2']+        let diff = diffSortedBy (comparing fst) arg1 arg2+            lost = [ x | Remove x <- diff ]+        if null lost+          then putStrLn "OK given files are ordered"+          else do hPutStrLn stderr "Given files are not ordered, here are the lost entries:"+                  printEntries lost+                  exitFailure+    ("grep":args') | (label:args'') <- delete "-v" args' ->+        let invert = if "-v" `elem` args' then not else id in+        mapM_ C.putStrLn =<<+          (map fst . filter (invert . (C.pack label `elem`) . snd) . concatMap parseEntries) <$>+             readFiles args''+    ["patch",patchfile,entriesfile] -> do+        [patch]   <- readDiffEntriesFiles [patchfile]+        [entries] <- readSortedEntriesFiles [entriesfile]+        printEntries $ applyDiffEntries patch entries+    _ -> hPutStrLn stderr usageText >> fail "invalid arguments"++usageText :: String+usageText =+  "diff <file1> <file2>\n\+  \  # Shows a detailed list of differences between the given files\n\n\++  \labels <files>*\n\+  \  # Lists the set of labels in the given files\n\n\++  \merge {union|left|right} <files>*\n\+  \  # Merges the given files according the merging style\n\n\++  \ordered <file1> <file2>\n\+  \  # Are the given two files ordered? (no lost entries)\n\n\++  \grep [-v] <label> <files>*\n\+  \  # Shows only entries which contains the given label\n\n\++  \patch <patchfile> <file>\n\+  \  # Apply the given patch file to the given file of entries\n\+  \  # Patch formats is lines of the form:\n\+  \  # MSGID ( old labels -> new ones )\n"+

@@ -1,6 +1,6 @@ Name:           nptools Cabal-Version:  >=1.4-Version:        0.5.0+Version:        0.6.0 License:        BSD3 License-File:   LICENSE Copyright:      (c) Nicolas Pouillard@@ -15,12 +15,7 @@ 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+    ghc-options: -Wall  executable events-to-timelog     main-is: events-to-timelog.hs@@ -42,11 +37,6 @@     Build-depends: base>=3&&<5, HSH, split, process, bytestring     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@@ -57,19 +47,14 @@ --     Build-depends: base>=3&&<5 --     ghc-options: -Wall -Odph -executable show-non-ascii-    main-is: show-non-ascii.hs+executable drop-non-ascii+    main-is: drop-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, MissingH-    ghc-options: -Wall -Odph--executable deliver-to-pollbox-    main-is: deliver-to-pollbox.hs-    Build-depends: base>=3&&<5, filepath, bytestring, directory+executable show-non-ascii+    main-is: show-non-ascii.hs+    Build-depends: base>=3&&<5     ghc-options: -Wall -Odph  executable summ@@ -119,7 +104,7 @@ executable timer     main-is: timer.hs     Build-depends: unix<3-    ghc-options: -Wall -Odph+    ghc-options: -Wall  executable nest     main-is: nest.hs@@ -127,14 +112,19 @@  executable getpin     main-is: getpin.hs-    ghc-options: -Wall -Odph+    ghc-options: -Wall  executable starecho     main-is: starecho.hs-    ghc-options: -Wall -Odph+    ghc-options: -Wall  executable color-list     main-is: color-list.hs     Build-depends: base>=3&&<5, colour, array     Other-Modules: Data.List.NP-    ghc-options: -Wall -Odph+    ghc-options: -Wall++executable lmaptool+    main-is: lmaptool.hs+    build-depends: containers+    ghc-options: -O2 -Wall

@@ -1,31 +0,0 @@-#!/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.Path.Glob (glob)-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 =<< glob (dir </> "*")--main :: IO ()-main = do [arg] <- getArgs-          dirs <- sort <$> glob (arg </> "*/")-          print . sha1 . L.pack . show $ dirs-          mapM_ onDir dirs