{-# LANGUAGE ViewPatterns, TupleSections, RecordWildCards, ScopedTypeVariables, PatternGuards #-}

module Action.Generate(actionGenerate) where

import Data.List.Extra
import System.FilePath
import System.Directory.Extra
import System.IO.Extra
import Data.Tuple.Extra
import Control.Exception.Extra
import Data.IORef
import Data.Maybe
import qualified Data.Set as Set
import qualified Data.Map.Strict as Map
import Control.Monad.Extra
import Data.Monoid
import Data.Ord
import System.Console.CmdArgs.Verbosity
import Prelude

import Output.Items
import Output.Tags
import Output.Names
import Output.Types
import Input.Cabal
import Input.Haddock
import Input.Download
import Input.Reorder
import Input.Set
import Input.Settings
import Input.Item
import General.Util
import General.Store
import General.Timing
import General.Str
import Action.CmdLine
import General.Conduit
import Control.DeepSeq

{-


data GenList
    = GenList_Package String -- a literally named package
    | GenList_GhcPkg String -- command to run, or "" for @ghc-pkg list@
    | GenList_Stackage String -- URL of stackage file, defaults to @http://www.stackage.org/lts/cabal.config@
    | GenList_Dependencies String -- dependencies in a named .cabal file
    | GenList_Sort String -- URL of file to sort by, defaults to @http://packdeps.haskellers.com/reverse@

data GenTags
    = GenTags_GhcPkg String -- command to run, or "" for @ghc-pkg dump@
    | GenTags_Diff FilePath -- a diff to apply to previous metadata
    | GenTags_Tarball String -- tarball of Cabal files, defaults to http://hackage.haskell.org/packages/index.tar.gz
    | GetTags_Cabal FilePath -- tarball to get tag information from

data GenData
    = GenData_File FilePath -- a file containing package data
    | GenData_Tarball String -- URL where a tarball of data files resides


* `hoogle generate` - generate for all things in Stackage based on Hackage information.
* `hoogle generate --source=file1.txt --source=local --source=stackage --source=hackage --source=tarball.tar.gz`

Which files you want to index. Currently the list on stackage, could be those locally installed, those in a .cabal file etc. A `--list` flag, defaults to `stackage=url`. Can also be `ghc-pkg`, `ghc-pkg=user` `ghc-pkg=global`. `name=p1`.

Extra metadata you want to apply. Could be a file. `+shake author:Neil-Mitchell`, `-shake author:Neil-Mitchel`. Can be sucked out of .cabal files. A `--tags` flag, defaults to `tarball=url` and `diff=renamings.txt`.

Where the haddock files are. Defaults to `tarball=hackage-url`. Can also be `file=p1.txt`. Use `--data` flag.

Defaults to: `hoogle generate --list=ghc-pkg --list=constrain=stackage-url`.

Three pieces of data:

* Which packages to index, in order.
* Metadata.


generate :: Maybe Int -> [GenList] -> [GenTags] -> [GenData] -> IO ()
-- how often to redownload, where to put the files



generate :: FilePath -> [(String, [(String, String)])] -> [(String, LBS.ByteString)] -> IO ()
generate output metadata = ...
-}


-- -- generate all
-- @tagsoup -- generate tagsoup
-- @tagsoup filter -- search the tagsoup package
-- filter -- search all

type Download = String -> URL -> IO FilePath

readHaskellOnline :: Timing -> Settings -> Download -> IO (Map.Map PkgName Package, Set.Set PkgName, ConduitT () (PkgName, URL, LBStr) IO ())
readHaskellOnline :: Timing
-> Settings
-> Download
-> IO
     (Map PkgName Package, Set PkgName,
      ConduitT () (PkgName, URL, LBStr) IO ())
readHaskellOnline Timing
timing Settings
settings Download
download = do
    URL
stackageLts <- Download
download URL
"haskell-stackage-lts.txt" URL
"https://www.stackage.org/nightly/cabal.config"
    URL
stackageNightly <- Download
download URL
"haskell-stackage-nightly.txt" URL
"https://www.stackage.org/lts/cabal.config"
    URL
platform <- Download
download URL
"haskell-platform.txt" URL
"https://raw.githubusercontent.com/haskell/haskell-platform/master/hptool/src/Releases2015.hs"
    URL
cabals   <- Download
download URL
"haskell-cabal.tar.gz" URL
"https://hackage.haskell.org/packages/index.tar.gz"
    URL
hoogles  <- Download
download URL
"haskell-hoogle.tar.gz" URL
"https://hackage.haskell.org/packages/hoogle.tar.gz"

    -- peakMegabytesAllocated = 2
    Set PkgName
setStackage <- (URL -> PkgName) -> Set URL -> Set PkgName
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map URL -> PkgName
strPack (Set URL -> Set PkgName) -> IO (Set URL) -> IO (Set PkgName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Set URL -> Set URL -> Set URL
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Set URL -> Set URL -> Set URL)
-> IO (Set URL) -> IO (Set URL -> Set URL)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> URL -> IO (Set URL)
setStackage URL
stackageLts IO (Set URL -> Set URL) -> IO (Set URL) -> IO (Set URL)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> URL -> IO (Set URL)
setStackage URL
stackageNightly)
    Set PkgName
setPlatform <- (URL -> PkgName) -> Set URL -> Set PkgName
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map URL -> PkgName
strPack (Set URL -> Set PkgName) -> IO (Set URL) -> IO (Set PkgName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> URL -> IO (Set URL)
setPlatform URL
platform
    Set PkgName
setGHC <- (URL -> PkgName) -> Set URL -> Set PkgName
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map URL -> PkgName
strPack (Set URL -> Set PkgName) -> IO (Set URL) -> IO (Set PkgName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> URL -> IO (Set URL)
setGHC URL
platform

    Map PkgName Package
cbl <- Timing
-> URL -> IO (Map PkgName Package) -> IO (Map PkgName Package)
forall (m :: * -> *) a. MonadIO m => Timing -> URL -> m a -> m a
timed Timing
timing URL
"Reading Cabal" (IO (Map PkgName Package) -> IO (Map PkgName Package))
-> IO (Map PkgName Package) -> IO (Map PkgName Package)
forall a b. (a -> b) -> a -> b
$ Settings -> URL -> IO (Map PkgName Package)
parseCabalTarball Settings
settings URL
cabals
    let want :: Set PkgName
want = PkgName -> Set PkgName -> Set PkgName
forall a. Ord a => a -> Set a -> Set a
Set.insert (URL -> PkgName
strPack URL
"ghc") (Set PkgName -> Set PkgName) -> Set PkgName -> Set PkgName
forall a b. (a -> b) -> a -> b
$ [Set PkgName] -> Set PkgName
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [Set PkgName
setStackage, Set PkgName
setPlatform, Set PkgName
setGHC]
    Map PkgName Package
cbl <- Map PkgName Package -> IO (Map PkgName Package)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PkgName Package -> IO (Map PkgName Package))
-> Map PkgName Package -> IO (Map PkgName Package)
forall a b. (a -> b) -> a -> b
$ ((PkgName -> Package -> Package)
 -> Map PkgName Package -> Map PkgName Package)
-> Map PkgName Package
-> (PkgName -> Package -> Package)
-> Map PkgName Package
forall a b c. (a -> b -> c) -> b -> a -> c
flip (PkgName -> Package -> Package)
-> Map PkgName Package -> Map PkgName Package
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey Map PkgName Package
cbl ((PkgName -> Package -> Package) -> Map PkgName Package)
-> (PkgName -> Package -> Package) -> Map PkgName Package
forall a b. (a -> b) -> a -> b
$ \PkgName
name Package
p ->
        Package
p{packageTags :: [(PkgName, PkgName)]
packageTags =
            [(URL -> PkgName
strPack URL
"set",URL -> PkgName
strPack URL
"included-with-ghc") | PkgName
name PkgName -> Set PkgName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PkgName
setGHC] [(PkgName, PkgName)]
-> [(PkgName, PkgName)] -> [(PkgName, PkgName)]
forall a. [a] -> [a] -> [a]
++
            [(URL -> PkgName
strPack URL
"set",URL -> PkgName
strPack URL
"haskell-platform") | PkgName
name PkgName -> Set PkgName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PkgName
setPlatform] [(PkgName, PkgName)]
-> [(PkgName, PkgName)] -> [(PkgName, PkgName)]
forall a. [a] -> [a] -> [a]
++
            [(URL -> PkgName
strPack URL
"set",URL -> PkgName
strPack URL
"stackage") | PkgName
name PkgName -> Set PkgName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PkgName
setStackage] [(PkgName, PkgName)]
-> [(PkgName, PkgName)] -> [(PkgName, PkgName)]
forall a. [a] -> [a] -> [a]
++
            Package -> [(PkgName, PkgName)]
packageTags Package
p}

    let source :: ConduitT i (PkgName, URL, LBStr) IO ()
source = do
            [(URL, LBStr)]
tar <- IO [(URL, LBStr)]
-> ConduitT i (PkgName, URL, LBStr) IO [(URL, LBStr)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(URL, LBStr)]
 -> ConduitT i (PkgName, URL, LBStr) IO [(URL, LBStr)])
