App.hs

{-# LANGUAGE ApplicativeDo #-}

-- | @hs-bindgen@ application common types and functions
module HsBindgen.App (
    hsBindgen

    -- * Global options
  , GlobalOpts(..)
  , parseGlobalOpts

    -- * Argument/option parsers
    -- ** Bindgen configuration
  , Config
  , parseConfig
    -- ** Clang arguments
  , parseClangArgsConfig
    -- ** Translation option
  , parseUniqueId
    -- ** Module option
  , parseBaseModuleName
  , parseQualifiedStyle
    -- ** Output options
  , parseHsOutputDir
  , parseDirPolicy
  , parseFilePolicy
  , parseGenBindingSpec
  , parseGenTestsOutput
    -- ** Input arguments
  , parseInputs

    -- * Auxiliary optparse-applicative functions
  , cmd
  , cmd_
  ) where

import Data.Char qualified as Char
import Data.Default (Default (..))
import Data.Either (partitionEithers)
import Data.Maybe (catMaybes)
import Options.Applicative
import Options.Applicative.Extra (helperWith)
import System.IO (stderr)

import HsBindgen
import HsBindgen.ArtefactM (DirPolicy (..), FilePolicy (..))
import HsBindgen.BindingSpec
import HsBindgen.Config
import HsBindgen.Config.ClangArgs
import HsBindgen.Config.Internal
import HsBindgen.Frontend.Pass.Parse.IsPass (EmptyMacros (..))
import HsBindgen.Frontend.Pass.Select.IsPass
import HsBindgen.Frontend.Predicate
import HsBindgen.IR.C qualified as C
import HsBindgen.Macro (CExpr)
import HsBindgen.Macro qualified as Macro
import HsBindgen.TraceMsg
import HsBindgen.Util.Tracer

-- | Convenience entry point using the default C macro language.
hsBindgen ::
     TracerConfig Level     TraceMsg
  -> TracerConfig SafeLevel SafeTraceMsg
  -> BindgenConfig
  -> [C.UncheckedRootDirective]
  -> Artefact CExpr a
  -> IO a
hsBindgen = hsBindgenMacroLang (pure . Macro.cExpr)

{-------------------------------------------------------------------------------
  Global options
-------------------------------------------------------------------------------}

data GlobalOpts = GlobalOpts {
      unsafe :: TracerConfig Level     TraceMsg
    , safe   :: TracerConfig SafeLevel SafeTraceMsg
    }

parseGlobalOpts :: Parser GlobalOpts
parseGlobalOpts = aux <$> parseAnsiColor <*> parseTracerConfig
  where
    aux :: Maybe AnsiColor -> TracerConfig Level TraceMsg -> GlobalOpts
    aux ansiColor tracerConfig =
      let tracerConfigUnsafe :: TracerConfig Level TraceMsg
          tracerConfigUnsafe =
            tracerConfig { outputConfig = mkOutputConfig ansiColor }
          tracerConfigSafe :: TracerConfig SafeLevel SafeTraceMsg
          tracerConfigSafe = TracerConfig {
              verbosity      = tracerConfig.verbosity
            , outputConfig   = mkOutputConfig ansiColor
            , customLogLevel = mempty
            , showCallStack  = tracerConfig.showCallStack
            }
      in  GlobalOpts tracerConfigUnsafe tracerConfigSafe

{-------------------------------------------------------------------------------
  Output configuration
-------------------------------------------------------------------------------}

-- | Output configuration writing to 'stderr' with the given ANSI color setting.
--
-- 'Nothing' auto-detects color support from the handle.
mkOutputConfig :: Maybe AnsiColor -> OutputConfig e
mkOutputConfig ansiColor = OutputConfigHandle OutputHandle {
      handle    = stderr
    , ansiColor = ansiColor
    }

-- | Parse the @--color WHEN@ option: 'Nothing' (auto) is the default.
parseAnsiColor :: Parser (Maybe AnsiColor)
parseAnsiColor = option (eitherReader auxParse) $ mconcat [
      long "color"
    , metavar "WHEN"
    , value Nothing
    , showDefaultWith auxRender
    , help "Colorize diagnostics WHEN (supported: always, auto, never)"
    ]
  where
    auxParse :: String -> Either String (Maybe AnsiColor)
    auxParse = \case
      "always" -> Right (Just EnableAnsiColor)
      "auto"   -> Right Nothing
      "never"  -> Right (Just DisableAnsiColor)
      other    -> Left $
        "invalid color mode: " ++ other ++ " (supported: always, auto, never)"

    auxRender :: Maybe AnsiColor -> String
    auxRender = \case
      Just EnableAnsiColor  -> "always"
      Nothing               -> "auto"
      Just DisableAnsiColor -> "never"

{-------------------------------------------------------------------------------
  Tracer configuration
-------------------------------------------------------------------------------}

parseTracerConfig :: Parser (TracerConfig Level TraceMsg)
parseTracerConfig =
    TracerConfig
      <$> parseVerbosity
      <*> pure def
      <*> parseCustomLogLevel
      <*> parseShowCallStack

parseVerbosity :: Parser Verbosity
parseVerbosity = fmap nToVerbosity . option auto $ mconcat [
      short 'v'
    , long "verbosity"
    , metavar "INT"
    , value 2
    , help "Verbosity (0: error, 1: warning, 2: notice, 3: info, 4: debug)"
    , showDefault
    ]
  where
    nToVerbosity :: Int -> Verbosity
    nToVerbosity = Verbosity . \case
      n | n <= 0 -> Error
      1          -> Warning
      2          -> Notice
      3          -> Info
      _otherwise -> Debug

parseCustomLogLevel :: Parser (CustomLogLevel Level TraceMsg)
parseCustomLogLevel = do
    -- Generic setters
    makeTraceInfos    <- many $ parseMakeTrace Info
    makeTraceWarnings <- many $ parseMakeTrace Warning
    makeTraceErrors   <- many $ parseMakeTrace Error
    -- Generic modifiers
    makeBugsErrors     <- optional parseMakeBugsErrors
    makeWarningsErrors <- optional parseMakeWarningsErrors
    -- Specific setters
    enableMacroWarnings         <- optional parseEnableMacroWarnings
    makeMangleNamesSquashedInfo <- optional parseMakeMangleNamesSquashedInfo
    pure $ getCustomLogLevel $ catMaybes [
        enableMacroWarnings
      , makeMangleNamesSquashedInfo
      , makeBugsErrors
      , makeWarningsErrors
      ]
      ++ makeTraceInfos
      ++ makeTraceWarnings
      ++ makeTraceErrors
  where
    parseMakeTrace :: Level -> Parser CustomLogLevelSetting
    parseMakeTrace level =
      let levelStr = map Char.toLower $ show level
      in  fmap (MakeTrace level) . strOption $ mconcat [
              long $ "log-as-" <> levelStr
            , metavar "TRACE_ID"
            , help $ "Set log level of traces with TRACE_ID to " <> levelStr
            ]

    parseMakeBugsErrors :: Parser CustomLogLevelSetting
    parseMakeBugsErrors = flag' MakeBugsErrors $ mconcat [
        long "log-as-error-bugs"
      , help "Set log level of bugs to error"
      ]

    parseMakeWarningsErrors :: Parser CustomLogLevelSetting
    parseMakeWarningsErrors = flag' MakeWarningsErrors $ mconcat [
        long "log-as-error-warnings"
      , help "Set log level of warnings and bugs to error"
      ]

    parseEnableMacroWarnings :: Parser CustomLogLevelSetting
    parseEnableMacroWarnings = flag' EnableMacroWarnings $ mconcat [
        long "log-enable-macro-warnings"
      , help $ concat [
            "Set log level of macro reparse and typecheck errors to warning"
          , " (default: info)"
          ]
      ]

    parseMakeMangleNamesSquashedInfo :: Parser CustomLogLevelSetting
    parseMakeMangleNamesSquashedInfo =
        flag' MakeMangleNamesSquashedInfo $ mconcat [
            long "log-squashed-as-info"
          , help $ concat [
                "Set log level of squashed-typedef traces to info"
              , " (default: notice)"
              ]
          ]

