{-# 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
        , LibDir

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

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

        , parseWith

        -- * Internal

        , ghcWrapper

        , initDynFlags
        , initDynFlagsPure
        , parseModuleFromStringInternal
        , parseModuleEpAnnsWithCpp
        , parseModuleEpAnnsWithCppInternal
        , postParseTransform
        ) where

import Language.Haskell.GHC.ExactPrint.Preprocess

import Control.Monad.RWS

import qualified GHC hiding (parseModule)
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.Config      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.Parser.Errors.Ppr  as GHC
import qualified GHC.Types.SrcLoc       as GHC
import qualified GHC.Utils.Error        as GHC

import qualified GHC.LanguageExtensions as LangExt

{-# 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.
parseWith :: GHC.DynFlags
          -> FilePath
          -> GHC.P w
          -> String
          -> ParseResult w
parseWith :: forall w. 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
    GHC.PFailed PState
pst                     -> ErrorMessages -> ParseResult w
forall a b. a -> Either a b
Left ((PsError -> MsgEnvelope DecoratedSDoc)
-> Bag PsError -> ErrorMessages
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsError -> MsgEnvelope DecoratedSDoc
GHC.pprError (Bag PsError -> ErrorMessages) -> Bag PsError -> ErrorMessages
forall a b. (a -> b) -> a -> b
$ PState -> Bag PsError
GHC.getErrorMessages PState
pst)
    GHC.POk PState
_ w
pmod -> w -> ParseResult w
forall a b. b -> Either a b
Right w
pmod


parseWithECP :: (GHC.DisambECP w)
          => GHC.DynFlags
          -> FilePath
          -> GHC.P GHC.ECP
          -> String
          -> ParseResult (GHC.LocatedA w)
parseWithECP :: forall w.
DisambECP w =>
DynFlags
-> FilePath -> P ECP -> FilePath -> ParseResult (LocatedA w)
parseWithECP DynFlags
dflags FilePath
fileName P ECP
parser FilePath
s =
    case P (LocatedA w)
-> DynFlags -> FilePath -> FilePath -> ParseResult (LocatedA w)
forall a. P a -> DynFlags -> FilePath -> FilePath -> ParseResult a
runParser (P ECP
parser P ECP -> (ECP -> P (LocatedA w)) -> P (LocatedA w)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ECP
p -> PV (LocatedA w) -> P (LocatedA w)
forall a. PV a -> P a
GHC.runPV (PV (LocatedA w) -> P (LocatedA w))
-> PV (LocatedA w) -> P (LocatedA w)
forall a b. (a -> b) -> a -> b
$ ECP -> forall b. DisambECP b => PV (LocatedA b)
GHC.unECP ECP
p) DynFlags
dflags FilePath
fileName FilePath
s of
      GHC.PFailed PState
pst                     -> ErrorMessages -> ParseResult (LocatedA w)
forall a b. a -> Either a b
Left ((PsError -> MsgEnvelope DecoratedSDoc)
-> Bag PsError -> ErrorMessages
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsError -> MsgEnvelope DecoratedSDoc
GHC.pprError (Bag PsError -> ErrorMessages) -> Bag PsError -> ErrorMessages
forall a b. (a -> b) -> a -> b
$ PState -> Bag PsError
GHC.getErrorMessages PState
pst)
      GHC.POk PState
_ LocatedA w
pmod -> LocatedA w -> ParseResult (LocatedA w)
forall a b. b -> Either a b
Right LocatedA w
pmod

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

runParser :: GHC.P a -> GHC.DynFlags -> FilePath -> String -> GHC.ParseResult a
runParser :: forall a. P a -> DynFlags -> FilePath -> FilePath -> ParseResult a
runParser P a
parser DynFlags
flags FilePath
filename FilePath
str = P a -> PState -> ParseResult a
forall a. P a -> PState -> ParseResult a
GHC.unP P a
parser PState
parseState
    where
      location :: RealSrcLoc
location = FastString -> Int -> Int -> RealSrcLoc
GHC.mkRealSrcLoc (FilePath -> FastString
GHC.mkFastString FilePath
filename) Int
1 Int
1
      buffer :: StringBuffer
buffer = FilePath -> StringBuffer
GHC.stringToStringBuffer FilePath
str
      parseState :: PState
parseState = ParserOpts -> StringBuffer -> RealSrcLoc -> PState
GHC.initParserState (DynFlags -> ParserOpts
GHC.initParserOpts 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 :: LibDir -> (GHC.DynFlags -> a) -> IO a
withDynFlags :: forall a. FilePath -> (DynFlags -> a) -> IO a
withDynFlags FilePath
libdir DynFlags -> a
action = FilePath -> Ghc a -> IO a
forall a. FilePath -> Ghc a -> IO a
ghcWrapper FilePath
libdir (Ghc a -> IO a) -> Ghc a -> IO a
forall a b. (a -> b) -> a -> b
$ do
  DynFlags
dflags <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
  Ghc () -> Ghc ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Ghc () -> Ghc ()) -> Ghc () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> Ghc ()
forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
GHC.setSessionDynFlags DynFlags
dflags
  a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> a
action DynFlags
dflags)

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

