cabal-db 0.1.3 → 0.1.4

raw patch · 2 files changed

+25/−19 lines, 2 files

Files

• Src/Main.hs +24/−18
• cabal-db.cabal +1/−1

@@ -34,7 +34,7 @@     ,"base", "bytestring"     ,"containers", "cgi"     ,"deepseq","directory"-    ,"extensible-extensions"+    ,"extensible-exceptions"     ,"fgl","filepath"     ,"GLUT"     ,"haskell-src","haskell2010","haskell98","hpc","html","HUnit"@@ -185,28 +185,34 @@     putStrLn "}"  ------------------------------------------------------------------------run apkgs hidePlatform hiddenPackages specifiedPackages = generateDotM colorize $ mapM_ loop specifiedPackages+run apkgs hidePlatform hiddenPackages specifiedPackages = generateDotM colorize $ mapM_ (loop 0) specifiedPackages     where colorize pn                  | pn `elem` specifiedPackages = Just "red"                  | pn `elem` platformPackages  = Just "green"                  | otherwise                   = Nothing -          loop :: PackageName -> StateT St IO ()-          loop pn = do-            pni       <- resolve pn-            processed <- isProcessed pni-            unless processed $ do-                let desc = finPkgDesc <$> getPackageDescription apkgs pn Nothing-                case desc of-                    Just (Right (d,_)) -> do-                        let depNames = (if hidePlatform-                                            then filter (not . flip elem platformPackages)-                                            else id)-                                     $ filter (not . flip elem hiddenPackages)-                                     $ map (\(Dependency n _) -> n) $ buildDepends d-                        mapM_ loop depNames-                        mapM_ (resolve >=> insertDep pni) depNames-                    _ -> return ()+          loop :: Int -> PackageName -> StateT St IO ()+          loop !depth pn+            | depth > 1000 = error "internal error: infinite loop detected"+            | otherwise    = do+                pni       <- resolve pn+                processed <- isProcessed pni+                --liftIO $ putStrLn ("loop: " ++ show pn ++ " processed: " ++ show processed ++ " depth: " ++ show depth)+                unless processed $ do+                    let desc = finPkgDesc <$> getPackageDescription apkgs pn Nothing+                    case desc of+                        Just (Right (d,_)) -> do+                            let depNames = (if hidePlatform+                                                then filter (not . flip elem platformPackages)+                                                else id)+                                         $ filter (/= pn)+                                         $ filter (not . flip elem hiddenPackages)+                                         $ map (\(Dependency n _) -> n) $ buildDepends d+                            mapM_ (loop (depth+1)) depNames+                            mapM_ (resolve >=> insertDep pni) depNames+                        _ -> do+                            --liftIO $ putStrLn ("warning cannot handle: " ++ show pn ++ " : " ++ show desc)+                            return ()  ----------------------------------------------------------------------- data GraphFlag = Hide String | HidePlatform

@@ -1,5 +1,5 @@ Name:                cabal-db-Version:             0.1.3+Version:             0.1.4 Synopsis:            cabal-db Description:         cabal-db License:             BSD3