{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module GhcTags.Ghc
( GhcTag (..)
, GhcTags
, GhcTagKind (..)
, getGhcTags
) where
import Data.Maybe (mapMaybe)
import Data.Foldable (foldl')
import Data.ByteString (ByteString)
import BasicTypes ( SourceText (..)
)
import FastString ( FastString (..)
)
import FieldLabel ( FieldLbl (..)
)
import HsBinds ( HsBindLR (..)
, PatSynBind (..)
, Sig (..)
)
import HsDecls ( ForeignImport (..)
, ClsInstDecl (..)
, ConDecl (..)
, DataFamInstDecl (..)
, FamEqn (..)
, FamilyDecl (..)
, FamilyInfo (..)
, FamilyResultSig (..)
, ForeignDecl (..)
, LHsDecl
, HsConDeclDetails
, HsDecl (..)
, HsDataDefn (..)
, InstDecl (..)
, TyClDecl (..)
, TyFamInstDecl (..)
, hsConDeclArgTys
)
import HsImpExp ( IE (..)
, IEWildcard (..)
, ieWrappedName
)
import HsSyn ( FieldOcc (..)
, GhcPs
, HsModule (..)
, LFieldOcc
)
import HsTypes ( ConDeclField (..)
, HsConDetails (..)
, HsImplicitBndrs (..)
, HsKind
, HsType (..)
, HsWildCardBndrs
, LConDeclField
, LHsType
, LHsSigType
, HsTyVarBndr (..)
)
import SrcLoc ( GenLocated (..)
, Located
, SrcSpan (..)
, unLoc
)
import RdrName ( RdrName (..)
, rdrNameOcc
)
import Name ( nameOccName
, occNameFS
)
data GhcTagKind
= GtkTerm
| GtkFunction
| GtkTypeConstructor (Maybe (HsKind GhcPs))
| GtkDataConstructor (Located RdrName)
[HsType GhcPs]
| GtkGADTConstructor (HsType GhcPs)
| GtkRecordField
| GtkTypeSynonym (HsType GhcPs)
| GtkTypeSignature (HsWildCardBndrs GhcPs (LHsSigType GhcPs))
| GtkPatternSynonym
| GtkTypeClass
| GtkTypeClassMember
| GtkTypeClassInstance (HsType GhcPs)
| GtkTypeFamily (Maybe (HsKind GhcPs))
| GtkTypeFamilyInstance
| GtkDataTypeFamily (Maybe (HsKind GhcPs))
| GtkDataTypeFamilyInstance
| GtkForeignImport
| GtkForeignExport
data GhcTag = GhcTag {
gtSrcSpan :: !SrcSpan
, gtTag :: !ByteString
, gtKind :: !GhcTagKind
, gtIsExported :: !Bool
, gtFFI :: !(Maybe String)
}
type GhcTags = [GhcTag]
isExported :: Maybe [IE GhcPs] -> Located RdrName -> Bool
isExported Nothing _name = True
isExported (Just ies) (L _ name) =
any (\ie -> ieName ie == Just name) ies
where
ieName :: IE GhcPs -> Maybe RdrName
ieName (IEVar _ (L _ n)) = Just $ ieWrappedName n
ieName (IEThingAbs _ (L _ n)) = Just $ ieWrappedName n
ieName (IEThingWith _ (L _ n) _ _ _) = Just $ ieWrappedName n
ieName (IEThingAll _ (L _ n)) = Just $ ieWrappedName n
ieName _ = Nothing
isMemberExported :: Maybe [IE GhcPs]
-> Located RdrName
-> Located RdrName
-> Bool
isMemberExported Nothing _memberName _className = True
isMemberExported (Just ies) memberName className = any go ies
where
go :: IE GhcPs -> Bool
go (IEVar _ (L _ n)) = ieWrappedName n == unLoc memberName
go (IEThingAbs _ _) = False
go (IEThingAll _ (L _ n)) = ieWrappedName n == unLoc className
go (IEThingWith _ _ IEWildcard{} _ _) = True
go (IEThingWith _ (L _ n) NoIEWildcard ns lfls) =
ieWrappedName n == unLoc className
&& (isInWrappedNames || isInFieldLbls)
where
isInWrappedNames = any ((== occNameFS (rdrNameOcc (unLoc memberName))) . occNameFS . rdrNameOcc . ieWrappedName . unLoc) ns
isInFieldLbls = any ((== occNameFS (rdrNameOcc (unLoc memberName))) . occNameFS . rdrNameOcc . flSelector. unLoc) lfls
go _ = False
mkGhcTag :: Located RdrName
-> GhcTagKind
-> Bool
-> GhcTag
mkGhcTag (L gtSrcSpan rdrName) gtKind gtIsExported =
case rdrName of
Unqual occName ->
GhcTag { gtTag = fs_bs (occNameFS occName)
, gtSrcSpan
, gtKind
, gtIsExported
, gtFFI = Nothing
}
Qual _ occName ->
GhcTag { gtTag = fs_bs (occNameFS occName)
, gtSrcSpan
, gtKind
, gtIsExported
, gtFFI = Nothing
}
Orig _ occName ->
GhcTag { gtTag = fs_bs (occNameFS occName)
, gtSrcSpan
, gtKind
, gtIsExported
, gtFFI = Nothing
}
Exact eName ->
GhcTag { gtTag = fs_bs (occNameFS (nameOccName eName))
, gtSrcSpan
, gtKind
, gtIsExported
, gtFFI = Nothing
}
getGhcTags ::Located (HsModule GhcPs)
-> GhcTags
getGhcTags (L _ HsModule { hsmodDecls, hsmodExports }) =
reverse $ foldl' go [] hsmodDecls
where
mies :: Maybe [IE GhcPs]
mies = map unLoc . unLoc <$> hsmodExports
mkGhcTag' :: Located RdrName
-> GhcTagKind
-> GhcTag
mkGhcTag' a k = mkGhcTag a k (isExported mies a)
mkGhcTagForMember :: Located RdrName
-> Located RdrName
-> GhcTagKind
-> GhcTag
mkGhcTagForMember memberName className kind =
mkGhcTag memberName kind
(isMemberExported mies memberName className)
go :: GhcTags -> LHsDecl GhcPs -> GhcTags
go tags (L _ hsDecl) = case hsDecl of
TyClD _ tyClDecl ->
case tyClDecl of
FamDecl { tcdFam } ->
case mkFamilyDeclTags tcdFam Nothing of
Just tag -> tag : tags
Nothing -> tags
SynDecl { tcdLName, tcdRhs = L _ hsType } ->
mkGhcTag' tcdLName (GtkTypeSynonym hsType) : tags
DataDecl { tcdLName, tcdDataDefn } ->
case tcdDataDefn of
HsDataDefn { dd_cons, dd_kindSig } ->
mkGhcTag' tcdLName (GtkTypeConstructor (unLoc <$> dd_kindSig))
: (mkConsTags tcdLName . unLoc) `concatMap` dd_cons
++ tags
XHsDataDefn {} -> tags
ClassDecl { tcdLName, tcdSigs, tcdMeths, tcdATs, tcdATDefs } ->
mkGhcTag' tcdLName GtkTypeClass
: (mkClsMemberTags tcdLName . unLoc) `concatMap` tcdSigs
++ foldl' (\tags' hsBind -> mkHsBindLRTags (unLoc hsBind) ++ tags')
[]
tcdMeths
++ (flip mkFamilyDeclTags (Just tcdLName) . unLoc) `mapMaybe` tcdATs
++ foldl'
(\tags' (L _ tyFamDeflEqn) ->
case tyFamDeflEqn of
FamEqn { feqn_rhs } ->
case hsTypeTagName (unLoc feqn_rhs) of
Just a -> mkGhcTag' a GtkTypeFamilyInstance : tags'
Nothing -> tags'
XFamEqn {} -> tags')
[] tcdATDefs
++ tags
XTyClDecl {} -> tags
InstD _ instDecl ->
case instDecl of
ClsInstD { cid_inst } ->
case cid_inst of
XClsInstDecl {} -> tags
ClsInstDecl { cid_poly_ty, cid_tyfam_insts, cid_datafam_insts } ->
case cid_poly_ty of
XHsImplicitBndrs {} ->
tyFamTags ++ dataFamTags ++ tags
HsIB { hsib_body } ->
case mkLHsTypeTag hsib_body of
Nothing -> tyFamTags ++ dataFamTags ++ tags
Just tag -> tag : tyFamTags ++ dataFamTags ++ tags
where
dataFamTags = (mkDataFamInstDeclTag . unLoc) `concatMap` cid_datafam_insts
tyFamTags = (mkTyFamInstDeclTag . unLoc) `mapMaybe` cid_tyfam_insts
DataFamInstD { dfid_inst } ->
mkDataFamInstDeclTag dfid_inst ++ tags
TyFamInstD { tfid_inst } ->
case mkTyFamInstDeclTag tfid_inst of
Nothing -> tags
Just tag -> tag : tags
XInstDecl {} -> tags
DerivD {} -> tags
ValD _ hsBind -> mkHsBindLRTags hsBind ++ tags
SigD _ sig -> mkSigTags sig ++ tags
DefD {} -> tags
ForD _ foreignDecl ->
case foreignDecl of
ForeignImport { fd_name, fd_fi = CImport _ _ _mheader _ (L _ sourceText) } ->
case sourceText of
NoSourceText -> tag
SourceText s -> tag { gtFFI = Just s }
: tags
where
tag = mkGhcTag' fd_name GtkForeignImport
ForeignExport { fd_name } ->
mkGhcTag' fd_name GtkForeignExport
: tags
XForeignDecl {} -> tags
WarningD {} -> tags
AnnD {} -> tags
RuleD {} -> tags
SpliceD {} -> tags
DocD {} -> tags
RoleAnnotD {} -> tags
XHsDecl {} -> tags
mkConsTags :: Located RdrName
-> ConDecl GhcPs
-> GhcTags
mkConsTags tyName ConDeclGADT { con_names, con_args, con_res_ty = L _ con_res_ty } =
(\n -> mkGhcTagForMember n tyName (GtkGADTConstructor con_res_ty))
`map` con_names
++ mkHsConDeclDetails tyName con_args
mkConsTags tyName ConDeclH98 { con_name, con_args } =
mkGhcTagForMember con_name tyName
(GtkDataConstructor tyName (map unLoc $ hsConDeclArgTys con_args))
: mkHsConDeclDetails tyName con_args
mkConsTags _ XConDecl {} = []
mkHsConDeclDetails :: Located RdrName -> HsConDeclDetails GhcPs -> GhcTags
mkHsConDeclDetails tyName (RecCon (L _ fields)) =
foldl' f [] fields
where
f :: GhcTags -> LConDeclField GhcPs -> GhcTags
f ts (L _ ConDeclField { cd_fld_names }) = foldl' g ts cd_fld_names
f ts _ = ts
g :: GhcTags -> LFieldOcc GhcPs -> GhcTags
g ts (L _ FieldOcc { rdrNameFieldOcc }) =
mkGhcTagForMember rdrNameFieldOcc tyName GtkRecordField
: ts
g ts _ = ts
mkHsConDeclDetails _ _ = []
mkHsBindLRTags :: HsBindLR GhcPs GhcPs -> GhcTags
mkHsBindLRTags hsBind =
case hsBind of
FunBind { fun_id } -> [mkGhcTag' fun_id GtkFunction]
PatBind {} -> []
VarBind { var_id, var_rhs = L srcSpan _ } -> [mkGhcTag' (L srcSpan var_id) GtkTerm]
AbsBinds {} -> []
PatSynBind _ PSB { psb_id } -> [mkGhcTag' psb_id GtkPatternSynonym]
PatSynBind _ XPatSynBind {} -> []
XHsBindsLR {} -> []
mkClsMemberTags :: Located RdrName -> Sig GhcPs -> GhcTags
mkClsMemberTags clsName (TypeSig _ lhs hsSigWcType) =
(\n -> mkGhcTagForMember n clsName (GtkTypeSignature hsSigWcType))
`map` lhs
mkClsMemberTags clsName (PatSynSig _ lhs _) =
(\n -> mkGhcTagForMember n clsName GtkPatternSynonym)
`map` lhs
mkClsMemberTags clsName (ClassOpSig _ _ lhs _) =
(\n -> mkGhcTagForMember n clsName GtkTypeClassMember)
`map` lhs
mkClsMemberTags _ _ = []
mkSigTags :: Sig GhcPs -> GhcTags
mkSigTags (TypeSig _ lhs hsSigWcType)
= flip mkGhcTag' (GtkTypeSignature hsSigWcType)
`map` lhs
mkSigTags (PatSynSig _ lhs _) = flip mkGhcTag' GtkPatternSynonym `map` lhs
mkSigTags (ClassOpSig _ _ lhs _) = flip mkGhcTag' GtkTypeClassMember `map` lhs
mkSigTags IdSig {} = []
mkSigTags FixSig {} = []
mkSigTags InlineSig {} = []
mkSigTags SpecSig {} = []
mkSigTags SpecInstSig {} = []
mkSigTags MinimalSig {} = []
mkSigTags SCCFunSig {} = []
mkSigTags CompleteMatchSig {} = []
mkSigTags XSig {} = []
mkFamilyDeclTags :: FamilyDecl GhcPs
-> Maybe (Located RdrName)
-> Maybe GhcTag
mkFamilyDeclTags FamilyDecl { fdLName, fdInfo, fdResultSig = L _ familyResultSig } assocClsName =
case assocClsName of
Nothing -> Just $ mkGhcTag' fdLName tk
Just clsName -> Just $ mkGhcTagForMember fdLName clsName tk
where
tk = case fdInfo of
DataFamily -> GtkDataTypeFamily (famResultKindSignature familyResultSig)
OpenTypeFamily -> GtkTypeFamily (famResultKindSignature familyResultSig)
ClosedTypeFamily {} -> GtkTypeFamily (famResultKindSignature familyResultSig)
mkFamilyDeclTags XFamilyDecl {} _ = Nothing
mkLHsTypeTag :: LHsType GhcPs -> Maybe GhcTag
mkLHsTypeTag (L _ hsType) = (\a -> mkGhcTag a (GtkTypeClassInstance hsType) True) <$> hsTypeTagName hsType
hsTypeTagName :: HsType GhcPs -> Maybe (Located RdrName)
hsTypeTagName hsType =
case hsType of
HsForAllTy {hst_body} -> hsTypeTagName (unLoc hst_body)
HsQualTy {hst_body} -> hsTypeTagName (unLoc hst_body)
HsTyVar _ _ a -> Just $ a
HsAppTy _ a _ -> hsTypeTagName (unLoc a)
HsOpTy _ _ a _ -> Just $ a
HsKindSig _ a _ -> hsTypeTagName (unLoc a)
_ -> Nothing
mkDataFamInstDeclTag :: DataFamInstDecl GhcPs -> GhcTags
mkDataFamInstDeclTag DataFamInstDecl { dfid_eqn } =
case dfid_eqn of
XHsImplicitBndrs {} -> []
HsIB { hsib_body = FamEqn { feqn_tycon, feqn_rhs } } ->
case feqn_rhs of
HsDataDefn { dd_cons } ->
mkGhcTag' feqn_tycon GtkDataTypeFamilyInstance
: (mkConsTags feqn_tycon . unLoc) `concatMap` dd_cons
XHsDataDefn {} ->
mkGhcTag' feqn_tycon GtkDataTypeFamilyInstance : []
HsIB { hsib_body = XFamEqn {} } -> []
mkTyFamInstDeclTag :: TyFamInstDecl GhcPs -> Maybe GhcTag
mkTyFamInstDeclTag TyFamInstDecl { tfid_eqn } =
case tfid_eqn of
XHsImplicitBndrs {} -> Nothing
HsIB { hsib_body = FamEqn { feqn_tycon } } ->
Just $ mkGhcTag' feqn_tycon GtkTypeFamilyInstance
HsIB { hsib_body = XFamEqn {} } -> Nothing
famResultKindSignature :: FamilyResultSig GhcPs -> Maybe (HsKind GhcPs)
famResultKindSignature (NoSig _) = Nothing
famResultKindSignature (KindSig _ ki) = Just (unLoc ki)
famResultKindSignature (TyVarSig _ bndr) =
case unLoc bndr of
UserTyVar _ _ -> Nothing
KindedTyVar _ _ ki -> Just (unLoc ki)
XTyVarBndr {} -> Nothing
famResultKindSignature XFamilyResultSig {} = Nothing