{-# 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])]  -- ^^ type tparams newtype cons [(param types, [typarams])]
          | RecordType Text [Text] Bool Text [(Text, Text, [Text])] -- ^^ type tparams newtype cons [(fieldname, param type, [typarams])]
          | SumType Text [Text] [(Text, [(Text, [Text])])] -- ^^ type tparams [(cons, [param types, [typarams]])] (no records)
  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)
{- BOILERPLATE Type ToSexp
   field={ProductType:[type,tparams,newtype,cons,params],
          RecordType:[type,tparams,newtype,cons,fields],
          SumType:[type,tparams,data]}
   class={ProductType:product,
          RecordType:record,
          SumType:sum}
-}
{- BOILERPLATE START -}
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)]
{- BOILERPLATE END -}

-- line, col (1-indexed)
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)
{- BOILERPLATE Pos ToSexp field=[line,col] -}
{- BOILERPLATE START -}
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)]
{- BOILERPLATE END -}

data Comment = Comment Text Pos Pos -- text start end
  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)
{- BOILERPLATE Comment ToSexp field=[text,start,end] -}
{- BOILERPLATE START -}
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)]
{- BOILERPLATE END -}

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
    -- ParseResult (Located (HsModule GhcPs))
    GHC.POk PState
st (GHC.L SrcSpan
_ HsModule
hsmod) -> do
      -- http://hackage.haskell.org/package/ghc-8.8.3/docs/HsDecls.html#t:HsDecl
      -- [Located (HsDecl p)]
      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]) -- (name, type, [typarams])
              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]) -- (type, typarams)
              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 is (cons, [(field name, field type, [typarams])] | [(parameter type, [typarams])])
              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
                  -- http://hackage.haskell.org/package/ghc-8.8.3/docs/HsDecls.html#t:ConDecl
                  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
_ -> [] -- GADTS

             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