Internal.hs

module HsBindgen.TH.Internal (
    -- * Template Haskell API
    Config
  , IncludeDir(..)
  , withHsBindgenMacroLang
  , hashInclude
  , hashDefine
  , BindgenM

   -- * Internal artefacts
  , getExtensions
  , getThDecls
  ) where

import Control.Monad.State (State, execState)
import Control.Monad.State.Class (MonadState, modify)
import Data.Foldable qualified as Foldable
import Data.List qualified as List
import Data.Set qualified as Set
import Language.Haskell.TH qualified as TH
import Language.Haskell.TH.Syntax (getPackageRoot)
import System.FilePath (isAbsolute, (</>))

import Clang.CStandard
import Clang.Paths

import HsBindgen
import HsBindgen.Backend.Category
import HsBindgen.Backend.Extensions
import HsBindgen.Backend.Hs.CallConv
import HsBindgen.Backend.SHs.AST qualified as SHs
import HsBindgen.Backend.TH.Translation
import HsBindgen.Config
import HsBindgen.Config.Internal
import HsBindgen.Errors
import HsBindgen.Guasi
import HsBindgen.Imports
import HsBindgen.IR.C qualified as C
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

{-------------------------------------------------------------------------------
  Template Haskell API
-------------------------------------------------------------------------------}

-- | Configuration with C include directories
--
-- C include directories can be provided relative to the package root (see the
-- 'IncludeDir' data constructor 'PkgDir').
type Config = Config_ IncludeDir

-- | C include directory added to the C include search path
data IncludeDir =
    -- | Include directory at absolute path
    --
    -- A relative path is warned about: it is resolved against the working
    -- directory of the compiler invocation, not the package root.
    AbsDir FilePath

    -- | Include directory relative to package root
    --
    -- An absolute path is an error: it would discard the package root.
  | PkgDir FilePath
  deriving stock (Eq, Show, Generic)

toFilePath :: FilePath -> IncludeDir -> FilePath
toFilePath root (PkgDir x) = root </> x
toFilePath _    (AbsDir x) = x

-- | Misuse of an 'IncludeDir' constructor
data IncludeDirMisuse =
    -- | 'AbsDir' with a relative path
    RelativeAbsDir FilePath

    -- | 'PkgDir' with an absolute path
  | AbsolutePkgDir FilePath
  deriving stock (Eq, Show)

checkIncludeDir :: IncludeDir -> Maybe IncludeDirMisuse
checkIncludeDir = \case
    AbsDir path | not (isAbsolute path) -> Just $ RelativeAbsDir path
    PkgDir path | isAbsolute path       -> Just $ AbsolutePkgDir path
    _otherwise                          -> Nothing

-- | An absolute 'PkgDir' path discards the package root, so it is never what
-- the user meant; a relative 'AbsDir' path does work, but only by accident.
isFatal :: IncludeDirMisuse -> Bool
isFatal RelativeAbsDir{}  = False
isFatal AbsolutePkgDir{}  = True

prettyIncludeDirMisuse :: IncludeDirMisuse -> String
prettyIncludeDirMisuse = \case
    RelativeAbsDir path -> unwords [
        "Relative path in 'AbsDir " ++ show path ++ "':"
      , "it is resolved relative to the working directory of the compiler"
      , "invocation, which is not necessarily the package root."
      , "Use an absolute path, or 'PkgDir' for a path relative to the"
      , "package root."
      ]
    AbsolutePkgDir path -> unwords [
        "Absolute path in 'PkgDir " ++ show path ++ "':"
      , "the package root is discarded, so the path is not relative to it."
      , "Use 'AbsDir' for an absolute path."
      ]

-- | Warn about, or reject, misuses of 'IncludeDir' constructors
--
-- NOTE: We report through Template Haskell instead of the tracer: the tracers
-- are only created in 'hsBindgenMacroLang', which needs the configuration we
-- are checking here. Consequently, the warning cannot be silenced via
-- 'ConfigTH'. The same applies to 'checkLanguageExtensions'.
checkIncludeDirs :: [IncludeDir] -> TH.Q ()
checkIncludeDirs includeDirs = do
    mapM_ (TH.reportWarning . prettyIncludeDirMisuse) warnings
    unless (null errors) $
      failQ $ List.intercalate "\n" $ map prettyIncludeDirMisuse errors
  where
    errors, warnings :: [IncludeDirMisuse]
    (errors, warnings) =
      List.partition isFatal $ mapMaybe checkIncludeDir includeDirs