parseShowCallStack :: Parser ShowCallStack
parseShowCallStack = flag DisableCallStack EnableCallStack $ mconcat [
      long "log-show-call-stack"
    , help "Show call stacks in traces"
    ]

{-------------------------------------------------------------------------------
  Configuration
-------------------------------------------------------------------------------}

type Config = Config_ FilePath

parseConfig :: Parser Config
parseConfig = Config
    <$> parseClangArgsConfig
    <*> parseBindingSpec
    <*> parseSelectionPredicate
    <*> parseProgramSlicing
    <*> parseFieldNamingStrategy
    <*> parseEmptyMacros

{-------------------------------------------------------------------------------
  Binding specifications
-------------------------------------------------------------------------------}

parseBindingSpec :: Parser BindingSpecConfig
parseBindingSpec = BindingSpecConfig
  <$> parseEnableStdlibBindingSpec
  <*> parseBindingSpecAllowNewer
  <*> many parseExtBindingSpec
  <*> optional parsePrescriptiveBindingSpec

parseEnableStdlibBindingSpec :: Parser EnableStdlibBindingSpec
parseEnableStdlibBindingSpec =
    flag EnableStdlibBindingSpec DisableStdlibBindingSpec $ mconcat [
        long "no-stdlib"
      , help "Do not automatically use stdlib external binding specification"
      ]

