aihc-parser-1.0.0.2: common/HackageSupport.hs

{-# LANGUAGE OverloadedStrings #-}

-- | Thin adapter over "Aihc.Hackage" that converts string-typed results
-- to the rich types used by @aihc-parser@ executables and tests.
module HackageSupport
  ( downloadPackage,
    downloadPackageQuiet,
    downloadPackageQuietWithNetwork,
    findPackageBuildToolDependencyNames,
    findPackageDefaultsToHaskell98,
    findPackageUsesCustomPreprocessor,
    findTargetFilesFromCabal,
    FileInfo (..),
    readTextFileLenient,
    resolveIncludeBestEffort,
    diagToText,
    prefixCppErrors,
  )
where

import Aihc.Cpp (Diagnostic (..), IncludeKind (..), IncludeRequest (..), Severity (..))
import Aihc.Hackage.Cabal qualified as HC
import Aihc.Hackage.Download qualified as HD
import Aihc.Hackage.Types qualified as HT
import Aihc.Hackage.Util qualified as HU
import Aihc.Parser.Syntax qualified as Syntax
import Data.ByteString qualified as BS
import Data.List (nub)
import Data.Maybe (mapMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import Distribution.PackageDescription.Parsec (parseGenericPackageDescription, runParseResult)
import Distribution.Types.GenericPackageDescription (GenericPackageDescription)
import System.Directory (doesFileExist)
import System.FilePath (isAbsolute, makeRelative, normalise, splitDirectories, takeDirectory, (</>))

-- | Download a Hackage package with verbose logging.
downloadPackage :: String -> String -> IO FilePath
downloadPackage name version =
  HD.downloadPackage (HT.PackageSpec name version)

-- | Download a Hackage package silently.
downloadPackageQuiet :: String -> String -> IO FilePath
downloadPackageQuiet name version =
  HD.downloadPackageQuiet (HT.PackageSpec name version)

-- | Download a Hackage package, controlling network access.
downloadPackageQuietWithNetwork :: Bool -> String -> String -> IO FilePath
downloadPackageQuietWithNetwork allowNetwork name version =
  HD.downloadPackageWithOptions
    HD.defaultDownloadOptions
      { HD.downloadVerbose = False,
        HD.downloadAllowNetwork = allowNetwork
      }
    (HT.PackageSpec name version)

-- | Rich file info with parser-typed extensions and language.
data FileInfo = FileInfo
  { fileInfoPath :: FilePath,
    fileInfoExtensions :: [Syntax.ExtensionSetting],
    fileInfoCppOptions :: [String],
    fileInfoIncludeDirs :: [FilePath],
    fileInfoLanguage :: Maybe Syntax.LanguageEdition,
    fileInfoDependencies :: [Text]
  }
  deriving (Show)

-- | Find target Haskell source files from a @.cabal@ file.
--
-- Delegates to 'Aihc.Hackage.Cabal.collectComponentFiles' and then converts
-- the string-typed results to the rich types used by @aihc-parser@.
findTargetFilesFromCabal :: FilePath -> IO [FileInfo]
findTargetFilesFromCabal extractedRoot = do
  (gpd, cabalFile) <- parsePackageDescriptionFromRoot extractedRoot
  rawFiles <- HC.collectComponentFiles gpd (takeDirectory cabalFile)
  pure (map convertFileInfo rawFiles)

-- | Find active build-tool dependency names from a package's @.cabal@ file.
findPackageBuildToolDependencyNames :: FilePath -> IO [Text]
findPackageBuildToolDependencyNames extractedRoot = do
  (gpd, _) <- parsePackageDescriptionFromRoot extractedRoot
  pure (HC.buildToolDependencyNames gpd)

-- | Return whether any active library or executable defaults to Haskell98.
findPackageDefaultsToHaskell98 :: FilePath -> IO Bool
findPackageDefaultsToHaskell98 extractedRoot = do
  (gpd, _) <- parsePackageDescriptionFromRoot extractedRoot
  pure (HC.packageDefaultsToHaskell98 gpd)

-- | Find whether active package metadata requests a custom GHC preprocessor.
findPackageUsesCustomPreprocessor :: FilePath -> IO Bool
findPackageUsesCustomPreprocessor extractedRoot = do
  (gpd, _) <- parsePackageDescriptionFromRoot extractedRoot
  pure (HC.packageUsesCustomPreprocessor gpd)

parsePackageDescriptionFromRoot :: FilePath -> IO (GenericPackageDescription, FilePath)
parsePackageDescriptionFromRoot extractedRoot = do
  cabalFiles <- HU.findCabalFiles extractedRoot
  cabalFile <-
    case cabalFiles of
      [file] -> pure file
      [] ->
        ioError
          ( userError
              ("No .cabal file found under extracted package root: " ++ extractedRoot)
          )
      files -> pure (HU.chooseBestCabalFile extractedRoot files)
  cabalBytes <- BS.readFile cabalFile
  let (_, parseResult) = runParseResult (parseGenericPackageDescription cabalBytes)
  gpd <-
    case parseResult of
      Right parsed -> pure parsed
      Left (_, errs) ->
        ioError
          ( userError
              ("Failed to parse cabal file " ++ cabalFile ++ ": " ++ show errs)
          )
  pure (gpd, cabalFile)

-- | Convert a string-typed 'HC.FileInfo' to the rich-typed local 'FileInfo'.
convertFileInfo :: HC.FileInfo -> FileInfo
convertFileInfo raw =
  FileInfo
    { fileInfoPath = HC.fileInfoPath raw,
      fileInfoExtensions = mapMaybe (Syntax.parseExtensionSettingName . T.pack) (HC.fileInfoExtensions raw),
      fileInfoCppOptions = HC.fileInfoCppOptions raw,
      fileInfoIncludeDirs = HC.fileInfoIncludeDirs raw,
      fileInfoLanguage = HC.fileInfoLanguage raw >>= Syntax.parseLanguageEdition . T.pack,
      fileInfoDependencies = HC.fileInfoDependencies raw
    }

readTextFileLenient :: FilePath -> IO Text
readTextFileLenient = HU.readTextFileLenient

resolveIncludeBestEffort :: FilePath -> [FilePath] -> FilePath -> IncludeRequest -> IO (Maybe BS.ByteString)
resolveIncludeBestEffort packageRoot includeDirs currentFile req = do
  firstExisting <- firstExistingPath (includeCandidates packageRoot includeDirs currentFile req)
  case firstExisting of
    Nothing -> pure Nothing
    Just includeFile -> Just <$> BS.readFile includeFile

includeCandidates :: FilePath -> [FilePath] -> FilePath -> IncludeRequest -> [FilePath]
includeCandidates packageRoot includeDirs currentFile req =
  map normalise $ nub [dir </> includePath req | dir <- searchDirs]
  where
    includeDir = takeDirectory (includeFrom req)
    sourceRelDir = takeDirectory (makeRelative packageRoot currentFile)
    packageAncestors = ancestorDirs sourceRelDir
    localRoots =
      [ takeDirectory currentFile,
        packageRoot </> sourceRelDir,
        packageRoot </> includeDir
      ]
    systemRoots =
      includeDirs
        <> [ packageRoot </> "include",
             packageRoot </> "includes",
             packageRoot </> "cbits",
             packageRoot
           ]
    searchDirs =
      case includeKind req of
        IncludeLocal -> localRoots <> map (packageRoot </>) packageAncestors <> systemRoots
        IncludeSystem -> systemRoots <> localRoots <> map (packageRoot </>) packageAncestors

ancestorDirs :: FilePath -> [FilePath]
ancestorDirs path =
  case filter (not . null) (splitDirectories path) of
    [] -> []
    parts ->
      [ foldl (</>) "." (take n parts)
      | n <- [length parts, length parts - 1 .. 1]
      ]

firstExistingPath :: [FilePath] -> IO (Maybe FilePath)
firstExistingPath [] = pure Nothing
firstExistingPath (candidate : rest) = do
  let path = if isAbsolute candidate then candidate else normalise candidate
  exists <- doesFileExist path
  if exists
    then pure (Just path)
    else firstExistingPath rest

diagToText :: Diagnostic -> Text
diagToText diag =
  T.pack (diagFile diag)
    <> ":"
    <> T.pack (show (diagLine diag))
    <> ": "
    <> sev
    <> ": "
    <> diagMessage diag
  where
    sev =
      case diagSeverity diag of
        Warning -> "warning"
        Error -> "error"

prefixCppErrors :: Maybe Text -> Text -> Text
prefixCppErrors cppMsg msg =
  case cppMsg of
    Nothing -> msg
    Just cppText -> "cpp diagnostics:\n" <> cppText <> "\n" <> msg