-- | Generate bindings for given C headers at compile-time using a custom
-- macro language.
--
-- Use together with 'hashInclude', which acts in the 'TH.BindgenM' monad.
--
-- For example,
--
-- > withHsBindgenMacroLang myMacroLang def def $ do
-- >   hashDefine "FOO_FEATURE" "1"
-- >   hashInclude "foo.h"
-- >   hashInclude "bar.h"
withHsBindgenMacroLang ::
     forall l. Macro.HasTypes l
  => (ClangCStandard -> IO (Macro.Lang l))
     --  ^ The callback returning the macro 'Macro.Lang' to use.
  -> Config
  -> ConfigTH
  -> BindgenM ()
  -> TH.Q [TH.Dec]
withHsBindgenMacroLang mkMacroLang config configTH hashIncludes = do
    packageRoot <- getPackageRoot

    bindgenConfig <- toBindgenConfigTH config packageRoot configTH.categoryChoice

    let tracerConfigUnsafe :: TracerConfig Level TraceMsg
        tracerConfigUnsafe =
          tracerConfigDefTH
            & #verbosity      .~ configTH.verbosity
            & #customLogLevel .~ getCustomLogLevel configTH.customLogLevels

    let tracerConfigSafe :: TracerConfig SafeLevel SafeTraceMsg
        tracerConfigSafe =
          tracerConfigDefTH
            & #verbosity .~ configTH.verbosity

        -- Traverse root directives.
        bindgenState :: BindgenState
        bindgenState = execBindgenM hashIncludes (BindgenState [])

        -- Restore original order of the directives.
        uncheckedRootDirectives :: [C.UncheckedRootDirective]
        uncheckedRootDirectives = reverse bindgenState.rootDirectives

        artefact ::
          Artefact l
            ( [RealPath]
            , ( [C.RootDirective C.HashIncludeArg]
              , ([CWrapper], [SHs.SDecl])
              )
            )
        artefact = (,)
          <$> getDependencies
          <*> ((,) <$> RootDirectives <*> (Foldable.fold <$> FinalDecls))

    (deps, (rootDirectives, decls)) <- liftIO $ do
        hsBindgenMacroLang
          mkMacroLang
          tracerConfigUnsafe
          tracerConfigSafe
          bindgenConfig
          uncheckedRootDirectives
          artefact

    let fns  = bindgenConfig.frontend.fieldNamingStrategy
        exts = uncurry (getExtensions fns) decls
    checkLanguageExtensions exts
    -- Reverse SDecl order to counteract GHC reversing TH type/class
    -- declarations during dependency analysis, which causes Haddock to show
    -- declarations in reverse order.
    uncurry (getThDecls fns deps rootDirectives) (second reverse decls)

-- | @#include@ (i.e., generate bindings for) a C header
--
-- For example, the Haskell code,
--
-- > hashInclude "a.h"
--
-- corresponds to the following C code using angular brackets,
--
-- > #include <a.h>
--
-- See 'withHsBindgen'.
hashInclude :: FilePath -> BindgenM ()
hashInclude arg = do
    -- Prepend the directive to the list (the order will be reversed)
    modify $ #rootDirectives %~ (C.DirectiveHashInclude arg:)

-- | @#define@ a macro, in effect for all subsequent 'hashInclude's
--
-- > hashDefine "FOO" "1"    -- #define FOO 1
-- > hashDefine "FOO" ""     -- #define FOO      (empty replacement list)
-- > hashDefine "FOO(x)" "x" -- #define FOO(x) x
--
-- The directive applies to /all/ C stages: it is emitted both into the header
-- @libclang@ parses and into the generated C wrapper source GHC compiles.
--
-- Neither argument is validated; see t'C.HashDefine'.
--
-- This is @#define@ syntax, /not/ C ompiler @-D@ syntax. For example, @-D FOO@
-- corresponds to @--hash-define FOO 1@, translating to @#define FOO 1@.
hashDefine ::
     String -- ^ Macro name; may be function-like, e.g. @FOO(x)@
  -> String -- ^ Replacement list; @""@ for @#define FOO@
  -> BindgenM ()
