{-# LANGUAGE OverloadedStrings, CPP #-}

module HsDev.PackageDb (
		module HsDev.PackageDb.Types,

		packageDbPath, readPackageDb
		) where

import Control.Lens
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (listToMaybe)
import Data.Text (pack, unpack)
import qualified Data.Text.Encoding as E (encodeUtf8)
import Data.Traversable
import Distribution.InstalledPackageInfo
import Distribution.Package
import Distribution.Text (display)
import System.FilePath

import GHC.Paths

import HsDev.PackageDb.Types
import HsDev.Error
import HsDev.Symbols.Location
import HsDev.Tools.Base
import HsDev.Util (directoryContents, readFileUtf8)
import System.Directory.Paths

-- | Get path to package-db
packageDbPath :: PackageDb -> IO Path
packageDbPath :: PackageDb -> IO Path
packageDbPath PackageDb
GlobalDb = do
		[String]
out <- (String -> [String]) -> IO String -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> [String]
lines (IO String -> IO [String]) -> IO String -> IO [String]
forall a b. (a -> b) -> a -> b
$ String -> [String] -> IO String
runTool_ String
ghc_pkg [String
"list", String
"--global"]
		case [String]
out of
				(String
fpath:[String]
_) -> Path -> IO Path
forall (m :: * -> *) a. Monad m => a -> m a
return (Path -> IO Path) -> Path -> IO Path
forall a b. (a -> b) -> a -> b
$ String -> Path
fromFilePath (String -> Path) -> String -> Path
forall a b. (a -> b) -> a -> b
$ String -> String
normalise String
fpath
				[] -> HsDevError -> IO Path
forall (m :: * -> *) a. MonadThrow m => HsDevError -> m a
hsdevError (HsDevError -> IO Path) -> HsDevError -> IO Path
forall a b. (a -> b) -> a -> b
$ String -> String -> HsDevError
ToolError String
ghc_pkg String
"empty output, expecting path to global package-db"
packageDbPath PackageDb
UserDb = do
		[String]
out <- (String -> [String]) -> IO String -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> [String]
lines (IO String -> IO [String]) -> IO String -> IO [String]
forall a b. (a -> b) -> a -> b
$ String -> [String] -> IO String
runTool_ String
ghc_pkg [String
"list", String
"--user"]
		case [String]
out of
				(String
fpath:[String]
_) -> Path -> IO Path
forall (m :: * -> *) a. Monad m => a -> m a
return (Path -> IO Path) -> Path -> IO Path
forall a b. (a -> b) -> a -> b
$ String -> Path
fromFilePath (String -> Path) -> String -> Path
forall a b. (a -> b) -> a -> b
$ String -> String
normalise String
fpath
		 -- Bailing on the user package db if there isn't one doesn't seem quite correct. 'stack' and 'cabal'
		 -- can report no path...
		 -- 	[] -> hsdevError $ ToolError ghc_pkg "empty output, expecting path to user package db"
		 -- Report an empty path instead.
				[] -> Path -> IO Path
forall (m :: * -> *) a. Monad m => a -> m a
return (Path -> IO Path) -> Path -> IO Path
forall a b. (a -> b) -> a -> b
$ String -> Path
fromFilePath String
""
packageDbPath (PackageDb Path
fpath) = Path -> IO Path
forall (m :: * -> *) a. Monad m => a -> m a
return Path
fpath

-- | Read package-db conf files
readPackageDb :: PackageDb -> IO (Map ModulePackage [ModuleLocation])
readPackageDb :: PackageDb -> IO (Map ModulePackage [ModuleLocation])
readPackageDb PackageDb
pdb = do
		Path
p <- PackageDb -> IO Path
packageDbPath PackageDb
pdb
		Maybe String
mlibdir <- (String -> Maybe String) -> IO String -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe ([String] -> Maybe String)
-> (String -> [String]) -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines) (IO String -> IO (Maybe String)) -> IO String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> [String] -> IO String
runTool_ String
ghc [String
"--print-libdir"]
		[String]
confs <- ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
isConf) (IO [String] -> IO [String]) -> IO [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ String -> IO [String]
directoryContents (Path
p Path -> Getting String Path String -> String
forall s a. s -> Getting a s a -> a
^. Getting String Path String
Lens' Path String
path)
		([Map ModulePackage [ModuleLocation]]
 -> Map ModulePackage [ModuleLocation])
-> IO [Map ModulePackage [ModuleLocation]]
-> IO (Map ModulePackage [ModuleLocation])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Map ModulePackage [ModuleLocation]]
-> Map ModulePackage [ModuleLocation]
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
M.unions (IO [Map ModulePackage [ModuleLocation]]
 -> IO (Map ModulePackage [ModuleLocation]))