parseBindingSpecAllowNewer :: Parser BindingSpecCompatibility
parseBindingSpecAllowNewer =
    flag BindingSpecStrict BindingSpecAllowNewer $ mconcat [
        long "binding-spec-allow-newer"
      , help "Parse binding specifications with newer minor version"
      ]

parseExtBindingSpec :: Parser FilePath
parseExtBindingSpec = strOption $ mconcat [
      long "external-binding-spec"
    , metavar "FILE"
    , help "External binding specification (YAML file)"
    ]

parsePrescriptiveBindingSpec :: Parser FilePath
parsePrescriptiveBindingSpec = strOption $ mconcat [
      long "prescriptive-binding-spec"
    , metavar "FILE"
    , help "Prescriptive binding specification (YAML file)"
    ]

{-------------------------------------------------------------------------------
  Builtin include directory
-------------------------------------------------------------------------------}

parseBuiltinIncDirConfig :: Parser BuiltinIncDirConfig
parseBuiltinIncDirConfig = option (eitherReader auxParse) $ mconcat [
      long "builtin-include-dir"
    , metavar "MODE"
    , showDefaultWith auxRender
    , value BuiltinIncDirClang
    , help
        "Configure builtin include directory (supported: clang, disable)"
    ]
  where
    auxParse :: String -> Either String BuiltinIncDirConfig
    auxParse = \case
      "clang"   -> Right BuiltinIncDirClang
      "disable" -> Right BuiltinIncDirDisable
      other     -> Left $ "invalid builtin include directory mode: " ++ other

    auxRender :: BuiltinIncDirConfig -> String
    auxRender = \case
      BuiltinIncDirClang   -> "clang"
      BuiltinIncDirDisable -> "disable"

{-------------------------------------------------------------------------------
  Clang arguments
-------------------------------------------------------------------------------}

parseClangArgsConfig :: Parser (ClangArgsConfig FilePath)
parseClangArgsConfig = do
    -- ApplicativeDo to be able to reorder arguments for --help, and to use
    -- record construction (i.e., to avoid bool or string/path blindness)
    -- instead of positional one.
    enableBlocks     <- parseEnableBlocks
    builtinIncDir    <- parseBuiltinIncDirConfig
    extraIncludeDirs <- many parseIncludeDir
    argsBefore       <- many parseClangOptionBefore
    argsInner        <- many parseClangOptionInner
    argsAfter        <- many parseClangOptionAfter
    pure $ ClangArgsConfig{
        enableBlocks     = enableBlocks
      , builtinIncDir    = builtinIncDir
      , extraIncludeDirs = extraIncludeDirs
      , argsBefore       = argsBefore
      , argsInner        = argsInner
      , argsAfter        = argsAfter
      }

parseEnableBlocks :: Parser Bool
parseEnableBlocks = switch $ mconcat [
      long "fblocks"
    , help "Enable the 'blocks' language feature"
    ]

parseIncludeDir :: Parser FilePath
parseIncludeDir = strOption $ mconcat [
      short 'I'
    , metavar "DIR"
    , help "Include search path directory"
    ]

parseClangOptionBefore :: Parser String
parseClangOptionBefore = strOption $ mconcat [
      long "clang-option-before"
    , metavar "OPTION"
    , help "Prepend option when calling Clang; see also --clang-option"
    ]

parseClangOptionInner :: Parser String
parseClangOptionInner = strOption $ mconcat [
      long "clang-option"
    , metavar "OPTION"
    , help "Pass option to Clang"
    ]

parseClangOptionAfter :: Parser String
parseClangOptionAfter = strOption $ mconcat [
      long "clang-option-after"
    , metavar "OPTION"
    , help "Append option when calling Clang; see also --clang-option"
    ]

{-------------------------------------------------------------------------------
  Predicates and slicing
-------------------------------------------------------------------------------}

