{-# 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__ > 806
import Data.Data (Data)
#endif
import Data.Maybe (fromMaybe)

import GHC.Paths (libdir)

import System.Environment (lookupEnv)

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

#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
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 :: DynFlags -> FilePath -> P w -> FilePath -> ParseResult w
parseWith DynFlags
dflags FilePath
fileName P w
parser FilePath
s =
  case P w -> DynFlags -> FilePath -> FilePath -> ParseResult w
forall a. P a -> DynFlags -> FilePath -> FilePath -> ParseResult a
runParser P w
parser DynFlags
dflags FilePath
fileName FilePath
s of
#if __GLASGOW_HASKELL__ > 808
    GHC.PFailed PState
pst                       -> ErrorMessages -> ParseResult 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) w
pmod -> (Anns, w) -> ParseResult w
forall a b. b -> Either a b
Right (Anns
as, w
pmod)
      where as :: Anns
as = w -> ApiAnns -> Anns
forall ast.
(Data (SrcSpanLess ast), Annotate ast, HasSrcSpan ast) =>
ast -> ApiAnns -> Anns
relativiseApiAnns 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 :: 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.
(Data (SrcSpanLess ast), Annotate ast, HasSrcSpan ast) =>
ast -> ApiAnns -> Anns
relativiseApiAnns Located w
pmod ApiAnns
apianns
#endif

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

runParser :: GHC.P a -> GHC.DynFlags -> FilePath -> String -> GHC.ParseResult a
runParser :: 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 :: (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 [InstalledUnitId] -> Ghc ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Ghc [InstalledUnitId] -> Ghc ())
-> Ghc [InstalledUnitId] -> Ghc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Ghc [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
GHC.setSessionDynFlags DynFlags
dflags
  a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> a
action DynFlags
dflags)

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

parseFile :: GHC.DynFlags -> FilePath -> String -> GHC.ParseResult (GHC.Located (GHC.HsModule GhcPs))
parseFile :: DynFlags
-> FilePath -> FilePath -> ParseResult (Located (HsModule GhcPs))
parseFile = P (Located (HsModule GhcPs))
-> DynFlags
-> FilePath
-> FilePath
-> ParseResult (Located (HsModule GhcPs))
forall a. P a -> DynFlags -> FilePath -> FilePath -> ParseResult a
runParser P (Located (HsModule GhcPs))
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.
(Data (SrcSpanLess w), Annotate w, HasSrcSpan w) =>
DynFlags -> FilePath -> P w -> FilePath -> ParseResult 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.
(Data (SrcSpanLess w), Annotate w, HasSrcSpan w) =>
DynFlags -> FilePath -> P w -> FilePath -> ParseResult 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.
(Data (SrcSpanLess w), Annotate w, HasSrcSpan w) =>
DynFlags -> FilePath -> P w -> FilePath -> ParseResult 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.
(Data (SrcSpanLess w), Annotate w, HasSrcSpan w) =>
DynFlags -> FilePath -> P w -> FilePath -> ParseResult 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.
(Data (SrcSpanLess w), Annotate w, HasSrcSpan w) =>
DynFlags -> FilePath -> P w -> FilePath -> ParseResult 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 GhcPs)))
parseModule = CppOptions
-> DeltaOptions
-> FilePath
-> IO (ParseResult (Located (HsModule GhcPs)))
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 GhcPs)))
parseModuleFromString FilePath
fp FilePath
s = Ghc (ParseResult (Located (HsModule GhcPs)))
-> IO (ParseResult (Located (HsModule GhcPs)))
forall a. Ghc a -> IO a
ghcWrapper (Ghc (ParseResult (Located (HsModule GhcPs)))
 -> IO (ParseResult (Located (HsModule GhcPs))))
-> Ghc (ParseResult (Located (HsModule GhcPs)))
-> IO (ParseResult (Located (HsModule GhcPs)))
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 GhcPs))
-> Ghc (ParseResult (Located (HsModule GhcPs)))
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseResult (Located (HsModule GhcPs))
 -> Ghc (ParseResult (Located (HsModule GhcPs))))