hashDefine name value = do
    -- Prepend the directive to the list (the order will be reversed)
    modify $ #rootDirectives %~ (C.DirectiveHashDefine (C.HashDefine name value):)

{-------------------------------------------------------------------------------
  Internal artefacts
-------------------------------------------------------------------------------}

-- | Get required extensions
getExtensions :: FieldNamingStrategy -> [CWrapper] -> [SHs.SDecl] -> Set TH.Extension
getExtensions fieldNaming wrappers decls =
    userlandCapiExt <> foldMap (requiredExtensions fieldNaming) decls
  where
    userlandCapiExt = case wrappers of
      []  -> Set.empty
      _xs -> Set.singleton TH.TemplateHaskell

-- | Get Template Haskell declarations
--
-- Internal!
--
-- Non-IO part of 'withHsBindgen'.
getThDecls
    :: Guasi q
    => FieldNamingStrategy
    -> [RealPath]
    -> [C.RootDirective C.HashIncludeArg]
    -> [CWrapper]
    -> [SHs.SDecl]
    -> q [TH.Dec]
getThDecls fns deps rootDirectives wrappers decls = do
    -- Record dependencies, including transitively included headers.
    mapM_ (addDependentFile . getRealPath) deps

    -- Add userland-CAPI wrappers source code.
    unless (null wrapperSrc) $ addCSource wrapperSrc

    -- Generate TH declarations.
    xs <- fmap concat $ traverse (mkDecl fns) decls

    -- Report warnings/errors.
    reportMissingModules

    pure xs
  where
    wrapperSrc :: String
    wrapperSrc = getCWrappersSource rootDirectives wrappers

    reportMissingModules :: Guasi q => q ()
    reportMissingModules = do
      missingModules <- (.missingModules) <$> getGuasi
      unless (Set.null missingModules) $ do
        reportError $ concat $
          "External types not in scope. Add the following import(s):\n"
          : map getImportStatement (Set.elems missingModules)

    getImportStatement :: Hs.ModuleName -> String
    getImportStatement m =
      "    import " <> Hs.moduleNameToString m <> " qualified"

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

-- | The default tracer configuration in Q uses 'outputConfigTH'
tracerConfigDefTH :: TracerConfig l a
tracerConfigDefTH = def{outputConfig = outputConfigTH}

-- | State monad used by 'HsBindgen.withBindgen'
newtype BindgenM a = BindgenM { unwrap :: State BindgenState a }
  deriving newtype (Functor, Applicative, Monad, MonadState BindgenState)

execBindgenM :: BindgenM a -> BindgenState -> BindgenState
execBindgenM = execState . (.unwrap)

-- | State manipulated by 'hashInclude' and 'hashDefine'
--
-- Internal!
data BindgenState = BindgenState {
      rootDirectives :: [C.UncheckedRootDirective]
    }
  deriving stock (Generic)

-- NOTE: We could also check which enabled extension may interfere with the
-- generated code (e.g. Strict/Data).
--
-- NOTE: We report through Template Haskell instead of the tracer; see
-- 'checkIncludeDirs'.
checkLanguageExtensions :: Set TH.Extension -> TH.Q ()
checkLanguageExtensions requiredExts = do
    enabledExts <- Set.fromList <$> extsEnabled
    let missingExts  = requiredExts `Set.difference` enabledExts

    unless (null missingExts) $ do
      failQ $ unlines $
        "Missing language extension(s): " :
          (map (("    - " ++) . show) (toList missingExts))

toBindgenConfigTH :: Config -> FilePath -> ByCategory Choice -> TH.Q BindgenConfig
toBindgenConfigTH config packageRoot choice = do
    checkIncludeDirs $ Foldable.toList config
    uniqueId <- getUniqueId
    hsModuleName <- fromString . TH.loc_module <$> TH.location
    let bindgenConfig :: BindgenConfig
        bindgenConfig =
          toBindgenConfig
            (toFilePath packageRoot <$> config)
            uniqueId
            hsModuleName
            choice
    pure bindgenConfig
  where
    getUniqueId :: TH.Q UniqueId
    getUniqueId = UniqueId . TH.loc_package <$> TH.location