{-# 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 Data.Functor (void)

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.Parser as GHC
import qualified GHC.Driver.Errors.Types 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.LanguageExtensions as LangExt

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

-- | 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 (PsMessage -> GhcMessage
GHC.GhcPsMessage (PsMessage -> GhcMessage) -> Messages PsMessage -> ErrorMessages
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PState -> Messages PsMessage
GHC.getPsErrorMessages 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 a b. P a -> (a -> P b) -> P b
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 (PsMessage -> GhcMessage
GHC.GhcPsMessage (PsMessage -> GhcMessage) -> Messages PsMessage -> ErrorMessages
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PState -> Messages PsMessage
GHC.getPsErrorMessages 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
  dflags <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
  void $ GHC.setSessionDynFlags dflags
  return (action dflags)

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

parseFile :: GHC.DynFlags -> FilePath -> String -> GHC.ParseResult (GHC.Located (GHC.HsModule GHC.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 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 GhcPs)))
parseModule FilePath
libdir FilePath
file = FilePath
-> CppOptions
-> FilePath
-> IO (ParseResult (Located (HsModule GhcPs)))
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 GhcPs)))
parseModuleFromString FilePath
libdir FilePath
fp FilePath
s = FilePath
-> Ghc (ParseResult (Located (HsModule GhcPs)))
-> IO (ParseResult (Located (HsModule GhcPs)))
forall a. FilePath -> Ghc a -> IO a
ghcWrapper FilePath
libdir (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
  dflags <- FilePath -> FilePath -> Ghc DynFlags
forall (m :: * -> *).
GhcMonad m =>
FilePath -> FilePath -> m DynFlags
initDynFlagsPure FilePath
fp FilePath
s
  return $ parseModuleFromStringInternal dflags fp s

-- | Internal part of 'parseModuleFromString'.
parseModuleFromStringInternal :: Parser GHC.ParsedSource
parseModuleFromStringInternal :: Parser (Located (HsModule GhcPs))
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 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
        GHC.PFailed PState
pst
          -> ErrorMessages
-> Either
     ErrorMessages ([LEpaComment], DynFlags, Located (HsModule GhcPs))
forall a b. a -> Either a b
Left (PsMessage -> GhcMessage
GHC.GhcPsMessage (PsMessage -> GhcMessage) -> Messages PsMessage -> ErrorMessages
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PState -> Messages PsMessage
GHC.getPsErrorMessages PState
pst)
        GHC.POk     PState
_  Located (HsModule GhcPs)
pmod
          -> ([LEpaComment], DynFlags, Located (HsModule GhcPs))
-> Either
     ErrorMessages ([LEpaComment], DynFlags, Located (HsModule GhcPs))
forall a b. b -> Either a b
Right ([LEpaComment]
lp, DynFlags
dflags, Located (HsModule GhcPs)
pmod)
  in  Either
  ErrorMessages ([LEpaComment], DynFlags, Located (HsModule GhcPs))
-> ParseResult (Located (HsModule GhcPs))
forall a.
Either a ([LEpaComment], DynFlags, Located (HsModule GhcPs))
-> Either a (Located (HsModule GhcPs))
postParseTransform Either
  ErrorMessages ([LEpaComment], DynFlags, Located (HsModule GhcPs))
res

parseModuleWithOptions :: LibDir -- ^ GHC libdir
                       -> FilePath
                       -> IO (ParseResult GHC.ParsedSource)
parseModuleWithOptions :: FilePath -> FilePath -> IO (ParseResult (Located (HsModule GhcPs)))
parseModuleWithOptions FilePath
libdir FilePath
fp =
  FilePath
-> CppOptions
-> FilePath
-> IO (ParseResult (Located (HsModule GhcPs)))
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 GhcPs)))
parseModuleWithCpp FilePath
libdir CppOptions
cpp FilePath
fp = do
  res <- FilePath
-> CppOptions
-> FilePath
-> IO
     (Either
        ErrorMessages ([LEpaComment], DynFlags, Located (HsModule GhcPs)))
parseModuleEpAnnsWithCpp FilePath
libdir CppOptions
cpp FilePath
fp
  return $ postParseTransform 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 GhcPs)))