-> ParseResult (Located (HsModule GhcPs))
-> Ghc (ParseResult (Located (HsModule GhcPs)))
forall a b. (a -> b) -> a -> b
$ Parser (Located (HsModule GhcPs))
parseModuleFromStringInternal DynFlags
dflags FilePath
fp FilePath
s

-- | Internal part of 'parseModuleFromString'.
parseModuleFromStringInternal :: Parser GHC.ParsedSource
parseModuleFromStringInternal :: Parser (Located (HsModule GhcPs))
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 GhcPs))
res        = case P (Located (HsModule GhcPs))
-> DynFlags
-> FilePath
-> FilePath
-> ParseResult (Located (HsModule GhcPs))
forall a. P a -> DynFlags -> FilePath -> FilePath -> ParseResult a
runParser P (Located (HsModule GhcPs))
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 GhcPs))
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 GhcPs)
pmod -> (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
-> Either
     ErrorMessages
     (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
forall a b. b -> Either a b
Right (PState -> ApiAnns
mkApiAnns PState
x, [Comment]
lp, DynFlags
dflags, Located (HsModule GhcPs)
pmod)
  in  Either
  ErrorMessages
  (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
-> DeltaOptions -> ParseResult (Located (HsModule GhcPs))
forall a.
Either a (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
-> DeltaOptions -> Either a (Anns, Located (HsModule GhcPs))
postParseTransform Either
  ErrorMessages
  (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
res DeltaOptions
normalLayout

parseModuleWithOptions :: DeltaOptions
                       -> FilePath
                       -> IO (ParseResult GHC.ParsedSource)
parseModuleWithOptions :: DeltaOptions
-> FilePath -> IO (ParseResult (Located (HsModule GhcPs)))
parseModuleWithOptions DeltaOptions
opts FilePath
fp =
  CppOptions
-> DeltaOptions
-> FilePath
-> IO (ParseResult (Located (HsModule GhcPs)))
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 GhcPs)))
parseModuleWithCpp CppOptions
cpp DeltaOptions
opts FilePath
fp = do
  Either
  ErrorMessages
  (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
res <- CppOptions
-> FilePath
-> IO
     (Either
        ErrorMessages
        (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs)))
parseModuleApiAnnsWithCpp CppOptions
cpp FilePath
fp
  ParseResult (Located (HsModule GhcPs))
-> IO (ParseResult (Located (HsModule GhcPs)))
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseResult (Located (HsModule GhcPs))
 -> IO (ParseResult (Located (HsModule GhcPs))))
-> ParseResult (Located (HsModule GhcPs))
-> IO (ParseResult (Located (HsModule GhcPs)))
forall a b. (a -> b) -> a -> b
$ Either
  ErrorMessages
  (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
-> DeltaOptions -> ParseResult (Located (HsModule GhcPs))
forall a.
Either a (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
-> DeltaOptions -> Either a (Anns, Located (HsModule GhcPs))
postParseTransform Either
  ErrorMessages
  (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
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 GhcPs)))
parseModuleApiAnnsWithCpp CppOptions
cppOptions FilePath
file = Ghc
  (Either
     ErrorMessages
     (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs)))
-> IO
     (Either
        ErrorMessages
        (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs)))
forall a. Ghc a -> IO a
ghcWrapper (Ghc
   (Either
      ErrorMessages
      (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs)))
 -> IO
      (Either
         ErrorMessages
         (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))))
-> Ghc
     (Either
        ErrorMessages
        (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs)))
-> IO
     (Either
        ErrorMessages
        (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs)))
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 GhcPs)))
forall (m :: * -> *).
GhcMonad m =>
CppOptions
-> DynFlags
-> FilePath
-> m (Either
        ErrorMessages
        (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs)))
parseModuleApiAnnsWithCppInternal CppOptions
cppOptions DynFlags
dflags FilePath
file

