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

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

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

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


readHaskellDirs :: Timing -> Settings -> [FilePath] -> IO (Map.Map PkgName Package, Set.Set PkgName, ConduitT () (PkgName, URL, LBStr) IO ())
readHaskellDirs :: Timing
-> Settings
-> [String]
-> IO
     (Map Str Package, Set Str, ConduitT () (Str, String, LBStr) IO ())
readHaskellDirs Timing
timing Settings
settings [String]
dirs = do
    [String]
files <- (String -> IO [String]) -> [String] -> IO [String]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM String -> IO [String]
listFilesRecursive [String]
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 :: String -> (String, Down [Int])
order String
a = ([Int] -> Down [Int]) -> (String, [Int]) -> (String, Down [Int])
forall b b' a. (b -> b') -> (a, b) -> (a, b')
second [Int] -> Down [Int]
forall a. a -> Down a
Down ((String, [Int]) -> (String, Down [Int]))
-> (String, [Int]) -> (String, Down [Int])
forall a b. (a -> b) -> a -> b
$ String -> (String, [Int])
parseTrailingVersion String
a
    let packages :: [(Str, String)]
packages = (String -> (Str, String)) -> [String] -> [(Str, String)]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Str
strPack (String -> Str) -> (String -> String) -> String -> Str
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeBaseName (String -> Str) -> (String -> String) -> String -> (Str, String)
forall a b c. (a -> b) -> (a -> c) -> a -> (b, c)
&&& String -> String
forall a. a -> a
id) ([String] -> [(Str, String)]) -> [String] -> [(Str, String)]
forall a b. (a -> b) -> a -> b
$ (String -> [(String, Down [Int])]) -> [String] -> [String]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn ((String -> (String, Down [Int]))
-> [String] -> [(String, Down [Int])]
forall a b. (a -> b) -> [a] -> [b]
map String -> (String, Down [Int])
order ([String] -> [(String, Down [Int])])
-> (String -> [String]) -> String -> [(String, Down [Int])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
splitDirectories) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
(==) String
".txt" (String -> Bool) -> (String -> String) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeExtension) [String]
files
    [(Str, Package)]
cabals <- (String -> IO (Str, Package)) -> [String] -> IO [(Str, Package)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO (Str, Package)
parseCabal ([String] -> IO [(Str, Package)])
-> [String] -> IO [(Str, Package)]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
(==) String
".cabal" (String -> Bool) -> (String -> String) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeExtension) [String]
files
    let source :: ConduitT i (Str, String, LBStr) IO ()
source = [(Str, String)]
-> ((Str, String) -> ConduitT i (Str, String, LBStr) IO ())
-> ConduitT i (Str, String, LBStr) IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Str, String)]
packages (((Str, String) -> ConduitT i (Str, String, LBStr) IO ())
 -> ConduitT i (Str, String, LBStr) IO ())
-> ((Str, String) -> ConduitT i (Str, String, LBStr) IO ())
-> ConduitT i (Str, String, LBStr) IO ()
forall a b. (a -> b) -> a -> b
$ \(Str
name, String
file) -> do
            BStr
src <- IO BStr -> ConduitT i (Str, String, LBStr) IO BStr
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO BStr -> ConduitT i (Str, String, LBStr) IO BStr)
-> IO BStr -> ConduitT i (Str, String, LBStr) IO BStr
forall a b. (a -> b) -> a -> b
$ String -> IO BStr
bstrReadFile String
file
            String
dir <- IO String -> ConduitT i (Str, String, LBStr) IO String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> ConduitT i (Str, String, LBStr) IO String)
-> IO String -> ConduitT i (Str, String, LBStr) IO String
forall a b. (a -> b) -> a -> b
$ String -> IO String
canonicalizePath (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> String
takeDirectory String
file
            let url :: String
url = String
"file://" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
'/' | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String
"/" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
dir] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String -> String -> String
forall a. (Partial, Eq a) => [a] -> [a] -> [a] -> [a]
replace String
"\\" String
"/" String
dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/"
            (Str, String, LBStr) -> ConduitT i (Str, String, LBStr) IO ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Str
