Frontend.hs

module HsBindgen.Frontend (
    runFrontend
  , FrontendArtefact (..)
  , FrontendMsg(..)
  , ParseInfo(..)
  ) where


import Prelude hiding (zip)

import Control.Exception (catch)
import Data.List.NonEmpty qualified as NE
import Data.Map.Lazy qualified as Map

import Clang.Enum.Bitfield
import Clang.LowLevel.Core
import Clang.Paths

import HsBindgen.Boot
import HsBindgen.Cache
import HsBindgen.Clang
import HsBindgen.Config.Internal
import HsBindgen.Doxygen
import HsBindgen.Frontend.Analysis.IncludeGraph (IncludeGraph)
import HsBindgen.Frontend.Analysis.UnnamedIdUsage (UnnamedIdUsageAnalysis)
import HsBindgen.Frontend.Analysis.UnnamedIdUsage qualified as UnnamedIdUsageAnalysis
import HsBindgen.Frontend.Pass.AdjustTypes
import HsBindgen.Frontend.Pass.AdjustTypes.IsPass
import HsBindgen.Frontend.Pass.ConstructTranslationUnit
import HsBindgen.Frontend.Pass.ConstructTranslationUnit.IsPass
import HsBindgen.Frontend.Pass.EnrichComments
import HsBindgen.Frontend.Pass.EnrichComments.IsPass
import HsBindgen.Frontend.Pass.FillUnnamedIds
import HsBindgen.Frontend.Pass.FillUnnamedIds.IsPass
import HsBindgen.Frontend.Pass.Final
import HsBindgen.Frontend.Pass.MangleNames
import HsBindgen.Frontend.Pass.MangleNames.IsPass
import HsBindgen.Frontend.Pass.Parse
import HsBindgen.Frontend.Pass.Parse.IsPass
import HsBindgen.Frontend.Pass.Parse.Monad.Decl qualified as ParseDecl
import HsBindgen.Frontend.Pass.Parse.Result
import HsBindgen.Frontend.Pass.PrepareReparse
import HsBindgen.Frontend.Pass.PrepareReparse.IsPass
import HsBindgen.Frontend.Pass.ReparseMacroExpansions
import HsBindgen.Frontend.Pass.ReparseMacroExpansions.IsPass
import HsBindgen.Frontend.Pass.ResolveBindingSpecs
import HsBindgen.Frontend.Pass.ResolveBindingSpecs.IsPass
import HsBindgen.Frontend.Pass.Select
import HsBindgen.Frontend.Pass.Select.IsPass
import HsBindgen.Frontend.Pass.SimplifyAST
import HsBindgen.Frontend.Pass.SimplifyAST.IsPass
import HsBindgen.Frontend.Pass.TranslateTypes
import HsBindgen.Frontend.Pass.TranslateTypes.IsPass
import HsBindgen.Frontend.Pass.TypecheckMacros
import HsBindgen.Frontend.Pass.TypecheckMacros.IsPass
import HsBindgen.Frontend.Predicate
import HsBindgen.Frontend.ProcessIncludes
import HsBindgen.Frontend.RootHeader (RootHeader, RootHeaderMsg)
import HsBindgen.Frontend.RootHeader qualified as RootHeader
import HsBindgen.Frontend.TranslationUnit qualified as C
import HsBindgen.Imports
import HsBindgen.IR.C qualified as C
import HsBindgen.IR.Pass
import HsBindgen.Language.Haskell qualified as Hs
import HsBindgen.Macro.Type qualified as Macro
import HsBindgen.Macro.UniqueExpansion qualified as UniqueExpansion
import HsBindgen.Util.Tracer

import Doxygen.Parser (Doxygen, DoxygenException (..), Result (..),
                       emptyDoxygen, parse)