parseModuleEpAnnsWithCpp FilePath
libdir CppOptions
cppOptions FilePath
file = FilePath
-> Ghc
     (Either
        ErrorMessages ([LEpaComment], DynFlags, Located (HsModule GhcPs)))
-> IO
     (Either
        ErrorMessages ([LEpaComment], DynFlags, Located (HsModule GhcPs)))
forall a. FilePath -> Ghc a -> IO a
ghcWrapper FilePath
libdir (Ghc
   (Either
      ErrorMessages ([LEpaComment], DynFlags, Located (HsModule GhcPs)))
 -> IO
      (Either
         ErrorMessages ([LEpaComment], DynFlags, Located (HsModule GhcPs))))
-> Ghc
     (Either
        ErrorMessages ([LEpaComment], DynFlags, Located (HsModule GhcPs)))
-> IO
     (Either
        ErrorMessages ([LEpaComment], DynFlags, Located (HsModule GhcPs)))
forall a b. (a -> b) -> a -> b
$ do
  dflags <- FilePath -> Ghc DynFlags
forall (m :: * -> *). GhcMonad m => FilePath -> m DynFlags
initDynFlags FilePath
file
  parseModuleEpAnnsWithCppInternal cppOptions dflags 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 GhcPs)))
parseModuleEpAnnsWithCppInternal CppOptions
cppOptions DynFlags
dflags FilePath
file = do
  let useCpp :: Bool
useCpp = Extension -> DynFlags -> Bool
GHC.xopt Extension
LangExt.Cpp DynFlags
dflags
  (fileContents, injectedComments, dflags') <-
    if Bool
useCpp
      then do
        (contents,dflags1) <- CppOptions -> FilePath -> m (FilePath, DynFlags)
forall (m :: * -> *).
GhcMonad m =>
CppOptions -> FilePath -> m (FilePath, DynFlags)
getPreprocessedSrcDirect CppOptions
cppOptions FilePath
file
        cppComments <- getCppTokensAsComments cppOptions file
        return (contents,cppComments,dflags1)
      else do
        txt <- IO FilePath -> m FilePath
forall a. IO a -> m a
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,lp) = stripLinePragmas txt
        return (contents1,lp,dflags)
  return $
    case parseFile dflags' file fileContents of
      GHC.PFailed PState
pst
        -> ErrorMessages
-> Either
     ErrorMessages ([LEpaComment], DynFlags, Located (HsModule GhcPs))
forall a b. a -> Either a b
Left (PsMessage -> GhcMessage
GHC.GhcPsMessage (PsMessage -> GhcMessage) -> Messages PsMessage -> ErrorMessages
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PState -> Messages PsMessage
GHC.getPsErrorMessages PState
pst)
      GHC.POk PState
_ Located (HsModule GhcPs)
pmod
        -> ([LEpaComment], DynFlags, Located (HsModule GhcPs))
-> Either
     ErrorMessages ([LEpaComment], DynFlags, Located (HsModule GhcPs))
forall a b. b -> Either a b
Right (([LEpaComment], DynFlags, Located (HsModule GhcPs))
 -> Either
      ErrorMessages ([LEpaComment], DynFlags, Located (HsModule GhcPs)))
-> ([LEpaComment], DynFlags, Located (HsModule GhcPs))
-> Either
     ErrorMessages ([LEpaComment], DynFlags, Located (HsModule GhcPs))
forall a b. (a -> b) -> a -> b
$ ([LEpaComment]
injectedComments, DynFlags
dflags', Located (HsModule GhcPs) -> Located (HsModule GhcPs)
fixModuleComments Located (HsModule GhcPs)
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 GhcPs))
-> Either a (Located (HsModule GhcPs))
postParseTransform Either a ([LEpaComment], DynFlags, Located (HsModule GhcPs))
parseRes = (([LEpaComment], DynFlags, Located (HsModule GhcPs))
 -> Located (HsModule GhcPs))
-> Either a ([LEpaComment], DynFlags, Located (HsModule GhcPs))
-> Either a (Located (HsModule GhcPs))
forall a b. (a -> b) -> Either a a -> Either a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([LEpaComment], DynFlags, Located (HsModule GhcPs))
-> Located (HsModule GhcPs)
forall {a} {b}.
(a, b, Located (HsModule GhcPs)) -> Located (HsModule GhcPs)
mkAnns Either a ([LEpaComment], DynFlags, Located (HsModule GhcPs))
parseRes
  where
    mkAnns :: (a, b, Located (HsModule GhcPs)) -> Located (HsModule GhcPs)
