aboutsummaryrefslogtreecommitdiff
path: root/src/HaskellCodeExplorer
diff options
context:
space:
mode:
Diffstat (limited to 'src/HaskellCodeExplorer')
-rw-r--r--src/HaskellCodeExplorer/GhcUtils.hs131
1 files changed, 41 insertions, 90 deletions
diff --git a/src/HaskellCodeExplorer/GhcUtils.hs b/src/HaskellCodeExplorer/GhcUtils.hs
index fdf46d7..461344f 100644
--- a/src/HaskellCodeExplorer/GhcUtils.hs
+++ b/src/HaskellCodeExplorer/GhcUtils.hs
@@ -104,8 +104,6 @@ import GHC
, unXRec
, UnXRec
, GhcPass
- , XRec
- , LConDeclField
, recordPatSynField
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
, HsDocString
@@ -140,9 +138,7 @@ import GHC
, HsDecl(..)
, ConDecl(..)
, HsConDetails(..)
- , ConDeclField(..)
, DataFamInstDecl(..)
- , LSig
, Sig(..)
, ForeignDecl(..)
, FixitySig(..)
@@ -274,7 +270,6 @@ import GHC.Types.SrcLoc
( GenLocated(..)
, mkRealSrcLoc
, unLoc
- , UnhelpfulSpanReason(..)
)
-- import StringBuffer (StringBuffer(..), stringToStringBuffer)
import GHC.Data.StringBuffer (StringBuffer(..), stringToStringBuffer)
@@ -355,23 +350,14 @@ instanceToText :: DynFlags -> ClsInst -> T.Text
instanceToText flags ClsInst {..} =
T.append "instance " $ T.pack . showSDoc flags $ pprSigmaType (idType is_dfun)
-#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
instanceDeclToText :: DynFlags -> InstDecl GhcRn -> T.Text
-#else
-instanceDeclToText :: DynFlags -> InstDecl Name -> T.Text
-#endif
instanceDeclToText flags decl =
case decl of
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
- XInstDecl _ -> ""
- ClsInstD _ (XClsInstDecl _) -> ""
+-- Pattern match has inaccessible right hand side
+ -- XInstDecl _ -> ""
+ -- ClsInstD _ (XClsInstDecl _) -> ""
ClsInstD _ ClsInstDecl {..} ->
-#else
- ClsInstD ClsInstDecl {..} ->
-#endif
T.append "instance " (toText flags cid_poly_ty)
-
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
DataFamInstD _ di ->
let args =
T.intercalate " " . map (toText flags) . feqn_pats . dfid_eqn $ di
@@ -384,33 +370,6 @@ instanceDeclToText flags decl =
ti
in T.concat
["type instance ", toText flags $ tyFamInstDeclName ti, " ", args]
-#elif MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
- DataFamInstD di ->
- let args =
- T.intercalate " " . map (toText flags) . feqn_pats . hsib_body . dfid_eqn $ di
- in T.concat
- ["data instance ", toText flags (unLoc $ feqn_tycon . hsib_body . dfid_eqn $ di), " ", args]
- TyFamInstD ti ->
- let args =
- T.intercalate " " .
- map (toText flags) . feqn_pats . hsib_body . tfid_eqn $
- ti
- in T.concat
- ["type instance ", toText flags $ tyFamInstDeclName ti, " ", args]
-#else
- DataFamInstD di ->
- let args =
- T.intercalate " " . map (toText flags) . hsib_body $ dfid_pats di
- in T.concat
- ["data instance ", toText flags (unLoc $ dfid_tycon di), " ", args]
- TyFamInstD ti ->
- let args =
- T.intercalate " " .
- map (toText flags) . hsib_body . tfe_pats . unLoc . tfid_eqn $
- ti
- in T.concat
- ["type instance ", toText flags $ tyFamInstDeclName ti, " ", args]
-#endif
nameToText :: Name -> T.Text
nameToText = T.pack . unpackFS . occNameFS . nameOccName
@@ -633,14 +592,13 @@ isHsBoot :: HCE.HaskellModulePath -> Bool
isHsBoot = T.isSuffixOf "-boot" . HCE.getHaskellModulePath
moduleLocationInfo ::
- DynFlags
- -> UnitState
+ UnitState
-> HM.HashMap HCE.HaskellModuleName (HM.HashMap HCE.ComponentId HCE.HaskellModulePath)
-> HCE.PackageId
-> HCE.ComponentId
-> ModuleName
-> HCE.LocationInfo
-moduleLocationInfo flags unitState moduleNameMap currentPackageId compId moduleName =
+moduleLocationInfo unitState moduleNameMap currentPackageId compId moduleName =
let moduleNameText = T.pack . moduleNameString $ moduleName
currentPackageLocation =
HCE.ApproximateLocation
@@ -949,40 +907,30 @@ applyWrapper wp ty
| Just ty' <- coreView ty = applyWrapper wp ty'
applyWrapper WpHole t = t
applyWrapper (WpCompose w1 w2) t = applyWrapper w1 . applyWrapper w2 $ t
-#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
applyWrapper (WpFun w1 w2 t1 _doc) t =
mkVisFunTys [t1] (applyWrapper w2 $ piResultTy t
(applyWrapper w1 $ scaledThing t1))
-#else
-applyWrapper (WpFun w1 w2 t1) t = mkFunTy t1 (applyWrapper w2 $ piResultTy t (applyWrapper w1 t1))
-#endif
applyWrapper (WpCast coercion) _t = pSnd $ tcCoercionKind coercion
applyWrapper (WpEvLam v) t = mkVisFunTyMany (evVarPred v) t
applyWrapper (WpEvApp _ev) t = case splitFunTy_maybe t of
Just (_, _arg,res) -> res
Nothing -> t
-#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
applyWrapper (WpTyLam v) t = mkForAllTy v Required t
-#else
-applyWrapper (WpTyLam v) t = mkForAllTy (mkNamedBinder Invisible v) t
-#endif
applyWrapper (WpTyApp t') t = piResultTy t t'
applyWrapper (WpLet _) t = t
+applyWrapper (WpMultCoercion coercion) _ = pSnd $ tcCoercionKind coercion
wrapperTypes :: HsWrapper -> [Type]
wrapperTypes WpHole = []
wrapperTypes (WpCompose w1 w2) = wrapperTypes w2 ++ wrapperTypes w1
-#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
wrapperTypes (WpFun w1 w2 _ _) = wrapperTypes w2 ++ wrapperTypes w1
-#else
-wrapperTypes (WpFun w1 w2 _) = wrapperTypes w2 ++ wrapperTypes w1
-#endif
wrapperTypes (WpCast _) = []
wrapperTypes (WpEvLam _) = []
wrapperTypes (WpEvApp _) = []
wrapperTypes (WpTyLam _) = []
wrapperTypes (WpTyApp t) = [t]
wrapperTypes (WpLet _) = []
+wrapperTypes (WpMultCoercion _) = []
mkType :: DynFlags -> Type -> HCE.Type
mkType flags typ =
@@ -1140,47 +1088,48 @@ conDeclDocs conDecl =
getConNames $
conDecl
-extractRecCon :: ConDecl p -> Maybe (XRec p [LConDeclField p])
-extractRecCon = undefined
-
-selectorDocs :: ConDecl GhcRn -> [(Name, [HsDocString], SrcSpan)]
-selectorDocs con =
- case extractRecCon con of
- Just (L _ flds) ->
- concatMap
- (\(L _ (ConDeclField _ fieldOccs _ mbDoc)) ->
- map
- (\(L span f) ->
- (extFieldOcc f, maybe [] ((: []) . unLoc) mbDoc, span))
- fieldOccs)
- flds
- _ -> []
+-- no longer used by subordinateNamesWithDocs
+-- extractRecCon :: ConDecl p -> Maybe (XRec p [LConDeclField p])
+-- extractRecCon = undefined
+
+-- no longer used by subordinateNamesWithDocs
+-- selectorDocs :: ConDecl GhcRn -> [(Name, [HsDocString], SrcSpan)]
+-- selectorDocs con =
+-- case extractRecCon con of
+-- Just (L _ flds) ->
+-- concatMap
+-- (\(L _ (ConDeclField _ fieldOccs _ mbDoc)) ->
+-- map
+-- (\(L span f) ->
+-- (extFieldOcc f, maybe [] ((: []) . unLoc) mbDoc, span))
+-- fieldOccs)
+-- flds
+-- _ -> []
subordinateNamesWithDocs :: [LHsDecl GhcRn] -> [(Name, [HsDocString], SrcSpan)]
subordinateNamesWithDocs =
concatMap
(\lhd ->
case unLoc lhd of
- TyClD _ classDecl@ClassDecl {..} ->
+ TyClD _ classDecl ->
concatMap
(\(L _ decl, docs) -> map (, docs, getLocA lhd) $ getMainDeclBinder decl) $
classDeclDocs classDecl
- TyClD _ DataDecl {..} ->
- concatMap (\(L _ con) -> conDeclDocs con ++ selectorDocs con) $
- dd_cons tcdDataDefn
+ -- Pattern match is redundant
+ -- TyClD _ DataDecl {..} ->
+ -- concatMap (\(L _ con) -> conDeclDocs con ++ selectorDocs con) $
+ -- dd_cons tcdDataDefn
InstD _ (DataFamInstD _ DataFamInstDecl {..}) ->
concatMap (conDeclDocs . unLoc) . dd_cons . feqn_rhs $ dfid_eqn
_ -> [])
-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
+-- no longer needed by ungroup
+-- isUserLSig :: forall p. UnXRec p => LSig p -> Bool
+-- isUserLSig sig = case unXRec @p sig of
+-- TypeSig {} -> True
+-- ClassOpSig {} -> True
+-- _ -> False
#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
getMainDeclBinder :: HsDecl GhcRn -> [IdP GhcRn]
@@ -1229,9 +1178,10 @@ sigNameNoLoc _ = []
clsInstDeclSrcSpan :: ClsInstDecl (GhcPass p) -> SrcSpan
clsInstDeclSrcSpan ClsInstDecl {cid_poly_ty = ty} = getLocA ty
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-clsInstDeclSrcSpan (XClsInstDecl _) = UnhelpfulSpan (UnhelpfulOther "XClsinstdecl")
-#endif
+-- Pattern match is redundant
+-- #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+-- clsInstDeclSrcSpan (XClsInstDecl _) = UnhelpfulSpan (UnhelpfulOther "XClsinstdecl")
+-- #endif
hsDocsToDocH :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> Doc Name
hsDocsToDocH flags rdrEnv =
@@ -1353,8 +1303,9 @@ makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r
isLegal '.' = True
isLegal c = isAscii c && isAlphaNum c
+-- no more HasSrcSpan or SrcSpanLess
-- #if MIN_VERSION_ghc(8,8,0)
--- ghcDL :: GHC.RealSrcSpan a => a -> GHC.Located (GHC.SrcSpan a)
+-- ghcDL :: GHC.HasSrcSpan a => a -> GHC.Located (GHC.SrcSpanLess a)
-- ghcDL = GHC.dL
-- #else
ghcDL :: GHC.Located a -> GHC.Located a
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-27 11:57:18 +0000