hs-bindgen-1.0.0.0: src-internal/HsBindgen.hs

module HsBindgen (
    hsBindgenMacroLang

    -- * Artefacts
  , Artefact(..)

    -- ** High-level artefacts
  , writeIncludeGraph
  , writeUseDeclGraph
  , writeDoxygen
  , getBindings
  , getBindingsMultiple
  , writeBindings
  , writeBindingsSingle
  , writeBindingsMultiple
  , writeBindingSpec
  , writeTests

    -- ** Low-level artefacts
  , getConfig
  , getIncludeGraph
  , getDeclIndex
  , getUseDeclGraph
  , getDeclUseGraph
  , getOmittedTypes
  , getReifiedC
  , getSquashedTypes
  , getDependencies
  , getGetMainHeaders

    -- * Errors
  , BindgenError(..)

    -- * Traces
  , SafeTraceMsg(..)

    -- * Test infrastructure
  , hsBindgenEMacroLang
  ) where

import Control.Exception (Exception (..), catch)
import Control.Monad.Except (MonadError (..), withExceptT)
import Control.Monad.Trans.Except (runExceptT)
import Data.Map qualified as Map
import Data.Set qualified as Set
import System.Exit (ExitCode (..), exitWith)
import Text.SimplePrettyPrint qualified as PP

import Clang.CStandard
import Clang.Paths

import HsBindgen.Artefact
import HsBindgen.ArtefactM
import HsBindgen.Backend
import HsBindgen.Backend.Category
import HsBindgen.Backend.HsModule.Render
import HsBindgen.Backend.HsModule.Translation
import HsBindgen.Backend.HsModule.Translation.Doxygen (ExportTags,
                                                       computeExportTags,
                                                       resolveExports)
import HsBindgen.BindingSpec qualified as BindingSpec
import HsBindgen.BindingSpec.Gen
import HsBindgen.Boot
import HsBindgen.Clang
import HsBindgen.Config.Internal
import HsBindgen.Errors (throwPure_TODO)
import HsBindgen.Frontend
import HsBindgen.Frontend.Analysis.DeclIndex (DeclIndex)
import HsBindgen.Frontend.Analysis.DeclIndex qualified as DeclIndex
import HsBindgen.Frontend.Analysis.DeclUseGraph (DeclUseGraph)
import HsBindgen.Frontend.Analysis.IncludeGraph (IncludeGraph)
import HsBindgen.Frontend.Analysis.IncludeGraph qualified as IncludeGraph
import HsBindgen.Frontend.Analysis.UseDeclGraph (UseDeclGraph)
import HsBindgen.Frontend.Analysis.UseDeclGraph qualified as UseDeclGraph
import HsBindgen.Frontend.DeclMeta
import HsBindgen.Frontend.Pass.Final
import HsBindgen.Frontend.Predicate
import HsBindgen.Frontend.ProcessIncludes qualified as ProcessIncludes
import HsBindgen.Frontend.TranslationUnit qualified as C
import HsBindgen.Imports
import HsBindgen.IR.C qualified as C
import HsBindgen.IR.Translation
import HsBindgen.Language.Haskell qualified as Hs
import HsBindgen.Macro.Interface qualified as Macro
import HsBindgen.Macro.Type qualified as Macro
import HsBindgen.TraceMsg
import HsBindgen.Util.Tracer

-- | Main entry point to run @hs-bindgen@.
--
-- For a list of build artefacts, see the description and constructors of
-- 'Artefact'.
hsBindgenMacroLang ::
     Macro.HasTypes l
  => (ClangCStandard -> IO (Macro.Lang l))
  -> TracerConfig Level     TraceMsg
  -> TracerConfig SafeLevel SafeTraceMsg
  -> BindgenConfig
  -> [C.UncheckedRootDirective]
  -> Artefact l a
  -> IO a
hsBindgenMacroLang mkMacroLang tu ts b i a = do
    eRes <- hsBindgenEMacroLang mkMacroLang tu ts b i a `catch` \e ->
      case fromException e of
        Just (LibclangException msg) -> do
          print $ PP.string msg
          -- We specifically use exit code 3 here; it means that the call to
          -- `libclang` has failed.
          exitWith (ExitFailure 3)
        _ -> throwIO e
    case eRes of
      Left err -> do
        print $ prettyForTrace err
        -- We specifically use exit code 4 here; it means that `hs-bindgen` ran
        -- to completion, but an error has occurred.
        exitWith (ExitFailure 4)
      Right r -> pure r

