nptools-0.6.0: lmaptool.hs
{-# 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"