-> IO [(URL, LBStr)]
-> ConduitT i (PkgName, URL, LBStr) IO [(URL, LBStr)]
forall a b. (a -> b) -> a -> b
$ URL -> IO [(URL, LBStr)]
tarballReadFiles URL
hoogles
            [(URL, LBStr)]
-> ((URL, LBStr) -> ConduitT i (PkgName, URL, LBStr) IO ())
-> ConduitT i (PkgName, URL, LBStr) IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(URL, LBStr)]
tar (((URL, LBStr) -> ConduitT i (PkgName, URL, LBStr) IO ())
 -> ConduitT i (PkgName, URL, LBStr) IO ())
-> ((URL, LBStr) -> ConduitT i (PkgName, URL, LBStr) IO ())
-> ConduitT i (PkgName, URL, LBStr) IO ()
forall a b. (a -> b) -> a -> b
$ \(URL -> PkgName
strPack (URL -> PkgName) -> (URL -> URL) -> URL -> PkgName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URL -> URL
takeBaseName -> PkgName
name, LBStr
src) ->
                (PkgName, URL, LBStr) -> ConduitT i (PkgName, URL, LBStr) IO ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (PkgName
name, PkgName -> URL
hackagePackageURL PkgName
name, LBStr
src)
    (Map PkgName Package, Set PkgName,
 ConduitT () (PkgName, URL, LBStr) IO ())
-> IO
     (Map PkgName Package, Set PkgName,
      ConduitT () (PkgName, URL, LBStr) IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PkgName Package
cbl, Set PkgName
want, ConduitT () (PkgName, URL, LBStr) IO ()
forall i. ConduitT i (PkgName, URL, LBStr) IO ()
source)


readHaskellDirs :: Timing -> Settings -> [FilePath] -> IO (Map.Map PkgName Package, Set.Set PkgName, ConduitT () (PkgName, URL, LBStr) IO ())
readHaskellDirs :: Timing
-> Settings
-> [URL]
-> IO
     (Map PkgName Package, Set PkgName,
      ConduitT () (PkgName, URL, LBStr) IO ())
readHaskellDirs Timing
timing Settings
settings [URL]
dirs = do
    [URL]
files <- (URL -> IO [URL]) -> [URL] -> IO [URL]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM URL -> IO [URL]
listFilesRecursive [URL]
dirs
    -- We reverse/sort the list because of #206
    -- Two identical package names with different versions might be foo-2.0 and foo-1.0
    -- We never distinguish on versions, so they are considered equal when reordering
    -- So put 2.0 first in the list and rely on stable sorting. A bit of a hack.
    let order :: URL -> (URL, Down [Int])
order URL
a = ([Int] -> Down [Int]) -> (URL, [Int]) -> (URL, Down [Int])
forall b b' a. (b -> b') -> (a, b) -> (a, b')
second [Int] -> Down [Int]
forall a. a -> Down a
Down ((URL, [Int]) -> (URL, Down [Int]))
-> (URL, [Int]) -> (URL, Down [Int])
forall a b. (a -> b) -> a -> b
$ URL -> (URL, [Int])
parseTrailingVersion URL
a
    let packages :: [(PkgName, URL)]
packages = (URL -> (PkgName, URL)) -> [URL] -> [(PkgName, URL)]
forall a b. (a -> b) -> [a] -> [b]
map (URL -> PkgName
strPack (URL -> PkgName) -> (URL -> URL) -> URL -> PkgName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URL -> URL
takeBaseName (URL -> PkgName) -> (URL -> URL) -> URL -> (PkgName, URL)
forall a b c. (a -> b) -> (a -> c) -> a -> (b, c)
&&& URL -> URL
forall a. a -> a
id) ([URL] -> [(PkgName, URL)]) -> [URL] -> [(PkgName, URL)]
forall a b. (a -> b) -> a -> b
$ (URL -> [(URL, Down [Int])]) -> [URL] -> [URL]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn ((URL -> (URL, Down [Int])) -> [URL] -> [(URL, Down [Int])]
forall a b. (a -> b) -> [a] -> [b]
map URL -> (URL, Down [Int])
order ([URL] -> [(URL, Down [Int])])
-> (URL -> [URL]) -> URL -> [(URL, Down [Int])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URL -> [URL]
splitDirectories) ([URL] -> [URL]) -> [URL] -> [URL]
forall a b. (a -> b) -> a -> b
$ (URL -> Bool) -> [URL] -> [URL]
forall a. (a -> Bool) -> [a] -> [a]
filter (URL -> URL -> Bool
forall a. Eq a => a -> a -> Bool
(==) URL
".txt" (URL -> Bool) -> (URL -> URL) -> URL -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URL -> URL
takeExtension) [URL]
files
    [(PkgName, Package)]
cabals <- (URL -> IO (PkgName, Package)) -> [URL] -> IO [(PkgName, Package)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM URL -> IO (PkgName, Package)
parseCabal ([URL] -> IO [(PkgName, Package)])
-> [URL] -> IO [(PkgName, Package)]
forall a b. (a -> b) -> a -> b
$ (URL -> Bool) -> [URL] -> [URL]
forall a. (a -> Bool) -> [a] -> [a]
filter (URL -> URL -> Bool
forall a. Eq a => a -> a -> Bool
(==) URL
".cabal" (URL -> Bool) -> (URL -> URL) -> URL -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URL -> URL
takeExtension) [URL]
files
    let source :: ConduitT i (PkgName, URL, LBStr) IO ()
source = [(PkgName, URL)]
-> ((PkgName, URL) -> ConduitT i (PkgName, URL, LBStr) IO ())
-> ConduitT i (PkgName, URL, LBStr) IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(PkgName, URL)]
packages (((PkgName, URL) -> ConduitT i (PkgName, URL, LBStr) IO ())
 -> ConduitT i (PkgName, URL, LBStr) IO ())
-> ((PkgName, URL) -> ConduitT i (PkgName, URL, LBStr) IO ())
-> ConduitT i (PkgName, URL, LBStr) IO ()
forall a b. (a -> b) -> a -> b
$ \(PkgName
name, URL
file) -> do
            BStr
src <- IO BStr -> ConduitT i (PkgName, URL, LBStr) IO BStr
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO BStr -> ConduitT i (PkgName, URL, LBStr) IO BStr)
-> IO BStr -> ConduitT i (PkgName, URL, LBStr) IO BStr
forall a b. (a -> b) -> a -> b
$ URL -> IO BStr
bstrReadFile URL
file
            URL
dir <- IO URL -> ConduitT i (PkgName, URL, LBStr) IO URL
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO URL -> ConduitT i (PkgName, URL, LBStr) IO URL)
-> IO URL -> ConduitT i (PkgName, URL, LBStr) IO URL
forall a b. (a -> b) -> a -> b
$ URL -> IO URL
canonicalizePath (URL -> IO URL) -> URL -> IO URL
forall a b. (a -> b) -> a -> b
$ URL -> URL
takeDirectory URL
file
            let url :: URL
