Literate.hs

{-# LANGUAGE ApplicativeDo #-}

-- | @hs-bindgen-cli tool-support literate@ command
--
-- Intended for qualified import.
--
-- > import HsBindgen.Cli.ToolSupport.Literate qualified as Literate
module HsBindgen.Cli.ToolSupport.Literate (
    -- * CLI help
    info
    -- * Options (provided by @cabal-install@ on the command line)
  , Opts(..)
  , parseOpts
    -- * Execution
  , exec
  ) where

import Control.Exception (throwIO)
import Data.List.NonEmpty (NonEmpty (..))
import GHC.Exception (Exception (..))
import Options.Applicative hiding (info)
import Options.Applicative qualified as O
import Text.Read (readMaybe)

import HsBindgen
import HsBindgen.App
import HsBindgen.App.Output (OutputMode (..), OutputOptions,
                             SingleFileCategory (..), buildCategoryChoice,
                             parseOutputOptions)
import HsBindgen.ArtefactM
import HsBindgen.Config
import HsBindgen.Config.Internal (BindgenConfig)
import HsBindgen.Errors
import HsBindgen.IR.C qualified as C
import HsBindgen.Macro

{-------------------------------------------------------------------------------
  CLI help
-------------------------------------------------------------------------------}

info :: InfoMod a
info = progDesc $ mconcat [
      "Generate Haskell module from C header, acting as literate Haskell"
    , " preprocessor"
    ]

{-------------------------------------------------------------------------------
  Options (provided by @cabal-install@ on the command line)
-------------------------------------------------------------------------------}

-- | Command line options when the literate preprocessor is invoked
--
-- NOTE: Most of the /actual/ @hs-bindgen-cli@ arguments come from parsing the
-- /contents/ of the file we are processing.
data Opts = Opts {
      input  :: FilePath
    , output :: FilePath
    }
  deriving (Show, Eq)

parseOpts :: Parser Opts
parseOpts = do
    -- When @cabal-install@ calls GHC and the preprocessor, it passes some
    -- standard flags, which we do not (all) use.  In particular, it passes
    -- @-hide-all-packages@.
    _ <- strOption @String $ mconcat [
             short 'h'
           , metavar "IGNORED"
           , help "Ignore some preprocessor options provided by cabal-install"
           ]

    input  <- strArgument $ metavar "IN"
    output <- strArgument $ metavar "OUT"

    return Opts{
        input  = input
      , output = output
      }

{-------------------------------------------------------------------------------
  Options (provided at the top of literate Haskell files)
-------------------------------------------------------------------------------}

data Lit = Lit {
      globalOpts     :: GlobalOpts
    , config         :: Config
    , uniqueId       :: UniqueId
    , baseModuleName :: BaseModuleName
    , qualifiedStyle :: QualifiedStyle
    , outputOptions  :: OutputOptions
    , inputs         :: [C.UncheckedRootDirective]
    }

parseLit :: Parser Lit
parseLit = Lit
  <$> parseGlobalOpts
  <*> parseConfig
  <*> parseUniqueId
  <*> parseBaseModuleName
  <*> parseQualifiedStyle
  <*> parseOutputOptions (SingleFile (SingleFileSafe "" :| []))
  <*> parseInputs

{-------------------------------------------------------------------------------
  Execution
-------------------------------------------------------------------------------}

exec :: Opts -> IO ()
exec opts = do
    args <- maybe (throwIO' "cannot parse literate file") return . readMaybe
      =<< readFile opts.input
    lit <- handleParseResult $ pureParseLit args

    let bindgenConfig :: BindgenConfig
        bindgenConfig =
          toBindgenConfig
            lit.config
            lit.uniqueId
            lit.baseModuleName
            (buildCategoryChoice lit.outputOptions)

        -- It is understood that literate mode will overwrite existing files
        -- (generated files will anyway live in @dist-newstyle@ or similar)
        filePolicy :: FilePolicy
        filePolicy = AllowFileOverwrite

        mrc :: ModuleRenderConfig
        mrc = ModuleRenderConfig {
            qualifiedStyle = lit.qualifiedStyle
          }

        artefact :: Artefact CExpr ()
        artefact = writeBindings mrc filePolicy DoNotCreateOutputDirs opts.output

    hsBindgen
      lit.globalOpts.unsafe
      lit.globalOpts.safe
      bindgenConfig
      lit.inputs
      artefact
  where
    throwIO' :: String -> IO a
    throwIO' = throwIO . LiterateFileException opts.input

    pureParseLit :: [String] -> ParserResult Lit
    pureParseLit =
        execParserPure (prefs subparserInline) (O.info parseLit mempty)

{-------------------------------------------------------------------------------
  Exception
-------------------------------------------------------------------------------}

data LiterateFileException = LiterateFileException FilePath String
  deriving Show

instance Exception LiterateFileException where
    toException = hsBindgenExceptionToException
    fromException = hsBindgenExceptionFromException
    displayException (LiterateFileException path err) =
      "error loading " ++ path ++ ": " ++ err