Boot.hs

module HsBindgen.Boot (
    runBoot
  , ClangArtefacts (..)
  , getClangArtefacts
  , BootArtefact (..)
  , BootMsg (..)
  ) where

import Control.Exception (displayException)
import Text.SimplePrettyPrint (CtxDoc, (><))
import Text.SimplePrettyPrint qualified as PP

import Clang.Args
import Clang.CStandard

import HsBindgen.Backend.Category (Category (..))
import HsBindgen.BindingSpec
import HsBindgen.Cache
import HsBindgen.Clang
import HsBindgen.Clang.CompareVersions (CompareVersionsMsg,
                                        compareClangVersions)
import HsBindgen.Clang.Discover
import HsBindgen.Clang.ExtraClangArgs
import HsBindgen.Clang.Macos
import HsBindgen.Config.ClangArgs (ClangArgsConfig)
import HsBindgen.Config.ClangArgs qualified as ClangArgs
import HsBindgen.Config.Internal
import HsBindgen.Imports
import HsBindgen.IR.C qualified as C
import HsBindgen.Macro.Interface qualified as Macro
import HsBindgen.Util.Tracer

-- | Boot phase.
--
-- Basic setup and checks.
--
-- - Check arguments to @#include@.
-- - Determine Clang arguments.
-- - Load external and prescriptive binding specifications.
runBoot ::
     Tracer BootMsg
  -> (ClangCStandard -> IO (Macro.Lang l))
  -> BindgenConfig
  -> [C.UncheckedRootDirective]
  -> IO (BootArtefact l)