-- | Frontend
--
-- = Overview of passes
--
-- See the documentation of 'HsBindgen.Frontend.Pass.IsPass'.
--
-- == 1. "HsBindgen.Frontend.Pass.Parse"
--
-- "HsBindgen.Frontend.Pass.Parse" traverses the @libclang@ AST, getting all
-- information that we need from @libclang@ and constructing a pure Haskell
-- representation (see "HsBindgen.Frontend.AST.Decl"). It runs in 'IO', to
-- interface with @libclang@.
--
-- Constraints:
--
-- * Must be first, to get the declarations from @libclang@
--
-- == 2. "HsBindgen.Frontend.Pass.SimplifyAST"
--
-- "HsBindgen.Frontend.Pass.SimplifyAST" simplifies the AST by converting
-- untagged enums without use sites into pattern synonym declarations. For
-- example, @enum { FOO, BAR }@ is converted into separate pattern synonym
-- declarations that will later be rendered as Haskell pattern synonyms.
--
-- Constraints:
--
-- * Must run before "HsBindgen.Frontend.Pass.FillUnnamedIds" because
--   FillUnnamedIds will delete unnamed declarations without use sites (it
--   needs a use site to determine a name)."
--
-- == 3. "HsBindgen.Frontend.Pass.FillUnnamedIds"
--
-- "HsBindgen.Frontend.Pass.FillUnnamedIds" assigns names to all unnamed
-- declarations, replacing 'HsBindgen.Frontend.Naming.PrelimDeclId' by
-- 'HsBindgen.Frontend.Naming.DeclId', which is used from this point forward.
--
-- Constraints:
--
-- * Must be before "HsBindgen.Frontend.Pass.ConstructTranslationUnit" so that
--   'HsBindgen.Frontend.Naming.DeclId' can be used as the key for the
--   'DeclIndex.DeclIndex', 'UseDeclGraph.UseDeclGraph', and
--   'DeclUseGraph.DeclUseGraph'
-- * Must be before "HsBindgen.Frontend.Pass.ResolveBindingSpecs" so that
--   binding specifications can use the assigned names
--
-- == 4. "HsBindgen.Frontend.Pass.EnrichComments"
--
-- "HsBindgen.Frontend.Pass.EnrichComments" enriches parsed declarations with
-- doxygen comments by looking up each declaration in the 'Doxygen' state.
--
-- Constraints:
--
-- * Must be after "HsBindgen.Frontend.Pass.FillUnnamedIds" so that
--   'HsBindgen.Frontend.Naming.DeclId' is available for the 'DeclIndex' and
--   for building doxygen-qualified names
--
-- == 5. "HsBindgen.Frontend.Pass.ConstructTranslationUnit"
--
-- "HsBindgen.Frontend.Pass.ConstructTranslationUnit" constructs a list of
-- sorted declarations as well as 'DeclIndex.DeclIndex',
-- 'UseDeclGraph.UseDeclGraph', and 'DeclUseGraph.DeclUseGraph'.
--
-- Constraints:
--
-- * Must be before the rest of the passes because they use these structures and
--   depend on the ordering of declarations
--
-- == 6. "HsBindgen.Frontend.Pass.TypecheckMacros"
--
-- "HsBindgen.Frontend.Pass.TypecheckMacros" collects known types and typechecks
-- all macros. Note that macros may neither refer to nor introduce new unnamed
-- declarations, so running "HsBindgen.Frontend.Pass.FillUnnamedIds" before
-- "HsBindgen.Frontend.Pass.TypecheckMacros" is fine.
--
-- Constraints:
--
-- * Must be before "HsBindgen.Frontend.Pass.ReparseMacroExpansions", because
--   "HsBindgen.Frontend.Pass.TypecheckMacros" typechecks macro-defined types
--   that are required to parse declarations with macro expansions.
--
-- == 7. "HsBindgen.Frontend.Pass.PrepareReparse"
--
-- @PrepareReparse@ prepares declarations that need to be reparsed because they
-- contain macro invocations. These declarations carry raw tokens intended to be
-- reparsed later, and the main goal of @PrepareReparse@ is to preprocess the
-- tokens to expand select macro invocations. If we leave macro invocations
-- unexpanded, then declarations that contain them will very likely fail to be
-- reparsed. In particular this is because the reparser expects its input to be
-- preprocessed. However, we do not expand a macro invocation if its definition
-- is identified (through parsing and typechecking) as a macro-defined type.
-- Such definitions are instead treated by the reparser as if they are
-- references to actual typedefs.
--
-- See issue #1225 for examples of how /not/ preprocessing caused problems in
-- the past:
--
-- <https://github.com/well-typed/hs-bindgen/issues/1225>
--
-- Constraints:
--
-- * Must be after @TypecheckMacros@, because @PrepareReparse@ needs to know
--   which macro definitions where identified as macro-defined types before we
--   can decide whether to expand macro invocations.
--
-- * Must be before @ReparseMacroExpansions@, because @ReparseMacroExpansions@
--   expects its reparser input to be preprocessed, which is what
--   @PrepareReparse@ takes care of.
--
-- == 8. "HsBindgen.Frontend.Pass.ReparseMacroExpansions"
--
-- "HsBindgen.Frontend.Pass.ReparseMacroExpansions" reparses declarations that
-- contain macro expansions.
--
-- Constraints:
--
-- * Must be before "HsBindgen.Frontend.Pass.AdjustTypes", because
--   "HsBindgen.Frontend.Pass.ReparseMacroExpansions" reparses declarations
--   referencing macro-defined types that may have to be adjusted.
--
-- == 9. "HsBindgen.Frontend.Pass.ResolveBindingSpecs"
--
-- "HsBindgen.Frontend.Pass.ResolveBindingSpecs" has two responsibilities:
--
-- * It matches declarations/uses with external binding specifications, removing
--   matching declarations and replacing uses with external references.
-- * It matches declarations with prescriptive binding specifications, either
--   omitting them or annotating the declarations with specifications to be used
--   in later passes.
--
-- Constraints:
--
-- * Must be before "HsBindgen.Frontend.Pass.Select" because prescriptive
--   binding specs may omit declarations and external binding specs may remove
--   declarations, and program slicing must take this into account
-- * Must be before "HsBindgen.Frontend.Pass.MangleNames" because prescriptive
--   binding specs may configure typedef squashing, which happens in
--   MangleNames.
-- * Must be before "HsBindgen.Frontend.Pass.MangleNames" because prescriptive
--   binding specs may specify arbitrary names
--
-- == 10. "HsBindgen.Frontend.Pass.MangleNames"
--
-- "HsBindgen.Frontend.Pass.MangleNames" assigns Haskell names for types,
-- constructors, fields, etc. It also deals with name clashes that can arise
-- from typedefs, squashing "unneeded" typedefs.
--
-- == 11. "HsBindgen.Frontend.Pass.AdjustTypes"
--
-- "HsBindgen.Frontend.Pass.AdjustTypes" adjusts types in declarations. For
-- example, if a function argument is a function type, then it is adjusted to a
-- function /pointer/ type.
--
-- == 12. "HsBindgen.Frontend.Pass.TranslateTypes"
--
-- "HsBindgen.Frontend.Pass.TranslateTypes" translates types (use sites) to
-- Haskell types.
--
-- == 13. "HsBindgen.Frontend.Pass.Select"
--
-- "HsBindgen.Frontend.Pass.Select" filters the declarations using predicates
-- and program slicing. It also emits delayed trace messages for declarations
-- that are selected.
--
-- Constraints:
--
-- * The 'Select' pass must come last so that if a declaration is
--   'HsBindgen.Frontend.Analysis.DeclIndex.UnusableEntry' for whatever reason
--   (e.g., it contains unsupported types such as @long double@, or the name
--   mangler was unable to find a suitable name, etc.), the 'Select' pass can
--   make sure that the unusable declaration /and all of its dependencies/ will
--   not be selected.
runFrontend ::
     forall l. (Macro.HasTypes l, HasCallStack)
  => Tracer FrontendMsg
  -> FrontendConfig
  -> BootArtefact l
  -> IO (FrontendArtefact l)
