{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
-----------------------------------------------------------------------------
-- |
-- This module rexposes wrapped parsers from the GHC API. Along with
-- returning the parse result, the corresponding annotations are also
-- returned such that it is then easy to modify the annotations and print
-- the result.
--
----------------------------------------------------------------------------
module Language.Haskell.GHC.ExactPrint.Parsers (
        -- * Utility
          Parser
        , ParseResult
        , withDynFlags
        , CppOptions(..)
        , defaultCppOptions

        -- * Module Parsers
        , parseModule
        , parseModuleFromString
        , parseModuleWithOptions
        , parseModuleWithCpp

        -- * Basic Parsers
        , parseExpr
        , parseImport
        , parseType
        , parseDecl
        , parsePattern
        , parseStmt

        , parseWith

        -- * Internal

        , ghcWrapper

        , initDynFlags
        , initDynFlagsPure
        , parseModuleFromStringInternal
        , parseModuleApiAnnsWithCpp
        , parseModuleApiAnnsWithCppInternal
        , postParseTransform
        ) where

import Language.Haskell.GHC.ExactPrint.Annotate
import Language.Haskell.GHC.ExactPrint.Delta
import Language.Haskell.GHC.ExactPrint.Preprocess
import Language.Haskell.GHC.ExactPrint.Types

import Control.Exception (IOException, catch)
import Control.Monad.RWS
#if __GLASGOW_HASKELL__ >= 900
#elif __GLASGOW_HASKELL__ > 806
import Data.Data (Data)
#endif
import Data.Maybe (fromMaybe)


import GHC.Paths (libdir)

import System.Environment (lookupEnv)

import qualified GHC hiding (parseModule)
#if __GLASGOW_HASKELL__ >= 900
import qualified Control.Monad.IO.Class as GHC
import qualified GHC.Data.FastString    as GHC
import qualified GHC.Data.StringBuffer  as GHC
import qualified GHC.Driver.Session     as GHC
import qualified GHC.Parser             as GHC
import qualified GHC.Parser.Header      as GHC
import qualified GHC.Parser.Lexer       as GHC
import qualified GHC.Parser.PostProcess as GHC
import qualified GHC.Types.SrcLoc       as GHC
import qualified GHC.Utils.Error        as GHC
#else
-- import qualified ApiAnnotation as GHC
import qualified DynFlags      as GHC
#if __GLASGOW_HASKELL__ > 808
import qualified ErrUtils      as GHC
#endif
import qualified FastString    as GHC
-- import qualified GHC           as GHC hiding (parseModule)
import qualified HeaderInfo    as GHC
import qualified Lexer         as GHC
import qualified MonadUtils    as GHC
#if __GLASGOW_HASKELL__ <= 808
import qualified Outputable    as GHC
#endif
import qualified Parser        as GHC
#if __GLASGOW_HASKELL__ > 808
import qualified RdrHsSyn      as GHC
#endif
import qualified SrcLoc        as GHC
import qualified StringBuffer  as GHC
#endif

#if __GLASGOW_HASKELL__ <= 710
import qualified OrdList as OL
#else
import qualified GHC.LanguageExtensions as LangExt
#endif

import qualified Data.Map as Map


{-# ANN module "HLint: ignore Eta reduce" #-}
{-# ANN module "HLint: ignore Redundant do" #-}
{-# ANN module "HLint: ignore Reduce duplication" #-}
-- ---------------------------------------------------------------------

-- | Wrapper function which returns Annotations along with the parsed
-- element.
#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900)
parseWith :: (Data (GHC.SrcSpanLess w), Annotate w, GHC.HasSrcSpan w)
          => GHC.DynFlags
          -> FilePath
          -> GHC.P w
          -> String
          -> ParseResult w
#else
parseWith :: Annotate w
          => GHC.DynFlags
          -> FilePath
          -> GHC.P (GHC.Located w)
          -> String
          -> ParseResult (GHC.Located w)
#endif
parseWith :: forall w.
Annotate w =>
DynFlags
-> FilePath -> P (Located w) -> FilePath -> ParseResult (Located w)
parseWith DynFlags
dflags FilePath
fileName P (Located w)
parser FilePath
s =
  case P (Located w)
-> DynFlags -> FilePath -> FilePath -> ParseResult (Located w)
forall a. P a -> DynFlags -> FilePath -> FilePath -> ParseResult a
runParser P (Located w)
parser DynFlags
dflags FilePath
fileName FilePath
s of
#if __GLASGOW_HASKELL__ > 808
    GHC.PFailed PState
pst                       -> ErrorMessages -> ParseResult (Located w)
forall a b. a -> Either a b
Left (PState -> DynFlags -> ErrorMessages
GHC.getErrorMessages PState
pst DynFlags
dflags)
#elif __GLASGOW_HASKELL__ >= 804
    GHC.PFailed _ ss m                    -> Left (ss, GHC.showSDoc dflags m)
#else
    GHC.PFailed ss m                    -> Left (ss, GHC.showSDoc dflags m)
#endif
    GHC.POk (PState -> ApiAnns
mkApiAnns -> ApiAnns
apianns) Located w
pmod -> (Anns, Located w) -> ParseResult (Located w)
forall a b. b -> Either a b
Right (Anns
as, Located w
pmod)
      where as :: Anns
as = Located w -> ApiAnns -> Anns
forall ast. Annotate ast => Located ast -> ApiAnns -> Anns
relativiseApiAnns Located w
pmod ApiAnns
apianns


#if __GLASGOW_HASKELL__ > 808
parseWithECP :: (GHC.DisambECP w, Annotate (GHC.Body w GHC.GhcPs))
          => GHC.DynFlags
          -> FilePath
          -> GHC.P GHC.ECP
          -> String
          -> ParseResult (GHC.Located w)
parseWithECP :: forall w.
(DisambECP w, Annotate (Body w GhcPs)) =>
DynFlags
-> FilePath -> P ECP -> FilePath -> ParseResult (Located w)
parseWithECP DynFlags
dflags FilePath
fileName P ECP
parser FilePath
s =
    -- case runParser ff dflags fileName s of
    case P (Located w)
-> DynFlags -> FilePath -> FilePath -> ParseResult (Located w)
forall a. P a -> DynFlags -> FilePath -> FilePath -> ParseResult a
runParser (P ECP
parser P ECP -> (ECP -> P (Located w)) -> P (Located w)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ECP
p -> ECP -> P (Located w)
forall b. DisambECP b => ECP -> P (Located b)
GHC.runECP_P ECP
p) DynFlags
dflags FilePath
fileName FilePath
s of
      GHC.PFailed PState
pst                      -> ErrorMessages -> ParseResult (Located w)
forall a b. a -> Either a b
Left (PState -> DynFlags -> ErrorMessages
GHC.getErrorMessages PState
pst DynFlags
dflags)
      GHC.POk (PState -> ApiAnns
mkApiAnns -> ApiAnns
apianns) Located w
pmod -> (Anns, Located w) -> ParseResult (Located w)
forall a b. b -> Either a b
Right (Anns
as, Located w
pmod)
        where as :: Anns
as = Located w -> ApiAnns -> Anns
forall ast. Annotate ast => Located ast -> ApiAnns -> Anns
relativiseApiAnns Located w
pmod ApiAnns
apianns
#endif

-- ---------------------------------------------------------------------

runParser :: GHC.P a -> GHC.DynFlags -> FilePath -> String -> GHC.ParseResult a
runParser :: forall a. P a -> DynFlags -> FilePath -> FilePath -> ParseResult a
runParser P a
parser DynFlags
flags FilePath
filename FilePath
str = P a -> PState -> ParseResult a
forall a. P a -> PState -> ParseResult a
GHC.unP P a
parser PState
parseState
    where
      location :: RealSrcLoc
location = FastString -> Int -> Int -> RealSrcLoc
GHC.mkRealSrcLoc (FilePath -> FastString
GHC.mkFastString FilePath
filename) Int
1 Int
1
      buffer :: StringBuffer
buffer = FilePath -> StringBuffer
GHC.stringToStringBuffer FilePath
str
      parseState :: PState
parseState = DynFlags -> StringBuffer -> RealSrcLoc -> PState
GHC.mkPState DynFlags
flags StringBuffer
buffer RealSrcLoc
location

-- ---------------------------------------------------------------------

-- | Provides a safe way to consume a properly initialised set of
-- 'DynFlags'.
--
-- @
-- myParser fname expr = withDynFlags (\\d -> parseExpr d fname expr)
-- @
withDynFlags :: (GHC.DynFlags -> a) -> IO a
withDynFlags :: forall a. (DynFlags -> a) -> IO a
withDynFlags DynFlags -> a
action = Ghc a -> IO a
forall a. Ghc a -> IO a
ghcWrapper (Ghc a -> IO a) -> Ghc a -> IO a
forall a b. (a -> b) -> a -> b
$ do
  DynFlags
dflags <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
  Ghc () -> Ghc ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Ghc () -> Ghc ()) -> Ghc () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Ghc ()
forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
GHC.setSessionDynFlags DynFlags
dflags
  a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> a
action DynFlags
dflags)

-- ---------------------------------------------------------------------

#if __GLASGOW_HASKELL__ >= 900
parseFile :: GHC.DynFlags -> FilePath -> String -> GHC.ParseResult (GHC.Located GHC.HsModule)
#else
parseFile :: GHC.DynFlags -> FilePath -> String -> GHC.ParseResult (GHC.Located (GHC.HsModule GhcPs))
#endif
parseFile :: DynFlags -> FilePath -> FilePath -> ParseResult (Located HsModule)
parseFile = P (Located HsModule)
-> DynFlags
-> FilePath
-> FilePath
-> ParseResult (Located HsModule)
forall a. P a -> DynFlags -> FilePath -> FilePath -> ParseResult a
runParser P (Located HsModule)
GHC.parseModule

-- ---------------------------------------------------------------------

#if __GLASGOW_HASKELL__ > 808
type ParseResult a = Either GHC.ErrorMessages (Anns, a)
#else
type ParseResult a = Either (GHC.SrcSpan, String) (Anns, a)
#endif

type Parser a = GHC.DynFlags -> FilePath -> String
                -> ParseResult a

parseExpr :: Parser (GHC.LHsExpr GhcPs)
#if __GLASGOW_HASKELL__ > 808
parseExpr :: Parser (LHsExpr GhcPs)
parseExpr DynFlags
df FilePath
fp = DynFlags
-> FilePath -> P ECP -> FilePath -> ParseResult (LHsExpr GhcPs)
forall w.
(DisambECP w, Annotate (Body w GhcPs)) =>
DynFlags
-> FilePath -> P ECP -> FilePath -> ParseResult (Located w)
parseWithECP DynFlags
df FilePath
fp P ECP
GHC.parseExpression
#else
parseExpr df fp = parseWith df fp GHC.parseExpression
#endif

parseImport :: Parser (GHC.LImportDecl GhcPs)
parseImport :: Parser (LImportDecl GhcPs)
parseImport DynFlags
df FilePath
fp = DynFlags
-> FilePath
-> P (LImportDecl GhcPs)
-> FilePath
-> ParseResult (LImportDecl GhcPs)
forall w.
Annotate w =>
DynFlags
-> FilePath -> P (Located w) -> FilePath -> ParseResult (Located w)
parseWith DynFlags
df FilePath
fp P (LImportDecl GhcPs)
GHC.parseImport

parseType :: Parser (GHC.LHsType GhcPs)
parseType :: Parser (LHsType GhcPs)
parseType DynFlags
df FilePath
fp = DynFlags
-> FilePath
-> P (LHsType GhcPs)
-> FilePath
-> ParseResult (LHsType GhcPs)
forall w.
Annotate w =>
DynFlags
-> FilePath -> P (Located w) -> FilePath -> ParseResult (Located w)
parseWith DynFlags
df FilePath
fp P (LHsType GhcPs)
GHC.parseType

-- safe, see D1007
parseDecl :: Parser (GHC.LHsDecl GhcPs)
#if __GLASGOW_HASKELL__ <= 710
parseDecl df fp = parseWith df fp (head . OL.fromOL <$> GHC.parseDeclaration)
#else
parseDecl :: Parser (LHsDecl GhcPs)
parseDecl DynFlags
df FilePath
fp = DynFlags
-> FilePath
-> P (LHsDecl GhcPs)
-> FilePath
-> ParseResult (LHsDecl GhcPs)
forall w.
Annotate w =>
DynFlags
-> FilePath -> P (Located w) -> FilePath -> ParseResult (Located w)
parseWith DynFlags
df FilePath
fp P (LHsDecl GhcPs)
GHC.parseDeclaration
#endif

parseStmt :: Parser (GHC.ExprLStmt GhcPs)
parseStmt :: Parser (ExprLStmt GhcPs)
parseStmt DynFlags
df FilePath
fp = DynFlags
-> FilePath
-> P (ExprLStmt GhcPs)
-> FilePath
-> ParseResult (ExprLStmt GhcPs)
forall w.
Annotate w =>
DynFlags
-> FilePath -> P (Located w) -> FilePath -> ParseResult (Located w)
parseWith DynFlags
df FilePath
fp P (ExprLStmt GhcPs)
GHC.parseStatement

parsePattern :: Parser (GHC.LPat GhcPs)
parsePattern :: Parser (LPat GhcPs)
parsePattern DynFlags
df FilePath
fp = DynFlags
-> FilePath
-> P (Located (Pat GhcPs))
-> FilePath
-> ParseResult (Located (Pat GhcPs))
forall w.
Annotate w =>
DynFlags
-> FilePath -> P (Located w) -> FilePath -> ParseResult (Located w)
parseWith DynFlags
df FilePath
fp P (Located (Pat GhcPs))
GHC.parsePattern

-- ---------------------------------------------------------------------
--

-- | This entry point will also work out which language extensions are
-- required and perform CPP processing if necessary.
--
-- @
-- parseModule = parseModuleWithCpp defaultCppOptions
-- @
--
-- Note: 'GHC.ParsedSource' is a synonym for 'GHC.Located' ('GHC.HsModule' 'GhcPs')
parseModule :: FilePath -> IO (ParseResult GHC.ParsedSource)
parseModule :: FilePath -> IO (ParseResult (Located HsModule))
parseModule = CppOptions
-> DeltaOptions -> FilePath -> IO (ParseResult (Located HsModule))
parseModuleWithCpp CppOptions
defaultCppOptions DeltaOptions
normalLayout


-- | This entry point will work out which language extensions are
-- required but will _not_ perform CPP processing.
-- In contrast to `parseModoule` the input source is read from the provided
-- string; the `FilePath` parameter solely exists to provide a name
-- in source location annotations.
parseModuleFromString
  :: FilePath
  -> String
  -> IO (ParseResult GHC.ParsedSource)
parseModuleFromString :: FilePath -> FilePath -> IO (ParseResult (Located HsModule))
parseModuleFromString FilePath
fp FilePath
s = Ghc (ParseResult (Located HsModule))
-> IO (ParseResult (Located HsModule))
forall a. Ghc a -> IO a
ghcWrapper (Ghc (ParseResult (Located HsModule))
 -> IO (ParseResult (Located HsModule)))
-> Ghc (ParseResult (Located HsModule))
-> IO (ParseResult (Located HsModule))
forall a b. (a -> b) -> a -> b
$ do
  DynFlags
dflags <- FilePath -> FilePath -> Ghc DynFlags
forall (m :: * -> *).
GhcMonad m =>
FilePath -> FilePath -> m DynFlags
initDynFlagsPure FilePath
fp FilePath
s
  ParseResult (Located HsModule)
-> Ghc (ParseResult (Located HsModule))
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseResult (Located HsModule)
 -> Ghc (ParseResult (Located HsModule)))
-> ParseResult (Located HsModule)
-> Ghc (ParseResult (Located HsModule))
forall a b. (a -> b) -> a -> b
$ Parser (Located HsModule)
parseModuleFromStringInternal DynFlags
dflags FilePath
fp FilePath
s

-- | Internal part of 'parseModuleFromString'.
parseModuleFromStringInternal :: Parser GHC.ParsedSource
parseModuleFromStringInternal :: Parser (Located HsModule)
parseModuleFromStringInternal DynFlags
dflags FilePath
fileName FilePath
str =
  let (FilePath
str1, [Comment]
lp) = FilePath -> (FilePath, [Comment])
stripLinePragmas FilePath
str
      res :: Either
  ErrorMessages (ApiAnns, [Comment], DynFlags, Located HsModule)
res        = case P (Located HsModule)
-> DynFlags
-> FilePath
-> FilePath
-> ParseResult (Located HsModule)
forall a. P a -> DynFlags -> FilePath -> FilePath -> ParseResult a
runParser P (Located HsModule)
GHC.parseModule DynFlags
dflags FilePath
fileName FilePath
str1 of
#if __GLASGOW_HASKELL__ > 808
        GHC.PFailed PState
pst     -> ErrorMessages
-> Either
     ErrorMessages (ApiAnns, [Comment], DynFlags, Located HsModule)
forall a b. a -> Either a b
Left (PState -> DynFlags -> ErrorMessages
GHC.getErrorMessages PState
pst DynFlags
dflags)
#elif __GLASGOW_HASKELL__ >= 804
        GHC.PFailed _ ss m  -> Left (ss, GHC.showSDoc dflags m)
#else
        GHC.PFailed ss m    -> Left (ss, GHC.showSDoc dflags m)
#endif
        GHC.POk     PState
x  Located HsModule
pmod -> (ApiAnns, [Comment], DynFlags, Located HsModule)
-> Either
     ErrorMessages (ApiAnns, [Comment], DynFlags, Located HsModule)
forall a b. b -> Either a b
Right (PState -> ApiAnns
mkApiAnns PState
x, [Comment]
lp, DynFlags
dflags, Located HsModule
pmod)
  in  Either
  ErrorMessages (ApiAnns, [Comment], DynFlags, Located HsModule)
-> DeltaOptions -> ParseResult (Located HsModule)
forall a.
Either a (ApiAnns, [Comment], DynFlags, Located HsModule)
-> DeltaOptions -> Either a (Anns, Located HsModule)
postParseTransform Either
  ErrorMessages (ApiAnns, [Comment], DynFlags, Located HsModule)
res DeltaOptions
normalLayout

parseModuleWithOptions :: DeltaOptions
                       -> FilePath
                       -> IO (ParseResult GHC.ParsedSource)
parseModuleWithOptions :: DeltaOptions -> FilePath -> IO (ParseResult (Located HsModule))
parseModuleWithOptions DeltaOptions
opts FilePath
fp =
  CppOptions
-> DeltaOptions -> FilePath -> IO (ParseResult (Located HsModule))
parseModuleWithCpp CppOptions
defaultCppOptions DeltaOptions
opts FilePath
fp


-- | Parse a module with specific instructions for the C pre-processor.
parseModuleWithCpp
  :: CppOptions
  -> DeltaOptions
  -> FilePath
  -> IO (ParseResult GHC.ParsedSource)
parseModuleWithCpp :: CppOptions
-> DeltaOptions -> FilePath -> IO (ParseResult (Located HsModule))
parseModuleWithCpp CppOptions
cpp DeltaOptions
opts FilePath
fp = do
  Either
  ErrorMessages (ApiAnns, [Comment], DynFlags, Located HsModule)
res <- CppOptions
-> FilePath
-> IO
     (Either
        ErrorMessages (ApiAnns, [Comment], DynFlags, Located HsModule))
parseModuleApiAnnsWithCpp CppOptions
cpp FilePath
fp
  ParseResult (Located HsModule)
-> IO (ParseResult (Located HsModule))
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseResult (Located HsModule)
 -> IO (ParseResult (Located HsModule)))
