content: module HsBindgen.Resolve (
      -- * Trace messages
      ResolveHeaderMsg(..)
      -- * API
    , resolveHeaders
    ) where
  
  import Control.Monad ((<=<))
  import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
  import Data.Either (partitionEithers)
  import Data.List.Compat ((!?))
  import Data.Map.Strict qualified as Map
  import Data.Set qualified as Set
  import Data.Text qualified as Text
  import Text.SimplePrettyPrint (hang, hsep, string)
  
  import Clang.Args
  import Clang.Enum.Simple
  import Clang.HighLevel qualified as HighLevel
  import Clang.HighLevel.Types
  import Clang.LowLevel.Core
  import Clang.Paths
  
  import HsBindgen.Clang
  import HsBindgen.Errors (panicIO)
  import HsBindgen.Frontend.RootHeader
  import HsBindgen.Imports
  import HsBindgen.Util.Tracer
  
  {-------------------------------------------------------------------------------
    Trace messages
  -------------------------------------------------------------------------------}
  
  data ResolveHeaderMsg =
      ResolveHeaderClang ClangMsg
    | ResolveHeaderFound HashIncludeArg SourcePath
    | ResolveHeaderNotFound HashIncludeArg
  
      -- | Header not attempted to be resolved, /perhaps/ due to an error while
      -- parsing previous headers
      --
      -- NOTE: We have not been able to construct an example that causes this to
      -- happen, but we can at least detect if it happens.
    | ResolveHeaderNotAttempted HashIncludeArg
    deriving stock (Show)
  
  instance PrettyForTrace ResolveHeaderMsg where
    prettyForTrace = \case
      ResolveHeaderClang msg -> hang
        "during header resolution:" 2 (prettyForTrace msg)
      ResolveHeaderFound header path -> hsep [
          "header"
        , string $ getHashIncludeArg header
        , "resolved to"
        , string $ getSourcePath path
        ]
      ResolveHeaderNotFound header -> hsep [
          "header"
        , string $ getHashIncludeArg header
        , "could not be resolved (header not found)"
        ]
      ResolveHeaderNotAttempted header -> hsep [
          "header"
        , string $ getHashIncludeArg header
        , "not attempted to be resolved"
        ]
  
  instance IsTrace Level ResolveHeaderMsg where
    getDefaultLogLevel = \case
      ResolveHeaderClang x        -> getDefaultLogLevel x
      ResolveHeaderFound{}        -> Info
      ResolveHeaderNotFound{}     -> Error
      ResolveHeaderNotAttempted{} -> Error
    getSource = \case
      ResolveHeaderClang x        -> getSource x
      ResolveHeaderFound{}        -> HsBindgen
      ResolveHeaderNotFound{}     -> HsBindgen
      ResolveHeaderNotAttempted{} -> HsBindgen
    getTraceId = const "resolve-header"
  
  {-------------------------------------------------------------------------------
    API
  -------------------------------------------------------------------------------}
  
  -- | Resolve any number of headers
  resolveHeaders ::
       Tracer IO ResolveHeaderMsg
    -> ClangArgs
    -> Set HashIncludeArg
    -> IO (Map HashIncludeArg SourcePath)
  resolveHeaders tracer args headers =
        fmap (fromMaybe Map.empty)
      . withClang' (contramap ResolveHeaderClang tracer) clangSetup
      $ \unit -> do
          root <- clang_getTranslationUnitCursor unit
          (notFounds, successes) <-
            bimap Set.fromList Map.fromList . partitionEithers
              <$> HighLevel.clang_visitChildren root visit
          forM_ headerList $ \header -> traceWith tracer $
            case Map.lookup header successes of
              Just path -> ResolveHeaderFound header path
              Nothing
                | Set.member header notFounds -> ResolveHeaderNotFound header
                | otherwise -> ResolveHeaderNotAttempted header
          return $ Just successes
    where
      headerList :: [HashIncludeArg]
      headerList = Set.toAscList headers
  
      rootHeaderName :: FilePath
      rootHeaderName = "hs-bindgen-resolve.h"
  
      rootHeaderPath :: SourcePath
      rootHeaderPath = SourcePath $ Text.pack rootHeaderName
  
      rootHeaderContent :: String
      rootHeaderContent = unlines [
          "#include <" ++ getHashIncludeArg header ++ ">"
        | header <- headerList
        ]
  
      clangSetup :: ClangSetup
      clangSetup = defaultClangSetup args $
        ClangInputMemory rootHeaderName rootHeaderContent
  
      visit :: Fold IO (Either HashIncludeArg (HashIncludeArg, SourcePath))
      visit = simpleFold $ \curr ->
        maybe foldContinue foldContinueWith <=< runMaybeT $ do
          sloc <- HighLevel.clang_getCursorLocation' curr
          -- Only process the root header
          guard $ singleLocPath sloc == rootHeaderPath
          -- Only process inclusion directives
          guard . (== Right CXCursor_InclusionDirective) . fromSimpleEnum
            =<< clang_getCursorKind curr
          -- Process inclusion directive
          header <- maybe (panicIO "resolveHeaders unknown include") return $
            headerList !? (singleLocLine sloc - 1)
          path <- clang_getFileName =<< clang_getIncludedFile curr
          return $
            if Text.null path
              then Left header
              else Right (header, SourcePath path)
  