hackage-diff (empty) → 0.1.0.0
raw patch · 4 files changed
+749/−0 lines, 4 filesdep +Cabaldep +HTTPdep +ansi-terminalsetup-changed
Dependencies added: Cabal, HTTP, ansi-terminal, async, attoparsec, base, cpphs, directory, filepath, haskell-src-exts, mtl, process, text
Files
- LICENSE +11/−0
- Main.hs +635/−0
- Setup.hs +2/−0
- hackage-diff.cabal +101/−0
+ LICENSE view
@@ -0,0 +1,11 @@+++Copyright (C) 2014 Tim C. Schroeder+++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.+
+ Main.hs view
@@ -0,0 +1,635 @@++{-# LANGUAGE LambdaCase+ , ScopedTypeVariables+ , OverloadedStrings+ , RecordWildCards #-}++module Main (main) where++import System.Exit+import System.Directory+import System.Environment+import System.FilePath+import System.Process+import System.Console.GetOpt+import System.Console.ANSI+import Control.Monad+import Control.Monad.Except+import Control.Monad.State+import Control.Applicative+import Control.Exception+import Control.Concurrent.Async+import Data.Function+import Data.List+import Data.Either+import Data.Char+import qualified Data.Text as T+import qualified Data.Text.IO as TI+import Data.Attoparsec.Text hiding (try)+import Text.Printf+import Distribution.PackageDescription+import Distribution.PackageDescription.Parse+import Distribution.Verbosity (normal)+import Distribution.Simple.Utils (findPackageDesc)+import Distribution.ModuleName (toFilePath, components)+import Language.Haskell.Exts as E+import Language.Preprocessor.Cpphs+import Network.HTTP++main :: IO ()+main = do+ -- Process command line arguments+ (pkgName, argVerA, argVerB, flags) <-+ runExcept <$> (getCmdOpt <$> getProgName <*> getArgs) >>= either die return+ when (argVerA == argVerB) $+ die "Need to specify different versions / packages for comparison"+ mode <- case foldr (\f r -> case f of FlagMode m -> m; _ -> r) "downloaddb" flags of+ "downloaddb" -> return ModeDownloadDB+ "builddb" -> return ModeBuildDB+ "parsehs" -> return ModeParseHS+ m -> die $ printf "'%s' is not a valid mode" m+ let disableColor = FlagDisableColor `elem` flags+ silentFlag = FlagSilent `elem` flags+ -- Did we get a package version, DB path or package path?+ ([verA, verB] :: [EitherVerPath]) <- forM [argVerA, argVerB] $ \ver ->+ case parseOnly pkgVerParser (T.pack ver) of+ -- Not a version, check if we got a valid DB file or package path+ Left _ | mode == ModeParseHS -> do+ flip unless (die $ errHdr ++ " or package path" ) =<< doesDirectoryExist ver+ return $ Right ver+ | otherwise -> do+ flip unless (die $ errHdr ++ " or database path") =<< doesFileExist ver+ return $ Right ver+ where errHdr = "'" ++ ver ++ "' is not a valid version string (1.0[.0[.0]])"+ -- Looks like a valid version string+ Right _ -> return $ Left ver+ diff <- withTmpDirectory $ \tmpDir -> do+ -- Need to download packages?+ when (mode `elem` [ModeBuildDB, ModeParseHS]) $+ forM_ (lefts [verA, verB]) $ \verString -> do+ let pkg = pkgName ++ "-" ++ verString+ unless silentFlag . putStrLn $ "Downloading " ++ pkg ++ "..."+ runExceptT (downloadPackage pkg tmpDir) >>= either die return+ -- Parse, compute difference+ either die return =<<+ ( runExceptT $+ let cp = ComputeParams tmpDir pkgName verA verB silentFlag+ in case mode of+ ModeDownloadDB -> computeDiffDownloadHoogleDB cp+ ModeBuildDB -> computeDiffBuildHoogleDB cp+ ModeParseHS -> computeDiffParseHaskell cp+ )+ -- Output results+ unless silentFlag $ printf "\n--- Diff for | %s → %s | ---\n\n"+ (either id id verA)+ (either id id verB)+ outputDiff diff disableColor silentFlag+ where die :: String -> IO a+ die str = putStrLn str >> exitFailure++data FlagMode = ModeDownloadDB | ModeBuildDB | ModeParseHS+ deriving (Eq)++data CmdFlag = FlagDisableColor | FlagSilent | FlagMode String+ deriving (Eq)++getCmdOpt :: String -> [String] -> Except String (String, String, String, [CmdFlag])+getCmdOpt prgName args =+ case getOpt RequireOrder opt args of+ (flags, (pkgName:verA:verB:[]), []) -> return (pkgName, verA, verB, flags)+ (_, _, []) -> throwError usage+ (_, _, err) -> throwError (concat err ++ "\n" ++ usage)+ where+ header =+ "hackage-diff | Compare the public API of different versions of a Hackage library\n" +++ "github.com/blitzcode/hackage-diff | www.blitzcode.net | (C) 2014 Tim C. Schroeder\n\n" +++ "Usage: " ++ prgName ++ " [options] <package-name> <old-version|path> <new-version|path>"+ footer =+ "\nExamples:\n" +++ " " ++ prgName ++ " mtl 2.1 2.2.1\n" +++ " " ++ prgName ++ " --mode=builddb JuicyPixels 3.1.4.1 3.1.5.2\n" +++ " " ++ prgName ++ " conduit 1.1.5 ~/tmp/conduit-1.1.6/dist/doc/html/conduit/conduit.txt\n" +++ " " ++ prgName ++ " --mode=parsehs QuickCheck 2.6 2.7.6\n" +++ " " ++ prgName ++ " --mode=parsehs -s Cabal ~/tmp/Cabal-1.18.0/ 1.20.0.0\n"+ usage = usageInfo header opt ++ footer+ opt = [ Option []+ ["mode"]+ (ReqArg FlagMode "[downloaddb|builddb|parsehs]")+ ( "what to download / read, how to compare\n" +++ " downloaddb - download Hoogle DBs and diff (Default)\n" +++ " builddb - download packages, build Hoogle DBs and diff\n" +++ " parsehs - download packages, directly diff .hs exports"+ )+ , Option ['c']+ ["disable-color"]+ (NoArg FlagDisableColor)+ "disable color output"+ , Option ['s']+ ["silent"]+ (NoArg FlagSilent)+ "disable progress output"+ ]++-- Check a package version string (1.0[.0[.0]])+pkgVerParser :: Parser ()+pkgVerParser = (nDigits 4 <|> nDigits 3 <|> nDigits 2) *> endOfInput+ where digitInt = void (decimal :: Parser Int)+ nDigits n = count (n - 1) (digitInt *> char '.') *> digitInt++-- Create and clean up temporary working directory+withTmpDirectory :: (FilePath -> IO a) -> IO a+withTmpDirectory = bracket+ ( do sysTmpDir <- getTemporaryDirectory+ let tmpDir = addTrailingPathSeparator $ sysTmpDir </> "hackage-diff"+ createDirectoryIfMissing True tmpDir+ return tmpDir+ )+ ( removeDirectoryRecursive )++cabalInstall :: [String] -> ExceptT String IO ()+cabalInstall args = do+ (cabalExit, _, cabalStdErr) <- liftIO $ readProcessWithExitCode "cabal" args []+ unless (cabalExit == ExitSuccess) . throwError $ cabalStdErr++-- Use cabal-install to download a package from hackage+downloadPackage :: String -> FilePath -> ExceptT String IO ()+downloadPackage pkg destination = cabalInstall [ "get", pkg, "--destdir=" ++ destination ]++data ExportCmp = EAdded | ERemoved | EModified String {- Old signature -} | EUnmodified+ deriving (Show, Eq, Ord)++data ModuleCmp = MAdded [String] -- Module was added+ | MAddedParseError -- Like above, but we couldn't parse the new one+ | MRemoved [String] -- Module was removed+ | MRemovedParseError -- Like above, but we couldn't parse the old one+ | MNotSureIfModifiedParseError -- New and/or old didn't parse, can't tell+ | MModified [(ExportCmp, String)] -- Modified+ | MUnmodifed -- Changed+ deriving (Show, Eq, Ord)++type Diff = [(ModuleCmp, String)]++-- Print out the computed difference, optionally with ANSI colors+outputDiff :: Diff -> Bool -> Bool -> IO ()+outputDiff diff disableColor disableLengend = do+ let putStrCol color str+ | disableColor = liftIO $ putStr str+ | otherwise = liftIO . putStr $ setSGRCode [SetColor Foreground Vivid color] +++ str ++ setSGRCode [Reset]+ putStrLnCol color str = liftIO $ putStrCol color str >> putStrLn ""+ breakingChanges <- flip execStateT (0 :: Int) . forM_ diff $ \case+ (MAdded exps , mname) -> do+ putStrLnCol Green $ "+ " ++ mname+ mapM_ (putStrLnCol Green . printf " + %s") exps+ (MAddedParseError , mname) ->+ putStrLnCol Green $+ printf " + %s (ERROR: failed to parse new version, exports not available)" mname+ (MRemoved exps , mname) -> do+ putStrLnCol Red $ "- " ++ mname+ mapM_ (\e -> modify' (+ 1) >> putStrLnCol Red (printf " - %s" e)) exps+ (MRemovedParseError , mname) -> do+ modify' (+ 1)+ putStrLnCol Red $+ " - " ++ mname ++ " (ERROR: failed to parse old version, exports not available)"+ (MNotSureIfModifiedParseError, mname) -> do+ putStrLnCol Yellow $ "× " ++ mname +++ " (Potentially modified, ERROR: failed to parse new and/or old version)"+ (MModified exps , mname) -> do+ putStrLnCol Yellow $ "× " ++ mname+ forM_ exps $ \(cmp, expname) -> case cmp of+ EAdded -> putStrLnCol Green $ " + " ++ expname+ ERemoved -> do modify' (+ 1)+ putStrLnCol Red $ " - " ++ expname+ EModified old -> do modify' (+ 1)+ putStrLnCol Yellow $ " × New: " ++ expname ++ "\n" +++ " Old: " ++ old+ EUnmodified -> return ()+ (MUnmodifed , mname) -> putStrLnCol White $ "· " ++ mname+ unless disableLengend $ do+ putStrLn ""+ putStrCol Green "[+ Added] "+ putStrCol Red "[- Removed] "+ putStrCol Yellow "[× Modified] "+ putStrCol White "[· Unmodified]\n"+ unless (breakingChanges == 0) $+ putStrLnCol Red $ printf "\n%i potential breaking changes found" breakingChanges++-- All the parameters required by the various compute* functions that actually prepare the+-- data and compute the difference+data ComputeParams = ComputeParams { cpTmpDir :: FilePath+ , cpPackage :: String+ , cpVerA :: EitherVerPath+ , cpVerB :: EitherVerPath+ , cpSilentFlag :: Bool+ } deriving (Eq, Show)++-- A package can be specified by a version string, a Hoogle DB file path or a package path+type VersionString = String+type EitherVerPath = Either VersionString FilePath++-- Compute a Diff by comparing the package's Hoogle DB read from disk or downloaded from Hackage+computeDiffDownloadHoogleDB :: ComputeParams -> ExceptT String IO Diff+computeDiffDownloadHoogleDB ComputeParams { .. } = do+ -- Get Hoogle databases+ putS "Downloading / Reading Hoogle DBs..."+ (dbA, dbB) <-+ either (\(e :: IOException) -> throwError $ "DB Error: " ++ show e ++ tip) return =<<+ (liftIO . try $ concurrently (downloadOrRead cpVerA) (downloadOrRead cpVerB))+ -- Parse+ putS "Parsing Hoogle DBs..."+ [parsedDBA, parsedDBB] <- forM [dbA, dbB] $ \db ->+ either throwError return $ parseOnly hoogleDBParser db+ -- Compare+ putS "Comparing Hoogle DBs..."+ return $ diffHoogleDB parsedDBA parsedDBB+ where getHoogleDBURL ver = "http://hackage.haskell.org/package" </> cpPackage ++ "-" ++ ver </>+ "docs" </> cpPackage <.> "txt"+ -- Network.HTTP is kinda crummy, but pulling in http-client/conduit+ -- just for downloading two small text files is probably not worth it+ downloadURL url = T.pack <$> do+ req <- simpleHTTP (getRequest url)+ -- HTTP will throw an IOException for any connection error,+ -- also examine the response code and throw one for every+ -- non-200 one we get+ code <- getResponseCode req+ unless (code == (2, 0, 0)) . throwIO . userError $+ "Status code " ++ show code ++ " for request " ++ url+ getResponseBody req+ tip = "\nYou can try building missing Hoogle DBs yourself by running with --mode=builddb"+ putS = unless cpSilentFlag . liftIO . putStrLn+ downloadOrRead = either (downloadURL . getHoogleDBURL) (TI.readFile)++-- Compute a Diff by comparing the package's Hoogle DB build through Haddock. Unfortunately,+-- running Haddock requires to have the package configured with all dependencies+-- installed. This can often be very slow and frequently fails for older packages, on top+-- of any Haddock failures that might happen+computeDiffBuildHoogleDB :: ComputeParams -> ExceptT String IO Diff+computeDiffBuildHoogleDB ComputeParams { .. } =+ flip catchError (\e -> throwError $ e ++ tip) $ do+ forM_ (lefts [cpVerA, cpVerB]) $ \ver -> do -- Only build if we don't have a DB file path+ let pkg = cpPackage ++ "-" ++ ver+ putS $ "Processing " ++ pkg ++ "..."+ -- TODO: This is rather ugly. Cabal does not allow us to specify the target+ -- directory, and the current directory is not a per-thread property.+ -- While createProcess allows the specification of a working directory, our+ -- preferred wrapper readProcessWithExitCode does not expose that.+ -- Duplicating that function and its web of private helpers here would be+ -- quite some overhead. For now we simply change the working directory of+ -- the process+ --+ -- https://ghc.haskell.org/trac/ghc/ticket/9322#ticket+ --+ liftIO . setCurrentDirectory $ cpTmpDir </> pkg+ -- All the steps required to get the Hoogle DB+ putS " Creating Sandbox" >> cabalInstall [ "sandbox", "init" ]+ putS " Installing Dependencies" >> cabalInstall [ "install"+ , "--dependencies-only"+ -- Try building as fast as+ -- possible+ , "-j"+ , "--disable-optimization"+ , "--ghc-option=-O0"+ , "--disable-library-for-ghci"+ ]+ putS " Configuring" >> cabalInstall [ "configure" ]+ putS " Building Haddock" >> cabalInstall [ "haddock", "--hoogle" ]+ -- Read DBs from disk+ [dbA, dbB] <-+ forM [cpVerA, cpVerB] $ \ver ->+ (liftIO . try . TI.readFile $ either getHoogleDBPath id ver)+ >>= either (\(e :: IOException) -> throwError $ show e) return+ -- Parse+ [parsedDBA, parsedDBB] <- forM [dbA, dbB] $ \db ->+ either throwError return $ parseOnly hoogleDBParser db+ -- Compare+ return $ diffHoogleDB parsedDBA parsedDBB+ where+ putS = unless cpSilentFlag . liftIO . putStrLn+ getHoogleDBPath ver = cpTmpDir </> cpPackage ++ "-" ++ ver </> "dist/doc/html" </>+ cpPackage </> cpPackage <.> "txt"+ tip = "\nIf downloading / building Hoogle DBs fails, you can try directly parsing " +++ "the source files by running with --mode=parsehs"++-- Compare two packages made up of readily parsed Hoogle DBs+diffHoogleDB :: [DBEntry] -> [DBEntry] -> Diff+diffHoogleDB dbA dbB = do+ let [verA, verB] = flip map [dbA, dbB]+ ( -- Sort exports by name+ map (\(nm, exps) -> (nm, sortBy (compare `on` dbeName) exps))+ -- Sort modules by name+ . sortBy (compare `on` fst)+ -- Extract module name, put into (name, exports) pair+ . map (\case ((DBModule nm):exps) -> (nm , exps)+ exps -> ("(Unknown)", exps)+ )+ -- Group by module+ . groupBy (\a b -> or $ (\case DBModule _ -> False+ _ -> True+ ) <$> [a, b]+ )+ -- Filter out comments and package information+ . filter (\case (DBPkgInfo _ _) -> False+ (DBComment _ ) -> False+ _ -> True+ )+ )+ modulesAdded = allANotInBBy ((==) `on` fst) verB verA+ modulesRemoved = allANotInBBy ((==) `on` fst) verA verB+ modulesKept = intersectBy ((==) `on` fst) verA verB+ resAdded = flip map modulesAdded $ \(nm, exps) ->+ (MAdded . map (show) $ exps, T.unpack nm)+ resRemoved = flip map modulesRemoved $ \(nm, exps) ->+ (MRemoved . map (show) $ exps, T.unpack nm)+ resKept =+ sortBy compareKept . flip map modulesKept $ \(mname, modA') ->+ -- Did the exports change?+ case (modA', snd <$> find ((== mname) . fst) verB) of+ (_ , Nothing ) -> -- This really should not ever happen here+ (MNotSureIfModifiedParseError, T.unpack mname)+ (modA, Just modB)+ | didExpChange -> (MModified expCmp , T.unpack mname)+ | otherwise -> (MUnmodifed , T.unpack mname)+ where -- Which exports were added / removed / modified?+ didExpChange = or $ map (\case (EUnmodified, _) -> False; _ -> True) expCmp+ expCmp = expAdded ++ expRemoved ++ expKept+ expAdded =+ [(EAdded , show x) | x <- allANotInBBy compareDBEName modB modA]+ expRemoved =+ [(ERemoved, show x) | x <- allANotInBBy compareDBEName modA modB]+ expKept =+ -- We don't sort by modified / unmodified here as we currently+ -- don't list the unmodified ones+ flip map (intersectBy compareDBEName modA modB) $ \eOld ->+ case find (compareDBEName eOld) modB of+ Nothing -> error "intersectBy / find is broken..."+ Just eNew | compareDBEType eOld eNew ->+ (EUnmodified, show eOld)+ | otherwise ->+ (EModified $ show eOld, show eNew)+ -- Sort everything by modification type, but make sure we sort+ -- modified modules by their name, not their export list+ compareKept a b = case (a, b) of+ ((MModified _, nameA), (MModified _, nameB)) -> compare nameA nameB+ _ -> compare a b+ in resAdded ++ resRemoved ++ resKept++-- Stupid helper to build module / export lists. Should probably switch to using+-- Data.Set for all of these operations to stop having O(n*m) everywhere+allANotInBBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]+allANotInBBy f a b = filter (\m -> not $ any (f m) b) a++data DBEntry = DBModule !T.Text+ | DBPkgInfo !T.Text !T.Text+ | DBComment !T.Text+ | DBType !T.Text !T.Text+ | DBNewtype !T.Text !T.Text+ | DBData !T.Text !T.Text+ | DBCtor !T.Text !T.Text+ | DBClass !T.Text !T.Text+ | DBInstance !T.Text !T.Text+ | DBFunction !T.Text !T.Text+ deriving (Eq)++-- When comparing names we have to take the kind of the export into account, i.e.+-- type and value constructors may have the same name without being identical+compareDBEName :: DBEntry -> DBEntry -> Bool+compareDBEName a b = case (a, b) of+ (DBModule _ , DBModule _ ) -> cmp; (DBPkgInfo _ _ , DBPkgInfo _ _ ) -> cmp;+ (DBComment _ , DBComment _ ) -> cmp; (DBType _ _ , DBType _ _ ) -> cmp;+ (DBNewtype _ _ , DBNewtype _ _ ) -> cmp; (DBData _ _ , DBData _ _ ) -> cmp;+ (DBCtor _ _ , DBCtor _ _ ) -> cmp; (DBClass _ _ , DBClass _ _ ) -> cmp;+ (DBInstance _ _, DBInstance _ _) -> cmp; (DBFunction _ _, DBFunction _ _) -> cmp;+ _ -> False+ where cmp = ((==) `on` dbeName) a b++-- Compare the type of two entries. If we simply compare the type string, we will+-- have mistakes like classifying those two functions as having a change in type:+--+-- func :: Num a => a -> a+-- func :: (Num a) => a -> a+--+-- So we try to parse the type with haskell-src-exts and then fall back on a string+-- compare if that fails. Parsing again every time the comparison function is called is+-- obviously rather slow, but it hasn't been an issue so far+--+-- TODO: We should do a name normalization pass on the parsed type, otherwise+-- 'id :: a -> a' and 'id :: b -> b' will be reported as different+--+compareDBEType :: DBEntry -> DBEntry -> Bool+compareDBEType a b =+ -- We assume that a and b are the same kind of export (i.e. they have already been+ -- matched with dbeName, which only compares exports of the same kind), and now we+ -- want to know if the type differs between them+ case a of+ -- The syntax we use to list exported Ctors and their types can't be parsed as a+ -- declaration, just compare the type part+ DBCtor _ _ -> case ( parseTypeWithMode mode . T.unpack $ dbeType a+ , parseTypeWithMode mode . T.unpack $ dbeType b+ ) of+ (E.ParseOk resA, E.ParseOk resB) -> resA == resB+ _ -> stringTypeCmp+ -- Also can't parse our type / newtype syntax, fall back to string compare+ DBType _ _ -> stringTypeCmp+ DBNewtype _ _ -> stringTypeCmp+ -- Parse everything else in its entirety as a top-level declaration+ _ -> case ( parseDeclWithMode mode $ show a+ , parseDeclWithMode mode $ show b+ ) of+ (E.ParseOk resA, E.ParseOk resB) -> resA == resB+ _ -> stringTypeCmp+ where mode = -- Enable some common extension to make parsing more likely to succeed+ defaultParseMode+ {+ extensions = [ EnableExtension FunctionalDependencies+ , EnableExtension MultiParamTypeClasses+ , EnableExtension TypeOperators+ , EnableExtension KindSignatures+ , EnableExtension MagicHash+ , EnableExtension FlexibleContexts+ ]+ }+ stringTypeCmp = ((==) `on` dbeType) a b++-- Extract a database entry's "name" (i.e. a function name vs its type)+dbeName :: DBEntry -> T.Text+dbeName = \case+ DBModule nm -> nm; DBPkgInfo k _ -> k ; DBComment _ -> "";+ DBType nm _ -> nm; DBNewtype nm _ -> nm; DBData nm _ -> nm;+ DBCtor nm _ -> nm; DBClass nm _ -> nm; DBInstance nm _ -> nm;+ DBFunction nm _ -> nm++-- Extract a database entry's "type" (i.e. a function type vs its name)+dbeType :: DBEntry -> T.Text+dbeType = \case+ DBModule _ -> ""; DBPkgInfo _ v -> v ; DBComment _ -> "";+ DBType _ ty -> ty; DBNewtype _ ty -> ty; DBData _ ty -> ty;+ DBCtor _ ty -> ty; DBClass _ ty -> ty; DBInstance _ ty -> ty;+ DBFunction _ ty -> ty++instance Show DBEntry where+ show = \case+ DBModule nm -> "module " ++ T.unpack nm+ DBPkgInfo k v -> "@" ++ T.unpack k ++ T.unpack v+ DBComment txt -> "-- " ++ T.unpack txt+ DBType nm ty -> "type " ++ T.unpack nm ++ " " ++ T.unpack ty+ DBNewtype nm ty -> "newtype " ++ T.unpack nm ++ " " ++ T.unpack ty+ DBData nm ty -> "data " ++ T.unpack nm ++ (if T.null ty then "" else " " ++ T.unpack ty)+ DBCtor nm ty -> T.unpack nm ++ " :: " ++ T.unpack ty+ DBClass _ ty -> "class " ++ T.unpack ty+ DBInstance _ ty -> "instance " ++ T.unpack ty+ DBFunction nm ty -> T.unpack nm ++ " :: " ++ T.unpack ty++-- Parse a Hoogle text database+hoogleDBParser :: Parser [DBEntry]+hoogleDBParser = many parseLine+ where+ parseLine = (*>) skipEmpty $ parseComment <|> parseData <|> parsePkgInfo <|>+ parseDBModule <|> parseCtor <|> parseNewtype <|>+ parseDBType <|> parseClass <|> parseInstance <|>+ parseFunction+ parseComment = string "-- " *> (DBComment <$> tillEoL)+ parsePkgInfo = char '@' *> (DBPkgInfo <$> takeTill (== ' ') <*> tillEoL)+ parseData = string "data " *>+ ( (DBData <$> takeTill (`elem` [ ' ', '\n' ]) <* endOfLine <*> "") <|>+ (DBData <$> takeTill (== ' ') <* skipSpace <*> tillEoL)+ )+ parseNewtype = string "newtype " *>+ ( (DBNewtype <$> takeTill (`elem` [ ' ', '\n' ]) <* endOfLine <*> "") <|>+ (DBNewtype <$> takeTill (== ' ') <* skipSpace <*> tillEoL)+ )+ parseCtor = do peekChar' >>= flip unless (fail "lowercase") . isAsciiUpper+ DBCtor <$> takeTill (== ' ') <* string " :: " <*> tillEoL+ parseFunction = do peekChar' >>=+ flip unless (fail "uppercase") . (\c -> isAsciiLower c || c == '(')+ DBFunction <$> takeTill (== ' ') <* string " :: " <*> tillEoL+ parseInstance = do void $ string "instance "+ line <- T.words <$> tillEoL+ -- The name of an instance is basically everything+ -- after the typeclass requirements+ let nm = case break (== "=>") line of+ (xs, []) -> T.unwords xs+ (_, (_:xs)) -> T.unwords xs+ return . DBInstance nm $ T.unwords line+ parseClass = do void $ string "class "+ line <- T.words <$> tillEoL+ let nm = case break (== "=>") line of+ ((n:_), []) -> n+ (_, (_:n:_)) -> n+ _ -> ""+ -- TODO: Sometimes typeclasses have all their default method+ -- implementations listed right after the 'where' part,+ -- just cut all of this off for now+ trunc = fst . break (== "where") $ line+ in return . DBClass nm $ T.unwords trunc+ parseDBType = string "type " *> (DBType <$> takeTill (== ' ') <* skipSpace <*> tillEoL)+ parseDBModule = string "module " *> (DBModule <$> takeTill (== '\n')) <* endOfLine+ skipEmpty = many endOfLine+ tillEoL = takeTill (== '\n') <* endOfLine++-- Compute a Diff by processing Haskell files directly. We use the Cabal API to locate and+-- parse the package .cabal file, extract a list of modules from it, and then pre-process+-- each module with cpphs and finally parse it with haskell-src-exts. The principal issue+-- with this approach is the often complex use of the CPP inside Haskell packages, making+-- this fail fairly often. This method also currently does not look at type signatures and+-- has various other limitations, like not working with modules that do not have an+-- export list+computeDiffParseHaskell :: ComputeParams -> ExceptT String IO Diff+computeDiffParseHaskell ComputeParams { .. } = do+ [mListA, mListB] <- forM [cpVerA, cpVerB] $ \ver -> do+ let pkgPath = either (\v -> cpTmpDir </> cpPackage ++ "-" ++ v) id ver+ unless cpSilentFlag . liftIO . putStrLn $ "Processing " ++ pkgPath ++ "..."+ -- Find .cabal file+ dotCabal <- (liftIO . findPackageDesc $ pkgPath) >>= either throwError return+ -- Parse .cabal file, extract exported modules+ exports <- condLibrary <$> (liftIO $ readPackageDescription normal dotCabal) >>= \case+ Nothing -> throwError $ pkgPath ++ " is not a library"+ Just node -> return $ exposedModules . condTreeData $ node+ -- Build module name / module source file list+ --+ -- TODO: Some packages have a more complex source structure, need to look at the+ -- cabal file some more to locate the files+ let modules = flip map exports $+ \m -> ( concat . intersperse "." . components $ m+ , pkgPath </> toFilePath m <.> "hs" -- TODO: Also .lhs?+ )+ -- Parse modules+ liftIO . forM modules $ \(modName, modPath) -> do+ unless cpSilentFlag . putStrLn $ " Parsing " ++ modName+ Main.parseModule modPath >>= either+ -- Errors only affecting single modules are recoverable, just+ -- print them instead of throwing+ (\e -> putStrLn (" " ++ e) >> return (modName, Nothing))+ (\r -> return (modName, Just r ))+ -- Compute difference+ return $ comparePackageModules mListA mListB++-- Parse a Haskell module interface using haskell-src-exts and cpphs+parseModule :: FilePath -> IO (Either String Module)+parseModule modPath = runExceptT $ do+ (liftIO $ doesFileExist modPath) >>= flip unless+ (throwError $ "Can't open source file '" ++ modPath ++ "'")+ -- Run cpphs as pre-processor over our module+ --+ -- TODO: This obviously doesn't have the same defines and include paths set like+ -- when compiling with GHC, major source of failures right now+ modSrcCPP <- liftIO $ readFile modPath >>= runCpphs defaultCpphsOptions modPath+ -- Parse pre-processed Haskell source. This pure parsing function unfortunately throws+ -- exceptions for things like encountering an '#error' directive in the code, so we+ -- also have to handle those as well+ (liftIO . try . evaluate $+ parseFileContentsWithMode defaultParseMode { parseFilename = modPath } modSrcCPP)+ >>= \case Left (e :: ErrorCall) ->+ throwError $ "Haskell Parse Exception - " ++ show e+ Right (E.ParseFailed (SrcLoc fn ln cl) err) ->+ throwError $ printf "Haskell Parse Error - %s:%i:%i: %s" fn ln cl err+ Right (E.ParseOk parsedModule) ->+ return parsedModule++type PackageModuleList = [(String, Maybe Module)]++-- Compare two packages made up of readily parsed Haskell modules+comparePackageModules :: PackageModuleList -> PackageModuleList -> Diff+comparePackageModules verA verB = do+ let -- Compare lists of modules+ modulesAdded = allANotInBBy ((==) `on` fst) verB verA+ modulesRemoved = allANotInBBy ((==) `on` fst) verA verB+ modulesKept = intersectBy ((==) `on` fst) verA verB+ -- Build result Diff of modules+ resAdded = flip map modulesAdded $ \case+ (mname, Just m ) ->+ (MAdded . map (prettyPrint) $ moduleExports m, mname)+ (mname, Nothing) ->+ (MAddedParseError, mname)+ resRemoved = flip map modulesRemoved $ \case+ (mname, Just m ) ->+ (MRemoved . map (prettyPrint) $ moduleExports m, mname)+ (mname, Nothing) ->+ (MRemovedParseError, mname)+ -- TODO: This doesn't sort correctly by type of change + name+ resKept = sortBy (compare `on` fst) . flip map modulesKept $ \(mname, modA') ->+ -- Did the exports change?+ case (modA', findModule verB mname) of+ (_, Nothing) -> (MNotSureIfModifiedParseError, mname)+ (Nothing, _) -> (MNotSureIfModifiedParseError, mname)+ (Just modA, Just modB)+ | moduleExports modA == moduleExports modB+ -> (MUnmodifed , mname)+ | otherwise -> (MModified expCmp, mname)+ where -- Which exports were added / removed?+ expCmp =+ [(EAdded , prettyPrint x) | x <- expAdded ] +++ [(ERemoved , prettyPrint x) | x <- expRemoved ] +++ [(EUnmodified, prettyPrint x) | x <- expUnmodified]+ -- TODO: We do not look for type changes, no EModified+ expAdded = allANotInBBy (==) (moduleExports modB)+ (moduleExports modA)+ expRemoved = allANotInBBy (==) (moduleExports modA)+ (moduleExports modB)+ expUnmodified = intersectBy (==) (moduleExports modA)+ (moduleExports modB)+ -- TODO: If the module does not have an export spec, we assume it exports nothing+ moduleExports (Module _ _ _ _ (Just exportSpec) _ _) = exportSpec+ moduleExports _ = []+ findModule mlist mname = maybe Nothing snd $ find ((== mname) . fst) mlist+ in resAdded ++ resRemoved ++ resKept+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hackage-diff.cabal view
@@ -0,0 +1,101 @@+-- Initial hackage-diff.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: hackage-diff+version: 0.1.0.0+synopsis: Compare the public API of different versions of a Hackage library+description: Please see <https://github.com/blitzcode/hackage-diff github.com/blitzcode/hackage-diff> for a user's manual.+ .+ Sample output+ .+ > Downloading Hoogle DBs...+ > Parsing Hoogle DBs...+ > Comparing Hoogle DBs...+ > + > --- Diff for | 0.2 → 0.3.5.2 | ---+ > + > + Data.Serialize.IEEE754+ > + getFloat32be :: Get Float+ > + getFloat32le :: Get Float+ > + getFloat64be :: Get Double+ > + getFloat64le :: Get Double+ > + putFloat32be :: Float -> Put+ > + putFloat32le :: Float -> Put+ > + putFloat64be :: Double -> Put+ > + putFloat64le :: Double -> Put+ > × Data.Serialize+ > + instance Serialize a => GSerialize (K1 i a)+ > + instance GSerialize a => GSerialize (M1 i c a)+ > + instance (GSerialize a, GSerialize b) => GSerialize (a :*: b)+ > + instance GSerialize U1+ > + instance GSerialize a => GetSum (C1 c a)+ > + instance (GetSum a, GetSum b, GSerialize a, GSerialize b) => GetSum (a :+: b)+ > + instance GSerialize a => PutSum (C1 c a)+ > + instance (PutSum a, PutSum b, GSerialize a, GSerialize b) => PutSum (a :+: b)+ > + instance SumSize (C1 c a)+ > + instance (SumSize a, SumSize b) => SumSize (a :+: b)+ > + decodeLazy :: Serialize a => ByteString -> Either String a+ > + encodeLazy :: Serialize a => a -> ByteString+ > - data Get a+ > - type Put = PutM ()+ > - type Putter a = a -> Put+ > - getWord8 :: Get Word8+ > - putWord8 :: Putter Word8+ > × Data.Serialize.Get+ > + Done :: r -> ByteString -> Result r+ > + instance Eq More+ > + Fail :: String -> Result r+ > + instance Functor Result+ > + Partial :: (ByteString -> Result r) -> Result r+ > + data Result r+ > + instance Show r => Show (Result r)+ > + ensure :: Int -> Get ByteString+ > + runGetLazy :: Get a -> ByteString -> Either String a+ > + runGetLazyState :: Get a -> ByteString -> Either String (a, ByteString)+ > + runGetPartial :: Get a -> ByteString -> Result a+ > × New: isolate :: Int -> Get a -> Get a+ > Old: isolate :: String -> Int -> Get a -> Get a+ > × Data.Serialize.Put+ > + runPutLazy :: Put -> ByteString+ > + runPutMLazy :: PutM a -> (a, ByteString)+ > · Data.Serialize.Builder+ > + > [+ Added] [- Removed] [× Modified] [· Unmodified]++license: MIT+license-file: LICENSE+author: Tim C. Schroeder+maintainer: www.blitzcode.net+homepage: https://github.com/blitzcode/hackage-diff+bug-reports: https://github.com/blitzcode/hackage-diff/issues+copyright: (C) 2014 Tim C. Schroeder+category: Distribution+build-type: Simple+-- extra-source-files: +cabal-version: >=1.18++source-repository head+ type: git+ location: git@github.com:blitzcode/hackage-diff.git++executable hackage-diff+ main-is: Main.hs+ -- other-modules:+ -- other-extensions:+ build-depends: base >=4.7 && <4.8,+ Cabal >=1.20.0.0,+ haskell-src-exts >=1.15.0,+ ansi-terminal >=0.6.1.1,+ directory >=1.2.0.0,+ filepath >=1.3.0.0,+ process >=1.2.0.0,+ attoparsec >=0.12.1.0,+ cpphs >=1.18.5,+ mtl >=2.2.1,+ text >=1.1.1.0,+ HTTP >=4000.2.17,+ async >=2.0.1.5+ -- hs-source-dirs: + default-language: Haskell2010+ ghc-options: -Wall -O2 -rtsopts+ ghc-prof-options: -fprof-auto -caf-all