{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

module HsInspect.Types where

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 qualified DynFlags as GHC
import GHC (HscEnv)
import qualified GHC as GHC
import HsInspect.Sexp
import qualified HsInspect.Util as H
import HsInspect.Workarounds (mkCppState)
import qualified Lexer as GHC
import qualified Outputable as GHC
import qualified Parser
import qualified RnTypes as GHC
#if __GLASGOW_HASKELL__ >= 810
import qualified ErrUtils as GHC
#endif

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
(Type -> Type -> Bool) -> (Type -> Type -> Bool) -> Eq Type
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
(Int -> Type -> ShowS)
-> (Type -> String) -> ([Type] -> ShowS) -> Show Type
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 ([(Sexp, Sexp)] -> Sexp) -> [(Sexp, Sexp)] -> Sexp
forall a b. (a -> b) -> a -> b
$ (Sexp
"class", Sexp
"product") (Sexp, Sexp) -> [(Sexp, Sexp)] -> [(Sexp, Sexp)]
forall a. a -> [a] -> [a]
: [(Sexp
"type", Text -> Sexp
forall a. ToSexp a => a -> Sexp
toSexp Text
p_1_1), (Sexp
"tparams", [Text] -> Sexp
forall a. ToSexp a => a -> Sexp
toSexp [Text]
p_1_2), (Sexp
"newtype", Bool -> Sexp
forall a. ToSexp a => a -> Sexp
toSexp Bool
p_1_3), (Sexp
"cons", Text -> Sexp
forall a. ToSexp a => a -> Sexp
toSexp Text
p_1_4), (Sexp
"params", [(Text, [Text])] -> Sexp
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 ([(Sexp, Sexp)] -> Sexp) -> [(Sexp, Sexp)] -> Sexp
forall a b. (a -> b) -> a -> b
$ (Sexp
"class", Sexp
"record") (Sexp, Sexp) -> [(Sexp, Sexp)] -> [(Sexp, Sexp)]
forall a. a -> [a] -> [a]
: [(Sexp
"type", Text -> Sexp
forall a. ToSexp a => a -> Sexp
toSexp Text
p_1_1), (Sexp
"tparams", [Text] -> Sexp
forall a. ToSexp a => a -> Sexp
toSexp [Text]
p_1_2), (Sexp
"newtype", Bool -> Sexp
forall a. ToSexp a => a -> Sexp
toSexp Bool
p_1_3), (Sexp
"cons", Text -> Sexp
forall a. ToSexp a => a -> Sexp
toSexp Text
p_1_4), (Sexp
"fields", [(Text, Text, [Text])] -> Sexp
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 ([(Sexp, Sexp)] -> Sexp) -> [(Sexp, Sexp)] -> Sexp
forall a b. (a -> b) -> a -> b
$ (Sexp
"class", Sexp
"sum") (Sexp, Sexp) -> [(Sexp, Sexp)] -> [(Sexp, Sexp)]
forall a. a -> [a] -> [a]
: [(Sexp
"type", Text -> Sexp
forall a. ToSexp a => a -> Sexp
toSexp Text
p_1_1), (Sexp
"tparams", [Text] -> Sexp
forall a. ToSexp a => a -> Sexp
toSexp [Text]
p_1_2), (Sexp
"data", [(Text, [(Text, [Text])])] -> Sexp
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
(Pos -> Pos -> Bool) -> (Pos -> Pos -> Bool) -> Eq Pos
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
Eq Pos
-> (Pos -> Pos -> Ordering)
-> (Pos -> Pos -> Bool)
-> (Pos -> Pos -> Bool)
-> (Pos -> Pos -> Bool)
-> (Pos -> Pos -> Bool)
-> (Pos -> Pos -> Pos)
-> (Pos -> Pos -> Pos)
-> Ord 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
$cp1Ord :: Eq Pos
Ord, Int -> Pos -> ShowS
[Pos] -> ShowS
Pos -> String
(Int -> Pos -> ShowS)
-> (Pos -> String) -> ([Pos] -> ShowS) -> Show Pos
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", Int -> Sexp
forall a. ToSexp a => a -> Sexp
toSexp Int
p_1_1), (Sexp
"col", Int -> Sexp
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
(Comment -> Comment -> Bool)
-> (Comment -> Comment -> Bool) -> Eq Comment
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
(Int -> Comment -> ShowS)
-> (Comment -> String) -> ([Comment] -> ShowS) -> Show Comment
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", Text -> Sexp
forall a. ToSexp a => a -> Sexp
toSexp Text
p_1_1), (Sexp
"start", Pos -> Sexp
forall a. ToSexp a => a -> Sexp
toSexp Pos
p_1_2), (Sexp
"end", Pos -> Sexp
forall a. ToSexp a => a -> Sexp
toSexp Pos
p_1_3)]
{- BOILERPLATE END -}

types :: GHC.GhcMonad m => FilePath -> m ([Type], [Comment])
types :: String -> m ([Type], [Comment])
types String
file = do
  DynFlags
dflags <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
  [InstalledUnitId]
_ <- DynFlags -> m [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
GHC.setSessionDynFlags (DynFlags -> m [InstalledUnitId])
-> DynFlags -> m [InstalledUnitId]
forall a b. (a -> b) -> a -> b
$ DynFlags -> GeneralFlag -> DynFlags
GHC.gopt_set DynFlags
dflags GeneralFlag
GHC.Opt_KeepRawTokenStream
  HscEnv
env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
GHC.getSession
  IO ([Type], [Comment]) -> m ([Type], [Comment])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([Type], [Comment]) -> m ([Type], [Comment]))
-> IO ([Type], [Comment]) -> m ([Type], [Comment])
forall a b. (a -> b) -> a -> b
$ HscEnv -> String -> IO ([Type], [Comment])
parseTypes HscEnv
env String
file

parseTypes :: 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 :: a -> Text
showGhc = String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Outputable a => a -> String
H.showGhc
  case P (Located (HsModule GhcPs))
-> PState -> ParseResult (Located (HsModule GhcPs))
forall a. P a -> PState -> ParseResult a
GHC.unP P (Located (HsModule GhcPs))
Parser.parseModule PState
pstate of
    -- ParseResult (Located (HsModule GhcPs))
    GHC.POk PState
st (GHC.L SrcSpan
_ HsModule GhcPs
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 GhcPs -> [LHsDecl GhcPs]
forall pass. HsModule pass -> [LHsDecl pass]
GHC.hsmodDecls HsModule GhcPs
hsmod
          findType :: GenLocated l (HsDecl GhcPs) -> Maybe Type
findType (GHC.L l
_ (GHC.TyClD XTyClD GhcPs
_ (GHC.DataDecl XDataDecl GhcPs
_ Located (IdP 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 -> Located (IdP GhcPs) -> Text
forall a. Outputable a => a -> Text
showGhc Located (IdP GhcPs)
tycon'
                LexicalFixity
GHC.Infix -> Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Located (IdP GhcPs) -> Text
forall a. Outputable a => a -> Text
showGhc Located (IdP GhcPs)
tycon' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
              tparams :: [Text]
tparams = LHsTyVarBndr GhcPs -> Text
forall l. GenLocated l (HsTyVarBndr GhcPs) -> Text
renderTparam (LHsTyVarBndr GhcPs -> Text) -> [LHsTyVarBndr GhcPs] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LHsTyVarBndr GhcPs]
tparams'
              nt :: Bool
nt = case HsDataDefn GhcPs -> NewOrData
forall pass. HsDataDefn pass -> NewOrData
GHC.dd_ND HsDataDefn GhcPs
ddn of
                NewOrData
GHC.NewType -> Bool
True
                NewOrData
GHC.DataType -> Bool
False
              renderTyParams :: GHC.LHsType GHC.GhcPs -> [Text]
              renderTyParams :: LHsType GhcPs -> [Text]
renderTyParams LHsType GhcPs
tpe = Located RdrName -> Text
forall a. Outputable a => a -> Text
showGhc (Located RdrName -> Text) -> [Located RdrName] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
#if __GLASGOW_HASKELL__ >= 810
                LHsType GhcPs -> [Located RdrName]
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 :: GenLocated l (ConDeclField GhcPs) -> (Text, Text, [Text])
renderField (GHC.L l
_ ConDeclField GhcPs
field) =
                let tpe :: LHsType GhcPs
tpe = ConDeclField GhcPs -> LHsType GhcPs
forall pass. ConDeclField pass -> LBangType pass
GHC.cd_fld_type ConDeclField GhcPs
field
                 in (LFieldOcc GhcPs -> Text
forall a. Outputable a => a -> Text
showGhc (LFieldOcc GhcPs -> Text)
-> ([LFieldOcc GhcPs] -> LFieldOcc GhcPs)
-> [LFieldOcc GhcPs]
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LFieldOcc GhcPs] -> LFieldOcc GhcPs
forall a. [a] -> a
head ([LFieldOcc GhcPs] -> Text) -> [LFieldOcc GhcPs] -> Text
forall a b. (a -> b) -> a -> b
$ ConDeclField GhcPs -> [LFieldOcc GhcPs]
forall pass. ConDeclField pass -> [LFieldOcc pass]
GHC.cd_fld_names ConDeclField GhcPs
field, LHsType GhcPs -> Text
forall a. Outputable a => a -> Text
showGhc LHsType GhcPs
tpe, LHsType GhcPs -> [Text]
renderTyParams LHsType GhcPs
tpe)
              renderArg :: GHC.LBangType GHC.GhcPs -> (Text, [Text]) -- (type, typarams)
              renderArg :: LHsType GhcPs -> (Text, [Text])
renderArg t :: LHsType GhcPs
t@(GHC.L SrcSpan
_ BangType GhcPs
arg) = (BangType GhcPs -> Text
forall a. Outputable a => a -> Text
showGhc BangType GhcPs
arg, LHsType GhcPs -> [Text]
renderTyParams LHsType GhcPs
t)
              -- rhs is (cons, [(field name, field type, [typarams])] | [(parameter type, [typarams])])
              rhs :: [(Text, Either [(Text, Text, [Text])] [(Text, [Text])])]
rhs = do
                (GHC.L SrcSpan
_ ConDecl GhcPs
ddl) <- HsDataDefn GhcPs -> [GenLocated SrcSpan (ConDecl GhcPs)]
forall pass. HsDataDefn pass -> [LConDecl pass]
GHC.dd_cons HsDataDefn GhcPs
ddn
                case ConDecl GhcPs
ddl of
                  -- http://hackage.haskell.org/package/ghc-8.8.3/docs/HsDecls.html#t:ConDecl
                  GHC.ConDeclH98 XConDeclH98 GhcPs
_ Located (IdP GhcPs)
cons Located Bool
_ [LHsTyVarBndr GhcPs]
_ Maybe (LHsContext GhcPs)
_ (GHC.RecCon (GHC.L SrcSpan
_ [LConDeclField GhcPs]
fields)) Maybe LHsDocString
_ -> [(Located (IdP GhcPs) -> Text
forall a. Outputable a => a -> Text
showGhc Located (IdP GhcPs)
cons, [(Text, Text, [Text])]
-> Either [(Text, Text, [Text])] [(Text, [Text])]
forall a b. a -> Either a b
Left ([(Text, Text, [Text])]
 -> Either [(Text, Text, [Text])] [(Text, [Text])])
-> [(Text, Text, [Text])]
-> Either [(Text, Text, [Text])] [(Text, [Text])]
forall a b. (a -> b) -> a -> b
$ LConDeclField GhcPs -> (Text, Text, [Text])
forall l. GenLocated l (ConDeclField GhcPs) -> (Text, Text, [Text])
renderField (LConDeclField GhcPs -> (Text, Text, [Text]))
-> [LConDeclField GhcPs] -> [(Text, Text, [Text])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LConDeclField GhcPs]
fields)]
                  GHC.ConDeclH98 XConDeclH98 GhcPs
_ Located (IdP GhcPs)
cons Located Bool
_ [LHsTyVarBndr GhcPs]
_ Maybe (LHsContext GhcPs)
_ (GHC.InfixCon LHsType GhcPs
a1 LHsType GhcPs
a2) Maybe LHsDocString
_ -> [(Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Located (IdP GhcPs) -> Text
forall a. Outputable a => a -> Text
showGhc Located (IdP GhcPs)
cons Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")", [(Text, [Text])] -> Either [(Text, Text, [Text])] [(Text, [Text])]
forall a b. b -> Either a b
Right ([(Text, [Text])]
 -> Either [(Text, Text, [Text])] [(Text, [Text])])
-> [(Text, [Text])]
-> Either [(Text, Text, [Text])] [(Text, [Text])]
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> (Text, [Text])
renderArg (LHsType GhcPs -> (Text, [Text]))
-> [LHsType GhcPs] -> [(Text, [Text])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LHsType GhcPs
a1, LHsType GhcPs
a2])]
                  GHC.ConDeclH98 XConDeclH98 GhcPs
_ Located (IdP GhcPs)
cons Located Bool
_ [LHsTyVarBndr GhcPs]
_ Maybe (LHsContext GhcPs)
_ (GHC.PrefixCon [LHsType GhcPs]
args) Maybe LHsDocString
_ -> [(Located (IdP GhcPs) -> Text
forall a. Outputable a => a -> Text
showGhc Located (IdP GhcPs)
cons, [(Text, [Text])] -> Either [(Text, Text, [Text])] [(Text, [Text])]
forall a b. b -> Either a b
Right ([(Text, [Text])]
 -> Either [(Text, Text, [Text])] [(Text, [Text])])
-> [(Text, [Text])]
-> Either [(Text, Text, [Text])] [(Text, [Text])]
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> (Text, [Text])
renderArg (LHsType GhcPs -> (Text, [Text]))
-> [LHsType GhcPs] -> [(Text, [Text])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LHsType GhcPs]
args)]
                  ConDecl GhcPs
_ -> [] -- GADTS

             in case [(Text, Either [(Text, Text, [Text])] [(Text, [Text])])]
rhs of
              [] -> Maybe Type
forall a. Maybe a
Nothing
              [(Text
cons, Right [(Text, [Text])]
tpes)] -> Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Type -> Maybe Type
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)] -> Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Type -> Maybe Type
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 -> Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type)
-> ([(Text, [(Text, [Text])])] -> Type)
-> [(Text, [(Text, [Text])])]
-> Maybe Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> [(Text, [(Text, [Text])])] -> Type
SumType Text
tycon [Text]
tparams ([(Text, [(Text, [Text])])] -> Maybe Type)
-> [(Text, [(Text, [Text])])] -> Maybe Type
forall a b. (a -> b) -> a -> b
$ (Text, Either [(Text, Text, [Text])] [(Text, [Text])])
-> (Text, [(Text, [Text])])
forall (f :: * -> *) a a a b.
Functor f =>
(a, Either (f (a, a, b)) (f (a, b))) -> (a, f (a, b))
render ((Text, Either [(Text, Text, [Text])] [(Text, [Text])])
 -> (Text, [(Text, [Text])]))
-> [(Text, Either [(Text, Text, [Text])] [(Text, [Text])])]
-> [(Text, [(Text, [Text])])]
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)) ((a, a, b) -> (a, b)) -> f (a, a, b) -> f (a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a, a, b)
fargs)

          findType GenLocated l (HsDecl GhcPs)
_ = Maybe Type
forall a. Maybe a
Nothing

          renderTparam :: GHC.GenLocated l (GHC.HsTyVarBndr GHC.GhcPs) -> Text
          renderTparam :: GenLocated l (HsTyVarBndr GhcPs) -> Text
renderTparam (GHC.L l
_ (GHC.UserTyVar XUserTyVar GhcPs
_ Located (IdP GhcPs)
p)) = Located RdrName -> Text
forall a. Outputable a => a -> Text
showGhc Located (IdP GhcPs)
Located RdrName
p
          renderTparam (GHC.L l
_ (GHC.KindedTyVar XKindedTyVar GhcPs
_ Located (IdP GhcPs)
p LHsType GhcPs
_)) = Located RdrName -> Text
forall a. Outputable a => a -> Text
showGhc Located (IdP GhcPs)
Located RdrName
p
          renderTparam (GHC.L l
_ (GHC.XTyVarBndr XXTyVarBndr GhcPs
_)) = Text
"<unsupported>"

          extractComment :: GenLocated SrcSpan AnnotationComment -> Maybe Comment
extractComment (GHC.L (GHC.RealSrcSpan RealSrcSpan
pos) AnnotationComment
c) =
            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)
             in (\String
str -> Text -> Pos -> Pos -> Comment
Comment (String -> Text
T.pack String
str) Pos
start Pos
end) (String -> Comment) -> Maybe String -> Maybe Comment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case AnnotationComment
c of
            (GHC.AnnLineComment String
txt) -> String -> Maybe String
forall a. a -> Maybe a
Just String
txt
            (GHC.AnnBlockComment String
txt) -> String -> Maybe String
forall a. a -> Maybe a
Just String
txt
            AnnotationComment
_ -> Maybe String
forall a. Maybe a
Nothing
          extractComment GenLocated SrcSpan AnnotationComment
_ = Maybe Comment
forall a. Maybe a
Nothing

          types :: [Type]
types = (LHsDecl GhcPs -> Maybe Type) -> [LHsDecl GhcPs] -> [Type]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe LHsDecl GhcPs -> Maybe Type
forall l. GenLocated l (HsDecl GhcPs) -> Maybe Type
findType [LHsDecl GhcPs]
decls
          comments :: [Comment]
comments = (GenLocated SrcSpan AnnotationComment -> Maybe Comment)
-> [GenLocated SrcSpan AnnotationComment] -> [Comment]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe GenLocated SrcSpan AnnotationComment -> Maybe Comment
extractComment ([GenLocated SrcSpan AnnotationComment] -> [Comment])
-> [GenLocated SrcSpan AnnotationComment] -> [Comment]
forall a b. (a -> b) -> a -> b
$ PState -> [GenLocated SrcSpan AnnotationComment]
GHC.comment_q PState
st

      ([Type], [Comment]) -> IO ([Type], [Comment])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Type]
