diff options
| -rw-r--r-- | src/HaskellCodeExplorer/GhcUtils.hs | 131 |
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 |