parseFile :: GHC.DynFlags -> FilePath -> String -> GHC.ParseResult (GHC.Located GHC.HsModule)
parseFile :: DynFlags -> FilePath -> FilePath -> ParseResult (Located HsModule)
parseFile = P (Located HsModule)
-> DynFlags
-> FilePath
-> FilePath
-> ParseResult (Located HsModule)
forall a. P a -> DynFlags -> FilePath -> FilePath -> ParseResult a
runParser P (Located HsModule)
GHC.parseModule

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

type LibDir = FilePath

type ParseResult a = Either GHC.ErrorMessages a

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

parseExpr :: Parser (GHC.LHsExpr GHC.GhcPs)
parseExpr :: Parser (LHsExpr GhcPs)
parseExpr DynFlags
df FilePath
fp = DynFlags
-> FilePath
-> P ECP
-> FilePath
-> ParseResult (LocatedA (HsExpr GhcPs))
forall w.
DisambECP w =>
DynFlags
-> FilePath -> P ECP -> FilePath -> ParseResult (LocatedA w)
parseWithECP DynFlags
df FilePath
fp P ECP
GHC.parseExpression

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

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

-- safe, see D1007
parseDecl :: Parser (GHC.LHsDecl GHC.GhcPs)
parseDecl :: Parser (LHsDecl GhcPs)
parseDecl DynFlags
df FilePath
fp = DynFlags
-> FilePath
-> P (GenLocated SrcSpanAnnA (HsDecl GhcPs))
-> FilePath
-> ParseResult (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall w. DynFlags -> FilePath -> P w -> FilePath -> ParseResult w
parseWith DynFlags
df FilePath
fp P (GenLocated SrcSpanAnnA (HsDecl GhcPs))
GHC.parseDeclaration

parseStmt :: Parser (GHC.ExprLStmt GHC.GhcPs)
parseStmt :: Parser (ExprLStmt GhcPs)
parseStmt DynFlags
df FilePath
fp = DynFlags
-> FilePath
-> P (GenLocated
        SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs))))
-> FilePath
-> ParseResult
     (GenLocated
        SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs))))
forall w. DynFlags -> FilePath -> P w -> FilePath -> ParseResult w
parseWith DynFlags
df FilePath
fp P (GenLocated
     SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs))))
GHC.parseStatement