url = URL
"file://" URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ [Char
'/' | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ URL
"/" URL -> URL -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` URL
dir] URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ URL -> URL -> URL -> URL
forall a. (Partial, Eq a) => [a] -> [a] -> [a] -> [a]
replace URL
"\\" URL
"/" URL
dir URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ URL
"/"
            (PkgName, URL, LBStr) -> ConduitT i (PkgName, URL, LBStr) IO ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (PkgName
name, URL
url, [BStr] -> LBStr
lbstrFromChunks [BStr
src])
    (Map PkgName Package, Set PkgName,
 ConduitT () (PkgName, URL, LBStr) IO ())
-> IO
     (Map PkgName Package, Set PkgName,
      ConduitT () (PkgName, URL, LBStr) IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PkgName Package -> Map PkgName Package -> Map PkgName Package
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union
                ([(PkgName, Package)] -> Map PkgName Package
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PkgName, Package)]
cabals)
                ((Package -> Package -> Package)
-> [(PkgName, Package)] -> Map PkgName Package
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Package -> Package -> Package
forall a. Semigroup a => a -> a -> a
(<>) ([(PkgName, Package)] -> Map PkgName Package)
-> [(PkgName, Package)] -> Map PkgName Package
forall a b. (a -> b) -> a -> b
$ ((PkgName, URL) -> (PkgName, Package))
-> [(PkgName, URL)] -> [(PkgName, Package)]
forall a b. (a -> b) -> [a] -> [b]
map (PkgName, URL) -> (PkgName, Package)
forall a. (a, URL) -> (a, Package)
generateBarePackage [(PkgName, URL)]
packages)
           ,[PkgName] -> Set PkgName
forall a. Ord a => [a] -> Set a
Set.fromList ([PkgName] -> Set PkgName) -> [PkgName] -> Set PkgName
forall a b. (a -> b) -> a -> b
$ ((PkgName, URL) -> PkgName) -> [(PkgName, URL)] -> [PkgName]
forall a b. (a -> b) -> [a] -> [b]
map (PkgName, URL) -> PkgName
forall a b. (a, b) -> a
fst [(PkgName, URL)]
packages, ConduitT () (PkgName, URL, LBStr) IO ()
forall i. ConduitT i (PkgName, URL, LBStr) IO ()
source)
  where
    parseCabal :: URL -> IO (PkgName, Package)
parseCabal URL
fp = do
        URL
src <- URL -> IO URL
readFileUTF8' URL
fp
        let pkg :: Package
pkg = Settings -> URL -> Package
readCabal Settings
settings URL
src
        (PkgName, Package) -> IO (PkgName, Package)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (URL -> PkgName
strPack (URL -> PkgName) -> URL -> PkgName
forall a b. (a -> b) -> a -> b
$ URL -> URL
takeBaseName URL
fp, Package
pkg)

    generateBarePackage :: (a, URL) -> (a, Package)
generateBarePackage (a
name, URL
file) =
        (a
name, Package
forall a. Monoid a => a
mempty{packageTags :: [(PkgName, PkgName)]
packageTags = (URL -> PkgName
strPack URL
"set", URL -> PkgName
strPack URL
"all") (PkgName, PkgName) -> [(PkgName, PkgName)] -> [(PkgName, PkgName)]
forall a. a -> [a] -> [a]
: [(PkgName, PkgName)]
sets})
      where
        sets :: [(PkgName, PkgName)]
sets = (URL -> (PkgName, PkgName)) -> [URL] -> [(PkgName, PkgName)]
forall a b. (a -> b) -> [a] -> [b]
map URL -> (PkgName, PkgName)
setFromDir ([URL] -> [(PkgName, PkgName)]) -> [URL] -> [(PkgName, PkgName)]
forall a b. (a -> b) -> a -> b
$ (URL -> Bool) -> [URL] -> [URL]
forall a. (a -> Bool) -> [a] -> [a]
filter (URL -> URL -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` URL
file) [URL]
dirs
        setFromDir :: URL -> (PkgName, PkgName)
setFromDir URL
dir = (URL -> PkgName
strPack URL
"set", URL -> PkgName
strPack (URL -> PkgName) -> URL -> PkgName
forall a b. (a -> b) -> a -> b
$ URL -> URL
takeFileName (URL -> URL) -> URL -> URL
forall a b. (a -> b) -> a -> b
$ URL -> URL
dropTrailingPathSeparator URL
dir)

readFregeOnline :: Timing -> Download -> IO (Map.Map PkgName Package, Set.Set PkgName, ConduitT () (PkgName, URL, LBStr) IO ())
readFregeOnline :: Timing
-> Download
-> IO
     (Map PkgName Package, Set PkgName,
      ConduitT () (PkgName, URL, LBStr) IO ())
readFregeOnline Timing
timing Download
download = do
    URL
frege <- Download
download URL
"frege-frege.txt" URL
"http://try.frege-lang.org/hoogle-frege.txt"
    let source :: ConduitT i (PkgName, URL, LBStr) IO ()
source = do
            BStr
src <- IO BStr -> ConduitT i (PkgName, URL, LBStr) IO BStr
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO BStr -> ConduitT i (PkgName, URL, LBStr) IO BStr)
-> IO BStr -> ConduitT i (PkgName, URL, LBStr) IO BStr
forall a b. (a -> b) -> a -> b
$ URL -> IO BStr
bstrReadFile URL
frege
            (PkgName, URL, LBStr) -> ConduitT i (PkgName, URL, LBStr) IO ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (URL -> PkgName
strPack URL
"frege", URL
"http://google.com/", [BStr] -> LBStr
lbstrFromChunks [BStr
src])
    (Map PkgName Package, Set PkgName,
 ConduitT () (PkgName, URL, LBStr) IO ())
-> IO
     (Map PkgName Package, Set PkgName,
      ConduitT () (PkgName, URL, LBStr) IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PkgName Package
forall k a. Map k a
Map.empty, PkgName -> Set PkgName
forall a. a -> Set a
Set.singleton (PkgName -> Set PkgName) -> PkgName -> Set PkgName
forall a b. (a -> b) -> a -> b
$ URL -> PkgName
strPack URL
"frege", ConduitT () (PkgName, URL, LBStr) IO ()
forall i. ConduitT i (PkgName, URL, LBStr) IO ()
source)


readHaskellGhcpkg :: Timing -> Settings -> IO (Map.Map PkgName Package, Set.Set PkgName, ConduitT () (PkgName, URL, LBStr) IO ())
readHaskellGhcpkg :: Timing
-> Settings
-> IO
     (Map PkgName Package, Set PkgName,
      ConduitT () (PkgName, URL, LBStr) IO ())
readHaskellGhcpkg Timing
timing Settings
settings = do
    Map PkgName Package
cbl <- Timing
-> URL -> IO (Map PkgName Package) -> IO (Map PkgName Package)
forall (m :: * -> *) a. MonadIO m => Timing -> URL -> m a -> m a
timed Timing
timing URL
"Reading ghc-pkg" (IO (Map PkgName Package) -> IO (Map PkgName Package))
-> IO (Map PkgName Package) -> IO (Map PkgName Package)
forall a b. (a -> b) -> a -> b
$ Settings -> IO (Map PkgName Package)
readGhcPkg Settings
settings
    let source :: ConduitT i (PkgName, URL, LBStr) IO ()
source =
            [(PkgName, Package)]
-> ((PkgName, Package) -> ConduitT i (PkgName, URL, LBStr) IO ())
-> ConduitT i (PkgName, URL, LBStr) IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map PkgName Package -> [(PkgName, Package)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PkgName Package
cbl) (((PkgName, Package) -> ConduitT i (PkgName, URL, LBStr) IO ())
 -> ConduitT i (PkgName, URL, LBStr) IO ())
-> ((PkgName, Package) -> ConduitT i (PkgName, URL, LBStr) IO ())
-> ConduitT i (PkgName, URL, LBStr) IO ()
forall a b. (a -> b) -> a -> b
$ \(PkgName
name,Package{Bool
[(PkgName, PkgName)]
[PkgName]
Maybe URL
PkgName
packageDocs :: Package -> Maybe URL
packageDepends :: Package -> [PkgName]
packageVersion :: Package -> PkgName
packageSynopsis :: Package -> PkgName
packageLibrary :: Package -> Bool
packageDocs :: Maybe URL
packageDepends :: [PkgName]
packageVersion :: PkgName
packageSynopsis :: PkgName
packageLibrary :: Bool
packageTags :: [(PkgName, PkgName)]
packageTags :: Package -> [(PkgName, PkgName)]
..}) -> Maybe URL
-> (URL -> ConduitT i (PkgName, URL, LBStr) IO ())
-> ConduitT i (PkgName, URL, LBStr) IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe URL
packageDocs ((URL -> ConduitT i (PkgName, URL, LBStr) IO ())
 -> ConduitT i (PkgName, URL, LBStr) IO ())
-> (URL -> ConduitT i (PkgName, URL, LBStr) IO ())
-> ConduitT i (PkgName, URL, LBStr) IO ()
forall a b. (a -> b) -> a -> b
$ \URL
docs -> do
                let file :: URL
file = URL
docs URL -> URL -> URL
</> PkgName -> URL
strUnpack PkgName
name URL -> URL -> URL
<.> URL
"txt"
                ConduitT i (PkgName, URL, LBStr) IO Bool
-> ConduitT i (PkgName, URL, LBStr) IO ()
-> ConduitT i (PkgName, URL, LBStr) IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (IO Bool -> ConduitT i (PkgName, URL, LBStr) IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ConduitT i (PkgName, URL, LBStr) IO Bool)
-> IO Bool -> ConduitT i (PkgName, URL, LBStr) IO Bool
forall a b. (a -> b) -> a -> b
$ URL -> IO Bool
doesFileExist URL
file) (ConduitT i (PkgName, URL, LBStr) IO ()
 -> ConduitT i (PkgName, URL, LBStr) IO ())