name, String
url, [BStr] -> LBStr
lbstrFromChunks [BStr
src])
    (Map Str Package, Set Str, ConduitT () (Str, String, LBStr) IO ())
-> IO
     (Map Str Package, Set Str, ConduitT () (Str, String, LBStr) IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Str Package -> Map Str Package -> Map Str Package
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union
                ([(Str, Package)] -> Map Str Package
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Str, Package)]
cabals)
                ((Package -> Package -> Package)
-> [(Str, Package)] -> Map Str 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
(<>) ([(Str, Package)] -> Map Str Package)
-> [(Str, Package)] -> Map Str Package
forall a b. (a -> b) -> a -> b
$ ((Str, String) -> (Str, Package))
-> [(Str, String)] -> [(Str, Package)]
forall a b. (a -> b) -> [a] -> [b]
map (Str, String) -> (Str, Package)
forall {a}. (a, String) -> (a, Package)
generateBarePackage [(Str, String)]
packages)
           ,[Str] -> Set Str
forall a. Ord a => [a] -> Set a
Set.fromList ([Str] -> Set Str) -> [Str] -> Set Str
forall a b. (a -> b) -> a -> b
$ ((Str, String) -> Str) -> [(Str, String)] -> [Str]
forall a b. (a -> b) -> [a] -> [b]
map (Str, String) -> Str
forall a b. (a, b) -> a
fst [(Str, String)]
packages, ConduitT () (Str, String, LBStr) IO ()
forall {i}. ConduitT i (Str, String, LBStr) IO ()
source)
  where
    parseCabal :: String -> IO (Str, Package)
parseCabal String
fp = do
        String
src <- String -> IO String
readFileUTF8' String
fp
        let pkg :: Package
pkg = Settings -> String -> Package
readCabal Settings
settings String
src
        (Str, Package) -> IO (Str, Package)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Str
strPack (String -> Str) -> String -> Str
forall a b. (a -> b) -> a -> b
$ String -> String
takeBaseName String
fp, Package
pkg)

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

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


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

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

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

