{-# LANGUAGE CPP #-}
-- |
-- Description: provides a wrapper around the 'ghc-exactprint' parser

module Smuggler2.Parser
  ( runParser,
  )
where

import Control.Monad.IO.Class (MonadIO (liftIO))
import DynFlags (DynFlags, GeneralFlag (Opt_KeepRawTokenStream), gopt_set)
import GHC (ParsedSource)
import Language.Haskell.GHC.ExactPrint (Anns)
import Language.Haskell.GHC.ExactPrint.Parsers (parseModuleFromStringInternal)
#if MIN_VERSION_GLASGOW_HASKELL(8,10,1,0)
import ErrUtils (fatalErrorMsg, printBagOfErrors )
import Outputable (text)
#else
import ErrUtils (fatalErrorMsg)
import Outputable (ppr, showSDoc, text)
#endif
import TcRnTypes (RnM)

-- | Wrapper around the 'ghc-exactprint' parser.  Prints diagnostics for failed parses
-- (which should never happen). We need to use
-- 'Language.Haskell.GHC.ExactPrint.parseModuleFromStringInternal'
-- because 'Language.Haskell.GHC.ExactPrintparseModuleFromString'
-- doesn't pick up the correct 'DynFlags' in some cases.
runParser ::
  DynFlags -> FilePath -> String -> RnM (Either () (Anns, ParsedSource))
runParser :: DynFlags
-> FilePath -> FilePath -> RnM (Either () (Anns, ParsedSource))
runParser DynFlags
dflags FilePath
fileName FilePath
fileContents = do
  -- Without the following, comments are stripped (see #10942)
  -- It would be more efficient, but less visible, to apply this tweak at the
  -- outset, in the main plugin function, but keep it here for visibility
  -- See also https://gitlab.haskell.org/ghc/ghc/-/wikis/api-annotations, which
  -- notes that the flags are returned as annotations by the
  -- @Opt_KeepRawTokenStream@ flag.
  let dflags' :: DynFlags
dflags' = DynFlags
dflags DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
Opt_KeepRawTokenStream

  case Parser ParsedSource
parseModuleFromStringInternal DynFlags
dflags' FilePath
fileName FilePath
fileContents of
    Left ErrorMessages
msg -> IO (Either () (Anns, ParsedSource))
-> RnM (Either () (Anns, ParsedSource))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either () (Anns, ParsedSource))
 -> RnM (Either () (Anns, ParsedSource)))
-> IO (Either () (Anns, ParsedSource))
-> RnM (Either () (Anns, ParsedSource))
forall a b. (a -> b) -> a -> b
$ do
#if MIN_VERSION_GLASGOW_HASKELL(8,10,1,0)
      DynFlags -> MsgDoc -> IO ()
fatalErrorMsg DynFlags
dflags (FilePath -> MsgDoc
text FilePath
"smuggler2 parse failure:")
      DynFlags -> ErrorMessages -> IO ()
printBagOfErrors DynFlags
dflags ErrorMessages
msg
#else
      fatalErrorMsg dflags (text $ "smuggler2 parse failure: " ++
                            showSDoc dflags (ppr $ fst msg) ++ ": " ++ snd msg)
#endif
      Either () (Anns, ParsedSource)
-> IO (Either () (Anns, ParsedSource))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either () (Anns, ParsedSource)
 -> IO (Either () (Anns, ParsedSource)))
-> Either () (Anns, ParsedSource)
-> IO (Either () (Anns, ParsedSource))
forall a b. (a -> b) -> a -> b
$ () -> Either () (Anns, ParsedSource)
forall a b. a -> Either a b
Left ()
    Right (Anns, ParsedSource)
x -> Either () (Anns, ParsedSource)
-> RnM (Either () (Anns, ParsedSource))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either () (Anns, ParsedSource)
 -> RnM (Either () (Anns, ParsedSource)))
-> Either () (Anns, ParsedSource)
-> RnM (Either () (Anns, ParsedSource))
forall a b. (a -> b) -> a -> b
$ (Anns, ParsedSource) -> Either () (Anns, ParsedSource)
forall a b. b -> Either a b
Right (Anns, ParsedSource)
x