parsePattern :: Parser (GHC.LPat GHC.GhcPs)
parsePattern :: Parser (LPat GhcPs)
parsePattern DynFlags
df FilePath
fp = DynFlags
-> FilePath
-> P (GenLocated SrcSpanAnnA (Pat GhcPs))
-> FilePath
-> ParseResult (GenLocated SrcSpanAnnA (Pat GhcPs))
forall w. DynFlags -> FilePath -> P w -> FilePath -> ParseResult w
parseWith DynFlags
df FilePath
fp P (GenLocated SrcSpanAnnA (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 :: LibDir -> FilePath -> IO (ParseResult GHC.ParsedSource)
parseModule :: FilePath -> FilePath -> IO (ParseResult (Located HsModule))
parseModule FilePath
libdir FilePath
file = FilePath
-> CppOptions -> FilePath -> IO (ParseResult (Located HsModule))
parseModuleWithCpp FilePath
libdir CppOptions
defaultCppOptions FilePath
file


-- | 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
  :: LibDir -- GHC libdir
  -> FilePath
  -> String
  -> IO (ParseResult GHC.ParsedSource)
parseModuleFromString :: FilePath
-> FilePath -> FilePath -> IO (ParseResult (Located HsModule))
parseModuleFromString FilePath
libdir FilePath
fp FilePath
s = FilePath
-> Ghc (ParseResult (Located HsModule))
-> IO (ParseResult (Located HsModule))
forall a. FilePath -> Ghc a -> IO a
ghcWrapper FilePath
libdir (Ghc (ParseResult (Located HsModule))
 -> IO (ParseResult (Located HsModule)))
-> Ghc (ParseResult (Located HsModule))
-> IO (ParseResult (Located HsModule))
forall a b. (a -> b) -> a -> b
$ do
  DynFlags
dflags <- FilePath -> FilePath -> Ghc DynFlags
forall (m :: * -> *).
GhcMonad m =>
FilePath -> FilePath -> m DynFlags
initDynFlagsPure FilePath
fp FilePath
s
  ParseResult (Located HsModule)
-> Ghc (ParseResult (Located HsModule))
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseResult (Located HsModule)
 -> Ghc (ParseResult (Located HsModule)))
-> ParseResult (Located HsModule)
-> Ghc (ParseResult (Located HsModule))
forall a b. (a -> b) -> a -> b
$ Parser (Located HsModule)
parseModuleFromStringInternal DynFlags
dflags FilePath
fp FilePath
s

-- | Internal part of 'parseModuleFromString'.
parseModuleFromStringInternal :: Parser GHC.ParsedSource
parseModuleFromStringInternal :: Parser (Located HsModule)
parseModuleFromStringInternal DynFlags
dflags FilePath
fileName FilePath
str =
  let (FilePath
str1, [LEpaComment]
lp) = FilePath -> (FilePath, [LEpaComment])
stripLinePragmas FilePath
str
      res :: Either ErrorMessages ([LEpaComment], DynFlags, Located HsModule)
res        = case P (Located HsModule)
-> DynFlags
-> FilePath
-> FilePath
-> ParseResult (Located HsModule)
forall a. P a -> DynFlags -> FilePath -> FilePath -> ParseResult a
runParser P (Located HsModule)
GHC.parseModule DynFlags
dflags FilePath
fileName FilePath
str1 of
        GHC.PFailed PState
pst     -> ErrorMessages
-> Either ErrorMessages ([LEpaComment], DynFlags, Located HsModule)
forall a b. a -> Either a b
Left ((PsError -> MsgEnvelope DecoratedSDoc)
-> Bag PsError -> ErrorMessages
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsError -> MsgEnvelope DecoratedSDoc
GHC.pprError (Bag PsError -> ErrorMessages) -> Bag PsError -> ErrorMessages
forall a b. (a -> b) -> a -> b
$ PState -> Bag PsError
GHC.getErrorMessages PState
pst)
        GHC.POk     PState
_  Located HsModule
pmod -> ([LEpaComment], DynFlags, Located HsModule)
-> Either ErrorMessages ([LEpaComment], DynFlags, Located HsModule)
forall a b. b -> Either a b
Right ([LEpaComment]
lp, DynFlags
dflags, Located HsModule
pmod)
  in  Either ErrorMessages ([LEpaComment], DynFlags, Located HsModule)
-> ParseResult (Located HsModule)
forall a.
Either a ([LEpaComment], DynFlags, Located HsModule)
-> Either a (Located HsModule)
postParseTransform Either ErrorMessages ([LEpaComment], DynFlags, Located HsModule)
res

parseModuleWithOptions :: LibDir -- ^ GHC libdir
                       -> FilePath
                       -> IO (ParseResult GHC.ParsedSource)
parseModuleWithOptions :: FilePath -> FilePath -> IO (ParseResult (Located HsModule))
parseModuleWithOptions FilePath
libdir FilePath
fp =
  FilePath
-> CppOptions -> FilePath -> IO (ParseResult (Located HsModule))
parseModuleWithCpp FilePath
libdir CppOptions
defaultCppOptions FilePath
fp


-- | Parse a module with specific instructions for the C pre-processor.
parseModuleWithCpp
  :: LibDir -- ^ GHC libdir
  -> CppOptions
  -> FilePath -- ^ File to be parsed
  -> IO (ParseResult GHC.ParsedSource)
parseModuleWithCpp :: FilePath
-> CppOptions -> FilePath -> IO (ParseResult (Located HsModule))
parseModuleWithCpp FilePath
libdir CppOptions
cpp FilePath
fp = do
  Either ErrorMessages ([LEpaComment], DynFlags, Located HsModule)
res <- FilePath
-> CppOptions
-> FilePath
-> IO
     (Either ErrorMessages ([LEpaComment], DynFlags, Located HsModule))
parseModuleEpAnnsWithCpp FilePath
libdir CppOptions
cpp FilePath
fp
  ParseResult (Located HsModule)
-> IO (ParseResult (Located HsModule))
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseResult (Located HsModule)
 -> IO (ParseResult (Located HsModule)))