-> IO [Map ModulePackage [ModuleLocation]]
-> IO (Map ModulePackage [ModuleLocation])
forall a b. (a -> b) -> a -> b
$ [String]
-> (String -> IO (Map ModulePackage [ModuleLocation]))
-> IO [Map ModulePackage [ModuleLocation]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
confs ((String -> IO (Map ModulePackage [ModuleLocation]))
 -> IO [Map ModulePackage [ModuleLocation]])
-> (String -> IO (Map ModulePackage [ModuleLocation]))
-> IO [Map ModulePackage [ModuleLocation]]
forall a b. (a -> b) -> a -> b
$ \String
conf -> do
				Path
cts <- String -> IO Path
readFileUtf8 String
conf
				case Either (NonEmpty String) ([String], InstalledPackageInfo)
-> Either (NonEmpty String) ([String], InstalledPackageInfo)
forall a. a -> a
parseResult (ByteString
-> Either (NonEmpty String) ([String], InstalledPackageInfo)
parseInstalledPackageInfo (Path -> ByteString
unpackCts Path
cts)) of
						Left NonEmpty String
_ -> Map ModulePackage [ModuleLocation]
-> IO (Map ModulePackage [ModuleLocation])
forall (m :: * -> *) a. Monad m => a -> m a
return Map ModulePackage [ModuleLocation]
forall k a. Map k a
M.empty  -- FIXME: Should log as warning
						Right ([String]
_, InstalledPackageInfo
res) -> ([ModuleLocation] -> IO [ModuleLocation])
-> Map ModulePackage [ModuleLocation]
-> IO (Map ModulePackage [ModuleLocation])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((ModuleLocation -> IO ModuleLocation)
-> [ModuleLocation] -> IO [ModuleLocation]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ModuleLocation -> IO ModuleLocation
forall a. Paths a => a -> IO a
canonicalize) (Map ModulePackage [ModuleLocation]
 -> IO (Map ModulePackage [ModuleLocation]))
-> Map ModulePackage [ModuleLocation]
-> IO (Map ModulePackage [ModuleLocation])
forall a b. (a -> b) -> a -> b
$
							ASetter
  (Map ModulePackage [ModuleLocation])
  (Map ModulePackage [ModuleLocation])
  Path
  Path
-> (Path -> Path)
-> Map ModulePackage [ModuleLocation]
-> Map ModulePackage [ModuleLocation]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (([ModuleLocation] -> Identity [ModuleLocation])
-> Map ModulePackage [ModuleLocation]
-> Identity (Map ModulePackage [ModuleLocation])
forall s t a b. Each s t a b => Traversal s t a b
each (([ModuleLocation] -> Identity [ModuleLocation])
 -> Map ModulePackage [ModuleLocation]
 -> Identity (Map ModulePackage [ModuleLocation]))
-> ((Path -> Identity Path)
    -> [ModuleLocation] -> Identity [ModuleLocation])
-> ASetter
     (Map ModulePackage [ModuleLocation])
     (Map ModulePackage [ModuleLocation])
     Path
     Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleLocation -> Identity ModuleLocation)
-> [ModuleLocation] -> Identity [ModuleLocation]
forall s t a b. Each s t a b => Traversal s t a b
each ((ModuleLocation -> Identity ModuleLocation)
 -> [ModuleLocation] -> Identity [ModuleLocation])
-> ((Path -> Identity Path)
    -> ModuleLocation -> Identity ModuleLocation)
-> (Path -> Identity Path)
-> [ModuleLocation]
-> Identity [ModuleLocation]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Path] -> Identity [Path])
-> ModuleLocation -> Identity ModuleLocation
Traversal' ModuleLocation [Path]
moduleInstallDirs (([Path] -> Identity [Path])
 -> ModuleLocation -> Identity ModuleLocation)
-> ((Path -> Identity Path) -> [Path] -> Identity [Path])
-> (Path -> Identity Path)
-> ModuleLocation
-> Identity ModuleLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path -> Identity Path) -> [Path] -> Identity [Path]
forall s t a b. Each s t a b => Traversal s t a b
each) (Maybe String -> Path -> Path
subst Maybe String
mlibdir) (Map ModulePackage [ModuleLocation]
 -> Map ModulePackage [ModuleLocation])
