{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE StrictData #-} module HaskellCodeExplorer.AST.RenamedSource ( NameOccurrence(..) , namesFromRenamedSource ) where -- import BasicTypes (TupleSort(..)) import GHC.Types.Basic (TupleSort(..)) -- import BooleanFormula (BooleanFormula(..)) import GHC.Data.BooleanFormula (BooleanFormula(..)) import Data.Generics (Data, everything, extQ, mkQ) import Data.Maybe (Maybe(..), mapMaybe) import qualified Data.Text as T (Text) import GHC ( AmbiguousFieldOcc(..) , ConDecl(..) , ConDeclField(..) #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) #else , DataFamInstDecl(..) #endif , FamilyDecl(..) , FieldOcc(..) , FixitySig(..) , ForeignDecl(..) , GenLocated(..) , getLocA , HsBindLR(..) , HsExpr(..) #if MIN_VERSION_GLASGOW_HASKELL(8,4,1,0) , HsPatSynDetails #else , HsPatSynDetails(..) #endif , HsRecField'(..) , HsTupleSort(..) , HsTyLit(..) , HsTyPats , HsTyVarBndr(..) , HsType(..) , IE(..) , LHsBindLR , LHsExpr #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) #else , LHsQTyVars(..) #endif , LHsType , LPat , LSig , LTyClDecl , Located , HsBracket(..) #if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) , HsMatchContext(..) , Match(..) #else , m_fixity , MatchFixity(..) #endif , MatchGroup(..) , Name , Pat(..) , PatSynBind(..) , reLocN , Sig(..) , TyClDecl(..) #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) , FamEqn(..) , HsDataDefn(..) #else , TyFamEqn(..) #endif , Type , RoleAnnotDecl(..) , InjectivityAnn (..) , unLoc ) #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) -- import HsExtension (GhcRn) import GHC.Hs.Extension (GhcRn) #endif import HaskellCodeExplorer.GhcUtils (hsPatSynDetails, ieLocNames, ghcDL) import Prelude hiding (span) -- import TysWiredIn import GHC.Builtin.Types ( nilDataConName , tupleTyConName -- , typeNatKind , naturalTy , typeSymbolKind ) -- import SrcLoc import GHC.Types.SrcLoc ( mkRealSrcSpan , mkRealSrcLoc , realSrcSpanEnd , realSrcSpanStart , srcLocCol , srcLocFile , srcLocLine , SrcSpan(..) ) data NameOccurrence = NameOccurrence { locatedName :: Located (Maybe Name) , description :: T.Text , isBinder :: Bool } | TyLitOccurrence { locatedName :: Located (Maybe Name) , description :: T.Text , kind :: Type } -- | Here we are only interested in a small subset of all AST nodes, so it is -- convenient to use generic functions namesFromRenamedSource :: (Data a) => a -> [NameOccurrence] namesFromRenamedSource = everything (++) ([] `mkQ` hsExprNames `extQ` matchGroupNames `extQ` bindNames `extQ` patNames `extQ` sigNames `extQ` hsTypeNames `extQ` tyClDeclNames `extQ` familyDeclNames `extQ` #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) familyEqNames `extQ` dataEqNames `extQ` #else tyFamilyEqNames `extQ` tyFamilyDefEqNames `extQ` dataFamInstDeclNames `extQ` #endif conDeclNames `extQ` importNames `extQ` hsTyVarBndrNames `extQ` hsPatSynDetailsNames `extQ` conDeclFieldNames `extQ` hsRecFieldExprNames `extQ` hsRecAmbFieldExprNames `extQ` hsRecFieldPatNames `extQ` foreignDeclNames `extQ` roleAnnotationNames `extQ` injectivityAnnotationNames) fieldOccName :: Bool -> FieldOcc GhcRn -> NameOccurrence fieldOccName _ (XFieldOcc _) = undefined fieldOccName isBinder (FieldOcc name located) = NameOccurrence { locatedName = L (getLocA located) (Just name) , description = "FieldOcc" , isBinder = isBinder } #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) conDeclFieldNames :: ConDeclField GhcRn -> [NameOccurrence] #else conDeclFieldNames :: ConDeclField Name -> [NameOccurrence] #endif conDeclFieldNames ConDeclField {..} = map (fieldOccName True . unLoc) cd_fld_names #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) conDeclFieldNames _ = [] #endif #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) hsRecFieldExprNames :: HsRecField' (FieldOcc GhcRn) (LHsExpr GhcRn) -> [NameOccurrence] #else hsRecFieldExprNames :: HsRecField' (FieldOcc Name) (LHsExpr Name) -> [NameOccurrence] #endif hsRecFieldExprNames HsRecField {..} = [fieldOccName False $ unLoc hsRecFieldLbl] #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) hsRecAmbFieldExprNames :: HsRecField' (AmbiguousFieldOcc GhcRn) (LHsExpr GhcRn) -> [NameOccurrence] #else hsRecAmbFieldExprNames :: HsRecField' (AmbiguousFieldOcc Name) (LHsExpr Name) -> [NameOccurrence] #endif hsRecAmbFieldExprNames HsRecField {..} = let (L span recField) = hsRecFieldLbl mbName = case recField of Ambiguous _ _ -> Nothing #if MIN_VERSION_GLASGOW_HASKELL(8,6,3,0) Unambiguous name _ -> Just name _ -> Nothing #else Unambiguous _ name -> Just name #endif in [ NameOccurrence { locatedName = L span mbName , description = "AmbiguousFieldOcc" , isBinder = False } ] #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) hsRecFieldPatNames :: HsRecField' (FieldOcc GhcRn) (LPat GhcRn) -> [NameOccurrence] #else hsRecFieldPatNames :: HsRecField' (FieldOcc Name) (LPat Name) -> [NameOccurrence] #endif hsRecFieldPatNames HsRecField {..} = [fieldOccName False $ unLoc hsRecFieldLbl] hsExprNames :: LHsExpr GhcRn -> [NameOccurrence] hsExprNames (L _span (HsVar _ name)) = [ NameOccurrence { locatedName = Just <$> reLocN name , description = "HsVar" , isBinder = False } ] hsExprNames lhe@(L _ (ExplicitList _ exprs)) | null exprs = [ NameOccurrence { locatedName = L (getLocA lhe) $ Just nilDataConName , description = "ExplicitList" , isBinder = False } ] | otherwise = [] hsExprNames (L _span (RecordCon _ name _)) = [ NameOccurrence { locatedName = Just <$> reLocN name , description = "RecordCon" , isBinder = False } ] hsExprNames (L _span (HsRecFld _ (Unambiguous name located))) = [ NameOccurrence { locatedName = L (getLocA located) (Just name) , description = "HsRecFld" , isBinder = False } ] hsExprNames (L _span (HsRecFld _ (Ambiguous _name located))) = [ NameOccurrence { locatedName = L (getLocA located) Nothing , description = "HsRecFld" , isBinder = False } ] hsExprNames lhr@(L span (HsRnBracketOut _ (VarBr _ quote name) _)) = case getLocA lhr of RealSrcSpan realSpan _ -> let start = realSrcSpanStart realSpan end = realSrcSpanEnd realSpan offset = if quote then 1 -- 'x else 2 -- ''T start' = mkRealSrcLoc (srcLocFile start) (srcLocLine start) (srcLocCol start + offset) span' = RealSrcSpan (mkRealSrcSpan start' end) Nothing in [ NameOccurrence { locatedName = L span' (Just $ unLoc name) , description = "VarBr" , isBinder = False } ] _ -> [] hsExprNames _ = [] matchGroupNames :: MatchGroup GhcRn (LHsExpr GhcRn) -> [NameOccurrence] matchGroupNames = mapMaybe (fmap toNameOcc . matchContextName . m_ctxt . unLoc) . unLoc . mg_alts where --matchContextName :: HsMatchContext Name -> Maybe (Located Name) matchContextName (FunRhs name _ _bool) = Just name matchContextName _ = Nothing --toNameOcc :: LIdP GhcRn -> NameOccurrence toNameOcc n = NameOccurrence {locatedName = Just <$> reLocN n, description = "Match", isBinder = True} bindNames :: LHsBindLR GhcRn GhcRn -> [NameOccurrence] bindNames (L _span (PatSynBind _ PSB {..})) = [ NameOccurrence { locatedName = Just <$> reLocN psb_id , description = "PatSynBind" , isBinder = True } ] bindNames _ = [] hsPatSynDetailsNames :: HsPatSynDetails GhcRn -> [NameOccurrence] hsPatSynDetailsNames = map (\name -> NameOccurrence { locatedName = Just <$> name , description = "HsPatSynDetails" , isBinder = True }) . hsPatSynDetails #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) importNames :: IE GhcRn -> [NameOccurrence] #else importNames :: IE Name -> [NameOccurrence] #endif importNames = map (\name -> NameOccurrence { locatedName = Just <$> name , description = "IE" , isBinder = False }) . ieLocNames patNames :: LPat GhcRn -> [NameOccurrence] patNames (L _span (VarPat _ name)) = [ NameOccurrence { locatedName = Just <$> reLocN name , description = "VarPat" , isBinder = True } ] patNames (L _span (ConPat _ name _)) = [ NameOccurrence { locatedName = Just <$> reLocN name , description = "ConPatIn" , isBinder = False } ] patNames (L _span (AsPat _ name _)) = [ NameOccurrence { locatedName = Just <$> reLocN name , description = "AsPat" , isBinder = True } ] patNames (L _span (NPlusKPat _ name _ _ _ _)) = [ NameOccurrence { locatedName = Just <$> reLocN name , description = "NPlusKPat" , isBinder = True } ] patNames _ = [] sigNames :: LSig GhcRn -> [NameOccurrence] sigNames (L _span (TypeSig _ names _)) = map (\n -> NameOccurrence { locatedName = Just <$> reLocN n , description = "TypeSig" , isBinder = False }) names sigNames (L _span (PatSynSig _ names _)) = map (\name -> NameOccurrence (Just <$> reLocN name) "PatSynSig" False) names sigNames (L _span (ClassOpSig _ _ names _)) = map (\n -> NameOccurrence { locatedName = Just <$> reLocN n , description = "ClassOpSig" , isBinder = True }) names sigNames (L _span (FixSig _ (FixitySig _ names _))) = map (\n -> NameOccurrence { locatedName = Just <$> reLocN n , description = "FixitySig" , isBinder = False }) names sigNames (L _span (InlineSig _ name _)) = [ NameOccurrence { locatedName = Just <$> reLocN name , description = "InlineSig" , isBinder = False } ] sigNames (L _span (SpecSig _ name _ _)) = [ NameOccurrence { locatedName = Just <$> reLocN name , description = "SpecSig" , isBinder = False } ] sigNames (L _span (MinimalSig _ _ (L _ boolFormula))) = map (\n -> NameOccurrence { locatedName = Just <$> reLocN n , description = "MinimalSig" , isBinder = False }) . boolFormulaNames $ boolFormula where boolFormulaNames :: BooleanFormula name -> [name] boolFormulaNames (Var a) = [a] boolFormulaNames (And fs) = concatMap (boolFormulaNames . unLoc) fs boolFormulaNames (Or fs) = concatMap (boolFormulaNames . unLoc) fs boolFormulaNames (Parens (L _ f)) = boolFormulaNames f sigNames (L _ _) = [] hsTypeNames :: LHsType GhcRn -> [NameOccurrence] hsTypeNames (L _span (HsTyVar _ _promoted name)) = [ NameOccurrence { locatedName = Just <$> reLocN name , description = "HsTyVar" , isBinder = False } ] hsTypeNames lht@(L span (HsTyLit _ lit)) = let kind = case lit of HsNumTy _ _ -> naturalTy HsStrTy _ _ -> typeSymbolKind in [ TyLitOccurrence { locatedName = L (getLocA lht) Nothing , description = "HsTyLit" , kind = kind } ] hsTypeNames (L _span (HsOpTy _ _ name _)) = [ NameOccurrence { locatedName = Just <$> reLocN name , description = "HsOpTy" , isBinder = False } ] hsTypeNames (L span (HsTupleTy _ tupleSort types)) | null types = let sort = case tupleSort of HsUnboxedTuple -> UnboxedTuple HsBoxedOrConstraintTuple -> BoxedTuple in [ NameOccurrence { locatedName = L span (Just $ tupleTyConName sort 0) , description = "HsTupleTy" , isBinder = False } ] | otherwise = [] --https://ghc.haskell.org/trac/ghc/ticket/13737 --hsTypeNames (L span (HsExplicitListTy _kind types)) = ... --hsTypeNames (L span (HsExplicitTupleTy _kind types)) = ... hsTypeNames _ = [] hsTyVarBndrNames :: HsTyVarBndr flag GhcRn -> [NameOccurrence] hsTyVarBndrNames (UserTyVar _ _ n) = [ NameOccurrence { locatedName = Just <$> n , description = "UserTyVar" , isBinder = True } ] hsTyVarBndrNames (KindedTyVar _ _ n _) = [ NameOccurrence { locatedName = Just <$> n , description = "KindedTyVar" , isBinder = True } ] hsTyVarBndrNames _ = [] #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) tyClDeclNames :: LTyClDecl GhcRn -> [NameOccurrence] #else tyClDeclNames :: LTyClDecl Name -> [NameOccurrence] #endif tyClDeclNames (L _span DataDecl {..}) = [ NameOccurrence { locatedName = Just <$> tcdLName , description = "DataDecl" , isBinder = True } ] tyClDeclNames (L _span SynDecl {..}) = [ NameOccurrence { locatedName = Just <$> tcdLName , description = "SynDecl" , isBinder = True } ] tyClDeclNames (L _span ClassDecl {..}) = NameOccurrence { locatedName = Just <$> tcdLName , description = "ClassDecl" , isBinder = True } : concatMap ((\(names1, names2) -> map toNameOcc names1 ++ map toNameOcc names2) . unLoc) tcdFDs where toNameOcc :: Located Name -> NameOccurrence toNameOcc n = NameOccurrence { locatedName = Just <$> n , description = "FunDep" , isBinder = False } tyClDeclNames _ = [] #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) familyDeclNames :: FamilyDecl GhcRn -> [NameOccurrence] #else familyDeclNames :: FamilyDecl Name -> [NameOccurrence] #endif familyDeclNames FamilyDecl {..} = [ NameOccurrence { locatedName = Just <$> fdLName , description = "FamilyDecl" , isBinder = True } ] #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) familyDeclNames _ = [] #endif #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) familyEqNames :: FamEqn GhcRn (LHsType GhcRn) -> [NameOccurrence] familyEqNames FamEqn {feqn_tycon = tyCon} = [ NameOccurrence { locatedName = Just <$> tyCon , description = "FamEqn" , isBinder = False } ] #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) familyEqNames _ = [] #endif dataEqNames :: FamEqn GhcRn (HsDataDefn GhcRn) -> [NameOccurrence] dataEqNames FamEqn {feqn_tycon = tyCon} = [ NameOccurrence { locatedName = Just <$> tyCon , description = "FamEqn" , isBinder = False } ] #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) dataEqNames _ = [] #endif #else tyFamilyEqNames :: TyFamEqn Name (HsTyPats Name) -> [NameOccurrence] tyFamilyEqNames TyFamEqn {tfe_tycon = tyCon} = [ NameOccurrence { locatedName = Just <$> tyCon , description = "TyFamEqn" , isBinder = False } ] tyFamilyDefEqNames :: TyFamEqn Name (LHsQTyVars Name) -> [NameOccurrence] tyFamilyDefEqNames TyFamEqn {tfe_tycon = tyCon} = [ NameOccurrence { locatedName = Just <$> tyCon , description = "TyFamEqn" , isBinder = False } ] dataFamInstDeclNames :: DataFamInstDecl Name -> [NameOccurrence] dataFamInstDeclNames DataFamInstDecl {dfid_tycon = tyCon} = [ NameOccurrence { locatedName = Just <$> tyCon , description = "DataFamInstDecl" , isBinder = False } ] #endif #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) conDeclNames :: ConDecl GhcRn -> [NameOccurrence] #else conDeclNames :: ConDecl Name -> [NameOccurrence] #endif conDeclNames con = case con of ConDeclGADT {con_names = names} -> map (\n -> NameOccurrence { locatedName = Just <$> n , description = "ConDeclGADT" , isBinder = True }) names ConDeclH98 {con_name = name} -> [ NameOccurrence { locatedName = Just <$> name , description = "ConDeclH98" , isBinder = True } ] #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) _ -> [] #endif #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) foreignDeclNames :: ForeignDecl GhcRn -> [NameOccurrence] #else foreignDeclNames :: ForeignDecl Name -> [NameOccurrence] #endif foreignDeclNames decl = [ NameOccurrence { locatedName = Just <$> fd_name decl , description = "ForeignDecl" , isBinder = True } ] #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) roleAnnotationNames :: RoleAnnotDecl GhcRn -> [NameOccurrence] #else roleAnnotationNames :: RoleAnnotDecl Name -> [NameOccurrence] #endif #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) roleAnnotationNames (RoleAnnotDecl _ n _) = #else roleAnnotationNames (RoleAnnotDecl n _) = #endif [ NameOccurrence { locatedName = Just <$> n , description = "RoleAnnotDecl" , isBinder = False } ] #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) roleAnnotationNames _ = [] #endif #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) injectivityAnnotationNames :: InjectivityAnn GhcRn -> [NameOccurrence] #else injectivityAnnotationNames :: InjectivityAnn Name -> [NameOccurrence] #endif injectivityAnnotationNames (InjectivityAnn lhsName rhsNames) = injAnnNameOcc lhsName : map injAnnNameOcc rhsNames where injAnnNameOcc :: GenLocated SrcSpan Name -> NameOccurrence injAnnNameOcc n = NameOccurrence { locatedName = Just <$> n , description = "InjectivityAnn" , isBinder = False }