actionGenerate :: CmdLine -> IO ()
actionGenerate :: CmdLine -> IO ()
actionGenerate g :: CmdLine
g@Generate{Bool
String
[String]
Maybe Bool
Maybe Int
Maybe String
Language
debug :: CmdLine -> Bool
haddock :: CmdLine -> Maybe String
local_ :: CmdLine -> [String]
include :: CmdLine -> [String]
insecure :: CmdLine -> Bool
download :: CmdLine -> Maybe Bool
language :: CmdLine -> Language
count :: CmdLine -> Maybe Int
database :: CmdLine -> String
language :: Language
debug :: Bool
haddock :: Maybe String
local_ :: [String]
count :: Maybe Int
include :: [String]
insecure :: Bool
database :: String
download :: Maybe Bool
..} = Maybe String -> (Timing -> IO ()) -> IO ()
forall a. Maybe String -> (Timing -> IO a) -> IO a
withTiming (if Bool
debug then String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String -> String -> String
replaceExtension String
database String
"timing" else Maybe String
forall a. Maybe a
Nothing) ((Timing -> IO ()) -> IO ()) -> (Timing -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Timing
timing -> do
    String -> IO ()
putStrLn String
"Starting generate"
    Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String
takeDirectory String
database
    IO () -> IO ()
whenLoud (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Generating files to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
takeDirectory String
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 -> String -> Download
downloadInput Timing
timing Bool
insecure Maybe Bool
download (String -> String
takeDirectory String
database)
    Settings
settings <- IO Settings
loadSettings
    (Map Str Package
cbl, Set Str
want, ConduitT () (Str, String, LBStr) IO ()
source) <- case Language
language of
        Language
Haskell | Just String
dir <- Maybe String
haddock -> Timing
-> Settings
-> String
-> IO
     (Map Str Package, Set Str, ConduitT () (Str, String, LBStr) IO ())
readHaskellHaddock Timing
timing Settings
settings String
dir
                | [String
""] <- [String]
local_ -> Timing
-> Settings
-> IO
     (Map Str Package, Set Str, ConduitT () (Str, String, LBStr) IO ())
readHaskellGhcpkg Timing
timing Settings
settings
                | [] <- [String]
local_ -> Timing
-> Settings
-> Download
-> IO
     (Map Str Package, Set Str, ConduitT () (Str, String, LBStr) IO ())
readHaskellOnline Timing
timing Settings
settings Download
download
                | Bool
otherwise -> Timing
-> Settings
-> [String]
-> IO
     (Map Str Package, Set Str, ConduitT () (Str, String, LBStr) IO ())
readHaskellDirs Timing
timing Settings
settings [String]
local_
        Language
Frege | [] <- [String]
local_ -> Timing
-> Download
-> IO
     (Map Str Package, Set Str, ConduitT () (Str, String, LBStr) IO ())
readFregeOnline Timing
timing Download
download
              | Bool
otherwise -> String
-> IO
     (Map Str Package, Set Str, ConduitT () (Str, String, LBStr) IO ())
forall a. Partial => String -> IO a
errorIO String
"No support for local Frege databases"
    ([String]
cblErrs, Map Str Int
popularity) <- ([String], Map Str Int) -> IO ([String], Map Str Int)
forall a. a -> IO a
evaluate (([String], Map Str Int) -> IO ([String], Map Str Int))
-> ([String], Map Str Int) -> IO ([String], Map Str Int)
forall a b. (a -> b) -> a -> b
$ Map Str Package -> ([String], Map Str Int)
packagePopularity Map Str Package
cbl
    Map Str Package
cbl <- Map Str Package -> IO (Map Str Package)
forall a. a -> IO a
evaluate (Map Str Package -> IO (Map Str Package))
-> Map Str Package -> IO (Map Str Package)
forall a b. (a -> b) -> a -> b
$ (Package -> Package) -> Map Str Package -> Map Str Package
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\Package
p -> Package
p{packageDepends :: [Str]
packageDepends=[]}) Map Str Package
cbl -- clear the memory, since the information is no longer used
    Map Str Int -> IO (Map Str Int)
forall a. a -> IO a
evaluate Map Str Int
popularity

    -- mtl is more popular than transformers, despite having dodgy docs, which is a shame, so we hack it
    Map Str Int
popularity <- Map Str Int -> IO (Map Str Int)
forall a. a -> IO a
evaluate (Map Str Int -> IO (Map Str Int))
-> Map Str Int -> IO (Map Str Int)
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> Str -> Map Str Int -> Map Str 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 -> Str -> Map Str Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Int
0 (String -> Str
strPack String
"mtl") Map Str Int
popularity) (String -> Str
strPack String
"transformers") Map Str Int
popularity

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

    ([String]
stats, ()
_) <- String -> (StoreWrite -> IO ()) -> IO ([String], ())
forall a. String -> (StoreWrite -> IO a) -> IO ([String], a)
storeWriteFile String
database ((StoreWrite -> IO ()) -> IO ([String], ()))
-> (StoreWrite -> IO ()) -> IO ([String], ())
forall a b. (a -> b) -> a -> b
$ \StoreWrite
store -> do
        [(Maybe TargetId, Item)]
