diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,6 +1,10 @@ Changelog for Hoogle -2.0.17.1, released 2018-01-27 +5.0.17.2, released 2018-03-16 + Remove support for GHC 7.10 + Require conduit-1.3.0 + #245, add support for GHC 8.4 +5.0.17.1, released 2018-01-27 #238, only identify the database by the first three version components #236, in --local mode replace file:// links in Haddock pages 5.0.17, released 2018-01-17 diff --git a/hoogle.cabal b/hoogle.cabal --- a/hoogle.cabal +++ b/hoogle.cabal @@ -1,7 +1,7 @@ cabal-version: >= 1.18 build-type: Simple name: hoogle -version: 5.0.17.1 +version: 5.0.17.2 license: BSD3 license-file: LICENSE category: Development @@ -15,7 +15,7 @@ or by approximate type signature. homepage: http://hoogle.haskell.org/ bug-reports: https://github.com/ndmitchell/hoogle/issues -tested-with: GHC==8.2.2, GHC==8.0.2, GHC==7.10.3 +tested-with: GHC==8.4.1, GHC==8.2.2, GHC==8.0.2 extra-doc-files: README.md CHANGES.txt @@ -58,8 +58,8 @@ binary, bytestring >= 0.10.2.0, cmdargs, - conduit, - conduit-extra, + conduit >= 1.3.0, + conduit-extra >= 1.2.3.2, connection, containers >= 0.5, deepseq, diff --git a/src/Action/Generate.hs b/src/Action/Generate.hs --- a/src/Action/Generate.hs +++ b/src/Action/Generate.hs @@ -1,5 +1,4 @@ {-# LANGUAGE ViewPatterns, TupleSections, RecordWildCards, ScopedTypeVariables, PatternGuards #-} -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- getGCStats became getRTSStats module Action.Generate(actionGenerate) where @@ -35,8 +34,6 @@ import General.Store import General.Timing import General.Str -import System.Mem -import GHC.Stats import Action.CmdLine import General.Conduit @@ -95,7 +92,7 @@ type Download = String -> URL -> IO FilePath -readHaskellOnline :: Timing -> Settings -> Download -> IO (Map.Map String Package, Set.Set String, Source IO (String, URL, LStr)) +readHaskellOnline :: Timing -> Settings -> Download -> IO (Map.Map String Package, Set.Set String, ConduitT () (String, URL, LStr) IO ()) readHaskellOnline timing settings download = do stackage <- download "haskell-stackage.txt" "https://www.stackage.org/lts/cabal.config" platform <- download "haskell-platform.txt" "https://raw.githubusercontent.com/haskell/haskell-platform/master/hptool/src/Releases2015.hs" @@ -123,7 +120,7 @@ return (cbl, want, source) -readHaskellDirs :: Timing -> Settings -> [FilePath] -> IO (Map.Map String Package, Set.Set String, Source IO (String, URL, LStr)) +readHaskellDirs :: Timing -> Settings -> [FilePath] -> IO (Map.Map String Package, Set.Set String, ConduitT () (String, URL, LStr) IO ()) readHaskellDirs timing settings dirs = do files <- concatMapM listFilesRecursive dirs -- We reverse/sort the list because of #206 @@ -148,7 +145,7 @@ let pkg = readCabal settings src return (takeBaseName fp, pkg) -readFregeOnline :: Timing -> Download -> IO (Map.Map String Package, Set.Set String, Source IO (String, URL, LStr)) +readFregeOnline :: Timing -> Download -> IO (Map.Map String Package, Set.Set String, ConduitT () (String, URL, LStr) IO ()) readFregeOnline timing download = do frege <- download "frege-frege.txt" "http://try.frege-lang.org/hoogle-frege.txt" let source = do @@ -157,7 +154,7 @@ return (Map.empty, Set.singleton "frege", source) -readHaskellGhcpkg :: Timing -> Settings -> IO (Map.Map String Package, Set.Set String, Source IO (String, URL, LStr)) +readHaskellGhcpkg :: Timing -> Settings -> IO (Map.Map String Package, Set.Set String, ConduitT () (String, URL, LStr) IO ()) readHaskellGhcpkg timing settings = do cbl <- timed timing "Reading ghc-pkg" $ readGhcPkg settings let source = @@ -173,7 +170,7 @@ in Map.map (\p -> p{packageTags = ts ++ packageTags p}) cbl return (cbl, Map.keysSet cbl, source) -readHaskellHaddock :: Timing -> Settings -> FilePath -> IO (Map.Map String Package, Set.Set String, Source IO (String, URL, LStr)) +readHaskellHaddock :: Timing -> Settings -> FilePath -> IO (Map.Map String Package, Set.Set String, ConduitT () (String, URL, LStr) IO ()) readHaskellHaddock timing settings docBaseDir = do cbl <- timed timing "Reading ghc-pkg" $ readGhcPkg settings let source = @@ -195,7 +192,6 @@ actionGenerate g@Generate{..} = withTiming (if debug then Just $ replaceExtension database "timing" else Nothing) $ \timing -> do putStrLn "Starting generate" createDirectoryIfMissing True $ takeDirectory database - gcStats <- getGCStatsEnabled download <- return $ downloadInput timing insecure download (takeDirectory database) settings <- loadSettings @@ -218,18 +214,18 @@ itemWarn <- newIORef 0 let warning msg = do modifyIORef itemWarn succ; hPutStrLn warnings msg - let consume :: Conduit (Int, (String, URL, LStr)) IO (Maybe Target, [Item]) + let consume :: ConduitM (Int, (String, URL, LStr)) (Maybe Target, [Item]) IO () consume = awaitForever $ \(i, (pkg, url, body)) -> do timedOverwrite timing ("[" ++ show i ++ "/" ++ show (Set.size want) ++ "] " ++ pkg) $ parseHoogle (\msg -> warning $ pkg ++ ":" ++ msg) url body writeItems store $ \items -> do xs <- runConduit $ - source =$= - filterC (flip Set.member want . fst3) =$= + source .| + filterC (flip Set.member want . fst3) .| void ((|$|) - (zipFromC 1 =$= consume) - (do seen <- fmap Set.fromList $ mapC fst3 =$= sinkList + (zipFromC 1 .| consume) + (do seen <- fmap Set.fromList $ mapC fst3 .| sinkList let missing = [x | x <- Set.toList $ want `Set.difference` seen , fmap packageLibrary (Map.lookup x cbl) /= Just False] @@ -251,26 +247,25 @@ else return () )) - =$= pipelineC 10 (items =$= sinkList) + .| pipelineC 10 (items .| sinkList) itemWarn <- readIORef itemWarn when (itemWarn > 0) $ putStrLn $ "Found " ++ show itemWarn ++ " warnings when processing items" return [(a,b) | (a,bs) <- xs, b <- bs] - itemsMb <- if not gcStats then return 0 else do performGC; GCStats{..} <- getGCStats; return $ currentBytesUsed `div` (1024*1024) + itemsMemory <- getStatsCurrentLiveBytes xs <- timed timing "Reodering items" $ return $! reorderItems settings (\s -> maybe 1 negate $ Map.lookup s popularity) xs timed timing "Writing tags" $ writeTags store (`Set.member` want) (\x -> maybe [] (map (both T.unpack) . packageTags) $ Map.lookup x cbl) xs timed timing "Writing names" $ writeNames store xs timed timing "Writing types" $ writeTypes store (if debug then Just $ dropExtension database else Nothing) xs - when gcStats $ do - stats@GCStats{..} <- getGCStats - x <- getVerbosity - when (x >= Loud) $ - print stats - when (x >= Normal) $ do - putStrLn $ "Peak of " ++ show peakMegabytesAllocated ++ "Mb, " ++ show itemsMb ++ "Mb for items" + x <- getVerbosity + when (x >= Loud) $ + maybe (return ()) print =<< getStatsDebug + when (x >= Normal) $ do + whenJustM getStatsPeakAllocBytes $ \x -> + putStrLn $ "Peak of " ++ x ++ ", " ++ fromMaybe "unknown" itemsMemory ++ " for items" when debug $ writeFile (database `replaceExtension` "store") $ unlines stats diff --git a/src/Action/Server.hs b/src/Action/Server.hs --- a/src/Action/Server.hs +++ b/src/Action/Server.hs @@ -1,5 +1,4 @@ {-# LANGUAGE ViewPatterns, TupleSections, RecordWildCards, ScopedTypeVariables, PatternGuards #-} -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- getGCStats became getRTSStats module Action.Server(actionServer, actionReplay, action_server_test_, action_server_test) where @@ -23,7 +22,6 @@ import Data.Time.Calendar import System.IO.Unsafe import Numeric.Extra -import GHC.Stats import System.Info.Extra import Output.Tags @@ -115,12 +113,10 @@ log <- displayLog <$> logSummary log OutputHTML <$> templateRender templateLog [("data",str log)] ["stats"] -> do - stats <- getGCStatsEnabled - if stats then do - x <- getGCStats - return $ OutputText $ lstrPack $ replace ", " "\n" $ takeWhile (/= '}') $ drop 1 $ dropWhile (/= '{') $ show x - else - return $ OutputFail $ lstrPack "GHC Statistics is not enabled, restart with +RTS -T" + stats <- getStatsDebug + return $ case stats of + Nothing -> OutputFail $ lstrPack "GHC Statistics is not enabled, restart with +RTS -T" + Just x -> OutputText $ lstrPack $ replace ", " "\n" $ takeWhile (/= '}') $ drop 1 $ dropWhile (/= '{') $ show x "haddock":xs | Just x <- haddock -> do let file = intercalate "/" $ filter (not . (== "..")) (x:xs) return $ OutputFile $ file ++ (if hasTrailingPathSeparator file then "index.html" else "") diff --git a/src/General/Conduit.hs b/src/General/Conduit.hs --- a/src/General/Conduit.hs +++ b/src/General/Conduit.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE NoMonomorphismRestriction, PatternGuards, Rank2Types, CPP #-} -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- QSem was deprecated in 7.6, but then undeprecated +{-# LANGUAGE NoMonomorphismRestriction, PatternGuards, CPP #-} module General.Conduit( module Data.Conduit, MonadIO, liftIO, @@ -10,6 +9,7 @@ zipFromC, linesCR ) where +import Data.Void import Data.Conduit import Data.Conduit.List as C import Data.Conduit.Binary as C @@ -30,18 +30,18 @@ mapAccumMC f = C.mapAccumM (\x a -> a `seq` f a x) filterC = C.filter -zipFromC :: (Monad m, Enum i) => i -> Conduit a m (i, a) +zipFromC :: (Monad m, Enum i) => i -> ConduitM a (i, a) m () zipFromC = void . mapAccumC (\i x -> (succ i, (i,x))) (|$|) :: Monad m => ConduitM i o m r1 -> ConduitM i o m r2 -> ConduitM i o m (r1,r2) (|$|) a b = getZipConduit $ (,) <$> ZipConduit a <*> ZipConduit b -sinkList :: Monad m => Consumer a m [a] +sinkList :: Monad m => ConduitM a o m [a] sinkList = consume -- | Group things while they have the same function result, only return the last value. -- Conduit version of @groupOnLast f = map last . groupOn f@. -groupOnLastC :: (Monad m, Eq b) => (a -> b) -> Conduit a m a +groupOnLastC :: (Monad m, Eq b) => (a -> b) -> ConduitM a a m () groupOnLastC op = do x <- await whenJust x $ \x -> f (op x) x @@ -53,16 +53,16 @@ f k2 v2 -linesCR :: Monad m => Conduit Str m Str -linesCR = C.lines =$= mapC f +linesCR :: Monad m => ConduitM Str Str m () +linesCR = C.lines .| mapC f where f x | Just (x, '\r') <- BS.unsnoc x = x | otherwise = x -sourceLStr :: Monad m => LStr -> Producer m Str +sourceLStr :: Monad m => LStr -> ConduitM i Str m () sourceLStr = sourceList . lstrToChunks -pipelineC :: Int -> Consumer o IO r -> Consumer o IO r +pipelineC :: Int -> ConduitM o Void IO r -> ConduitM o Void IO r pipelineC buffer sink = do sem <- liftIO $ newQSem buffer -- how many are in flow, to avoid memory leaks chan <- liftIO newChan -- the items in flow (type o) @@ -74,7 +74,7 @@ x <- liftIO $ readChan chan liftIO $ signalQSem sem whenJust x yield - return $ isJust x) =$= + return $ isJust x) .| sink awaitForever $ \x -> liftIO $ do waitQSem sem diff --git a/src/General/Timing.hs b/src/General/Timing.hs --- a/src/General/Timing.hs +++ b/src/General/Timing.hs @@ -1,5 +1,4 @@ {-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- getGCStats became getRTSStats module General.Timing(Timing, withTiming, timed, timedOverwrite) where @@ -9,7 +8,6 @@ import Control.Monad.Extra import System.IO import General.Util -import GHC.Stats import Control.Monad.IO.Class @@ -68,8 +66,7 @@ let time = end - start liftIO $ modifyIORef timingStore ((msg,time):) - stats <- liftIO getGCStatsEnabled - s <- if not stats then return "" else do GCStats{..} <- liftIO getGCStats; return $ " (" ++ show peakMegabytesAllocated ++ "Mb)" + s <- maybe "" (\x -> " (" ++ x ++ ")") <$> liftIO getStatsPeakAllocBytes undo2 <- out $ showDuration time ++ s old <- liftIO $ readIORef timingOverwrite diff --git a/src/General/Util.hs b/src/General/Util.hs --- a/src/General/Util.hs +++ b/src/General/Util.hs @@ -20,6 +20,7 @@ trimVersion, exitFail, prettyTable, + getStatsPeakAllocBytes, getStatsCurrentLiveBytes, getStatsDebug, hackagePackageURL, hackageModuleURL, hackageDeclURL, ghcModuleURL, minimum', maximum', general_util_test @@ -48,11 +49,61 @@ import Data.Int import System.IO import System.Exit +import System.Mem +import GHC.Stats import Prelude -- | A URL, complete with a @https:@ prefix. type URL = String + +#if __GLASGOW_HASKELL__ >= 802 +#define RTS_STATS 1 +#endif + +showMb :: (Show a, Integral a) => a -> String +#if RTS_STATS +showMb x = show x ++ "Mb" +#else +showMb x = show (x `mod` (1024*1024)) ++ "Mb" +#endif + + +#if RTS_STATS +withRTSStats :: (RTSStats -> a) -> IO (Maybe a) +withRTSStats f = ifM getRTSStatsEnabled (Just . f <$> getRTSStats) (return Nothing) +#else +withGCStats :: (GCStats -> a) -> IO (Maybe a) +withGCStats f = ifM getGCStatsEnabled (Just . f <$> getGCStats) (return Nothing) +#endif + +getStatsCurrentLiveBytes :: IO (Maybe String) +getStatsCurrentLiveBytes = do + performGC +#if RTS_STATS + withRTSStats $ showMb . gcdetails_live_bytes . gc +#else + withGCStats $ showMb . currentBytesUsed +#endif + +getStatsPeakAllocBytes :: IO (Maybe String) +getStatsPeakAllocBytes = do +#if RTS_STATS + withRTSStats $ showMb . max_mem_in_use_bytes +#else + withGCStats $ showMb . peakMegabytesAllocated +#endif + +getStatsDebug :: IO (Maybe String) +getStatsDebug = do + let dump = replace ", " "\n" . takeWhile (/= '}') . drop 1 . dropWhile (/= '{') . show +#if RTS_STATS + withRTSStats dump +#else + withGCStats dump +#endif + + exitFail :: String -> IO () exitFail msg = do diff --git a/src/General/Web.hs b/src/General/Web.hs --- a/src/General/Web.hs +++ b/src/General/Web.hs @@ -1,17 +1,11 @@ -{-# LANGUAGE ScopedTypeVariables, OverloadedStrings, CPP, ViewPatterns, RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables, OverloadedStrings, ViewPatterns, RecordWildCards #-} module General.Web( Input(..), Output(..), readInput, server ) where --- #define PROFILE - --- For some reason, profiling stops working if I import warp --- Tracked as https://github.com/yesodweb/wai/issues/311 -#ifndef PROFILE import Network.Wai.Handler.Warp hiding (Port, Handle) import Network.Wai.Handler.WarpTLS -#endif import Action.CmdLine import Network.Wai.Logger @@ -31,6 +25,7 @@ import System.Time.Extra import General.Log import Network.URI +import Prelude data Input = Input @@ -59,9 +54,6 @@ server :: Log -> CmdLine -> (Input -> IO Output) -> IO () -#ifdef PROFILE -server _ _ _ = return () -#else server log Server{..} act = do let host' = fromString $ @@ -101,4 +93,3 @@ OutputHTML msg -> responseLBS status200 [("content-type","text/html")] msg contentType = [(".html","text/html"),(".css","text/css"),(".js","text/javascript")] -#endif diff --git a/src/Input/Cabal.hs b/src/Input/Cabal.hs --- a/src/Input/Cabal.hs +++ b/src/Input/Cabal.hs @@ -99,9 +99,9 @@ -- rely on the fact the highest version is last (using lastValues) parseCabalTarball settings tarfile = do res <- runConduit $ - (sourceList =<< liftIO (tarballReadFiles tarfile)) =$= - mapC (first takeBaseName) =$= groupOnLastC fst =$= mapMC (\x -> do evaluate $ rnf x; return x) =$= - pipelineC 10 (mapC (second $ readCabal settings . lstrUnpack) =$= mapMC (\x -> do evaluate $ rnf x; return x) =$= sinkList) + (sourceList =<< liftIO (tarballReadFiles tarfile)) .| + mapC (first takeBaseName) .| groupOnLastC fst .| mapMC (\x -> do evaluate $ rnf x; return x) .| + pipelineC 10 (mapC (second $ readCabal settings . lstrUnpack) .| mapMC (\x -> do evaluate $ rnf x; return x) .| sinkList) return $ Map.fromList res diff --git a/src/Input/Download.hs b/src/Input/Download.hs --- a/src/Input/Download.hs +++ b/src/Input/Download.hs @@ -1,5 +1,4 @@ {-# LANGUAGE TupleSections #-} -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- Use conduitManagerSettings to work with http-conduit-2.1.6 and below module Input.Download(downloadInput) where @@ -31,8 +30,8 @@ downloadFile :: Bool -> FilePath -> String -> IO () downloadFile insecure file url = withSocketsDo $ do - request <- C.parseUrl url + let request = C.parseRequest_ url manager <- C.newManager $ C.mkManagerSettings (TLSSettingsSimple insecure False False) Nothing runResourceT $ do response <- C.http request manager - C.responseBody response C.$$ sinkFile file + C.runConduit $ C.responseBody response C..| sinkFile file diff --git a/src/Input/Haddock.hs b/src/Input/Haddock.hs --- a/src/Input/Haddock.hs +++ b/src/Input/Haddock.hs @@ -27,10 +27,10 @@ fakePackage name desc = (Just $ Target (hackagePackageURL name) Nothing Nothing "package" (renderPackage name) desc, [IPackage name]) -- | Given a file name (for errors), feed in lines to the conduit and emit either errors or items -parseHoogle :: Monad m => (String -> m ()) -> URL -> LStr -> Producer m (Maybe Target, [Item]) -parseHoogle warning url body = sourceLStr body =$= linesCR =$= zipFromC 1 =$= parserC warning =$= hierarchyC url =$= mapC (\x -> rnf x `seq` x) +parseHoogle :: Monad m => (String -> m ()) -> URL -> LStr -> ConduitM i (Maybe Target, [Item]) m () +parseHoogle warning url body = sourceLStr body .| linesCR .| zipFromC 1 .| parserC warning .| hierarchyC url .| mapC (\x -> rnf x `seq` x) -parserC :: Monad m => (String -> m ()) -> Conduit (Int, Str) m (Target, Entry) +parserC :: Monad m => (String -> m ()) -> ConduitM (Int, Str) (Target, Entry) m () parserC warning = f [] "" where f com url = do @@ -60,7 +60,7 @@ reformat = unlines . map strUnpack -hierarchyC :: Monad m => URL -> Conduit (Target, Entry) m (Maybe Target, [Item]) +hierarchyC :: Monad m => URL -> ConduitM (Target, Entry) (Maybe Target, [Item]) m () hierarchyC packageUrl = void $ mapAccumC f (Nothing, Nothing) where f (pkg, mod) (t, EPackage x) = ((Just (x, url), Nothing), (Just t{targetURL=url}, [IPackage x])) diff --git a/src/Input/Settings.hs b/src/Input/Settings.hs --- a/src/Input/Settings.hs +++ b/src/Input/Settings.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards, PatternGuards, TemplateHaskell #-} +{-# LANGUAGE RecordWildCards, PatternGuards, TemplateHaskell, CPP #-} -- | Module for reading settings files. @@ -53,7 +53,12 @@ loadSettings :: IO Settings loadSettings = do dataDir <- getDataDir +#ifdef PROFILE + -- profiling and TemplateHaskell don't play well + let backup = "" +#else let backup = $(runIO (readFileUTF8 "misc/settings.txt") >>= lift) +#endif src <- readFileSettings (dataDir "misc/settings.txt") backup return $ createSettings src diff --git a/src/Output/Items.hs b/src/Output/Items.hs --- a/src/Output/Items.hs +++ b/src/Output/Items.hs @@ -37,7 +37,7 @@ -- write all the URLs, docs and enough info to pretty print it to a result -- and replace each with an identifier (index in the space) - big reduction in memory -writeItems :: StoreWrite -> (Conduit (Maybe Target, item) IO (Maybe TargetId, item) -> IO a) -> IO a +writeItems :: StoreWrite -> (ConduitM (Maybe Target, item) (Maybe TargetId, item) IO () -> IO a) -> IO a writeItems store act = act $ do void $ (\f -> mapAccumMC f 0) $ \pos (target, item) -> case target of Nothing -> return (pos, (Nothing, item))