CabalApi.hs

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

module Hhp.CabalApi (
    getCompilerOptions,
    parseCabalFile,
    cabalAllBuildInfo,
    cabalAllBuildInfo',
    cabalDependPackages,
    cabalSourceDirs,
    cabalAllTargets,
    getHsSourceDir,
) 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.List (isPrefixOf)
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe, maybeToList)
import Data.Set (fromList, toList)
import System.Directory (doesFileExist)
import System.Environment (lookupEnv)
import System.FilePath (dropExtension, takeDirectory, takeFileName, (</>))

import Hhp.GhcPkg
import Hhp.Types

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

-- | Getting necessary 'CompilerOptions' from three information sources.
getCompilerOptions
    :: [GHCOption]
    -> Cradle
    -> PackageDescription
    -> Maybe FilePath
    -> IO CompilerOptions
getCompilerOptions ghcopts cradle pkgDesc hsFile = do
    gopts <-
        getGHCOptions ghcopts cradle rdir $ unsafeHead "getCompilerOptions" buildInfos
    dbPkgs <- ghcPkgListEx (cradlePkgDbStack cradle)
    let compOpt = CompilerOptions gopts idirs (depPkgs dbPkgs)
    return compOpt
  where
    wdir = cradleCurrentDir cradle
    rdir = cradleRootDir cradle
    cfile = fromMaybe "error getCompilerOptions" $ cradleCabalFile cradle
    thisPkg = dropExtension $ takeFileName cfile
    buildInfos = cabalAllBuildInfo cradle pkgDesc hsFile
    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
    :: Cradle -> PackageDescription -> Maybe FilePath -> [BuildInfo]
cabalAllBuildInfo cradle pd mHsFile = libBI ++ subBI ++ addBI
  where
    libBI = map P.libBuildInfo $ maybeToList $ P.library pd
    subBI = map P.libBuildInfo $ P.subLibraries pd
    addBI = fst $ cabalExtraBuildInfo (Just cradle) pd mHsFile

-- for testing
cabalAllBuildInfo'
    :: PackageDescription -> [BuildInfo]
cabalAllBuildInfo' pd = libBI ++ subBI ++ addBI
  where
    libBI = map P.libBuildInfo $ maybeToList $ P.library pd
    subBI = map P.libBuildInfo $ P.subLibraries pd
    addBI = fst $ cabalExtraBuildInfo Nothing pd Nothing

getHsSourceDir
    :: Cradle -> PackageDescription -> Maybe FilePath -> Maybe FilePath
getHsSourceDir cradle pd mHsFile =
    snd $ cabalExtraBuildInfo (Just cradle) pd mHsFile

cabalExtraBuildInfo
    :: Maybe Cradle
    -> PackageDescription
    -> Maybe FilePath
    -> ([BuildInfo], Maybe FilePath)
cabalExtraBuildInfo mcradle pd mHsFile = (addBI, hsDir addBI)
  where
    execBI = map P.buildInfo $ P.executables pd
    testBI = map P.testBuildInfo $ P.testSuites pd
    benchBI = map P.benchmarkBuildInfo $ P.benchmarks pd
    addBI0 = execBI ++ testBI ++ benchBI
    addBI = case mHsFile of
        Nothing -> addBI0 -- fixme: Is [] more suitable?
        Just hsFile -> case mcradle of
            Nothing -> addBI0 -- fixme: Is [] more suitable?
            Just cradle -> do
                let hsFile' = takeRelativePath cradle hsFile
                 in filter (include hsFile') addBI0
    include hsFile b = any (`match` hsFile) $ map toPath $ P.hsSourceDirs b
    match "." _ = True
    match dir fn = dir `isPrefixOf` fn
    hsDir [] = Nothing
    hsDir (b : _) = toPath <$> listToMaybe (P.hsSourceDirs b)

takeRelativePath :: Cradle -> FilePath -> FilePath
takeRelativePath cradle fn = rp
  where
    root = cradleRootDir cradle
    rp
        | root `isPrefixOf` fn = takeDirectory $ drop (length root + 1) fn
        | otherwise = takeDirectory fn

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

-- | 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