ghc-tags-1.4: src/GhcTags/Ghc.hs
-- | Generate tags from @'HsModule' 'GhcPs'@ representation.
--
module GhcTags.Ghc
( GhcTag (..)
, GhcTagKind (..)
, getGhcTags
, hsDeclsToGhcTags
) where
import Data.ByteString (ByteString)
import Data.Maybe
import GHC.Data.Bag
import GHC.Data.FastString
import GHC.Hs (HsModule(..), NoExtField(..))
import GHC.Hs.Binds
import GHC.Hs.Decls hiding (famResultKindSignature)
import GHC.Hs.Expr
import GHC.Hs.Extension
import GHC.Hs.ImpExp
import GHC.Hs.Type hiding (hsSigWcType)
import GHC.Parser.Annotation
import GHC.Types.Name (nameOccName, occNameFS)
import GHC.Types.Name.Reader
import GHC.Types.SourceText
import GHC.Types.SrcLoc
import GHC.Unit.Module.Name
-- | Kind of the term.
--
data GhcTagKind
= GtkModule
| GtkTerm
| GtkFunction
| GtkTypeConstructor (Maybe (HsKind GhcPs))
-- | H98 data construtor
| GtkDataConstructor (ConDecl GhcPs)
-- | GADT constructor with its type
| GtkGADTConstructor (ConDecl GhcPs)
| GtkRecordField
| GtkTypeSynonym (HsType GhcPs)
| GtkTypeSignature (HsWildCardBndrs GhcPs (LHsSigType GhcPs))
| GtkTypeKindSignature (LHsSigType GhcPs)
| GtkPatternSynonym
| GtkTypeClass
| GtkTypeClassMember (HsType GhcPs)
| GtkTypeClassInstance (HsType GhcPs)
| GtkTypeFamily (Maybe ([HsTyVarBndr () GhcPs], Either (HsKind GhcPs) (HsTyVarBndr () GhcPs)))
| GtkTypeFamilyInstance (TyFamInstDecl GhcPs)
| GtkDataTypeFamily (Maybe ([HsTyVarBndr () GhcPs], Either (HsKind GhcPs) (HsTyVarBndr () GhcPs)))
| GtkDataTypeFamilyInstance (Maybe (HsKind GhcPs))
| GtkForeignImport
| GtkForeignExport
-- | We can read names from using fields of type 'GHC.Hs.Extensions.IdP' (a type
-- family) which for @'Parsed@ resolved to 'RdrName'
--
data GhcTag = GhcTag {
gtSrcSpan :: SrcSpan
-- ^ term location
, gtTag :: ByteString
-- ^ utf8 encoded tag's name
, gtKind :: GhcTagKind
-- ^ tag's kind
, gtIsExported :: Bool
-- ^ 'True' iff the term is exported
, gtFFI :: Maybe String
-- ^ @ffi@ import
}
-- | Check if an identifier is exported.
--
isExported :: Maybe [IE GhcPs] -> LocatedN RdrName -> Bool
isExported Nothing _name = True
isExported (Just ies) (L _ name) =
any (\ie -> listToMaybe (ieNames ie) == Just name) ies
-- | Check if a class member or a type constructors is exported.
--
isMemberExported :: Maybe [IE GhcPs]
-> LocatedN RdrName -- member name / constructor name
-> LocatedN RdrName -- type class name / type constructor name
-> 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) =
ieWrappedName n == unLoc className
&& isInWrappedNames
where
-- the 'NameSpace' does not agree between things that are in the 'IE'
-- list and passed member or type class names (constructor / type
-- constructor names, respectively)
isInWrappedNames = any ((== occNameFS (rdrNameOcc (unLoc memberName))) . occNameFS . rdrNameOcc . ieWrappedName . unLoc) ns
go _ = False
-- | Create a 'GhcTag', effectively a smart constructor.
--
mkGhcTag :: LocatedN RdrName
-- ^ @RdrName ~ IdP GhcPs@ it *must* be a name of a top level identifier.
-> GhcTagKind
-- ^ tag's kind
-> Bool
-- ^ is term exported
-> GhcTag
mkGhcTag (L SrcSpanAnn { locA = gtSrcSpan } rdrName) gtKind gtIsExported =
case rdrName of
Unqual occName ->
GhcTag { gtTag = bytesFS (occNameFS occName)
, gtSrcSpan
, gtKind
, gtIsExported
, gtFFI = Nothing
}
Qual _ occName ->
GhcTag { gtTag = bytesFS (occNameFS occName)
, gtSrcSpan
, gtKind
, gtIsExported
, gtFFI = Nothing
}
-- Orig is the only one we are interested in
Orig _ occName ->
GhcTag { gtTag = bytesFS (occNameFS occName)
, gtSrcSpan
, gtKind
, gtIsExported
, gtFFI = Nothing
}
Exact eName ->
GhcTag { gtTag = bytesFS (occNameFS (nameOccName eName))
, gtSrcSpan
, gtKind
, gtIsExported
, gtFFI = Nothing
}
-- | Generate tags for a module - simple walk over the syntax tree.
--
-- Supported identifiers:
--
-- * /module name/
-- * /top level terms/
-- * /data types/
-- * /record fields/
-- * /type synonyms/
-- * /type classes/
-- * /type class members/
-- * /type class instances/
-- * /type families/
-- * /type family instances/
-- * /data type families/
-- * /data type families instances/
-- * /data type family instances constructors/
--
getGhcTags :: Located HsModule
-> [GhcTag]
getGhcTags (L _ HsModule { hsmodName, hsmodDecls, hsmodExports }) =
maybeToList (mkModNameTag <$> hsmodName)
++ hsDeclsToGhcTags mies hsmodDecls
where
mies :: Maybe [IE GhcPs]
mies = map unLoc . unLoc <$> hsmodExports
mkModNameTag :: LocatedA ModuleName -> GhcTag
mkModNameTag (L l modName) =
GhcTag { gtSrcSpan = locA l
, gtTag = bytesFS $ moduleNameFS modName
, gtKind = GtkModule
, gtIsExported = True
, gtFFI = Nothing
}
hsDeclsToGhcTags :: Maybe [IE GhcPs]
-> [LHsDecl GhcPs]
-> [GhcTag]
hsDeclsToGhcTags mies = foldr go []
where
fixLoc :: SrcSpan -> GhcTag -> GhcTag
fixLoc loc gt@GhcTag { gtSrcSpan = UnhelpfulSpan {} } = gt { gtSrcSpan = loc }
fixLoc _ gt = gt
-- like 'mkGhcTag' but checks if the identifier is exported
mkGhcTag' :: SrcSpan
-- ^ declaration's location; it is useful when the term does not
-- contain useful inforamtion (e.g. code generated from template
-- haskell splices).
-> LocatedN RdrName
-- ^ @RdrName ~ IdP GhcPs@ it *must* be a name of a top level
-- identifier.
-> GhcTagKind
-- ^ tag's kind
-> GhcTag
mkGhcTag' l a k = fixLoc l $ mkGhcTag a k (isExported mies a)
mkGhcTagForMember :: SrcSpan
-- ^ declartion's 'SrcSpan'
-> LocatedN RdrName -- member name
-> LocatedN RdrName -- class name
-> GhcTagKind
-> GhcTag
mkGhcTagForMember decLoc memberName className kind =
fixLoc decLoc $ mkGhcTag memberName kind
(isMemberExported mies memberName className)
-- Main routine which traverse all top level declarations.
--
go :: LHsDecl GhcPs -> [GhcTag] -> [GhcTag]
go (L SrcSpanAnn { locA = decLoc } hsDecl) tags = case hsDecl of
-- type or class declaration
TyClD _ tyClDecl ->
case tyClDecl of
-- type family declarations
FamDecl { tcdFam } ->
case mkFamilyDeclTags decLoc tcdFam Nothing of
Just tag -> tag : tags
Nothing -> tags
-- type synonyms
SynDecl { tcdLName, tcdRhs = L _ hsType } ->
mkGhcTag' decLoc tcdLName (GtkTypeSynonym hsType) : tags
-- data declaration:
-- type,
-- constructors,
-- record fields
--
DataDecl { tcdLName, tcdDataDefn } ->
case tcdDataDefn of
HsDataDefn { dd_cons, dd_kindSig } ->
mkGhcTag' decLoc tcdLName (GtkTypeConstructor (unLoc <$> dd_kindSig))
: (mkConsTags decLoc tcdLName . unLoc) `concatMap` dd_cons
++ tags
-- Type class declaration:
-- type class name,
-- type class members,
-- default methods,
-- default data type instance
--
ClassDecl { tcdLName, tcdSigs, tcdMeths, tcdATs, tcdATDefs } ->
-- class name
mkGhcTag' decLoc tcdLName GtkTypeClass
-- class methods
: (mkClsMemberTags decLoc tcdLName . unLoc) `concatMap` tcdSigs
-- default methods
++ concatMap (\hsBind -> mkHsBindLRTags decLoc (unLoc hsBind)) tcdMeths
-- associated types
++ ((\a -> mkFamilyDeclTags decLoc a (Just tcdLName)) . unLoc) `mapMaybe` tcdATs
-- associated type defaults (data type families, type families
-- (open or closed)
++ foldr
(\(L _ decl@(TyFamInstDecl { tfid_eqn })) tags' ->
case tfid_eqn of
FamEqn { feqn_rhs = L _ hsType } ->
case hsTypeTagName hsType of
-- TODO: add a `default` field
Just a -> mkGhcTag' decLoc a (GtkTypeFamilyInstance decl) : tags'
Nothing -> tags'
)
[] tcdATDefs
++ tags
-- Instance declarations
-- class instances
-- type family instance
-- data type family instances
--
InstD _ instDecl ->
case instDecl of
-- class instance declaration
ClsInstD { cid_inst } ->
case cid_inst of
ClsInstDecl { cid_poly_ty, cid_tyfam_insts, cid_datafam_insts
, cid_binds, cid_sigs } ->
case cid_poly_ty of
-- TODO: @hsbib_body :: LHsType GhcPs@
L _ HsSig { sig_body } ->
case mkLHsTypeTag decLoc sig_body of
Nothing -> tags'
Just tag -> tag : tags'
where
tags' =
-- type family instances
mapMaybe (mkTyFamInstDeclTag decLoc . unLoc) cid_tyfam_insts
-- data family instances
++ concatMap (mkDataFamInstDeclTag decLoc . unLoc) cid_datafam_insts
-- class methods
++ concatMap (mkHsBindLRTags decLoc . unLoc) cid_binds
-- optional method signatures
++ concatMap (mkSigTags decLoc . unLoc) cid_sigs
++ tags
-- data family instance
DataFamInstD { dfid_inst } ->
mkDataFamInstDeclTag decLoc dfid_inst ++ tags
-- type family instance
TyFamInstD { tfid_inst } ->
case mkTyFamInstDeclTag decLoc tfid_inst of
Nothing -> tags
Just tag -> tag : tags
-- deriving declaration
DerivD {} -> tags
-- value declaration
ValD _ hsBind -> mkHsBindLRTags decLoc hsBind ++ tags
-- signature declaration
SigD _ sig -> mkSigTags decLoc sig ++ tags
-- standalone kind signatures
KindSigD _ stdKindSig ->
case stdKindSig of
StandaloneKindSig _ ksName sigType ->
mkGhcTag' decLoc ksName (GtkTypeKindSignature sigType) : tags
-- default declaration
DefD {} -> tags
-- foreign declaration
ForD _ foreignDecl ->
case foreignDecl of
ForeignImport { fd_name, fd_fi = CImport _ _ _mheader _ (L _ sourceText) } ->
case sourceText of
NoSourceText -> tag
-- TODO: add header information from '_mheader'
SourceText s -> tag { gtFFI = Just s }
: tags
where
tag = mkGhcTag' decLoc fd_name GtkForeignImport
ForeignExport { fd_name } ->
mkGhcTag' decLoc fd_name GtkForeignExport
: tags
WarningD {} -> tags
AnnD {} -> tags
-- TODO: Rules are named it would be nice to get them too
RuleD {} -> tags
SpliceD {} -> tags
DocD {} -> tags
RoleAnnotD {} -> tags
-- generate tags of all constructors of a type
--
mkConsTags :: SrcSpan
-> LocatedN RdrName
-- name of the type
-> ConDecl GhcPs
-- constructor declaration
-> [GhcTag]
mkConsTags decLoc tyName con@ConDeclGADT { con_names, con_g_args } =
(\n -> mkGhcTagForMember decLoc n tyName (GtkGADTConstructor con))
`map` con_names
++ mkHsConDeclGADTDetails decLoc tyName con_g_args
mkConsTags decLoc tyName con@ConDeclH98 { con_name, con_args } =
mkGhcTagForMember decLoc con_name tyName
(GtkDataConstructor con)
: mkHsConDeclH98Details decLoc tyName con_args
mkHsLocalBindsTags :: SrcSpan -> HsLocalBinds GhcPs -> [GhcTag]
mkHsLocalBindsTags decLoc (HsValBinds _ (ValBinds _ hsBindsLR sigs)) =
-- where clause bindings
concatMap (mkHsBindLRTags decLoc . unLoc) (bagToList hsBindsLR)
++ concatMap (mkSigTags decLoc . unLoc) sigs
mkHsLocalBindsTags _ _ = []
mkHsConDeclGADTDetails
:: SrcSpan
-> LocatedN RdrName
-> HsConDeclGADTDetails GhcPs
-> [GhcTag]
mkHsConDeclGADTDetails decLoc tyName (RecConGADT (L _ fields)) =
foldr f [] fields
where
f :: LConDeclField GhcPs -> [GhcTag] -> [GhcTag]
f (L _ ConDeclField { cd_fld_names }) ts = ts ++ map g cd_fld_names
g :: LFieldOcc GhcPs -> GhcTag
g (L _ FieldOcc { rdrNameFieldOcc }) =
mkGhcTagForMember decLoc rdrNameFieldOcc tyName GtkRecordField
mkHsConDeclGADTDetails _ _ _ = []
mkHsConDeclH98Details
:: SrcSpan
-> LocatedN RdrName
-> HsConDeclH98Details GhcPs
-> [GhcTag]
mkHsConDeclH98Details decLoc tyName (RecCon (L _ fields)) =
foldr f [] fields
where
f :: LConDeclField GhcPs -> [GhcTag] -> [GhcTag]
f (L _ ConDeclField { cd_fld_names }) ts = ts ++ map g cd_fld_names
g :: LFieldOcc GhcPs -> GhcTag
g (L _ FieldOcc { rdrNameFieldOcc }) =
mkGhcTagForMember decLoc rdrNameFieldOcc tyName GtkRecordField
mkHsConDeclH98Details _ _ _ = []
mkHsBindLRTags :: SrcSpan
-- ^ declaration's 'SrcSpan'
-> HsBindLR GhcPs GhcPs
-> [GhcTag]
mkHsBindLRTags decLoc hsBind = case hsBind of
FunBind { fun_id, fun_matches } ->
let binds = map (grhssLocalBinds . m_grhss . unLoc)
. unLoc
. mg_alts
$ fun_matches
in mkGhcTag' decLoc fun_id GtkFunction
: concatMap (mkHsLocalBindsTags decLoc) binds
-- TODO
-- This is useful fo generating tags for
-- ````
-- Just x = lhs
-- ```
PatBind {} -> []
-- According to the GHC documentation VarBinds are introduced by the
-- type checker, so ghc-tags will never encounter them.
VarBind {} -> []
-- abstraction binding is only used after translation
AbsBinds {} -> []
PatSynBind _ PSB { psb_id } -> [mkGhcTag' decLoc psb_id GtkPatternSynonym]
mkClsMemberTags :: SrcSpan -> LocatedN RdrName -> Sig GhcPs -> [GhcTag]
mkClsMemberTags decLoc clsName (TypeSig _ lhs hsSigWcType) =
(\n -> mkGhcTagForMember decLoc n clsName (GtkTypeSignature hsSigWcType)) `map` lhs
mkClsMemberTags decLoc clsName (PatSynSig _ lhs hsSigWcType) =
(\n -> mkGhcTagForMember decLoc n clsName $
GtkTypeSignature HsWC { hswc_ext = NoExtField
, hswc_body = hsSigWcType
}) `map` lhs
mkClsMemberTags decLoc clsName (ClassOpSig _ _ lhs hsSigWcType) =
(\n -> mkGhcTagForMember decLoc n clsName $
GtkTypeSignature HsWC { hswc_ext = NoExtField
, hswc_body = hsSigWcType
}) `map` lhs
mkClsMemberTags _ _ _ = []
mkSigTags :: SrcSpan -> Sig GhcPs -> [GhcTag]
mkSigTags decLoc (TypeSig _ lhs hsSigWcType) =
flip (mkGhcTag' decLoc) (GtkTypeSignature hsSigWcType) `map` lhs
mkSigTags decLoc (PatSynSig _ lhs hsSigWcType) =
flip (mkGhcTag' decLoc) (GtkTypeSignature HsWC { hswc_ext = NoExtField
, hswc_body = hsSigWcType
}) `map` lhs
mkSigTags decLoc (ClassOpSig _ _ lhs hsSigWcType) =
flip (mkGhcTag' decLoc) (GtkTypeSignature HsWC { hswc_ext = NoExtField
, hswc_body = hsSigWcType
}) `map` lhs
mkSigTags _ IdSig {} = []
-- TODO: generate theses with additional info (fixity)
mkSigTags _ FixSig {} = []
mkSigTags _ InlineSig {} = []
-- SPECIALISE pragmas
mkSigTags _ SpecSig {} = []
mkSigTags _ SpecInstSig {} = []
-- MINIMAL pragma
mkSigTags _ MinimalSig {} = []
-- SSC pragma
mkSigTags _ SCCFunSig {} = []
-- COMPLETE pragma
mkSigTags _ CompleteMatchSig {} = []
mkFamilyDeclTags :: SrcSpan
-> FamilyDecl GhcPs
-- ^ declaration's 'SrcSpan'
-> Maybe (LocatedN RdrName)
-- if this type family is associate, pass the name of the
-- associated class
-> Maybe GhcTag
mkFamilyDeclTags decLoc FamilyDecl { fdLName, fdInfo, fdTyVars, fdResultSig = L _ familyResultSig } assocClsName =
case assocClsName of
Nothing -> Just $ mkGhcTag' decLoc fdLName tk
Just clsName -> Just $ mkGhcTagForMember decLoc fdLName clsName tk
where
mb_fdvars = case fdTyVars of
HsQTvs { hsq_explicit } -> Just $ unLoc `map` hsq_explicit
mb_resultsig = famResultKindSignature familyResultSig
mb_typesig = (,) <$> mb_fdvars <*> mb_resultsig
tk = case fdInfo of
DataFamily -> GtkDataTypeFamily mb_typesig
OpenTypeFamily -> GtkTypeFamily mb_typesig
ClosedTypeFamily {} -> GtkTypeFamily mb_typesig
-- used to generate tag of an instance declaration
mkLHsTypeTag :: SrcSpan
-- declartaion's 'SrcSpan'
-> LHsType GhcPs
-> Maybe GhcTag
mkLHsTypeTag decLoc (L _ hsType) =
(\a -> fixLoc decLoc $ mkGhcTag a (GtkTypeClassInstance hsType) True)
<$> hsTypeTagName hsType
hsTypeTagName :: HsType GhcPs -> Maybe (LocatedN 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
-- data family instance declaration
--
mkDataFamInstDeclTag :: SrcSpan -> DataFamInstDecl GhcPs -> [GhcTag]
mkDataFamInstDeclTag decLoc DataFamInstDecl { dfid_eqn } =
case dfid_eqn of
FamEqn { feqn_tycon, feqn_rhs } ->
case feqn_rhs of
HsDataDefn { dd_cons, dd_kindSig } ->
mkGhcTag' decLoc feqn_tycon
(GtkDataTypeFamilyInstance
(unLoc <$> dd_kindSig))
: (mkConsTags decLoc feqn_tycon . unLoc)
`concatMap` dd_cons
-- type family instance declaration
--
mkTyFamInstDeclTag :: SrcSpan -> TyFamInstDecl GhcPs -> Maybe GhcTag
mkTyFamInstDeclTag decLoc decl@TyFamInstDecl { tfid_eqn } =
case tfid_eqn of
-- TODO: should we check @feqn_rhs :: LHsType GhcPs@ as well?
FamEqn { feqn_tycon } ->
Just $ mkGhcTag' decLoc feqn_tycon (GtkTypeFamilyInstance decl)
--
--
--
famResultKindSignature :: FamilyResultSig GhcPs
-> Maybe (Either (HsKind GhcPs) (HsTyVarBndr () GhcPs))
famResultKindSignature (NoSig _) = Nothing
famResultKindSignature (KindSig _ ki) = Just (Left (unLoc ki))
famResultKindSignature (TyVarSig _ bndr) = Just (Right (unLoc bndr))