diff options
| -rw-r--r-- | src/HaskellCodeExplorer/GhcUtils.hs | 169 |
1 files changed, 63 insertions, 106 deletions
diff --git a/src/HaskellCodeExplorer/GhcUtils.hs b/src/HaskellCodeExplorer/GhcUtils.hs index 4256641..16e9e00 100644 --- a/src/HaskellCodeExplorer/GhcUtils.hs +++ b/src/HaskellCodeExplorer/GhcUtils.hs @@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE OverloadedStrings #-} @@ -61,6 +64,7 @@ module HaskellCodeExplorer.GhcUtils import GHC.Data.Bag (bagToList) -- import ConLike (ConLike(..)) import GHC.Core.ConLike (ConLike(..)) +import GHC.HsToCore.Docs (collectDocs) import qualified Data.ByteString as BS import Data.Hashable (Hashable,hash) import qualified Data.ByteString.Internal as BSI @@ -87,6 +91,9 @@ import GHC.Data.FastString (mkFastString, unpackFS) import GHC ( DynFlags , unXRec + , UnXRec + , XRec + , LConDeclField , recordPatSynField #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) , HsDocString @@ -98,6 +105,8 @@ import GHC , Name , SrcSpan(..) , RealSrcSpan(..) + , SrcSpanAnnA + , Anno , ClsInstDecl(..) , TyClDecl(..) , HsDataDefn(..) @@ -134,6 +143,7 @@ import GHC , NHsValBindsLR(..) -- , getConArgs , unpackHDS + , NoExtField(..) -- , NoExt(..) , extFieldOcc #else @@ -230,6 +240,8 @@ import Distribution.Package (packageVersion) import GHC.Unit.State ( LookupResult(..) , lookupModuleWithSuggestions + , lookupUnit + , lookupUnitId -- , lookupPackage -- , packageNameString ) @@ -599,22 +611,22 @@ lookupIdInTypeEnv typeEnv name = do _ -> Nothing lookupNameModuleAndPackage :: - DynFlags + UnitState -> HCE.PackageId -> Name -> Either T.Text (HCE.HaskellModuleName, HCE.PackageId) -lookupNameModuleAndPackage flags currentPackageId name = +lookupNameModuleAndPackage state currentPackageId name = case nameModule_maybe name of Just Module {..} -> - case lookupPackage flags moduleUnitId of - Just packageConfig -> + case lookupUnit state moduleUnit of + Just unitInfo -> let packageId = - if (T.pack . packageNameString $ packageConfig) == + if (T.pack . unitPackageNameString $ unitInfo) == HCE.name (currentPackageId :: HCE.PackageId) then currentPackageId else HCE.PackageId - (T.pack $ packageNameString packageConfig) - (packageVersion packageConfig) + (T.pack $ unitPackageNameString unitInfo) + (packageVersion unitInfo) in Right ( HCE.HaskellModuleName . T.pack . moduleNameString $ moduleName , packageId) @@ -634,12 +646,13 @@ isHsBoot = T.isSuffixOf "-boot" . HCE.getHaskellModulePath moduleLocationInfo :: DynFlags + -> UnitState -> HM.HashMap HCE.HaskellModuleName (HM.HashMap HCE.ComponentId HCE.HaskellModulePath) -> HCE.PackageId -> HCE.ComponentId -> ModuleName -> HCE.LocationInfo -moduleLocationInfo flags moduleNameMap currentPackageId compId moduleName = +moduleLocationInfo flags unitState moduleNameMap currentPackageId compId moduleName = let moduleNameText = T.pack . moduleNameString $ moduleName currentPackageLocation = HCE.ApproximateLocation @@ -663,12 +676,12 @@ moduleLocationInfo flags moduleNameMap currentPackageId compId moduleName = _ -> case lookupModuleWithSuggestions flags moduleName Nothing of LookupFound Module {moduleUnit = unitId} _ -> - case lookupPackage flags unitId of - Just packInfo -> + case lookupUnitId unitState unitId of + Just unitInfo -> let packageId = HCE.PackageId - (T.pack $ packageNameString packInfo) - (packageVersion packInfo) + (T.pack $ unitPackageNameString unitInfo) + (packageVersion unitInfo) in HCE.ApproximateLocation packageId (HCE.HaskellModuleName . T.pack . moduleNameString $ @@ -1077,28 +1090,10 @@ tyVarsOfType = varSetElems . everything unionVarSet (emptyVarSet `mkQ` tyVar) -- Some functions are copied from haddock-api package -------------------------------------------------------------------------------- -collectDocs :: [LHsDecl a] -> [(LHsDecl a, [HsDocString])] -collectDocs = go Nothing [] - where - go Nothing _ [] = [] - go (Just prev) docs [] = finished prev docs [] -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) - go prev docs (L _ (DocD _ (DocCommentNext str)):ds) -#else - go prev docs (L _ (DocD (DocCommentNext str)):ds) -#endif - - | Nothing <- prev = go Nothing (str : docs) ds - | Just decl <- prev = finished decl docs (go Nothing [str] ds) -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) - go prev docs (L _ (DocD _ (DocCommentPrev str)):ds) = go prev (str : docs) ds -#else - go prev docs (L _ (DocD (DocCommentPrev str)):ds) = go prev (str : docs) ds -#endif - go Nothing docs (d:ds) = go (Just d) docs ds - go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds) - finished decl docs rest = (decl, reverse docs) : rest +-- collectDocs is available in GHC.HsToCore.Docs +-- collectDocs :: [LHsDecl p] -> [(LHsDecl p, [HsDocString])] +-- also available in GHC.HsToCore.Docs #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn] #else @@ -1106,7 +1101,7 @@ ungroup :: HsGroup Name -> [LHsDecl Name] #endif ungroup group_ = #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) - mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD NoExt) group_ ++ + mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD NoExtField) group_ ++ #elif MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) mkDecls (tyClGroupTyClDecls . hs_tyclds) TyClD group_ ++ #else @@ -1114,10 +1109,10 @@ ungroup group_ = #endif #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) - mkDecls hs_derivds (DerivD NoExt) group_ ++ - mkDecls hs_defds (DefD NoExt) group_ ++ - mkDecls hs_fords (ForD NoExt) group_ ++ - mkDecls hs_docs (DocD NoExt) group_ ++ + mkDecls hs_derivds (DerivD NoExtField) group_ ++ + mkDecls hs_defds (DefD NoExtField) group_ ++ + mkDecls hs_fords (ForD NoExtField) group_ ++ + mkDecls hs_docs (DocD NoExtField) group_ ++ #else mkDecls hs_derivds DerivD group_ ++ mkDecls hs_defds DefD group_ ++ @@ -1126,7 +1121,7 @@ ungroup group_ = #endif #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) - mkDecls hsGroupInstDecls (InstD NoExt) group_ ++ + mkDecls hsGroupInstDecls (InstD NoExtField) group_ ++ #elif MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) mkDecls hsGroupInstDecls InstD group_ ++ #else @@ -1134,8 +1129,8 @@ ungroup group_ = #endif #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) - mkDecls (typesigs . hs_valds) (SigD NoExt) group_ ++ - mkDecls (valbinds . hs_valds) (ValD NoExt) group_ + mkDecls (typesigs . hs_valds) (SigD NoExtField) group_ ++ + mkDecls (valbinds . hs_valds) (ValD NoExtField) group_ #else mkDecls (typesigs . hs_valds) SigD group_ ++ mkDecls (valbinds . hs_valds) ValD group_ @@ -1156,6 +1151,7 @@ ungroup group_ = #endif valbinds _ = [] +-- also available in GHC.HsToCore.Docs mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c] mkDecls field con struct = [L loc (con decl) | L loc decl <- field struct] @@ -1171,10 +1167,10 @@ classDeclDocs class_ = collectDocs . sortByLoc $ decls where decls = docs ++ defs ++ sigs ++ ats #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) - docs = mkDecls tcdDocs (DocD NoExt) class_ - defs = mkDecls (bagToList . tcdMeths) (ValD NoExt) class_ - sigs = mkDecls tcdSigs (SigD NoExt) class_ - ats = mkDecls tcdATs ((TyClD NoExt) . (FamDecl NoExt)) class_ + docs = mkDecls tcdDocs (DocD NoExtField) class_ + defs = mkDecls (bagToList . tcdMeths) (ValD NoExtField) class_ + sigs = mkDecls tcdSigs (SigD NoExtField) class_ + ats = mkDecls tcdATs ((TyClD NoExtField) . (FamDecl NoExtField)) class_ #else docs = mkDecls tcdDocs DocD class_ defs = mkDecls (bagToList . tcdMeths) ValD class_ @@ -1193,37 +1189,24 @@ conDeclDocs conDecl = getConNames $ conDecl -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) +extractRecCon :: ConDecl p -> Maybe (XRec p [LConDeclField p]) +extractRecCon = undefined + selectorDocs :: ConDecl GhcRn -> [(Name, [HsDocString], SrcSpan)] -#else -selectorDocs :: ConDecl Name -> [(Name, [HsDocString], SrcSpan)] -#endif selectorDocs con = -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) - case getConArgs con of -#else - case getConDetails con of -#endif - RecCon (L _ flds) -> + case extractRecCon con of + Just (L _ flds) -> concatMap -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) (\(L _ (ConDeclField _ fieldOccs _ mbDoc)) -> -#else - (\(L _ (ConDeclField fieldOccs _ mbDoc)) -> -#endif map (\(L span f) -> -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) (extFieldOcc f, maybe [] ((: []) . unLoc) mbDoc, span)) -#else - (selectorFieldOcc f, maybe [] ((: []) . unLoc) mbDoc, span)) -#endif fieldOccs) flds _ -> [] #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) -subordinateNamesWithDocs :: [GenLocated SrcSpan (HsDecl GhcRn)] -> [(Name, [HsDocString], SrcSpan)] +subordinateNamesWithDocs :: [LHsDecl GhcRn] -> [(Name, [HsDocString], SrcSpan)] #else subordinateNamesWithDocs :: [GenLocated SrcSpan (HsDecl Name)] -> [(Name, [HsDocString], SrcSpan)] #endif @@ -1253,17 +1236,21 @@ subordinateNamesWithDocs = #endif #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) - concatMap (conDeclDocs . unLoc) . dd_cons . feqn_rhs . hsib_body $ dfid_eqn + concatMap (conDeclDocs . unLoc) . dd_cons . feqn_rhs $ dfid_eqn #else concatMap (conDeclDocs . unLoc) . dd_cons $ dfid_defn #endif _ -> []) -isUserLSig :: LSig name -> Bool -isUserLSig (L _ TypeSig {}) = True -isUserLSig (L _ ClassOpSig {}) = True -isUserLSig _ = False +isUserLSig :: forall p. UnXRec p => LSig p -> Bool +isUserLSig sig = case unXRec @p sig of + TypeSig {} -> True + ClassOpSig {} -> True + otherwise -> False +-- isUserLSig (L _ TypeSig {}) = True +-- isUserLSig (L _ ClassOpSig {}) = True +-- isUserLSig _ = False #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) getMainDeclBinder :: HsDecl GhcRn -> [IdP GhcRn] @@ -1301,43 +1288,13 @@ getMainDeclBinder (ForD ForeignExport {}) = [] #endif getMainDeclBinder _ = [] -#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0) -sigNameNoLoc :: Sig pass -> [IdP pass] -#else -sigNameNoLoc :: Sig name -> [name] -#endif -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -sigNameNoLoc (TypeSig _ ns _) = map unLoc ns -#else -sigNameNoLoc (TypeSig ns _) = map unLoc ns -#endif -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -sigNameNoLoc (ClassOpSig _ _ ns _) = map unLoc ns -#else -sigNameNoLoc (ClassOpSig _ ns _) = map unLoc ns -#endif -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -sigNameNoLoc (PatSynSig _ ns _) = map unLoc ns -#elif MIN_VERSION_GLASGOW_HASKELL(8,2,2,0) -sigNameNoLoc (PatSynSig ns _) = map unLoc ns -#else -sigNameNoLoc (PatSynSig n _) = [unLoc n] -#endif -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -sigNameNoLoc (SpecSig _ n _ _) = [unLoc n] -#else -sigNameNoLoc (SpecSig n _ _) = [unLoc n] -#endif -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -sigNameNoLoc (InlineSig _ n _) = [unLoc n] -#else -sigNameNoLoc (InlineSig n _) = [unLoc n] -#endif -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) -sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns -#else -sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns -#endif +sigNameNoLoc :: forall p. UnXRec p => Sig p -> [IdP p] +sigNameNoLoc (TypeSig _ ns _) = map (unXRec @p) ns +sigNameNoLoc (ClassOpSig _ _ ns _) = map (unXRec @p) ns +sigNameNoLoc (PatSynSig _ ns _) = map (unXRec @p) ns +sigNameNoLoc (SpecSig _ n _ _) = [unXRec @p n] +sigNameNoLoc (InlineSig _ n _) = [unXRec @p n] +sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map (unXRec @p) ns sigNameNoLoc _ = [] clsInstDeclSrcSpan :: ClsInstDecl a -> SrcSpan |