aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/HaskellCodeExplorer/GhcUtils.hs169
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-25 19:24:05 +0000