aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/HaskellCodeExplorer/GhcUtils.hs202
1 files changed, 74 insertions, 128 deletions
diff --git a/src/HaskellCodeExplorer/GhcUtils.hs b/src/HaskellCodeExplorer/GhcUtils.hs
index b408570..65244e9 100644
--- a/src/HaskellCodeExplorer/GhcUtils.hs
+++ b/src/HaskellCodeExplorer/GhcUtils.hs
@@ -64,7 +64,11 @@ module HaskellCodeExplorer.GhcUtils
import GHC.Data.Bag (bagToList)
-- import ConLike (ConLike(..))
import GHC.Core.ConLike (ConLike(..))
-import GHC.HsToCore.Docs (collectDocs)
+import GHC.HsToCore.Docs
+ ( collectDocs
+ , ungroup
+ , mkDecls
+ )
import qualified Data.ByteString as BS
import Data.Hashable (Hashable,hash)
import qualified Data.ByteString.Internal as BSI
@@ -80,9 +84,11 @@ import qualified Data.Text as T
-- import DataCon (dataConWorkId, flSelector)
import GHC.Core.DataCon (dataConWorkId, flSelector)
import Documentation.Haddock.Parser (overIdentifier, parseParas)
-import Documentation.Haddock.Types (DocH(..),
- Header(..),
- _doc
+import Documentation.Haddock.Types
+ ( DocH(..)
+ , Header(..)
+ , _doc
+ , Namespace
)
-- import DynFlags ()
import GHC.Driver.Session (DynFlags)
@@ -90,6 +96,8 @@ import GHC.Driver.Session (DynFlags)
import GHC.Data.FastString (mkFastString, unpackFS)
import GHC
( DynFlags
+ , CollectFlag(..)
+ , reLocN
, unXRec
, UnXRec
, GhcPass
@@ -257,7 +265,11 @@ import GHC.Parser (parseIdentifier)
import GHC.Core.PatSyn (PatSyn, patSynMatcher, patSynSig)
import Prelude hiding (id, span)
-- import RdrName (GlobalRdrEnv, RdrName(..), gre_name, lookupGRE_RdrName)
-import GHC.Types.Name.Reader (GlobalRdrEnv, RdrName(..), gre_name, lookupGRE_RdrName)
+import GHC.Types.Name.Reader
+ ( GlobalRdrEnv
+ , RdrName(..)
+ , grePrintableName
+ , lookupGRE_RdrName)
-- import RnEnv (dataTcOccs)
import GHC.Rename.Env (dataTcOccs)
-- import SrcLoc (GenLocated(..), mkRealSrcLoc, unLoc)
@@ -269,13 +281,14 @@ import System.FilePath (normalise)
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 GHC.Core.TyCo.Rep
+ ( Type(..)
+ , ArgFlag(..)
+ , mkVisFunTyMany
+ , mkVisFunTys
+ , mkVisFunTysMany
+ , scaledThing
+ )
-- import TyCon (tyConName)
import GHC.Core.TyCon (tyConName)
-- import Type
@@ -284,11 +297,9 @@ import GHC.Core.Type
, expandTypeSynonyms
, mkForAllTy
, mkFunTy
+ , mkTyCoInvForAllTys
-- , mkFunTys
-- , mkInvForAllTys
-
-
-
, piResultTy
, splitFunTy_maybe
, tidyOpenType, mkVisForAllTys
@@ -316,6 +327,7 @@ import GHC.Types.Var
( idDetails
, isId
, mkTyVar
+ , mkCoVar
, setVarType
, varName
, varType
@@ -360,18 +372,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 . dfid_eqn $ di
+ in T.concat
+ ["data instance ", toText flags (unLoc $ feqn_tycon . dfid_eqn $ di), " ", args]
+ TyFamInstD _ ti ->
+ let args =
+ T.intercalate " " .
+ map (toText flags) . feqn_pats . 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 =
@@ -542,7 +554,7 @@ hsPatSynDetails patDetails =
#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
unwrapName :: LIEWrappedName a -> Located a
-unwrapName = undefined
+unwrapName = reLocN . ieLWrappedName
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
unwrapName :: LIEWrappedName Name -> Located Name
unwrapName = ieLWrappedName
@@ -559,10 +571,11 @@ 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) = [unwrapName n]
+ieLocNames (IEVar n) =
#endif
+ [unwrapName n]
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
ieLocNames (IEThingAbs _ n) =
#else
@@ -901,6 +914,7 @@ srcSpanToLineAndColNumbers ::
HCE.SourceCodeTransformation
-> SrcSpan
-> Maybe (HCE.HaskellFilePath, (Int, Int), (Int, Int))
+-- do we need to do anything with the BufSpan?
srcSpanToLineAndColNumbers transformation (RealSrcSpan s _) =
let filePath =
HCE.HaskellFilePath . T.pack . normalise . unpackFS . srcSpanFile $ s
@@ -945,11 +959,11 @@ patSynId patSyn =
| otherwise = reqTheta
-- required => provided => arg_1 -> ... -> arg_n -> res
patSynTy =
- mkVisForAllTys univTvs $
+ mkTyCoInvForAllTys univTvs $
mkVisFunTysMany reqTheta' $
- mkVisForAllTys exTvs $ mkVisFunTysMany provTheta $
- mkVisFunTysMany argTys resTy
- in flip setVarType patSynTy . fst . patSynMatcher $ patSyn
+ mkTyCoInvForAllTys exTvs $ mkVisFunTysMany provTheta $ mkVisFunTys argTys resTy
+ (name, _, _) = patSynMatcher patSyn
+ in mkCoVar name patSynTy
applyWrapper :: HsWrapper -> Type -> Type
applyWrapper wp ty
@@ -957,14 +971,16 @@ 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 = mkFunTy t1 (applyWrapper w2 $ piResultTy t (applyWrapper w1 t1))
+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 = mkFunTy (evVarPred v) t
+applyWrapper (WpEvLam v) t = mkVisFunTyMany (evVarPred v) t
applyWrapper (WpEvApp _ev) t = case splitFunTy_maybe t of
- Just (_arg,res) -> res
+ Just (_, _arg,res) -> res
Nothing -> t
#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
applyWrapper (WpTyLam v) t = mkForAllTy v Required t
@@ -1089,69 +1105,19 @@ tyVarsOfType = varSetElems . everything unionVarSet (emptyVarSet `mkQ` tyVar)
-- 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
-ungroup :: HsGroup Name -> [LHsDecl Name]
-#endif
-ungroup group_ =
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
- mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD NoExtField) group_ ++
-#elif MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
- mkDecls (tyClGroupTyClDecls . hs_tyclds) TyClD group_ ++
-#else
- mkDecls (tyClGroupConcat . hs_tyclds) TyClD group_ ++
-#endif
-
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
- 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_ ++
- mkDecls hs_fords ForD group_ ++
- mkDecls hs_docs DocD group_ ++
-#endif
-
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
- mkDecls hsGroupInstDecls (InstD NoExtField) group_ ++
-#elif MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
- mkDecls hsGroupInstDecls InstD group_ ++
-#else
- mkDecls hs_instds InstD group_ ++
-#endif
-
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
- 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_
-#endif
-
-
- where
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
- typesigs (XValBindsLR (NValBinds _ sigs)) = filter isUserLSig sigs
-#else
- typesigs (ValBindsOut _ sigs) = filter isUserLSig sigs
-#endif
- typesigs _ = []
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
- valbinds (XValBindsLR (NValBinds binds _)) = concatMap (bagToList . snd) binds
-#else
- valbinds (ValBindsOut binds _) = concatMap (bagToList . snd) binds
-#endif
- valbinds _ = []
+-- available in GHC.HsToCore.Docs
+-- #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+-- ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn]
+-- #else
+-- ungroup :: HsGroup Name -> [LHsDecl Name]
+-- #endif
-- 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]
+-- mkDecls :: (struct -> [GenLocated l decl]) -> (decl -> hsDecl) -> struct -> [GenLocated l hsDecl]
+-- mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c]
+-- mkDecls field con struct = [L loc (con decl) | L loc decl <- field struct]
-sortByLoc :: [Located a] -> [Located a]
+sortByLoc :: [GenLocated l a] -> [GenLocated l a]
sortByLoc = L.sortOn getLoc
#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
@@ -1181,7 +1147,7 @@ conDeclDocs :: ConDecl GhcRn -> [(Name, [HsDocString], SrcSpan)]
conDeclDocs :: ConDecl Name -> [(Name, [HsDocString], SrcSpan)]
#endif
conDeclDocs conDecl =
- map (\(L span n) -> (n, maybe [] ((: []) . unLoc) $ con_doc conDecl, span)) .
+ map (\con -> (unLoc con, maybe [] ((: []) . unLoc) $ con_doc conDecl, getLocA con)) .
getConNames $
conDecl
@@ -1201,41 +1167,20 @@ selectorDocs con =
flds
_ -> []
-#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
subordinateNamesWithDocs :: [LHsDecl GhcRn] -> [(Name, [HsDocString], SrcSpan)]
-#else
-subordinateNamesWithDocs :: [GenLocated SrcSpan (HsDecl Name)] -> [(Name, [HsDocString], SrcSpan)]
-#endif
subordinateNamesWithDocs =
concatMap
- (\(L span tyClDecl) ->
- case tyClDecl of
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+ (\lhd ->
+ case unLoc lhd of
TyClD _ classDecl@ClassDecl {..} ->
-#else
- TyClD classDecl@ClassDecl {..} ->
-#endif
concatMap
- (\(L _ decl, docs) -> map (, docs, span) $ getMainDeclBinder decl) $
+ (\(L _ decl, docs) -> map (, docs, getLocA lhd) $ getMainDeclBinder decl) $
classDeclDocs classDecl
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
TyClD _ DataDecl {..} ->
-#else
- TyClD DataDecl {..} ->
-#endif
concatMap (\(L _ con) -> conDeclDocs con ++ selectorDocs con) $
dd_cons tcdDataDefn
-#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
InstD _ (DataFamInstD _ DataFamInstDecl {..}) ->
-#else
- InstD (DataFamInstD DataFamInstDecl {..}) ->
-#endif
-
-#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
concatMap (conDeclDocs . unLoc) . dd_cons . feqn_rhs $ dfid_eqn
-#else
- concatMap (conDeclDocs . unLoc) . dd_cons $ dfid_defn
-#endif
_ -> [])
@@ -1264,7 +1209,7 @@ getMainDeclBinder (ValD _ d) =
#else
getMainDeclBinder (ValD d) =
#endif
- case collectHsBindBinders d of
+ case collectHsBindBinders CollNoDictBinders d of
[] -> []
(name:_) -> [name]
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
@@ -1315,8 +1260,8 @@ hsDocsToDocH flags rdrEnv =
. concatMap (unpackFS . (\(HsDocString s) -> s))
#endif
-parseIdent :: DynFlags -> String -> Maybe RdrName
-parseIdent dflags str0 =
+parseIdent :: DynFlags -> Namespace -> String -> Maybe RdrName
+parseIdent dflags _ str0 =
let buffer = stringToStringBuffer str0
realSrcLc = mkRealSrcLoc (mkFastString "<unknown file>") 0 0
pstate = initParserState (initParserOpts dflags) buffer realSrcLc
@@ -1329,6 +1274,7 @@ type Doc id = DocH (ModuleName, OccName) id
rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name
rename dflags gre = rn
where
+ rn :: Doc RdrName -> Doc Name
rn d = case d of
DocAppend a b -> DocAppend (rn a) (rn b)
DocParagraph doc -> DocParagraph (rn doc)
@@ -1338,7 +1284,7 @@ rename dflags gre = rn
let choices = dataTcOccs x
-- Try to look up all the names in the GlobalRdrEnv that match
-- the names.
- let names = concatMap (\c -> map gre_name (lookupGRE_RdrName c gre)) choices
+ let names = concatMap (\c -> map grePrintableName (lookupGRE_RdrName c gre)) choices
case names of
-- We found no names in the env so we start guessing.
@@ -1373,8 +1319,8 @@ rename dflags gre = rn
DocDefList list -> DocDefList [ (rn a, rn b) | (a, b) <- list ]
DocCodeBlock doc -> DocCodeBlock (rn doc)
DocIdentifierUnchecked x -> DocIdentifierUnchecked x
- DocModule str -> DocModule str
- DocHyperlink l -> DocHyperlink l
+ DocModule modLink -> DocModule (rn <$> modLink)
+ DocHyperlink hyperLink -> DocHyperlink (rn <$> hyperLink)
DocPic str -> DocPic str
DocMathInline str -> DocMathInline str
DocMathDisplay str -> DocMathDisplay str
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-27 06:17:29 +0000