-- | Like 'hsBindgen' but does not exit with failure when an error has occurred.
hsBindgenEMacroLang ::
     forall a l. Macro.HasTypes l
  => (ClangCStandard -> IO (Macro.Lang l))
  -> TracerConfig Level     TraceMsg
  -> TracerConfig SafeLevel SafeTraceMsg
  -> BindgenConfig
  -> [C.UncheckedRootDirective]
  -> Artefact l a
  -> IO (Either BindgenError a)
hsBindgenEMacroLang
  mkMacroLang
  tracerConfigUnsafe
  tracerConfigSafe
  config
  uncheckedRootDirectives
  artefacts = do
    eRes <- withTracer tracerConfigUnsafe $ \tracerUnsafe -> do
      -- 1. Boot.
      let tracerBoot :: Tracer BootMsg
          tracerBoot = contramap TraceBoot tracerUnsafe
      bootArtefact <-
        runBoot tracerBoot mkMacroLang config uncheckedRootDirectives
      -- 2. Frontend.
      let tracerFrontend :: Tracer FrontendMsg
          tracerFrontend = contramap TraceFrontend tracerUnsafe
      frontendArtefact <-
        runFrontend tracerFrontend config.frontend bootArtefact
      -- 3. Backend.
      let tracerConfigBackend :: TracerConfig SafeLevel BackendMsg
          tracerConfigBackend = contramap SafeBackendMsg tracerConfigSafe
      backendArtefact <-
        withTracerSafe tracerConfigBackend  $ \tracerSafe ->
          runBackend tracerSafe config bootArtefact frontendArtefact
      -- 4. Artefacts.
      let tracerConfigArtefact :: TracerConfig SafeLevel ArtefactMsg
          tracerConfigArtefact = contramap SafeArtefactMsg tracerConfigSafe
      withTracerSafe tracerConfigArtefact $ \tracerSafe ->
        runArtefacts
          tracerSafe
          config
          bootArtefact
          frontendArtefact
          backendArtefact
          artefacts

    let tracerConfigDelayedIO :: TracerConfig SafeLevel DelayedIOMsg
        tracerConfigDelayedIO = contramap SafeDelayedIOMsg tracerConfigSafe
    runExceptT $ withTracerSafe tracerConfigDelayedIO $ \tracerSafe ->
      case eRes of
        Left er       -> throwError $ BindgenErrorReported er
        Right (r, as) -> do
          -- Before creating directories or writing output files, we verify
          -- adherence to the provided policies.
          withExceptT BindgenDelayedIOError $ mapM_ checkPolicy as
          liftIO $ executeDelayedIOActions tracerSafe as
          pure r

{-------------------------------------------------------------------------------
  High-level artefacts
-------------------------------------------------------------------------------}

-- | Write the include graph to @STDOUT@ or a file.
writeIncludeGraph ::
     Boolean Regex
  -> IncludeGraph.HeaderLabelStyle
  -> IncludeGraph.IncludeGraphFormat
  -> FilePolicy
  -> DirPolicy
  -> Maybe FilePath
  -> Artefact l ()
writeIncludeGraph regex labelStyle format filePolicy dirPolicy mPath = do
    includeGraph <- getIncludeGraph
    let predicateUser :: RealPath -> Bool
        predicateUser rp = eval (\r -> matchTest r (getRealPathText rp)) regex
        opts = IncludeGraph.VisOpts{
            predicate  = predicateUser
          , labelStyle = labelStyle
          }
        rendered = case format of
          IncludeGraph.SortedList -> IncludeGraph.renderSortedList opts includeGraph
          IncludeGraph.Mermaid    -> IncludeGraph.renderMermaid    opts includeGraph
    case mPath of
      Nothing   ->
        Lift $ delay $ WriteToStdOut $ StringContent rendered
      Just path ->
        write filePolicy dirPolicy "include graph" (UserSpecified path) rendered

-- | Write @use-decl@ graph to file.
writeUseDeclGraph :: FilePolicy -> DirPolicy -> Maybe FilePath -> Artefact l ()
writeUseDeclGraph filePolicy dirPolicy mPath = do
    useDeclGraph <- getUseDeclGraph
    let rendered = UseDeclGraph.renderMermaid useDeclGraph
    case mPath of
      Nothing   ->
        Lift $ delay $ WriteToStdOut $ StringContent rendered
      Just path ->
        write filePolicy dirPolicy "use-decl graph" (UserSpecified path) rendered

-- | Write the parsed doxygen state to @STDOUT@ or a file.
writeDoxygen :: FilePolicy -> DirPolicy -> Maybe FilePath -> Artefact l ()
writeDoxygen filePolicy dirPolicy mPath = do
    doxy <- DoxygenA
    let rendered = show doxy
    case mPath of
      Nothing   ->
        Lift $ delay $ WriteToStdOut $ StringContent rendered
      Just path ->
        write filePolicy dirPolicy "doxygen" (UserSpecified path) rendered

