{-# 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
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, 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/lts/cabal.config"
String
stackageNightly <- Download
download String
"haskell-stackage-nightly.txt" String
"https://www.stackage.org/nightly/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"
Set PkgName
setStackage <- (String -> PkgName) -> Set String -> Set PkgName
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map String -> PkgName
strPack (Set String -> Set PkgName) -> IO (Set String) -> IO (Set PkgName)
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 a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> IO (Set String)
setStackage String
stackageNightly)
Set PkgName
setPlatform <- (String -> PkgName) -> Set String -> Set PkgName
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map String -> PkgName
strPack (Set String -> Set PkgName) -> IO (Set String) -> IO (Set PkgName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Set String)
setPlatform String
platform
Set PkgName
setGHC <- (String -> PkgName) -> Set String -> Set PkgName
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map String -> PkgName
strPack (Set String -> Set PkgName) -> IO (Set String) -> IO (Set PkgName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Set String)
setGHC String
platform
Map PkgName Package
cbl <- Timing
-> String -> IO (Map PkgName Package) -> IO (Map PkgName Package)
forall (m :: * -> *) a. MonadIO m => Timing -> String -> m a -> m a
timed Timing
timing String
"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 -> String -> IO (Map PkgName Package)
parseCabalTarball Settings
settings String
cabals
let want :: Set PkgName
want = PkgName -> Set PkgName -> Set PkgName
forall a. Ord a => a -> Set a -> Set a
Set.insert (String -> PkgName
strPack String
"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 a. a -> IO a
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 =
[(strPack "set",strPack "included-with-ghc") | name `Set.member` setGHC] ++
[(strPack "set",strPack "haskell-platform") | name `Set.member` setPlatform] ++
[(strPack "set",strPack "stackage") | name `Set.member` setStackage] ++
packageTags p}
let source :: ConduitT i (PkgName, String, LBStr) IO ()
source = do
[(String, LBStr)]
tar <- IO [(String, LBStr)]
-> ConduitT i (PkgName, String, LBStr) IO [(String, LBStr)]
forall a. IO a -> ConduitT i (PkgName, String, LBStr) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(String, LBStr)]
-> ConduitT i (PkgName, String, LBStr) IO [(String, LBStr)])
-> IO [(String, LBStr)]
-> ConduitT i (PkgName, 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 (PkgName, String, LBStr) IO ())
-> ConduitT i (PkgName, 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 (PkgName, String, LBStr) IO ())
-> ConduitT i (PkgName, String, LBStr) IO ())
-> ((String, LBStr) -> ConduitT i (PkgName, String, LBStr) IO ())
-> ConduitT i (PkgName, String, LBStr) IO ()
forall a b. (a -> b) -> a -> b
$ \(String -> PkgName
strPack (String -> PkgName) -> (String -> String) -> String -> PkgName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeBaseName -> PkgName
name, LBStr
src) ->
(PkgName, String, LBStr)
-> ConduitT i (PkgName, String, LBStr) IO ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (PkgName
name, PkgName -> String
hackagePackageURL PkgName
name, LBStr
src)
(Map PkgName Package, Set PkgName,
ConduitT () (PkgName, String, LBStr) IO ())
-> IO
(Map PkgName Package, Set PkgName,
ConduitT () (PkgName, String, LBStr) IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PkgName Package
cbl, Set PkgName
want, ConduitT () (PkgName, String, LBStr) IO ()
forall {i}. ConduitT i (PkgName, 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 PkgName Package, Set PkgName,
ConduitT () (PkgName, 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
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 :: [(PkgName, String)]
packages = (String -> (PkgName, String)) -> [String] -> [(PkgName, String)]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PkgName
strPack (String -> PkgName) -> (String -> String) -> String -> PkgName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeBaseName (String -> PkgName)
-> (String -> String) -> String -> (PkgName, String)
forall a b c. (a -> b) -> (a -> c) -> a -> (b, c)
&&& String -> String
forall a. a -> a
id) ([String] -> [(PkgName, String)])
-> [String] -> [(PkgName, 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
[(PkgName, Package)]
cabals <- (String -> IO (PkgName, Package))
-> [String] -> IO [(PkgName, Package)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> IO (PkgName, Package)
parseCabal ([String] -> IO [(PkgName, Package)])
-> [String] -> IO [(PkgName, 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 (PkgName, String, LBStr) IO ()
source = [(PkgName, String)]
-> ((PkgName, String) -> ConduitT i (PkgName, String, LBStr) IO ())
-> ConduitT i (PkgName, String, LBStr) IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(PkgName, String)]
packages (((PkgName, String) -> ConduitT i (PkgName, String, LBStr) IO ())
-> ConduitT i (PkgName, String, LBStr) IO ())
-> ((PkgName, String) -> ConduitT i (PkgName, String, LBStr) IO ())
-> ConduitT i (PkgName, String, LBStr) IO ()
forall a b. (a -> b) -> a -> b
$ \(PkgName
name, String
file) -> do
BStr
src <- IO BStr -> ConduitT i (PkgName, String, LBStr) IO BStr
forall a. IO a -> ConduitT i (PkgName, String, LBStr) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO BStr -> ConduitT i (PkgName, String, LBStr) IO BStr)
-> IO BStr -> ConduitT i (PkgName, String, LBStr) IO BStr
forall a b. (a -> b) -> a -> b
$ String -> IO BStr
bstrReadFile String
file
String
dir <- IO String -> ConduitT i (PkgName, String, LBStr) IO String
forall a. IO a -> ConduitT i (PkgName, String, LBStr) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> ConduitT i (PkgName, String, LBStr) IO String)
-> IO String -> ConduitT i (PkgName, 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. Eq a => [a] -> [a] -> [a] -> [a]
replace String
"\\" String
"/" String
dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/"
(PkgName, String, LBStr)
-> ConduitT i (PkgName, String, LBStr) IO ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (PkgName
name, String
url, [BStr] -> LBStr
lbstrFromChunks [BStr
src])
(Map PkgName Package, Set PkgName,
ConduitT () (PkgName, String, LBStr) IO ())
-> IO
(Map PkgName Package, Set PkgName,
ConduitT () (PkgName, String, LBStr) IO ())
forall a. a -> IO a
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, String) -> (PkgName, Package))
-> [(PkgName, String)] -> [(PkgName, Package)]
forall a b. (a -> b) -> [a] -> [b]
map (PkgName, String) -> (PkgName, Package)
forall {a}. (a, String) -> (a, Package)
generateBarePackage [(PkgName, String)]
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, String) -> PkgName) -> [(PkgName, String)] -> [PkgName]
forall a b. (a -> b) -> [a] -> [b]
map (PkgName, String) -> PkgName
forall a b. (a, b) -> a
fst [(PkgName, String)]
packages, ConduitT () (PkgName, String, LBStr) IO ()
forall {i}. ConduitT i (PkgName, String, LBStr) IO ()
source)
where
parseCabal :: String -> IO (PkgName, 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
(PkgName, Package) -> IO (PkgName, Package)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> PkgName
strPack (String -> PkgName) -> String -> PkgName
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 = (strPack "set", strPack "all") : sets})
where
sets :: [(PkgName, PkgName)]
sets = (String -> (PkgName, PkgName)) -> [String] -> [(PkgName, PkgName)]
forall a b. (a -> b) -> [a] -> [b]
map String -> (PkgName, PkgName)
setFromDir ([String] -> [(PkgName, PkgName)])
-> [String] -> [(PkgName, PkgName)]
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 -> (PkgName, PkgName)
setFromDir String
dir = (String -> PkgName
strPack String
"set", String -> PkgName
strPack (String -> PkgName) -> String -> PkgName
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 PkgName Package, Set PkgName,
ConduitT () (PkgName, 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 (PkgName, String, LBStr) IO ()
source = do
BStr
src <- IO BStr -> ConduitT i (PkgName, String, LBStr) IO BStr
forall a. IO a -> ConduitT i (PkgName, String, LBStr) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO BStr -> ConduitT i (PkgName, String, LBStr) IO BStr)
-> IO BStr -> ConduitT i (PkgName, String, LBStr) IO BStr
forall a b. (a -> b) -> a -> b
$ String -> IO BStr
bstrReadFile String
frege
(PkgName, String, LBStr)
-> ConduitT i (PkgName, String, LBStr) IO ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (String -> PkgName
strPack String
"frege", String
"http://google.com/", [BStr] -> LBStr
lbstrFromChunks [BStr
src])
(Map PkgName Package, Set PkgName,
ConduitT () (PkgName, String, LBStr) IO ())
-> IO
(Map PkgName Package, Set PkgName,
ConduitT () (PkgName, String, LBStr) IO ())
forall a. a -> IO a
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
$ String -> PkgName
strPack String
"frege", ConduitT () (PkgName, String, LBStr) IO ()
forall {i}. ConduitT i (PkgName, 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 PkgName Package, Set PkgName,
ConduitT () (PkgName, String, LBStr) IO ())
readHaskellGhcpkg Timing
timing Settings
settings = do
Map PkgName Package
cbl <- Timing
-> String -> IO (Map PkgName Package) -> IO (Map PkgName Package)
forall (m :: * -> *) a. MonadIO m => Timing -> String -> m a -> m a
timed Timing
timing String
"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, String, LBStr) IO ()
source =
[(PkgName, Package)]
-> ((PkgName, Package)
-> ConduitT i (PkgName, String, LBStr) IO ())
-> ConduitT i (PkgName, String, 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, String, LBStr) IO ())
-> ConduitT i (PkgName, String, LBStr) IO ())
-> ((PkgName, Package)
-> ConduitT i (PkgName, String, LBStr) IO ())
-> ConduitT i (PkgName, String, LBStr) IO ()
forall a b. (a -> b) -> a -> b
$ \(PkgName
name,Package{Bool
[(PkgName, PkgName)]
[PkgName]
Maybe String
PkgName
packageTags :: Package -> [(PkgName, PkgName)]
packageTags :: [(PkgName, PkgName)]
packageLibrary :: Bool
packageSynopsis :: PkgName
packageVersion :: PkgName
packageDepends :: [PkgName]
packageDocs :: Maybe String
packageLibrary :: Package -> Bool
packageSynopsis :: Package -> PkgName
packageVersion :: Package -> PkgName
packageDepends :: Package -> [PkgName]
packageDocs :: Package -> Maybe String
..}) -> Maybe String
-> (String -> ConduitT i (PkgName, String, LBStr) IO ())
-> ConduitT i (PkgName, String, LBStr) IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe String
packageDocs ((String -> ConduitT i (PkgName, String, LBStr) IO ())
-> ConduitT i (PkgName, String, LBStr) IO ())
-> (String -> ConduitT i (PkgName, String, LBStr) IO ())
-> ConduitT i (PkgName, String, LBStr) IO ()
forall a b. (a -> b) -> a -> b
$ \String
docs -> do
let file :: String
file = String
docs String -> String -> String
</> PkgName -> String
strUnpack PkgName
name String -> String -> String
<.> String
"txt"
ConduitT i (PkgName, String, LBStr) IO Bool
-> ConduitT i (PkgName, String, LBStr) IO ()
-> ConduitT i (PkgName, String, LBStr) IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (IO Bool -> ConduitT i (PkgName, String, LBStr) IO Bool
forall a. IO a -> ConduitT i (PkgName, String, LBStr) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ConduitT i (PkgName, String, LBStr) IO Bool)
-> IO Bool -> ConduitT i (PkgName, String, LBStr) IO Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
file) (ConduitT i (PkgName, String, LBStr) IO ()
-> ConduitT i (PkgName, String, LBStr) IO ())
-> ConduitT i (PkgName, String, LBStr) IO ()
-> ConduitT i (PkgName, String, LBStr) IO ()
forall a b. (a -> b) -> a -> b
$ do
BStr
src <- IO BStr -> ConduitT i (PkgName, String, LBStr) IO BStr
forall a. IO a -> ConduitT i (PkgName, String, LBStr) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO BStr -> ConduitT i (PkgName, String, LBStr) IO BStr)
-> IO BStr -> ConduitT i (PkgName, String, LBStr) IO BStr
forall a b. (a -> b) -> a -> b
$ String -> IO BStr
bstrReadFile String
file
String
docs <- IO String -> ConduitT i (PkgName, String, LBStr) IO String
forall a. IO a -> ConduitT i (PkgName, String, LBStr) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> ConduitT i (PkgName, String, LBStr) IO String)
-> IO String -> ConduitT i (PkgName, 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. Eq a => [a] -> [a] -> [a] -> [a]
replace String
"\\" String
"/" (String -> String
addTrailingPathSeparator String
docs)
(PkgName, String, LBStr)
-> ConduitT i (PkgName, String, LBStr) IO ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (PkgName
name, String
url, [BStr] -> LBStr
lbstrFromChunks [BStr
src])
Map PkgName Package
cbl <- Map PkgName Package -> IO (Map PkgName Package)
forall a. a -> IO a
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 = ((String, String) -> (PkgName, PkgName))
-> [(String, String)] -> [(PkgName, PkgName)]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> PkgName) -> (String, String) -> (PkgName, PkgName)
forall a b. (a -> b) -> (a, a) -> (b, b)
both String -> PkgName
strPack) [(String
"set",String
"stackage"),(String
"set",String
"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 = ts ++ packageTags p}) Map PkgName Package
cbl
(Map PkgName Package, Set PkgName,
ConduitT () (PkgName, String, LBStr) IO ())
-> IO
(Map PkgName Package, Set PkgName,
ConduitT () (PkgName, String, LBStr) IO ())
forall a. a -> IO a
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, String, LBStr) IO ()
forall {i}. ConduitT i (PkgName, 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 PkgName Package, Set PkgName,
ConduitT () (PkgName, String, LBStr) IO ())
readHaskellHaddock Timing
timing Settings
settings String
docBaseDir = do
Map PkgName Package
cbl <- Timing
-> String -> IO (Map PkgName Package) -> IO (Map PkgName Package)
forall (m :: * -> *) a. MonadIO m => Timing -> String -> m a -> m a
timed Timing
timing String
"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, String, LBStr) IO ()
source =
[(PkgName, Package)]
-> ((PkgName, Package)
-> ConduitT i (PkgName, String, LBStr) IO ())
-> ConduitT i (PkgName, String, 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, String, LBStr) IO ())
-> ConduitT i (PkgName, String, LBStr) IO ())
-> ((PkgName, Package)
-> ConduitT i (PkgName, String, LBStr) IO ())
-> ConduitT i (PkgName, String, LBStr) IO ()
forall a b. (a -> b) -> a -> b
$ \(PkgName
name, p :: Package
p@Package{Bool
[(PkgName, PkgName)]
[PkgName]
Maybe String
PkgName
packageTags :: Package -> [(PkgName, PkgName)]
packageLibrary :: Package -> Bool
packageSynopsis :: Package -> PkgName
packageVersion :: Package -> PkgName
packageDepends :: Package -> [PkgName]
packageDocs :: Package -> Maybe String
packageTags :: [(PkgName, PkgName)]
packageLibrary :: Bool
packageSynopsis :: PkgName
packageVersion :: PkgName
packageDepends :: [PkgName]
packageDocs :: Maybe String
..}) -> do
let docs :: String
docs = String -> Package -> String
docDir (PkgName -> String
strUnpack PkgName
name) Package
p
file :: String
file = String
docBaseDir String -> String -> String
</> String
docs String -> String -> String
</> (PkgName -> String
strUnpack PkgName
name) String -> String -> String
<.> String
"txt"
ConduitT i (PkgName, String, LBStr) IO Bool
-> ConduitT i (PkgName, String, LBStr) IO ()
-> ConduitT i (PkgName, String, LBStr) IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (IO Bool -> ConduitT i (PkgName, String, LBStr) IO Bool
forall a. IO a -> ConduitT i (PkgName, String, LBStr) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ConduitT i (PkgName, String, LBStr) IO Bool)
-> IO Bool -> ConduitT i (PkgName, String, LBStr) IO Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
file) (ConduitT i (PkgName, String, LBStr) IO ()
-> ConduitT i (PkgName, String, LBStr) IO ())
-> ConduitT i (PkgName, String, LBStr) IO ()
-> ConduitT i (PkgName, String, LBStr) IO ()
forall a b. (a -> b) -> a -> b
$ do
BStr
src <- IO BStr -> ConduitT i (PkgName, String, LBStr) IO BStr
forall a. IO a -> ConduitT i (PkgName, String, LBStr) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO BStr -> ConduitT i (PkgName, String, LBStr) IO BStr)
-> IO BStr -> ConduitT i (PkgName, 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. Eq a => [a] -> [a] -> [a] -> [a]
replace String
"\\" String
"/" (String -> String
addTrailingPathSeparator String
docs)
(PkgName, String, LBStr)
-> ConduitT i (PkgName, String, LBStr) IO ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (PkgName
name, String
url, [BStr] -> LBStr
lbstrFromChunks [BStr
src])
Map PkgName Package
cbl <- Map PkgName Package -> IO (Map PkgName Package)
forall a. a -> IO a
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 = ((String, String) -> (PkgName, PkgName))
-> [(String, String)] -> [(PkgName, PkgName)]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> PkgName) -> (String, String) -> (PkgName, PkgName)
forall a b. (a -> b) -> (a, a) -> (b, b)
both String -> PkgName
strPack) [(String
"set",String
"stackage"),(String
"set",String
"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 = ts ++ packageTags p}) Map PkgName Package
cbl
(Map PkgName Package, Set PkgName,
ConduitT () (PkgName, String, LBStr) IO ())
-> IO
(Map PkgName Package, Set PkgName,
ConduitT () (PkgName, String, LBStr) IO ())
forall a. a -> IO a
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, String, LBStr) IO ()
forall {i}. ConduitT i (PkgName, String, LBStr) IO ()
source)
where docDir :: String -> Package -> String
docDir String
name Package{Bool
[(PkgName, PkgName)]
[PkgName]
Maybe String
PkgName
packageTags :: Package -> [(PkgName, PkgName)]
packageLibrary :: Package -> Bool
packageSynopsis :: Package -> PkgName
packageVersion :: Package -> PkgName
packageDepends :: Package -> [PkgName]
packageDocs :: Package -> Maybe String
packageTags :: [(PkgName, PkgName)]
packageLibrary :: Bool
packageSynopsis :: PkgName
packageVersion :: PkgName
packageDepends :: [PkgName]
packageDocs :: Maybe String
..} = String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ PkgName -> String
strUnpack PkgName
packageVersion
actionGenerate :: CmdLine -> IO ()
actionGenerate :: CmdLine -> IO ()
actionGenerate g :: CmdLine
g@Generate{Bool
String
[String]
Maybe Bool
Maybe Int
Maybe String
Language
download :: Maybe Bool
database :: String
insecure :: Bool
include :: [String]
count :: Maybe Int
local_ :: [String]
haddock :: Maybe String
debug :: Bool
language :: Language
database :: CmdLine -> String
count :: CmdLine -> Maybe Int
language :: CmdLine -> Language
download :: CmdLine -> Maybe Bool
insecure :: CmdLine -> Bool
include :: CmdLine -> [String]
local_ :: CmdLine -> [String]
haddock :: CmdLine -> Maybe String
debug :: CmdLine -> 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
let warnFlagIgnored :: String -> String -> Bool -> String -> IO ()
warnFlagIgnored String
thisFlag String
reason Bool
ignoredFlagPred String
ignoredFlag =
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ignoredFlagPred (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
"Warning: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
thisFlag String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
reason String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", which means " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
ignoredFlag String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is ignored."
let doDownload :: Download
doDownload String
name String
url = do
let download' :: DownloadInput
download' = case Maybe Bool
download of
Just Bool
True -> DownloadInput
AlwaysDownloadInput
Just Bool
False -> DownloadInput
NeverDownloadInput
Maybe Bool
Nothing -> DownloadInput
DownloadInputIfNotThere
Timing -> Bool -> DownloadInput -> String -> Download
downloadInput Timing
timing Bool
insecure DownloadInput
download' (String -> String
takeDirectory String
database) String
name String
url
Settings
settings <- IO Settings
loadSettings
(Map PkgName Package
cbl, Set PkgName
want, ConduitT () (PkgName, String, LBStr) IO ()
source) <- case Language
language of
Language
Haskell | Just String
dir <- Maybe String
haddock -> do
String -> String -> Bool -> String -> IO ()
warnFlagIgnored String
"--haddock" String
"set" ([String]
local_ [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
/= []) String
"--local"
String -> String -> Bool -> String -> IO ()
warnFlagIgnored String
"--haddock" String
"set" (Maybe Bool -> Bool
forall a. Maybe a -> Bool
isJust Maybe Bool
download) String
"--download"
Timing
-> Settings
-> String
-> IO
(Map PkgName Package, Set PkgName,
ConduitT () (PkgName, String, LBStr) IO ())
readHaskellHaddock Timing
timing Settings
settings String
dir
| [String
""] <- [String]
local_ -> do
String -> String -> Bool -> String -> IO ()
warnFlagIgnored String
"--local" String
"used as flag (no paths)" (Maybe Bool -> Bool
forall a. Maybe a -> Bool
isJust Maybe Bool
download) String
"--download"
Timing
-> Settings
-> IO
(Map PkgName Package, Set PkgName,
ConduitT () (PkgName, String, LBStr) IO ())
readHaskellGhcpkg Timing
timing Settings
settings
| [] <- [String]
local_ -> do Timing
-> Settings
-> Download
-> IO
(Map PkgName Package, Set PkgName,
ConduitT () (PkgName, String, LBStr) IO ())
readHaskellOnline Timing
timing Settings
settings Download
doDownload
| Bool
otherwise -> Timing
-> Settings
-> [String]
-> IO
(Map PkgName Package, Set PkgName,
ConduitT () (PkgName, String, LBStr) IO ())
readHaskellDirs Timing
timing Settings
settings [String]
local_
Language
Frege | [] <- [String]
local_ -> Timing
-> Download
-> IO
(Map PkgName Package, Set PkgName,
ConduitT () (PkgName, String, LBStr) IO ())
readFregeOnline Timing
timing Download
doDownload
| Bool
otherwise -> String
-> IO
(Map PkgName Package, Set PkgName,
ConduitT () (PkgName, String, LBStr) IO ())
forall a. Partial => String -> IO a
errorIO String
"No support for local Frege databases"
([String]
cblErrs, Map PkgName Int
popularity) <- ([String], Map PkgName Int) -> IO ([String], Map PkgName Int)
forall a. a -> IO a
evaluate (([String], Map PkgName Int) -> IO ([String], Map PkgName Int))
-> ([String], Map PkgName Int) -> IO ([String], Map PkgName Int)
forall a b. (a -> b) -> a -> b
$ Map PkgName Package -> ([String], 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=[]}) Map PkgName Package
cbl
Map PkgName Int -> IO (Map PkgName Int)
forall a. a -> IO a
evaluate Map PkgName Int
popularity
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 (String -> PkgName
strPack String
"mtl") Map PkgName Int
popularity) (String -> PkgName
strPack String
"transformers") Map PkgName Int
popularity
Set PkgName
want <- Set PkgName -> IO (Set PkgName)
forall a. a -> IO a
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 [String]
include [String] -> [String] -> 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
$ (String -> PkgName) -> [String] -> [PkgName]
forall a b. (a -> b) -> [a] -> [b]
map String -> PkgName
strPack [String]
include else Set PkgName
want
Set PkgName
want <- Set PkgName -> IO (Set PkgName)
forall a. a -> IO a
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
([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 a. [a] -> 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, (PkgName, String, LBStr)) (Maybe Target, [Item]) IO ()
consume = ((Int, (PkgName, String, LBStr))
-> ConduitM
(Int, (PkgName, String, LBStr)) (Maybe Target, [Item]) IO ())
-> ConduitM
(Int, (PkgName, 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, (PkgName, String, LBStr))
-> ConduitM
(Int, (PkgName, String, LBStr)) (Maybe Target, [Item]) IO ())
-> ConduitM
(Int, (PkgName, String, LBStr)) (Maybe Target, [Item]) IO ())
-> ((Int, (PkgName, String, LBStr))
-> ConduitM
(Int, (PkgName, String, LBStr)) (Maybe Target, [Item]) IO ())
-> ConduitM
(Int, (PkgName, String, LBStr)) (Maybe Target, [Item]) IO ()
forall a b. (a -> b) -> a -> b
$ \(Int
i, (PkgName -> String
strUnpack -> String
pkg, String
url, LBStr
body)) -> do
Timing
-> String
-> ConduitM
(Int, (PkgName, String, LBStr)) (Maybe Target, [Item]) IO ()
-> ConduitM
(Int, (PkgName, 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 PkgName -> Int
forall a. Set a -> Int
Set.size Set PkgName
want) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"] " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pkg) (ConduitM
(Int, (PkgName, String, LBStr)) (Maybe Target, [Item]) IO ()
-> ConduitM
(Int, (PkgName, String, LBStr)) (Maybe Target, [Item]) IO ())
-> ConduitM
(Int, (PkgName, String, LBStr)) (Maybe Target, [Item]) IO ()
-> ConduitM
(Int, (PkgName, String, LBStr)) (Maybe Target, [Item]) IO ()
forall a b. (a -> b) -> a -> b
$
(String -> IO ())
-> String
-> LBStr
-> ConduitM
(Int, (PkgName, 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 () (PkgName, String, LBStr) IO ()
source ConduitT () (PkgName, String, LBStr) IO ()
-> ConduitT
(PkgName, 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
.|
((PkgName, String, LBStr) -> Bool)
-> ConduitT (PkgName, String, LBStr) (PkgName, String, 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, String, LBStr) -> PkgName)
-> (PkgName, String, LBStr)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PkgName, String, LBStr) -> PkgName
forall a b c. (a, b, c) -> a
fst3) ConduitT (PkgName, String, LBStr) (PkgName, String, LBStr) IO ()
-> ConduitT
(PkgName, String, LBStr) Void IO [(Maybe TargetId, [Item])]
-> ConduitT
(PkgName, 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
(PkgName, String, LBStr) (Maybe Target, [Item]) IO ((), ())
-> ConduitT (PkgName, String, LBStr) (Maybe Target, [Item]) IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ConduitT (PkgName, String, LBStr) (Maybe Target, [Item]) IO ()
-> ConduitT (PkgName, String, LBStr) (Maybe Target, [Item]) IO ()
-> ConduitT
(PkgName, 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
(PkgName, String, LBStr) (Int, (PkgName, String, LBStr)) IO ()
forall (m :: * -> *) i a.
(Monad m, Enum i) =>
i -> ConduitM a (i, a) m ()
zipFromC Int
1 ConduitM
(PkgName, String, LBStr) (Int, (PkgName, String, LBStr)) IO ()
-> ConduitM
(Int, (PkgName, String, LBStr)) (Maybe Target, [Item]) IO ()
-> ConduitT (PkgName, 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, (PkgName, String, LBStr)) (Maybe Target, [Item]) IO ()
consume)
(do Set PkgName
seen <- ([PkgName] -> Set PkgName)
-> ConduitT
(PkgName, String, LBStr) (Maybe Target, [Item]) IO [PkgName]
-> ConduitT
(PkgName, String, LBStr) (Maybe Target, [Item]) IO (Set PkgName)
forall a b.
(a -> b)
-> ConduitT (PkgName, String, LBStr) (Maybe Target, [Item]) IO a
-> ConduitT (PkgName, String, LBStr) (Maybe Target, [Item]) IO b
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, String, LBStr) (Maybe Target, [Item]) IO [PkgName]
-> ConduitT
(PkgName, String, LBStr) (Maybe Target, [Item]) IO (Set PkgName))
-> ConduitT
(PkgName, String, LBStr) (Maybe Target, [Item]) IO [PkgName]
-> ConduitT
(PkgName, String, LBStr) (Maybe Target, [Item]) IO (Set PkgName)
forall a b. (a -> b) -> a -> b
$ ((PkgName, String, LBStr) -> IO PkgName)
-> ConduitT (PkgName, String, 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, String, LBStr) -> PkgName)
-> (PkgName, String, 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, String, LBStr) -> PkgName)
-> (PkgName, String, LBStr)
-> PkgName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PkgName -> PkgName
strCopy (PkgName -> PkgName)
-> ((PkgName, String, LBStr) -> PkgName)
-> (PkgName, String, LBStr)
-> PkgName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PkgName, String, LBStr) -> PkgName
forall a b c. (a, b, c) -> a
fst3) ConduitT (PkgName, String, LBStr) PkgName IO ()
-> ConduitT PkgName (Maybe Target, [Item]) IO [PkgName]
-> ConduitT
(PkgName, String, LBStr) (Maybe Target, [Item]) IO [PkgName]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT 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 a b. (a -> b) -> Maybe a -> Maybe b
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, String, LBStr) (Maybe Target, [Item]) IO ()
forall a.
IO a
-> ConduitT (PkgName, String, LBStr) (Maybe Target, [Item]) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
-> ConduitT (PkgName, String, LBStr) (Maybe Target, [Item]) IO ())
-> IO ()
-> ConduitT (PkgName, String, LBStr) (Maybe Target, [Item]) IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
""
IO ()
-> ConduitT (PkgName, String, LBStr) (Maybe Target, [Item]) IO ()
forall a.
IO a
-> ConduitT (PkgName, String, LBStr) (Maybe Target, [Item]) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
-> ConduitT (PkgName, String, LBStr) (Maybe Target, [Item]) IO ())
-> IO ()
-> ConduitT (PkgName, 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 ([PkgName]
missing [PkgName] -> [PkgName] -> 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
$ (PkgName -> String) -> [PkgName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PkgName -> String
strUnpack [PkgName]
missing)
IO ()
-> ConduitT (PkgName, String, LBStr) (Maybe Target, [Item]) IO ()
forall a.
IO a
-> ConduitT (PkgName, String, LBStr) (Maybe Target, [Item]) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
-> ConduitT (PkgName, String, LBStr) (Maybe Target, [Item]) IO ())
-> IO ()
-> ConduitT (PkgName, 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 PkgName -> Bool
forall a. Set a -> Bool
Set.null Set PkgName
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)"
[(PkgName, Package)]
-> ((PkgName, Package)
-> ConduitT (PkgName, String, LBStr) (Maybe Target, [Item]) IO ())
-> ConduitT (PkgName, String, 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, String, LBStr) (Maybe Target, [Item]) IO ())
-> ConduitT (PkgName, String, LBStr) (Maybe Target, [Item]) IO ())
-> ((PkgName, Package)
-> ConduitT (PkgName, String, LBStr) (Maybe Target, [Item]) IO ())
-> ConduitT (PkgName, String, LBStr) (Maybe Target, [Item]) IO ()
forall a b. (a -> b) -> a -> b
$ \(PkgName
name, Package{Bool
[(PkgName, PkgName)]
[PkgName]
Maybe String
PkgName
packageTags :: Package -> [(PkgName, PkgName)]
packageLibrary :: Package -> Bool
packageSynopsis :: Package -> PkgName
packageVersion :: Package -> PkgName
packageDepends :: Package -> [PkgName]
packageDocs :: Package -> Maybe String
packageTags :: [(PkgName, PkgName)]
packageLibrary :: Bool
packageSynopsis :: PkgName
packageVersion :: PkgName
packageDepends :: [PkgName]
packageDocs :: Maybe String
..}) -> Bool
-> ConduitT (PkgName, String, LBStr) (Maybe Target, [Item]) IO ()
-> ConduitT (PkgName, String, 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, String, LBStr) (Maybe Target, [Item]) IO ()
-> ConduitT (PkgName, String, LBStr) (Maybe Target, [Item]) IO ())
-> ConduitT (PkgName, String, LBStr) (Maybe Target, [Item]) IO ()
-> ConduitT (PkgName, 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
$ PkgName -> String -> (Maybe Target, [Item])
fakePackage PkgName
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 (PkgName -> String
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 String
-> ConduitT (PkgName, 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 (PkgName, 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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
include then
String
-> ConduitT (PkgName, 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 (PkgName, String, LBStr) (Maybe Target, [Item]) IO ()
forall a.
a -> ConduitT (PkgName, String, LBStr) (Maybe Target, [Item]) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
))
ConduitT (PkgName, String, LBStr) (Maybe Target, [Item]) IO ()
-> ConduitT
(Maybe Target, [Item]) Void IO [(Maybe TargetId, [Item])]
-> ConduitT
(PkgName, 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 a. a -> IO a
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 a. a -> IO a
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 -> 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
-> (PkgName -> Bool)
-> (PkgName -> [(String, String)])
-> [(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 -> [(String, String)]
-> (Package -> [(String, String)])
-> Maybe Package
-> [(String, String)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (((PkgName, PkgName) -> (String, String))
-> [(PkgName, PkgName)] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map ((PkgName -> String) -> (PkgName, PkgName) -> (String, String)
forall a b. (a -> b) -> (a, a) -> (b, b)
both PkgName -> String
strUnpack) ([(PkgName, PkgName)] -> [(String, String)])
-> (Package -> [(PkgName, PkgName)])
-> Package
-> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Package -> [(PkgName, PkgName)]
packageTags) (Maybe Package -> [(String, String)])
-> Maybe Package -> [(String, String)]
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 -> 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