{-# 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 :: 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)

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

#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 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

#if __GLASGOW_HASKELL__ >= 900
mkApiAnns pstate
  = GHC.ApiAnns {
        GHC.apiAnnItems = Map.fromListWith (++) $ GHC.annotations pstate,
        GHC.apiAnnEofPos = GHC.eof_pos pstate,
        GHC.apiAnnComments = Map.fromList (GHC.annotations_comments pstate),
        GHC.apiAnnRogueComments = GHC.comment_q pstate
     }
#else
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))
#endif