runBoot tracer mkMacroLang config uncheckedRootDirectives = do
    traceStatus $ BootStatusStart config

    checkBackendConfig (contramap BootBackendConfig tracer) config.backend

    checkMacosEnv (contramap BootMacos tracer)

    getRootDirectives <- cache "rootDirectives" $ Cached $ do
      let tracer' = contramap BootHashIncludeArg tracer
      withTrace BootStatusRootDirectives $
        traverse (traverse (C.hashIncludeArgWithTrace tracer'))
          uncheckedRootDirectives

    getClangArtefacts' <- cache "clangArtefacts" $ Cached $
      getClangArtefacts tracer config.boot.clangArgs

    getCStandard <- cache "cStandard" $ withTrace BootStatusCStandard $
      (.cStandard) <$> getClangArtefacts'

    getClangExe <- cache "clangExe" $ withTrace BootStatusClangExe $
      (.clangExe) <$> getClangArtefacts'

    getClangArgs <- cache "clangArgs" $ withTrace BootStatusClangArgs $
      (.clangArgs) <$> getClangArtefacts'

    getMacroLang <- cache "macroLang" $ do
       cStandard <- getCStandard
       liftIO $ mkMacroLang cStandard

    getBindingSpecs <- cache "loadBindingSpecs" $ do
      clangArgs <- getClangArgs
      liftIO $ loadBindingSpecs
        (contramap BootBindingSpec tracer)
        clangArgs
        (fromBaseModuleName config.boot.baseModule (Just CType))
        config.boot.bindingSpec

    getExternalBindingSpecs <- cache "getExternalBindingSpecs" $
      withTrace BootStatusExternalBindingSpecs $
        fmap fst $ getBindingSpecs

    getPrescriptiveBindingSpec <- cache "getPrescriptiveBindingSpec" $
      withTrace BootStatusPrescriptiveBindingSpec $
        fmap snd $ getBindingSpecs

    pure BootArtefact {
          baseModule              = config.boot.baseModule
        , cStandard               = getCStandard
        , clangExe                = getClangExe
        , clangArgs               = getClangArgs
        , macroLang               = getMacroLang
        , rootDirectives          = getRootDirectives
        , externalBindingSpecs    = getExternalBindingSpecs
        , prescriptiveBindingSpec = getPrescriptiveBindingSpec
        }
  where
    tracerBootStatus :: Tracer BootStatusMsg
    tracerBootStatus = contramap BootStatus tracer

    traceStatus :: MonadIO m => BootStatusMsg -> m ()
    traceStatus = traceWith tracerBootStatus . withCallStack

    withTrace :: MonadIO m => (a -> BootStatusMsg) -> m a -> m a
    withTrace c a = do
      x <- a
      traceStatus $ c x
      pure x

    cache :: String -> Cached a -> IO (Cached a)
    cache = cacheWith (contramap (BootCache . SafeTrace) tracer) . Just

data ClangArtefacts = ClangArtefacts {
    cStandard :: ClangCStandard
  , clangExe  :: Maybe ClangExe
  , clangArgs :: ClangArgs
  }

-- | Determine Clang artefacts
getClangArtefacts ::
     Tracer BootMsg
  -> ClangArgsConfig FilePath
  -> IO ClangArtefacts
getClangArtefacts tracer config0 = do
    compareClangVersions (contramap BootCompareClangVersions tracer)
    extraClangArgs <- getExtraClangArgs tracerExtraClangArgs
    paths <- getPaths tracerDiscover config0.builtinIncDir
    let config =
            applyExtraClangArgs extraClangArgs
          . applyPaths paths
          $ config0
        clangArgs' = ClangArgs.clangArgsConfigToClangArgs config
    cStandard' <- getClangCStandard' tracer clangArgs'
    return ClangArtefacts{
        cStandard = cStandard'
      , clangExe  = paths.pClangExe
      , clangArgs = clangArgs'
      }
  where
    tracerDiscover :: Tracer DiscoverMsg
    tracerDiscover = contramap BootDiscover tracer

    tracerExtraClangArgs :: Tracer ExtraClangArgsMsg
    tracerExtraClangArgs = contramap BootExtraClangArgs tracer

-- | Fatal exceptions
data FatalException =
    UnableToDetermineCStandardException
  deriving Show

instance Exception FatalException where
  displayException = \case
    UnableToDetermineCStandardException -> "Unable to determine C standard"

-- | Determine the C standard using @libclang@
--
-- This function throws a 'UnableToDetermineCStandardException' if the call to
-- @libclang@ fails or we are unable to determine the C standard.
getClangCStandard' :: Tracer BootMsg -> ClangArgs -> IO ClangCStandard
getClangCStandard' tracer clangArgs =
    getClangCStandard clangArgs >>= \case
      Just clangCStandard -> do
        traceWith tracerCStandard $ withCallStack $ BootCStandardClang clangCStandard
        return clangCStandard
      Nothing -> do
        traceWith tracerCStandard $ withCallStack $ BootCStandardFail
        throwIO UnableToDetermineCStandardException
  where
    tracerCStandard :: Tracer BootCStandardMsg
    tracerCStandard = contramap BootCStandard tracer

{-------------------------------------------------------------------------------
  Artefact
-------------------------------------------------------------------------------}

data BootArtefact l = BootArtefact {
      baseModule              :: BaseModuleName
    , cStandard               :: Cached ClangCStandard
    , clangExe                :: Cached (Maybe ClangExe)
    , clangArgs               :: Cached ClangArgs
    , macroLang               :: Cached (Macro.Lang l)
    , rootDirectives          :: Cached [C.RootDirective C.HashIncludeArg]
    , externalBindingSpecs    :: Cached MergedBindingSpecs
    , prescriptiveBindingSpec :: Cached PrescriptiveBindingSpec
    }

{-------------------------------------------------------------------------------
  Trace
-------------------------------------------------------------------------------}

data BootStatusMsg =
    BootStatusStart                   BindgenConfig
  | BootStatusCStandard               ClangCStandard
  | BootStatusClangExe                (Maybe ClangExe)
  | BootStatusClangArgs               ClangArgs
  | BootStatusRootDirectives          [C.RootDirective C.HashIncludeArg]
  | BootStatusExternalBindingSpecs    MergedBindingSpecs
  | BootStatusPrescriptiveBindingSpec PrescriptiveBindingSpec
  deriving stock (Show, Generic)

bootStatus :: Show a => String -> a -> CtxDoc
bootStatus nm x =
  PP.hang ("Boot status (" >< PP.string nm >< "):") 2 $ PP.show x

instance PrettyForTrace BootStatusMsg where
  prettyForTrace = \case
    BootStatusStart                   x -> bootStatus "BindgenConfig"           x
    BootStatusCStandard               x -> bootStatus "ClangCStandard"          x
    BootStatusClangExe                x -> bootStatus "ClangExe"                x
    BootStatusClangArgs               x -> bootStatus "ClangArgs"               x
    BootStatusRootDirectives          x -> bootStatus "RootDirectives"          x
    BootStatusExternalBindingSpecs    x -> bootStatus "ExternalBindingSpecs"    x
    BootStatusPrescriptiveBindingSpec x -> bootStatus "PrescriptiveBindingSpec" x

instance IsTrace Level BootStatusMsg where
  getDefaultLogLevel = const Debug
  getSource          = const HsBindgen
  getTraceId         = const "boot-status"

data BootCStandardMsg =
    BootCStandardClang ClangCStandard
  | BootCStandardFail
  deriving stock (Show, Generic)

instance PrettyForTrace BootCStandardMsg where
  prettyForTrace = \case
    BootCStandardClang std ->
      "C standard determined by libclang: " >< PP.show std
    BootCStandardFail ->
      "Unable to determine C standard"

instance IsTrace Level BootCStandardMsg where
  getDefaultLogLevel = \case
    BootCStandardClang{} -> Info
    BootCStandardFail    -> Error

  getSource  = const HsBindgen
  getTraceId = const "boot-c-standard"

-- | Boot trace messages
data BootMsg =
    BootBackendConfig        BackendConfigMsg
  | BootMacos                MacosMsg
  | BootBindingSpec          BindingSpecMsg
  | BootDiscover             DiscoverMsg
  | BootClang                ClangMsg
  | BootCStandard            BootCStandardMsg
  | BootExtraClangArgs       ExtraClangArgsMsg
  | BootHashIncludeArg       C.HashIncludeArgMsg
  | BootCompareClangVersions CompareVersionsMsg
  | BootStatus               BootStatusMsg
  | BootCache                (SafeTrace CacheMsg)
  deriving stock (Show, Generic)
  deriving anyclass (PrettyForTrace, IsTrace Level)