xs <- String
-> IOMode
-> (Handle -> IO [(Maybe TargetId, Item)])
-> IO [(Maybe TargetId, Item)]
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile (String
database String -> String -> String
`replaceExtension` String
"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 -> String -> IO ()
hPutStr Handle
warnings (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
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
$ [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
cblErrs

            IORef Integer
itemWarn <- Integer -> IO (IORef Integer)
forall a. a -> IO (IORef a)
newIORef Integer
0
            let warning :: String -> IO ()
warning String
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 -> String -> IO ()
hPutStrLn Handle
warnings String
msg

            let consume :: ConduitM (Int, (PkgName, URL, LBStr)) (Maybe Target, [Item]) IO ()
                consume :: ConduitM (Int, (Str, String, LBStr)) (Maybe Target, [Item]) IO ()
consume = ((Int, (Str, String, LBStr))
 -> ConduitM
      (Int, (Str, String, LBStr)) (Maybe Target, [Item]) IO ())
-> ConduitM
     (Int, (Str, String, LBStr)) (Maybe Target, [Item]) IO ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever (((Int, (Str, String, LBStr))
  -> ConduitM
       (Int, (Str, String, LBStr)) (Maybe Target, [Item]) IO ())
 -> ConduitM
      (Int, (Str, String, LBStr)) (Maybe Target, [Item]) IO ())
-> ((Int, (Str, String, LBStr))
    -> ConduitM
         (Int, (Str, String, LBStr)) (Maybe Target, [Item]) IO ())
-> ConduitM
     (Int, (Str, String, LBStr)) (Maybe Target, [Item]) IO ()
forall a b. (a -> b) -> a -> b
$ \(Int
i, (Str -> String
strUnpack -> String
pkg, String
url, LBStr
body)) -> do
                    Timing
-> String
-> ConduitM
     (Int, (Str, String, LBStr)) (Maybe Target, [Item]) IO ()
-> ConduitM
     (Int, (Str, String, LBStr)) (Maybe Target, [Item]) IO ()
forall (m :: * -> *) a. MonadIO m => Timing -> String -> m a -> m a
timedOverwrite Timing
timing (String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Set Str -> Int
forall a. Set a -> Int
Set.size Set Str
want) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"] " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pkg) (ConduitM (Int, (Str, String, LBStr)) (Maybe Target, [Item]) IO ()
 -> ConduitM
      (Int, (Str, String, LBStr)) (Maybe Target, [Item]) IO ())
-> ConduitM
     (Int, (Str, String, LBStr)) (Maybe Target, [Item]) IO ()
-> ConduitM
     (Int, (Str, String, LBStr)) (Maybe Target, [Item]) IO ()
forall a b. (a -> b) -> a -> b
$
                        (String -> IO ())
-> String
-> LBStr
-> ConduitM
     (Int, (Str, String, LBStr)) (Maybe Target, [Item]) IO ()
forall (m :: * -> *) i.
Monad m =>
(String -> m ())
-> String -> LBStr -> ConduitM i (Maybe Target, [Item]) m ()
parseHoogle (\String
msg -> String -> IO ()
warning (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
pkg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg) String
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 () (Str, String, LBStr) IO ()
source ConduitT () (Str, String, LBStr) IO ()
-> ConduitT (Str, String, LBStr) Void IO [(Maybe TargetId, [Item])]
-> ConduitT () Void IO [(Maybe TargetId, [Item])]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.|
                    ((Str, String, LBStr) -> Bool)
-> ConduitT (Str, String, LBStr) (Str, String, LBStr) IO ()
forall {m :: * -> *} {a}.
Monad m =>
(a -> Bool) -> ConduitT a a m ()
filterC ((Str -> Set Str -> Bool) -> Set Str -> Str -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Str -> Set Str -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Set Str
want (Str -> Bool)
-> ((Str, String, LBStr) -> Str) -> (Str, String, LBStr) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Str, String, LBStr) -> Str
forall a b c. (a, b, c) -> a
fst3) ConduitT (Str, String, LBStr) (Str, String, LBStr) IO ()
-> ConduitT (Str, String, LBStr) Void IO [(Maybe TargetId, [Item])]
-> ConduitT (Str, String, LBStr) Void IO [(Maybe TargetId, [Item])]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.|
                    ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO ((), ())
-> ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO ()
-> ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO ()
-> ConduitT (Str, String, 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 (Str, String, LBStr) (Int, (Str, String, LBStr)) IO ()
forall (m :: * -> *) i a.
(Monad m, Enum i) =>
i -> ConduitM a (i, a) m ()
zipFromC Int
1 ConduitM (Str, String, LBStr) (Int, (Str, String, LBStr)) IO ()
-> ConduitM
     (Int, (Str, String, LBStr)) (Maybe Target, [Item]) IO ()
-> ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitM (Int, (Str, String, LBStr)) (Maybe Target, [Item]) IO ()
consume)
                        (do Set Str
seen <- ([Str] -> Set Str)
-> ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO [Str]
-> ConduitT
     (Str, String, LBStr) (Maybe Target, [Item]) IO (Set Str)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Str] -> Set Str
forall a. Ord a => [a] -> Set a
Set.fromList (ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO [Str]
 -> ConduitT
      (Str, String, LBStr) (Maybe Target, [Item]) IO (Set Str))
-> ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO [Str]
-> ConduitT
     (Str, String, LBStr) (Maybe Target, [Item]) IO (Set Str)
forall a b. (a -> b) -> a -> b
$ ((Str, String, LBStr) -> IO Str)
-> ConduitT (Str, String, LBStr) Str IO ()
forall {m :: * -> *} {a} {b}.
Monad m =>
(a -> m b) -> ConduitT a b m ()
mapMC (Str -> IO Str
forall a. a -> IO a
evaluate (Str -> IO Str)
-> ((Str, String, LBStr) -> Str) -> (Str, String, LBStr) -> IO Str
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Str -> Str
forall a. NFData a => a -> a
force (Str -> Str)
-> ((Str, String, LBStr) -> Str) -> (Str, String, LBStr) -> Str
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Str -> Str
strCopy (Str -> Str)
-> ((Str, String, LBStr) -> Str) -> (Str, String, LBStr) -> Str
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Str, String, LBStr) -> Str
forall a b c. (a, b, c) -> a
fst3) ConduitT (Str, String, LBStr) Str IO ()
-> ConduitT Str (Maybe Target, [Item]) IO [Str]
-> ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO [Str]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT Str (Maybe Target, [Item]) IO [Str]
forall (m :: * -> *) a o. Monad m => ConduitM a o m [a]
sinkList
                            let missing :: [Str]
missing = [Str
x | Str
x <- Set Str -> [Str]
forall a. Set a -> [a]
Set.toList (Set Str -> [Str]) -> Set Str -> [Str]
forall a b. (a -> b) -> a -> b
$ Set Str
want Set Str -> Set Str -> Set Str
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set Str
seen
                                             , (Package -> Bool) -> Maybe Package -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Package -> Bool
packageLibrary (Str -> Map Str Package -> Maybe Package
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Str
x Map Str 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 (Str, String, LBStr) (Maybe Target, [Item]) IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
 -> ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO ())
-> IO ()
-> ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
""
                            IO () -> ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
 -> ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO ())
-> IO ()
-> ConduitT (Str, String, 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 ([Str]
missing [Str] -> [Str] -> Bool
forall a. Eq a => a -> a -> Bool
/= []) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                                String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Packages missing documentation: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords ((String -> String) -> [String] -> [String]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn String -> String
lower ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (Str -> String) -> [Str] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Str -> String
strUnpack [Str]
missing)
                            IO () -> ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
 -> ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO ())
-> IO ()
-> ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Set Str -> Bool
forall a. Set a -> Bool
Set.null Set Str
seen) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                                String -> IO ()
exitFail String
"No packages were found, aborting (use no arguments to index all of Stackage)"
                            -- synthesise things for Cabal packages that are not documented
                            [(Str, Package)]