runFrontend tracer config boot = do
    rootHeaderC <- cache "rootHeader" $ do
      (msgs, rootHeader) <- RootHeader.fromRootDirectives <$> boot.rootDirectives
      liftIO $ mapM_ (traceWith tracerRootHeader . withCallStack) msgs
      pure rootHeader

    parsePass <- cache "parse" $ do
      setup     <- getSetup =<< rootHeaderC
      macroLang <- boot.macroLang
      liftIO $ withClang (contramap FrontendClang tracer) setup $ \unit -> do
        (includeGraph, isMainHeader, isInMainHeaderDir, getMainHeadersAndInclude, mainHeaderPaths) <-
          processIncludes unit
        -- Run doxygen on the resolved main header paths to extract
        -- structured comments.  The paths come from clang's own include
        -- resolution (via processIncludes), so no separate path search
        -- is needed.
        let resolvedPaths = map getRealPath mainHeaderPaths
            emptyResult   = Result {
                doxygen = emptyDoxygen, warnings = [], doxygenVersion = "unknown"
              }
        doxyResult <- case NE.nonEmpty resolvedPaths of
          Nothing -> pure emptyResult
          Just paths -> parse config.doxygenConfig paths
            `catch` \(e :: DoxygenException) -> do
              traceWith tracer $ withCallStack $ FrontendDoxygen $ DoxygenWarning e
              pure emptyResult

        -- Emit structured warnings for unsupported content
        forM_ doxyResult.warnings $ \w ->
          traceWith tracer $ withCallStack $ FrontendDoxygen $ DoxygenUnsupported w

        let parseEnv :: ParseDecl.Env
            parseEnv = ParseDecl.Env{
                unit                     = unit
              , getMainHeadersAndInclude = getMainHeadersAndInclude
              , emptyMacros              = config.emptyMacros
              , tracer                   = contramap FrontendParse tracer
              }
        (parseResults, macroAnalysis) <- parseDecls macroLang parseEnv

        let decls :: [C.Decl l Parse]
            decls = mapMaybe getParseResultMaybeDecl parseResults
            usageAnalysis = UnnamedIdUsageAnalysis.fromDecls decls

        pure $ ParsePassResult {
            results           = parseResults
          , doxygen           = doxyResult.doxygen
          , includeGraph      = includeGraph
          , isMainHeader      = isMainHeader
          , isInMainHeaderDir = isInMainHeaderDir
          , getMainHeaders    = toGetMainHeaders getMainHeadersAndInclude
          , usageAnalysis     = usageAnalysis
          , macroAnalysis     = macroAnalysis
          }

    parseMeta <- cache "parseMeta" $ do
      afterParse <- parsePass
      pure ParseInfo {
        includeGraph   = afterParse.includeGraph
      , getMainHeaders = afterParse.getMainHeaders
      }

    simplifyASTPass <- cache "simplifyAST" $ do
      afterParse <- parsePass
      let (afterSimplifyAST, msgsSimplifyAST) =
            simplifyAST afterParse.usageAnalysis afterParse.results
      forM_ msgsSimplifyAST $ traceWith (contramap FrontendSimplifyAST tracer)
      pure afterSimplifyAST

    fillUnnamedIdsPass <- cache "fillUnnamedIds" $ do
      afterParse       <- parsePass
      afterSimplifyAST <- simplifyASTPass
      let (afterFillUnnamedIds, msgsFillUnnamedIds) =
            fillUnnamedIds afterParse.usageAnalysis afterSimplifyAST
      forM_ msgsFillUnnamedIds $ traceWith (contramap FrontendFillUnnamedIds tracer)
      pure afterFillUnnamedIds

    enrichCommentsPass <- cache "enrichComments" $ do
      afterParse         <- parsePass
      afterFillUnnamedIds <- fillUnnamedIdsPass
      pure $ enrichComments afterParse.doxygen afterFillUnnamedIds

    constructTranslationUnitPass <- cache "constructTranslationUnit" $ do
      macroLang  <- boot.macroLang
      afterParse <- parsePass
      afterEnrichComments <- enrichCommentsPass
      let afterConstructTranslationUnit =
            constructTranslationUnit
              macroLang
              afterParse.macroAnalysis
              afterParse.isMainHeader
              afterEnrichComments
              afterParse.includeGraph
      pure afterConstructTranslationUnit

    typecheckMacrosPass <- cache "typecheckMacros" $ do
      macroLang                     <- boot.macroLang
      afterConstructTranslationUnit <- constructTranslationUnitPass
      pure $ typecheckMacros macroLang afterConstructTranslationUnit

    prepareReparsePass <- cache "prepareReparse" $ do
      (afterTypecheckMacros, _, _) <- typecheckMacrosPass
      clangExe <- boot.clangExe
      rootHeader <- rootHeaderC
      setup <- getSetup rootHeader
      liftIO $ prepareReparse
                  (contramap FrontendPrepareReparse tracer)
                  clangExe
                  setup
                  rootHeader
                  afterTypecheckMacros

    reparseMacroExpansionsPass <- cache "reparseMacroExpansions" $ do
      (_, knownTypes, knownMacros) <- typecheckMacrosPass
      afterPrepareReparse <- prepareReparsePass
      cStd <- boot.cStandard
      pure $ reparseMacroExpansions cStd (Map.map coercePass knownTypes) knownMacros afterPrepareReparse

    resolveBindingSpecsPass <- cache "resolveBindingSpecs" $ do
      afterReparseMacroExpansions <- reparseMacroExpansionsPass
      extSpecs <- boot.externalBindingSpecs
      pSpec    <- boot.prescriptiveBindingSpec
      let moduleName = Hs.ModuleName boot.baseModule.text -- do not import Backend
          (afterResolveBindingSpecs, msgsResolveBindingSpecs) =
            resolveBindingSpecs moduleName extSpecs pSpec afterReparseMacroExpansions
      forM_ msgsResolveBindingSpecs $ traceWith (contramap FrontendResolveBindingSpecs tracer)
      pure afterResolveBindingSpecs

    mangleNamesPass <- cache "mangleNames" $ do
      afterResolveBindingSpecs <- resolveBindingSpecsPass
      let (afterMangleNames, msgsMangleNames) =
            mangleNames config.fieldNamingStrategy afterResolveBindingSpecs
      forM_ msgsMangleNames $ traceWith (contramap FrontendMangleNames tracer)
      pure afterMangleNames

    adjustTypesPass <- cache "AdjustTypes" $ do
      afterMangleNamesPass <- mangleNamesPass
      pure $ adjustTypes afterMangleNamesPass

    translateTypesPass <- cache "TranslateTypes" $ do
      afterAdjustTypesPass <- adjustTypesPass
      let (afterTranslateTypes, msgsTranslateTypes) =
            translateTypes afterAdjustTypesPass
      forM_ msgsTranslateTypes $ traceWith (contramap FrontendTranslateTypes tracer)
      pure afterTranslateTypes

    selectPass <- cache "select" $ do
      afterParse <- parsePass
      afterTranslateTypesPass <- translateTypesPass
      let (afterSelect, msgsSelect) =
            selectDecls
              afterParse.isMainHeader
              afterParse.isInMainHeaderDir
              selectConfig
              afterTranslateTypesPass
      forM_ msgsSelect $  traceWith (contramap FrontendSelect tracer)
      pure afterSelect

    finalPass <- cache "Final" $ selectPass

    pure FrontendArtefact{
        parseMeta                = parseMeta
      , parse                    = (.results) <$> parsePass
      , doxygen                  = (.doxygen) <$> parsePass
      , simplifyAST              = simplifyASTPass
      , fillUnnamedIds           = fillUnnamedIdsPass
      , enrichComments           = enrichCommentsPass
      , constructTranslationUnit = constructTranslationUnitPass
      , typecheckMacros          = (\(x,_,_) -> x) <$> typecheckMacrosPass
      , reparseMacroExpansions   = reparseMacroExpansionsPass
      , resolveBindingSpecs      = resolveBindingSpecsPass
      , mangleNames              = mangleNamesPass
      , adjustTypes              = adjustTypesPass
      , translateTypes           = translateTypesPass
      , select                   = selectPass
      , final                    = finalPass
      }
  where
    getSetup :: RootHeader -> Cached ClangSetup
    getSetup rootHeader = do
      clangArgs <- boot.clangArgs
      let hContent = RootHeader.content rootHeader
          setup = defaultClangSetup clangArgs $ ClangInputMemory hFilePath hContent
      pure $ setup {
          flags = bitfieldEnum [
              CXTranslationUnit_DetailedPreprocessingRecord
            , CXTranslationUnit_IncludeAttributedTypes
            , CXTranslationUnit_VisitImplicitAttributes
            ]
        }

    hFilePath :: FilePath
    hFilePath = getSourcePath RootHeader.name

    selectConfig :: SelectConfig
    selectConfig = SelectConfig{
          programSlicing     = config.programSlicing
        , selectionPredicate = config.selectionPredicate
        }

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

    tracerRootHeader :: Tracer RootHeaderMsg
    tracerRootHeader = contramap FrontendRootHeader tracer

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