-> ConduitT i (PkgName, URL, LBStr) IO ()
-> ConduitT i (PkgName, URL, LBStr) IO ()
forall a b. (a -> b) -> a -> b
$ do
                    BStr
src <- IO BStr -> ConduitT i (PkgName, URL, LBStr) IO BStr
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO BStr -> ConduitT i (PkgName, URL, LBStr) IO BStr)
-> IO BStr -> ConduitT i (PkgName, URL, LBStr) IO BStr
forall a b. (a -> b) -> a -> b
$ URL -> IO BStr
bstrReadFile URL
file
                    URL
docs <- IO URL -> ConduitT i (PkgName, URL, LBStr) IO URL
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO URL -> ConduitT i (PkgName, URL, LBStr) IO URL)
-> IO URL -> ConduitT i (PkgName, URL, LBStr) IO URL
forall a b. (a -> b) -> a -> b
$ URL -> IO URL
canonicalizePath URL
docs
                    let url :: URL
url = URL
"file://" URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ [Char
'/' | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> URL -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isPathSeparator (URL -> Bool) -> URL -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> URL -> URL
forall a. Int -> [a] -> [a]
take Int
1 URL
docs] URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++
                              URL -> URL -> URL -> URL
forall a. (Partial, Eq a) => [a] -> [a] -> [a] -> [a]
replace URL
"\\" URL
"/" (URL -> URL
addTrailingPathSeparator URL
docs)
                    (PkgName, URL, LBStr) -> ConduitT i (PkgName, URL, LBStr) IO ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (PkgName
name, URL
url, [BStr] -> LBStr
lbstrFromChunks [BStr
src])
    Map PkgName Package
cbl <- Map PkgName Package -> IO (Map PkgName Package)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PkgName Package -> IO (Map PkgName Package))
-> Map PkgName Package -> IO (Map PkgName Package)
forall a b. (a -> b) -> a -> b
$ let ts :: [(PkgName, PkgName)]
ts = ((URL, URL) -> (PkgName, PkgName))
-> [(URL, URL)] -> [(PkgName, PkgName)]
forall a b. (a -> b) -> [a] -> [b]
map ((URL -> PkgName) -> (URL, URL) -> (PkgName, PkgName)
forall a b. (a -> b) -> (a, a) -> (b, b)
both URL -> PkgName
strPack) [(URL
"set",URL
"stackage"),(URL
"set",URL
"installed")]
                    in (Package -> Package) -> Map PkgName Package -> Map PkgName Package
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\Package
p -> Package
p{packageTags :: [(PkgName, PkgName)]
packageTags = [(PkgName, PkgName)]
ts [(PkgName, PkgName)]
-> [(PkgName, PkgName)] -> [(PkgName, PkgName)]
forall a. [a] -> [a] -> [a]
++ Package -> [(PkgName, PkgName)]
packageTags Package
p}) Map PkgName Package
cbl
    (Map PkgName Package, Set PkgName,
 ConduitT () (PkgName, URL, LBStr) IO ())
-> IO
     (Map PkgName Package, Set PkgName,
      ConduitT () (PkgName, URL, LBStr) IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PkgName Package
cbl, Map PkgName Package -> Set PkgName
forall k a. Map k a -> Set k
Map.keysSet Map PkgName Package
cbl, ConduitT () (PkgName, URL, LBStr) IO ()
forall i. ConduitT i (PkgName, URL, LBStr) IO ()
source)

readHaskellHaddock :: Timing -> Settings -> FilePath -> IO (Map.Map PkgName Package, Set.Set PkgName, ConduitT () (PkgName, URL, LBStr) IO ())
readHaskellHaddock :: Timing
-> Settings
-> URL
-> IO
     (Map PkgName Package, Set PkgName,
      ConduitT () (PkgName, URL, LBStr) IO ())
readHaskellHaddock Timing
timing Settings
settings URL
docBaseDir = do
    Map PkgName Package
cbl <- Timing
-> URL -> IO (Map PkgName Package) -> IO (Map PkgName Package)
forall (m :: * -> *) a. MonadIO m => Timing -> URL -> m a -> m a
timed Timing
timing URL
"Reading ghc-pkg" (IO (Map PkgName Package) -> IO (Map PkgName Package))
-> IO (Map PkgName Package) -> IO (Map PkgName Package)
forall a b. (a -> b) -> a -> b
$ Settings -> IO (Map PkgName Package)
readGhcPkg Settings
settings
    let source :: ConduitT i (PkgName, URL, LBStr) IO ()
source =
            [(PkgName, Package)]
-> ((PkgName, Package) -> ConduitT i (PkgName, URL, LBStr) IO ())
-> ConduitT i (PkgName, URL, LBStr) IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map PkgName Package -> [(PkgName, Package)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PkgName Package
cbl) (((PkgName, Package) -> ConduitT i (PkgName, URL, LBStr) IO ())
 -> ConduitT i (PkgName, URL, LBStr) IO ())
-> ((PkgName, Package) -> ConduitT i (PkgName, URL, LBStr) IO ())
-> ConduitT i (PkgName, URL, LBStr) IO ()
forall a b. (a -> b) -> a -> b
$ \(PkgName
name, p :: Package
p@Package{Bool
[(PkgName, PkgName)]
[PkgName]
Maybe URL
PkgName
packageDocs :: Maybe URL
packageDepends :: [PkgName]
packageVersion :: PkgName
packageSynopsis :: PkgName
packageLibrary :: Bool
packageTags :: [(PkgName, PkgName)]
packageDocs :: Package -> Maybe URL
packageDepends :: Package -> [PkgName]
packageVersion :: Package -> PkgName
packageSynopsis :: Package -> PkgName
packageLibrary :: Package -> Bool
packageTags :: Package -> [(PkgName, PkgName)]
..}) -> do
                let docs :: URL
docs = URL -> Package -> URL
docDir (PkgName -> URL
strUnpack PkgName
name) Package
p
                    file :: URL
file = URL
docBaseDir URL -> URL -> URL
</> URL
docs URL -> URL -> URL
</> (PkgName -> URL
strUnpack PkgName
name) URL -> URL -> URL
<.> URL
"txt"
                ConduitT i (PkgName, URL, LBStr) IO Bool
-> ConduitT i (PkgName, URL, LBStr) IO ()
-> ConduitT i (PkgName, URL, LBStr) IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (IO Bool -> ConduitT i (PkgName, URL, LBStr) IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ConduitT i (PkgName, URL, LBStr) IO Bool)
-> IO Bool -> ConduitT i (PkgName, URL, LBStr) IO Bool
forall a b. (a -> b) -> a -> b
$ URL -> IO Bool
doesFileExist URL
file) (ConduitT i (PkgName, URL, LBStr) IO ()
 -> ConduitT i (PkgName, URL, LBStr) IO ())
-> ConduitT i (PkgName, URL, LBStr) IO ()
-> ConduitT i (PkgName, URL, LBStr) IO ()
forall a b. (a -> b) -> a -> b
$ do
                    BStr
src <- IO BStr -> ConduitT i (PkgName, URL, LBStr) IO BStr
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO BStr -> ConduitT i (PkgName, URL, LBStr) IO BStr)
-> IO BStr -> ConduitT i (PkgName, URL, LBStr) IO BStr
forall a b. (a -> b) -> a -> b
$ URL -> IO BStr
bstrReadFile URL
file
                    let url :: URL
url = [Char
'/' | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> URL -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isPathSeparator (URL -> Bool) -> URL -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> URL -> URL
forall a. Int -> [a] -> [a]
take Int
1 URL
docs] URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++
                              URL -> URL -> URL -> URL
forall a. (Partial, Eq a) => [a] -> [a] -> [a] -> [a]
replace URL
"\\" URL
"/" (URL -> URL
addTrailingPathSeparator URL
docs)
                    (PkgName, URL, LBStr) -> ConduitT i (PkgName, URL, LBStr) IO ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (PkgName
name, URL
url, [BStr] -> LBStr
lbstrFromChunks [BStr
src])
    Map PkgName Package
