Parser.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}

module Proto3.Suite.Haskell.Parser
  ( Logger
  , initLogger
  , parseModule
  , renderSDoc
  ) where

import qualified GHC.Data.EnumSet as EnumSet
import GHC.Data.StringBuffer (StringBuffer)
import GHC.Driver.Session (languageExtensions)
import qualified GHC.Hs
import qualified GHC.Parser
import GHC.Parser.Lexer (P(..), PState, ParseResult(..))
import GHC.Types.SrcLoc (Located, RealSrcLoc)
import GHC.Utils.Outputable (SDoc)

#if MIN_VERSION_ghc_lib_parser(9,8,0)
import qualified GHC.Driver.Errors (printMessages)
import GHC.Parser.Errors.Types (PsMessage)
import GHC.Parser.Lexer (getPsMessages, initParserState, mkParserOpts)
import GHC.Types.Error (Messages, NoDiagnosticOpts(..), partitionMessages, unionMessages)
import GHC.Utils.Error (DiagOpts, emptyDiagOpts)
import GHC.Utils.Logger (Logger, initLogger)
import GHC.Utils.Outputable (defaultSDocContext, renderWithContext)
#elif MIN_VERSION_ghc_lib_parser(9,6,0)
import qualified GHC.Driver.Errors (printMessages)
import GHC.Parser.Errors.Types (PsMessage)
import GHC.Parser.Lexer (getPsMessages, initParserState, mkParserOpts)
import GHC.Types.Error (Messages, NoDiagnosticOpts(..), partitionMessages, unionMessages)
import GHC.Utils.Error (DiagOpts(..))
import GHC.Utils.Logger (Logger, initLogger)
import GHC.Utils.Outputable (defaultSDocContext, renderWithContext)
#elif MIN_VERSION_ghc_lib_parser(9,4,0)
import qualified GHC.Driver.Errors (printMessages)
import GHC.Parser.Errors.Types (PsMessage)
import GHC.Parser.Lexer (getPsMessages, initParserState, mkParserOpts)
import GHC.Types.Error (Messages, partitionMessages, unionMessages)
import GHC.Utils.Error (DiagOpts(..))
import GHC.Utils.Logger (Logger, initLogger)
import GHC.Utils.Outputable (defaultSDocContext, renderWithContext)
#else
import Control.Arrow ((***))
import Data.Foldable (traverse_)
import GHC.ByteOrder (targetByteOrder)
import GHC.Data.Bag (Bag)
import GHC.Driver.Session
         (DynFlags(..), FileSettings(..), GhcNameVersion(..),
          LlvmConfig(..), Settings(..), defaultDynFlags)
import GHC.Parser.Errors.Ppr (pprError, pprWarning)
import GHC.Parser.Lexer (getMessages, initParserState, mkParserOpts)
import GHC.Platform (ArchOS(..))
import GHC.Settings (Platform(..), PlatformMisc(..), ToolSettings(..))
import GHC.Types.Error (DecoratedSDoc, MsgEnvelope(..), renderDiagnostic)
import GHC.Utils.Error (formatBulleted, sortMsgBag)
import GHC.Utils.Fingerprint (fingerprint0)
import GHC.Utils.Logger (Logger, initLogger, putLogMsg)
import GHC.Utils.Outputable (defaultSDocContext, mkErrStyle, renderWithContext, withPprStyle)
#endif

-- | Parses the module with the specified location and content,
-- returning 'Nothing' on parse failure.  Errors and warnings
-- are sent to the given 'Logger', except on GHC 9.0, which
-- would require a 'DynFlags' in order to report messages.
-- Unfortunately, creating a 'DynFlags' would require a directory
-- containing a GHC installation; we do not wish to require that.
parseModule ::
  Logger ->
  RealSrcLoc ->
  StringBuffer ->
  IO (Maybe (Located (GHC.Hs.HsModule
#if MIN_VERSION_ghc_lib_parser(9,6,0)
                                      GHC.Hs.GhcPs
#endif
                     )))
parseModule logger location input = do
    case unP GHC.Parser.parseModule initialState of
      POk _finalState m -> do
        printWarningsAndErrors logger diagOpts _finalState
        pure (Just m)
      PFailed _finalState -> do
        printWarningsAndErrors logger diagOpts _finalState
        pure Nothing
  where
    exts = EnumSet.fromList (languageExtensions Nothing)
#if MIN_VERSION_ghc_lib_parser(9,4,0)
    diagOpts =
#if MIN_VERSION_ghc_lib_parser(9,8,0)
      emptyDiagOpts
#else
      DiagOpts
        { diag_warning_flags = mempty
        , diag_fatal_warning_flags = mempty
        , diag_warn_is_error = False
        , diag_reverse_errors = False
        , diag_max_errors = Nothing
        , diag_ppr_ctx = defaultSDocContext
        }
#endif
    parserOpts = mkParserOpts exts diagOpts [] False True True True
    initialState = initParserState parserOpts input location
#else
    diagOpts = DiagOpts
    parserOpts = mkParserOpts EnumSet.empty exts False True True True
    initialState = initParserState parserOpts input location
#endif

printWarningsAndErrors :: Logger -> DiagOpts -> PState -> IO ()
printWarningsAndErrors logger diagOpts state = do
#if MIN_VERSION_ghc_lib_parser(9,4,0)
  let (ws, es) = getPsMessages state
  let (warnings, unionMessages es -> errors) = partitionMessages ws