-> ParseResult (Located HsModule)
-> IO (ParseResult (Located HsModule))
forall a b. (a -> b) -> a -> b
$ Either
  ErrorMessages (ApiAnns, [Comment], DynFlags, Located HsModule)
-> DeltaOptions -> ParseResult (Located HsModule)
forall a.
Either a (ApiAnns, [Comment], DynFlags, Located HsModule)
-> DeltaOptions -> Either a (Anns, Located HsModule)
postParseTransform Either
  ErrorMessages (ApiAnns, [Comment], DynFlags, Located HsModule)
res DeltaOptions
opts

-- ---------------------------------------------------------------------

-- | Low level function which is used in the internal tests.
-- It is advised to use 'parseModule' or 'parseModuleWithCpp' instead of
-- this function.
parseModuleApiAnnsWithCpp
  :: CppOptions
  -> FilePath
  -> IO
       ( Either
#if __GLASGOW_HASKELL__ > 808
           GHC.ErrorMessages
#else
           (GHC.SrcSpan, String)
#endif
           (GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource)
       )
parseModuleApiAnnsWithCpp :: CppOptions
-> FilePath
-> IO
     (Either
        ErrorMessages (ApiAnns, [Comment], DynFlags, Located HsModule))
parseModuleApiAnnsWithCpp CppOptions
cppOptions FilePath
file = Ghc
  (Either
     ErrorMessages (ApiAnns, [Comment], DynFlags, Located HsModule))
