module Codex.Project where
import Control.Exception (try, SomeException)
import Data.Functor
import Data.Maybe
import Data.String.Utils
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.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 PackageIdentifier FilePath
deriving (Eq, Show)
type ProjectDependencies = (PackageIdentifier, [PackageIdentifier], [WorkspaceProject])
identifier :: GenericPackageDescription -> PackageIdentifier
identifier = package . packageDescription
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)
findPackageDescription :: FilePath -> IO (Maybe GenericPackageDescription)
findPackageDescription root = do
files <- getDirectoryContents root
traverse (readPackageDescription silent) $ fmap (\x -> root </> x) $ List.find (endswith ".cabal") files
resolveCurrentProjectDependencies :: IO ProjectDependencies
resolveCurrentProjectDependencies = do
ws <- getWorkspace ".."
resolveProjectDependenciesWithWorkspace ws "."
resolveProjectDependenciesWithWorkspace :: Workspace -> FilePath -> IO ProjectDependencies
resolveProjectDependenciesWithWorkspace ws root = do
pd <- maybe (error "No cabal file found.") id <$> findPackageDescription root
xs <- resolveProjectDependencies root pd
let wsds = List.filter (shouldOverride xs) $ resolveWorkspaceDependencies ws pd
let pjds = List.filter (\x -> List.notElem (pkgName x) $ fmap (\(WorkspaceProject x _) -> pkgName x) 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
resolveProjectDependencies :: FilePath -> GenericPackageDescription -> IO [PackageIdentifier]
resolveProjectDependencies 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
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
xs = fmap sourcePackageId $ (maybeToList . lookupInstalledPackageId ipkgs) =<< fmap fst pkgs
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
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
getWorkspace :: FilePath -> IO Workspace
getWorkspace _root = do
root <- canonicalizePath _root
xs <- listDirectory root
ys <- traverse find xs
return . Workspace $ ys >>= maybeToList where
find path = do
isDirectory <- doesDirectoryExist path
if isDirectory then do
pd <- findPackageDescription path
return $ fmap (\x -> WorkspaceProject (identifier x) path) pd
else return Nothing
listDirectory fp = do
xs <- getDirectoryContents fp
return . fmap (fp </>) $ filter (not . startswith ".") xs