From: Duncan Coutts <duncan.coutts@wo...>  20061124 22:08:13

Fri Nov 24 13:59:24 PST 2006 Duncan Coutts <duncan@...> * Add API diff tool Not exactly polished, but here it is. adddir ./tools/apidiff addfile ./tools/apidiff/HiDiff.hs hunk ./tools/apidiff/HiDiff.hs 1 + +module Main where + +import Data.Char as Char hiding (isSymbol) +import Data.List as List (nub, isPrefixOf, sortBy) +import Data.Maybe as Maybe (catMaybes) +import Control.Monad +import System.Environment (getArgs) + +main = do + [original, modified] < getArgs + diff original modified + +diff :: FilePath > FilePath > IO () +diff originalFile modifiedFile = do + original < readFile originalFile + modified < readFile modifiedFile + let (added, removed, changed) = + classify (extractFunctionsFromHi original) + (extractFunctionsFromHi modified) + putStrLn "Functions added:" + mapM_ putStrLn added + [_$_] + when (not $ null removed) + (do putStrLn "Functions removed:" + mapM_ putStrLn removed) + + when (not $ null changed) + (do putStrLn "Functions changed:" + mapM_ putStrLn [ name ++ " changed from\n :: " ++ originalType + ++ "\nto :: " ++ modifiedType +  (name, originalType, modifiedType) < changed ]) + + +classify :: [(String, String)] > [(String, String)] > ([String], [String], [(String, String, String)]) +classify originalFuns modifiedFuns = + ( [ originalName  (originalName, originalType) < added ] + , [ modifiedName  (modifiedName, modifiedType) < removed + , not $ "lvl" `isPrefixOf` modifiedName + , not $ "gtk_" `isPrefixOf` modifiedName ] + , [ (originalName, originalType, modifiedType) +  ((originalName, originalType), (modifiedName, modifiedType)) < changed + , canonicaliseQuantifiedVars originalType + /= canonicaliseQuantifiedVars modifiedType] ) + where (removed, changed, added) = + mergeBy (comparing fst) + (sortBy (comparing fst) originalFuns) + (sortBy (comparing fst) modifiedFuns) + + +canonicaliseQuantifiedVars :: String > String +canonicaliseQuantifiedVars ty = + unwords [ case lookup w varMapping of + Nothing > w + Just w' > w' +  w < words ty ] + where quantifiedVars = [ w  w@(c:_) < words ty, Char.isLower c ] + varMapping = zip (List.nub quantifiedVars) (map (\c > [c]) ['a'..'z']) + + + mergeBy cmp xs ys = (only_in_xs, in_both, only_in_ys) +mergeBy :: (a > b > Ordering) > [a] > [b] > ([a], [(a, b)], [b]) +mergeBy cmp = merge [] [] [] + where merge l m r [] ys = (reverse l, reverse m, reverse (ys++r)) + merge l m r xs [] = (reverse (xs++l), reverse m, reverse r) + merge l m r (x:xs) (y:ys) = [_$_] + case x `cmp` y of + GT > merge l m (y:r) (x:xs) ys + EQ > merge l ((x,y):m) r xs ys + LT > merge (x:l) m r xs (y:ys) + +comparing :: (Ord a) => (b > a) > b > b > Ordering +comparing p x y = compare (p x) (p y) + + + returns a list of function names with their types +extractFunctionsFromHi :: String > [(String, String)] +extractFunctionsFromHi = catMaybes . map (eval . lexer) . init . parse + + +ignore = ["module", "__interface", "__export", "package", "orphans", + ";", "$", "import", ":", "infixr", "infixl", "infix", "("] + +eval :: [String] > Maybe (String, String) +eval (x:_)  x `elem` ignore = Nothing + + +eval ("instance":ls) = Nothing +eval ("type":ls) = Nothing +eval ("data":ls) = Nothing + functions +eval ls@(name:"::":type_) = Just (name, respace (filterBraces type_)) +eval xs = Nothing + +filterBraces ("{":"}":xs) = filterBraces xs +filterBraces (x:xs) = x : filterBraces xs +filterBraces [] = [] + +respace :: [String] > String +respace x = f (filter (/= ";") x) + where + f [] = "" + f [x] = x + f (x1:x2:xs) = if shouldspace x1 x2 + then x1 ++ " " ++ f (x2:xs) + else x1 ++ f (x2:xs) + +lBrack = "({[" +rBrack = ")}]" + +isRight [x] = x `elem` rBrack +isRight _ = False + +isLeft [x] = x `elem` lBrack +isLeft _ = False + + +shouldspace l r = not $ + isRight r  isLeft l  r == "," + + +splitTerms :: [String] > [[String]] +splitTerms xs@(x:_)  isLeft x = left : splitTerms (drop (length left) xs) + where + left = readBrack 0 xs + [_$_] + readBrack 1 (x:xs)  isRight x = [x] + readBrack n (x:xs)  isRight x = x : readBrack (n1) xs +  isLeft x = x : readBrack (n+1) xs +  otherwise = x : readBrack n xs + +splitTerms (x:xs) = [x] : splitTerms xs +splitTerms [] = [] + [_$_] + [_$_] + +splitOn :: Eq a => a > [a] > [[a]] +splitOn x [] = [] +splitOn x as = takeWhile (/= x) as : splitOn x (safeTail (dropWhile (/= x) as)) + + +safeTail (x:xs) = xs +safeTail [] = [] + + + +parse :: String > [String] +parse xs = rejoin (lines xs) + where + rejoin (x1:x2@(x2h:x2t):xs)  isSpace x2h = rejoin ((x1 ++ " " ++ dropWhile isSpace x2) : xs) + rejoin (x:xs) = x : rejoin xs + rejoin [] = [] + + +lexer :: String > [String] +lexer = demodule . lexRaw + +demodule :: [String] > [String] +demodule ("(":".":xs) = "(":".": demodule xs +demodule (x:".":xs) = demodule xs +demodule (x:xs) = x : demodule xs +demodule [] = [] + + + Chunks taken from NHC's lexer, with modifications +lexRaw :: String > [String] + +lexRaw "" = [] +lexRaw (x:xs)  isSpace x = lexRaw xs + +lexRaw (x:xs)  x == '\''  x == '\"' = f [x] xs + where + f done [] = [reverse done] + f done ('\\':x:xs) = f (x:'\\':done) xs + f done (a:xs)  a == x = reverse (a:done) : lexRaw xs +  otherwise = f (a:done) xs + +lexRaw ('{':'':x) = f x + where + f ('':'}':x) = lexRaw x + f (x:xs) = f xs + f [] = [] + [_$_] +lexRaw ('[':']':xs) = "[]" : lexRaw xs +lexRaw ('(':')':xs) = "()" : lexRaw xs + +lexRaw ('(':x:xs)  isSymbol x && b == ')' = a : lexRaw bs + where (a, b:bs) = span isSymbol (x:xs) + +lexRaw (x:xs)  x `elem` ",;()[]{}`" = [x] : lexRaw xs +  isDigit x = lexRaw xs  drop digits, not needed  continue isDigit +  isSymbol x = continue isSymbol +  isIdFirst x = continue isIdAny + where + isIdFirst c = isAlpha c  c == '_' + isIdAny c = isAlphaNum c  c `elem` "_'#" + [_$_] + continue f = a : lexRaw b + where (a, b) = span f (x:xs) + +isSymbol c = c `elem` "!@#$%&*+./<=>?\\^:~" + +{ + +lex (c:s)  isSingle c = [([c],s)] +  isSym c = [(c:sym,t)  (sym,t) < [span isSym s]] +  isIdInit c = [(c:nam,t)  (nam,t) < [span isIdChar s]] +  isDigit c = [(c:ds++fe,t)  (ds,s) < [span isDigit s], + (fe,t) < lexFracExp s ] +  otherwise = []  bad character + + where + isSingle c = c `elem` ",;()[]{}`" + isSym c = c `elem` "!@#$%&*+./<=>?\\^:~" + isIdInit c = [_$_] + isIdChar c = isAlphaNum c  c `elem` "_'" + + lexFracExp ('.':c:s)  isDigit c + = [('.':ds++e,u)  (ds,t) < lexDigits (c:s), + (e,u) < lexExp t ] + lexFracExp s = lexExp s + + lexExp (e:s)  e `elem` "eE" + = [(e:c:ds,u)  (c:t) < [s], c `elem` "+", + (ds,u) < lexDigits t] ++ + [(e:ds,t)  (ds,t) < lexDigits s] + lexExp s = [("",s)] [_$_] + + + +lexRaw "" = [] +lexRaw (' ':x) = lexRaw x +lexRaw (';':x) = lexRaw x + + to make up for Hugs being wrong +lexRaw ('_':x) = lexRaw x + +lexRaw ('{':'':x) = f x + where + f ('':'}':x) = lexRaw x + f (x:xs) = f xs + f [] = [] + +lexRaw x = a : lexRaw b + where [(a, b)] = lex x +} addfile ./tools/apidiff/ghcpkgapidump.sh hunk ./tools/apidiff/ghcpkgapidump.sh 1 +#/bin/bash + +# tool for comparing the exported API of different version of the same GHC +# library package. It reports type changes and removals but not additions as +# thoses are what is important from an API compatability point of view. + +# $ ./ghcpkgapidump.sh gtk0.9.10 gtk0.9.10.2 > apichanges + +# You can override the version of GHC using: + +# $ GHC=ghc6.4.2 GHCPKG=ghcpkg6.4.2 ./ghcpkgapidump.sh ... etc + +GHC=${GHC:ghc} +GHCPKG=${GHCPKG:ghcpkg} + +originalexposedmodules=$($GHCPKG field $1 exposedmodules  sed 's/exposedmodules://';) +originalimportdirs=$($GHCPKG field $1 importdirs  sed 's/importdirs://';) + +modifiedimportdirs=$($GHCPKG field $2 importdirs  sed 's/importdirs://';) + +for pkg in ${originalexposedmodules}; do + originalhifile=${originalimportdirs}/${pkg//./\/}.hi + modifiedhifile=${modifiedimportdirs}/${pkg//./\/}.hi + + if test f ${modifiedhifile}; then + echo "dumping ${pkg}..." > /dev/stderr + ./hidiff <($GHC showiface ${originalhifile}) \ + <($GHC showiface ${modifiedhifile}) + else + echo "${pkg} missing from $2 (can't find ${modifiedhifile})" + fi +done 