-> Map ModulePackage [ModuleLocation]
-> Map ModulePackage [ModuleLocation]
forall a b. (a -> b) -> a -> b
$ InstalledPackageInfo -> Map ModulePackage [ModuleLocation]
listMods InstalledPackageInfo
res
		where
#if MIN_VERSION_Cabal(3,2,0)
				unpackCts :: Path -> ByteString
unpackCts = Path -> ByteString
E.encodeUtf8
#else
				unpackCts = unpack
#endif

#if MIN_VERSION_Cabal(3,0,0)
				parseResult :: a -> a
parseResult = a -> a
forall a. a -> a
id
#else
				parseResult (ParseFailed e) = Left [show e]
				parseResult (ParseOk ws res) = Right (map show ws, res)
#endif

				isConf :: String -> Bool
isConf String
f = String -> String
takeExtension String
f String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".conf"
				listMods :: InstalledPackageInfo -> Map ModulePackage [ModuleLocation]
listMods InstalledPackageInfo
pinfo = ModulePackage
-> [ModuleLocation] -> Map ModulePackage [ModuleLocation]
forall k a. k -> a -> Map k a
M.singleton ModulePackage
pname [ModuleLocation]
pmods where
						pname :: ModulePackage
pname = Path -> Path -> ModulePackage
ModulePackage
								(String -> Path
pack (String -> Path)
-> (PackageIdentifier -> String) -> PackageIdentifier -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
forall a. Pretty a => a -> String
display (PackageName -> String)
-> (PackageIdentifier -> PackageName)
-> PackageIdentifier
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> Path) -> PackageIdentifier -> Path
forall a b. (a -> b) -> a -> b
$ InstalledPackageInfo -> PackageIdentifier
sourcePackageId InstalledPackageInfo
pinfo)
								(String -> Path
pack (String -> Path)
-> (PackageIdentifier -> String) -> PackageIdentifier -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> String
forall a. Pretty a => a -> String
display (Version -> String)
-> (PackageIdentifier -> Version) -> PackageIdentifier -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> Version
pkgVersion (PackageIdentifier -> Path) -> PackageIdentifier -> Path
forall a b. (a -> b) -> a -> b
$ InstalledPackageInfo -> PackageIdentifier
sourcePackageId InstalledPackageInfo
pinfo)
						pmods :: [ModuleLocation]
pmods = [[Path] -> ModulePackage -> Path -> Bool -> ModuleLocation
InstalledModule ((String -> Path) -> [String] -> [Path]
forall a b. (a -> b) -> [a] -> [b]
map String -> Path
fromFilePath ([String] -> [Path]) -> [String] -> [Path]
forall a b. (a -> b) -> a -> b
$ InstalledPackageInfo -> [String]
libraryDirs InstalledPackageInfo
pinfo) ModulePackage
pname Path
nm Bool
exposed' | (Path
nm, Bool
exposed') <- [(Path, Bool)]
names]
						names :: [(Path, Bool)]
names = [Path] -> [Bool] -> [(Path, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((ExposedModule -> Path) -> [ExposedModule] -> [Path]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Path
pack (String -> Path)
-> (ExposedModule -> String) -> ExposedModule -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExposedModule -> String
forall a. Pretty a => a -> String
display) (InstalledPackageInfo -> [ExposedModule]
exposedModules InstalledPackageInfo
pinfo)) (Bool -> [Bool]
forall a. a -> [a]
repeat Bool
True) [(Path, Bool)] -> [(Path, Bool)] -> [(Path, Bool)]
forall a. [a] -> [a] -> [a]
++ [Path] -> [Bool] -> [(Path, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((ModuleName -> Path) -> [ModuleName] -> [Path]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Path
pack (String -> Path) -> (ModuleName -> String) -> ModuleName -> Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> String
forall a. Pretty a => a -> String
display) (InstalledPackageInfo -> [ModuleName]
hiddenModules InstalledPackageInfo
pinfo)) (Bool -> [Bool]
forall a. a -> [a]
repeat Bool
False)
				subst :: Maybe String -> Path -> Path
subst Maybe String
Nothing Path
f = Path
f
				subst (Just String
libdir') Path
f = case Path -> [Path]
splitPaths Path
f of
						(Path
"$topdir":[Path]
rest) -> [Path] -> Path
joinPaths (String -> Path
fromFilePath String
libdir' Path -> [Path] -> [Path]
forall a. a -> [a] -> [a]
: [Path]
rest)
						[Path]
_ -> Path
f