CabalApi.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}

module Hhp.CabalApi (
    getCompilerOptions,
    parseCabalFile,
    cabalAllBuildInfo,
    cabalDependPackages,
    cabalSourceDirs,
    cabalAllTargets,
) where

import Distribution.Compiler (AbiTag (NoAbiTag), unknownCompilerInfo)
import Distribution.ModuleName (ModuleName, toFilePath)
import Distribution.Package (Dependency (Dependency))
import qualified Distribution.Package as C
import Distribution.PackageDescription (
    BuildInfo,
    Executable,
    PackageDescription,
    TestSuite,
    TestSuiteInterface (..),
 )
import qualified Distribution.PackageDescription as P
import Distribution.PackageDescription.Configuration (finalizePD)
import Distribution.Simple.Compiler (CompilerFlavor (..), CompilerId (..))
import Distribution.Simple.Program (ghcProgram)
import Distribution.Simple.Program.Types (programFindVersion, programName)
import Distribution.System (buildPlatform)
import Distribution.Text (display)
import Distribution.Verbosity (silent)
import Distribution.Version (Version)
#if MIN_VERSION_Cabal(3,8,0)
import Distribution.Simple.PackageDescription (readGenericPackageDescription)
#else
import Distribution.PackageDescription.Parsec (readGenericPackageDescription)
#endif
import Distribution.Types.ComponentRequestedSpec (defaultComponentRequestedSpec)
import Distribution.Types.Flag (mkFlagAssignment, mkFlagName)
import Distribution.Types.PackageName (unPackageName)
#if MIN_VERSION_Cabal(3,6,0)
import Distribution.Utils.Path (getSymbolicPath, SymbolicPath)
#endif
#if MIN_VERSION_Cabal(3,14,0)
import qualified Distribution.Utils.Path as Path
#endif

import GHC.Utils.Monad (liftIO)

import Control.Exception (throwIO)
import Control.Monad (filterM)
import Data.Maybe (fromMaybe, mapMaybe, maybeToList)
import Data.Set (fromList, toList)
import System.Directory (doesFileExist)
import System.Environment (lookupEnv)
import System.FilePath (dropExtension, takeFileName, (</>))

import Hhp.GhcPkg
import Hhp.Types

----------------------------------------------------------------

-- | Getting necessary 'CompilerOptions' from three information sources.
getCompilerOptions
    :: [GHCOption]
    -> Cradle
    -> PackageDescription
    -> IO CompilerOptions
getCompilerOptions ghcopts cradle pkgDesc = do
    gopts <- getGHCOptions ghcopts cradle rdir $ unsafeHead buildInfos
    dbPkgs <- ghcPkgListEx (cradlePkgDbStack cradle)
    return $ CompilerOptions gopts idirs (depPkgs dbPkgs)
  where
    wdir = cradleCurrentDir cradle
    rdir = cradleRootDir cradle
    cfile = fromMaybe "error getCompilerOptions" $ cradleCabalFile cradle
    thisPkg = dropExtension $ takeFileName cfile
    buildInfos = cabalAllBuildInfo pkgDesc
    idirs = includeDirectories rdir wdir $ cabalSourceDirs buildInfos
    depPkgs ps =
        attachPackageIds ps $
            removeThem (problematicPackages ++ [thisPkg]) $
                cabalDependPackages buildInfos

----------------------------------------------------------------
-- Dependent packages

removeThem :: [PackageBaseName] -> [PackageBaseName] -> [PackageBaseName]
removeThem badpkgs = filter (`notElem` badpkgs)

problematicPackages :: [PackageBaseName]
problematicPackages =
    [ "base-compat" -- providing "Prelude"
    ]

attachPackageIds :: [Package] -> [PackageBaseName] -> [Package]
attachPackageIds pkgs = mapMaybe (`lookup3` pkgs)

