diff options
Diffstat (limited to 'haddock-api/src/Haddock/Interface')
| -rw-r--r-- | haddock-api/src/Haddock/Interface/AttachInstances.hs | 40 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 286 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Json.hs | 10 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/LexParseRn.hs | 12 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/ParseModuleHeader.hs | 5 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Rename.hs | 77 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Specialize.hs | 53 |
7 files changed, 157 insertions, 326 deletions
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index ce987b76..6ef0ed19 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -19,7 +19,6 @@ module Haddock.Interface.AttachInstances (attachInstances) where import Haddock.Types import Haddock.Convert -import Haddock.GhcUtils import Control.Applicative ((<|>)) import Control.Arrow hiding ((<+>)) @@ -29,23 +28,24 @@ import Data.Maybe ( maybeToList, mapMaybe, fromMaybe ) import qualified Data.Map as Map import qualified Data.Set as Set -import Class -import DynFlags -import CoreSyn (isOrphan) -import ErrUtils -import FamInstEnv +import GHC.Core.Class +import GHC.Driver.Session +import GHC.Core (isOrphan) +import GHC.Utils.Error +import GHC.Core.FamInstEnv import GHC -import InstEnv -import Module ( ModuleSet, moduleSetElts ) -import MonadUtils (liftIO) -import Name -import NameEnv -import Outputable (text, sep, (<+>)) -import SrcLoc -import TyCon -import TyCoRep -import TysPrim( funTyConName ) -import Var hiding (varName) +import GHC.Core.InstEnv +import GHC.Unit.Module.Env ( ModuleSet, moduleSetElts ) +import GHC.Utils.Monad (liftIO) +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Utils.Outputable (text, sep, (<+>)) +import GHC.Types.SrcLoc +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep +import GHC.Builtin.Types.Prim( funTyConName ) +import GHC.Types.Var hiding (varName) +import GHC.HsToCore.Docs type ExportedNames = Set.Set Name type Modules = Set.Set Module @@ -196,13 +196,13 @@ instHead (_, _, cls, args) argCount :: Type -> Int argCount (AppTy t _) = argCount t + 1 argCount (TyConApp _ ts) = length ts -argCount (FunTy _ _ _) = 2 +argCount (FunTy _ _ _ _) = 2 argCount (ForAllTy _ t) = argCount t argCount (CastTy t _) = argCount t argCount _ = 0 simplify :: Type -> SimpleType -simplify (FunTy _ t1 t2) = SimpleType funTyConName [simplify t1, simplify t2] +simplify (FunTy _ _ t1 t2) = SimpleType funTyConName [simplify t1, simplify t2] simplify (ForAllTy _ t) = simplify t simplify (AppTy t1 t2) = SimpleType s (ts ++ maybeToList (simplify_maybe t2)) where (SimpleType s ts) = simplify t1 @@ -257,7 +257,7 @@ isTypeHidden expInfo = typeHidden case t of TyVarTy {} -> False AppTy t1 t2 -> typeHidden t1 || typeHidden t2 - FunTy _ t1 t2 -> typeHidden t1 || typeHidden t2 + FunTy _ _ t1 t2 -> typeHidden t1 || typeHidden t2 TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args ForAllTy bndr ty -> typeHidden (tyVarKind (binderVar bndr)) || typeHidden ty LitTy _ -> False diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index d554eeb3..7fb71d4b 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -33,31 +33,30 @@ import Data.Bitraversable import qualified Data.Map as M import qualified Data.Set as S import Data.Map (Map) -import Data.List (find, foldl', sortBy) +import Data.List (find, foldl') import Data.Maybe -import Data.Ord -import Control.Applicative import Control.Monad import Data.Traversable import GHC.Stack (HasCallStack) -import Avail hiding (avail) -import qualified Avail -import qualified Module -import qualified SrcLoc -import ConLike (ConLike(..)) +import GHC.Types.Avail hiding (avail) +import qualified GHC.Types.Avail as Avail +import qualified GHC.Unit.Module as Module +import qualified GHC.Types.SrcLoc as SrcLoc +import GHC.Core.ConLike (ConLike(..)) import GHC -import HscTypes -import Name -import NameSet -import NameEnv -import Packages ( lookupModuleInAllPackages, PackageName(..) ) -import Bag -import RdrName -import TcRnTypes -import FastString ( unpackFS, bytesFS ) -import BasicTypes ( StringLiteral(..), SourceText(..), PromotionFlag(..) ) -import qualified Outputable as O +import GHC.Driver.Types +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Unit.State +import GHC.Types.Name.Reader +import GHC.Tc.Types +import GHC.Data.FastString ( unpackFS, bytesFS ) +import GHC.Types.Basic ( StringLiteral(..), SourceText(..), PromotionFlag(..) ) +import qualified GHC.Utils.Outputable as O +import GHC.HsToCore.Docs hiding (mkMaps) +import GHC.Parser.Annotation (IsUnicodeSyntax(..)) mkExceptionContext :: TypecheckedModule -> String mkExceptionContext = @@ -168,7 +167,7 @@ createInterface tm flags modMap instIfaceMap = !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems' let !aliases = - mkAliasMap dflags $ tm_renamed_source tm + mkAliasMap (unitState dflags) $ tm_renamed_source tm modWarn <- liftErrMsg (moduleWarning dflags gre warnings) @@ -213,12 +212,13 @@ createInterface tm flags modMap instIfaceMap = , ifaceDynFlags = dflags } + -- | Given all of the @import M as N@ declarations in a package, -- create a mapping from the module identity of M, to an alias N -- (if there are multiple aliases, we pick the last one.) This -- will go in 'ifaceModuleAliases'. -mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName -mkAliasMap dflags mRenamedSource = +mkAliasMap :: UnitState -> Maybe RenamedSource -> M.Map Module ModuleName +mkAliasMap state mRenamedSource = case mRenamedSource of Nothing -> M.empty Just (_,impDecls,_,_) -> @@ -226,7 +226,7 @@ mkAliasMap dflags mRenamedSource = mapMaybe (\(SrcLoc.L _ impDecl) -> do SrcLoc.L _ alias <- ideclAs impDecl return $ - (lookupModuleDyn dflags + (lookupModuleDyn state -- TODO: This is supremely dodgy, because in general the -- UnitId isn't going to look anything like the package -- qualifier (even with old versions of GHC, the @@ -241,7 +241,7 @@ mkAliasMap dflags mRenamedSource = -- them to the user. We should reuse that information; -- or at least reuse the renamed imports, which know what -- they import! - (fmap Module.fsToUnitId $ + (fmap Module.fsToUnit $ fmap sl_fs $ ideclPkgQual impDecl) (case ideclName impDecl of SrcLoc.L _ name -> name), alias)) @@ -285,13 +285,13 @@ unrestrictedModuleImports idecls = -- Similar to GHC.lookupModule -- ezyang: Not really... lookupModuleDyn :: - DynFlags -> Maybe UnitId -> ModuleName -> Module + UnitState -> Maybe Unit -> ModuleName -> Module lookupModuleDyn _ (Just pkgId) mdlName = Module.mkModule pkgId mdlName -lookupModuleDyn dflags Nothing mdlName = - case lookupModuleInAllPackages dflags mdlName of +lookupModuleDyn state Nothing mdlName = + case lookupModuleInAllUnits state mdlName of (m,_):_ -> m - [] -> Module.mkModule Module.mainUnitId mdlName + [] -> Module.mkModule Module.mainUnit mdlName ------------------------------------------------------------------------------- @@ -396,9 +396,8 @@ mkMaps dflags pkgName gre instances decls = do , [(Name, Map Int (MDoc Name))] , [(Name, [LHsDecl GhcRn])] ) - mappings (ldecl, docStrs) = do - let L l decl = ldecl - declDoc :: [HsDocString] -> Map Int HsDocString + mappings (ldecl@(L (RealSrcSpan l _) decl), docStrs) = do + let declDoc :: [HsDocString] -> Map Int HsDocString -> ErrMsgM (Maybe (MDoc Name), Map Int (MDoc Name)) declDoc strs m = do doc' <- processDocStrings dflags pkgName gre strs @@ -426,12 +425,13 @@ mkMaps dflags pkgName gre instances decls = do seqList subDocs `seq` seqList subArgs `seq` pure (dm, am, cm) + mappings (L (UnhelpfulSpan _) _, _) = pure ([], [], []) - instanceMap :: Map SrcSpan Name - instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ] + instanceMap :: Map RealSrcSpan Name + instanceMap = M.fromList [(l, n) | n <- instances, RealSrcSpan l _ <- [getSrcSpan n] ] - names :: SrcSpan -> HsDecl GhcRn -> [Name] - names _ (InstD _ d) = maybeToList (M.lookup loc instanceMap) -- See note [2]. + names :: RealSrcSpan -> HsDecl GhcRn -> [Name] + names _ (InstD _ d) = maybeToList (SrcLoc.lookupSrcSpan loc instanceMap) -- See note [2]. where loc = case d of -- The CoAx's loc is the whole line, but only for TFs. The -- workaround is to dig into the family instance declaration and @@ -454,200 +454,13 @@ mkMaps dflags pkgName gre instances decls = do -------------------------------------------------------------------------------- --- | Get all subordinate declarations inside a declaration, and their docs. --- A subordinate declaration is something like the associate type or data --- family of a type class. -subordinates :: InstMap - -> HsDecl GhcRn - -> [(Name, [HsDocString], Map Int HsDocString)] -subordinates instMap decl = case decl of - InstD _ (ClsInstD _ d) -> do - DataFamInstDecl { dfid_eqn = HsIB { hsib_body = - FamEqn { feqn_tycon = L l _ - , feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d - [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn - - InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d }))) - -> dataSubs (feqn_rhs d) - TyClD _ d | isClassDecl d -> classSubs d - | isDataDecl d -> dataSubs (tcdDataDefn d) - _ -> [] - where - classSubs dd = [ (name, doc, declTypeDocs d) | (L _ d, doc) <- classDecls dd - , name <- getMainDeclBinder d, not (isValD d) - ] - dataSubs :: HsDataDefn GhcRn -> [(Name, [HsDocString], Map Int HsDocString)] - dataSubs dd = constrs ++ fields ++ derivs - where - cons = map unLoc $ (dd_cons dd) - constrs = [ (unLoc cname, maybeToList $ fmap unLoc $ con_doc c, conArgDocs c) - | c <- cons, cname <- getConNames c ] - fields = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty) - | RecCon flds <- map getConArgs cons - , L _ (ConDeclField _ ns _ doc) <- (unLoc flds) - , L _ n <- ns ] - derivs = [ (instName, [unLoc doc], M.empty) - | (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $ - concatMap (unLoc . deriv_clause_tys . unLoc) $ - unLoc $ dd_derivs dd - , Just instName <- [M.lookup l instMap] ] - - extract_deriv_ty :: LHsType GhcRn -> Maybe (SrcSpan, LHsDocString) - extract_deriv_ty ty = - case dL ty of - -- deriving (forall a. C a {- ^ Doc comment -}) - L l (HsForAllTy{ hst_fvf = ForallInvis - , hst_body = dL->L _ (HsDocTy _ _ doc) }) - -> Just (l, doc) - -- deriving (C a {- ^ Doc comment -}) - L l (HsDocTy _ _ doc) -> Just (l, doc) - _ -> Nothing - --- | Extract constructor argument docs from inside constructor decls. -conArgDocs :: ConDecl GhcRn -> Map Int HsDocString -conArgDocs con = case getConArgs con of - PrefixCon args -> go 0 (map unLoc args ++ ret) - InfixCon arg1 arg2 -> go 0 ([unLoc arg1, unLoc arg2] ++ ret) - RecCon _ -> go 1 ret - where - go n (HsDocTy _ _ (L _ ds) : tys) = M.insert n ds $ go (n+1) tys - go n (HsBangTy _ _ (L _ (HsDocTy _ _ (L _ ds))) : tys) = M.insert n ds $ go (n+1) tys - go n (_ : tys) = go (n+1) tys - go _ [] = M.empty - - ret = case con of - ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ] - _ -> [] - --- | Extract function argument docs from inside top-level decls. -declTypeDocs :: HsDecl GhcRn -> Map Int HsDocString -declTypeDocs (SigD _ (TypeSig _ _ ty)) = typeDocs (unLoc (hsSigWcType ty)) -declTypeDocs (SigD _ (ClassOpSig _ _ _ ty)) = typeDocs (unLoc (hsSigType ty)) -declTypeDocs (SigD _ (PatSynSig _ _ ty)) = typeDocs (unLoc (hsSigType ty)) -declTypeDocs (ForD _ (ForeignImport _ _ ty _)) = typeDocs (unLoc (hsSigType ty)) -declTypeDocs (TyClD _ (SynDecl { tcdRhs = ty })) = typeDocs (unLoc ty) -declTypeDocs _ = M.empty - --- | Extract function argument docs from inside types. -typeDocs :: HsType GhcRn -> Map Int HsDocString -typeDocs = go 0 - where - go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty) - go n (HsQualTy { hst_body = ty }) = go n (unLoc ty) - go n (HsFunTy _ (L _ (HsDocTy _ _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty - go n (HsFunTy _ _ ty) = go (n+1) (unLoc ty) - go n (HsDocTy _ _ (L _ doc)) = M.singleton n doc - go _ _ = M.empty - --- | All the sub declarations of a class (that we handle), ordered by --- source location, with documentation attached if it exists. -classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])] -classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls - where - decls = docs ++ defs ++ sigs ++ ats - 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_ - - --- | The top-level declarations of a module that we care about, --- ordered by source location, with documentation attached if it exists. -topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])] -topDecls = - filterClasses . filterDecls . collectDocs . sortByLoc . ungroup -- | Extract a map of fixity declarations only mkFixMap :: HsGroup GhcRn -> FixMap -mkFixMap group_ = M.fromList [ (n,f) - | L _ (FixitySig _ ns f) <- hs_fixds group_, - L _ n <- ns ] - - --- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. -ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn] -ungroup group_ = - mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExtField) 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_ ++ - mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExtField) group_ ++ - mkDecls (typesigs . hs_valds) (SigD noExtField) group_ ++ - mkDecls (valbinds . hs_valds) (ValD noExtField) group_ - where - typesigs (XValBindsLR (NValBinds _ sigs)) = filter isUserLSig sigs - typesigs _ = error "expected ValBindsOut" - - valbinds (XValBindsLR (NValBinds binds _)) = concatMap bagToList . snd . unzip $ binds - valbinds _ = error "expected ValBindsOut" - - --- | Take a field of declarations from a data structure and create HsDecls --- using the given constructor -mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c] -mkDecls field con struct = [ L loc (con decl) | L loc decl <- field struct ] - - --- | Sort by source location -sortByLoc :: [Located a] -> [Located a] -sortByLoc = sortBy (comparing getLoc) - - --------------------------------------------------------------------------------- --- Filtering of declarations --- --- We filter out declarations that we don't intend to handle later. --------------------------------------------------------------------------------- - - --- | Filter out declarations that we don't handle in Haddock -filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] -filterDecls = filter (isHandled . unLoc . fst) - where - isHandled (ForD _ (ForeignImport {})) = True - isHandled (TyClD {}) = True - isHandled (InstD {}) = True - isHandled (DerivD {}) = True - isHandled (SigD _ d) = isUserLSig (noLoc d) - isHandled (ValD {}) = True - -- we keep doc declarations to be able to get at named docs - isHandled (DocD {}) = True - isHandled _ = False - --- | Go through all class declarations and filter their sub-declarations -filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] -filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x - | x@(L loc d, doc) <- decls ] - where - filterClass (TyClD x c) = - TyClD x $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c } - filterClass _ = error "expected TyClD" - - --------------------------------------------------------------------------------- --- Collect docs --- --- To be able to attach the right Haddock comment to the right declaration, --- we sort the declarations by their SrcLoc and "collect" the docs for each --- declaration. --------------------------------------------------------------------------------- - - --- | Collect docs and attach them to the right declarations. -collectDocs :: [LHsDecl a] -> [(LHsDecl a, [HsDocString])] -collectDocs = go Nothing [] - where - go Nothing _ [] = [] - go (Just prev) docs [] = finished prev docs [] - go prev docs (L _ (DocD _ (DocCommentNext str)) : ds) - | Nothing <- prev = go Nothing (str:docs) ds - | Just decl <- prev = finished decl docs (go Nothing [str] ds) - go prev docs (L _ (DocD _ (DocCommentPrev str)) : ds) = go prev (str:docs) ds - 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 +mkFixMap group_ = + M.fromList [ (n,f) + | L _ (FixitySig _ ns f) <- hsGroupTopLevelFixitySigs group_, + L _ n <- ns ] -- | Build the list of items that will become the documentation, from the @@ -874,11 +687,11 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames Nothing -> return ([], (noDocForDecl, availNoDocs avail)) -- TODO: If we try harder, we might be able to find -- a Haddock! Look in the Haddocks for each thing in - -- requirementContext (pkgState) + -- requirementContext (unitState) Just decl -> return ([decl], (noDocForDecl, availNoDocs avail)) | otherwise -> return ([], (noDocForDecl, availNoDocs avail)) - | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap + | Just iface <- M.lookup (semToIdMod (moduleUnit thisMod) m) modMap , Just ds <- M.lookup n (ifaceDeclMap iface) = return (ds, lookupDocs avail warnings (ifaceDocMap iface) @@ -924,10 +737,10 @@ availNoDocs avail = -- | Given a 'Module' from a 'Name', convert it into a 'Module' that -- we can actually find in the 'IfaceMap'. -semToIdMod :: UnitId -> Module -> Module +semToIdMod :: Unit -> Module -> Module semToIdMod this_uid m | Module.isHoleModule m = mkModule this_uid (moduleName m) - | otherwise = m + | otherwise = m -- | Reify a declaration from the GHC internal 'TyThing' representation. hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl GhcRn)) @@ -1006,8 +819,7 @@ moduleExport thisMod dflags ifaceMap instIfaceMap expMod = "documentation for exported module: " ++ pretty dflags expMod] return [] where - m = mkModule unitId expMod -- Identity module! - unitId = moduleUnitId thisMod + m = mkModule (moduleUnit thisMod) expMod -- Identity module! -- Note [1]: ------------ @@ -1180,9 +992,9 @@ extractPatternSyn nm t tvs cons = extract con = let args = case getConArgs con of - PrefixCon args' -> args' + PrefixCon args' -> (map hsScaledThing args') RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields - InfixCon arg1 arg2 -> [arg1, arg2] + InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2] typ = longArrow args (data_ty con) typ' = case con of @@ -1192,7 +1004,7 @@ extractPatternSyn nm t tvs cons = in PatSynSig noExtField [noLoc nm] (mkEmptyImplicitBndrs typ'') longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn - longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField x y)) output inputs + longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y)) output inputs data_ty con | ConDeclGADT{} <- con = con_res_ty con @@ -1209,7 +1021,7 @@ extractRecSel _ _ _ [] = Left "extractRecSel: selector not found" extractRecSel nm t tvs (L _ con : rest) = case getConArgs con of RecCon (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields -> - pure (L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField data_ty (getBangType ty)))))) + pure (L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty)))))) _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)] @@ -1242,7 +1054,7 @@ mkVisibleNames (_, _, _, instMap) exports opts where subs = map fst (expItemSubDocs e) patsyns = concatMap (getMainDeclBinder . fst) (expItemPats e) name = case unLoc $ expItemDecl e of - InstD _ d -> maybeToList $ M.lookup (getInstLoc d) instMap + InstD _ d -> maybeToList $ SrcLoc.lookupSrcSpan (getInstLoc d) instMap decl -> getMainDeclBinder decl exportName ExportNoDecl {} = [] -- we don't count these as visible, since -- we don't want links to go to them. diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs index 2cacabe1..4e271602 100644 --- a/haddock-api/src/Haddock/Interface/Json.hs +++ b/haddock-api/src/Haddock/Interface/Json.hs @@ -5,11 +5,11 @@ module Haddock.Interface.Json ( , renderJson ) where -import BasicTypes -import Json -import Module -import Name -import Outputable +import GHC.Types.Basic +import GHC.Utils.Json +import GHC.Unit.Module +import GHC.Types.Name +import GHC.Utils.Outputable import Control.Arrow import Data.Map (Map) diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 08a3c0f8..d1d6bb31 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -25,17 +25,17 @@ import Data.Functor (($>)) import Data.List (maximumBy, (\\)) import Data.Ord import Documentation.Haddock.Doc (metaDocConcat) -import DynFlags (languageExtensions) +import GHC.Driver.Session (languageExtensions) import qualified GHC.LanguageExtensions as LangExt import GHC import Haddock.Interface.ParseModuleHeader import Haddock.Parser import Haddock.Types -import Name -import Outputable ( showPpr, showSDoc ) -import RdrName -import RdrHsSyn (setRdrNameSpace) -import EnumSet +import GHC.Types.Name +import GHC.Parser.PostProcess +import GHC.Utils.Outputable ( showPpr, showSDoc ) +import GHC.Types.Name.Reader +import GHC.Data.EnumSet as EnumSet processDocStrings :: DynFlags -> Maybe Package -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (MDoc Name)) diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs index 37813d16..3e464fbc 100644 --- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs +++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE DeriveFunctor #-} {-# OPTIONS_GHC -Wwarn #-} +{-# LANGUAGE DeriveFunctor #-} + ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.ParseModuleHeader @@ -15,7 +16,7 @@ module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where import Control.Applicative (Alternative (..)) import Control.Monad (ap) import Data.Char -import DynFlags +import GHC.Driver.Session import Haddock.Parser import Haddock.Types diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 4d9eadac..bb9cd02d 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -20,11 +20,11 @@ import Data.Traversable (mapM) import Haddock.GhcUtils import Haddock.Types -import Bag (emptyBag) +import GHC.Data.Bag (emptyBag) import GHC hiding (NoLink) -import Name -import RdrName (RdrName(Exact)) -import TysWiredIn (eqTyCon_RDR) +import GHC.Types.Name +import GHC.Types.Name.Reader (RdrName(Exact)) +import GHC.Builtin.Types (eqTyCon_RDR) import Control.Applicative import Control.Arrow ( first ) @@ -33,6 +33,7 @@ import Data.List (intercalate) import qualified Data.Map as Map hiding ( Map ) import qualified Data.Set as Set import Prelude hiding (mapM) +import GHC.HsToCore.Docs -- | Traverse docstrings and ASTs in the Haddock interface, renaming 'Name' to -- 'DocName'. @@ -232,7 +233,6 @@ renameFamilyResultSig (L loc (KindSig _ ki)) renameFamilyResultSig (L loc (TyVarSig _ bndr)) = do { bndr' <- renameLTyVarBndr bndr ; return (L loc (TyVarSig noExtField bndr')) } -renameFamilyResultSig (L _ (XFamilyResultSig nec)) = noExtCon nec renameInjectivityAnn :: LInjectivityAnn GhcRn -> RnM (LInjectivityAnn DocNameI) renameInjectivityAnn (L loc (InjectivityAnn lhs rhs)) @@ -244,13 +244,18 @@ renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) -> RnM (Maybe (LInjectivityAnn DocNameI)) renameMaybeInjectivityAnn = traverse renameInjectivityAnn +renameArrow :: HsArrow GhcRn -> RnM (HsArrow DocNameI) +renameArrow (HsUnrestrictedArrow u) = return (HsUnrestrictedArrow u) +renameArrow (HsLinearArrow u) = return (HsLinearArrow u) +renameArrow (HsExplicitMult u p) = HsExplicitMult u <$> renameLType p + renameType :: HsType GhcRn -> RnM (HsType DocNameI) renameType t = case t of - HsForAllTy { hst_fvf = fvf, hst_bndrs = tyvars, hst_body = ltype } -> do - tyvars' <- mapM renameLTyVarBndr tyvars - ltype' <- renameLType ltype - return (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField - , hst_bndrs = tyvars', hst_body = ltype' }) + HsForAllTy { hst_tele = tele, hst_body = ltype } -> do + tele' <- renameHsForAllTelescope tele + ltype' <- renameLType ltype + return (HsForAllTy { hst_xforall = noExtField + , hst_tele = tele', hst_body = ltype' }) HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do lcontext' <- renameLContext lcontext @@ -272,10 +277,11 @@ renameType t = case t of b' <- renameLKind b return (HsAppKindTy noExtField a' b') - HsFunTy _ a b -> do + HsFunTy _ w a b -> do a' <- renameLType a b' <- renameLType b - return (HsFunTy noExtField a' b') + w' <- renameArrow w + return (HsFunTy noExtField w' a' b') HsListTy _ ty -> return . (HsListTy noExtField) =<< renameLType ty HsIParamTy _ n ty -> liftM (HsIParamTy noExtField n) (renameLType ty) @@ -326,17 +332,22 @@ renameLHsQTyVars (HsQTvs { hsq_explicit = tvs }) = do { tvs' <- mapM renameLTyVarBndr tvs ; return (HsQTvs { hsq_ext = noExtField , hsq_explicit = tvs' }) } -renameLHsQTyVars (XLHsQTyVars nec) = noExtCon nec -renameLTyVarBndr :: LHsTyVarBndr GhcRn -> RnM (LHsTyVarBndr DocNameI) -renameLTyVarBndr (L loc (UserTyVar x (L l n))) +renameHsForAllTelescope :: HsForAllTelescope GhcRn -> RnM (HsForAllTelescope DocNameI) +renameHsForAllTelescope tele = case tele of + HsForAllVis x bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs + pure $ HsForAllVis x bndrs' + HsForAllInvis x bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs + pure $ HsForAllInvis x bndrs' + +renameLTyVarBndr :: LHsTyVarBndr flag GhcRn -> RnM (LHsTyVarBndr flag DocNameI) +renameLTyVarBndr (L loc (UserTyVar x fl (L l n))) = do { n' <- rename n - ; return (L loc (UserTyVar x (L l n'))) } -renameLTyVarBndr (L loc (KindedTyVar x (L lv n) kind)) + ; return (L loc (UserTyVar x fl (L l n'))) } +renameLTyVarBndr (L loc (KindedTyVar x fl (L lv n) kind)) = do { n' <- rename n ; kind' <- renameLKind kind - ; return (L loc (KindedTyVar x (L lv n') kind')) } -renameLTyVarBndr (L _ (XTyVarBndr nec)) = noExtCon nec + ; return (L loc (KindedTyVar x fl (L lv n') kind')) } renameLContext :: Located [LHsType GhcRn] -> RnM (Located [LHsType DocNameI]) renameLContext (L loc context) = do @@ -427,7 +438,6 @@ renameTyClD d = case d of , tcdFixity = fixity , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdCExt = noExtField }) - XTyClDecl nec -> noExtCon nec where renameLFunDep (L loc (xs, ys)) = do @@ -453,7 +463,6 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname , fdFixity = fixity , fdResultSig = result' , fdInjectivityAnn = injectivity' }) -renameFamilyDecl (XFamilyDecl nec) = noExtCon nec renamePseudoFamilyDecl :: PseudoFamilyDecl GhcRn @@ -483,7 +492,6 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType , dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType , dd_kindSig = k', dd_cons = cons' , dd_derivs = noLoc [] }) -renameDataDefn (XHsDataDefn nec) = noExtCon nec renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI) renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars @@ -503,7 +511,7 @@ renameCon decl@(ConDeclGADT { con_names = lnames, con_qvars = ltyvars , con_res_ty = res_ty , con_doc = mbldoc }) = do lnames' <- mapM renameL lnames - ltyvars' <- renameLHsQTyVars ltyvars + ltyvars' <- mapM renameLTyVarBndr ltyvars lcontext' <- traverse renameLContext lcontext details' <- renameDetails details res_ty' <- renameLType res_ty @@ -511,16 +519,21 @@ renameCon decl@(ConDeclGADT { con_names = lnames, con_qvars = ltyvars return (decl { con_g_ext = noExtField, con_names = lnames', con_qvars = ltyvars' , con_mb_cxt = lcontext', con_args = details' , con_res_ty = res_ty', con_doc = mbldoc' }) -renameCon (XConDecl nec) = noExtCon nec + +renameHsScaled :: HsScaled GhcRn (LHsType GhcRn) + -> RnM (HsScaled DocNameI (LHsType DocNameI)) +renameHsScaled (HsScaled w ty) = HsScaled <$> renameArrow w <*> renameLType ty renameDetails :: HsConDeclDetails GhcRn -> RnM (HsConDeclDetails DocNameI) renameDetails (RecCon (L l fields)) = do fields' <- mapM renameConDeclFieldField fields return (RecCon (L l fields')) -renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps + -- This causes an assertion failure +--renameDetails (PrefixCon ps) = -- return . PrefixCon =<< mapM (_renameLType) ps +renameDetails (PrefixCon ps) = PrefixCon <$> mapM renameHsScaled ps renameDetails (InfixCon a b) = do - a' <- renameLType a - b' <- renameLType b + a' <- renameHsScaled a + b' <- renameHsScaled b return (InfixCon a' b') renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI) @@ -529,13 +542,11 @@ renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do t' <- renameLType t doc' <- mapM renameLDocHsSyn doc return $ L l (ConDeclField noExtField names' t' doc') -renameConDeclFieldField (L _ (XConDeclField nec)) = noExtCon nec renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI) renameLFieldOcc (L l (FieldOcc sel lbl)) = do sel' <- rename sel return $ L l (FieldOcc sel' lbl) -renameLFieldOcc (L _ (XFieldOcc nec)) = noExtCon nec renameSig :: Sig GhcRn -> RnM (Sig DocNameI) renameSig sig = case sig of @@ -570,7 +581,6 @@ renameForD (ForeignExport _ lname ltype x) = do lname' <- renameL lname ltype' <- renameLSigType ltype return (ForeignExport noExtField lname' ltype' x) -renameForD (XForeignDecl nec) = noExtCon nec renameInstD :: InstDecl GhcRn -> RnM (InstDecl DocNameI) @@ -583,7 +593,6 @@ renameInstD (TyFamInstD { tfid_inst = d }) = do renameInstD (DataFamInstD { dfid_inst = d }) = do d' <- renameDataFamInstD d return (DataFamInstD { dfid_ext = noExtField, dfid_inst = d' }) -renameInstD (XInstDecl nec) = noExtCon nec renameDerivD :: DerivDecl GhcRn -> RnM (DerivDecl DocNameI) renameDerivD (DerivDecl { deriv_type = ty @@ -595,7 +604,6 @@ renameDerivD (DerivDecl { deriv_type = ty , deriv_type = ty' , deriv_strategy = strat' , deriv_overlap_mode = omode }) -renameDerivD (XDerivDecl nec) = noExtCon nec renameDerivStrategy :: DerivStrategy GhcRn -> RnM (DerivStrategy DocNameI) renameDerivStrategy StockStrategy = pure StockStrategy @@ -614,7 +622,6 @@ renameClsInstD (ClsInstDecl { cid_overlap_mode = omode , cid_poly_ty = ltype', cid_binds = emptyBag , cid_sigs = [] , cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' }) -renameClsInstD (XClsInstDecl nec) = noExtCon nec renameTyFamInstD :: TyFamInstDecl GhcRn -> RnM (TyFamInstDecl DocNameI) @@ -642,7 +649,6 @@ renameTyFamInstEqn eqn , feqn_pats = pats' , feqn_fixity = fixity , feqn_rhs = rhs' }) } - rename_ty_fam_eqn (XFamEqn nec) = noExtCon nec renameTyFamDefltD :: TyFamDefltDecl GhcRn -> RnM (TyFamDefltDecl DocNameI) renameTyFamDefltD = renameTyFamInstD @@ -668,7 +674,6 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn }) , feqn_pats = pats' , feqn_fixity = fixity , feqn_rhs = defn' }) } - rename_data_fam_eqn (XFamEqn nec) = noExtCon nec renameImplicit :: (in_thing -> RnM out_thing) -> HsImplicitBndrs GhcRn in_thing @@ -677,7 +682,6 @@ renameImplicit rn_thing (HsIB { hsib_body = thing }) = do { thing' <- rn_thing thing ; return (HsIB { hsib_body = thing' , hsib_ext = noExtField }) } -renameImplicit _ (XHsImplicitBndrs nec) = noExtCon nec renameWc :: (in_thing -> RnM out_thing) -> HsWildCardBndrs GhcRn in_thing @@ -686,7 +690,6 @@ renameWc rn_thing (HsWC { hswc_body = thing }) = do { thing' <- rn_thing thing ; return (HsWC { hswc_body = thing' , hswc_ext = noExtField }) } -renameWc _ (XHsWildCardBndrs nec) = noExtCon nec renameDocInstance :: DocInstance GhcRn -> RnM (DocInstance DocNameI) renameDocInstance (inst, idoc, L l n, m) = do diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 6e11a859..a084af90 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -15,10 +15,10 @@ import Haddock.Syb import Haddock.Types import GHC -import Name -import FastString -import TysPrim ( funTyConName ) -import TysWiredIn ( listTyConName ) +import GHC.Types.Name +import GHC.Data.FastString +import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName ) +import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import Control.Monad import Control.Monad.Trans.State @@ -134,7 +134,7 @@ sugarTuples typ = sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb) | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb - | funTyConName == name' = HsFunTy noExtField la lb + | unrestrictedFunTyConName == name' = HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) la lb where name' = getName name sugarOperators typ = typ @@ -204,12 +204,16 @@ freeVariables = everythingWithState Set.empty Set.union query where query term ctx = case cast term :: Maybe (HsType GhcRn) of - Just (HsForAllTy _ _ bndrs _) -> - (Set.empty, Set.union ctx (bndrsNames bndrs)) + Just (HsForAllTy _ tele _) -> + (Set.empty, Set.union ctx (teleNames tele)) Just (HsTyVar _ _ (L _ name)) | getName name `Set.member` ctx -> (Set.empty, ctx) | otherwise -> (Set.singleton $ getName name, ctx) _ -> (Set.empty, ctx) + + teleNames (HsForAllVis _ bndrs) = bndrsNames bndrs + teleNames (HsForAllInvis _ bndrs) = bndrsNames bndrs + bndrsNames = Set.fromList . map (getName . hsTyVarBndrName . unLoc) @@ -242,9 +246,9 @@ data RenameEnv name = RenameEnv renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn) -renameType (HsForAllTy x fvf bndrs lt) = - HsForAllTy x fvf - <$> mapM (located renameBinder) bndrs +renameType (HsForAllTy x tele lt) = + HsForAllTy x + <$> renameForAllTelescope tele <*> renameLType lt renameType (HsQualTy x lctxt lt) = HsQualTy x @@ -254,7 +258,7 @@ renameType (HsTyVar x ip name) = HsTyVar x ip <$> located renameName name renameType t@(HsStarTy _ _) = pure t renameType (HsAppTy x lf la) = HsAppTy x <$> renameLType lf <*> renameLType la renameType (HsAppKindTy x lt lk) = HsAppKindTy x <$> renameLType lt <*> renameLKind lk -renameType (HsFunTy x la lr) = HsFunTy x <$> renameLType la <*> renameLType lr +renameType (HsFunTy x w la lr) = HsFunTy x <$> renameHsArrow w <*> renameLType la <*> renameLType lr renameType (HsListTy x lt) = HsListTy x <$> renameLType lt renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt renameType (HsSumTy x lt) = HsSumTy x <$> mapM renameLType lt @@ -275,6 +279,10 @@ renameType (HsExplicitTupleTy x ltys) = renameType t@(HsTyLit _ _) = pure t renameType (HsWildCardTy wc) = pure (HsWildCardTy wc) +renameHsArrow :: HsArrow GhcRn -> Rename (IdP GhcRn) (HsArrow GhcRn) +renameHsArrow (HsExplicitMult u p) = HsExplicitMult u <$> renameLType p +renameHsArrow mult = pure mult + renameLType :: LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn) renameLType = located renameType @@ -289,14 +297,23 @@ renameLTypes = mapM renameLType renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn) renameContext = renameLTypes -renameBinder :: HsTyVarBndr GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr GhcRn) -renameBinder (UserTyVar x lname) = UserTyVar x <$> located renameName lname -renameBinder (KindedTyVar x lname lkind) = - KindedTyVar x <$> located renameName lname <*> located renameType lkind -renameBinder (XTyVarBndr nec) = noExtCon nec +renameForAllTelescope :: HsForAllTelescope GhcRn + -> Rename (IdP GhcRn) (HsForAllTelescope GhcRn) +renameForAllTelescope (HsForAllVis x bndrs) = + HsForAllVis x <$> mapM renameLBinder bndrs +renameForAllTelescope (HsForAllInvis x bndrs) = + HsForAllInvis x <$> mapM renameLBinder bndrs + +renameBinder :: HsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr flag GhcRn) +renameBinder (UserTyVar x fl lname) = UserTyVar x fl <$> located renameName lname +renameBinder (KindedTyVar x fl lname lkind) = + KindedTyVar x fl <$> located renameName lname <*> located renameType lkind + +renameLBinder :: LHsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (LHsTyVarBndr flag GhcRn) +renameLBinder = located renameBinder -- | Core renaming logic. -renameName :: SetName name => name -> Rename name name +renameName :: (Eq name, SetName name) => name -> Rename name name renameName name = do RenameEnv { .. } <- get case Map.lookup (getName name) rneCtx of @@ -345,5 +362,3 @@ alternativeNames name = located :: Functor f => (a -> f b) -> Located a -> f (Located b) located f (L loc e) = L loc <$> f e - - |