#else
  let (warnings, errors) = (fmap pprWarning *** fmap pprError) (getMessages state)
#endif
  printMessages logger diagOpts warnings
  printMessages logger diagOpts errors

#if MIN_VERSION_ghc_lib_parser(9,6,0)

printMessages :: Logger -> DiagOpts -> Messages PsMessage -> IO ()
printMessages logger = GHC.Driver.Errors.printMessages logger NoDiagnosticOpts

#elif MIN_VERSION_ghc_lib_parser(9,4,0)

printMessages :: Logger -> DiagOpts -> Messages PsMessage -> IO ()
printMessages = GHC.Driver.Errors.printMessages

#else

printMessages :: Logger -> DiagOpts -> Bag (MsgEnvelope DecoratedSDoc) -> IO ()
printMessages logger _ = traverse_ report . sortMsgBag Nothing
  where
    report MsgEnvelope
             { errMsgContext = errCtxt
             , errMsgDiagnostic = diagnostic
             , errMsgReason = reason
             , errMsgSeverity = severity
             , errMsgSpan = sp } =
        putLogMsg logger renderingDynFlags reason severity sp $
          withPprStyle (mkErrStyle errCtxt) $
            formatBulleted defaultSDocContext (renderDiagnostic diagnostic)

#endif

renderSDoc :: SDoc -> String
renderSDoc = renderWithContext defaultSDocContext

#if !MIN_VERSION_ghc_lib_parser(9,4,0)

data DiagOpts = DiagOpts

-- | 'DynFlags' suitable only for rendering
-- Haskell source and diagnostic messages.
--
-- NOTE: For use with GHC 9.0 only.  These flags are rather questionable
-- all of the tools direction information consists of placeholders so
-- that compile-proto-file does not require an actual GHC installation.
renderingDynFlags :: DynFlags
renderingDynFlags = defaultDynFlags placeholderSettings placeholderLlvmConfig
  where
    archUnknown = read "ArchUnknown"
    osUnknown = read "OSUnknown"
    placeholderSettings = Settings
      { sGhcNameVersion = GhcNameVersion "compile-proto-file" "v?"
      , sFileSettings = FileSettings
        { fileSettings_ghcUsagePath = mempty
        , fileSettings_ghciUsagePath = mempty
        , fileSettings_toolDir = Nothing
        , fileSettings_topDir = mempty
        , fileSettings_tmpDir = mempty
        , fileSettings_globalPackageDatabase = mempty
        }
      , sTargetPlatform = Platform
        { platformArchOS = ArchOS archUnknown osUnknown
        , platformWordSize = read "8"
        , platformByteOrder = targetByteOrder
        , platformUnregisterised = True
        , platformHasGnuNonexecStack = False
        , platformHasIdentDirective = False
        , platformHasSubsectionsViaSymbols = False
        , platformIsCrossCompiling = True
        , platformLeadingUnderscore = True
        , platformTablesNextToCode = False
        , platform_constants = Nothing
        }
      , sToolSettings = ToolSettings
        { toolSettings_ldSupportsCompactUnwind = False
        , toolSettings_ldSupportsBuildId = False
        , toolSettings_ldSupportsFilelist = False
        , toolSettings_ldIsGnuLd = False
        , toolSettings_ccSupportsNoPie = False
        , toolSettings_pgm_L = mempty
        , toolSettings_pgm_P = mempty
        , toolSettings_pgm_F = mempty
        , toolSettings_pgm_c = mempty
        , toolSettings_pgm_a = mempty
        , toolSettings_pgm_l = mempty
        , toolSettings_pgm_lm = mempty
        , toolSettings_pgm_dll = mempty
        , toolSettings_pgm_T = mempty
        , toolSettings_pgm_windres = mempty
        , toolSettings_pgm_libtool = mempty
        , toolSettings_pgm_ar = mempty
        , toolSettings_pgm_otool = mempty
        , toolSettings_pgm_install_name_tool = mempty
        , toolSettings_pgm_ranlib = mempty
        , toolSettings_pgm_lo = mempty
        , toolSettings_pgm_lc = mempty
        , toolSettings_pgm_lcc = mempty
        , toolSettings_pgm_i = mempty
        , toolSettings_opt_L = mempty
        , toolSettings_opt_P = mempty
        , toolSettings_opt_P_fingerprint = fingerprint0
        , toolSettings_opt_F = mempty
        , toolSettings_opt_c = mempty
        , toolSettings_opt_cxx = mempty
        , toolSettings_opt_a = mempty
        , toolSettings_opt_l = mempty
        , toolSettings_opt_lm = mempty
        , toolSettings_opt_windres = mempty
        , toolSettings_opt_lo = mempty
        , toolSettings_opt_lc = mempty
        , toolSettings_opt_lcc = mempty
        , toolSettings_opt_i = mempty
        , toolSettings_extraGccViaCFlags = mempty
        }
      , sPlatformMisc = PlatformMisc
        { platformMisc_targetPlatformString = mempty
        , platformMisc_ghcWithInterpreter = False
        , platformMisc_ghcWithSMP = False
        , platformMisc_ghcRTSWays = mempty
        , platformMisc_libFFI = False
        , platformMisc_ghcRtsWithLibdw = False
        , platformMisc_llvmTarget = mempty
        }
      , sRawSettings = mempty
      }

    placeholderLlvmConfig = LlvmConfig
      { llvmTargets = mempty
      , llvmPasses = mempty
      }

#endif