diff options
| author | Ben Gamari <ben@smart-cactus.org> | 2021-01-05 16:23:02 -0500 | 
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2021-01-05 16:23:02 -0500 | 
| commit | 99f61534a470b84c424fde0835215de6a3b6d721 (patch) | |
| tree | 7152e5a53fe1c18e6fd5044d5aa3168ab99c3cc6 /haddock-api/src/Haddock/Interface | |
| parent | 3e29ec51498dfe092b228889343dc8370ec0e64b (diff) | |
| parent | 1e56f63c3197e7ca1c1e506e083c2bad25d08793 (diff) | |
Merge commit '1e56f63c3197e7ca1c1e506e083c2bad25d08793' into ghc-9.0
Diffstat (limited to 'haddock-api/src/Haddock/Interface')
| -rw-r--r-- | haddock-api/src/Haddock/Interface/AttachInstances.hs | 5 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 180 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Json.hs | 166 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/LexParseRn.hs | 103 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/ParseModuleHeader.hs | 229 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Rename.hs | 38 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Specialize.hs | 19 | 
7 files changed, 516 insertions, 224 deletions
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 0840bd77..6ef0ed19 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -1,5 +1,7 @@  {-# LANGUAGE MagicHash, BangPatterns #-}  {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  -----------------------------------------------------------------------------  -- |  -- Module      :  Haddock.Interface.AttachInstances @@ -17,11 +19,10 @@ module Haddock.Interface.AttachInstances (attachInstances) where  import Haddock.Types  import Haddock.Convert -import Haddock.GhcUtils  import Control.Applicative ((<|>))  import Control.Arrow hiding ((<+>)) -import Data.List +import Data.List (sortBy)  import Data.Ord (comparing)  import Data.Maybe ( maybeToList, mapMaybe, fromMaybe )  import qualified Data.Map as Map diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index dd9419eb..7fb71d4b 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -31,12 +31,13 @@ import Haddock.Interface.LexParseRn  import Data.Bifunctor  import Data.Bitraversable  import qualified Data.Map as M +import qualified Data.Set as S  import Data.Map (Map) -import Data.List +import Data.List (find, foldl')  import Data.Maybe -import Control.Applicative  import Control.Monad  import Data.Traversable +import GHC.Stack (HasCallStack)  import GHC.Types.Avail hiding (avail)  import qualified GHC.Types.Avail  as Avail @@ -49,7 +50,6 @@ import GHC.Types.Name  import GHC.Types.Name.Set  import GHC.Types.Name.Env  import GHC.Unit.State -import GHC.Data.Bag  import GHC.Types.Name.Reader  import GHC.Tc.Types  import GHC.Data.FastString ( unpackFS, bytesFS ) @@ -58,16 +58,21 @@ import qualified GHC.Utils.Outputable as O  import GHC.HsToCore.Docs hiding (mkMaps)  import GHC.Parser.Annotation (IsUnicodeSyntax(..)) +mkExceptionContext :: TypecheckedModule -> String +mkExceptionContext = +  ("creating Haddock interface for " ++) . moduleNameString . ms_mod_name . pm_mod_summary . tm_parsed_module  -- | Use a 'TypecheckedModule' to produce an 'Interface'.  -- To do this, we need access to already processed modules in the topological  -- sort. That's what's in the 'IfaceMap'. -createInterface :: TypecheckedModule +createInterface :: HasCallStack +                => TypecheckedModule                  -> [Flag]       -- Boolean flags                  -> IfaceMap     -- Locally processed modules                  -> InstIfaceMap -- External, already installed interfaces                  -> ErrMsgGhc Interface -createInterface tm flags modMap instIfaceMap = do +createInterface tm flags modMap instIfaceMap = + withExceptionContext (mkExceptionContext tm) $ do    let ms             = pm_mod_summary . tm_parsed_module $ tm        mi             = moduleInfo tm @@ -85,8 +90,9 @@ createInterface tm flags modMap instIfaceMap = do        (TcGblEnv { tcg_rdr_env = gre                  , tcg_warns   = warnings -                , tcg_exports = all_exports +                , tcg_exports = all_exports0                  }, md) = tm_internals_ tm +      all_local_avails = gresToAvailInfo . filter isLocalGRE . globalRdrEnvElts $ gre    -- The 'pkgName' is necessary to decide what package to mention in "@since"    -- annotations. Not having it is not fatal though. @@ -113,9 +119,9 @@ createInterface tm flags modMap instIfaceMap = do    let declsWithDocs = topDecls group_        exports0 = fmap (map (first unLoc)) mayExports -      exports -        | OptIgnoreExports `elem` opts = Nothing -        | otherwise = exports0 +      (all_exports, exports) +        | OptIgnoreExports `elem` opts = (all_local_avails, Nothing) +        | otherwise = (all_exports0, exports0)        unrestrictedImportedMods          -- module re-exports are only possible with @@ -127,8 +133,8 @@ createInterface tm flags modMap instIfaceMap = do        fixMap = mkFixMap group_        (decls, _) = unzip declsWithDocs        localInsts = filter (nameIsLocalOrFrom sem_mdl) -                        $  map getName instances -                        ++ map getName fam_instances +                        $  map getName fam_instances +                        ++ map getName instances        -- Locations of all TH splices        splices = [ l | L l (SpliceD _ _) <- hsmodDecls hsm ] @@ -165,6 +171,18 @@ createInterface tm flags modMap instIfaceMap = do    modWarn <- liftErrMsg (moduleWarning dflags gre warnings) +  -- Prune the docstring 'Map's to keep only docstrings that are not private. +  -- +  -- Besides all the names that GHC has told us this module exports, we also +  -- keep the docs for locally defined class instances. This is more names than +  -- we need, but figuring out which instances are fully private is tricky. +  -- +  -- We do this pruning to avoid having to rename, emit warnings, and save +  -- docstrings which will anyways never be rendered. +  let !localVisibleNames = S.fromList (localInsts ++ exportedNames) +      !prunedDocMap = M.restrictKeys docMap localVisibleNames +      !prunedArgMap = M.restrictKeys argMap localVisibleNames +    return $! Interface {      ifaceMod               = mdl    , ifaceIsSig             = is_sig @@ -173,12 +191,12 @@ createInterface tm flags modMap instIfaceMap = do    , ifaceDoc               = Documentation mbDoc modWarn    , ifaceRnDoc             = Documentation Nothing Nothing    , ifaceOptions           = opts -  , ifaceDocMap            = docMap -  , ifaceArgMap            = argMap -  , ifaceRnDocMap          = M.empty -  , ifaceRnArgMap          = M.empty +  , ifaceDocMap            = prunedDocMap +  , ifaceArgMap            = prunedArgMap +  , ifaceRnDocMap          = M.empty -- Filled in `renameInterface` +  , ifaceRnArgMap          = M.empty -- Filled in `renameInterface`    , ifaceExportItems       = prunedExportItems -  , ifaceRnExportItems     = [] +  , ifaceRnExportItems     = [] -- Filled in `renameInterface`    , ifaceExports           = exportedNames    , ifaceVisibleExports    = visibleNames    , ifaceDeclMap           = declMap @@ -452,7 +470,8 @@ mkFixMap group_ =  -- We create the export items even if the module is hidden, since they  -- might be useful when creating the export items for other modules.  mkExportItems -  :: Bool               -- is it a signature +  :: HasCallStack +  => Bool               -- is it a signature    -> IfaceMap    -> Maybe Package      -- this package    -> Module             -- this module @@ -490,7 +509,7 @@ mkExportItems        return [ExportDoc doc]      lookupExport (IEDocNamed _ str, _)      = liftErrMsg $ -      findNamedDoc str [ unL d | d <- decls ] >>= \case +      findNamedDoc str [ unLoc d | d <- decls ] >>= \case          Nothing -> return  []          Just docStr -> do            doc <- processDocStringParas dflags pkgName gre docStr @@ -511,7 +530,8 @@ mkExportItems        availExportItem is_sig modMap thisMod semMod warnings exportedNames          maps fixMap splices instIfaceMap dflags avail -availExportItem :: Bool               -- is it a signature +availExportItem :: HasCallStack +                => Bool               -- is it a signature                  -> IfaceMap                  -> Module             -- this module                  -> Module             -- semantic module @@ -538,13 +558,13 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames            export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap            return [export]          (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds -> -          let declNames = getMainDeclBinder (unL decl) +          let declNames = getMainDeclBinder (unLoc decl)            in case () of              _                -- We should not show a subordinate by itself if any of its                -- parents is also exported. See note [1].                | t `notElem` declNames, -                Just p <- find isExported (parents t $ unL decl) -> +                Just p <- find isExported (parents t $ unLoc decl) ->                  do liftErrMsg $ tell [                       "Warning: " ++ moduleString thisMod ++ ": " ++                       pretty dflags (nameOccName t) ++ " is exported separately but " ++ @@ -593,11 +613,24 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames          _ -> return [] -    availExportDecl :: AvailInfo -> LHsDecl GhcRn +    -- Tries 'extractDecl' first then falls back to 'hiDecl' if that fails +    availDecl :: Name -> LHsDecl GhcRn -> ErrMsgGhc (LHsDecl GhcRn) +    availDecl declName parentDecl = +      case extractDecl declMap declName parentDecl of +        Right d -> pure d +        Left err -> do +          synifiedDeclOpt <- hiDecl dflags declName +          case synifiedDeclOpt of +            Just synifiedDecl -> pure synifiedDecl +            Nothing -> O.pprPanic "availExportItem" (O.text err) + +    availExportDecl :: HasCallStack => AvailInfo -> LHsDecl GhcRn                      -> (DocForDecl Name, [(Name, DocForDecl Name)])                      -> ErrMsgGhc [ ExportItem GhcRn ]      availExportDecl avail decl (doc, subs)        | availExportsDecl avail = do +          extractedDecl <- availDecl (availName avail) decl +            -- bundled pattern synonyms only make sense if the declaration is            -- exported (otherwise there would be nothing to bundle to)            bundledPatSyns <- findBundledPatterns avail @@ -613,8 +646,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames                  ]            return [ ExportDecl { -                       expItemDecl      = restrictTo (fmap fst subs) -                                            (extractDecl declMap (availName avail) decl) +                       expItemDecl      = restrictTo (fmap fst subs) extractedDecl                       , expItemPats      = bundledPatSyns                       , expItemMbDoc     = doc                       , expItemSubDocs   = subs @@ -624,18 +656,18 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames                       }                   ] -      | otherwise = -          return [ ExportDecl { -                       expItemDecl      = extractDecl declMap sub decl +      | otherwise = for subs $ \(sub, sub_doc) -> do +          extractedDecl <- availDecl sub decl + +          return ( ExportDecl { +                       expItemDecl      = extractedDecl                       , expItemPats      = []                       , expItemMbDoc     = sub_doc                       , expItemSubDocs   = []                       , expItemInstances = []                       , expItemFixities  = [ (sub, f) | Just f <- [M.lookup sub fixMap] ]                       , expItemSpliced   = False -                     } -                 | (sub, sub_doc) <- subs -                 ] +                     } )      exportedNameSet = mkNameSet exportedNames      isExported n = elemNameSet n exportedNameSet @@ -710,6 +742,7 @@ semToIdMod this_uid m      | Module.isHoleModule m = mkModule this_uid (moduleName m)      | otherwise             = m +-- | Reify a declaration from the GHC internal 'TyThing' representation.  hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl GhcRn))  hiDecl dflags t = do    mayTyThing <- liftGhcToErrMsgGhc $ lookupName t @@ -852,20 +885,31 @@ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNam      isSigD (L _ SigD{}) = True      isSigD _            = False +  -- | Sometimes the declaration we want to export is not the "main" declaration:  -- it might be an individual record selector or a class method.  In these  -- cases we have to extract the required declaration (and somehow cobble  -- together a type signature for it...). -extractDecl :: DeclMap -> Name -> LHsDecl GhcRn -> LHsDecl GhcRn +-- +-- This function looks through the declarations in this module to try to find +-- the one with the right name. +extractDecl +  :: HasCallStack +  => DeclMap                   -- ^ all declarations in the file +  -> Name                      -- ^ name of the declaration to extract +  -> LHsDecl GhcRn             -- ^ parent declaration +  -> Either ErrMsg (LHsDecl GhcRn)  extractDecl declMap name decl -  | name `elem` getMainDeclBinder (unLoc decl) = decl +  | name `elem` getMainDeclBinder (unLoc decl) = pure decl    | otherwise  =      case unLoc decl of -      TyClD _ d@ClassDecl {} -> +      TyClD _ d@ClassDecl { tcdLName = L _ clsNm +                          , tcdSigs = clsSigs +                          , tcdATs = clsATs } ->          let            matchesMethod =              [ lsig -            | lsig <- tcdSigs d +            | lsig <- clsSigs              , ClassOpSig _ False _ _ <- pure $ unLoc lsig                -- Note: exclude `default` declarations (see #505)              , name `elem` sigName lsig @@ -873,51 +917,54 @@ extractDecl declMap name decl            matchesAssociatedType =              [ lfam_decl -            | lfam_decl <- tcdATs d +            | lfam_decl <- clsATs              , name == unLoc (fdLName (unLoc lfam_decl))              ]              -- TODO: document fixity          in case (matchesMethod, matchesAssociatedType)  of -          ([s0], _) -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d) -                           L pos sig = addClassContext n tyvar_names s0 -                       in L pos (SigD noExtField sig) -          (_, [L pos fam_decl]) -> L pos (TyClD noExtField (FamDecl noExtField fam_decl)) +          ([s0], _) -> let tyvar_names = tyClDeclTyVars d +                           L pos sig = addClassContext clsNm tyvar_names s0 +                       in pure (L pos (SigD noExtField sig)) +          (_, [L pos fam_decl]) -> pure (L pos (TyClD noExtField (FamDecl noExtField fam_decl)))            ([], [])              | Just (famInstDecl:_) <- M.lookup name declMap              -> extractDecl declMap name famInstDecl -          _ -> O.pprPanic "extractDecl" (O.text "Ambiguous decl for" O.<+> O.ppr name O.<+> O.text "in class:" -                                         O.$$ O.nest 4 (O.ppr d) -                                         O.$$ O.text "Matches:" -                                         O.$$ O.nest 4 (O.ppr matchesMethod O.<+> O.ppr matchesAssociatedType)) -      TyClD _ d@DataDecl {} -> -        let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d)) -        in if isDataConName name -           then SigD noExtField <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d)) -           else SigD noExtField <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d)) +          _ -> Left (concat [ "Ambiguous decl for ", getOccString name +                            , " in class ", getOccString clsNm ]) + +      TyClD _ d@DataDecl { tcdLName = L _ dataNm +                         , tcdDataDefn = HsDataDefn { dd_cons = dataCons } } -> do +        let ty_args = map HsValArg (lHsQTyVarsToTypes (tyClDeclTyVars d)) +        lsig <- if isDataConName name +                  then extractPatternSyn name dataNm ty_args dataCons +                  else extractRecSel name dataNm ty_args dataCons +        pure (SigD noExtField <$> lsig) +        TyClD _ FamDecl {}          | isValName name          , Just (famInst:_) <- M.lookup name declMap          -> extractDecl declMap name famInst        InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = -                             FamEqn { feqn_tycon = L _ n -                                    , feqn_pats  = tys -                                    , feqn_rhs   = defn }}))) -> -        if isDataConName name -        then SigD noExtField <$> extractPatternSyn name n tys (dd_cons defn) -        else SigD noExtField <$> extractRecSel name n tys (dd_cons defn) +          FamEqn { feqn_tycon = L _ famName +                 , feqn_pats  = ty_args +                 , feqn_rhs   = HsDataDefn { dd_cons = dataCons } }}))) -> do +        lsig <- if isDataConName name +                  then extractPatternSyn name famName ty_args dataCons +                  else extractRecSel name famName ty_args dataCons +        pure (SigD noExtField <$> lsig)        InstD _ (ClsInstD _ ClsInstDecl { cid_datafam_insts = insts })          | isDataConName name ->              let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = -                                          FamEqn { feqn_rhs   = dd +                                          FamEqn { feqn_rhs   = HsDataDefn { dd_cons = dataCons }                                                   }                                           })) <- insts -                               , name `elem` map unLoc (concatMap (getConNames . unLoc) (dd_cons dd)) +                               , name `elem` map unLoc (concatMap (getConNames . unLoc) dataCons)                                 ]              in case matches of                  [d0] -> extractDecl declMap name (noLoc (InstD noExtField (DataFamInstD noExtField d0))) -                _    -> error "internal: extractDecl (ClsInstD)" +                _    -> Left "internal: extractDecl (ClsInstD)"          | otherwise ->              let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d }))                                     <- insts @@ -929,16 +976,15 @@ extractDecl declMap name decl                            ]              in case matches of                [d0] -> extractDecl declMap name (noLoc . InstD noExtField $ DataFamInstD noExtField d0) -              _ -> error "internal: extractDecl (ClsInstD)" -      _ -> O.pprPanic "extractDecl" $ -        O.text "Unhandled decl for" O.<+> O.ppr name O.<> O.text ":" -        O.$$ O.nest 4 (O.ppr decl) +              _ -> Left "internal: extractDecl (ClsInstD)" +      _ -> Left ("extractDecl: Unhandled decl for " ++ getOccString name) -extractPatternSyn :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn +extractPatternSyn :: HasCallStack => Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> Either ErrMsg (LSig GhcRn)  extractPatternSyn nm t tvs cons =    case filter matches cons of -    [] -> error "extractPatternSyn: constructor pattern not found" -    con:_ -> extract <$> con +    [] -> Left . O.showSDocUnsafe $ +          O.text "constructor pattern " O.<+> O.ppr nm O.<+> O.text "not found in type" O.<+> O.ppr t +    con:_ -> pure (extract <$> con)   where    matches :: LConDecl GhcRn -> Bool    matches (L _ con) = nm `elem` (unLoc <$> getConNames con) @@ -969,13 +1015,13 @@ extractPatternSyn nm t tvs cons =                            mkAppTyArg f (HsArgPar _) = HsParTy noExtField f  extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -              -> LSig GhcRn -extractRecSel _ _ _ [] = error "extractRecSel: selector not found" +              -> Either ErrMsg (LSig GhcRn) +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 -> -      L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) 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)] diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs index 043a1530..4e271602 100644 --- a/haddock-api/src/Haddock/Interface/Json.hs +++ b/haddock-api/src/Haddock/Interface/Json.hs @@ -13,7 +13,6 @@ import GHC.Utils.Outputable  import Control.Arrow  import Data.Map (Map) -import Data.Bifunctor  import qualified Data.Map as Map  import Haddock.Types @@ -58,11 +57,172 @@ jsonMap f g = jsonObject . map (f *** g) . Map.toList  jsonMDoc :: MDoc Name -> JsonDoc  jsonMDoc MetaDoc{..} =    jsonObject [ ("meta", jsonObject [("version", jsonMaybe (jsonString . show) (_version _meta))]) -             , ("doc",  jsonDoc _doc) +             , ("document",  jsonDoc _doc)               ] +showModName :: Wrap (ModuleName, OccName) -> String +showModName = showWrapped (moduleNameString . fst) + +showName :: Wrap Name -> String +showName = showWrapped nameStableString + +  jsonDoc :: Doc Name -> JsonDoc -jsonDoc doc = jsonString (show (bimap (moduleNameString . fst) nameStableString doc)) + +jsonDoc DocEmpty = jsonObject +    [ ("tag", jsonString "DocEmpty") ] + +jsonDoc (DocAppend x y) = jsonObject +    [ ("tag", jsonString "DocAppend") +    , ("first", jsonDoc x) +    , ("second", jsonDoc y) +    ] + +jsonDoc (DocString s) = jsonObject +    [ ("tag", jsonString "DocString") +    , ("string", jsonString s) +    ] + +jsonDoc (DocParagraph x) = jsonObject +    [ ("tag", jsonString "DocParagraph") +    , ("document", jsonDoc x) +    ] + +jsonDoc (DocIdentifier name) = jsonObject +    [ ("tag", jsonString "DocIdentifier") +    , ("name", jsonString (showName name)) +    ] + +jsonDoc (DocIdentifierUnchecked modName) = jsonObject +    [ ("tag", jsonString "DocIdentifierUnchecked") +    , ("modName", jsonString (showModName modName)) +    ] + +jsonDoc (DocModule s) = jsonObject +    [ ("tag", jsonString "DocModule") +    , ("string", jsonString s) +    ] + +jsonDoc (DocWarning x) = jsonObject +    [ ("tag", jsonString "DocWarning") +    , ("document", jsonDoc x) +    ] + +jsonDoc (DocEmphasis x) = jsonObject +    [ ("tag", jsonString "DocEmphasis") +    , ("document", jsonDoc x) +    ] + +jsonDoc (DocMonospaced x) = jsonObject +    [ ("tag", jsonString "DocMonospaced") +    , ("document", jsonDoc x) +    ] + +jsonDoc (DocBold x) = jsonObject +    [ ("tag", jsonString "DocBold") +    , ("document", jsonDoc x) +    ] + +jsonDoc (DocUnorderedList xs) = jsonObject +    [ ("tag", jsonString "DocUnorderedList") +    , ("documents", jsonArray (fmap jsonDoc xs)) +    ] + +jsonDoc (DocOrderedList xs) = jsonObject +    [ ("tag", jsonString "DocOrderedList") +    , ("documents", jsonArray (fmap jsonDoc xs)) +    ] + +jsonDoc (DocDefList xys) = jsonObject +    [ ("tag", jsonString "DocDefList") +    , ("definitions", jsonArray (fmap jsonDef xys)) +    ] +  where +    jsonDef (x, y) = jsonObject [("document", jsonDoc x), ("y", jsonDoc y)] + +jsonDoc (DocCodeBlock x) = jsonObject +    [ ("tag", jsonString "DocCodeBlock") +    , ("document", jsonDoc x) +    ] + +jsonDoc (DocHyperlink hyperlink) = jsonObject +    [ ("tag", jsonString "DocHyperlink") +    , ("hyperlink", jsonHyperlink hyperlink) +    ] +  where +    jsonHyperlink Hyperlink{..} = jsonObject +        [ ("hyperlinkUrl", jsonString hyperlinkUrl) +        , ("hyperlinkLabel", jsonMaybe jsonDoc hyperlinkLabel) +        ] + +jsonDoc (DocPic picture) = jsonObject +    [ ("tag", jsonString "DocPic") +    , ("picture", jsonPicture picture) +    ] +  where +    jsonPicture Picture{..} = jsonObject +        [ ("pictureUrl", jsonString pictureUri) +        , ("pictureLabel", jsonMaybe jsonString pictureTitle) +        ] + +jsonDoc (DocMathInline s) = jsonObject +    [ ("tag", jsonString "DocMathInline") +    , ("string", jsonString s) +    ] + +jsonDoc (DocMathDisplay s) = jsonObject +    [ ("tag", jsonString "DocMathDisplay") +    , ("string", jsonString s) +    ] + +jsonDoc (DocAName s) = jsonObject +    [ ("tag", jsonString "DocAName") +    , ("string", jsonString s) +    ] + +jsonDoc (DocProperty s) = jsonObject +    [ ("tag", jsonString "DocProperty") +    , ("string", jsonString s) +    ] + +jsonDoc (DocExamples examples) = jsonObject +    [ ("tag", jsonString "DocExamples") +    , ("examples", jsonArray (fmap jsonExample examples)) +    ] +  where +    jsonExample Example{..} = jsonObject +        [ ("exampleExpression", jsonString exampleExpression) +        , ("exampleResult", jsonArray (fmap jsonString exampleResult)) +        ] + +jsonDoc (DocHeader header) = jsonObject +    [ ("tag", jsonString "DocHeader") +    , ("header", jsonHeader header) +    ] +  where +    jsonHeader Header{..} = jsonObject +        [ ("headerLevel", jsonInt headerLevel) +        , ("headerTitle", jsonDoc headerTitle) +        ] + +jsonDoc (DocTable table) = jsonObject +    [ ("tag", jsonString "DocTable") +    , ("table", jsonTable table) +    ] +  where +    jsonTable Table{..} = jsonObject +        [ ("tableHeaderRows", jsonArray (fmap jsonTableRow tableHeaderRows)) +        , ("tableBodyRows", jsonArray (fmap jsonTableRow tableBodyRows)) +        ] + +    jsonTableRow TableRow{..} = jsonArray (fmap jsonTableCell tableRowCells) + +    jsonTableCell TableCell{..} = jsonObject +        [ ("tableCellColspan", jsonInt tableCellColspan) +        , ("tableCellRowspan", jsonInt tableCellRowspan) +        , ("tableCellContents", jsonDoc tableCellContents) +        ] +  jsonModule :: Module -> JsonDoc  jsonModule = JSString . moduleStableString diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 2b03ecfa..d1d6bb31 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -19,10 +19,10 @@ module Haddock.Interface.LexParseRn    , processModuleHeader    ) where -import GHC.Types.Avail  import Control.Arrow  import Control.Monad -import Data.List +import Data.Functor (($>)) +import Data.List (maximumBy, (\\))  import Data.Ord  import Documentation.Haddock.Doc (metaDocConcat)  import GHC.Driver.Session (languageExtensions) @@ -32,10 +32,10 @@ import Haddock.Interface.ParseModuleHeader  import Haddock.Parser  import Haddock.Types  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 -import GHC.Rename.Env (dataTcOccs)  processDocStrings :: DynFlags -> Maybe Package -> GlobalRdrEnv -> [HsDocString]                    -> ErrMsgM (Maybe (MDoc Name)) @@ -89,24 +89,38 @@ processModuleHeader dflags pkgName gre safety mayStr = do  -- fallbacks in case we can't locate the identifiers.  --  -- See the comments in the source for implementation commentary. -rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> ErrMsgM (Doc Name) +rename :: DynFlags -> GlobalRdrEnv -> Doc NsRdrName -> ErrMsgM (Doc Name)  rename dflags gre = rn    where      rn d = case d of        DocAppend a b -> DocAppend <$> rn a <*> rn b        DocParagraph doc -> DocParagraph <$> rn doc -      DocIdentifier x -> do +      DocIdentifier i -> do +        let NsRdrName ns x = unwrap i +            occ = rdrNameOcc x +            isValueName = isDataOcc occ || isVarOcc occ + +        let valueNsChoices | isValueName = [x] +                           | otherwise   = [] -- is this ever possible? +            typeNsChoices  | isValueName = [setRdrNameSpace x tcName] +                           | otherwise   = [x] +          -- Generate the choices for the possible kind of thing this -        -- is. -        let choices = dataTcOccs x +        -- is. We narrow down the possibilities with the namespace (if +        -- there is one). +        let choices = case ns of +                        Value -> valueNsChoices +                        Type  -> typeNsChoices +                        None  -> valueNsChoices ++ typeNsChoices          -- Lookup any GlobalRdrElts that match the choices.          case concatMap (\c -> lookupGRE_RdrName c gre) choices of            -- We found no names in the env so we start guessing.            [] ->              case choices of -              -- This shouldn't happen as 'dataTcOccs' always returns at least its input. -              [] -> pure (DocMonospaced (DocString (showPpr dflags x))) +              -- The only way this can happen is if a value namespace was +              -- specified on something that cannot be a value. +              [] -> invalidValue dflags i                -- There was nothing in the environment so we need to                -- pick some default from what's available to us. We @@ -116,14 +130,14 @@ rename dflags gre = rn                -- type constructor names (such as in #253). So now we                -- only get type constructor links if they are actually                -- in scope. -              a:_ -> outOfScope dflags a +              a:_ -> outOfScope dflags ns (i $> a)            -- There is only one name in the environment that matches so            -- use it. -          [a] -> pure (DocIdentifier (gre_name a)) +          [a] -> pure (DocIdentifier (i $> gre_name a))            -- There are multiple names available. -          gres -> ambiguous dflags x gres +          gres -> ambiguous dflags i gres        DocWarning doc -> DocWarning <$> rn doc        DocEmphasis doc -> DocEmphasis <$> rn doc @@ -155,19 +169,25 @@ rename dflags gre = rn  -- users shouldn't rely on this doing the right thing. See tickets  -- #253 and #375 on the confusion this causes depending on which  -- default we pick in 'rename'. -outOfScope :: DynFlags -> RdrName -> ErrMsgM (Doc a) -outOfScope dflags x = -  case x of -    Unqual occ -> warnAndMonospace occ -    Qual mdl occ -> pure (DocIdentifierUnchecked (mdl, occ)) -    Orig _ occ -> warnAndMonospace occ -    Exact name -> warnAndMonospace name  -- Shouldn't happen since x is out of scope +outOfScope :: DynFlags -> Namespace -> Wrap RdrName -> ErrMsgM (Doc a) +outOfScope dflags ns x = +  case unwrap x of +    Unqual occ -> warnAndMonospace (x $> occ) +    Qual mdl occ -> pure (DocIdentifierUnchecked (x $> (mdl, occ))) +    Orig _ occ -> warnAndMonospace (x $> occ) +    Exact name -> warnAndMonospace (x $> name)  -- Shouldn't happen since x is out of scope    where +    prefix = case ns of +               Value -> "the value " +               Type -> "the type " +               None -> "" +      warnAndMonospace a = do -      tell ["Warning: '" ++ showPpr dflags a ++ "' is out of scope.\n" ++ +      let a' = showWrapped (showPpr dflags) a +      tell ["Warning: " ++ prefix ++ "'" ++ a' ++ "' is out of scope.\n" ++              "    If you qualify the identifier, haddock can try to link it anyway."] -      pure (monospaced a) -    monospaced a = DocMonospaced (DocString (showPpr dflags a)) +      pure (monospaced a') +    monospaced = DocMonospaced . DocString  -- | Handle ambiguous identifiers.  -- @@ -175,26 +195,39 @@ outOfScope dflags x =  --  -- Emits a warning if the 'GlobalRdrElts's don't belong to the same type or class.  ambiguous :: DynFlags -          -> RdrName +          -> Wrap NsRdrName            -> [GlobalRdrElt] -- ^ More than one @gre@s sharing the same `RdrName` above.            -> ErrMsgM (Doc Name)  ambiguous dflags x gres = do -  let noChildren = map availName (gresToAvailInfo gres) -      dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren -      msg = "Warning: " ++ x_str ++ " is ambiguous. It is defined\n" ++ -            concatMap (\n -> "    * " ++ defnLoc n ++ "\n") (map gre_name gres) ++ +  let dflt = maximumBy (comparing (gre_lcl &&& isTyConName . gre_name)) gres +      msg = "Warning: " ++ showNsRdrName dflags x ++ " is ambiguous. It is defined\n" ++ +            concatMap (\n -> "    * " ++ defnLoc n ++ "\n") gres ++              "    You may be able to disambiguate the identifier by qualifying it or\n" ++ -            "    by hiding some imports.\n" ++ -            "    Defaulting to " ++ x_str ++ " defined " ++ defnLoc dflt +            "    by specifying the type/value namespace explicitly.\n" ++ +            "    Defaulting to the one defined " ++ defnLoc dflt    -- TODO: Once we have a syntax for namespace qualification (#667) we may also    -- want to emit a warning when an identifier is a data constructor for a type    -- of the same name, but not the only constructor.    -- For example, for @data D = C | D@, someone may want to reference the @D@    -- constructor. -  when (length noChildren > 1) $ tell [msg] -  pure (DocIdentifier dflt) +  when (length (gresToAvailInfo gres) > 1) $ tell [msg] +  pure (DocIdentifier (x $> gre_name dflt)) +  where +    defnLoc = showSDoc dflags . pprNameDefnLoc . gre_name + +-- | Handle value-namespaced names that cannot be for values. +-- +-- Emits a warning that the value-namespace is invalid on a non-value identifier. +invalidValue :: DynFlags -> Wrap NsRdrName -> ErrMsgM (Doc a) +invalidValue dflags x = do +  tell ["Warning: " ++ showNsRdrName dflags x ++ " cannot be value, yet it is\n" ++ +            "    namespaced as such. Did you mean to specify a type namespace\n" ++ +            "    instead?"] +  pure (DocMonospaced (DocString (showNsRdrName dflags x))) + +-- | Printable representation of a wrapped and namespaced name +showNsRdrName :: DynFlags -> Wrap NsRdrName -> String +showNsRdrName dflags = (\p i -> p ++ "'" ++ i ++ "'") <$> prefix <*> ident    where -    isLocalName (nameSrcLoc -> RealSrcLoc {}) = True -    isLocalName _ = False -    x_str = '\'' : showPpr dflags x ++ "'" -    defnLoc = showSDoc dflags . pprNameDefnLoc +    ident = showWrapped (showPpr dflags . rdrName) +    prefix = renderNs . namespace . unwrap diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs index 611d8b6f..3e464fbc 100644 --- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs +++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs @@ -1,4 +1,6 @@  {-# OPTIONS_GHC -Wwarn #-} +{-# LANGUAGE DeriveFunctor #-} +  -----------------------------------------------------------------------------  -- |  -- Module      :  Haddock.Interface.ParseModuleHeader @@ -11,12 +13,12 @@  -----------------------------------------------------------------------------  module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where -import Control.Monad (mplus) +import Control.Applicative (Alternative (..)) +import Control.Monad (ap)  import Data.Char  import GHC.Driver.Session  import Haddock.Parser  import Haddock.Types -import GHC.Types.Name.Reader  -- -----------------------------------------------------------------------------  -- Parsing module headers @@ -24,37 +26,47 @@ import GHC.Types.Name.Reader  -- NB.  The headers must be given in the order Module, Description,  -- Copyright, License, Maintainer, Stability, Portability, except that  -- any or all may be omitted. -parseModuleHeader :: DynFlags -> Maybe Package -> String -> (HaddockModInfo RdrName, MDoc RdrName) +parseModuleHeader :: DynFlags -> Maybe Package -> String -> (HaddockModInfo NsRdrName, MDoc NsRdrName)  parseModuleHeader dflags pkgName str0 =     let -      getKey :: String -> String -> (Maybe String,String) -      getKey key str = case parseKey key str of -         Nothing -> (Nothing,str) -         Just (value,rest) -> (Just value,rest) - -      (_moduleOpt,str1) = getKey "Module" str0 -      (descriptionOpt,str2) = getKey "Description" str1 -      (copyrightOpt,str3) = getKey "Copyright" str2 -      (licenseOpt,str4) = getKey "License" str3 -      (licenceOpt,str5) = getKey "Licence" str4 -      (spdxLicenceOpt,str6) = getKey "SPDX-License-Identifier" str5 -      (maintainerOpt,str7) = getKey "Maintainer" str6 -      (stabilityOpt,str8) = getKey "Stability" str7 -      (portabilityOpt,str9) = getKey "Portability" str8 +      kvs :: [(String, String)] +      str1 :: String + +      (kvs, str1) = maybe ([], str0) id $ runP fields str0 + +      -- trim whitespaces +      trim :: String -> String +      trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse + +      getKey :: String -> Maybe String +      getKey key = fmap trim (lookup key kvs) + +      descriptionOpt = getKey "Description" +      copyrightOpt   = getKey "Copyright" +      licenseOpt     = getKey "License" +      licenceOpt     = getKey "Licence" +      spdxLicenceOpt = getKey "SPDX-License-Identifier" +      maintainerOpt  = getKey "Maintainer" +      stabilityOpt   = getKey "Stability" +      portabilityOpt = getKey "Portability"     in (HaddockModInfo {            hmi_description = parseString dflags <$> descriptionOpt,            hmi_copyright = copyrightOpt, -          hmi_license = spdxLicenceOpt `mplus` licenseOpt `mplus` licenceOpt, +          hmi_license = spdxLicenceOpt <|> licenseOpt <|> licenceOpt,            hmi_maintainer = maintainerOpt,            hmi_stability = stabilityOpt,            hmi_portability = portabilityOpt,            hmi_safety = Nothing,            hmi_language = Nothing, -- set in LexParseRn            hmi_extensions = [] -- also set in LexParseRn -          }, parseParas dflags pkgName str9) +          }, parseParas dflags pkgName str1) + +------------------------------------------------------------------------------- +-- Small parser to parse module header. +------------------------------------------------------------------------------- --- | This function is how we read keys. +-- | The below is a small parser framework how we read keys.  --  -- all fields in the header are optional and have the form  -- @@ -73,78 +85,105 @@ parseModuleHeader dflags pkgName str0 =  --  -- the value will be "this is a .. description" and the rest will begin  -- at "The module comment". -parseKey :: String -> String -> Maybe (String,String) -parseKey key toParse0 = -   do -      let -         (spaces0,toParse1) = extractLeadingSpaces (dropWhile (`elem` ['\r', '\n']) toParse0) - -         indentation = spaces0 -      afterKey0 <- extractPrefix key toParse1 -      let -         afterKey1 = extractLeadingSpaces afterKey0 -      afterColon0 <- case snd afterKey1 of -         ':':afterColon -> return afterColon -         _ -> Nothing -      let -         (_,afterColon1) = extractLeadingSpaces afterColon0 - -      return (scanKey True indentation afterColon1) -   where -      scanKey :: Bool -> String -> String -> (String,String) -      scanKey _       _           [] = ([],[]) -      scanKey isFirst indentation str = -         let -            (nextLine,rest1) = extractNextLine str - -            accept = isFirst || sufficientIndentation || allSpaces - -            sufficientIndentation = case extractPrefix indentation nextLine of -               Just (c:_) | isSpace c -> True -               _ -> False - -            allSpaces = case extractLeadingSpaces nextLine of -               (_,[]) -> True -               _ -> False -         in -            if accept -               then -                  let -                     (scanned1,rest2) = scanKey False indentation rest1 - -                     scanned2 = case scanned1 of -                        "" -> if allSpaces then "" else nextLine -                        _ -> nextLine ++ "\n" ++ scanned1 -                  in -                     (scanned2,rest2) -               else -                  ([],str) - -      extractLeadingSpaces :: String -> (String,String) -      extractLeadingSpaces [] = ([],[]) -      extractLeadingSpaces (s@(c:cs)) -         | isSpace c = -            let -               (spaces1,cs1) = extractLeadingSpaces cs -            in -               (c:spaces1,cs1) -         | otherwise = ([],s) - -      extractNextLine :: String -> (String,String) -      extractNextLine [] = ([],[]) -      extractNextLine (c:cs) -         | c == '\n' = -            ([],cs) -         | otherwise = -            let -               (line,rest) = extractNextLine cs -            in -               (c:line,rest) - -      -- comparison is case-insensitive. -      extractPrefix :: String -> String -> Maybe String -      extractPrefix [] s = Just s -      extractPrefix _ [] = Nothing -      extractPrefix (c1:cs1) (c2:cs2) -         | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2 -         | otherwise = Nothing + +-- | 'C' is a 'Char' carrying its column. +-- +-- This let us make an indentation-aware parser, as we know current indentation. +-- by looking at the next character in the stream ('curInd'). +-- +-- Thus we can munch all spaces but only not-spaces which are indented. +-- +data C = C {-# UNPACK #-} !Int Char + +newtype P a = P { unP :: [C] -> Maybe ([C], a) } +  deriving Functor + +instance Applicative P where +    pure x = P $ \s -> Just (s, x) +    (<*>)  = ap + +instance Monad P where +    return = pure +    m >>= k = P $ \s0 -> do +        (s1, x) <- unP m s0 +        unP (k x) s1 + +instance Alternative P where +    empty   = P $ \_ -> Nothing +    a <|> b = P $ \s -> unP a s <|> unP b s + +runP :: P a -> String -> Maybe a +runP p input = fmap snd (unP p input') +  where +    input' = concat +        [ zipWith C [0..] l ++ [C (length l) '\n'] +        | l <- lines input +        ] + +------------------------------------------------------------------------------- +-- +------------------------------------------------------------------------------- + +curInd :: P Int +curInd = P $ \s -> Just . (,) s $ case s of +    []        -> 0 +    C i _ : _ -> i + +rest :: P String +rest = P $ \cs -> Just ([], [ c | C _ c <- cs ]) + +munch :: (Int -> Char -> Bool) -> P String +munch p = P $ \cs -> +    let (xs,ys) = takeWhileMaybe p' cs in Just (ys, xs) +  where +    p' (C i c) +        | p i c  = Just c +        | otherwise = Nothing + +munch1 :: (Int -> Char -> Bool) -> P String +munch1 p = P $ \s -> case s of +    [] -> Nothing +    (c:cs) | Just c' <- p' c -> let (xs,ys) = takeWhileMaybe p' cs in Just (ys, c' : xs) +           | otherwise -> Nothing +  where +    p' (C i c) +        | p i c  = Just c +        | otherwise = Nothing + +char :: Char -> P Char +char c = P $ \s -> case s of +    []                        -> Nothing +    (C _ c' : cs) | c == c'   -> Just (cs, c) +                  | otherwise -> Nothing + +skipSpaces :: P () +skipSpaces = P $ \cs -> Just (dropWhile (\(C _ c) -> isSpace c) cs, ()) + +takeWhileMaybe :: (a -> Maybe b) -> [a] -> ([b], [a]) +takeWhileMaybe f = go where +    go xs0@[] = ([], xs0) +    go xs0@(x:xs) = case f x of +        Just y  -> let (ys, zs) = go xs in (y : ys, zs) +        Nothing -> ([], xs0) + +------------------------------------------------------------------------------- +-- Fields +------------------------------------------------------------------------------- + +field :: Int -> P (String, String) +field i = do +    fn <- munch1 $ \_ c -> isAlpha c || c == '-' +    skipSpaces +    _ <- char ':' +    skipSpaces +    val <- munch $ \j c -> isSpace c || j > i +    return (fn, val) + +fields :: P ([(String, String)], String) +fields = do +    skipSpaces +    i  <- curInd +    fs <- many (field i) +    r  <- rest +    return (fs, r) + diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 061ef8eb..bb9cd02d 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -1,5 +1,6 @@  {-# LANGUAGE RecordWildCards #-}  {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}  ----------------------------------------------------------------------------  -- |  -- Module      :  Haddock.Interface.Rename @@ -28,13 +29,22 @@ import GHC.Builtin.Types (eqTyCon_RDR)  import Control.Applicative  import Control.Arrow ( first )  import Control.Monad hiding (mapM) -import Data.List +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 -renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface -renameInterface dflags renamingEnv warnings iface = +-- | Traverse docstrings and ASTs in the Haddock interface, renaming 'Name' to +-- 'DocName'. +-- +-- What this really boils down to is: for each 'Name', figure out which of the +-- modules that export the name is the preferred place to link to. +-- +-- The renamed output gets written into fields in the Haddock interface record +-- that were previously left empty. +renameInterface :: DynFlags -> [String] -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface +renameInterface _dflags ignoredSymbols renamingEnv warnings iface =    -- first create the local env, where every name exported by this module    -- is mapped to itself, and everything else comes from the global renaming @@ -69,8 +79,15 @@ renameInterface dflags renamingEnv warnings iface =        -- Note that since the renamed AST represents equality constraints as        -- @HasOpTy t1 eqTyCon_RDR t2@ (and _not_ as @HsEqTy t1 t2@), we need to        -- manually filter out 'eqTyCon_RDR' (aka @~@). -      strings = [ pretty dflags n + +      qualifiedName n = (moduleNameString $ moduleName $ nameModule n) <> "." <> getOccString n + +      ignoreSet = Set.fromList ignoredSymbols + +      strings = [ qualifiedName n +                  | n <- missingNames +                , not (qualifiedName n `Set.member` ignoreSet)                  , not (isSystemName n)                  , not (isBuiltInSyntax n)                  , Exact n /= eqTyCon_RDR @@ -82,7 +99,7 @@ renameInterface dflags renamingEnv warnings iface =      unless (OptHide `elem` ifaceOptions iface || null strings || not warnings) $        tell ["Warning: " ++ moduleString (ifaceMod iface) ++              ": could not find link destinations for:\n"++ -            unwords ("   " : strings) ] +            intercalate "\n\t- "  ("" : strings) ]      return $ iface { ifaceRnDoc         = finalModuleDoc,                       ifaceRnDocMap      = rnDocMap, @@ -130,6 +147,11 @@ lookupRn name = RnM $ \lkp ->      (False,maps_to) -> (maps_to, (name :))      (True, maps_to) -> (maps_to, id) +-- | Look up a 'Name' in the renaming environment, but don't warn if you don't +-- find the name. Prefer to use 'lookupRn' whenever possible. +lookupRnNoWarn :: Name -> RnM DocName +lookupRnNoWarn name = RnM $ \lkp -> (snd (lkp name), id) +  -- | Run the renamer action using lookup in a 'LinkEnv' as the lookup function.  -- Returns the renamed value along with a list of `Name`'s that could not be  -- renamed because they weren't in the environment. @@ -173,8 +195,8 @@ renameLDocHsSyn :: LHsDocString -> RnM LHsDocString  renameLDocHsSyn = return -renameDoc :: Traversable t => t Name -> RnM (t DocName) -renameDoc = traverse rename +renameDoc :: Traversable t => t (Wrap Name) -> RnM (t (Wrap DocName)) +renameDoc = traverse (traverse rename)  renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName)  renameFnArgsDoc = mapM renameDoc @@ -544,7 +566,7 @@ renameSig sig = case sig of      lnames' <- mapM renameL lnames      return $ FixSig noExtField (FixitySig noExtField lnames' fixity)    MinimalSig _ src (L l s) -> do -    s' <- traverse renameL s +    s' <- traverse (traverse lookupRnNoWarn) s      return $ MinimalSig noExtField src (L l s')    -- we have filtered out all other kinds of signatures in Interface.Create    _ -> error "expected TypeSig" diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 0e9fc851..a084af90 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -3,19 +3,20 @@  {-# LANGUAGE ScopedTypeVariables #-}  {-# LANGUAGE TypeApplications #-}  {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}  module Haddock.Interface.Specialize      ( specializeInstHead      ) where +import Haddock.GhcUtils ( hsTyVarBndrName )  import Haddock.Syb  import Haddock.Types  import GHC  import GHC.Types.Name  import GHC.Data.FastString -import GHC.Builtin.Types.Prim ( funTyConName )  import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName )  import GHC.Parser.Annotation (IsUnicodeSyntax(..)) @@ -57,13 +58,9 @@ specialize specs = go spec_map0  -- Again, it is just a convenience function around 'specialize'. Note that  -- length of type list should be the same as the number of binders.  specializeTyVarBndrs :: LHsQTyVars GhcRn -> [HsType GhcRn] -> HsType GhcRn -> HsType GhcRn -specializeTyVarBndrs bndrs typs = -    specialize $ zip bndrs' typs +specializeTyVarBndrs bndrs typs = specialize $ zip bndrs' typs    where -    bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs -    bname (UserTyVar _ _ (L _ name)) = name -    bname (KindedTyVar _ _ (L _ name) _) = name -    bname (XTyVarBndr _) = error "haddock:specializeTyVarBndrs" +    bndrs' = map (hsTyVarBndrName . unLoc) . hsq_explicit $ bndrs @@ -217,7 +214,7 @@ freeVariables =      teleNames (HsForAllVis   _ bndrs) = bndrsNames bndrs      teleNames (HsForAllInvis _ bndrs) = bndrsNames bndrs -    bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) +    bndrsNames = Set.fromList . map (getName . hsTyVarBndrName . unLoc)  -- | Make given type visually unambiguous. @@ -365,9 +362,3 @@ alternativeNames name =  located :: Functor f => (a -> f b) -> Located a -> f (Located b)  located f (L loc e) = L loc <$> f e - - -tyVarName :: HsTyVarBndr flag name -> IdP name -tyVarName (UserTyVar _ _ name) = unLoc name -tyVarName (KindedTyVar _ _ (L _ name) _) = name -tyVarName (XTyVarBndr _ ) = error "haddock:tyVarName"  | 
