{-# 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
        , 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.Monad.RWS
#if __GLASGOW_HASKELL__ > 806
import Data.Data (Data)
#endif

import GHC.Paths (libdir)

import qualified ApiAnnotation as GHC
import qualified DynFlags      as GHC
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
import qualified Outputable    as GHC
import qualified Parser        as GHC
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
          -> Either (GHC.SrcSpan, String) (Anns, w)
#else
parseWith :: Annotate w
          => GHC.DynFlags
          -> FilePath
          -> GHC.P (GHC.Located w)
          -> String
          -> Either (GHC.SrcSpan, String) (Anns, GHC.Located w)
#endif
parseWith :: DynFlags
-> FilePath
-> P w
-> FilePath
-> Either (SrcSpan, FilePath) (Anns, w)
parseWith dflags :: DynFlags
dflags fileName :: FilePath
fileName parser :: P w
parser s :: 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__ >= 804
    GHC.PFailed _ ss :: SrcSpan
ss m :: MsgDoc
m                    -> (SrcSpan, FilePath) -> Either (SrcSpan, FilePath) (Anns, w)
forall a b. a -> Either a b
Left (SrcSpan
ss, DynFlags -> MsgDoc -> FilePath
GHC.showSDoc DynFlags
dflags MsgDoc
m)
#else
    GHC.PFailed ss m                    -> Left (ss, GHC.showSDoc dflags m)
#endif
    GHC.POk (PState -> ApiAnns
mkApiAnns -> ApiAnns
apianns) pmod :: w
pmod -> (Anns, w) -> Either (SrcSpan, FilePath) (Anns, 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

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

runParser :: GHC.P a -> GHC.DynFlags -> FilePath -> String -> GHC.ParseResult a
runParser :: P a -> DynFlags -> FilePath -> FilePath -> ParseResult a
runParser parser :: P a
parser flags :: DynFlags
flags filename :: FilePath
filename str :: 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) 1 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 action :: 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

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

type Parser a = GHC.DynFlags -> FilePath -> String
                -> Either (GHC.SrcSpan, String)
                          (Anns, a)

parseExpr :: Parser (GHC.LHsExpr GhcPs)
parseExpr :: Parser (LHsExpr GhcPs)
parseExpr df :: DynFlags
df fp :: FilePath
fp = DynFlags
-> FilePath
-> P (LHsExpr GhcPs)
-> FilePath
-> Either (SrcSpan, FilePath) (Anns, LHsExpr GhcPs)
forall w.
(Data (SrcSpanLess w), Annotate w, HasSrcSpan w) =>
DynFlags
-> FilePath
-> P w
-> FilePath
-> Either (SrcSpan, FilePath) (Anns, w)
parseWith DynFlags
df FilePath
fp P (LHsExpr GhcPs)
GHC.parseExpression

parseImport :: Parser (GHC.LImportDecl GhcPs)
parseImport :: Parser (LImportDecl GhcPs)
parseImport df :: DynFlags
df fp :: FilePath
fp = DynFlags
-> FilePath
-> P (LImportDecl GhcPs)
-> FilePath
-> Either (SrcSpan, FilePath) (Anns, LImportDecl GhcPs)
forall w.
(Data (SrcSpanLess w), Annotate w, HasSrcSpan w) =>
DynFlags
-> FilePath
-> P w
-> FilePath
-> Either (SrcSpan, FilePath) (Anns, w)
parseWith DynFlags
df FilePath
fp P (LImportDecl GhcPs)
GHC.parseImport

parseType :: Parser (GHC.LHsType GhcPs)
parseType :: Parser (LHsType GhcPs)
parseType df :: DynFlags
df fp :: FilePath
fp = DynFlags
-> FilePath
-> P (LHsType GhcPs)
-> FilePath
-> Either (SrcSpan, FilePath) (Anns, LHsType GhcPs)
forall w.
(Data (SrcSpanLess w), Annotate w, HasSrcSpan w) =>
DynFlags
-> FilePath
-> P w
-> FilePath
-> Either (SrcSpan, FilePath) (Anns, 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 df :: DynFlags
df fp :: FilePath
fp = DynFlags
-> FilePath
-> P (LHsDecl GhcPs)
-> FilePath
-> Either (SrcSpan, FilePath) (Anns, LHsDecl GhcPs)
forall w.
(Data (SrcSpanLess w), Annotate w, HasSrcSpan w) =>
DynFlags
-> FilePath
-> P w
-> FilePath
-> Either (SrcSpan, FilePath) (Anns, w)
parseWith DynFlags
df FilePath
fp P (LHsDecl GhcPs)
GHC.parseDeclaration
#endif

parseStmt :: Parser (GHC.ExprLStmt GhcPs)
parseStmt :: Parser (ExprLStmt GhcPs)
parseStmt df :: DynFlags
df fp :: FilePath
fp = DynFlags
-> FilePath
-> P (ExprLStmt GhcPs)
-> FilePath
-> Either (SrcSpan, FilePath) (Anns, ExprLStmt GhcPs)
forall w.
(Data (SrcSpanLess w), Annotate w, HasSrcSpan w) =>
DynFlags
-> FilePath
-> P w
-> FilePath
-> Either (SrcSpan, FilePath) (Anns, w)
parseWith DynFlags
df FilePath
fp P (ExprLStmt GhcPs)
GHC.parseStatement

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

-- | Internal part of 'parseModuleFromString'.
parseModuleFromStringInternal
  :: GHC.DynFlags
  -> FilePath
  -> String
  -> Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource)
parseModuleFromStringInternal :: DynFlags
-> FilePath
-> FilePath
-> Either (SrcSpan, FilePath) (Anns, Located (HsModule GhcPs))
parseModuleFromStringInternal dflags :: DynFlags
dflags fileName :: FilePath
fileName str :: FilePath
str =
  let (str1 :: FilePath
str1, lp :: [Comment]
lp) = FilePath -> (FilePath, [Comment])
stripLinePragmas FilePath
str
      res :: Either
  (SrcSpan, FilePath)
  (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__ >= 804
        GHC.PFailed _ ss :: SrcSpan
ss m :: MsgDoc
m  -> (SrcSpan, FilePath)
-> Either
     (SrcSpan, FilePath)
     (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
forall a b. a -> Either a b
Left (SrcSpan
ss, DynFlags -> MsgDoc -> FilePath
GHC.showSDoc DynFlags
dflags MsgDoc
m)
#else
        GHC.PFailed ss m    -> Left (ss, GHC.showSDoc dflags m)
#endif
        GHC.POk     x :: PState
x  pmod :: Located (HsModule GhcPs)
pmod -> (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
-> Either
     (SrcSpan, FilePath)
     (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
forall a b. b -> Either a b
Right ((ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
 -> Either
      (SrcSpan, FilePath)
      (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs)))
-> (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
-> Either
     (SrcSpan, FilePath)
     (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
forall a b. (a -> b) -> a -> b
$ (PState -> ApiAnns
mkApiAnns PState
x, [Comment]
lp, DynFlags
dflags, Located (HsModule GhcPs)
pmod)
  in  Either
  (SrcSpan, FilePath)
  (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
-> DeltaOptions
-> Either (SrcSpan, FilePath) (Anns, Located (HsModule GhcPs))
forall a.
Either a (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
-> DeltaOptions -> Either a (Anns, Located (HsModule GhcPs))
postParseTransform Either
  (SrcSpan, FilePath)
  (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
res DeltaOptions
normalLayout

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

-- | Internal function. Exposed if you want to muck with DynFlags
-- before parsing.
parseModuleApiAnnsWithCppInternal
  :: GHC.GhcMonad m
  => CppOptions
  -> GHC.DynFlags
  -> FilePath
  -> m
       ( Either
           (GHC.SrcSpan, String)
           (GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource)
       )
parseModuleApiAnnsWithCppInternal :: CppOptions
-> DynFlags
-> FilePath
-> m (Either
        (SrcSpan, FilePath)
        (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs)))
parseModuleApiAnnsWithCppInternal cppOptions :: CppOptions
cppOptions dflags :: DynFlags
dflags file :: 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
  (fileContents :: FilePath
fileContents, injectedComments :: [Comment]
injectedComments, dflags' :: DynFlags
dflags') <-
    if Bool
useCpp
      then do
        (contents :: FilePath
contents,dflags1 :: 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 (contents1 :: FilePath
contents1,lp :: [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
  (SrcSpan, FilePath)
  (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
-> m (Either
        (SrcSpan, FilePath)
        (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (SrcSpan, FilePath)
   (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
 -> m (Either
         (SrcSpan, FilePath)
         (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))))
-> Either
     (SrcSpan, FilePath)
     (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
-> m (Either
        (SrcSpan, FilePath)
        (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__ >= 804
      GHC.PFailed _ ss :: SrcSpan
ss m :: MsgDoc
m -> (SrcSpan, FilePath)
-> Either
     (SrcSpan, FilePath)
     (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
forall a b. a -> Either a b
Left ((SrcSpan, FilePath)
 -> Either
      (SrcSpan, FilePath)
      (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs)))
-> (SrcSpan, FilePath)
-> Either
     (SrcSpan, FilePath)
     (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
forall a b. (a -> b) -> a -> b
$ (SrcSpan
ss, (DynFlags -> MsgDoc -> FilePath
GHC.showSDoc DynFlags
dflags MsgDoc
m))
#else
      GHC.PFailed ss m -> Left $ (ss, (GHC.showSDoc dflags m))
#endif
      GHC.POk (PState -> ApiAnns
mkApiAnns -> ApiAnns
apianns) pmod :: Located (HsModule GhcPs)
pmod  ->
        (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
-> Either
     (SrcSpan, FilePath)
     (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
forall a b. b -> Either a b
Right ((ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
 -> Either
      (SrcSpan, FilePath)
      (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs)))
-> (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
-> Either
     (SrcSpan, FilePath)
     (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 parseRes :: Either a (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
parseRes opts :: DeltaOptions
opts = (a -> Either a (Anns, Located (HsModule GhcPs)))
-> ((ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
    -> Either a (Anns, Located (HsModule GhcPs)))
-> Either
     a (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
-> Either a (Anns, Located (HsModule GhcPs))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> Either a (Anns, Located (HsModule GhcPs))
forall a b. a -> Either a b
Left (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
-> Either a (Anns, Located (HsModule GhcPs))
forall b c a.
(Annotate b, HasSrcSpan b, Data (SrcSpanLess b)) =>
(ApiAnns, [Comment], c, b) -> Either a (Anns, b)
mkAnns Either a (ApiAnns, [Comment], DynFlags, Located (HsModule GhcPs))
parseRes
  where
    mkAnns :: (ApiAnns, [Comment], c, b) -> Either a (Anns, b)
mkAnns (apianns :: ApiAnns
apianns, cs :: [Comment]
cs, _, m :: b
m) =
      (Anns, b) -> Either a (Anns, b)
forall a b. b -> Either a b
Right (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 file :: 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
  (dflags1 :: DynFlags
dflags1, _, _) <- 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"
  (dflags3 :: DynFlags
dflags3, _, _) <- 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 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 fp :: FilePath
fp s :: 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
  (dflags1 :: DynFlags
dflags1, _, _) <- 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"
  (dflags3 :: DynFlags
dflags3, _, _) <- 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 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
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))