diff --git a/bufferize.hs b/bufferize.hs deleted file mode 100644 --- a/bufferize.hs +++ /dev/null @@ -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 ]* * -- *" - ,"" - ,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 diff --git a/color-diff.hs b/color-diff.hs deleted file mode 100644 --- a/color-diff.hs +++ /dev/null @@ -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) diff --git a/deliver-to-pollbox.hs b/deliver-to-pollbox.hs deleted file mode 100644 --- a/deliver-to-pollbox.hs +++ /dev/null @@ -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 diff --git a/drop-non-ascii.hs b/drop-non-ascii.hs new file mode 100644 --- /dev/null +++ b/drop-non-ascii.hs @@ -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 diff --git a/git-prompt.hs b/git-prompt.hs --- a/git-prompt.hs +++ b/git-prompt.hs @@ -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 diff --git a/label.hs b/label.hs --- a/label.hs +++ b/label.hs @@ -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)) diff --git a/lmaptool.hs b/lmaptool.hs new file mode 100644 --- /dev/null +++ b/lmaptool.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE PatternGuards, OverloadedStrings #-} +-------------------------------------------------------------------- +-- | +-- Program : lmaptool +-- Copyright : (c) Nicolas Pouillard 2008, 2009 +-- License : BSD3 +-- +-- Maintainer : Nicolas Pouillard +-- 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 \n\ + \ # Shows a detailed list of differences between the given files\n\n\ + + \labels *\n\ + \ # Lists the set of labels in the given files\n\n\ + + \merge {union|left|right} *\n\ + \ # Merges the given files according the merging style\n\n\ + + \ordered \n\ + \ # Are the given two files ordered? (no lost entries)\n\n\ + + \grep [-v]