parseSelectionPredicate :: Parser (Boolean SelectionPredicate)
parseSelectionPredicate = fmap aux . many . asum $ [
      flag' (Right BTrue) $ mconcat [
          long "select-all"
        , help "Select all declarations"
        ]
    , flag' (Right (BIf (SelectHeader FromMainHeaders))) $ mconcat [
          long "select-from-main-headers"
        , help "Select declarations in main headers (default)"
        ]
    , flag' (Right (BIf (SelectHeader FromMainHeaderDirs))) $ mconcat [
          long "select-from-main-header-dirs"
        , help "Select declarations in main header directories"
        ]
    , flag' (Right (BIf (SelectHeader FromAllHeaders))) $ mconcat [
          long "select-from-all-headers"
        , help $ concat [
              "Select declarations in any header"
            , " (unlike --select-all, not root directives or -D options)"
            ]
        ]
    , fmap (Right . BIf . SelectHeader . HeaderPathMatches) $ strOption $ mconcat [
          long "select-by-header-path"
        , metavar "PCRE"
        , help "Select declarations in headers with paths that match PCRE"
        ]
    , fmap (Left . BIf . SelectHeader . HeaderPathMatches) $ strOption $ mconcat [
          long "select-except-by-header-path"
        , metavar "PCRE"
        , help $ concat [
              "Select except declarations in headers with paths that match"
            , " PCRE"
            ]
        ]
    , fmap (Right . BIf . SelectDecl . DeclNameMatches) $ strOption $ mconcat [
          long "select-by-decl-name"
        , metavar "PCRE"
        , help "Select declarations with C names that match PCRE"
        ]
    , fmap (Left . BIf . SelectDecl . DeclNameMatches) $ strOption $ mconcat [
          long "select-except-by-decl-name"
        , metavar "PCRE"
        , help "Select except (i.e., do not select) declarations with C names that match PCRE"
        ]
    , flag' (Left $ BIf $ SelectDecl DeclDeprecated) $ mconcat [
          long "select-except-deprecated"
        , help "Select except (i.e., do not select) deprecated declarations"
        ]
    ]
  where
    aux ::
         [Either (Boolean SelectionPredicate) (Boolean SelectionPredicate)]
      -> (Boolean SelectionPredicate)
    aux = uncurry mergeBooleans . fmap applyDefault . partitionEithers

    applyDefault :: Default a => [a] -> [a]
    applyDefault = \case
      [] -> [def]
      ps -> ps

parseProgramSlicing :: Parser ProgramSlicing
parseProgramSlicing =
    flag DisableProgramSlicing EnableProgramSlicing $ mconcat [
        long "enable-program-slicing"
      , help $ concat [
            "Enable program slicing:"
          , " Select declarations using the selection predicate,"
          , " and also select their transitive dependencies;"
          , " program slicing can cause declarations to be included"
          , " even if they are explicitly deselected by a selection predicate"
          ]
      ]

{-------------------------------------------------------------------------------
  Macros
-------------------------------------------------------------------------------}

parseEmptyMacros :: Parser EmptyMacros
parseEmptyMacros =
    flag DoNotParseEmptyMacros ParseEmptyMacros $ mconcat [
        long "parse-empty-macros"
      , help $ concat [
            "Parse macros with an empty replacement list (e.g. '#define FOO');"
          , " by default, empty macros are not parsed"
          ]
      ]

{-------------------------------------------------------------------------------
  Translation options
-------------------------------------------------------------------------------}

parseUniqueId :: Parser UniqueId
parseUniqueId = fmap UniqueId . strOption $ mconcat [
      long "unique-id"
    , metavar "ID"
    , value ""
    , help $ concat [
          "Use unique ID to discriminate global C identifiers"
        , " (default: empty string)"
        ]
    ]

{-------------------------------------------------------------------------------
  Module option
-------------------------------------------------------------------------------}


parseFieldNamingStrategy :: Parser FieldNamingStrategy
parseFieldNamingStrategy =
    flag AddFieldPrefixes OmitFieldPrefixes $ mconcat [
        long "omit-field-prefixes"
      , help $ concat [
            "Use unprefixed field names (e.g. 'x' instead of 'structName_x'). "
          , "All newtype unwrap functions are called 'unwrap'. "
          , "Requires 'DuplicateRecordFields' extension."
          ]
      ]

