{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
module HsInspect.Types where
#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)
import qualified GHC.Utils.Error as GHC
import qualified GHC.Types.Error as GHC
#elif MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)
import qualified GHC.Utils.Error as GHC
import qualified GHC.Parser.Errors.Ppr as GHC
#elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
import qualified GHC.Utils.Error as GHC
#elif MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
import qualified ErrUtils as GHC
#endif
#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
import qualified GHC.Parser.Lexer as GHC
import qualified GHC.Utils.Outputable as GHC
import qualified GHC.Driver.Session as GHC
import qualified GHC.Parser as Parser
import qualified GHC.Rename.HsType as GHC
#else
import qualified DynFlags as GHC
import qualified Lexer as GHC
import qualified Outputable as GHC
import qualified Parser as Parser
import qualified RnTypes as GHC
#endif
import qualified GHC as GHC
import Control.Exception (throwIO)
import Control.Monad.IO.Class (liftIO)
import Data.List (sortOn)
import Data.Maybe (mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import HsInspect.Sexp
import qualified HsInspect.Util as H
import HsInspect.Workarounds (mkCppState)
data Type = ProductType Text [Text] Bool Text [(Text, [Text])]
| RecordType Text [Text] Bool Text [(Text, Text, [Text])]
| SumType Text [Text] [(Text, [(Text, [Text])])]
deriving (Type -> Type -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Type -> Type -> Bool
$c/= :: Type -> Type -> Bool
== :: Type -> Type -> Bool
$c== :: Type -> Type -> Bool
Eq, Int -> Type -> ShowS
[Type] -> ShowS
Type -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Type] -> ShowS
$cshowList :: [Type] -> ShowS
show :: Type -> String
$cshow :: Type -> String
showsPrec :: Int -> Type -> ShowS
$cshowsPrec :: Int -> Type -> ShowS
Show)
instance ToSexp Type where
toSexp :: Type -> Sexp
toSexp (ProductType Text
p_1_1 [Text]
p_1_2 Bool
p_1_3 Text
p_1_4 [(Text, [Text])]
p_1_5) = [(Sexp, Sexp)] -> Sexp
alist forall a b. (a -> b) -> a -> b
$ (Sexp
"class", Sexp
"product") forall a. a -> [a] -> [a]
: [(Sexp
"type", forall a. ToSexp a => a -> Sexp
toSexp Text
p_1_1), (Sexp
"tparams", forall a. ToSexp a => a -> Sexp
toSexp [Text]
p_1_2), (Sexp
"newtype", forall a. ToSexp a => a -> Sexp
toSexp Bool
p_1_3), (Sexp
"cons", forall a. ToSexp a => a -> Sexp
toSexp Text
p_1_4), (Sexp
"params", forall a. ToSexp a => a -> Sexp
toSexp [(Text, [Text])]
p_1_5)]
toSexp (RecordType Text
p_1_1 [Text]
p_1_2 Bool
p_1_3 Text
p_1_4 [(Text, Text, [Text])]
p_1_5) = [(Sexp, Sexp)] -> Sexp
alist forall a b. (a -> b) -> a -> b
$ (Sexp
"class", Sexp
"record") forall a. a -> [a] -> [a]
: [(Sexp
"type", forall a. ToSexp a => a -> Sexp
toSexp Text
p_1_1), (Sexp
"tparams", forall a. ToSexp a => a -> Sexp
toSexp [Text]
p_1_2), (Sexp
"newtype", forall a. ToSexp a => a -> Sexp
toSexp Bool
p_1_3), (Sexp
"cons", forall a. ToSexp a => a -> Sexp
toSexp Text
p_1_4), (Sexp
"fields", forall a. ToSexp a => a -> Sexp
toSexp [(Text, Text, [Text])]
p_1_5)]
toSexp (SumType Text
p_1_1 [Text]
p_1_2 [(Text, [(Text, [Text])])]
p_1_3) = [(Sexp, Sexp)] -> Sexp
alist forall a b. (a -> b) -> a -> b
$ (Sexp
"class", Sexp
"sum") forall a. a -> [a] -> [a]
: [(Sexp
"type", forall a. ToSexp a => a -> Sexp
toSexp Text
p_1_1), (Sexp
"tparams", forall a. ToSexp a => a -> Sexp
toSexp [Text]
p_1_2), (Sexp
"data", forall a. ToSexp a => a -> Sexp
toSexp [(Text, [(Text, [Text])])]
p_1_3)]
data Pos = Pos Int Int
deriving (Pos -> Pos -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Pos -> Pos -> Bool
$c/= :: Pos -> Pos -> Bool
== :: Pos -> Pos -> Bool
$c== :: Pos -> Pos -> Bool
Eq, Eq Pos
Pos -> Pos -> Bool
Pos -> Pos -> Ordering
Pos -> Pos -> Pos
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Pos -> Pos -> Pos
$cmin :: Pos -> Pos -> Pos
max :: Pos -> Pos -> Pos
$cmax :: Pos -> Pos -> Pos
>= :: Pos -> Pos -> Bool
$c>= :: Pos -> Pos -> Bool
> :: Pos -> Pos -> Bool
$c> :: Pos -> Pos -> Bool
<= :: Pos -> Pos -> Bool
$c<= :: Pos -> Pos -> Bool
< :: Pos -> Pos -> Bool
$c< :: Pos -> Pos -> Bool
compare :: Pos -> Pos -> Ordering
$ccompare :: Pos -> Pos -> Ordering
Ord, Int -> Pos -> ShowS
[Pos] -> ShowS
Pos -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Pos] -> ShowS
$cshowList :: [Pos] -> ShowS
show :: Pos -> String
$cshow :: Pos -> String
showsPrec :: Int -> Pos -> ShowS
$cshowsPrec :: Int -> Pos -> ShowS
Show)
instance ToSexp Pos where
toSexp :: Pos -> Sexp
toSexp (Pos Int
p_1_1 Int
p_1_2) = [(Sexp, Sexp)] -> Sexp
alist [(Sexp
"line", forall a. ToSexp a => a -> Sexp
toSexp Int
p_1_1), (Sexp
"col", forall a. ToSexp a => a -> Sexp
toSexp Int
p_1_2)]
data = Text Pos Pos
deriving (Comment -> Comment -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Comment -> Comment -> Bool
$c/= :: Comment -> Comment -> Bool
== :: Comment -> Comment -> Bool
$c== :: Comment -> Comment -> Bool
Eq, Int -> Comment -> ShowS
[Comment] -> ShowS
Comment -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Comment] -> ShowS
$cshowList :: [Comment] -> ShowS
show :: Comment -> String
$cshow :: Comment -> String
showsPrec :: Int -> Comment -> ShowS
$cshowsPrec :: Int -> Comment -> ShowS
Show)
instance ToSexp Comment where
toSexp :: Comment -> Sexp
toSexp (Comment Text
p_1_1 Pos
p_1_2 Pos
p_1_3) = [(Sexp, Sexp)] -> Sexp
alist [(Sexp
"text", forall a. ToSexp a => a -> Sexp
toSexp Text
p_1_1), (Sexp
"start", forall a. ToSexp a => a -> Sexp
toSexp Pos
p_1_2), (Sexp
"end", forall a. ToSexp a => a -> Sexp
toSexp Pos
p_1_3)]
types :: GHC.GhcMonad m => FilePath -> m ([Type], [Comment])
types :: forall (m :: * -> *). GhcMonad m => String -> m ([Type], [Comment])
types String
file = do
DynFlags
dflags <- forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
()
_ <- forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
GHC.setSessionDynFlags forall a b. (a -> b) -> a -> b
$ DynFlags -> GeneralFlag -> DynFlags
GHC.gopt_set DynFlags
dflags GeneralFlag
GHC.Opt_KeepRawTokenStream
HscEnv
env <- forall (m :: * -> *). GhcMonad m => m HscEnv
GHC.getSession
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> String -> IO ([Type], [Comment])
parseTypes HscEnv
env String
file
parseTypes :: GHC.HscEnv -> FilePath -> IO ([Type], [Comment])
parseTypes :: HscEnv -> String -> IO ([Type], [Comment])
parseTypes HscEnv
env String
file = do
(PState
pstate, [Located String]
_) <- HscEnv -> String -> IO (PState, [Located String])
mkCppState HscEnv
env String
file
let showGhc :: GHC.Outputable a => a -> Text
showGhc :: forall a. Outputable a => a -> Text
showGhc = String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> String
H.showGhc
case forall a. P a -> PState -> ParseResult a
GHC.unP P (Located HsModule)
Parser.parseModule PState
pstate of
GHC.POk PState
st (GHC.L SrcSpan
_ HsModule
hsmod) -> do
let decls :: [LHsDecl GhcPs]
decls = HsModule -> [LHsDecl GhcPs]
GHC.hsmodDecls HsModule
hsmod
findType :: GenLocated l (HsDecl GhcPs) -> Maybe Type
findType (GHC.L l
_ (GHC.TyClD XTyClD GhcPs
_ (GHC.DataDecl XDataDecl GhcPs
_ LIdP GhcPs
tycon' (GHC.HsQTvs XHsQTvs GhcPs
_ [LHsTyVarBndr () GhcPs]
tparams') LexicalFixity
fixity HsDataDefn GhcPs
ddn))) =
let
tycon :: Text
tycon = case LexicalFixity
fixity of
LexicalFixity
GHC.Prefix -> forall a. Outputable a => a -> Text
showGhc LIdP GhcPs
tycon'
LexicalFixity
GHC.Infix -> Text
"(" forall a. Semigroup a => a -> a -> a
<> forall a. Outputable a => a -> Text
showGhc LIdP GhcPs
tycon' forall a. Semigroup a => a -> a -> a
<> Text
")"
tparams :: [Text]
tparams = LHsTyVarBndr () GhcPs -> Text
renderTparam forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LHsTyVarBndr () GhcPs]
tparams'
#if MIN_VERSION_GLASGOW_HASKELL(9,5,0,0)
nt = case GHC.dd_cons ddn of
GHC.NewTypeCon _ -> True
GHC.DataTypeCons _ _ -> False
#else
nt :: Bool
nt = case forall pass. HsDataDefn pass -> NewOrData
GHC.dd_ND HsDataDefn GhcPs
ddn of
NewOrData
GHC.NewType -> Bool
True
NewOrData
GHC.DataType -> Bool
False
#endif
renderTyParams :: GHC.LHsType GHC.GhcPs -> [Text]
renderTyParams :: LHsType GhcPs -> [Text]
renderTyParams LHsType GhcPs
tpe = forall a. Outputable a => a -> Text
showGhc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
#if MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
LHsType GhcPs -> FreeKiTyVars
GHC.extractHsTyRdrTyVars LHsType GhcPs
tpe
#else
(GHC.freeKiTyVarsTypeVars $ GHC.extractHsTyRdrTyVars tpe)
#endif
renderField :: GHC.GenLocated l (GHC.ConDeclField GHC.GhcPs) -> (Text, Text, [Text])
renderField :: forall l. GenLocated l (ConDeclField GhcPs) -> (Text, Text, [Text])
renderField (GHC.L l
_ ConDeclField GhcPs
field) =
let tpe :: LHsType GhcPs
tpe = forall pass. ConDeclField pass -> LBangType pass
GHC.cd_fld_type ConDeclField GhcPs
field
in (forall a. Outputable a => a -> Text
showGhc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ forall pass. ConDeclField pass -> [LFieldOcc pass]
GHC.cd_fld_names ConDeclField GhcPs
field, forall a. Outputable a => a -> Text
showGhc GenLocated SrcSpanAnnA (HsType GhcPs)
tpe, LHsType GhcPs -> [Text]
renderTyParams GenLocated SrcSpanAnnA (HsType GhcPs)
tpe)
renderArg' :: GHC.LBangType GHC.GhcPs -> (Text, [Text])
renderArg' :: LHsType GhcPs -> (Text, [Text])
renderArg' t :: LHsType GhcPs
t@(GHC.L SrcSpanAnnA
_ HsType GhcPs
arg) = (forall a. Outputable a => a -> Text
showGhc HsType GhcPs
arg, LHsType GhcPs -> [Text]
renderTyParams LHsType GhcPs
t)
#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
renderArg :: HsScaled pass (GenLocated SrcSpanAnnA (HsType GhcPs))
-> (Text, [Text])
renderArg = LHsType GhcPs -> (Text, [Text])
renderArg' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass a. HsScaled pass a -> a
GHC.hsScaledThing
#else
renderArg = renderArg'
#endif
rhs :: [(Text, Either [(Text, Text, [Text])] [(Text, [Text])])]
rhs = do
#if MIN_VERSION_GLASGOW_HASKELL(9,5,0,0)
ddl <- case GHC.dd_cons ddn of
GHC.NewTypeCon (GHC.unLoc -> a) -> [a]
GHC.DataTypeCons _ (fmap GHC.unLoc -> as) -> as
#else
(GHC.L SrcSpanAnnA
_ ConDecl GhcPs
ddl) <- forall pass. HsDataDefn pass -> [LConDecl pass]
GHC.dd_cons HsDataDefn GhcPs
ddn
#endif
case ConDecl GhcPs
ddl of
GHC.ConDeclH98 XConDeclH98 GhcPs
_ LIdP GhcPs
cons Bool
_ [LHsTyVarBndr Specificity GhcPs]
_ Maybe (LHsContext GhcPs)
_ (GHC.RecCon (GHC.L SrcSpanAnnL
_ [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
fields)) Maybe LHsDocString
_ -> [(forall a. Outputable a => a -> Text
showGhc LIdP GhcPs
cons, forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall l. GenLocated l (ConDeclField GhcPs) -> (Text, Text, [Text])
renderField forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
fields)]
GHC.ConDeclH98 XConDeclH98 GhcPs
_ LIdP GhcPs
cons Bool
_ [LHsTyVarBndr Specificity GhcPs]
_ Maybe (LHsContext GhcPs)
_ (GHC.InfixCon HsScaled GhcPs (LHsType GhcPs)
a1 HsScaled GhcPs (LHsType GhcPs)
a2) Maybe LHsDocString
_ -> [(Text
"(" forall a. Semigroup a => a -> a -> a
<> forall a. Outputable a => a -> Text
showGhc LIdP GhcPs
cons forall a. Semigroup a => a -> a -> a
<> Text
")", forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall {pass}.
HsScaled pass (GenLocated SrcSpanAnnA (HsType GhcPs))
-> (Text, [Text])
renderArg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [HsScaled GhcPs (LHsType GhcPs)
a1, HsScaled GhcPs (LHsType GhcPs)
a2])]
#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)
GHC.ConDeclH98 XConDeclH98 GhcPs
_ LIdP GhcPs
cons Bool
_ [LHsTyVarBndr Specificity GhcPs]
_ Maybe (LHsContext GhcPs)
_ (GHC.PrefixCon [Void]
_ [HsScaled GhcPs (LHsType GhcPs)]
args) Maybe LHsDocString
_ -> [(forall a. Outputable a => a -> Text
showGhc LIdP GhcPs
cons, forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall {pass}.
HsScaled pass (GenLocated SrcSpanAnnA (HsType GhcPs))
-> (Text, [Text])
renderArg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [HsScaled GhcPs (LHsType GhcPs)]
args)]
#else
GHC.ConDeclH98 _ cons _ _ _ (GHC.PrefixCon args) _ -> [(showGhc cons, Right $ renderArg <$> args)]
#endif
ConDecl GhcPs
_ -> []
in case [(Text, Either [(Text, Text, [Text])] [(Text, [Text])])]
rhs of
[] -> forall a. Maybe a
Nothing
[(Text
cons, Right [(Text, [Text])]
tpes)] -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Bool -> Text -> [(Text, [Text])] -> Type
ProductType Text
tycon [Text]
tparams Bool
nt Text
cons [(Text, [Text])]
tpes
[(Text
cons, Left [(Text, Text, [Text])]
fields)] -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Bool -> Text -> [(Text, Text, [Text])] -> Type
RecordType Text
tycon [Text]
tparams Bool
nt Text
cons [(Text, Text, [Text])]
fields
[(Text, Either [(Text, Text, [Text])] [(Text, [Text])])]
mult -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> [(Text, [(Text, [Text])])] -> Type
SumType Text
tycon [Text]
tparams forall a b. (a -> b) -> a -> b
$ forall {f :: * -> *} {a} {a} {a} {b}.
Functor f =>
(a, Either (f (a, a, b)) (f (a, b))) -> (a, f (a, b))
render forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Either [(Text, Text, [Text])] [(Text, [Text])])]
mult
where
render :: (a, Either (f (a, a, b)) (f (a, b))) -> (a, f (a, b))
render (a
cons, Right f (a, b)
args) = (a
cons, f (a, b)
args)
render (a
cons, Left f (a, a, b)
fargs) = (a
cons, (\(a
_, a
tpes, b
typs) -> (a
tpes, b
typs)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a, a, b)
fargs)
findType GenLocated l (HsDecl GhcPs)
_ = forall a. Maybe a
Nothing
#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
renderTparam :: GHC.LHsTyVarBndr () GHC.GhcPs -> Text
renderTparam :: LHsTyVarBndr () GhcPs -> Text
renderTparam (GHC.L SrcSpanAnnA
_ (GHC.UserTyVar XUserTyVar GhcPs
_ ()
_ LIdP GhcPs
p)) = forall a. Outputable a => a -> Text
showGhc LIdP GhcPs
p
renderTparam (GHC.L SrcSpanAnnA
_ (GHC.KindedTyVar XKindedTyVar GhcPs
_ ()
_ LIdP GhcPs
p LHsType GhcPs
_)) = forall a. Outputable a => a -> Text
showGhc LIdP GhcPs
p
#else
renderTparam :: GHC.GenLocated l (GHC.HsTyVarBndr GHC.GhcPs) -> Text
renderTparam (GHC.L _ (GHC.UserTyVar _ p)) = showGhc p
renderTparam (GHC.L _ (GHC.KindedTyVar _ p _)) = showGhc p
renderTparam (GHC.L _ (GHC.XTyVarBndr _)) = "<unsupported>"
#endif
#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)
extractComment :: GenLocated Anchor EpaComment -> Maybe Comment
extractComment (GHC.L (Anchor -> RealSrcSpan
GHC.anchor -> RealSrcSpan
pos) EpaComment
c) =
#elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
extractComment (GHC.L pos c) =
#else
extractComment (GHC.L (GHC.RealSrcSpan pos) c) =
#endif
let start :: Pos
start = Int -> Int -> Pos
Pos (RealSrcSpan -> Int
GHC.srcSpanStartLine RealSrcSpan
pos) (RealSrcSpan -> Int
GHC.srcSpanStartCol RealSrcSpan
pos)
end :: Pos
end = Int -> Int -> Pos
Pos (RealSrcSpan -> Int
GHC.srcSpanEndLine RealSrcSpan
pos) (RealSrcSpan -> Int
GHC.srcSpanEndCol RealSrcSpan
pos)
#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)
in (\String
str -> Text -> Pos -> Pos -> Comment
Comment (String -> Text
T.pack String
str) Pos
start Pos
end) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case EpaComment -> EpaCommentTok
GHC.ac_tok EpaComment
c of
(GHC.EpaLineComment String
txt) -> forall a. a -> Maybe a
Just String
txt
(GHC.EpaBlockComment String
txt) -> forall a. a -> Maybe a
Just String
txt
EpaCommentTok
_ -> forall a. Maybe a
Nothing
#else
in (\str -> Comment (T.pack str) start end) <$> case c of
(GHC.AnnLineComment txt) -> Just txt
(GHC.AnnBlockComment txt) -> Just txt
_ -> Nothing
#endif
#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
#else
extractComment _ = Nothing
#endif
types :: [Type]
types = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {l}. GenLocated l (HsDecl GhcPs) -> Maybe Type
findType [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
decls
comments :: [Comment]
comments = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe GenLocated Anchor EpaComment -> Maybe Comment
extractComment forall a b. (a -> b) -> a -> b
$ PState -> [GenLocated Anchor EpaComment]
GHC.comment_q PState
st
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Type]
types, forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\(Comment Text
_ Pos
s Pos
_) -> Pos
s) [Comment]
comments)
#if MIN_VERSION_GLASGOW_HASKELL(9,5,0,0)
GHC.PFailed st ->
let errs = GHC.interppSP
. GHC.pprMsgEnvelopeBagWithLocDefault
. GHC.getMessages
$ GHC.getPsErrorMessages st
in throwIO . userError $ "unable to parse " <> file <> " due to " <> GHC.showSDocUnsafe errs
#elif MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)
GHC.PFailed st ->
let errs = GHC.interppSP
. GHC.pprMsgEnvelopeBagWithLoc
. GHC.getMessages
$ GHC.getPsErrorMessages st
in throwIO . userError $ "unable to parse " <> file <> " due to " <> GHC.showSDocUnsafe errs
#elif MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)
GHC.PFailed PState
st ->
let errs :: SDoc
errs = forall a. Outputable a => [a] -> SDoc
GHC.interppSP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bag (MsgEnvelope DecoratedSDoc) -> [SDoc]
GHC.pprMsgEnvelopeBagWithLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsError -> MsgEnvelope DecoratedSDoc
GHC.pprError
forall a b. (a -> b) -> a -> b
$ PState -> Bag PsError
GHC.getErrorMessages PState
st
in forall e a. Exception e => e -> IO a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IOError
userError forall a b. (a -> b) -> a -> b
$ String
"unable to parse " forall a. Semigroup a => a -> a -> a
<> String
file forall a. Semigroup a => a -> a -> a
<> String
" due to " forall a. Semigroup a => a -> a -> a
<> SDoc -> String
GHC.showSDocUnsafe SDoc
errs
#elif MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)
GHC.PFailed st ->
let errs = GHC.interppSP
. GHC.pprErrMsgBagWithLoc
. GHC.getErrorMessages st
$ GHC.unsafeGlobalDynFlags
in throwIO . userError $ "unable to parse " <> file <> " due to " <> GHC.showSDocUnsafe errs
#else
GHC.PFailed _ _ err -> throwIO . userError $ "unable to parse " <> file <> " due to " <> GHC.showSDocUnsafe err
#endif