cbl <- Map PkgName Package -> IO (Map PkgName Package)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PkgName Package -> IO (Map PkgName Package))
-> Map PkgName Package -> IO (Map PkgName Package)
forall a b. (a -> b) -> a -> b
$ let ts :: [(PkgName, PkgName)]
ts = ((URL, URL) -> (PkgName, PkgName))
-> [(URL, URL)] -> [(PkgName, PkgName)]
forall a b. (a -> b) -> [a] -> [b]
map ((URL -> PkgName) -> (URL, URL) -> (PkgName, PkgName)
forall a b. (a -> b) -> (a, a) -> (b, b)
both URL -> PkgName
strPack) [(URL
"set",URL
"stackage"),(URL
"set",URL
"installed")]
                    in (Package -> Package) -> Map PkgName Package -> Map PkgName Package
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\Package
p -> Package
p{packageTags :: [(PkgName, PkgName)]
packageTags = [(PkgName, PkgName)]
ts [(PkgName, PkgName)]
-> [(PkgName, PkgName)] -> [(PkgName, PkgName)]
forall a. [a] -> [a] -> [a]
++ Package -> [(PkgName, PkgName)]
packageTags Package
p}) Map PkgName Package
cbl
    (Map PkgName Package, Set PkgName,
 ConduitT () (PkgName, URL, LBStr) IO ())
-> IO
     (Map PkgName Package, Set PkgName,
      ConduitT () (PkgName, URL, LBStr) IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PkgName Package
cbl, Map PkgName Package -> Set PkgName
forall k a. Map k a -> Set k
Map.keysSet Map PkgName Package
cbl, ConduitT () (PkgName, URL, LBStr) IO ()
forall i. ConduitT i (PkgName, URL, LBStr) IO ()
source)

    where docDir :: URL -> Package -> URL
docDir URL
name Package{Bool
[(PkgName, PkgName)]
[PkgName]
Maybe URL
PkgName
packageDocs :: Maybe URL
packageDepends :: [PkgName]
packageVersion :: PkgName
packageSynopsis :: PkgName
packageLibrary :: Bool
packageTags :: [(PkgName, PkgName)]
packageDocs :: Package -> Maybe URL
packageDepends :: Package -> [PkgName]
packageVersion :: Package -> PkgName
packageSynopsis :: Package -> PkgName
packageLibrary :: Package -> Bool
packageTags :: Package -> [(PkgName, PkgName)]
..} = URL
name URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ URL
"-" URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ PkgName -> URL
strUnpack PkgName
packageVersion

actionGenerate :: CmdLine -> IO ()
actionGenerate :: CmdLine -> IO ()
actionGenerate g :: CmdLine
g@Generate{Bool
URL
[URL]
Maybe Bool
Maybe Int
Maybe URL
Language
debug :: CmdLine -> Bool
haddock :: CmdLine -> Maybe URL
local_ :: CmdLine -> [URL]
include :: CmdLine -> [URL]
insecure :: CmdLine -> Bool
download :: CmdLine -> Maybe Bool
language :: CmdLine -> Language
count :: CmdLine -> Maybe Int
database :: CmdLine -> URL
language :: Language
debug :: Bool
haddock :: Maybe URL
local_ :: [URL]
count :: Maybe Int
include :: [URL]
insecure :: Bool
database :: URL
download :: Maybe Bool
..} = Maybe URL -> (Timing -> IO ()) -> IO ()
forall a. Maybe URL -> (Timing -> IO a) -> IO a
withTiming (if Bool
debug then URL -> Maybe URL
forall a. a -> Maybe a
Just (URL -> Maybe URL) -> URL -> Maybe URL
forall a b. (a -> b) -> a -> b
$ URL -> URL -> URL
replaceExtension URL
database URL
"timing" else Maybe URL
forall a. Maybe a
Nothing) ((Timing -> IO ()) -> IO ()) -> (Timing -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Timing
timing -> do
    URL -> IO ()
putStrLn URL
"Starting generate"
    Bool -> URL -> IO ()
createDirectoryIfMissing Bool
True (URL -> IO ()) -> URL -> IO ()
forall a b. (a -> b) -> a -> b
$ URL -> URL
takeDirectory URL
database
    IO () -> IO ()
whenLoud (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ URL -> IO ()
putStrLn (URL -> IO ()) -> URL -> IO ()
forall a b. (a -> b) -> a -> b
$ URL
"Generating files to " URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ URL -> URL
takeDirectory URL
database

    Download
download <- Download -> IO Download
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Download -> IO Download) -> Download -> IO Download
forall a b. (a -> b) -> a -> b
$ Timing -> Bool -> Maybe Bool -> URL -> Download
downloadInput Timing
timing Bool
insecure Maybe Bool
download (URL -> URL
takeDirectory URL
database)
    Settings
settings <- IO Settings
loadSettings
    (Map PkgName Package
cbl, Set PkgName
want, ConduitT () (PkgName, URL, LBStr) IO ()
source) <- case Language
language of
        Language
Haskell | Just URL
dir <- Maybe URL
haddock -> Timing
-> Settings
-> URL
-> IO
     (Map PkgName Package, Set PkgName,
      ConduitT () (PkgName, URL, LBStr) IO ())
readHaskellHaddock Timing
timing Settings
settings URL
dir
                | [URL
""] <- [URL]
local_ -> Timing
-> Settings
-> IO
     (Map PkgName Package, Set PkgName,
      ConduitT () (PkgName, URL, LBStr) IO ())
readHaskellGhcpkg Timing
timing Settings
settings
                | [] <- [URL]
local_ -> Timing
-> Settings
-> Download
-> IO
     (Map PkgName Package, Set PkgName,
      ConduitT () (PkgName, URL, LBStr) IO ())
readHaskellOnline Timing
timing Settings
settings Download
download
                | Bool
otherwise -> Timing
-> Settings
-> [URL]
-> IO
     (Map PkgName Package, Set PkgName,
      ConduitT () (PkgName, URL, LBStr) IO ())
readHaskellDirs Timing
timing Settings
settings [URL]
local_
        Language
Frege | [] <- [URL]
local_ -> Timing
-> Download
-> IO
     (Map PkgName Package, Set PkgName,
      ConduitT () (PkgName, URL, LBStr) IO ())
readFregeOnline Timing
timing Download
download
              | Bool
otherwise -> URL
-> IO
     (Map PkgName Package, Set PkgName,
      ConduitT () (PkgName, URL, LBStr) IO ())
forall a. Partial => URL -> IO a
errorIO URL
"No support for local Frege databases"
    ([URL]
cblErrs, Map PkgName Int
popularity) <- ([URL], Map PkgName Int) -> IO ([URL], Map PkgName Int)
forall a. a -> IO a
evaluate (([URL], Map PkgName Int) -> IO ([URL], Map PkgName Int))
-> ([URL], Map PkgName Int) -> IO ([URL], Map PkgName Int)
forall a b. (a -> b) -> a -> b
$ Map PkgName Package -> ([URL], Map PkgName Int)
packagePopularity Map PkgName Package
cbl
    Map PkgName Package
cbl <- Map PkgName Package -> IO (Map PkgName Package)
forall a. a -> IO a
evaluate (Map PkgName Package -> IO (Map PkgName Package))
-> Map PkgName Package -> IO (Map PkgName Package)
forall a b. (a -> b) -> a -> b
$ (Package -> Package) -> Map PkgName Package -> Map PkgName Package
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\Package
p -> Package
p{packageDepends :: [PkgName]
packageDepends=[]}) Map PkgName Package
cbl -- clear the memory, since the information is no longer used
    Map PkgName Int -> IO (Map PkgName Int)
forall a. a -> IO a
evaluate Map PkgName Int
popularity

    -- mtl is more popular than transformers, despite having dodgy docs, which is a shame, so we hack it
    Map PkgName Int
popularity <- Map PkgName Int -> IO (Map PkgName Int)
forall a. a -> IO a
evaluate (Map PkgName Int -> IO (Map PkgName Int))
-> Map PkgName Int -> IO (Map PkgName Int)
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> PkgName -> Map PkgName Int -> Map PkgName Int
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Int -> Int -> Int) -> Int -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> PkgName -> Map PkgName Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Int
0 (URL -> PkgName
strPack URL
"mtl") Map PkgName Int
popularity) (URL -> PkgName
strPack URL
"transformers") Map PkgName Int
popularity

    Set PkgName
want <- Set PkgName -> IO (Set PkgName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set PkgName -> IO (Set PkgName))
-> Set PkgName -> IO (Set PkgName)
forall a b. (a -> b) -> a -> b
$ if [URL]
include [URL] -> [URL] -> Bool
forall a. Eq a => a -> a -> Bool
/= [] then [PkgName] -> Set PkgName
forall a. Ord a => [a] -> Set a
Set.fromList ([PkgName] -> Set PkgName) -> [PkgName] -> Set PkgName
forall a b. (a -> b) -> a -> b
$ (URL -> PkgName) -> [URL] -> [PkgName]
forall a b. (a -> b) -> [a] -> [b]
map URL -> PkgName
strPack [URL]
include else Set PkgName
want
    Set PkgName