-> IO
     (Either
        ErrorMessages (ApiAnns, [Comment], DynFlags, Located HsModule))
forall a. Ghc a -> IO a
ghcWrapper (Ghc
   (Either
      ErrorMessages (ApiAnns, [Comment], DynFlags, Located HsModule))
 -> IO
      (Either
         ErrorMessages (ApiAnns, [Comment], DynFlags, Located HsModule)))
-> Ghc
     (Either
        ErrorMessages (ApiAnns, [Comment], DynFlags, Located HsModule))
-> IO
     (Either
        ErrorMessages (ApiAnns, [Comment], DynFlags, Located HsModule))
forall a b. (a -> b) -> a -> b
$ do
  DynFlags
dflags <- FilePath -> Ghc DynFlags
forall (m :: * -> *). GhcMonad m => FilePath -> m DynFlags
initDynFlags FilePath
file
  CppOptions
-> DynFlags
-> FilePath
-> Ghc
     (Either
        ErrorMessages (ApiAnns, [Comment], DynFlags, Located HsModule))
forall (m :: * -> *).
GhcMonad m =>
CppOptions
-> DynFlags
-> FilePath
-> m (Either
        ErrorMessages (ApiAnns, [Comment], DynFlags, Located HsModule))
parseModuleApiAnnsWithCppInternal CppOptions
cppOptions DynFlags
dflags FilePath
file