-> ParseResult (Located HsModule)
-> IO (ParseResult (Located HsModule))
forall a b. (a -> b) -> a -> b
$ Either ErrorMessages ([LEpaComment], DynFlags, Located HsModule)
-> ParseResult (Located HsModule)
forall a.
Either a ([LEpaComment], DynFlags, Located HsModule)
-> Either a (Located HsModule)
postParseTransform Either ErrorMessages ([LEpaComment], DynFlags, Located HsModule)
res

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

-- | Low level function which is used in the internal tests.
-- It is advised to use 'parseModule' or 'parseModuleWithCpp' instead of
-- this function.
parseModuleEpAnnsWithCpp
  :: LibDir -- ^ GHC libdir
  -> CppOptions
  -> FilePath -- ^ File to be parsed
  -> IO
       ( Either
           GHC.ErrorMessages
           ([GHC.LEpaComment], GHC.DynFlags, GHC.ParsedSource)
       )
parseModuleEpAnnsWithCpp :: FilePath
-> CppOptions
-> FilePath
-> IO
     (Either ErrorMessages ([LEpaComment], DynFlags, Located HsModule))
parseModuleEpAnnsWithCpp FilePath
libdir CppOptions
cppOptions FilePath
file = FilePath
-> Ghc
     (Either ErrorMessages ([LEpaComment], DynFlags, Located HsModule))
-> IO
     (Either ErrorMessages ([LEpaComment], DynFlags, Located HsModule))
forall a. FilePath -> Ghc a -> IO a
ghcWrapper FilePath
libdir (Ghc
   (Either ErrorMessages ([LEpaComment], DynFlags, Located HsModule))
 -> IO
      (Either ErrorMessages ([LEpaComment], DynFlags, Located HsModule)))
-> Ghc
     (Either ErrorMessages ([LEpaComment], DynFlags, Located HsModule))
-> IO
     (Either ErrorMessages ([LEpaComment], DynFlags, Located HsModule))
forall a b. (a -> b) -> a -> b
$ do
  DynFlags
dflags <- FilePath -> Ghc DynFlags
forall (m :: * -> *). GhcMonad m => FilePath -> m DynFlags
initDynFlags FilePath
file
  CppOptions
-> DynFlags
-> FilePath
-> Ghc
     (Either ErrorMessages ([LEpaComment], DynFlags, Located HsModule))
forall (m :: * -> *).
GhcMonad m =>
CppOptions
-> DynFlags
-> FilePath
-> m (Either
        ErrorMessages ([LEpaComment], DynFlags, Located HsModule))
parseModuleEpAnnsWithCppInternal CppOptions
cppOptions DynFlags
dflags FilePath
file

-- | Internal function. Default runner of GHC.Ghc action in IO.
ghcWrapper :: LibDir -> GHC.Ghc a -> IO a
ghcWrapper :: forall a. FilePath -> Ghc a -> IO a
ghcWrapper FilePath
libdir Ghc a
a =
  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) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ 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
