module Codex.Project where
import Control.Exception (try, SomeException)
import Data.Functor
import Data.Function
import Data.Maybe
import Data.Traversable (traverse)
import Distribution.InstalledPackageInfo
import Distribution.Hackage.DB (Hackage, readHackage)
import Distribution.Hackage.Utils
import Distribution.Package
import Distribution.PackageDescription
import Distribution.PackageDescription.Parse
import Distribution.Simple.Configure
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.PackageIndex
import Distribution.Package
import Distribution.Utils (identifier, findPackageDescription, findProjects, readProject)
import Distribution.Verbosity
import Distribution.Version
import System.Directory
import System.FilePath
import qualified Data.List as List
import qualified Data.Map as Map
newtype Workspace = Workspace [WorkspaceProject]
deriving (Eq, Show)
data WorkspaceProject = WorkspaceProject { workspaceProjectIdentifier :: PackageIdentifier, workspaceProjectPath :: FilePath }
deriving (Eq, Show)
type ProjectDependencies = (PackageIdentifier, [PackageIdentifier], [WorkspaceProject])
allDependencies :: GenericPackageDescription -> [Dependency]
allDependencies pd = List.filter (not . isCurrent) $ concat [lds, eds, tds] where
lds = condTreeConstraints =<< (maybeToList $ condLibrary pd)
eds = (condTreeConstraints . snd) =<< condExecutables pd
tds = (condTreeConstraints . snd) =<< condTestSuites pd
isCurrent (Dependency n _) = n == (pkgName $ identifier pd)
resolveCurrentProjectDependencies :: IO ProjectDependencies
resolveCurrentProjectDependencies = do
ws <- getWorkspace ".."
resolveProjectDependencies ws "."
resolveProjectDependencies :: Workspace -> FilePath -> IO ProjectDependencies
resolveProjectDependencies ws root = do
pd <- maybe (error "No cabal file found.") id <$> findPackageDescription root
xs <- resolvePackageDependencies root pd
ys <- resolveSandboxDependencies root
let zs = resolveWorkspaceDependencies ws pd
let wsds = List.filter (shouldOverride xs) $ List.nubBy (on (==) prjId) $ concat [ys, zs]
let pjds = List.filter (\x -> List.notElem (pkgName x) $ fmap prjId wsds) xs
return (identifier pd, pjds, wsds) where
shouldOverride xs (WorkspaceProject x _) =
maybe True (\y -> pkgVersion x >= pkgVersion y) $ List.find (\y -> pkgName x == pkgName y) xs
prjId = pkgName . workspaceProjectIdentifier
resolveInstalledDependencies :: FilePath -> IO (Either SomeException [PackageIdentifier])
resolveInstalledDependencies root = try $ do
lbi <- getPersistBuildConfig distPref
let pkg = localPkgDescr lbi
ipkgs = installedPkgs lbi
clbis = snd <$> allComponentsInBuildOrder lbi
pkgs = componentPackageDeps =<< clbis
ys = (maybeToList . lookupInstalledPackageId ipkgs) =<< fmap fst pkgs
xs = fmap sourcePackageId $ ys
return xs where
distPref = root </> "dist"
resolveHackageDependencies :: Hackage -> GenericPackageDescription -> [GenericPackageDescription]
resolveHackageDependencies db pd = maybeToList . resolveDependency db =<< allDependencies pd where
resolveDependency db (Dependency (PackageName name) versionRange) = do
pdsByVersion <- Map.lookup name db
latest <- List.find (\x -> withinRange x versionRange) $ List.reverse $ List.sort $ Map.keys pdsByVersion
Map.lookup latest pdsByVersion
resolvePackageDependencies :: FilePath -> GenericPackageDescription -> IO [PackageIdentifier]
resolvePackageDependencies root pd = do
xs <- either (fallback pd) return =<< resolveInstalledDependencies root
return xs where
fallback pd e = do
putStrLn $ concat ["cabal: ", show e]
putStrLn "codex: *warning* falling back on dependency resolution using hackage"
resolveWithHackage pd
resolveWithHackage pd = do
db <- readHackage
return $ identifier <$> resolveHackageDependencies db pd
resolveSandboxDependencies :: FilePath -> IO [WorkspaceProject]
resolveSandboxDependencies root = do
fileExists <- doesFileExist sourcesFile
if fileExists then readSources else return [] where
readSources = do
fileContent <- readFile sourcesFile
xs <- traverse readWorkspaceProject $ projects fileContent
return $ xs >>= maybeToList where
projects :: String -> [FilePath]
projects x = sources x >>= (\x -> fmap fst $ snd x)
sources :: String -> [(String, [(FilePath, Int)])]
sources x = read x
sourcesFile = root </> ".cabal-sandbox" </> "add-source-timestamps"
resolveWorkspaceDependencies :: Workspace -> GenericPackageDescription -> [WorkspaceProject]
resolveWorkspaceDependencies (Workspace ws) pd = maybeToList . resolveDependency =<< allDependencies pd where
resolveDependency (Dependency name versionRange) =
List.find (\(WorkspaceProject (PackageIdentifier n v) _) -> n == name && withinRange v versionRange) ws
readWorkspaceProject :: FilePath -> IO (Maybe WorkspaceProject)
readWorkspaceProject fp = do
maybePrj <- readProject fp
return $ (\(path, id) -> WorkspaceProject id path) <$> maybePrj
getWorkspace :: FilePath -> IO Workspace
getWorkspace fp = do
prjs <- findProjects fp
return $ Workspace $ (\(path, id) -> WorkspaceProject id path) <$> prjs