-- | Get bindings (single module).
getBindings :: ModuleRenderConfig -> Artefact l String
getBindings mrc = do
    name   <- ModuleBaseName
    dirs   <- RootDirectives
    decls  <- FinalDecls
    tags   <- getExportTags
    when (all nullDecls decls) $ EmitTrace $ NoBindingsSingleModule name
    config <- getConfig
    let fns = config.frontend.fieldNamingStrategy
    pure $ render $
      translateModuleSingle fns mrc dirs name (resolveExports tags) decls

-- | Write bindings to file.
writeBindings ::
     ModuleRenderConfig
  -> FilePolicy
  -> DirPolicy
  -> FilePath
  -> Artefact l ()
writeBindings mrc filePolicy dirPolicy path = do
    bindings <- getBindings mrc
    write filePolicy dirPolicy "bindings" (UserSpecified path) bindings

-- | Write bindings to a directory (single module combining all categories).
--
-- Unlike 'writeBindings', this writes to a directory and automatically
-- constructs the file path from the module name, similar to
-- 'writeBindingsMultiple' but generating only one file.
writeBindingsSingle ::
     ModuleRenderConfig
  -> FilePolicy
  -> DirPolicy
  -> FilePath
  -> Artefact l ()
writeBindingsSingle mrc filePolicy dirPolicy hsOutputDir = do
    moduleBaseName <- ModuleBaseName
    bindings       <- getBindings mrc
    let localPath :: FilePath
        localPath = Hs.moduleNamePath $
            fromBaseModuleName moduleBaseName Nothing

        location :: FileLocation
        location = RelativeFileLocation RelativeToOutputDir{
              outputDir = hsOutputDir
            , localPath = localPath
            }

    write filePolicy dirPolicy "bindings" location bindings

-- | Get bindings (one module per binding category).
getBindingsMultiple :: ModuleRenderConfig -> Artefact l (ByCategory_ (Maybe String))
getBindingsMultiple mrc = do
    name   <- ModuleBaseName
    dirs   <- RootDirectives
    decls  <- FinalDecls
    tags   <- getExportTags
    when (all nullDecls decls) $
      EmitTrace $ NoBindingsMultipleModules name
    config <- getConfig
    let fns = config.frontend.fieldNamingStrategy
    pure $ fmap render <$>
      translateModuleMultiple fns mrc dirs name (resolveExports tags) decls

-- | Write bindings to files in provided output directory.
--
-- Each file contains a different binding category.
--
-- If no file is given, print to standard output.
writeBindingsMultiple ::
     ModuleRenderConfig
  -> FilePolicy
  -> DirPolicy
  -> FilePath
  -> Artefact l ()
writeBindingsMultiple mrc filePolicy dirPolicy hsOutputDir = do
    moduleBaseName     <- ModuleBaseName
    bindingsByCategory <- getBindingsMultiple mrc
    writeByCategory
      filePolicy
      dirPolicy
      "Bindings"
      hsOutputDir
      moduleBaseName
      bindingsByCategory

-- | Write binding specifications to file.
writeBindingSpec ::
     FilePolicy
  -> DirPolicy
  -> FilePath
  -> Artefact l ()
writeBindingSpec filePolicy dirPolicy path = do
    moduleBaseName <- ModuleBaseName
    includeGraph   <- getIncludeGraph
    declIndex      <- getDeclIndex
    getMainHeaders <- getGetMainHeaders
    omittedTypes   <- getOmittedTypes
    squashedTypes  <- getSquashedTypes
    hsDecls        <- HsDecls
    -- Binding specifications only specify types.
    let bs =
          genBindingSpec
            (BindingSpec.getFormat path)
            (fromBaseModuleName moduleBaseName (Just CType))
            includeGraph
            declIndex
            getMainHeaders
            omittedTypes
            squashedTypes
            (view (lensForCategory CType) hsDecls)
        fileDescription = FileDescription {
              description = "Binding specifications"
            , location    = UserSpecified path
            , filePolicy  = filePolicy
            , dirPolicy   = dirPolicy
            , content     = ByteStringContent bs
            }
    Lift $ delay $ WriteToFile fileDescription

-- | Create test suite in directory.
writeTests :: FilePath -> Artefact l ()
writeTests _testDir = do
    -- moduleBaseName  <- ModuleBaseName
    -- rootDirectives  <- RootDirectives
    -- hsDecls         <- HsDecls
    -- liftIO $
    --   genTests
    --     rootDirectives
    --     hsDecls
    --     moduleBaseName
    --     testDir
    throwPure_TODO 22 "Test generation integrated into the artefact API"