a

-- | Internal function. Exposed if you want to muck with DynFlags
-- before parsing.
parseModuleEpAnnsWithCppInternal
  :: GHC.GhcMonad m
  => CppOptions
  -> GHC.DynFlags
  -> FilePath
  -> m
       ( Either
           GHC.ErrorMessages
           ([GHC.LEpaComment], GHC.DynFlags, GHC.ParsedSource)
       )
parseModuleEpAnnsWithCppInternal :: forall (m :: * -> *).
GhcMonad m =>
CppOptions
-> DynFlags
-> FilePath
-> m (Either
        ErrorMessages ([LEpaComment], DynFlags, Located HsModule))
parseModuleEpAnnsWithCppInternal CppOptions
cppOptions DynFlags
dflags FilePath
file = do
  let useCpp :: Bool
useCpp = Extension -> DynFlags -> Bool
GHC.xopt Extension
LangExt.Cpp DynFlags
dflags
  (FilePath
fileContents, [LEpaComment]
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
        [LEpaComment]
cppComments <- CppOptions -> FilePath -> m [LEpaComment]
forall (m :: * -> *).
GhcMonad m =>
CppOptions -> FilePath -> m [LEpaComment]
getCppTokensAsComments CppOptions
cppOptions FilePath
file
        (FilePath, [LEpaComment], DynFlags)
-> m (FilePath, [LEpaComment], DynFlags)
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
contents,[LEpaComment]
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,[LEpaComment]
lp) = FilePath -> (FilePath, [LEpaComment])
stripLinePragmas FilePath
txt
        (FilePath, [LEpaComment], DynFlags)
-> m (FilePath, [LEpaComment], DynFlags)
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
contents1,[LEpaComment]
lp,DynFlags
dflags)
  Either ErrorMessages ([LEpaComment], DynFlags, Located HsModule)
-> m (Either
        ErrorMessages ([LEpaComment], DynFlags, Located HsModule))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ErrorMessages ([LEpaComment], DynFlags, Located HsModule)
 -> m (Either
         ErrorMessages ([LEpaComment], DynFlags, Located HsModule)))
-> Either ErrorMessages ([LEpaComment], DynFlags, Located HsModule)
-> m (Either
        ErrorMessages ([LEpaComment], DynFlags, Located HsModule))
forall a b. (a -> b) -> a -> b
$
    case DynFlags -> FilePath -> FilePath -> ParseResult (Located HsModule)
parseFile DynFlags
dflags' FilePath
file FilePath
fileContents of
      GHC.PFailed PState
pst -> ErrorMessages
-> Either ErrorMessages ([LEpaComment], DynFlags, Located HsModule)
forall a b. a -> Either a b
Left ((PsError -> MsgEnvelope DecoratedSDoc)
-> Bag PsError -> ErrorMessages
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsError -> MsgEnvelope DecoratedSDoc
GHC.pprError (Bag PsError -> ErrorMessages) -> Bag PsError -> ErrorMessages
forall a b. (a -> b) -> a -> b
$ PState -> Bag PsError
GHC.getErrorMessages PState
pst)
      GHC.POk PState
_ Located HsModule
pmod  ->
        ([LEpaComment], DynFlags, Located HsModule)
-> Either ErrorMessages ([LEpaComment], DynFlags, Located HsModule)
forall a b. b -> Either a b
Right (([LEpaComment], DynFlags, Located HsModule)
 -> Either
      ErrorMessages ([LEpaComment], DynFlags, Located HsModule))
-> ([LEpaComment], DynFlags, Located HsModule)
-> Either ErrorMessages ([LEpaComment], DynFlags, Located HsModule)
forall a b. (a -> b) -> a -> b
$ ([LEpaComment]
injectedComments, DynFlags
dflags', Located HsModule -> Located HsModule
fixModuleTrailingComments Located HsModule
pmod)

-- | Internal function. Exposed if you want to muck with DynFlags
-- before parsing. Or after parsing.
postParseTransform
  :: Either a ([GHC.LEpaComment], GHC.DynFlags, GHC.ParsedSource)
  -> Either a (GHC.ParsedSource)