mkAnns (a
_cs, b
_, Located (HsModule GhcPs)
m) = Located (HsModule GhcPs) -> Located (HsModule GhcPs)
fixModuleComments Located (HsModule GhcPs)
m

fixModuleComments :: GHC.ParsedSource -> GHC.ParsedSource
fixModuleComments :: Located (HsModule GhcPs) -> Located (HsModule GhcPs)
fixModuleComments Located (HsModule GhcPs)
p = Located (HsModule GhcPs) -> Located (HsModule GhcPs)
fixModuleHeaderComments (Located (HsModule GhcPs) -> Located (HsModule GhcPs))
-> Located (HsModule GhcPs) -> Located (HsModule GhcPs)
forall a b. (a -> b) -> a -> b
$ Located (HsModule GhcPs) -> Located (HsModule GhcPs)
fixModuleTrailingComments Located (HsModule GhcPs)
p

fixModuleTrailingComments :: GHC.ParsedSource -> GHC.ParsedSource
fixModuleTrailingComments :: Located (HsModule GhcPs) -> Located (HsModule GhcPs)
fixModuleTrailingComments (GHC.L SrcSpan
l HsModule GhcPs
p) = SrcSpan -> HsModule GhcPs -> Located (HsModule GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
l HsModule GhcPs
p'
  where
    an' :: EpAnn AnnsModule
an' = case XModulePs -> EpAnn AnnsModule
GHC.hsmodAnn (XModulePs -> EpAnn AnnsModule) -> XModulePs -> EpAnn AnnsModule
forall a b. (a -> b) -> a -> b
$ HsModule GhcPs -> XCModule GhcPs
forall p. HsModule p -> XCModule p
GHC.hsmodExt HsModule GhcPs
p of
      (GHC.EpAnn EpaLocation
a AnnsModule
an EpAnnComments
ocs) -> EpaLocation -> AnnsModule -> EpAnnComments -> EpAnn AnnsModule
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
GHC.EpAnn EpaLocation
a AnnsModule
an (EpAnnComments -> EpAnnComments
rebalance EpAnnComments
ocs)
    p' :: HsModule GhcPs
p' = HsModule GhcPs
p { GHC.hsmodExt = (GHC.hsmodExt p){ GHC.hsmodAnn = an' } }

    rebalance :: GHC.EpAnnComments -> GHC.EpAnnComments
    rebalance :: EpAnnComments -> EpAnnComments
rebalance EpAnnComments
cs = EpAnnComments
cs'
      where
        cs' :: EpAnnComments
cs' = case XModulePs -> EpLayout
GHC.hsmodLayout (XModulePs -> EpLayout) -> XModulePs -> EpLayout
forall a b. (a -> b) -> a -> b
$ HsModule GhcPs -> XCModule GhcPs
forall p. HsModule p -> XCModule p
GHC.hsmodExt HsModule GhcPs
p of
          GHC.EpExplicitBraces EpToken "{"
_ (GHC.EpTok (GHC.EpaSpan (GHC.RealSrcSpan RealSrcSpan
ss Maybe BufSpan
_))) ->
            let
              pc :: [LEpaComment]
pc = EpAnnComments -> [LEpaComment]
GHC.priorComments EpAnnComments
cs
              fc :: [LEpaComment]
fc = EpAnnComments -> [LEpaComment]
GHC.getFollowingComments EpAnnComments
cs
              bf :: GenLocated (EpaLocation' a) e -> Bool
bf (GHC.L EpaLocation' a
anc e
_) = EpaLocation' a -> RealSrcSpan
forall a. EpaLocation' a -> RealSrcSpan
GHC.epaLocationRealSrcSpan EpaLocation' a
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 {a} {e}. GenLocated (EpaLocation' a) 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''
          EpLayout
_ -> EpAnnComments
cs

-- Deal with https://gitlab.haskell.org/ghc/ghc/-/issues/23984
-- The Lexer works bottom-up, so does not have module declaration info
-- when the first top decl processed
fixModuleHeaderComments :: GHC.ParsedSource -> GHC.ParsedSource
fixModuleHeaderComments :: Located (HsModule GhcPs) -> Located (HsModule GhcPs)
fixModuleHeaderComments (GHC.L SrcSpan
l HsModule GhcPs
p) = SrcSpan -> HsModule GhcPs -> Located (HsModule GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
l HsModule GhcPs
p'
  where
    moveComments :: GHC.EpaLocation -> GHC.LHsDecl GHC.GhcPs -> GHC.EpAnnComments
                 -> (GHC.LHsDecl GHC.GhcPs, GHC.EpAnnComments)
    moveComments :: EpaLocation
-> LHsDecl GhcPs -> EpAnnComments -> (LHsDecl GhcPs, EpAnnComments)
moveComments GHC.EpaDelta{} LHsDecl GhcPs
dd EpAnnComments
cs = (LHsDecl GhcPs
dd,EpAnnComments
cs)
    moveComments (GHC.EpaSpan (GHC.UnhelpfulSpan UnhelpfulSpanReason
_)) LHsDecl GhcPs
dd EpAnnComments
cs = (LHsDecl GhcPs
dd,EpAnnComments
cs)
    moveComments (GHC.EpaSpan (GHC.RealSrcSpan RealSrcSpan
r Maybe BufSpan
_)) (GHC.L (GHC.EpAnn EpaLocation
anc AnnListItem
an EpAnnComments
csd) HsDecl GhcPs
a) EpAnnComments
cs = (LHsDecl GhcPs
GenLocated SrcSpanAnnA (HsDecl GhcPs)
dd,EpAnnComments
css)
      where
        -- Move any comments on the decl that occur prior to the location
        pc :: [LEpaComment]
pc = EpAnnComments -> [LEpaComment]
GHC.priorComments EpAnnComments
csd
        fc :: [LEpaComment]
fc = EpAnnComments -> [LEpaComment]
GHC.getFollowingComments EpAnnComments
csd
        bf :: GenLocated (EpaLocation' a) e -> Bool
bf (GHC.L EpaLocation' a
anch e
_) = EpaLocation' a -> RealSrcSpan
forall a. EpaLocation' a -> RealSrcSpan
GHC.epaLocationRealSrcSpan EpaLocation' a
anch RealSrcSpan -> RealSrcSpan -> Bool
forall a. Ord a => a -> a -> Bool
> RealSrcSpan
r
        ([LEpaComment]
move,[LEpaComment]
keep) = (LEpaComment -> Bool)
-> [LEpaComment] -> ([LEpaComment], [LEpaComment])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break LEpaComment -> Bool
forall {a} {e}. GenLocated (EpaLocation' a) e -> Bool
bf [LEpaComment]
pc
        csd' :: EpAnnComments
csd' = [LEpaComment] -> [LEpaComment] -> EpAnnComments
GHC.EpaCommentsBalanced [LEpaComment]
keep [LEpaComment]
fc

        dd :: GenLocated SrcSpanAnnA (HsDecl GhcPs)
dd = SrcSpanAnnA
-> HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs)
forall l e. l -> e -> GenLocated l e
GHC.L (EpaLocation -> AnnListItem -> EpAnnComments -> SrcSpanAnnA
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
GHC.EpAnn EpaLocation
anc AnnListItem
an EpAnnComments
csd') HsDecl GhcPs
a
        css :: EpAnnComments
css = EpAnnComments
cs EpAnnComments -> EpAnnComments -> EpAnnComments
forall a. Semigroup a => a -> a -> a
<> [LEpaComment] -> EpAnnComments
GHC.EpaComments [LEpaComment]
move

    ([LHsDecl GhcPs]
ds',EpAnn AnnsModule
an') = ([LHsDecl GhcPs], EpAnn AnnsModule)
-> ([LHsDecl GhcPs], EpAnn AnnsModule)
rebalance (HsModule GhcPs -> [LHsDecl GhcPs]
forall p. HsModule p -> [LHsDecl p]
GHC.hsmodDecls HsModule GhcPs
p, XModulePs -> EpAnn AnnsModule
GHC.hsmodAnn (XModulePs -> EpAnn AnnsModule) -> XModulePs -> EpAnn AnnsModule
forall a b. (a -> b) -> a -> b
$ HsModule GhcPs -> XCModule GhcPs
forall p. HsModule p -> XCModule p
GHC.hsmodExt HsModule GhcPs
p)
    p' :: HsModule GhcPs
p' = HsModule GhcPs
p { GHC.hsmodExt = (GHC.hsmodExt p){ GHC.hsmodAnn = an' },
             GHC.hsmodDecls = ds'
           }

    rebalance :: ([GHC.LHsDecl GHC.GhcPs], GHC.EpAnn GHC.AnnsModule)
              -> ([GHC.LHsDecl GHC.GhcPs], GHC.EpAnn GHC.AnnsModule)
    rebalance :: ([LHsDecl GhcPs], EpAnn AnnsModule)
-> ([LHsDecl GhcPs], EpAnn AnnsModule)
rebalance ([LHsDecl GhcPs]
ds, GHC.EpAnn EpaLocation
a AnnsModule
an EpAnnComments
cs) = ([LHsDecl GhcPs]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
ds1, EpaLocation -> AnnsModule -> EpAnnComments -> EpAnn AnnsModule
forall ann. EpaLocation -> ann -> EpAnnComments -> EpAnn ann
GHC.EpAnn EpaLocation
a AnnsModule
an EpAnnComments
cs')
      where
        ([GenLocated SrcSpanAnnA (HsDecl GhcPs)]
ds1,EpAnnComments
cs') = case AnnsModule -> EpToken "where"
GHC.am_where AnnsModule
an of
                     GHC.EpTok EpaLocation
whereLoc ->
                           case HsModule GhcPs -> [LHsDecl GhcPs]
forall p. HsModule p -> [LHsDecl p]
GHC.hsmodDecls HsModule GhcPs
p of
                               (LHsDecl GhcPs
d:[LHsDecl GhcPs]
ds0) -> (GenLocated SrcSpanAnnA (HsDecl GhcPs)
d'GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. a -> [a] -> [a]
:[LHsDecl GhcPs]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
ds0, EpAnnComments
cs0)
                                   where (LHsDecl GhcPs
d',EpAnnComments
cs0) = EpaLocation
-> LHsDecl GhcPs -> EpAnnComments -> (LHsDecl GhcPs, EpAnnComments)
moveComments EpaLocation
whereLoc LHsDecl GhcPs
d EpAnnComments
cs
                               [LHsDecl GhcPs]
ds0 -> ([LHsDecl GhcPs]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
ds0,EpAnnComments
cs)
                     EpToken "where"
_ -> ([LHsDecl GhcPs]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
ds,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
  -- Based on GHC backpack driver doBackPack
  dflags0         <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
  let parser_opts0 = DynFlags -> ParserOpts
GHC.initParserOpts DynFlags
dflags0
  (_, src_opts)   <- GHC.liftIO $ GHC.getOptionsFromFile parser_opts0 file
  (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 src_opts
  -- Turn this on last to avoid T10942
  let dflags2 = DynFlags
dflags1 DynFlags -> GeneralFlag -> DynFlags
`GHC.gopt_set` GeneralFlag
GHC.Opt_KeepRawTokenStream
  -- Prevent parsing of .ghc.environment.* "package environment files"
  (dflags3, _, _) <- GHC.parseDynamicFlagsCmdLine
    dflags2
    [GHC.noLoc "-hide-all-packages"]
  _ <- GHC.setSessionDynFlags dflags3
  return 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
  -- AZ Note: "I" below appears to be Lennart Spitzner
  -- 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.
  dflags0 <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
  let parser_opts0 = DynFlags -> ParserOpts
GHC.initParserOpts DynFlags
dflags0
  let (_, pragmaInfo) = GHC.getOptions parser_opts0 (GHC.stringToStringBuffer $ s) fp
  (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 pragmaInfo
  -- Turn this on last to avoid T10942
  let dflags2 = DynFlags
dflags1 DynFlags -> GeneralFlag -> DynFlags
`GHC.gopt_set` GeneralFlag
GHC.Opt_KeepRawTokenStream
  -- Prevent parsing of .ghc.environment.* "package environment files"
  (dflags3, _, _) <- GHC.parseDynamicFlagsCmdLine
    dflags2
    [GHC.noLoc "-hide-all-packages"]
  _ <- GHC.setSessionDynFlags dflags3
  return dflags3

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