{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
module GHC.All(
CppFlags(..), ParseFlags(..), defaultParseFlags,
parseFlagsAddFixities, parseFlagsSetLanguage,
ParseError(..), ModuleEx(..),
parseModuleEx, createModuleEx, ghcComments,
parseExpGhcWithMode, parseImportDeclGhcWithMode, parseDeclGhcWithMode,
) where
import Util
import Data.Char
import Data.List.Extra
import Timing
import Language.Preprocessor.Cpphs
import qualified Data.Map as Map
import System.IO.Extra
import Fixity
import Extension
import FastString
import GHC.Hs
import SrcLoc
import ErrUtils
import Outputable
import Lexer hiding (context)
import GHC.LanguageExtensions.Type
import ApiAnnotation
import DynFlags hiding (extensions)
import Bag
import Language.Haskell.GhclibParserEx.GHC.Parser
import Language.Haskell.GhclibParserEx.Fixity
import GHC.Util
data CppFlags
= NoCpp
| 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
NoCpp Maybe Language
forall a. Maybe a
Nothing [Extension]
defaultExtensions [] [FixityInfo]
defaultFixities
parseFlagsAddFixities :: [FixityInfo] -> ParseFlags -> ParseFlags
parseFlagsAddFixities :: [FixityInfo] -> ParseFlags -> ParseFlags
parseFlagsAddFixities fx :: [FixityInfo]
fx x :: 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 (l :: Maybe Language
l, (es :: [Extension]
es, ds :: [Extension]
ds)) x :: 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 NoCpp _ x :: FilePath
x = FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
x
runCpp CppSimple _ x :: FilePath
x = FilePath -> IO FilePath
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 -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath -> FilePath
trimStart FilePath
x then "" else FilePath
x | FilePath
x <- FilePath -> [FilePath]
lines FilePath
x]
runCpp (Cpphs o :: CpphsOptions
o) file :: FilePath
file x :: 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 -> (a :: FilePath
a,b :: FilePath
b)) | "{-# LINE " FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
a = FilePath
b
dropLine x :: FilePath
x = FilePath
x
data ParseError = ParseError
{ ParseError -> SrcSpan
parseErrorLocation :: SrcSpan
, ParseError -> FilePath
parseErrorMessage :: String
, ParseError -> FilePath
parseErrorContents :: String
}
data ModuleEx = ModuleEx {
ModuleEx -> Located (HsModule GhcPs)
ghcModule :: Located (HsModule GhcPs)
, ModuleEx -> ApiAnns
ghcAnnotations :: ApiAnns
}
ghcComments :: ModuleEx -> [Located AnnotationComment]
m :: ModuleEx
m = [[Located AnnotationComment]] -> [Located AnnotationComment]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Map SrcSpan [Located AnnotationComment]
-> [[Located AnnotationComment]]
forall k a. Map k a -> [a]
Map.elems (Map SrcSpan [Located AnnotationComment]
-> [[Located AnnotationComment]])
-> Map SrcSpan [Located AnnotationComment]
-> [[Located AnnotationComment]]
forall a b. (a -> b) -> a -> b
$ ApiAnns -> Map SrcSpan [Located AnnotationComment]
forall a b. (a, b) -> b
snd (ModuleEx -> ApiAnns
ghcAnnotations ModuleEx
m))
ghcFailOpParseModuleEx :: String
-> FilePath
-> String
-> (SrcSpan, ErrUtils.MsgDoc)
-> IO (Either ParseError ModuleEx)
ghcFailOpParseModuleEx :: FilePath
-> FilePath
-> FilePath
-> (SrcSpan, MsgDoc)
-> IO (Either ParseError ModuleEx)
ghcFailOpParseModuleEx ppstr :: FilePath
ppstr file :: FilePath
file str :: FilePath
str (loc :: SrcSpan
loc, err :: MsgDoc
err) = do
let pe :: FilePath
pe = case SrcSpan
loc of
RealSrcSpan r :: RealSrcSpan
r -> Int -> FilePath -> FilePath
context (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
r) FilePath
ppstr
_ -> ""
msg :: FilePath
msg = DynFlags -> MsgDoc -> FilePath
Outputable.showSDoc DynFlags
baseDynFlags MsgDoc
err
Either ParseError ModuleEx -> IO (Either ParseError ModuleEx)
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, 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 parseMode :: 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 (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 (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
(enable :: [Extension]
enable, disable :: [Extension]
disable) = ParseFlags -> ([Extension], [Extension])
ghcExtensionsFromParseFlags ParseFlags
parseMode
parseExpGhcWithMode :: ParseFlags -> String -> ParseResult (LHsExpr GhcPs)
parseExpGhcWithMode :: ParseFlags -> FilePath -> ParseResult (LHsExpr GhcPs)
parseExpGhcWithMode parseMode :: ParseFlags
parseMode s :: 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 pst :: PState
pst a :: LHsExpr 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)] -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a. Data a => [(FilePath, Fixity)] -> a -> a
applyFixities [(FilePath, Fixity)]
fixities LHsExpr 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 parseMode :: ParseFlags
parseMode s :: 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 parseMode :: ParseFlags
parseMode s :: 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 pst :: PState
pst a :: LHsDecl 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)] -> LHsDecl GhcPs -> LHsDecl GhcPs
forall a. Data a => [(FilePath, Fixity)] -> a -> a
applyFixities [(FilePath, Fixity)]
fixities LHsDecl GhcPs
a
f :: ParseResult (LHsDecl GhcPs)
f@PFailed{} -> ParseResult (LHsDecl GhcPs)
f
createModuleEx :: ApiAnns -> Located (HsModule GhcPs) -> ModuleEx
createModuleEx :: ApiAnns -> Located (HsModule GhcPs) -> ModuleEx
createModuleEx anns :: ApiAnns
anns ast :: Located (HsModule GhcPs)
ast =
Located (HsModule GhcPs) -> ApiAnns -> ModuleEx
ModuleEx ([(FilePath, Fixity)]
-> Located (HsModule GhcPs) -> Located (HsModule GhcPs)
forall a. Data a => [(FilePath, Fixity)] -> a -> a
applyFixities (Located (HsModule GhcPs) -> [(FilePath, Fixity)]
fixitiesFromModule Located (HsModule GhcPs)
ast [(FilePath, Fixity)]
-> [(FilePath, Fixity)] -> [(FilePath, Fixity)]
forall a. [a] -> [a] -> [a]
++ (FixityInfo -> (FilePath, Fixity))
-> [FixityInfo] -> [(FilePath, Fixity)]
forall a b. (a -> b) -> [a] -> [b]
map FixityInfo -> (FilePath, Fixity)
toFixity [FixityInfo]
defaultFixities) Located (HsModule GhcPs)
ast) ApiAnns
anns
parseModuleEx :: ParseFlags -> FilePath -> Maybe String -> IO (Either ParseError ModuleEx)
parseModuleEx :: ParseFlags
-> FilePath -> Maybe FilePath -> IO (Either ParseError ModuleEx)
parseModuleEx flags :: ParseFlags
flags file :: FilePath
file str :: Maybe FilePath
str = FilePath
-> FilePath
-> IO (Either ParseError ModuleEx)
-> IO (Either ParseError ModuleEx)
forall a. FilePath -> FilePath -> IO a -> IO a
timedIO "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
$ do
FilePath
str <- case Maybe FilePath
str of
Just x :: FilePath
x -> FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
x
Nothing | FilePath
file FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "-" -> IO FilePath
getContentsUTF8
| Bool
otherwise -> FilePath -> IO FilePath
readFileUTF8' FilePath
file
FilePath
str <- FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath
forall a. Eq a => [a] -> [a] -> [a]
dropPrefix "\65279" FilePath
str
FilePath
ppstr <- CppFlags -> FilePath -> FilePath -> IO FilePath
runCpp (ParseFlags -> CppFlags
cppFlags ParseFlags
flags) FilePath
file FilePath
str
let enableDisableExts :: ([Extension], [Extension])
enableDisableExts = ParseFlags -> ([Extension], [Extension])
ghcExtensionsFromParseFlags ParseFlags
flags
Either FilePath DynFlags
dynFlags <- DynFlags
-> ([Extension], [Extension])
-> FilePath
-> FilePath
-> IO (Either FilePath DynFlags)
parsePragmasIntoDynFlags DynFlags
baseDynFlags ([Extension], [Extension])
enableDisableExts FilePath
file FilePath
ppstr
case Either FilePath DynFlags
dynFlags of
Right ghcFlags :: DynFlags
ghcFlags -> do
DynFlags
ghcFlags <- DynFlags -> IO DynFlags
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DynFlags -> IO DynFlags) -> DynFlags -> IO DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags -> Maybe Language -> DynFlags
lang_set DynFlags
ghcFlags (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 GhcPs))
fileToModule FilePath
file FilePath
ppstr DynFlags
ghcFlags of
POk s :: PState
s a :: Located (HsModule GhcPs)
a -> do
let errs :: [ErrMsg]
errs = Bag ErrMsg -> [ErrMsg]
forall a. Bag a -> [a]
bagToList (Bag ErrMsg -> [ErrMsg])
-> ((Bag ErrMsg, Bag ErrMsg) -> Bag ErrMsg)
-> (Bag ErrMsg, Bag ErrMsg)
-> [ErrMsg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bag ErrMsg, Bag ErrMsg) -> Bag ErrMsg
forall a b. (a, b) -> b
snd ((Bag ErrMsg, Bag ErrMsg) -> [ErrMsg])
-> (Bag ErrMsg, Bag ErrMsg) -> [ErrMsg]
forall a b. (a -> b) -> a -> b
$ PState -> DynFlags -> (Bag ErrMsg, Bag ErrMsg)
getMessages PState
s DynFlags
ghcFlags
if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [ErrMsg] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ErrMsg]
errs then
DynFlags
-> FilePath
-> FilePath
-> FilePath
-> [ErrMsg]
-> IO (Either ParseError ModuleEx)
handleParseFailure DynFlags
ghcFlags FilePath
ppstr FilePath
file FilePath
str [ErrMsg]
errs
else do
let anns :: ApiAnns
anns =
( ([SrcSpan] -> [SrcSpan] -> [SrcSpan])
-> [(ApiAnnKey, [SrcSpan])] -> Map ApiAnnKey [SrcSpan]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. [a] -> [a] -> [a]
(++) ([(ApiAnnKey, [SrcSpan])] -> Map ApiAnnKey [SrcSpan])
-> [(ApiAnnKey, [SrcSpan])] -> Map ApiAnnKey [SrcSpan]
forall a b. (a -> b) -> a -> b
$ PState -> [(ApiAnnKey, [SrcSpan])]
annotations PState
s
, [(SrcSpan, [Located AnnotationComment])]
-> Map SrcSpan [Located AnnotationComment]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((SrcSpan
noSrcSpan, PState -> [Located AnnotationComment]
comment_q PState
s) (SrcSpan, [Located AnnotationComment])
-> [(SrcSpan, [Located AnnotationComment])]
-> [(SrcSpan, [Located AnnotationComment])]
forall a. a -> [a] -> [a]
: PState -> [(SrcSpan, [Located AnnotationComment])]
annotations_comments PState
s)
)
let fixes :: [(FilePath, Fixity)]
fixes = Located (HsModule GhcPs) -> [(FilePath, Fixity)]
fixitiesFromModule Located (HsModule GhcPs)
a [(FilePath, Fixity)]
-> [(FilePath, Fixity)] -> [(FilePath, Fixity)]
forall a. [a] -> [a] -> [a]
++ ParseFlags -> [(FilePath, Fixity)]
ghcFixitiesFromParseFlags ParseFlags
flags
Either ParseError ModuleEx -> IO (Either ParseError ModuleEx)
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
$ ModuleEx -> Either ParseError ModuleEx
forall a b. b -> Either a b
Right (Located (HsModule GhcPs) -> ApiAnns -> ModuleEx
ModuleEx ([(FilePath, Fixity)]
-> Located (HsModule GhcPs) -> Located (HsModule GhcPs)
forall a. Data a => [(FilePath, Fixity)] -> a -> a
applyFixities [(FilePath, Fixity)]
fixes Located (HsModule GhcPs)
a) ApiAnns
anns)
PFailed s :: PState
s ->
DynFlags
-> FilePath
-> FilePath
-> FilePath
-> [ErrMsg]
-> IO (Either ParseError ModuleEx)
handleParseFailure DynFlags
ghcFlags FilePath
ppstr FilePath
file FilePath
str ([ErrMsg] -> IO (Either ParseError ModuleEx))
-> [ErrMsg] -> IO (Either ParseError ModuleEx)
forall a b. (a -> b) -> a -> b
$ Bag ErrMsg -> [ErrMsg]
forall a. Bag a -> [a]
bagToList (Bag ErrMsg -> [ErrMsg])
-> ((Bag ErrMsg, Bag ErrMsg) -> Bag ErrMsg)
-> (Bag ErrMsg, Bag ErrMsg)
-> [ErrMsg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bag ErrMsg, Bag ErrMsg) -> Bag ErrMsg
forall a b. (a, b) -> b
snd ((Bag ErrMsg, Bag ErrMsg) -> [ErrMsg])
-> (Bag ErrMsg, Bag ErrMsg) -> [ErrMsg]
forall a b. (a -> b) -> a -> b
$ PState -> DynFlags -> (Bag ErrMsg, Bag ErrMsg)
getMessages PState
s DynFlags
ghcFlags
Left msg :: FilePath
msg -> do
let loc :: SrcLoc
loc = FastString -> Int -> Int -> SrcLoc
mkSrcLoc (FilePath -> FastString
mkFastString FilePath
file) (1 :: Int) (1 :: Int)
Either ParseError ModuleEx -> IO (Either ParseError ModuleEx)
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 (SrcSpan -> FilePath -> FilePath -> ParseError
ParseError (SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan SrcLoc
loc SrcLoc
loc) FilePath
msg FilePath
ppstr)
where
handleParseFailure :: DynFlags
-> FilePath
-> FilePath
-> FilePath
-> [ErrMsg]
-> IO (Either ParseError ModuleEx)
handleParseFailure ghcFlags :: DynFlags
ghcFlags ppstr :: FilePath
ppstr file :: FilePath
file str :: FilePath
str errs :: [ErrMsg]
errs =
let errMsg :: ErrMsg
errMsg = [ErrMsg] -> ErrMsg
forall a. [a] -> a
head [ErrMsg]
errs
loc :: SrcSpan
loc = ErrMsg -> SrcSpan
errMsgSpan ErrMsg
errMsg
doc :: MsgDoc
doc = DynFlags -> ErrDoc -> MsgDoc
formatErrDoc DynFlags
ghcFlags (ErrMsg -> ErrDoc
errMsgDoc ErrMsg
errMsg)
in FilePath
-> FilePath
-> FilePath
-> (SrcSpan, MsgDoc)
-> IO (Either ParseError ModuleEx)
ghcFailOpParseModuleEx FilePath
ppstr FilePath
file FilePath
str (SrcSpan
loc, MsgDoc
doc)
context :: Int -> String -> String
context :: Int -> FilePath -> FilePath
context lineNo :: Int
lineNo src :: 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 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
- 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]
++ ["","","","",""]
where ticks :: [FilePath]
ticks = Int -> [FilePath] -> [FilePath]
forall a. Int -> [a] -> [a]
drop (3 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lineNo) [" "," ","> "," "," "]