{-# 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]