aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/HaskellCodeExplorer/GhcUtils.hs235
1 files changed, 140 insertions, 95 deletions
diff --git a/src/HaskellCodeExplorer/GhcUtils.hs b/src/HaskellCodeExplorer/GhcUtils.hs
index 0f3ff1c..2a40213 100644
--- a/src/HaskellCodeExplorer/GhcUtils.hs
+++ b/src/HaskellCodeExplorer/GhcUtils.hs
@@ -57,8 +57,10 @@ module HaskellCodeExplorer.GhcUtils
, hsDocsToDocH
, subordinateNamesWithDocs
) where
-import Bag (bagToList)
-import ConLike (ConLike(..))
+-- import Bag (bagToList)
+import GHC.Data.Bag (bagToList)
+-- import ConLike (ConLike(..))
+import GHC.Core.ConLike (ConLike(..))
import qualified Data.ByteString as BS
import Data.Hashable (Hashable,hash)
import qualified Data.ByteString.Internal as BSI
@@ -71,14 +73,17 @@ import qualified Data.HashMap.Strict as HM
import qualified Data.List as L
import Data.Maybe (fromMaybe, isJust, mapMaybe)
import qualified Data.Text as T
-import DataCon (dataConWorkId, flSelector)
+-- import DataCon (dataConWorkId, flSelector)
+import GHC.Core.DataCon (dataConWorkId, flSelector)
import Documentation.Haddock.Parser (overIdentifier, parseParas)
import Documentation.Haddock.Types (DocH(..),
Header(..),
_doc
)
-import DynFlags ()
-import FastString (mkFastString, unpackFS)
+-- import DynFlags ()
+import GHC.Driver.Session (DynFlags)
+-- import FastString (mkFastString, unpackFS)
+import GHC.Data.FastString (mkFastString, unpackFS)
import GHC
( DynFlags
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
@@ -121,13 +126,13 @@ import GHC
, tcdName
, collectHsBindBinders
, getLoc
- , hsSigType
+-- , hsSigType
, getConNames
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
, NHsValBindsLR(..)
- , getConArgs
+-- , getConArgs
, unpackHDS
- , NoExt(..)
+-- , NoExt(..)
, extFieldOcc
#else
, getConDetails
@@ -153,36 +158,47 @@ import GHC
, srcSpanEndCol
, isExternalName
, moduleNameString
- , recordPatSynSelectorId
+-- , recordPatSynSelectorId
, recordPatSynPatVar
, isGoodSrcSpan
, isLocalId
, isDataFamilyDecl
, tyFamInstDeclName
, idType
- , hsib_body
+-- , hsib_body
#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
#else
, tfe_pats
#endif
, tfid_eqn
#if MIN_VERSION_ghc(8,8,0)
- , dL
- , HasSrcSpan
- , SrcSpanLess
+-- , dL
+-- , HasSrcSpan
+-- , SrcSpanLess
#endif
)
import qualified HaskellCodeExplorer.Types as HCE
-import HscTypes (TypeEnv, lookupTypeEnv)
+-- import HscTypes (TypeEnv, lookupTypeEnv)
+import GHC.Types.TypeEnv (TypeEnv, lookupTypeEnv)
#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
-import HsExtension (GhcRn,IdP)
-#endif
-import IdInfo (IdDetails(..))
-import InstEnv (ClsInst(..))
-import Lexer (ParseResult(POk), mkPState, unP)
-import Module (Module(..))
-import Name
+-- import HsExtension (GhcRn,IdP)
+import GHC.Hs.Extension (GhcRn)
+import Language.Haskell.Syntax.Extension (IdP)
+#endif
+-- import IdInfo (IdDetails(..))
+import GHC.Types.Id.Info (IdDetails(..))
+-- import InstEnv (ClsInst(..))
+import GHC.Core.InstEnv (ClsInst(..))
+-- import GHC.Parser.Lexer (ParseResult(POk), mkPState, unP)
+import GHC.Parser.Lexer (
+ ParseResult(POk)
+ , unP
+ )
+-- import Module (Module(..))
+import GHC.Unit.Types (Module(..))
+-- import Name
+import GHC.Types.Name
( isDataConNameSpace
, isDerivedOccName
, isInternalName
@@ -201,63 +217,84 @@ import Name
, occNameString
, wiredInNameTyThing_maybe
)
-import OccName (OccName)
-import Outputable (Outputable, ppr, showPpr, showSDoc)
-import PackageConfig (packageVersion)
-import Packages
+-- import OccName (OccName)
+import GHC.Types.Name.Occurrence (OccName)
+-- import Outputable (Outputable, ppr, showPpr, showSDoc)
+import GHC.Utils.Outputable (Outputable, ppr)
+import GHC.Driver.Ppr (showPpr, showSDoc)
+-- import PackageConfig (packageVersion)
+-- import Packages
+import Distribution.Package (packageVersion)
+import GHC.Unit.State
( LookupResult(..)
, lookupModuleWithSuggestions
- , lookupPackage
- , packageNameString
+-- , lookupPackage
+-- , packageNameString
)
-import Pair (pSnd)
-import Parser (parseIdentifier)
-import PatSyn (PatSyn, patSynMatcher, patSynSig)
+-- import Pair (pSnd)
+import GHC.Data.Pair (pSnd)
+-- import Parser (parseIdentifier)
+import GHC.Parser (parseIdentifier)
+-- import PatSyn (PatSyn, patSynMatcher, patSynSig)
+import GHC.Core.PatSyn (PatSyn, patSynMatcher, patSynSig)
import Prelude hiding (id, span)
-import RdrName (GlobalRdrEnv, RdrName(..), gre_name, lookupGRE_RdrName)
-import RnEnv (dataTcOccs)
-import SrcLoc (GenLocated(..), mkRealSrcLoc, unLoc)
-import StringBuffer (StringBuffer(..), stringToStringBuffer)
+-- import RdrName (GlobalRdrEnv, RdrName(..), gre_name, lookupGRE_RdrName)
+import GHC.Types.Name.Reader (GlobalRdrEnv, RdrName(..), gre_name, lookupGRE_RdrName)
+-- import RnEnv (dataTcOccs)
+import GHC.Rename.Env (dataTcOccs)
+-- import SrcLoc (GenLocated(..), mkRealSrcLoc, unLoc)
+import GHC.Types.SrcLoc (GenLocated(..), mkRealSrcLoc, unLoc)
+-- import StringBuffer (StringBuffer(..), stringToStringBuffer)
+import GHC.Data.StringBuffer (StringBuffer(..), stringToStringBuffer)
import System.FilePath (normalise)
-import TcEvidence (HsWrapper(..), tcCoercionKind)
-import TcType (evVarPred)
-import TyCoRep (Type(..),
-#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
- ArgFlag(..)
-#else
- VisibilityFlag(..)
-#endif
+-- import TcEvidence (HsWrapper(..), tcCoercionKind)
+import GHC.Tc.Types.Evidence (HsWrapper(..), tcCoercionKind)
+-- import TcType (evVarPred)
+import GHC.Tc.Utils.TcType (evVarPred)
+import GHC.Core.TyCo.Rep (Type(..),
+
+ ArgFlag(..), mkVisFunTysMany
+
+
+
)
-import TyCon (tyConName)
-import Type
+-- import TyCon (tyConName)
+import GHC.Core.TyCon (tyConName)
+-- import Type
+import GHC.Core.Type
( coreView
, expandTypeSynonyms
, mkForAllTy
, mkFunTy
- , mkFunTys
- , mkInvForAllTys
-#if !MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
- , mkNamedBinder
-#endif
+-- , mkFunTys
+-- , mkInvForAllTys
+
+
+
, piResultTy
- , pprSigmaType
, splitFunTy_maybe
- , tidyOpenType
+ , tidyOpenType, mkVisForAllTys
)
+import GHC.Core.TyCo.Ppr (pprSigmaType)
#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
-import ToIface
-import IfaceType
-#endif
-import TysWiredIn (unitTy)
-import UniqSet (emptyUniqSet, unionUniqSets,
+import GHC.CoreToIface
+-- import IfaceType
+import GHC.Iface.Type
+#endif
+-- import TysWiredIn (unitTy)
+import GHC.Builtin.Types (unitTy)
+-- import UniqSet (emptyUniqSet, unionUniqSets,
+import GHC.Types.Unique.Set (emptyUniqSet, unionUniqSets,
#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
nonDetEltsUniqSet
#else
uniqSetToList
#endif
)
-import Unique (getKey)
-import Var
+-- import Unique (getKey)
+import GHC.Types.Unique (getKey)
+-- import Var
+import GHC.Types.Var
( idDetails
, isId
, mkTyVar
@@ -266,13 +303,16 @@ import Var
, varType
, varUnique
)
-import VarEnv (TidyEnv)
-import VarSet (VarSet, emptyVarSet, unionVarSet, unitVarSet
+-- import VarEnv (TidyEnv)
+import GHC.Types.Var.Env (TidyEnv)
+-- import VarSet (VarSet, emptyVarSet, unionVarSet, unitVarSet
+import GHC.Types.Var.Set (VarSet, emptyVarSet, unionVarSet, unitVarSet
#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
#else
,varSetElems
#endif
)
+import GHC.Unit
--------------------------------------------------------------------------------
-- Pretty-printing
@@ -302,18 +342,18 @@ instanceDeclToText flags decl =
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 . 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]
+ 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]
#elif MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
DataFamInstD di ->
let args =
@@ -464,9 +504,10 @@ hsPatSynDetails patDetails =
#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
case patDetails of
InfixCon name1 name2 -> [name1, name2]
- PrefixCon fields -> fields
+ PrefixCon _ fields -> fields
RecCon fields -> concatMap
- (\field -> [recordPatSynSelectorId field, recordPatSynPatVar field])
+ (\field -> [-- recordPatSynSelectorId field,
+ recordPatSynPatVar field])
fields
#else
case patDetails of
@@ -481,7 +522,7 @@ hsPatSynDetails patDetails =
#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
unwrapName :: LIEWrappedName a -> Located a
-unwrapName = ieLWrappedName
+unwrapName = undefined
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
unwrapName :: LIEWrappedName Name -> Located Name
unwrapName = ieLWrappedName
@@ -498,11 +539,10 @@ ieLocNames :: IE Name -> [Located Name]
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
ieLocNames (XIE _) = []
-ieLocNames (IEVar _ n) =
+ieLocNames (IEVar _ n) = []
#else
-ieLocNames (IEVar n) =
+ieLocNames (IEVar n) = [unwrapName n]
#endif
- [unwrapName n]
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
ieLocNames (IEThingAbs _ n) =
#else
@@ -515,12 +555,16 @@ ieLocNames (IEThingAll _ n) =
ieLocNames (IEThingAll n) =
#endif
[unwrapName n]
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+#if MIN_VERSION_GLASGOW_HASKELL(9,2,1,0)
+ieLocNames (IEThingWith _ n _ ns) =
+ unwrapName n : (map unwrapName ns)
+#elif MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
ieLocNames (IEThingWith _ n _ ns labels) =
+ unwrapName n : (map unwrapName ns ++ map (fmap flSelector) labels)
#else
ieLocNames (IEThingWith n _ ns labels) =
-#endif
unwrapName n : (map unwrapName ns ++ map (fmap flSelector) labels)
+#endif
ieLocNames IEModuleContents {} = []
ieLocNames IEGroup {} = []
ieLocNames IEDoc {} = []
@@ -558,7 +602,7 @@ lookupNameModuleAndPackage flags currentPackageId name =
then currentPackageId
else HCE.PackageId
(T.pack $ packageNameString packageConfig)
- (PackageConfig.packageVersion packageConfig)
+ (packageVersion packageConfig)
in Right
( HCE.HaskellModuleName . T.pack . moduleNameString $ moduleName
, packageId)
@@ -606,13 +650,13 @@ moduleLocationInfo flags moduleNameMap currentPackageId compId moduleName =
1
_ ->
case lookupModuleWithSuggestions flags moduleName Nothing of
- LookupFound Module {moduleUnitId = unitId} _ ->
+ LookupFound Module {moduleUnit = unitId} _ ->
case lookupPackage flags unitId of
Just packInfo ->
let packageId =
HCE.PackageId
(T.pack $ packageNameString packInfo)
- (PackageConfig.packageVersion packInfo)
+ (packageVersion packInfo)
in HCE.ApproximateLocation
packageId
(HCE.HaskellModuleName . T.pack . moduleNameString $
@@ -700,13 +744,13 @@ nameLocationInfo flags currentPackageId compId transformation fileMap defSiteMap
realSrcSpan :: Name -> Maybe SrcSpan -> Maybe RealSrcSpan
realSrcSpan n mbSpan =
case nameSrcSpan n of
- RealSrcSpan span -> Just span
+ RealSrcSpan span _ -> Just span
_
| isWiredInName n ->
case mbSpan of
Just span ->
case span of
- RealSrcSpan s -> Just s
+ RealSrcSpan s _ -> Just s
_ -> Nothing
_ -> Nothing
_ -> Nothing
@@ -828,7 +872,7 @@ lookupNameDocumentation name defSiteMap =
_ -> lookupDoc HCE.types
srcSpanToFilePath :: SrcSpan -> Maybe HCE.HaskellFilePath
-srcSpanToFilePath (RealSrcSpan s) =
+srcSpanToFilePath (RealSrcSpan s _) =
Just . HCE.HaskellFilePath . T.pack . normalise . unpackFS . srcSpanFile $ s
srcSpanToFilePath (UnhelpfulSpan _) = Nothing
@@ -836,7 +880,7 @@ srcSpanToLineAndColNumbers ::
HCE.SourceCodeTransformation
-> SrcSpan
-> Maybe (HCE.HaskellFilePath, (Int, Int), (Int, Int))
-srcSpanToLineAndColNumbers transformation (RealSrcSpan s) =
+srcSpanToLineAndColNumbers transformation (RealSrcSpan s _) =
let filePath =
HCE.HaskellFilePath . T.pack . normalise . unpackFS . srcSpanFile $ s
eitherStart =
@@ -880,9 +924,10 @@ patSynId patSyn =
| otherwise = reqTheta
-- required => provided => arg_1 -> ... -> arg_n -> res
patSynTy =
- mkInvForAllTys univTvs $
- mkFunTys reqTheta' $
- mkInvForAllTys exTvs $ mkFunTys provTheta $ mkFunTys argTys resTy
+ mkVisForAllTys univTvs $
+ mkVisFunTysMany reqTheta' $
+ mkVisForAllTys exTvs $ mkVisFunTysMany provTheta $
+ mkVisFunTysMany argTys resTy
in flip setVarType patSynTy . fst . patSynMatcher $ patSyn
applyWrapper :: HsWrapper -> Type -> Type
@@ -1408,10 +1453,10 @@ makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r
isLegal '.' = True
isLegal c = isAscii c && isAlphaNum c
-#if MIN_VERSION_ghc(8,8,0)
-ghcDL :: GHC.HasSrcSpan a => a -> GHC.Located (GHC.SrcSpanLess a)
-ghcDL = GHC.dL
-#else
+-- #if MIN_VERSION_ghc(8,8,0)
+-- ghcDL :: GHC.RealSrcSpan a => a -> GHC.Located (GHC.SrcSpan a)
+-- ghcDL = GHC.dL
+-- #else
ghcDL :: GHC.Located a -> GHC.Located a
ghcDL x = x
-#endif
+-- #endif
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-27 07:31:48 +0000