want <- Set PkgName -> IO (Set PkgName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set PkgName -> IO (Set PkgName))
-> Set PkgName -> IO (Set PkgName)
forall a b. (a -> b) -> a -> b
$ case Maybe Int
count of Maybe Int
Nothing -> Set PkgName
want; Just Int
count -> [PkgName] -> Set PkgName
forall a. Ord a => [a] -> Set a
Set.fromList ([PkgName] -> Set PkgName) -> [PkgName] -> Set PkgName
forall a b. (a -> b) -> a -> b
$ Int -> [PkgName] -> [PkgName]
forall a. Int -> [a] -> [a]
take Int
count ([PkgName] -> [PkgName]) -> [PkgName] -> [PkgName]
forall a b. (a -> b) -> a -> b
$ Set PkgName -> [PkgName]
forall a. Set a -> [a]
Set.toList Set PkgName
want

    ([URL]
stats, ()
_) <- URL -> (StoreWrite -> IO ()) -> IO ([URL], ())
forall a. URL -> (StoreWrite -> IO a) -> IO ([URL], a)
storeWriteFile URL
database ((StoreWrite -> IO ()) -> IO ([URL], ()))
-> (StoreWrite -> IO ()) -> IO ([URL], ())
forall a b. (a -> b) -> a -> b
$ \StoreWrite
store -> do
        [(Maybe TargetId, Item)]
xs <- URL
-> IOMode
-> (Handle -> IO [(Maybe TargetId, Item)])
-> IO [(Maybe TargetId, Item)]
forall r. URL -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile (URL
database URL -> URL -> URL
`replaceExtension` URL
"warn") IOMode
WriteMode ((Handle -> IO [(Maybe TargetId, Item)])
 -> IO [(Maybe TargetId, Item)])
-> (Handle -> IO [(Maybe TargetId, Item)])
-> IO [(Maybe TargetId, Item)]
forall a b. (a -> b) -> a -> b
$ \Handle
warnings -> do
            Handle -> TextEncoding -> IO ()
hSetEncoding Handle
warnings TextEncoding
utf8
            Handle -> URL -> IO ()
hPutStr Handle
warnings (URL -> IO ()) -> URL -> IO ()
forall a b. (a -> b) -> a -> b
$ [URL] -> URL
unlines [URL]
cblErrs
            Int
nCblErrs <- Int -> IO Int
forall a. a -> IO a
evaluate (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ [URL] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [URL]
cblErrs

            IORef Integer
itemWarn <- Integer -> IO (IORef Integer)
forall a. a -> IO (IORef a)
newIORef Integer
0
            let warning :: URL -> IO ()
warning URL
msg = do IORef Integer -> (Integer -> Integer) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef Integer
itemWarn Integer -> Integer
forall a. Enum a => a -> a
succ; Handle -> URL -> IO ()
hPutStrLn Handle
warnings URL
msg

            let consume :: ConduitM (Int, (PkgName, URL, LBStr)) (Maybe Target, [Item]) IO ()
                consume :: ConduitM (Int, (PkgName, URL, LBStr)) (Maybe Target, [Item]) IO ()
consume = ((Int, (PkgName, URL, LBStr))
 -> ConduitM
      (Int, (PkgName, URL, LBStr)) (Maybe Target, [Item]) IO ())
-> ConduitM
     (Int, (PkgName, URL, LBStr)) (Maybe Target, [Item]) IO ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever (((Int, (PkgName, URL, LBStr))
  -> ConduitM
       (Int, (PkgName, URL, LBStr)) (Maybe Target, [Item]) IO ())
 -> ConduitM
      (Int, (PkgName, URL, LBStr)) (Maybe Target, [Item]) IO ())
-> ((Int, (PkgName, URL, LBStr))
    -> ConduitM
         (Int, (PkgName, URL, LBStr)) (Maybe Target, [Item]) IO ())
-> ConduitM
     (Int, (PkgName, URL, LBStr)) (Maybe Target, [Item]) IO ()
forall a b. (a -> b) -> a -> b
$ \(Int
i, (PkgName -> URL
strUnpack -> URL
pkg, URL
url, LBStr
body)) -> do
                    Timing
-> URL
-> ConduitM
     (Int, (PkgName, URL, LBStr)) (Maybe Target, [Item]) IO ()
-> ConduitM
     (Int, (PkgName, URL, LBStr)) (Maybe Target, [Item]) IO ()
forall (m :: * -> *) a. MonadIO m => Timing -> URL -> m a -> m a
timedOverwrite Timing
timing (URL
"[" URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ Int -> URL
forall a. Show a => a -> URL
show Int
i URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ URL
"/" URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ Int -> URL
forall a. Show a => a -> URL
show (Set PkgName -> Int
forall a. Set a -> Int
Set.size Set PkgName
want) URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ URL
"] " URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ URL
pkg) (ConduitM (Int, (PkgName, URL, LBStr)) (Maybe Target, [Item]) IO ()
 -> ConduitM
      (Int, (PkgName, URL, LBStr)) (Maybe Target, [Item]) IO ())
-> ConduitM
     (Int, (PkgName, URL, LBStr)) (Maybe Target, [Item]) IO ()
-> ConduitM
     (Int, (PkgName, URL, LBStr)) (Maybe Target, [Item]) IO ()
forall a b. (a -> b) -> a -> b
$
                        (URL -> IO ())
-> URL
-> LBStr
-> ConduitM
     (Int, (PkgName, URL, LBStr)) (Maybe Target, [Item]) IO ()
forall (m :: * -> *) i.
Monad m =>
(URL -> m ())
-> URL -> LBStr -> ConduitM i (Maybe Target, [Item]) m ()
parseHoogle (\URL
msg -> URL -> IO ()
warning (URL -> IO ()) -> URL -> IO ()
forall a b. (a -> b) -> a -> b
$ URL
pkg URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ URL
":" URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ URL
msg) URL
url LBStr
body

            StoreWrite
-> (ConduitM (Maybe Target, [Item]) (Maybe TargetId, [Item]) IO ()
    -> IO [(Maybe TargetId, Item)])
-> IO [(Maybe TargetId, Item)]
forall item a.
StoreWrite
-> (ConduitM (Maybe Target, item) (Maybe TargetId, item) IO ()
    -> IO a)
-> IO a
writeItems StoreWrite
store ((ConduitM (Maybe Target, [Item]) (Maybe TargetId, [Item]) IO ()
  -> IO [(Maybe TargetId, Item)])
 -> IO [(Maybe TargetId, Item)])
-> (ConduitM (Maybe Target, [Item]) (Maybe TargetId, [Item]) IO ()
    -> IO [(Maybe TargetId, Item)])
-> IO [(Maybe TargetId, Item)]
forall a b. (a -> b) -> a -> b
$ \ConduitM (Maybe Target, [Item]) (Maybe TargetId, [Item]) IO ()
items -> do
                [(Maybe TargetId, [Item])]
xs <- ConduitT () Void IO [(Maybe TargetId, [Item])]
-> IO [(Maybe TargetId, [Item])]
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void IO [(Maybe TargetId, [Item])]
 -> IO [(Maybe TargetId, [Item])])
-> ConduitT () Void IO [(Maybe TargetId, [Item])]
-> IO [(Maybe TargetId, [Item])]
forall a b. (a -> b) -> a -> b
$
                    ConduitT () (PkgName, URL, LBStr) IO ()
source ConduitT () (PkgName, URL, LBStr) IO ()
-> ConduitM
     (PkgName, URL, LBStr) Void IO [(Maybe TargetId, [Item])]
-> ConduitT () Void IO [(Maybe TargetId, [Item])]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.|
                    ((PkgName, URL, LBStr) -> Bool)
-> ConduitT (PkgName, URL, LBStr) (PkgName, URL, LBStr) IO ()
forall (m :: * -> *) a. Monad m => (a -> Bool) -> ConduitT a a m ()
filterC ((PkgName -> Set PkgName -> Bool) -> Set PkgName -> PkgName -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip PkgName -> Set PkgName -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Set PkgName
want (PkgName -> Bool)
-> ((PkgName, URL, LBStr) -> PkgName)
-> (PkgName, URL, LBStr)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PkgName, URL, LBStr) -> PkgName
forall a b c. (a, b, c) -> a
fst3) ConduitT (PkgName, URL, LBStr) (PkgName, URL, LBStr) IO ()
-> ConduitM
     (PkgName, URL, LBStr) Void IO [(Maybe TargetId, [Item])]
-> ConduitM
     (PkgName, URL, LBStr) Void IO [(Maybe TargetId, [Item])]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.|
                    ConduitT (PkgName, URL, LBStr) (Maybe Target, [Item]) IO ((), ())
