{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
module GHC.All(
CppFlags(..), ParseFlags(..), defaultParseFlags,
parseFlagsAddFixities, parseFlagsSetLanguage,
ParseError(..), ModuleEx(..),
parseModuleEx, createModuleEx, createModuleExWithFixities, ghcComments, modComments,
parseExpGhcWithMode, parseImportDeclGhcWithMode, parseDeclGhcWithMode,
) where
import GHC.Driver.Ppr
import Control.Monad.Trans.Except
import Control.Monad.IO.Class
import Util
import Data.Char
import Data.List.Extra
import Timing
import Language.Preprocessor.Cpphs
import System.IO.Extra
import Fixity
import Extension
import GHC.Data.FastString
import GHC.Hs
import GHC.Types.SrcLoc
import GHC.Types.Fixity
import GHC.Types.Error
import GHC.Driver.Errors.Types
import GHC.Utils.Error
import GHC.Parser.Lexer hiding (context)
import GHC.LanguageExtensions.Type
import GHC.Driver.Session hiding (extensions)
import GHC.Data.Bag
import Data.Generics.Uniplate.DataOnly
import Language.Haskell.GhclibParserEx.GHC.Parser
import Language.Haskell.GhclibParserEx.Fixity
import GHC.Util
data CppFlags
= CppSimple
| Cpphs CpphsOptions
data ParseFlags = ParseFlags
{ParseFlags -> CppFlags
cppFlags :: CppFlags
,ParseFlags -> Maybe Language
baseLanguage :: Maybe Language
,ParseFlags -> [Extension]
enabledExtensions :: [Extension]
,ParseFlags -> [Extension]
disabledExtensions :: [Extension]
,ParseFlags -> [FixityInfo]
fixities :: [FixityInfo]
}
defaultParseFlags :: ParseFlags
defaultParseFlags :: ParseFlags
defaultParseFlags = CppFlags
-> Maybe Language
-> [Extension]
-> [Extension]
-> [FixityInfo]
-> ParseFlags
ParseFlags CppFlags
CppSimple Maybe Language
forall a. Maybe a
Nothing [Extension]
defaultExtensions [] [FixityInfo]
defaultFixities
parseFlagsAddFixities :: [FixityInfo] -> ParseFlags -> ParseFlags
parseFlagsAddFixities :: [FixityInfo] -> ParseFlags -> ParseFlags
parseFlagsAddFixities [FixityInfo]
fx ParseFlags
x = ParseFlags
x{fixities :: [FixityInfo]
fixities = [FixityInfo]
fx [FixityInfo] -> [FixityInfo] -> [FixityInfo]
forall a. [a] -> [a] -> [a]
++ ParseFlags -> [FixityInfo]
fixities ParseFlags
x}
parseFlagsSetLanguage :: (Maybe Language, ([Extension], [Extension])) -> ParseFlags -> ParseFlags
parseFlagsSetLanguage :: (Maybe Language, ([Extension], [Extension]))
-> ParseFlags -> ParseFlags
parseFlagsSetLanguage (Maybe Language
l, ([Extension]
es, [Extension]
ds)) ParseFlags
x = ParseFlags
x{baseLanguage :: Maybe Language
baseLanguage = Maybe Language
l, enabledExtensions :: [Extension]
enabledExtensions = [Extension]
es, disabledExtensions :: [Extension]
disabledExtensions = [Extension]
ds}
runCpp :: CppFlags -> FilePath -> String -> IO String
runCpp :: CppFlags -> FilePath -> FilePath -> IO FilePath
runCpp CppFlags
CppSimple FilePath
_ FilePath
x = FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines [if FilePath
"#" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath -> FilePath
trimStart FilePath
x then FilePath
"" else FilePath
x | FilePath
x <- FilePath -> [FilePath]
lines FilePath
x]
runCpp (Cpphs CpphsOptions
o) FilePath
file FilePath
x = FilePath -> FilePath
dropLine (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CpphsOptions -> FilePath -> FilePath -> IO FilePath
runCpphs CpphsOptions
o FilePath
file FilePath
x
where
dropLine :: FilePath -> FilePath
dropLine (FilePath -> (FilePath, FilePath)
line1 -> (FilePath
a,FilePath
b)) | FilePath
"{-# LINE " FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
a = FilePath
b
dropLine FilePath
x = FilePath
x
data ParseError = ParseError
{ ParseError -> SrcSpan
parseErrorLocation :: SrcSpan
, ParseError -> FilePath
parseErrorMessage :: String
, ParseError -> FilePath
parseErrorContents :: String
}
newtype ModuleEx = ModuleEx {
ModuleEx -> Located HsModule
ghcModule :: Located HsModule
}
ghcComments :: ModuleEx -> [LEpaComment]
= Located HsModule -> [LEpaComment]
forall from to. Biplate from to => from -> [to]
universeBi (Located HsModule -> [LEpaComment])
-> (ModuleEx -> Located HsModule) -> ModuleEx -> [LEpaComment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleEx -> Located HsModule
ghcModule
modComments :: ModuleEx -> EpAnnComments
= EpAnn AnnsModule -> EpAnnComments
forall ann. EpAnn ann -> EpAnnComments
comments (EpAnn AnnsModule -> EpAnnComments)
-> (ModuleEx -> EpAnn AnnsModule) -> ModuleEx -> EpAnnComments
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsModule -> EpAnn AnnsModule
hsmodAnn (HsModule -> EpAnn AnnsModule)
-> (ModuleEx -> HsModule) -> ModuleEx -> EpAnn AnnsModule
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located HsModule -> HsModule
forall l e. GenLocated l e -> e
unLoc (Located HsModule -> HsModule)
-> (ModuleEx -> Located HsModule) -> ModuleEx -> HsModule
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleEx -> Located HsModule
ghcModule
ghcFailOpParseModuleEx :: String
-> FilePath
-> String
-> (SrcSpan, SDoc)
-> IO (Either ParseError ModuleEx)
ghcFailOpParseModuleEx :: FilePath
-> FilePath
-> FilePath
-> (SrcSpan, SDoc)
-> IO (Either ParseError ModuleEx)
ghcFailOpParseModuleEx FilePath
ppstr FilePath
file FilePath
str (SrcSpan
loc, SDoc
err) = do
let pe :: FilePath
pe = case SrcSpan
loc of
RealSrcSpan RealSrcSpan
r Maybe BufSpan
_ -> Int -> FilePath -> FilePath
context (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
r) FilePath
ppstr
SrcSpan
_ -> FilePath
""
msg :: FilePath
msg = DynFlags -> SDoc -> FilePath
GHC.Driver.Ppr.showSDoc DynFlags
baseDynFlags SDoc
err
Either ParseError ModuleEx -> IO (Either ParseError ModuleEx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ParseError ModuleEx -> IO (Either ParseError ModuleEx))
-> Either ParseError ModuleEx -> IO (Either ParseError ModuleEx)
forall a b. (a -> b) -> a -> b
$ ParseError -> Either ParseError ModuleEx
forall a b. a -> Either a b
Left (ParseError -> Either ParseError ModuleEx)
-> ParseError -> Either ParseError ModuleEx
forall a b. (a -> b) -> a -> b
$ SrcSpan -> FilePath -> FilePath -> ParseError
ParseError SrcSpan
loc FilePath
msg FilePath
pe
ghcExtensionsFromParseFlags :: ParseFlags -> ([Extension], [Extension])
ghcExtensionsFromParseFlags :: ParseFlags -> ([Extension], [Extension])
ghcExtensionsFromParseFlags ParseFlags{enabledExtensions :: ParseFlags -> [Extension]
enabledExtensions=[Extension]
es, disabledExtensions :: ParseFlags -> [Extension]
disabledExtensions=[Extension]
ds}= ([Extension]
es, [Extension]
ds)
ghcFixitiesFromParseFlags :: ParseFlags -> [(String, GHC.Types.Fixity.Fixity)]
ghcFixitiesFromParseFlags :: ParseFlags -> [(FilePath, Fixity)]
ghcFixitiesFromParseFlags = (FixityInfo -> (FilePath, Fixity))
-> [FixityInfo] -> [(FilePath, Fixity)]
forall a b. (a -> b) -> [a] -> [b]
map FixityInfo -> (FilePath, Fixity)
toFixity ([FixityInfo] -> [(FilePath, Fixity)])
-> (ParseFlags -> [FixityInfo])
-> ParseFlags
-> [(FilePath, Fixity)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseFlags -> [FixityInfo]
fixities
parseModeToFlags :: ParseFlags -> DynFlags
parseModeToFlags :: ParseFlags -> DynFlags
parseModeToFlags ParseFlags
parseMode =
(DynFlags -> Maybe Language -> DynFlags)
-> Maybe Language -> DynFlags -> DynFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip DynFlags -> Maybe Language -> DynFlags
lang_set (ParseFlags -> Maybe Language
baseLanguage ParseFlags
parseMode) (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ (DynFlags -> Extension -> DynFlags)
-> DynFlags -> [Extension] -> DynFlags
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> Extension -> DynFlags
xopt_unset ((DynFlags -> Extension -> DynFlags)
-> DynFlags -> [Extension] -> DynFlags
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> Extension -> DynFlags
xopt_set DynFlags
baseDynFlags [Extension]
enable) [Extension]
disable
where
([Extension]
enable, [Extension]
disable) = ParseFlags -> ([Extension], [Extension])
ghcExtensionsFromParseFlags ParseFlags
parseMode
parseExpGhcWithMode :: ParseFlags -> String -> ParseResult (LHsExpr GhcPs)
parseExpGhcWithMode :: ParseFlags -> FilePath -> ParseResult (LHsExpr GhcPs)
parseExpGhcWithMode ParseFlags
parseMode FilePath
s =
let fixities :: [(FilePath, Fixity)]
fixities = ParseFlags -> [(FilePath, Fixity)]
ghcFixitiesFromParseFlags ParseFlags
parseMode
in case FilePath -> DynFlags -> ParseResult (LHsExpr GhcPs)
parseExpression FilePath
s (DynFlags -> ParseResult (LHsExpr GhcPs))
-> DynFlags -> ParseResult (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ ParseFlags -> DynFlags
parseModeToFlags ParseFlags
parseMode of
POk PState
pst GenLocated SrcSpanAnnA (HsExpr GhcPs)
a -> PState -> LHsExpr GhcPs -> ParseResult (LHsExpr GhcPs)
forall a. PState -> a -> ParseResult a
POk PState
pst (LHsExpr GhcPs -> ParseResult (LHsExpr GhcPs))
-> LHsExpr GhcPs -> ParseResult (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ [(FilePath, Fixity)]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a. Data a => [(FilePath, Fixity)] -> a -> a
applyFixities [(FilePath, Fixity)]
fixities GenLocated SrcSpanAnnA (HsExpr GhcPs)
a
f :: ParseResult (LHsExpr GhcPs)
f@PFailed{} -> ParseResult (LHsExpr GhcPs)
f
parseImportDeclGhcWithMode :: ParseFlags -> String -> ParseResult (LImportDecl GhcPs)
parseImportDeclGhcWithMode :: ParseFlags -> FilePath -> ParseResult (LImportDecl GhcPs)
parseImportDeclGhcWithMode ParseFlags
parseMode FilePath
s =
FilePath -> DynFlags -> ParseResult (LImportDecl GhcPs)
parseImport FilePath
s (DynFlags -> ParseResult (LImportDecl GhcPs))
-> DynFlags -> ParseResult (LImportDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ ParseFlags -> DynFlags
parseModeToFlags ParseFlags
parseMode
parseDeclGhcWithMode :: ParseFlags -> String -> ParseResult (LHsDecl GhcPs)
parseDeclGhcWithMode :: ParseFlags -> FilePath -> ParseResult (LHsDecl GhcPs)
parseDeclGhcWithMode ParseFlags
parseMode FilePath
s =
let fixities :: [(FilePath, Fixity)]
fixities = ParseFlags -> [(FilePath, Fixity)]
ghcFixitiesFromParseFlags ParseFlags
parseMode
in case FilePath -> DynFlags -> ParseResult (LHsDecl GhcPs)
parseDeclaration FilePath
s (DynFlags -> ParseResult (LHsDecl GhcPs))
-> DynFlags -> ParseResult (LHsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ ParseFlags -> DynFlags
parseModeToFlags ParseFlags
parseMode of
POk PState
pst GenLocated SrcSpanAnnA (HsDecl GhcPs)
a -> PState -> LHsDecl GhcPs -> ParseResult (LHsDecl GhcPs)
forall a. PState -> a -> ParseResult a
POk PState
pst (LHsDecl GhcPs -> ParseResult (LHsDecl GhcPs))
-> LHsDecl GhcPs -> ParseResult (LHsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ [(FilePath, Fixity)]
-> GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> GenLocated SrcSpanAnnA (HsDecl GhcPs)
forall a. Data a => [(FilePath, Fixity)] -> a -> a
applyFixities [(FilePath, Fixity)]
fixities GenLocated SrcSpanAnnA (HsDecl GhcPs)
a
f :: ParseResult (LHsDecl GhcPs)
f@PFailed{} -> ParseResult (LHsDecl GhcPs)
f
createModuleEx :: Located HsModule -> ModuleEx
createModuleEx :: Located HsModule -> ModuleEx
createModuleEx = [(FilePath, Fixity)] -> Located HsModule -> ModuleEx
createModuleExWithFixities ((FixityInfo -> (FilePath, Fixity))
-> [FixityInfo] -> [(FilePath, Fixity)]
forall a b. (a -> b) -> [a] -> [b]
map FixityInfo -> (FilePath, Fixity)
toFixity [FixityInfo]
defaultFixities)
createModuleExWithFixities :: [(String, Fixity)] -> Located HsModule -> ModuleEx
createModuleExWithFixities :: [(FilePath, Fixity)] -> Located HsModule -> ModuleEx
createModuleExWithFixities [(FilePath, Fixity)]
fixities Located HsModule
ast =
Located HsModule -> ModuleEx
ModuleEx ([(FilePath, Fixity)] -> Located HsModule -> Located HsModule
forall a. Data a => [(FilePath, Fixity)] -> a -> a
applyFixities (Located HsModule -> [(FilePath, Fixity)]
fixitiesFromModule Located HsModule
ast [(FilePath, Fixity)]
-> [(FilePath, Fixity)] -> [(FilePath, Fixity)]
forall a. [a] -> [a] -> [a]
++ [(FilePath, Fixity)]
fixities) Located HsModule
ast)
parseModuleEx :: ParseFlags -> FilePath -> Maybe String -> IO (Either ParseError ModuleEx)
parseModuleEx :: ParseFlags
-> FilePath -> Maybe FilePath -> IO (Either ParseError ModuleEx)
parseModuleEx ParseFlags
flags FilePath
file Maybe FilePath
str = FilePath
-> FilePath
-> IO (Either ParseError ModuleEx)
-> IO (Either ParseError ModuleEx)
forall a. FilePath -> FilePath -> IO a -> IO a
timedIO FilePath
"Parse" FilePath
file (IO (Either ParseError ModuleEx)
-> IO (Either ParseError ModuleEx))
-> IO (Either ParseError ModuleEx)
-> IO (Either ParseError ModuleEx)
forall a b. (a -> b) -> a -> b
$ ExceptT ParseError IO ModuleEx -> IO (Either ParseError ModuleEx)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ParseError IO ModuleEx -> IO (Either ParseError ModuleEx))
-> ExceptT ParseError IO ModuleEx
-> IO (Either ParseError ModuleEx)
forall a b. (a -> b) -> a -> b
$ do
FilePath
str <- case Maybe FilePath
str of
Just FilePath
x -> FilePath -> ExceptT ParseError IO FilePath
forall a. a -> ExceptT ParseError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
x
Maybe FilePath
Nothing | FilePath
file FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"-" -> IO FilePath -> ExceptT ParseError IO FilePath
forall a. IO a -> ExceptT ParseError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getContentsUTF8
| Bool
otherwise -> IO FilePath -> ExceptT ParseError IO FilePath
forall a. IO a -> ExceptT ParseError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> ExceptT ParseError IO FilePath)
-> IO FilePath -> ExceptT ParseError IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
readFileUTF8' FilePath
file
FilePath
str <- FilePath -> ExceptT ParseError IO FilePath
forall a. a -> ExceptT ParseError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> ExceptT ParseError IO FilePath)
-> FilePath -> ExceptT ParseError IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath
forall a. Eq a => [a] -> [a] -> [a]
dropPrefix FilePath
"\65279" FilePath
str
let enableDisableExts :: ([Extension], [Extension])
enableDisableExts = ParseFlags -> ([Extension], [Extension])
ghcExtensionsFromParseFlags ParseFlags
flags
DynFlags
dynFlags <- (FilePath -> ParseError)
-> ExceptT FilePath IO DynFlags -> ExceptT ParseError IO DynFlags
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (FilePath -> FilePath -> ParseError
parsePragmasErr FilePath
str) (ExceptT FilePath IO DynFlags -> ExceptT ParseError IO DynFlags)
-> ExceptT FilePath IO DynFlags -> ExceptT ParseError IO DynFlags
forall a b. (a -> b) -> a -> b
$ IO (Either FilePath DynFlags) -> ExceptT FilePath IO DynFlags
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (DynFlags
-> ([Extension], [Extension])
-> FilePath
-> FilePath
-> IO (Either FilePath DynFlags)
parsePragmasIntoDynFlags DynFlags
baseDynFlags ([Extension], [Extension])
enableDisableExts FilePath
file FilePath
str)
DynFlags
dynFlags <- DynFlags -> ExceptT ParseError IO DynFlags
forall a. a -> ExceptT ParseError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DynFlags -> ExceptT ParseError IO DynFlags)
-> DynFlags -> ExceptT ParseError IO DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags -> Maybe Language -> DynFlags
lang_set DynFlags
dynFlags (Maybe Language -> DynFlags) -> Maybe Language -> DynFlags
forall a b. (a -> b) -> a -> b
$ ParseFlags -> Maybe Language
baseLanguage ParseFlags
flags
FilePath
str <- if Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
Cpp DynFlags
dynFlags) then FilePath -> ExceptT ParseError IO FilePath
forall a. a -> ExceptT ParseError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
str else IO FilePath -> ExceptT ParseError IO FilePath
forall a. IO a -> ExceptT ParseError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> ExceptT ParseError IO FilePath)
-> IO FilePath -> ExceptT ParseError IO FilePath
forall a b. (a -> b) -> a -> b
$ CppFlags -> FilePath -> FilePath -> IO FilePath
runCpp (ParseFlags -> CppFlags
cppFlags ParseFlags
flags) FilePath
file FilePath
str
DynFlags
dynFlags <- if Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
Cpp DynFlags
dynFlags) then DynFlags -> ExceptT ParseError IO DynFlags
forall a. a -> ExceptT ParseError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DynFlags
dynFlags
else (FilePath -> ParseError)
-> ExceptT FilePath IO DynFlags -> ExceptT ParseError IO DynFlags
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (FilePath -> FilePath -> ParseError
parsePragmasErr FilePath
str) (ExceptT FilePath IO DynFlags -> ExceptT ParseError IO DynFlags)
-> ExceptT FilePath IO DynFlags -> ExceptT ParseError IO DynFlags
forall a b. (a -> b) -> a -> b
$ IO (Either FilePath DynFlags) -> ExceptT FilePath IO DynFlags
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (DynFlags
-> ([Extension], [Extension])
-> FilePath
-> FilePath
-> IO (Either FilePath DynFlags)
parsePragmasIntoDynFlags DynFlags
baseDynFlags ([Extension], [Extension])
enableDisableExts FilePath
file FilePath
str)
DynFlags
dynFlags <- DynFlags -> ExceptT ParseError IO DynFlags
forall a. a -> ExceptT ParseError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DynFlags -> ExceptT ParseError IO DynFlags)
-> DynFlags -> ExceptT ParseError IO DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags -> Maybe Language -> DynFlags
lang_set DynFlags
dynFlags (Maybe Language -> DynFlags) -> Maybe Language -> DynFlags
forall a b. (a -> b) -> a -> b
$ ParseFlags -> Maybe Language
baseLanguage ParseFlags
flags
case FilePath -> FilePath -> DynFlags -> ParseResult (Located HsModule)
fileToModule FilePath
file FilePath
str DynFlags
dynFlags of
POk PState
s Located HsModule
a -> do
let errs :: [MsgEnvelope GhcMessage]
errs = Bag (MsgEnvelope GhcMessage) -> [MsgEnvelope GhcMessage]
forall a. Bag a -> [a]
bagToList (Bag (MsgEnvelope GhcMessage) -> [MsgEnvelope GhcMessage])
-> (Messages GhcMessage -> Bag (MsgEnvelope GhcMessage))
-> Messages GhcMessage
-> [MsgEnvelope GhcMessage]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Messages GhcMessage -> Bag (MsgEnvelope GhcMessage)
forall e. Messages e -> Bag (MsgEnvelope e)
getMessages (Messages GhcMessage -> [MsgEnvelope GhcMessage])
-> Messages GhcMessage -> [MsgEnvelope GhcMessage]
forall a b. (a -> b) -> a -> b
$ PsMessage -> GhcMessage
GhcPsMessage (PsMessage -> GhcMessage)
-> Messages PsMessage -> Messages GhcMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Messages PsMessage, Messages PsMessage) -> Messages PsMessage
forall a b. (a, b) -> b
snd (PState -> (Messages PsMessage, Messages PsMessage)
getPsMessages PState
s)
if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [MsgEnvelope GhcMessage] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [MsgEnvelope GhcMessage]
errs then
IO (Either ParseError ModuleEx) -> ExceptT ParseError IO ModuleEx
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ParseError ModuleEx) -> ExceptT ParseError IO ModuleEx)
-> IO (Either ParseError ModuleEx)
-> ExceptT ParseError IO ModuleEx
forall a b. (a -> b) -> a -> b
$ DynFlags
-> FilePath
-> FilePath
-> FilePath
-> [MsgEnvelope GhcMessage]
-> IO (Either ParseError ModuleEx)
forall {e} {p}.
Diagnostic e =>
p
-> FilePath
-> FilePath
-> FilePath
-> [MsgEnvelope e]
-> IO (Either ParseError ModuleEx)
parseFailureErr DynFlags
dynFlags FilePath
str FilePath
file FilePath
str [MsgEnvelope GhcMessage]
errs
else do
let fixes :: [(FilePath, Fixity)]
fixes = Located HsModule -> [(FilePath, Fixity)]
fixitiesFromModule Located HsModule
a [(FilePath, Fixity)]
-> [(FilePath, Fixity)] -> [(FilePath, Fixity)]
forall a. [a] -> [a] -> [a]
++ ParseFlags -> [(FilePath, Fixity)]
ghcFixitiesFromParseFlags ParseFlags
flags
ModuleEx -> ExceptT ParseError IO ModuleEx
forall a. a -> ExceptT ParseError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ModuleEx -> ExceptT ParseError IO ModuleEx)
-> ModuleEx -> ExceptT ParseError IO ModuleEx
forall a b. (a -> b) -> a -> b
$ Located HsModule -> ModuleEx
ModuleEx ([(FilePath, Fixity)] -> Located HsModule -> Located HsModule
forall a. Data a => [(FilePath, Fixity)] -> a -> a
applyFixities [(FilePath, Fixity)]
fixes Located HsModule
a)
PFailed PState
s ->
IO (Either ParseError ModuleEx) -> ExceptT ParseError IO ModuleEx
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ParseError ModuleEx) -> ExceptT ParseError IO ModuleEx)
-> IO (Either ParseError ModuleEx)
-> ExceptT ParseError IO ModuleEx
forall a b. (a -> b) -> a -> b
$ DynFlags
-> FilePath
-> FilePath
-> FilePath
-> [MsgEnvelope GhcMessage]
-> IO (Either ParseError ModuleEx)
forall {e} {p}.
Diagnostic e =>
p
-> FilePath
-> FilePath
-> FilePath
-> [MsgEnvelope e]
-> IO (Either ParseError ModuleEx)
parseFailureErr DynFlags
dynFlags FilePath
str FilePath
file FilePath
str ([MsgEnvelope GhcMessage] -> IO (Either ParseError ModuleEx))
-> [MsgEnvelope GhcMessage] -> IO (Either ParseError ModuleEx)
forall a b. (a -> b) -> a -> b
$ Bag (MsgEnvelope GhcMessage) -> [MsgEnvelope GhcMessage]
forall a. Bag a -> [a]
bagToList (Bag (MsgEnvelope GhcMessage) -> [MsgEnvelope GhcMessage])
-> (Messages GhcMessage -> Bag (MsgEnvelope GhcMessage))
-> Messages GhcMessage
-> [MsgEnvelope GhcMessage]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Messages GhcMessage -> Bag (MsgEnvelope GhcMessage)
forall e. Messages e -> Bag (MsgEnvelope e)
getMessages (Messages GhcMessage -> [MsgEnvelope GhcMessage])
-> Messages GhcMessage -> [MsgEnvelope GhcMessage]
forall a b. (a -> b) -> a -> b
$ PsMessage -> GhcMessage
GhcPsMessage (PsMessage -> GhcMessage)
-> Messages PsMessage -> Messages GhcMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Messages PsMessage, Messages PsMessage) -> Messages PsMessage
forall a b. (a, b) -> b
snd (PState -> (Messages PsMessage, Messages PsMessage)
getPsMessages PState
s)
where
parsePragmasErr :: FilePath -> FilePath -> ParseError
parsePragmasErr FilePath
src FilePath
msg =
let loc :: SrcLoc
loc = FastString -> Int -> Int -> SrcLoc
mkSrcLoc (FilePath -> FastString
mkFastString FilePath
file) (Int
1 :: Int) (Int
1 :: Int)
in SrcSpan -> FilePath -> FilePath -> ParseError
ParseError (SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan SrcLoc
loc SrcLoc
loc) FilePath
msg FilePath
src
parseFailureErr :: p
-> FilePath
-> FilePath
-> FilePath
-> [MsgEnvelope e]
-> IO (Either ParseError ModuleEx)
parseFailureErr p
dynFlags FilePath
ppstr FilePath
file FilePath
str [MsgEnvelope e]
errs =
let errMsg :: MsgEnvelope e
errMsg = [MsgEnvelope e] -> MsgEnvelope e
forall a. HasCallStack => [a] -> a
head [MsgEnvelope e]
errs
loc :: SrcSpan
loc = MsgEnvelope e -> SrcSpan
forall e. MsgEnvelope e -> SrcSpan
errMsgSpan MsgEnvelope e
errMsg
doc :: SDoc
doc = MsgEnvelope e -> SDoc
forall e. Diagnostic e => MsgEnvelope e -> SDoc
pprLocMsgEnvelope MsgEnvelope e
errMsg
in FilePath
-> FilePath
-> FilePath
-> (SrcSpan, SDoc)
-> IO (Either ParseError ModuleEx)
ghcFailOpParseModuleEx FilePath
ppstr FilePath
file FilePath
str (SrcSpan
loc, SDoc
doc)
context :: Int -> String -> String
context :: Int -> FilePath -> FilePath
context Int
lineNo FilePath
src =
[FilePath] -> FilePath
unlines ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd ((Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace) ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace) ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$
(FilePath -> FilePath -> FilePath)
-> [FilePath] -> [FilePath] -> [FilePath]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
(++) [FilePath]
ticks ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ Int -> [FilePath] -> [FilePath]
forall a. Int -> [a] -> [a]
take Int
5 ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ Int -> [FilePath] -> [FilePath]
forall a. Int -> [a] -> [a]
drop (Int
lineNo Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3) ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
lines FilePath
src [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
"",FilePath
"",FilePath
"",FilePath
"",FilePath
""]
where ticks :: [FilePath]
ticks = Int -> [FilePath] -> [FilePath]
forall a. Int -> [a] -> [a]
drop (Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lineNo) [FilePath
" ",FilePath
" ",FilePath
"> ",FilePath
" ",FilePath
" "]