-> ((Str, Package)
    -> ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO ())
-> ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map Str Package -> [(Str, Package)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Str Package
cbl) (((Str, Package)
  -> ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO ())
 -> ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO ())
-> ((Str, Package)
    -> ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO ())
-> ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO ()
forall a b. (a -> b) -> a -> b
$ \(Str
name, Package{Bool
[(Str, Str)]
[Str]
Maybe String
Str
packageDocs :: Maybe String
packageDepends :: [Str]
packageVersion :: Str
packageSynopsis :: Str
packageLibrary :: Bool
packageTags :: [(Str, Str)]
packageDocs :: Package -> Maybe String
packageDepends :: Package -> [Str]
packageVersion :: Package -> Str
packageSynopsis :: Package -> Str
packageLibrary :: Package -> Bool
packageTags :: Package -> [(Str, Str)]
..}) -> Bool
-> ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO ()
-> ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Str
name Str -> Set Str -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Str
seen) (ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO ()
 -> ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO ())
-> ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO ()
-> ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO ()
forall a b. (a -> b) -> a -> b
$ do
                                let ret :: String -> ConduitT i (Maybe Target, [Item]) m ()
ret String
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
$ Str -> String -> (Maybe Target, [Item])
fakePackage Str
name (String -> (Maybe Target, [Item]))
-> String -> (Maybe Target, [Item])
forall a b. (a -> b) -> a -> b
$ String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
trim (Str -> String
strUnpack Str
packageSynopsis)
                                if Str
