{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
module Language.Haskell.GHC.ExactPrint.Parsers (
Parser
, ParseResult
, withDynFlags
, CppOptions(..)
, defaultCppOptions
, LibDir
, parseModule
, parseModuleFromString
, parseModuleWithOptions
, parseModuleWithCpp
, parseExpr
, parseImport
, parseType
, parseDecl
, parsePattern
, parseStmt
, parseWith
, 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
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
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 :: * -> *).
(HasCallStack, GhcMonad m) =>
DynFlags -> m ()
GHC.setSessionDynFlags DynFlags
dflags
a -> Ghc a
forall a. 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 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
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
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
parseModuleFromString
:: 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
DynFlags
dflags <- FilePath -> FilePath -> Ghc DynFlags
forall (m :: * -> *).
GhcMonad m =>
FilePath -> FilePath -> m DynFlags
initDynFlagsPure FilePath
fp FilePath
s
ParseResult (Located (HsModule GhcPs))
-> Ghc (ParseResult (Located (HsModule GhcPs)))
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseResult (Located (HsModule GhcPs))
-> Ghc (ParseResult (Located (HsModule GhcPs))))
-> ParseResult (Located (HsModule GhcPs))
-> Ghc (ParseResult (Located (HsModule GhcPs)))
forall a b. (a -> b) -> a -> b
$ Parser (Located (HsModule GhcPs))
parseModuleFromStringInternal DynFlags
dflags FilePath
fp FilePath
s
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
-> 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
parseModuleWithCpp
:: LibDir
-> CppOptions
-> FilePath
-> IO (ParseResult GHC.ParsedSource)
parseModuleWithCpp :: FilePath
-> CppOptions
-> FilePath
-> IO (ParseResult (Located (HsModule GhcPs)))
parseModuleWithCpp FilePath
libdir CppOptions
cpp FilePath
fp = do
Either
ErrorMessages ([LEpaComment], DynFlags, Located (HsModule GhcPs))
res <- FilePath
-> CppOptions
-> FilePath
-> IO
(Either
ErrorMessages ([LEpaComment], DynFlags, Located (HsModule GhcPs)))
parseModuleEpAnnsWithCpp FilePath
libdir CppOptions
cpp FilePath
fp
ParseResult (Located (HsModule GhcPs))
-> IO (ParseResult (Located (HsModule GhcPs)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseResult (Located (HsModule GhcPs))
-> IO (ParseResult (Located (HsModule GhcPs))))
-> ParseResult (Located (HsModule GhcPs))
-> IO (ParseResult (Located (HsModule GhcPs)))
forall a b. (a -> b) -> a -> b
$ Either
ErrorMessages ([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
parseModuleEpAnnsWithCpp
:: LibDir
-> CppOptions
-> FilePath
-> 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
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 GhcPs)))
forall (m :: * -> *).
GhcMonad m =>
CppOptions
-> DynFlags
-> FilePath
-> m (Either
ErrorMessages ([LEpaComment], DynFlags, Located (HsModule GhcPs)))
parseModuleEpAnnsWithCppInternal CppOptions
cppOptions DynFlags
dflags FilePath
file
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
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
(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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
contents,[LEpaComment]
cppComments,DynFlags
dflags1)
else do
FilePath
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 (FilePath
contents1,[LEpaComment]
lp) = FilePath -> (FilePath, [LEpaComment])
stripLinePragmas FilePath
txt
(FilePath, [LEpaComment], DynFlags)
-> m (FilePath, [LEpaComment], DynFlags)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
contents1,[LEpaComment]
lp,DynFlags
dflags)
Either
ErrorMessages ([LEpaComment], DynFlags, Located (HsModule GhcPs))
-> m (Either
ErrorMessages ([LEpaComment], DynFlags, Located (HsModule GhcPs)))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
ErrorMessages ([LEpaComment], DynFlags, Located (HsModule GhcPs))
-> m (Either
ErrorMessages ([LEpaComment], DynFlags, Located (HsModule GhcPs))))
-> Either
ErrorMessages ([LEpaComment], DynFlags, Located (HsModule GhcPs))
-> m (Either
ErrorMessages ([LEpaComment], 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
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)
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
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
(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 Anchor
a AnnsModule
an EpAnnComments
ocs) -> Anchor -> AnnsModule -> EpAnnComments -> EpAnn AnnsModule
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
GHC.EpAnn Anchor
a AnnsModule
an (EpAnnComments -> EpAnnComments
rebalance EpAnnComments
ocs)
EpAnn AnnsModule
unused -> EpAnn AnnsModule
unused
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 -> LayoutInfo GhcPs
GHC.hsmodLayout (XModulePs -> LayoutInfo GhcPs) -> XModulePs -> LayoutInfo GhcPs
forall a b. (a -> b) -> a -> b
$ HsModule GhcPs -> XCModule GhcPs
forall p. HsModule p -> XCModule p
GHC.hsmodExt HsModule GhcPs
p of
GHC.ExplicitBraces LHsToken "{" GhcPs
_ (GHC.L (GHC.TokenLoc (GHC.EpaSpan RealSrcSpan
ss Maybe BufSpan
_)) HsToken "}"
_) ->
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''
LayoutInfo GhcPs
_ -> EpAnnComments
cs
fixModuleHeaderComments :: GHC.ParsedSource -> GHC.ParsedSource
(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 EpaLocation
_loc dd :: LHsDecl GhcPs
dd@(GHC.L (GHC.SrcSpanAnn EpAnn AnnListItem
GHC.EpAnnNotUsed SrcSpan
_) HsDecl GhcPs
_) EpAnnComments
cs = (LHsDecl GhcPs
dd,EpAnnComments
cs)
moveComments (GHC.EpaSpan RealSrcSpan
r Maybe BufSpan
_) (GHC.L (GHC.SrcSpanAnn (GHC.EpAnn Anchor
anc AnnListItem
an EpAnnComments
csd) SrcSpan
ll) HsDecl GhcPs
a) EpAnnComments
cs = (LHsDecl GhcPs
GenLocated SrcSpanAnnA (HsDecl GhcPs)
dd,EpAnnComments
css)
where
pc :: [LEpaComment]
pc = EpAnnComments -> [LEpaComment]
GHC.priorComments EpAnnComments
csd
fc :: [LEpaComment]
fc = EpAnnComments -> [LEpaComment]
GHC.getFollowingComments EpAnnComments
csd
bf :: GenLocated Anchor e -> Bool
bf (GHC.L Anchor
anch e
_) = Anchor -> RealSrcSpan
GHC.anchor Anchor
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 {e}. GenLocated Anchor 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 (EpAnn AnnListItem -> SrcSpan -> SrcSpanAnnA
forall a. a -> SrcSpan -> SrcSpanAnn' a
GHC.SrcSpanAnn (Anchor -> AnnListItem -> EpAnnComments -> EpAnn AnnListItem
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
GHC.EpAnn Anchor
anc AnnListItem
an EpAnnComments
csd') SrcSpan
ll) 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, EpAnn AnnsModule
GHC.EpAnnNotUsed) = ([LHsDecl GhcPs]
ds, EpAnn AnnsModule
forall ann. EpAnn ann
GHC.EpAnnNotUsed)
rebalance ([LHsDecl GhcPs]
ds, GHC.EpAnn Anchor
a AnnsModule
an EpAnnComments
cs) = ([LHsDecl GhcPs]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
ds1, Anchor -> AnnsModule -> EpAnnComments -> EpAnn AnnsModule
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
GHC.EpAnn Anchor
a AnnsModule
an EpAnnComments
cs')
where
([GenLocated SrcSpanAnnA (HsDecl GhcPs)]
ds1,EpAnnComments
cs') = case (AddEpAnn -> Bool) -> [AddEpAnn] -> ([AddEpAnn], [AddEpAnn])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (\(GHC.AddEpAnn AnnKeywordId
k EpaLocation
_) -> AnnKeywordId
k AnnKeywordId -> AnnKeywordId -> Bool
forall a. Eq a => a -> a -> Bool
== AnnKeywordId
GHC.AnnWhere) (AnnsModule -> [AddEpAnn]
GHC.am_main AnnsModule
an) of
([AddEpAnn]
_, (GHC.AddEpAnn AnnKeywordId
_ EpaLocation
whereLoc:[AddEpAnn]
_)) ->
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)
([AddEpAnn], [AddEpAnn])
_ -> ([LHsDecl GhcPs]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
ds,EpAnnComments
cs)
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
let parser_opts0 :: ParserOpts
parser_opts0 = DynFlags -> ParserOpts
GHC.initParserOpts DynFlags
dflags0
(Messages PsMessage
_, [Located FilePath]
src_opts) <- IO (Messages PsMessage, [Located FilePath])
-> m (Messages PsMessage, [Located FilePath])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
GHC.liftIO (IO (Messages PsMessage, [Located FilePath])
-> m (Messages PsMessage, [Located FilePath]))
-> IO (Messages PsMessage, [Located FilePath])
-> m (Messages PsMessage, [Located FilePath])
forall a b. (a -> b) -> a -> b
$ ParserOpts
-> FilePath -> IO (Messages PsMessage, [Located FilePath])
GHC.getOptionsFromFile ParserOpts
parser_opts0 FilePath
file
(DynFlags
dflags1, [Located FilePath]
_, Messages DriverMessage
_) <- DynFlags
-> [Located FilePath]
-> m (DynFlags, [Located FilePath], Messages DriverMessage)
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located FilePath]
-> m (DynFlags, [Located FilePath], Messages DriverMessage)
GHC.parseDynamicFilePragma DynFlags
dflags0 [Located FilePath]
src_opts
let dflags2 :: DynFlags
dflags2 = DynFlags
dflags1 DynFlags -> GeneralFlag -> DynFlags
`GHC.gopt_set` GeneralFlag
GHC.Opt_KeepRawTokenStream
(DynFlags
dflags3, [Located FilePath]
_, Messages DriverMessage
_) <- DynFlags
-> [Located FilePath]
-> m (DynFlags, [Located FilePath], Messages DriverMessage)
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located FilePath]
-> m (DynFlags, [Located FilePath], Messages DriverMessage)
GHC.parseDynamicFlagsCmdLine
DynFlags
dflags2
[FilePath -> Located FilePath
forall e. e -> Located e
GHC.noLoc FilePath
"-hide-all-packages"]
()
_ <- DynFlags -> m ()
forall (m :: * -> *).
(HasCallStack, GhcMonad m) =>
DynFlags -> m ()
GHC.setSessionDynFlags DynFlags
dflags3
DynFlags -> m DynFlags
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags
dflags3
initDynFlagsPure :: GHC.GhcMonad m => FilePath -> String -> m GHC.DynFlags
initDynFlagsPure :: forall (m :: * -> *).
GhcMonad m =>
FilePath -> FilePath -> m DynFlags
initDynFlagsPure FilePath
fp FilePath
s = do
DynFlags
dflags0 <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
let parser_opts0 :: ParserOpts
parser_opts0 = DynFlags -> ParserOpts
GHC.initParserOpts DynFlags
dflags0
let (Messages PsMessage
_, [Located FilePath]
pragmaInfo) = ParserOpts
-> StringBuffer
-> FilePath
-> (Messages PsMessage, [Located FilePath])
GHC.getOptions ParserOpts
parser_opts0 (FilePath -> StringBuffer
GHC.stringToStringBuffer (FilePath -> StringBuffer) -> FilePath -> StringBuffer
forall a b. (a -> b) -> a -> b
$ FilePath
s) FilePath
fp
(DynFlags
dflags1, [Located FilePath]
_, Messages DriverMessage
_) <- DynFlags
-> [Located FilePath]
-> m (DynFlags, [Located FilePath], Messages DriverMessage)
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located FilePath]
-> m (DynFlags, [Located FilePath], Messages DriverMessage)
GHC.parseDynamicFilePragma DynFlags
dflags0 [Located FilePath]
pragmaInfo
let dflags2 :: DynFlags
dflags2 = DynFlags
dflags1 DynFlags -> GeneralFlag -> DynFlags
`GHC.gopt_set` GeneralFlag
GHC.Opt_KeepRawTokenStream
(DynFlags
dflags3, [Located FilePath]
_, Messages DriverMessage
_) <- DynFlags
-> [Located FilePath]
-> m (DynFlags, [Located FilePath], Messages DriverMessage)
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located FilePath]
-> m (DynFlags, [Located FilePath], Messages DriverMessage)
GHC.parseDynamicFlagsCmdLine
DynFlags
dflags2
[FilePath -> Located FilePath
forall e. e -> Located e
GHC.noLoc FilePath
"-hide-all-packages"]
()
_ <- DynFlags -> m ()
forall (m :: * -> *).
(HasCallStack, GhcMonad m) =>
DynFlags -> m ()
GHC.setSessionDynFlags DynFlags
dflags3
DynFlags -> m DynFlags
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags
dflags3