-- | Internal function. Default runner of GHC.Ghc action in IO.
ghcWrapper :: GHC.Ghc a -> IO a
ghcWrapper :: forall a. Ghc a -> IO a
ghcWrapper Ghc a
ghc = do
  let handler :: IOException -> IO (Maybe FilePath)
handler = Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath -> IO (Maybe FilePath))
-> (IOException -> Maybe FilePath)
-> IOException
-> IO (Maybe FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe FilePath -> IOException -> Maybe FilePath
forall a b. a -> b -> a
const Maybe FilePath
forall a. Maybe a
Nothing :: IOException -> IO (Maybe String)
  Maybe FilePath
rtLibdir <- IO (Maybe FilePath) -> IO (Maybe FilePath)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe FilePath) -> IO (Maybe FilePath))
-> IO (Maybe FilePath) -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"GHC_EXACTPRINT_GHC_LIBDIR" IO (Maybe FilePath)
-> (IOException -> IO (Maybe FilePath)) -> IO (Maybe FilePath)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` IOException -> IO (Maybe FilePath)
handler
  let libdir' :: FilePath
libdir' = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
libdir Maybe FilePath
rtLibdir
  FatalMessager -> FlushOut -> IO a -> IO a
forall (m :: * -> *) a.
ExceptionMonad m =>
FatalMessager -> FlushOut -> m a -> m a
GHC.defaultErrorHandler FatalMessager
GHC.defaultFatalMessager FlushOut
GHC.defaultFlushOut
    (IO a -> IO a) -> (Ghc a -> IO a) -> Ghc a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe FilePath -> Ghc a -> IO a
forall a. Maybe FilePath -> Ghc a -> IO a
GHC.runGhc (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
libdir') (Ghc a -> IO a) -> Ghc a -> IO a
forall a b. (a -> b) -> a -> b
$ Ghc a
ghc

-- | Internal function. Exposed if you want to muck with DynFlags
-- before parsing.
parseModuleApiAnnsWithCppInternal
  :: GHC.GhcMonad m
  => CppOptions
  -> GHC.DynFlags
  -> FilePath
  -> m
       ( Either
#if __GLASGOW_HASKELL__ > 808
           GHC.ErrorMessages
#else
           (GHC.SrcSpan, String)
#endif
           (GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource)
       )
parseModuleApiAnnsWithCppInternal :: forall (m :: * -> *).
GhcMonad m =>
CppOptions
-> DynFlags
-> FilePath
-> m (Either
        ErrorMessages (ApiAnns, [Comment], DynFlags, Located HsModule))
parseModuleApiAnnsWithCppInternal CppOptions
cppOptions DynFlags
dflags FilePath
file = do
#if __GLASGOW_HASKELL__ <= 710
  let useCpp = GHC.xopt GHC.Opt_Cpp dflags
#else
  let useCpp :: Bool
useCpp = Extension -> DynFlags -> Bool
GHC.xopt Extension
LangExt.Cpp DynFlags
dflags
#endif
  (FilePath
fileContents, [Comment]
injectedComments, DynFlags
dflags') <-
    if Bool
useCpp
      then do
        (FilePath
contents,DynFlags
dflags1) <- CppOptions -> FilePath -> m (FilePath, DynFlags)
forall (m :: * -> *).
GhcMonad m =>
CppOptions -> FilePath -> m (FilePath, DynFlags)
getPreprocessedSrcDirect CppOptions
cppOptions FilePath
file
        [Comment]
cppComments <- CppOptions -> FilePath -> m [Comment]
forall (m :: * -> *).
GhcMonad m =>
CppOptions -> FilePath -> m [Comment]
getCppTokensAsComments CppOptions
cppOptions FilePath
file
        (FilePath, [Comment], DynFlags)
-> m (FilePath, [Comment], DynFlags)
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
contents,[Comment]
cppComments,DynFlags
dflags1)
      else do
        FilePath
txt <- IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
GHC.liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
readFileGhc FilePath
file
        let (FilePath
contents1,[Comment]
lp) = FilePath -> (FilePath, [Comment])
stripLinePragmas FilePath
txt
        (FilePath, [Comment], DynFlags)
-> m (FilePath, [Comment], DynFlags)
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
contents1,[Comment]
lp,DynFlags
dflags)
  Either
  ErrorMessages (ApiAnns, [Comment], DynFlags, Located HsModule)
-> m (Either
        ErrorMessages (ApiAnns, [Comment], DynFlags, Located HsModule))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   ErrorMessages (ApiAnns, [Comment], DynFlags, Located HsModule)
 -> m (Either
         ErrorMessages (ApiAnns, [Comment], DynFlags, Located HsModule)))
-> Either
     ErrorMessages (ApiAnns, [Comment], DynFlags, Located HsModule)
-> m (Either
        ErrorMessages (ApiAnns, [Comment], DynFlags, Located HsModule))
forall a b. (a -> b) -> a -> b
$
    case DynFlags -> FilePath -> FilePath -> ParseResult (Located HsModule)
parseFile DynFlags
dflags' FilePath
file FilePath
fileContents of
#if __GLASGOW_HASKELL__ > 808
      GHC.PFailed PState
pst -> ErrorMessages
-> Either
     ErrorMessages (ApiAnns, [Comment], DynFlags, Located HsModule)
forall a b. a -> Either a b
Left (PState -> DynFlags -> ErrorMessages
GHC.getErrorMessages PState
pst DynFlags
dflags)
#elif __GLASGOW_HASKELL__ >= 804
      GHC.PFailed _ ss m -> Left $ (ss, (GHC.showSDoc dflags m))
#else
      GHC.PFailed ss m -> Left $ (ss, (GHC.showSDoc dflags m))
#endif
      GHC.POk (PState -> ApiAnns
mkApiAnns -> ApiAnns
apianns) Located HsModule
pmod  ->
        (ApiAnns, [Comment], DynFlags, Located HsModule)
-> Either
     ErrorMessages (ApiAnns, [Comment], DynFlags, Located HsModule)
forall a b. b -> Either a b
Right ((ApiAnns, [Comment], DynFlags, Located HsModule)
 -> Either
      ErrorMessages (ApiAnns, [Comment], DynFlags, Located HsModule))
-> (ApiAnns, [Comment], DynFlags, Located HsModule)
-> Either
     ErrorMessages (ApiAnns, [Comment], DynFlags, Located HsModule)
forall a b. (a -> b) -> a -> b
$ (ApiAnns
apianns, [Comment]
injectedComments, DynFlags
dflags', Located HsModule
pmod)

-- | Internal function. Exposed if you want to muck with DynFlags
-- before parsing. Or after parsing.
postParseTransform
  :: Either a (GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource)
  -> DeltaOptions
  -> Either a (Anns, GHC.ParsedSource)
postParseTransform :: forall a.
Either a (ApiAnns, [Comment], DynFlags, Located HsModule)
-> DeltaOptions -> Either a (Anns, Located HsModule)
postParseTransform Either a (ApiAnns, [Comment], DynFlags, Located HsModule)
parseRes DeltaOptions
opts = ((ApiAnns, [Comment], DynFlags, Located HsModule)
 -> (Anns, Located HsModule))
-> Either a (ApiAnns, [Comment], DynFlags, Located HsModule)
-> Either a (Anns, Located HsModule)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ApiAnns, [Comment], DynFlags, Located HsModule)
-> (Anns, Located HsModule)
forall {ast} {c}.
Annotate ast =>
(ApiAnns, [Comment], c, Located ast) -> (Anns, Located ast)
mkAnns Either a (ApiAnns, [Comment], DynFlags, Located HsModule)
parseRes
  where
    mkAnns :: (ApiAnns, [Comment], c, Located ast) -> (Anns, Located ast)
mkAnns (ApiAnns
apianns, [Comment]
cs, c
_, Located ast
m) =
      (DeltaOptions -> [Comment] -> Located ast -> ApiAnns -> Anns
forall ast.
Annotate ast =>
DeltaOptions -> [Comment] -> Located ast -> ApiAnns -> Anns
relativiseApiAnnsWithOptions DeltaOptions
opts [Comment]
cs Located ast
m ApiAnns
apianns, Located ast
m)

-- | Internal function. Initializes DynFlags value for parsing.
--
-- Passes "-hide-all-packages" to the GHC API to prevent parsing of
-- package environment files. However this only works if there is no
-- invocation of `setSessionDynFlags` before calling `initDynFlags`.
-- See ghc tickets #15513, #15541.
initDynFlags :: GHC.GhcMonad m => FilePath -> m GHC.DynFlags
initDynFlags :: forall (m :: * -> *). GhcMonad m => FilePath -> m DynFlags
initDynFlags FilePath
file = do
  DynFlags
dflags0         <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
  [Located FilePath]
src_opts        <- IO [Located FilePath] -> m [Located FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
GHC.liftIO (IO [Located FilePath] -> m [Located FilePath])
-> IO [Located FilePath] -> m [Located FilePath]
forall a b. (a -> b) -> a -> b
$ DynFlags -> FilePath -> IO [Located FilePath]
GHC.getOptionsFromFile DynFlags
dflags0 FilePath
file
  (DynFlags
dflags1, [Located FilePath]
_, [Warn]
_) <- DynFlags
-> [Located FilePath] -> m (DynFlags, [Located FilePath], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located FilePath] -> m (DynFlags, [Located FilePath], [Warn])
GHC.parseDynamicFilePragma DynFlags
dflags0 [Located FilePath]
src_opts
  -- Turn this on last to avoid T10942
  let dflags2 :: DynFlags
dflags2 = DynFlags
dflags1 DynFlags -> GeneralFlag -> DynFlags
`GHC.gopt_set` GeneralFlag
GHC.Opt_KeepRawTokenStream
  -- Prevent parsing of .ghc.environment.* "package environment files"
  (DynFlags
dflags3, [Located FilePath]
_, [Warn]
_) <- DynFlags
-> [Located FilePath] -> m (DynFlags, [Located FilePath], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located FilePath] -> m (DynFlags, [Located FilePath], [Warn])
GHC.parseDynamicFlagsCmdLine
    DynFlags
dflags2
    [FilePath -> Located FilePath
forall e. e -> Located e
GHC.noLoc FilePath
"-hide-all-packages"]
  ()
_ <- DynFlags -> m ()
forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
GHC.setSessionDynFlags DynFlags
dflags3
  DynFlags -> m DynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags
dflags3

-- | Requires GhcMonad constraint because there is
-- no pure variant of `parseDynamicFilePragma`. Yet, in constrast to
-- `initDynFlags`, it does not (try to) read the file at filepath, but
-- solely depends on the module source in the input string.
--
-- Passes "-hide-all-packages" to the GHC API to prevent parsing of
-- package environment files. However this only works if there is no
-- invocation of `setSessionDynFlags` before calling `initDynFlagsPure`.
-- See ghc tickets #15513, #15541.
initDynFlagsPure :: GHC.GhcMonad m => FilePath -> String -> m GHC.DynFlags
initDynFlagsPure :: forall (m :: * -> *).
GhcMonad m =>
FilePath -> FilePath -> m DynFlags
initDynFlagsPure FilePath
fp FilePath
s = do
  -- I was told we could get away with using the unsafeGlobalDynFlags.
  -- as long as `parseDynamicFilePragma` is impure there seems to be
  -- no reason to use it.
  DynFlags
dflags0 <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
  let pragmaInfo :: [Located FilePath]
pragmaInfo = DynFlags -> StringBuffer -> FilePath -> [Located FilePath]
GHC.getOptions DynFlags
dflags0 (FilePath -> StringBuffer
GHC.stringToStringBuffer (FilePath -> StringBuffer) -> FilePath -> StringBuffer
forall a b. (a -> b) -> a -> b
$ FilePath
s) FilePath
fp
  (DynFlags
dflags1, [Located FilePath]
_, [Warn]
_) <- DynFlags
-> [Located FilePath] -> m (DynFlags, [Located FilePath], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located FilePath] -> m (DynFlags, [Located FilePath], [Warn])
GHC.parseDynamicFilePragma DynFlags
dflags0 [Located FilePath]
pragmaInfo
  -- Turn this on last to avoid T10942
  let dflags2 :: DynFlags
dflags2 = DynFlags
dflags1 DynFlags -> GeneralFlag -> DynFlags
`GHC.gopt_set` GeneralFlag
GHC.Opt_KeepRawTokenStream
  -- Prevent parsing of .ghc.environment.* "package environment files"
  (DynFlags
dflags3, [Located FilePath]
_, [Warn]
_) <- DynFlags
-> [Located FilePath] -> m (DynFlags, [Located FilePath], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located FilePath] -> m (DynFlags, [Located FilePath], [Warn])
GHC.parseDynamicFlagsCmdLine
    DynFlags
dflags2
    [FilePath -> Located FilePath
forall e. e -> Located e
GHC.noLoc FilePath
"-hide-all-packages"]
  ()
_ <- DynFlags -> m ()
forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
GHC.setSessionDynFlags DynFlags
dflags3
  DynFlags -> m DynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags
dflags3

-- ---------------------------------------------------------------------

mkApiAnns :: GHC.PState -> GHC.ApiAnns

#if __GLASGOW_HASKELL__ >= 900
mkApiAnns :: PState -> ApiAnns
mkApiAnns PState
pstate
  = ApiAnns :: Map ApiAnnKey [RealSrcSpan]
-> Maybe RealSrcSpan
-> Map RealSrcSpan [RealLocated AnnotationComment]
-> [RealLocated AnnotationComment]
-> ApiAnns
GHC.ApiAnns {
        apiAnnItems :: Map ApiAnnKey [RealSrcSpan]
GHC.apiAnnItems = ([RealSrcSpan] -> [RealSrcSpan] -> [RealSrcSpan])
-> [(ApiAnnKey, [RealSrcSpan])] -> Map ApiAnnKey [RealSrcSpan]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [RealSrcSpan] -> [RealSrcSpan] -> [RealSrcSpan]
forall a. [a] -> [a] -> [a]
(++) ([(ApiAnnKey, [RealSrcSpan])] -> Map ApiAnnKey [RealSrcSpan])
-> [(ApiAnnKey, [RealSrcSpan])] -> Map ApiAnnKey [RealSrcSpan]
forall a b. (a -> b) -> a -> b
$ PState -> [(ApiAnnKey, [RealSrcSpan])]
GHC.annotations PState
pstate,
        apiAnnEofPos :: Maybe RealSrcSpan
GHC.apiAnnEofPos = PState -> Maybe RealSrcSpan
GHC.eof_pos PState
pstate,
        apiAnnComments :: Map RealSrcSpan [RealLocated AnnotationComment]
GHC.apiAnnComments = [(RealSrcSpan, [RealLocated AnnotationComment])]
-> Map RealSrcSpan [RealLocated AnnotationComment]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (PState -> [(RealSrcSpan, [RealLocated AnnotationComment])]
GHC.annotations_comments PState
pstate),
        apiAnnRogueComments :: [RealLocated AnnotationComment]
GHC.apiAnnRogueComments = PState -> [RealLocated AnnotationComment]
GHC.comment_q PState
pstate
     }
#else
mkApiAnns pstate
  = ( Map.fromListWith (++) . GHC.annotations $ pstate
    , Map.fromList ((GHC.noSrcSpan, GHC.comment_q pstate) : GHC.annotations_comments pstate))
#endif