lookup3 :: Eq a => a -> [(a, b, c)] -> Maybe (a, b, c)
lookup3 _ [] = Nothing
lookup3 k (t@(a, _, _) : ls)
    | k == a = Just t
    | otherwise = lookup3 k ls

----------------------------------------------------------------
-- Include directories for modules

cabalBuildDirs :: [FilePath]
cabalBuildDirs = ["dist/build", "dist/build/autogen"]

includeDirectories :: FilePath -> FilePath -> [FilePath] -> [FilePath]
includeDirectories cdir wdir dirs = uniqueAndSort (extdirs ++ [cdir, wdir])
  where
    extdirs = map expand $ dirs ++ cabalBuildDirs
    expand "." = cdir
    expand subdir = cdir </> subdir

----------------------------------------------------------------

-- | Parsing a cabal file and returns 'PackageDescription'.
--   'IOException' is thrown if parsing fails.
parseCabalFile :: FilePath -> IO PackageDescription
parseCabalFile file = do
    cid <- getGHCId
    let cid' = unknownCompilerInfo cid NoAbiTag
    epgd <- readPackageDescription file
    flags <- getFlags
    case toPkgDesc cid' flags epgd of
        Left deps -> throwIO $ userError $ show deps ++ " are not installed"
        Right (pd, _) ->
            if nullPkg pd
                then throwIO $ userError $ file ++ " is broken"
                else return pd
  where
    envFlags = do
        let parseF [] = []
            parseF ccs@(c : cs)
                | c == '-' = [(mkFlagName cs, False)]
                | otherwise = [(mkFlagName ccs, True)]
        maybe [] (concatMap parseF . words) `fmap` lookupEnv "HHP_CABAL_FLAGS"
    getFlags = mkFlagAssignment <$> envFlags
    nullPkg pd = unPackageName (C.pkgName (P.package pd)) == ""
    toPkgDesc cid flags =
        finalizePD flags defaultComponentRequestedSpec (const True) buildPlatform cid []

----------------------------------------------------------------

getGHCOptions
    :: [GHCOption] -> Cradle -> FilePath -> BuildInfo -> IO [GHCOption]
getGHCOptions ghcopts cradle rdir binfo = do
    cabalCpp <- cabalCppOptions rdir
    let cpps = map ("-optP" ++) $ P.cppOptions binfo ++ cabalCpp
    return $ ghcopts ++ pkgDb ++ exts ++ [lang] ++ libs ++ libDirs ++ cpps
  where
    pkgDb = ghcDbStackOpts $ cradlePkgDbStack cradle
    lang = maybe "-XHaskell98" (("-X" ++) . display) $ P.defaultLanguage binfo
    libDirs = map ("-L" ++) $ extLibDirs binfo
    exts = map (("-X" ++) . display) $ P.usedExtensions binfo
    libs = map ("-l" ++) $ P.extraLibs binfo

cabalCppOptions :: FilePath -> IO [String]
cabalCppOptions dir = do
    exist <- doesFileExist cabalMacro
    return $
        if exist
            then ["-include", cabalMacro]
            else []
  where
    cabalMacro = dir </> "dist/build/autogen/cabal_macros.h"

----------------------------------------------------------------

-- | Extracting all 'BuildInfo' for libraries, executables, and tests.
cabalAllBuildInfo :: PackageDescription -> [BuildInfo]
cabalAllBuildInfo pd = libBI ++ subBI ++ execBI ++ testBI ++ benchBI
  where
    libBI = map P.libBuildInfo $ maybeToList $ P.library pd
    subBI = map P.libBuildInfo $ P.subLibraries pd
    execBI = map P.buildInfo $ P.executables pd
    testBI = map P.testBuildInfo $ P.testSuites pd
    benchBI = map P.benchmarkBuildInfo $ P.benchmarks pd

----------------------------------------------------------------