-> ConduitT (PkgName, URL, LBStr) (Maybe Target, [Item]) IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ConduitT (PkgName, URL, LBStr) (Maybe Target, [Item]) IO ()
-> ConduitT (PkgName, URL, LBStr) (Maybe Target, [Item]) IO ()
-> ConduitT
     (PkgName, URL, LBStr) (Maybe Target, [Item]) IO ((), ())
forall (m :: * -> *) i o r1 r2.
Monad m =>
ConduitM i o m r1 -> ConduitM i o m r2 -> ConduitM i o m (r1, r2)
(|$|)
                        (Int
-> ConduitM
     (PkgName, URL, LBStr) (Int, (PkgName, URL, LBStr)) IO ()
forall (m :: * -> *) i a.
(Monad m, Enum i) =>
i -> ConduitM a (i, a) m ()
zipFromC Int
1 ConduitM (PkgName, URL, LBStr) (Int, (PkgName, URL, LBStr)) IO ()
-> ConduitM
     (Int, (PkgName, URL, LBStr)) (Maybe Target, [Item]) IO ()
-> ConduitT (PkgName, URL, LBStr) (Maybe Target, [Item]) IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM (Int, (PkgName, URL, LBStr)) (Maybe Target, [Item]) IO ()
consume)
                        (do Set PkgName
seen <- ([PkgName] -> Set PkgName)
-> ConduitT
     (PkgName, URL, LBStr) (Maybe Target, [Item]) IO [PkgName]
-> ConduitT
     (PkgName, URL, LBStr) (Maybe Target, [Item]) IO (Set PkgName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [PkgName] -> Set PkgName
forall a. Ord a => [a] -> Set a
Set.fromList (ConduitT (PkgName, URL, LBStr) (Maybe Target, [Item]) IO [PkgName]
 -> ConduitT
      (PkgName, URL, LBStr) (Maybe Target, [Item]) IO (Set PkgName))
-> ConduitT
     (PkgName, URL, LBStr) (Maybe Target, [Item]) IO [PkgName]
-> ConduitT
     (PkgName, URL, LBStr) (Maybe Target, [Item]) IO (Set PkgName)
forall a b. (a -> b) -> a -> b
$ ((PkgName, URL, LBStr) -> IO PkgName)
-> ConduitT (PkgName, URL, LBStr) PkgName IO ()
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
mapMC (PkgName -> IO PkgName
forall a. a -> IO a
evaluate (PkgName -> IO PkgName)
-> ((PkgName, URL, LBStr) -> PkgName)
-> (PkgName, URL, LBStr)
-> IO PkgName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PkgName -> PkgName
forall a. NFData a => a -> a
force (PkgName -> PkgName)
-> ((PkgName, URL, LBStr) -> PkgName)
-> (PkgName, URL, LBStr)
-> PkgName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PkgName -> PkgName
strCopy (PkgName -> PkgName)
-> ((PkgName, URL, LBStr) -> PkgName)
-> (PkgName, URL, LBStr)
-> PkgName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PkgName, URL, LBStr) -> PkgName
forall a b c. (a, b, c) -> a
fst3) ConduitT (PkgName, URL, LBStr) PkgName IO ()
-> ConduitM PkgName (Maybe Target, [Item]) IO [PkgName]
-> ConduitT
     (PkgName, URL, LBStr) (Maybe Target, [Item]) IO [PkgName]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM PkgName (Maybe Target, [Item]) IO [PkgName]
forall (m :: * -> *) a o. Monad m => ConduitM a o m [a]
sinkList
                            let missing :: [PkgName]
missing = [PkgName
x | PkgName
x <- Set PkgName -> [PkgName]
forall a. Set a -> [a]
Set.toList (Set PkgName -> [PkgName]) -> Set PkgName -> [PkgName]
forall a b. (a -> b) -> a -> b
$ Set PkgName
want Set PkgName -> Set PkgName -> Set PkgName
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set PkgName
seen
                                             , (Package -> Bool) -> Maybe Package -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Package -> Bool
packageLibrary (PkgName -> Map PkgName Package -> Maybe Package
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PkgName
x Map PkgName Package
cbl) Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False]
                            IO ()
-> ConduitT (PkgName, URL, LBStr) (Maybe Target, [Item]) IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
 -> ConduitT (PkgName, URL, LBStr) (Maybe Target, [Item]) IO ())
-> IO ()
-> ConduitT (PkgName, URL, LBStr) (Maybe Target, [Item]) IO ()
forall a b. (a -> b) -> a -> b
$ URL -> IO ()
putStrLn URL
""
                            IO ()
-> ConduitT (PkgName, URL, LBStr) (Maybe Target, [Item]) IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
 -> ConduitT (PkgName, URL, LBStr) (Maybe Target, [Item]) IO ())
-> IO ()
-> ConduitT (PkgName, URL, LBStr) (Maybe Target, [Item]) IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
whenNormal (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([PkgName]
missing [PkgName] -> [PkgName] -> Bool
forall a. Eq a => a -> a -> Bool
/= []) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                                URL -> IO ()
putStrLn (URL -> IO ()) -> URL -> IO ()
forall a b. (a -> b) -> a -> b
$ URL
"Packages missing documentation: " URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ [URL] -> URL
unwords ((URL -> URL) -> [URL] -> [URL]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn URL -> URL
lower ([URL] -> [URL]) -> [URL] -> [URL]
forall a b. (a -> b) -> a -> b
$ (PkgName -> URL) -> [PkgName] -> [URL]
forall a b. (a -> b) -> [a] -> [b]
map PkgName -> URL
strUnpack [PkgName]
missing)
                            IO ()
-> ConduitT (PkgName, URL, LBStr) (Maybe Target, [Item]) IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
 -> ConduitT (PkgName, URL, LBStr) (Maybe Target, [Item]) IO ())
-> IO ()
-> ConduitT (PkgName, URL, LBStr) (Maybe Target, [Item]) IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Set PkgName -> Bool
forall a. Set a -> Bool
Set.null Set PkgName
seen) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                                URL -> IO ()
exitFail URL
"No packages were found, aborting (use no arguments to index all of Stackage)"
                            -- synthesise things for Cabal packages that are not documented
                            [(PkgName, Package)]
-> ((PkgName, Package)
    -> ConduitT (PkgName, URL, LBStr) (Maybe Target, [Item]) IO ())
-> ConduitT (PkgName, URL, LBStr) (Maybe Target, [Item]) IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map PkgName Package -> [(PkgName, Package)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PkgName Package
cbl) (((PkgName, Package)
  -> ConduitT (PkgName, URL, LBStr) (Maybe Target, [Item]) IO ())
 -> ConduitT (PkgName, URL, LBStr) (Maybe Target, [Item]) IO ())
-> ((PkgName, Package)
    -> ConduitT (PkgName, URL, LBStr) (Maybe Target, [Item]) IO ())
-> ConduitT (PkgName, URL, LBStr) (Maybe Target, [Item]) IO ()
forall a b. (a -> b) -> a -> b
$ \(PkgName
name, Package{Bool
[(PkgName, PkgName)]
[PkgName]
Maybe URL
PkgName
packageDocs :: Maybe URL
packageDepends :: [PkgName]
packageVersion :: PkgName
packageSynopsis :: PkgName
packageLibrary :: Bool
packageTags :: [(PkgName, PkgName)]
packageDocs :: Package -> Maybe URL
packageDepends :: Package -> [PkgName]
packageVersion :: Package -> PkgName
packageSynopsis :: Package -> PkgName
packageLibrary :: Package -> Bool
packageTags :: Package -> [(PkgName, PkgName)]
..}) -> Bool
-> ConduitT (PkgName, URL, LBStr) (Maybe Target, [Item]) IO ()
-> ConduitT (PkgName, URL, LBStr) (Maybe Target, [Item]) IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PkgName
name PkgName -> Set PkgName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set PkgName
seen) (ConduitT (PkgName, URL, LBStr) (Maybe Target, [Item]) IO ()
 -> ConduitT (PkgName, URL, LBStr) (Maybe Target, [Item]) IO ())
-> ConduitT (PkgName, URL, LBStr) (Maybe Target, [Item]) IO ()
-> ConduitT (PkgName, URL, LBStr) (Maybe Target, [Item]) IO ()
forall a b. (a -> b) -> a -> b
$ do
                                let ret :: URL -> ConduitT i (Maybe Target, [Item]) m ()