name Str -> Set Str -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Str
want then
                                    (if Bool
packageLibrary
                                        then String
-> ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO ()
forall {m :: * -> *} {i}.
Monad m =>
String -> ConduitT i (Maybe Target, [Item]) m ()
ret String
"Documentation not found, so not searched.\n"
                                        else String
-> ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO ()
forall {m :: * -> *} {i}.
Monad m =>
String -> ConduitT i (Maybe Target, [Item]) m ()
ret String
"Executable only. ")
                                else if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
include then
                                    String
-> ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO ()
forall {m :: * -> *} {i}.
Monad m =>
String -> ConduitT i (Maybe Target, [Item]) m ()
ret String
"Not on Stackage, so not searched.\n"
                                else
                                    () -> ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                            ))
                    ConduitT (Str, String, LBStr) (Maybe Target, [Item]) IO ()
-> ConduitT
     (Maybe Target, [Item]) Void IO [(Maybe TargetId, [Item])]
-> ConduitT (Str, String, LBStr) Void IO [(Maybe TargetId, [Item])]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| Int
-> ConduitT
     (Maybe Target, [Item]) Void IO [(Maybe TargetId, [Item])]
-> ConduitT
     (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 ()
-> ConduitT
     (Maybe TargetId, [Item]) Void IO [(Maybe TargetId, [Item])]
-> ConduitT
     (Maybe Target, [Item]) Void IO [(Maybe TargetId, [Item])]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT
  (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
$
                    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
itemWarn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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 String
itemsMemory <- IO (Maybe String)
getStatsCurrentLiveBytes
        [(Maybe TargetId, Item)]
xs <- Timing
-> String
-> IO [(Maybe TargetId, Item)]
-> IO [(Maybe TargetId, Item)]
forall (m :: * -> *) a. MonadIO m => Timing -> String -> m a -> m a
timed Timing
timing String
"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
-> (Str -> Int)
-> [(Maybe TargetId, Item)]
-> [(Maybe TargetId, Item)]
forall a. Settings -> (Str -> Int) -> [(a, Item)] -> [(a, Item)]
reorderItems Settings
settings (\Str
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
$ Str -> Map Str Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Str
s Map Str Int
popularity) [(Maybe TargetId, Item)]
xs
        Timing -> String -> IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => Timing -> String -> m a -> m a
timed Timing
timing String
"Writing tags" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ StoreWrite
-> (Str -> Bool)
-> (Str -> [(String, String)])
-> [(Maybe TargetId, Item)]
-> IO ()
writeTags StoreWrite
store (Str -> Set Str -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Str
want) (\Str
x -> [(String, String)]
-> (Package -> [(String, String)])
-> Maybe Package
-> [(String, String)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (((Str, Str) -> (String, String))
-> [(Str, Str)] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map ((Str -> String) -> (Str, Str) -> (String, String)
forall a b. (a -> b) -> (a, a) -> (b, b)
both Str -> String
strUnpack) ([(Str, Str)] -> [(String, String)])
-> (Package -> [(Str, Str)]) -> Package -> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Package -> [(Str, Str)]
packageTags) (Maybe Package -> [(String, String)])
-> Maybe Package -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ Str -> Map Str Package -> Maybe Package
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Str
x Map Str Package
cbl) [(Maybe TargetId, Item)]
xs
        Timing -> String -> IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => Timing -> String -> m a -> m a
timed Timing
timing String
"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 -> String -> IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => Timing -> String -> m a -> m a
timed Timing
timing String
"Writing types" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ StoreWrite -> Maybe String -> [(Maybe TargetId, Item)] -> IO ()
writeTypes StoreWrite
store (if Bool
debug then String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String -> String
dropExtension String
database else Maybe String
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 String) -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> (a -> m ()) -> m ()
whenJustM IO (Maybe String)
getStatsDebug String -> 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 String) -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> (a -> m ()) -> m ()
whenJustM IO (Maybe String)
getStatsPeakAllocBytes ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
x ->
                String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Peak of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"unknown" Maybe String
itemsMemory String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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
$
        String -> String -> IO ()
writeFile (String
database String -> String -> String
`replaceExtension` String
"store") (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
stats