{-------------------------------------------------------------------------------
  Low-level artefacts
-------------------------------------------------------------------------------}

getConfig :: Artefact l BindgenConfig
getConfig = Lift askConfig

getGetMainHeaders :: Artefact l ProcessIncludes.GetMainHeaders
getGetMainHeaders = (.getMainHeaders) <$> ParseInfoA

getIncludeGraph :: Artefact l IncludeGraph
getIncludeGraph = (.includeGraph) <$> ParseInfoA

getDeclIndex :: Artefact l (DeclIndex l)
getDeclIndex = (.meta.declIndex) <$> FrontendPassA FinalPass

getUseDeclGraph :: Artefact l UseDeclGraph
getUseDeclGraph = (.meta.useDeclGraph) <$> FrontendPassA FinalPass

getDeclUseGraph :: Artefact l DeclUseGraph
getDeclUseGraph = (.meta.declUseGraph) <$> FrontendPassA FinalPass

getOmittedTypes :: Artefact l [(C.DeclId, RealPath)]
getOmittedTypes =
    Map.toList . DeclIndex.getOmitted <$> getDeclIndex

getReifiedC :: Artefact l [C.Decl l Final]
getReifiedC = (.decls) <$> FrontendPassA FinalPass

-- TODO <https://github.com/well-typed/hs-bindgen/issues/1549>
-- When we properly record aliases, we may not need this anymore.
getSquashedTypes :: Artefact l [(C.DeclId, (RealPath, Hs.Name Hs.NsTypeConstr))]
getSquashedTypes = do
  decls <- getReifiedC
  let translatedDeclIds = Set.fromList $ map (.info.id.cName) decls
  declIndex <- getDeclIndex
  pure $ Map.toList $ DeclIndex.getSquashed declIndex translatedDeclIds

getDependencies :: Artefact l [RealPath]
getDependencies = IncludeGraph.toSortedList <$> getIncludeGraph

{-------------------------------------------------------------------------------
  Helpers
-------------------------------------------------------------------------------}

write :: FilePolicy -> DirPolicy -> String -> FileLocation -> String -> Artefact l ()
write filePolicy dirPolicy what loc str
  | null str =
    EmitTrace $ SkipWriteToFileNoBindings loc
  | otherwise =
    Lift $ delay $
      WriteToFile $ FileDescription what loc filePolicy dirPolicy (StringContent str)

writeByCategory ::
     FilePolicy
  -> DirPolicy
  -> String
  -> FilePath
  -> BaseModuleName
  -> ByCategory_ (Maybe String)
  -> Artefact l ()
writeByCategory filePolicy dirPolicy what dir moduleBaseName =
    sequence_ . mapWithCategory_ writeCategory
  where
    writeCategory :: Category -> Maybe String -> Artefact l ()
    writeCategory _    Nothing   = pure ()
    writeCategory cat (Just str) =
        write filePolicy dirPolicy whatWithCategory location str
      where
        localPath :: FilePath
        localPath = Hs.moduleNamePath $
            fromBaseModuleName moduleBaseName (Just cat)

        whatWithCategory :: String
        whatWithCategory = what ++ " (" ++ show cat ++ ")"

        location :: FileLocation
        location = RelativeFileLocation RelativeToOutputDir{
              outputDir = dir
            , localPath = localPath
            }

nullDecls :: ([a], [b]) -> Bool
nullDecls (xs, ys) = null xs && null ys

{-------------------------------------------------------------------------------
  Export tags
-------------------------------------------------------------------------------}

-- | Fetch doxygen data and final C declarations, then precompute export tags.
getExportTags :: Artefact l ExportTags
getExportTags = do
    doxy  <- DoxygenA
    final <- FrontendPassA FinalPass
    pure $ computeExportTags doxy final.decls

{-------------------------------------------------------------------------------
  Errors
-------------------------------------------------------------------------------}

data BindgenError =
      BindgenErrorReported  AnErrorHappened
    | BindgenDelayedIOError DelayedIOError
    deriving stock (Show)

instance PrettyForTrace BindgenError where
  prettyForTrace = \case
    BindgenErrorReported  e -> prettyForTrace e
    BindgenDelayedIOError e -> prettyForTrace e

{-------------------------------------------------------------------------------
  Traces
-------------------------------------------------------------------------------}

data SafeTraceMsg =
      SafeBackendMsg   BackendMsg
    | SafeArtefactMsg  ArtefactMsg
    | SafeDelayedIOMsg DelayedIOMsg
  deriving (Show, Generic, PrettyForTrace, IsTrace SafeLevel)