ret URL
prefix = (Maybe Target, [Item]) -> ConduitT i (Maybe Target, [Item]) m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ((Maybe Target, [Item]) -> ConduitT i (Maybe Target, [Item]) m ())
-> (Maybe Target, [Item]) -> ConduitT i (Maybe Target, [Item]) m ()
forall a b. (a -> b) -> a -> b
$ PkgName -> URL -> (Maybe Target, [Item])
fakePackage PkgName
name (URL -> (Maybe Target, [Item])) -> URL -> (Maybe Target, [Item])
forall a b. (a -> b) -> a -> b
$ URL
prefix URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ URL -> URL
trim (PkgName -> URL
strUnpack PkgName
packageSynopsis)
                                if PkgName
name PkgName -> Set PkgName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PkgName
want then
                                    (if Bool
packageLibrary
                                        then URL -> ConduitT (PkgName, URL, LBStr) (Maybe Target, [Item]) IO ()
forall (m :: * -> *) i.
Monad m =>
URL -> ConduitT i (Maybe Target, [Item]) m ()
ret URL
"Documentation not found, so not searched.\n"
                                        else URL -> ConduitT (PkgName, URL, LBStr) (Maybe Target, [Item]) IO ()
forall (m :: * -> *) i.
Monad m =>
URL -> ConduitT i (Maybe Target, [Item]) m ()
ret URL
"Executable only. ")
                                else if [URL] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [URL]
include then
                                    URL -> ConduitT (PkgName, URL, LBStr) (Maybe Target, [Item]) IO ()
forall (m :: * -> *) i.
Monad m =>
URL -> ConduitT i (Maybe Target, [Item]) m ()
ret URL
"Not on Stackage, so not searched.\n"
                                else
                                    () -> ConduitT (PkgName, URL, LBStr) (Maybe Target, [Item]) IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                            ))
                    ConduitT (PkgName, URL, LBStr) (Maybe Target, [Item]) IO ()
-> ConduitM
     (Maybe Target, [Item]) Void IO [(Maybe TargetId, [Item])]
-> ConduitM
     (PkgName, URL, LBStr) Void IO [(Maybe TargetId, [Item])]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| Int
-> ConduitM
     (Maybe Target, [Item]) Void IO [(Maybe TargetId, [Item])]
-> ConduitM
     (Maybe Target, [Item]) Void IO [(Maybe TargetId, [Item])]
forall o r. Int -> ConduitM o Void IO r -> ConduitM o Void IO r
pipelineC Int
10 (ConduitM (Maybe Target, [Item]) (Maybe TargetId, [Item]) IO ()
items ConduitM (Maybe Target, [Item]) (Maybe TargetId, [Item]) IO ()
-> ConduitM
     (Maybe TargetId, [Item]) Void IO [(Maybe TargetId, [Item])]
-> ConduitM
     (Maybe Target, [Item]) Void IO [(Maybe TargetId, [Item])]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM
  (Maybe TargetId, [Item]) Void IO [(Maybe TargetId, [Item])]
forall (m :: * -> *) a o. Monad m => ConduitM a o m [a]
sinkList)

                Integer
itemWarn <- IORef Integer -> IO Integer
forall a. IORef a -> IO a
readIORef IORef Integer
itemWarn
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
itemWarn Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    URL -> IO ()
putStrLn (URL -> IO ()) -> URL -> IO ()
forall a b. (a -> b) -> a -> b
$ URL
"Found " URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ Integer -> URL
forall a. Show a => a -> URL
show Integer
itemWarn URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ URL
" warnings when processing items"
                [(Maybe TargetId, Item)] -> IO [(Maybe TargetId, Item)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Maybe TargetId
a,Item
b) | (Maybe TargetId
a,[Item]
bs) <- [(Maybe TargetId, [Item])]
xs, Item
b <- [Item]
bs]

        Maybe URL
itemsMemory <- IO (Maybe URL)
getStatsCurrentLiveBytes
        [(Maybe TargetId, Item)]
xs <- Timing
-> URL
-> IO [(Maybe TargetId, Item)]
-> IO [(Maybe TargetId, Item)]
forall (m :: * -> *) a. MonadIO m => Timing -> URL -> m a -> m a
timed Timing
timing URL
"Reordering items" (IO [(Maybe TargetId, Item)] -> IO [(Maybe TargetId, Item)])
-> IO [(Maybe TargetId, Item)] -> IO [(Maybe TargetId, Item)]
forall a b. (a -> b) -> a -> b
$ [(Maybe TargetId, Item)] -> IO [(Maybe TargetId, Item)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Maybe TargetId, Item)] -> IO [(Maybe TargetId, Item)])
-> [(Maybe TargetId, Item)] -> IO [(Maybe TargetId, Item)]
forall a b. (a -> b) -> a -> b
$! Settings
-> (PkgName -> Int)
-> [(Maybe TargetId, Item)]
-> [(Maybe TargetId, Item)]
forall a.
Settings -> (PkgName -> Int) -> [(a, Item)] -> [(a, Item)]
reorderItems Settings
settings (\PkgName
s -> Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
1 Int -> Int
forall a. Num a => a -> a
negate (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ PkgName -> Map PkgName Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PkgName
s Map PkgName Int
popularity) [(Maybe TargetId, Item)]
xs
        Timing -> URL -> IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => Timing -> URL -> m a -> m a
timed Timing
timing URL
"Writing tags" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ StoreWrite
-> (PkgName -> Bool)
-> (PkgName -> [(URL, URL)])
-> [(Maybe TargetId, Item)]
-> IO ()
writeTags StoreWrite
store (PkgName -> Set PkgName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PkgName
want) (\PkgName
x -> [(URL, URL)]
-> (Package -> [(URL, URL)]) -> Maybe Package -> [(URL, URL)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (((PkgName, PkgName) -> (URL, URL))
-> [(PkgName, PkgName)] -> [(URL, URL)]
forall a b. (a -> b) -> [a] -> [b]
map ((PkgName -> URL) -> (PkgName, PkgName) -> (URL, URL)
forall a b. (a -> b) -> (a, a) -> (b, b)
both PkgName -> URL
strUnpack) ([(PkgName, PkgName)] -> [(URL, URL)])
-> (Package -> [(PkgName, PkgName)]) -> Package -> [(URL, URL)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Package -> [(PkgName, PkgName)]
packageTags) (Maybe Package -> [(URL, URL)]) -> Maybe Package -> [(URL, URL)]
forall a b. (a -> b) -> a -> b
$ PkgName -> Map PkgName Package -> Maybe Package
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PkgName
x Map PkgName Package
cbl) [(Maybe TargetId, Item)]
xs
        Timing -> URL -> IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => Timing -> URL -> m a -> m a
timed Timing
timing URL
"Writing names" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ StoreWrite -> [(Maybe TargetId, Item)] -> IO ()
writeNames StoreWrite
store [(Maybe TargetId, Item)]
xs
        Timing -> URL -> IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => Timing -> URL -> m a -> m a
timed Timing
timing URL
"Writing types" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ StoreWrite -> Maybe URL -> [(Maybe TargetId, Item)] -> IO ()
writeTypes StoreWrite
store (if Bool
debug then URL -> Maybe URL
forall a. a -> Maybe a
Just (URL -> Maybe URL) -> URL -> Maybe URL
forall a b. (a -> b) -> a -> b
$ URL -> URL
dropExtension URL
database else Maybe URL
forall a. Maybe a
Nothing) [(Maybe TargetId, Item)]
xs

        Verbosity
x <- IO Verbosity
getVerbosity
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
x Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
Loud) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            IO (Maybe URL) -> (URL -> IO ()) -> IO ()
forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> (a -> m ()) -> m ()
whenJustM IO (Maybe URL)
getStatsDebug URL -> IO ()
forall a. Show a => a -> IO ()
print
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
x Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
Normal) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            IO (Maybe URL) -> (URL -> IO ()) -> IO ()
forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> (a -> m ()) -> m ()
whenJustM IO (Maybe URL)
getStatsPeakAllocBytes ((URL -> IO ()) -> IO ()) -> (URL -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \URL
x ->
                URL -> IO ()
putStrLn (URL -> IO ()) -> URL -> IO ()
forall a b. (a -> b) -> a -> b
$ URL
"Peak of " URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ URL
x URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ URL
", " URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ URL -> Maybe URL -> URL
forall a. a -> Maybe a -> a
fromMaybe URL
"unknown" Maybe URL
itemsMemory URL -> URL -> URL
forall a. [a] -> [a] -> [a]
++ URL
" for items"

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        URL -> URL -> IO ()
writeFile (URL
database URL -> URL -> URL
`replaceExtension` URL
"store") (URL -> IO ()) -> URL -> IO ()
forall a b. (a -> b) -> a -> b
$ [URL] -> URL
unlines [URL]
stats