-- | Extracting package names of dependency.
cabalDependPackages :: [BuildInfo] -> [PackageBaseName]
cabalDependPackages bis = uniqueAndSort pkgs
  where
    pkgs = map getDependencyPackageName $ concatMap P.targetBuildDepends bis
    getDependencyPackageName (Dependency pkg _ _) = unPackageName pkg

----------------------------------------------------------------

-- | Extracting include directories for modules.
cabalSourceDirs :: [BuildInfo] -> [IncludeDir]
cabalSourceDirs bis = uniqueAndSort $ concatMap (map toPath . P.hsSourceDirs) bis

----------------------------------------------------------------

uniqueAndSort :: [String] -> [String]
uniqueAndSort = toList . fromList

----------------------------------------------------------------

getGHCId :: IO CompilerId
getGHCId = CompilerId GHC <$> getGHC

getGHC :: IO Version
getGHC = do
    mv <- programFindVersion ghcProgram silent (programName ghcProgram)
    case mv of
        Nothing -> throwIO $ userError "ghc not found"
        Just v -> return v

----------------------------------------------------------------

-- | Extracting all 'Module' 'FilePath's for libraries, executables,
-- tests and benchmarks.
cabalAllTargets
    :: PackageDescription -> IO ([String], [String], [String], [String])
cabalAllTargets pd = do
    exeTargets <- mapM getExecutableTarget $ P.executables pd
    testTargets <- mapM getTestTarget $ P.testSuites pd
    return (libTargets, concat exeTargets, concat testTargets, benchTargets)
  where
    lib = maybe [] P.explicitLibModules $ P.library pd

    libTargets = map toModuleString lib
    benchTargets = map toModuleString $ concatMap P.benchmarkModules $ P.benchmarks pd
    toModuleString :: ModuleName -> String
    toModuleString mn = fromFilePath $ toFilePath mn

    fromFilePath :: FilePath -> String
    fromFilePath fp = map (\c -> if c == '/' then '.' else c) fp

    getTestTarget :: TestSuite -> IO [String]
    getTestTarget ts =
        case P.testInterface ts of
            (TestSuiteExeV10 _ filePath) -> do
                let maybeTests =
                        [ p <//> e
                        | p <- P.hsSourceDirs $ P.testBuildInfo ts
                        , e <- [filePath]
                        ]
                liftIO $ filterM doesFileExist maybeTests
            (TestSuiteLibV09 _ moduleName) -> return [toModuleString moduleName]
            (TestSuiteUnsupported _) -> return []

    getExecutableTarget :: Executable -> IO [String]
    getExecutableTarget exe = do
        let maybeExes =
                [ p <//> e
                | p <- P.hsSourceDirs $ P.buildInfo exe
                , e <- [P.modulePath exe]
                ]
        liftIO $ filterM doesFileExist maybeExes

#if MIN_VERSION_Cabal(3,14,0)
(<//>) :: SymbolicPath Path.Pkg (Path.Dir Path.Source)
       -> Path.RelativePath Path.Source Path.File
       -> FilePath
dir <//> file = toPath (dir Path.</> file)
#else
(<//>) :: SymbolicPath from to -> FilePath -> FilePath
dir <//> file = toPath dir </> file
#endif

extLibDirs :: BuildInfo -> [FilePath]
#if MIN_VERSION_Cabal(3,14,0)
extLibDirs = map getSymbolicPath . P.extraLibDirs
#else
extLibDirs = P.extraLibDirs
#endif

#if MIN_VERSION_Cabal(3,6,0)
toPath :: SymbolicPath from to -> FilePath
toPath = getSymbolicPath
#else
toPath :: String -> String
toPath = id
#endif

readPackageDescription :: FilePath -> IO P.GenericPackageDescription
#if MIN_VERSION_Cabal(3,14,0)
readPackageDescription = readGenericPackageDescription silent Nothing . Path.makeSymbolicPath
#else
readPackageDescription = readGenericPackageDescription silent
#endif