data FrontendArtefact l = FrontendArtefact {
      parseMeta                :: Cached ParseInfo
    , parse                    :: Cached [ParseResult       l Parse]
    , doxygen                  :: Cached Doxygen
    , simplifyAST              :: Cached [ParseResult       l SimplifyAST]
    , fillUnnamedIds           :: Cached [ParseResult       l FillUnnamedIds]
    , enrichComments           :: Cached [ParseResult       l EnrichComments]
    , constructTranslationUnit :: Cached (C.TranslationUnit l ConstructTranslationUnit)
    , typecheckMacros          :: Cached (C.TranslationUnit l TypecheckMacros)
    , reparseMacroExpansions   :: Cached (C.TranslationUnit l ReparseMacroExpansions)
    , resolveBindingSpecs      :: Cached (C.TranslationUnit l ResolveBindingSpecs)
    , mangleNames              :: Cached (C.TranslationUnit l MangleNames)
    , adjustTypes              :: Cached (C.TranslationUnit l AdjustTypes)
    , translateTypes           :: Cached (C.TranslationUnit l TranslateTypes)
    , select                   :: Cached (C.TranslationUnit l Select)
    , final                    :: Cached (C.TranslationUnit l Final)
    }

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

-- | Frontend trace messages
--
-- Most passes in the frontend have their own set of trace messages.
data FrontendMsg =
    FrontendClang                     ClangMsg
  | FrontendParse                    (Msg Parse)
  | FrontendSimplifyAST              (Msg SimplifyAST)
  | FrontendFillUnnamedIds           (Msg FillUnnamedIds)
  | FrontendPrepareReparse           (Msg PrepareReparse)
  | FrontendReparseMacroExpansions   (Msg ReparseMacroExpansions)
  | FrontendResolveBindingSpecs      (Msg ResolveBindingSpecs)
  | FrontendMangleNames              (Msg MangleNames)
  | FrontendTranslateTypes           (Msg TranslateTypes)
  | FrontendSelect                   (Msg Select)
  | FrontendCache                    (SafeTrace CacheMsg)
  | FrontendDoxygen                   DoxygenMsg
  | FrontendRootHeader                RootHeaderMsg
  deriving stock    (Show, Generic)
  deriving anyclass (PrettyForTrace, IsTrace Level)

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

-- | Information useful for inspection as well as peripheral tasks.
--
-- Excluded from the parse pass result because there is no 'Show' instance.
data ParseInfo = ParseInfo {
      includeGraph      :: IncludeGraph
    , getMainHeaders    :: GetMainHeaders
    }

{-------------------------------------------------------------------------------
  Internal helpers
-------------------------------------------------------------------------------}

data ParsePassResult l = ParsePassResult {
      results           :: [ParseResult l Parse]
    , doxygen           :: Doxygen
    , includeGraph      :: IncludeGraph
    , isMainHeader      :: IsMainHeader
    , isInMainHeaderDir :: IsInMainHeaderDir
    , getMainHeaders    :: GetMainHeaders
    , usageAnalysis     :: UnnamedIdUsageAnalysis
    , macroAnalysis     :: UniqueExpansion.Analysis
    }