-- | Internal function. Default runner of GHC.Ghc action in IO.
ghcWrapper :: GHC.Ghc a -> IO a
ghcWrapper :: 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 :: CppOptions
-> DynFlags
-> FilePath
-> m (Either
        ErrorMessages
        (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs)))
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 GhcPs))
-> m (Either
        ErrorMessages
        (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   ErrorMessages
   (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
 -> m (Either
         ErrorMessages
         (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))))
-> Either
     ErrorMessages
     (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
-> m (Either
        ErrorMessages
        (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs)))
forall a b. (a -> b) -> a -> b
$
    case DynFlags
-> FilePath -> FilePath -> ParseResult (Located (HsModule GhcPs))
parseFile DynFlags
dflags' FilePath
file FilePath
fileContents of
#if __GLASGOW_HASKELL__ > 808
      GHC.PFailed PState
pst -> ErrorMessages
-> Either
     ErrorMessages
     (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
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 GhcPs)
pmod  ->
        (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
-> Either
     ErrorMessages
     (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
forall a b. b -> Either a b
Right ((ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
 -> Either
      ErrorMessages
      (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs)))
-> (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
-> Either
     ErrorMessages
     (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
forall a b. (a -> b) -> a -> b
$ (ApiAnns
apianns, [Comment]
injectedComments, DynFlags
dflags', Located (HsModule GhcPs)
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 :: Either a (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
-> DeltaOptions -> Either a (Anns, Located (HsModule GhcPs))
postParseTransform Either a (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
parseRes DeltaOptions
opts = ((ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
 -> (Anns, Located (HsModule GhcPs)))
-> Either
     a (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
-> Either a (Anns, Located (HsModule GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
-> (Anns, Located (HsModule GhcPs))
forall b c.
(Annotate b, HasSrcSpan b, Data (SrcSpanLess b)) =>
(ApiAnns, [Comment], c, b) -> (Anns, b)
mkAnns Either a (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
parseRes
  where
    mkAnns :: (ApiAnns, [Comment], c, b) -> (Anns, b)
mkAnns (ApiAnns
apianns, [Comment]
cs, c
_, b
m) =
      (DeltaOptions -> [Comment] -> b -> ApiAnns -> Anns
forall ast.
(Data (SrcSpanLess ast), Annotate ast, HasSrcSpan ast) =>
DeltaOptions -> [Comment] -> ast -> ApiAnns -> Anns
relativiseApiAnnsWithOptions DeltaOptions
opts [Comment]
cs b
m ApiAnns
apianns, b
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 :: 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
    [SrcSpanLess (Located FilePath) -> Located FilePath
forall a. HasSrcSpan a => SrcSpanLess a -> a
GHC.noLoc FilePath
SrcSpanLess (Located FilePath)
"-hide-all-packages"]
  [InstalledUnitId]
_ <- DynFlags -> m [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
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 :: 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
    [SrcSpanLess (Located FilePath) -> Located FilePath
forall a. HasSrcSpan a => SrcSpanLess a -> a
GHC.noLoc FilePath
SrcSpanLess (Located FilePath)
"-hide-all-packages"]
  [InstalledUnitId]
_ <- DynFlags -> m [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
GHC.setSessionDynFlags DynFlags
dflags3
  DynFlags -> m DynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags
dflags3

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

mkApiAnns :: GHC.PState -> GHC.ApiAnns
mkApiAnns :: PState -> ApiAnns
mkApiAnns PState
pstate
  = ( ([SrcSpan] -> [SrcSpan] -> [SrcSpan])
-> [(ApiAnnKey, [SrcSpan])] -> Map ApiAnnKey [SrcSpan]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. [a] -> [a] -> [a]
(++) ([(ApiAnnKey, [SrcSpan])] -> Map ApiAnnKey [SrcSpan])
-> (PState -> [(ApiAnnKey, [SrcSpan])])
-> PState
-> Map ApiAnnKey [SrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PState -> [(ApiAnnKey, [SrcSpan])]
GHC.annotations (PState -> Map ApiAnnKey [SrcSpan])
-> PState -> Map ApiAnnKey [SrcSpan]
forall a b. (a -> b) -> a -> b
$ PState
pstate
    , [(SrcSpan, [Located AnnotationComment])]
-> Map SrcSpan [Located AnnotationComment]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((SrcSpan
GHC.noSrcSpan, PState -> [Located AnnotationComment]
GHC.comment_q PState
pstate) (SrcSpan, [Located AnnotationComment])
-> [(SrcSpan, [Located AnnotationComment])]
-> [(SrcSpan, [Located AnnotationComment])]
forall a. a -> [a] -> [a]
: PState -> [(SrcSpan, [Located AnnotationComment])]
GHC.annotations_comments PState
pstate))