parseQualifiedStyle :: Parser QualifiedStyle
parseQualifiedStyle =
    flag PreQualified PostQualified $ mconcat [
        long "post-qualified-imports"
      , help $ concat [
            "Use post-qualified imports (e.g. 'import Data.Proxy qualified')"
          , " instead of pre-qualified imports."
          , " Adds 'ImportQualifiedPost' extension."
          ]
      ]

parseBaseModuleName :: Parser BaseModuleName
parseBaseModuleName = strOption $ mconcat [
      long "module"
    , metavar "NAME"
    , showDefault
    , value def
    , help "Base name of the generated Haskell modules"
    ]

{-------------------------------------------------------------------------------
  Output options
-------------------------------------------------------------------------------}

parseHsOutputDir :: Parser FilePath
parseHsOutputDir = strOption $ mconcat [
      long "hs-output-dir"
    , metavar "PATH"
    , help "Output directory of generated Haskell modules"
    ]

parseDirPolicy :: Parser DirPolicy
parseDirPolicy = flag DoNotCreateOutputDirs CreateOutputDirs $ mconcat [
      long "create-output-dirs"
    , help "Create the specified output directories if they do not exist"
    ]

parseFilePolicy :: Parser FilePolicy
parseFilePolicy = flag DoNotOverwriteFiles AllowFileOverwrite $ mconcat [
      long "overwrite-files"
    , help "Allow overwriting existing output files"
    ]

parseGenBindingSpec :: Parser FilePath
parseGenBindingSpec = strOption $ mconcat [
      long "gen-binding-spec"
    , metavar "PATH"
    , help "Binding specification to generate"
    ]

parseGenTestsOutput :: Parser FilePath
parseGenTestsOutput = strOption $ mconcat [
      short 'o'
    , long "output"
    , metavar "PATH"
    , showDefault
    , value "test-hs-bindgen"
    , help "Output directory for the test suite"
    ]

{-------------------------------------------------------------------------------
  Input arguments
-------------------------------------------------------------------------------}

-- | Parse one or more input root directives
--
-- @#include@s and @#define@s form a single ordered list: a @#define@ only
-- affects the headers listed after it.
--
-- We check that at least one directive is of type @#include@ when the root
-- header is constructed ('HsBindgen.Frontend.RootHeader.fromRootDirectives').
-- This ensures that CLI and TH mode have the same behavior. Also,
-- @optparse-applicative@ can only reject the parsed list with monadic
-- sequencing, but its usage renderer does not distinguish monadic sequencing
-- from repetition, so every bind picks up the @multiSuffix@ marker.
parseInputs :: Parser [C.UncheckedRootDirective]
parseInputs = some . asum $ [
      C.DirectiveHashInclude <$> parseHashInclude
    , C.DirectiveHashDefine  <$> parseHashDefine
    ]
  where
    parseHashInclude :: Parser C.UncheckedHashIncludeArg
    parseHashInclude = strArgument $ mconcat [
        metavar "HEADER"
      , help "Input C header(s), relative to an include path directory"
      ]

    parseHashDefine :: Parser C.HashDefine
    parseHashDefine =
        C.HashDefine
          -- The metavar covers both arguments, so that @--help@ shows the
          -- @#define@ shape; the value argument itself renders nothing.
          <$> strOption   (long "hash-define" <> metavar "NAME VALUE" <> help hashDefineHelp)
          <*> strArgument mempty

    hashDefineHelp :: String
    hashDefineHelp = unwords [
        "Emit '#define NAME VALUE' before the following headers."
      , "See 'Root directives' in the manual"
      , "(manual/low-level/usage/c-stages.md)."
      ]

{-------------------------------------------------------------------------------
  Auxiliary optparse-applicative functions
-------------------------------------------------------------------------------}

-- | Command with @-h@ and @--help@
cmd ::
     String     -- ^ Name
  -> (a -> c)   -- ^ Constructor
  -> Parser a   -- ^ Options parser
  -> InfoMod c  -- ^ Information
  -> Mod CommandFields c
cmd name mk parser = command name . info (helper <*> (mk <$> parser))

-- | Command with @--help@ (but no @-h@)
cmd_ ::
     String     -- ^ Name
  -> (a -> c)   -- ^ Constructor
  -> Parser a   -- ^ Options parser
  -> InfoMod c  -- ^ Information
  -> Mod CommandFields c
cmd_ name mk parser = command name . info (helper' <*> (mk <$> parser))
  where
    helper' :: Parser (a -> a)
    helper' = helperWith $ mconcat [
        long "help"
      , help "Show this help text"
      ]