postParseTransform :: forall a.
Either a ([LEpaComment], DynFlags, Located HsModule)
-> Either a (Located HsModule)
postParseTransform Either a ([LEpaComment], DynFlags, Located HsModule)
parseRes = (([LEpaComment], DynFlags, Located HsModule) -> Located HsModule)
-> Either a ([LEpaComment], DynFlags, Located HsModule)
-> Either a (Located HsModule)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([LEpaComment], DynFlags, Located HsModule) -> Located HsModule
forall {a} {b}. (a, b, Located HsModule) -> Located HsModule
mkAnns Either a ([LEpaComment], DynFlags, Located HsModule)
parseRes
  where
    -- TODO:AZ perhaps inject the comments into the parsedsource here already
    mkAnns :: (a, b, Located HsModule) -> Located HsModule
mkAnns (a
_cs, b
_, Located HsModule
m) = Located HsModule -> Located HsModule
fixModuleTrailingComments Located HsModule
m

fixModuleTrailingComments :: GHC.ParsedSource -> GHC.ParsedSource
fixModuleTrailingComments :: Located HsModule -> Located HsModule
fixModuleTrailingComments (GHC.L SrcSpan
l HsModule
p) = SrcSpan -> HsModule -> Located HsModule
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
l HsModule
p'
  where
    an' :: EpAnn AnnsModule
an' = case HsModule -> EpAnn AnnsModule
GHC.hsmodAnn HsModule
p of
      (GHC.EpAnn Anchor
a AnnsModule
an EpAnnComments
ocs) -> Anchor -> AnnsModule -> EpAnnComments -> EpAnn AnnsModule
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
GHC.EpAnn Anchor
a AnnsModule
an (AnnList -> EpAnnComments -> EpAnnComments
rebalance (AnnsModule -> AnnList
GHC.am_decls AnnsModule
an) EpAnnComments
ocs)
      EpAnn AnnsModule
unused -> EpAnn AnnsModule
unused
    p' :: HsModule
p' = HsModule
p { hsmodAnn :: EpAnn AnnsModule
GHC.hsmodAnn = EpAnn AnnsModule
an' }
    -- p'  = error $ "fixModuleTrailingComments: an'=" ++ showAst an'

    rebalance :: GHC.AnnList -> GHC.EpAnnComments -> GHC.EpAnnComments
    rebalance :: AnnList -> EpAnnComments -> EpAnnComments
rebalance AnnList
al EpAnnComments
cs = EpAnnComments
cs'
      where
        cs' :: EpAnnComments
cs' = case AnnList -> Maybe AddEpAnn
GHC.al_close AnnList
al of
          Just (GHC.AddEpAnn AnnKeywordId
_ (GHC.EpaSpan RealSrcSpan
ss)) ->
            let
              pc :: [LEpaComment]
pc = EpAnnComments -> [LEpaComment]
GHC.priorComments EpAnnComments
cs
              fc :: [LEpaComment]
fc = EpAnnComments -> [LEpaComment]
GHC.getFollowingComments EpAnnComments
cs
              bf :: GenLocated Anchor e -> Bool
bf (GHC.L Anchor
anc e
_) = Anchor -> RealSrcSpan
GHC.anchor Anchor
anc RealSrcSpan -> RealSrcSpan -> Bool
forall a. Ord a => a -> a -> Bool
> RealSrcSpan
ss
              ([LEpaComment]
prior,[LEpaComment]
f) = (LEpaComment -> Bool)
-> [LEpaComment] -> ([LEpaComment], [LEpaComment])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break LEpaComment -> Bool
forall {e}. GenLocated Anchor e -> Bool
bf [LEpaComment]
fc
              cs'' :: EpAnnComments
cs'' = [LEpaComment] -> [LEpaComment] -> EpAnnComments
GHC.EpaCommentsBalanced ([LEpaComment]
pc [LEpaComment] -> [LEpaComment] -> [LEpaComment]
forall a. Semigroup a => a -> a -> a
<> [LEpaComment]
prior) [LEpaComment]
f
            in EpAnnComments
cs''
          Maybe AddEpAnn
_ -> EpAnnComments
cs

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

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

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