types, (Comment -> Pos) -> [Comment] -> [Comment]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\(Comment Text
_ Pos
s Pos
_) -> Pos
s) [Comment]
comments)

#if __GLASGOW_HASKELL__ >= 810
    GHC.PFailed PState
st ->
      let errs :: SDoc
errs = [SDoc] -> SDoc
forall a. Outputable a => [a] -> SDoc
GHC.interppSP
            ([SDoc] -> SDoc) -> (DynFlags -> [SDoc]) -> DynFlags -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bag ErrMsg -> [SDoc]
GHC.pprErrMsgBagWithLoc
            (Bag ErrMsg -> [SDoc])
-> (DynFlags -> Bag ErrMsg) -> DynFlags -> [SDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PState -> DynFlags -> Bag ErrMsg
GHC.getErrorMessages PState
st
            (DynFlags -> SDoc) -> DynFlags -> SDoc
forall a b. (a -> b) -> a -> b
$ DynFlags
GHC.unsafeGlobalDynFlags
      in IOError -> IO ([Type], [Comment])
forall e a. Exception e => e -> IO a
throwIO (IOError -> IO ([Type], [Comment]))
-> (String -> IOError) -> String -> IO ([Type], [Comment])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IOError
userError (String -> IO ([Type], [Comment]))
-> String -> IO ([Type], [Comment])
forall a b. (a -> b) -> a -> b
$ String
"unable to parse " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
file String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" due to " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SDoc -> String
GHC.showSDocUnsafe SDoc
errs
#else
    GHC.PFailed _ _ err -> throwIO . userError $ "unable to parse " <> file <> " due to " <> GHC.showSDocUnsafe err
#endif