From 56dbfe17d272670e5f2d082401c025755796950d Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Wed, 20 Apr 2016 12:42:28 +0100 Subject: Track change to HsGroup This relates to a big GHC patch for Trac #11348 --- haddock-api/src/Haddock/Interface/Create.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/Create.hs') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 6466acfb..e3ae1175 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -395,12 +395,12 @@ mkFixMap group_ = M.fromList [ (n,f) -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. ungroup :: HsGroup Name -> [LHsDecl Name] ungroup group_ = - mkDecls (tyClGroupConcat . hs_tyclds) TyClD group_ ++ + mkDecls (tyClGroupTyClDecls . hs_tyclds) TyClD group_ ++ mkDecls hs_derivds DerivD group_ ++ mkDecls hs_defds DefD group_ ++ mkDecls hs_fords ForD group_ ++ mkDecls hs_docs DocD group_ ++ - mkDecls hs_instds InstD group_ ++ + mkDecls (tyClGroupInstDecls . hs_tyclds) InstD group_ ++ mkDecls (typesigs . hs_valds) SigD group_ ++ mkDecls (valbinds . hs_valds) ValD group_ where -- cgit v1.2.3 From 30f20af8c948f2c59799a16293c7c62508a7987b Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Wed, 4 May 2016 22:15:50 -0400 Subject: Render Haddocks for derived instances Currently, one can document top-level instance declarations, but derived instances (both those in `deriving` clauses and standalone `deriving` instances) do not enjoy the same privilege. This makes the necessary changes to the Haddock API to enable rendering Haddock comments for derived instances. This is part of a fix for Trac #11768. --- haddock-api/src/Haddock/Backends/LaTeX.hs | 1 + haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 1 + haddock-api/src/Haddock/Interface/Create.hs | 33 +++++++++++++++++--------- haddock-api/src/Haddock/Interface/Rename.hs | 10 ++++++++ 4 files changed, 34 insertions(+), 11 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/Create.hs') diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 81a23a1b..85716f33 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -300,6 +300,7 @@ ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of ppLPatSig loc (doc, fnArgsDoc) lname ty unicode ForD d -> ppFor loc (doc, fnArgsDoc) d unicode InstD _ -> empty + DerivD _ -> empty _ -> error "declaration not supported by ppDecl" where unicode = False diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index fab6bf8d..2bd8c4ad 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -54,6 +54,7 @@ ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs spl ty fixities splice unicode qual ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual InstD _ -> noHtml + DerivD _ -> noHtml _ -> error "declaration not supported by ppDecl" diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index e3ae1175..00cec0cf 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -306,16 +306,16 @@ mkMaps dflags gre instances decls = where loc = case d of TyFamInstD _ -> l -- The CoAx's loc is the whole line, but only for TFs _ -> getInstLoc d + names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2]. names _ decl = getMainDeclBinder decl -- Note [2]: ------------ --- We relate ClsInsts to InstDecls using the SrcSpans buried inside them. --- That should work for normal user-written instances (from looking at GHC --- sources). We can assume that commented instances are user-written. --- This lets us relate Names (from ClsInsts) to comments (associated --- with InstDecls). - +-- We relate ClsInsts to InstDecls and DerivDecls using the SrcSpans buried +-- inside them. That should work for normal user-written instances (from +-- looking at GHC sources). We can assume that commented instances are +-- user-written. This lets us relate Names (from ClsInsts) to comments +-- (associated with InstDecls and DerivDecls). -------------------------------------------------------------------------------- -- Declarations @@ -339,7 +339,7 @@ subordinates instMap decl = case decl of , name <- getMainDeclBinder d, not (isValD d) ] dataSubs :: HsDataDefn Name -> [(Name, [HsDocString], Map Int HsDocString)] - dataSubs dd = constrs ++ fields + dataSubs dd = constrs ++ fields ++ derivs where cons = map unL $ (dd_cons dd) constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty) @@ -348,6 +348,10 @@ subordinates instMap decl = case decl of | RecCon flds <- map getConDetails cons , L _ (ConDeclField ns _ doc) <- (unLoc flds) , L _ n <- ns ] + derivs = [ (instName, [unL doc], M.empty) + | Just (L _ tys) <- [dd_derivs dd] + , HsIB { hsib_body = L l (HsDocTy _ doc) } <- tys + , Just instName <- [M.lookup l instMap] ] -- | Extract function argument docs from inside types. typeDocs :: HsDecl Name -> Map Int HsDocString @@ -434,8 +438,9 @@ filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] filterDecls = filter (isHandled . unL . fst) where isHandled (ForD (ForeignImport {})) = True - isHandled (TyClD {}) = True - isHandled (InstD {}) = True + isHandled (TyClD {}) = True + isHandled (InstD {}) = True + isHandled (DerivD {}) = True isHandled (SigD d) = isUserLSig (reL d) isHandled (ValD _) = True -- we keep doc declarations to be able to get at named docs @@ -757,8 +762,10 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap | otherwise = return Nothing mkExportItem decl@(L l (InstD d)) | Just name <- M.lookup (getInstLoc d) instMap = - let (doc, subs) = lookupDocs name warnings docMap argMap subMap in - return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices)) + expInst decl l name + mkExportItem decl@(L l (DerivD {})) + | Just name <- M.lookup l instMap = + expInst decl l name mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do mdef <- liftGhcToErrMsgGhc $ minimalDef name let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . noLoc . fmap noLoc) mdef @@ -773,6 +780,10 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap expDecl decl l name = return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices)) where (doc, subs) = lookupDocs name warnings docMap argMap subMap + expInst decl l name = + let (doc, subs) = lookupDocs name warnings docMap argMap subMap in + return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices)) + -- | 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 diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 3054e2f9..1f3f2aab 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -328,6 +328,9 @@ renameDecl decl = case decl of InstD d -> do d' <- renameInstD d return (InstD d') + DerivD d -> do + d' <- renameDerivD d + return (DerivD d') _ -> error "renameDecl" renameLThing :: (a Name -> RnM (a DocName)) -> Located (a Name) -> RnM (Located (a DocName)) @@ -503,6 +506,13 @@ renameInstD (DataFamInstD { dfid_inst = d }) = do d' <- renameDataFamInstD d return (DataFamInstD { dfid_inst = d' }) +renameDerivD :: DerivDecl Name -> RnM (DerivDecl DocName) +renameDerivD (DerivDecl { deriv_type = ty + , deriv_overlap_mode = omode }) = do + ty' <- renameLSigType ty + return (DerivDecl { deriv_type = ty' + , deriv_overlap_mode = omode }) + renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName) renameClsInstD (ClsInstDecl { cid_overlap_mode = omode , cid_poly_ty =ltype, cid_tyfam_insts = lATs -- cgit v1.2.3 From d73b286cb39ad9d02bee4b1a104e817783ceb195 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Sun, 29 May 2016 23:30:27 -0400 Subject: Haddock changes for T10598 See https://ghc.haskell.org/trac/ghc/ticket/10598 --- haddock-api/src/Haddock/Backends/Hoogle.hs | 2 +- haddock-api/src/Haddock/Convert.hs | 4 ++-- haddock-api/src/Haddock/Interface/Create.hs | 5 +++-- haddock-api/src/Haddock/Interface/Rename.hs | 5 ++++- 4 files changed, 10 insertions(+), 6 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/Create.hs') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 1c3dea7c..48b97445 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -204,7 +204,7 @@ ppSynonym dflags x = [out dflags x] ppData :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs - = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=Nothing }} : + = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=noLoc [] }} : concatMap (ppCtor dflags decl subdocs . unL) (dd_cons defn) where diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 41e98c6f..4e2ee05c 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -153,7 +153,7 @@ synifyTyCon _coax tc , dd_kindSig = Just (synifyKindSig (tyConKind tc)) -- we have their kind accurately: , dd_cons = [] -- No constructors - , dd_derivs = Nothing } + , dd_derivs = noLoc [] } , tcdDataCusk = False , tcdFVs = placeHolderNamesTc } @@ -224,7 +224,7 @@ synifyTyCon coax tc consRaw = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc) cons = rights consRaw -- "deriving" doesn't affect the signature, no need to specify any. - alg_deriv = Nothing + alg_deriv = noLoc [] defn = HsDataDefn { dd_ND = alg_nd , dd_ctxt = alg_ctx , dd_cType = Nothing diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 2c8b0b7e..2cdc6f8b 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -349,8 +349,9 @@ subordinates instMap decl = case decl of , L _ (ConDeclField ns _ doc) <- (unLoc flds) , L _ n <- ns ] derivs = [ (instName, [unL doc], M.empty) - | Just (L _ tys) <- [dd_derivs dd] - , HsIB { hsib_body = L l (HsDocTy _ doc) } <- tys + | HsIB { hsib_body = L l (HsDocTy _ doc) } + <- concatMap (unLoc . deriv_clause_tys . unLoc) $ + unLoc $ dd_derivs dd , Just instName <- [M.lookup l instMap] ] -- | Extract function argument docs from inside types. diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index cf3b72ac..fa85ba64 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -416,7 +416,8 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType cons' <- mapM (mapM renameCon) cons -- I don't think we need the derivings, so we return Nothing return (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType - , dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing }) + , dd_kindSig = k', dd_cons = cons' + , dd_derivs = noLoc [] }) renameCon :: ConDecl Name -> RnM (ConDecl DocName) renameCon decl@(ConDeclH98 { con_name = lname, con_qvars = ltyvars @@ -509,9 +510,11 @@ renameInstD (DataFamInstD { dfid_inst = d }) = do renameDerivD :: DerivDecl Name -> RnM (DerivDecl DocName) renameDerivD (DerivDecl { deriv_type = ty + , deriv_strategy = strat , deriv_overlap_mode = omode }) = do ty' <- renameLSigType ty return (DerivDecl { deriv_type = ty' + , deriv_strategy = strat , deriv_overlap_mode = omode }) renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName) -- cgit v1.2.3 From 1dcefaddc52d968b20bb6107d620e1e0c6839970 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Thu, 3 Nov 2016 14:08:10 +0200 Subject: Match changes in GHC wip/T3384 branch --- haddock-api/src/Haddock/Backends/Hoogle.hs | 8 ++++---- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 2 +- haddock-api/src/Haddock/Backends/LaTeX.hs | 6 ++++-- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 7 ++++--- haddock-api/src/Haddock/Convert.hs | 16 ++++++++-------- haddock-api/src/Haddock/Interface/Create.hs | 10 +++++----- haddock-api/src/Haddock/Interface/Rename.hs | 4 ++-- haddock-api/src/Haddock/Interface/Specialize.hs | 16 ++++++++-------- haddock-api/src/Haddock/Types.hs | 6 +++--- haddock-api/src/Haddock/Utils.hs | 2 +- 10 files changed, 40 insertions(+), 37 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/Create.hs') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 48b97445..40106491 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -16,7 +16,7 @@ module Haddock.Backends.Hoogle ( ppHoogle ) where -import BasicTypes (OverlapFlag(..), OverlapMode(..)) +import BasicTypes (OverlapFlag(..), OverlapMode(..), SourceText(..)) import InstEnv (ClsInst(..)) import Haddock.GhcUtils import Haddock.Types hiding (Version) @@ -85,7 +85,7 @@ dropHsDocTy = f f (HsDocTy a _) = f $ unL a f x = x -outHsType :: (OutputableBndr a, OutputableBndr (NameOrRdrName a)) +outHsType :: (OutputableBndrId a, HasOccNameId a) => DynFlags -> HsType a -> String outHsType dflags = out dflags . dropHsDocTy @@ -196,7 +196,7 @@ ppInstance dflags x = -- safety information to a state where the Outputable instance -- produces no output which means no overlap and unsafe (or [safe] -- is generated). - cls = x { is_flag = OverlapFlag { overlapMode = NoOverlap mempty + cls = x { is_flag = OverlapFlag { overlapMode = NoOverlap NoSourceText , isSafeOverlap = False } } ppSynonym :: DynFlags -> TyClDecl Name -> [String] @@ -244,7 +244,7 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} -- docs for con_names on why it is a list to begin with. name = commaSeparate dflags . map unL $ getConNames con - resType = apps $ map (reL . HsTyVar . reL) $ + resType = apps $ map (reL . HsTyVar NotPromoted . reL) $ (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvExplicit $ tyClDeclTyVars dat] ppCtor dflags _dat subdocs con@ConDeclGADT {} diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index be17cb8b..1d9fbe20 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -72,7 +72,7 @@ types = everything (<|>) ty where ty term = case cast term of - (Just (GHC.L sspan (GHC.HsTyVar name))) -> + (Just (GHC.L sspan (GHC.HsTyVar _ name))) -> pure (sspan, RtkType (GHC.unLoc name)) _ -> empty diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index ffb4d782..36a859e6 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -949,7 +949,8 @@ ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode , ppr_mono_lty pREC_TOP ty unicode ] ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty -ppr_mono_ty _ (HsTyVar (L _ name)) _ = ppDocName name +ppr_mono_ty _ (HsTyVar NotPromoted (L _ name)) _ = ppDocName name +ppr_mono_ty _ (HsTyVar Promoted (L _ name)) _ = char '\'' <> ppDocName name ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys) ppr_mono_ty _ (HsSumTy tys) u = sumParens (map (ppLType u) tys) @@ -960,7 +961,8 @@ ppr_mono_ty _ (HsIParamTy n ty) u = brackets (ppIPName n <+> dcolon u ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy" ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy" -ppr_mono_ty _ (HsExplicitListTy _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys +ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys +ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys ppr_mono_ty _ (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index c6f1100b..499d9e11 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -984,12 +984,12 @@ ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual ppLContext ctxt unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual -- UnicodeSyntax alternatives -ppr_mono_ty _ (HsTyVar (L _ name)) True _ +ppr_mono_ty _ (HsTyVar _ (L _ name)) True _ | getOccString (getName name) == "*" = toHtml "★" | getOccString (getName name) == "(->)" = toHtml "(→)" ppr_mono_ty _ (HsBangTy b ty) u q = ppBang b +++ ppLParendType u q ty -ppr_mono_ty _ (HsTyVar (L _ name)) _ q = ppDocName q Prefix True name +ppr_mono_ty _ (HsTyVar _ (L _ name)) _ q = ppDocName q Prefix True name ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys) ppr_mono_ty _ (HsSumTy tys) u q = sumParens (map (ppLType u q) tys) @@ -1005,7 +1005,8 @@ ppr_mono_ty _ (HsRecTy {}) _ _ = toHtml "{..}" -- placeholder in the signature, which is followed by the field -- declarations. ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy" -ppr_mono_ty _ (HsExplicitListTy _ tys) u q = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys +ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u q = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys +ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u q = brackets $ hsep $ punctuate comma $ map (ppLType u q) tys ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = promoQuote $ parenList $ map (ppLType u q) tys ppr_mono_ty _ (HsAppsTy {}) _ _ = error "ppr_mono_ty HsAppsTy" diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 4e2ee05c..a99c5886 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -17,7 +17,7 @@ module Haddock.Convert where -- instance heads, which aren't TyThings, so just export everything. import Bag ( emptyBag ) -import BasicTypes ( TupleSort(..) ) +import BasicTypes ( TupleSort(..), SourceText(..) ) import Class import CoAxiom import ConLike @@ -80,7 +80,7 @@ tyThingToLHsDecl t = case t of , tcdFDs = map (\ (l,r) -> noLoc (map (noLoc . getName) l, map (noLoc . getName) r) ) $ snd $ classTvsFds cl - , tcdSigs = noLoc (MinimalSig mempty . noLoc . fmap noLoc $ classMinimalDef cl) : + , tcdSigs = noLoc (MinimalSig NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) : map (noLoc . synifyTcIdSig DeleteTopLevelQuantification) (classMethods cl) , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature @@ -366,17 +366,17 @@ synifyPatSynSigType :: PatSyn -> LHsSigType Name synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps) synifyType :: SynifyTypeState -> Type -> LHsType Name -synifyType _ (TyVarTy tv) = noLoc $ HsTyVar $ noLoc (getName tv) +synifyType _ (TyVarTy tv) = noLoc $ HsTyVar NotPromoted $ noLoc (getName tv) synifyType _ (TyConApp tc tys) -- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473) | tc `hasKey` tYPETyConKey , [TyConApp lev []] <- tys , lev `hasKey` ptrRepLiftedDataConKey - = noLoc (HsTyVar (noLoc starKindTyConName)) + = noLoc (HsTyVar NotPromoted (noLoc starKindTyConName)) | tc `hasKey` tYPETyConKey , [TyConApp lev []] <- tys , lev `hasKey` ptrRepUnliftedDataConKey - = noLoc (HsTyVar (noLoc unliftedTypeKindTyConName)) + = noLoc (HsTyVar NotPromoted (noLoc unliftedTypeKindTyConName)) -- Use non-prefix tuple syntax where possible, because it looks nicer. | Just sort <- tyConTuple_maybe tc , tyConArity tc == length tys @@ -400,7 +400,7 @@ synifyType _ (TyConApp tc tys) -- Most TyCons: | otherwise = foldl (\t1 t2 -> noLoc (HsAppTy t1 t2)) - (noLoc $ HsTyVar $ noLoc (getName tc)) + (noLoc $ HsTyVar NotPromoted $ noLoc (getName tc)) (map (synifyType WithinType) $ filterOut isCoercionTy tys) synifyType s (AppTy t1 (CoercionTy {})) = synifyType s t1 @@ -443,8 +443,8 @@ synifyPatSynType ps = let in noLoc $ sForAll univ_tvs $ sQual req_theta' $ sForAll ex_tvs $ sQual prov_theta sTau synifyTyLit :: TyLit -> HsTyLit -synifyTyLit (NumTyLit n) = HsNumTy mempty n -synifyTyLit (StrTyLit s) = HsStrTy mempty s +synifyTyLit (NumTyLit n) = HsNumTy NoSourceText n +synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s synifyKindSig :: Kind -> LHsKind Name synifyKindSig k = synifyType WithinType k diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 2cdc6f8b..4e1a9b3a 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -48,7 +48,7 @@ import Bag import RdrName import TcRnTypes import FastString (concatFS) -import BasicTypes ( StringLiteral(..) ) +import BasicTypes ( StringLiteral(..), SourceText(..) ) import qualified Outputable as O import HsDecls ( gadtDeclDetails,getConDetails ) @@ -164,7 +164,7 @@ mkAliasMap dflags mRenamedSource = Just (_,impDecls,_,_) -> M.fromList $ mapMaybe (\(SrcLoc.L _ impDecl) -> do - alias <- ideclAs impDecl + SrcLoc.L _ alias <- ideclAs impDecl return $ (lookupModuleDyn dflags (fmap Module.fsToUnitId $ @@ -569,7 +569,7 @@ mkExportItems L loc (TyClD cl@ClassDecl{}) -> do mdef <- liftGhcToErrMsgGhc $ minimalDef t - let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . noLoc . fmap noLoc) mdef + let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef return [ mkExportDecl t (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ] @@ -769,7 +769,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap expInst decl l name mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do mdef <- liftGhcToErrMsgGhc $ minimalDef name - let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . noLoc . fmap noLoc) mdef + let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name mkExportItem decl@(L l d) | name:_ <- getMainDeclBinder d = expDecl decl l name @@ -839,7 +839,7 @@ extractRecSel nm mdl t tvs (L _ con : rest) = data_ty -- | ResTyGADT _ ty <- con_res con = ty | ConDeclGADT{} <- con = hsib_body $ con_type con - | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar (noLoc t))) tvs + | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs -- | Keep export items with docs. pruneExportItems :: [ExportItem Name] -> [ExportItem Name] diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index fa85ba64..40a10675 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -219,7 +219,7 @@ renameType t = case t of ltype' <- renameLType ltype return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' }) - HsTyVar (L l n) -> return . HsTyVar . L l =<< rename n + HsTyVar ip (L l n) -> return . HsTyVar ip . L l =<< rename n HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype HsAppTy a b -> do @@ -262,7 +262,7 @@ renameType t = case t of HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a HsCoreTy a -> pure (HsCoreTy a) - HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b + HsExplicitListTy i a b -> HsExplicitListTy i a <$> mapM renameLType b HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b HsSpliceTy _ _ -> error "renameType: HsSpliceTy" HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 3e0df4e1..28bbf305 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -36,7 +36,7 @@ specialize :: (Eq name, Typeable name) specialize name details = everywhere $ mkT step where - step (HsTyVar (L _ name')) | name == name' = details + step (HsTyVar _ (L _ name')) | name == name' = details step typ = typ @@ -123,7 +123,7 @@ sugar = sugarLists :: NamedThing name => HsType name -> HsType name -sugarLists (HsAppTy (L _ (HsTyVar (L _ name))) ltyp) +sugarLists (HsAppTy (L _ (HsTyVar _ (L _ name))) ltyp) | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp where name' = getName name @@ -137,7 +137,7 @@ sugarTuples typ = where aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp aux apps (HsParTy (L _ typ')) = aux apps typ' - aux apps (HsTyVar (L _ name)) + aux apps (HsTyVar _ (L _ name)) | isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps where name' = getName name @@ -149,7 +149,7 @@ sugarTuples typ = sugarOperators :: NamedThing name => HsType name -> HsType name -sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar (L l name))) la)) lb) +sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar _ (L l name))) la)) lb) | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb where @@ -224,7 +224,7 @@ freeVariables = query term ctx = case cast term :: Maybe (HsType name) of Just (HsForAllTy bndrs _) -> (Set.empty, Set.union ctx (bndrsNames bndrs)) - Just (HsTyVar (L _ name)) + Just (HsTyVar _ (L _ name)) | getName name `Set.member` ctx -> (Set.empty, ctx) | otherwise -> (Set.singleton $ getNameRep name, ctx) _ -> (Set.empty, ctx) @@ -267,7 +267,7 @@ renameType (HsQualTy lctxt lt) = HsQualTy <$> located renameContext lctxt <*> renameLType lt -renameType (HsTyVar name) = HsTyVar <$> located renameName name +renameType (HsTyVar ip name) = HsTyVar ip <$> located renameName name renameType (HsAppTy lf la) = HsAppTy <$> renameLType lf <*> renameLType la renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr renameType (HsListTy lt) = HsListTy <$> renameLType lt @@ -285,8 +285,8 @@ renameType (HsDocTy lt doc) = HsDocTy <$> renameLType lt <*> pure doc renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt renameType t@(HsRecTy _) = pure t renameType t@(HsCoreTy _) = pure t -renameType (HsExplicitListTy ph ltys) = - HsExplicitListTy ph <$> renameLTypes ltys +renameType (HsExplicitListTy ip ph ltys) = + HsExplicitListTy ip ph <$> renameLTypes ltys renameType (HsExplicitTupleTy phs ltys) = HsExplicitTupleTy phs <$> renameLTypes ltys renameType t@(HsTyLit _) = pure t diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 5220e6e9..951faf5b 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -344,7 +344,7 @@ data InstType name | TypeInst (Maybe (HsType name)) -- ^ Body (right-hand side) | DataInst (TyClDecl name) -- ^ Data constructors -instance (OutputableBndr a, OutputableBndr (NameOrRdrName a)) +instance (OutputableBndrId a, HasOccNameId a) => Outputable (InstType a) where ppr (ClassInst { .. }) = text "ClassInst" <+> ppr clsiCtx @@ -380,8 +380,8 @@ mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl mkType (KindedTyVar (L loc name) lkind) = HsKindSig tvar lkind where - tvar = L loc (HsTyVar (L loc name)) - mkType (UserTyVar name) = HsTyVar name + tvar = L loc (HsTyVar NotPromoted (L loc name)) + mkType (UserTyVar name) = HsTyVar NotPromoted name -- | An instance head that may have documentation and a source location. diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index da87990c..ba382600 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -151,7 +151,7 @@ addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine lHsQTyVarsToTypes :: LHsQTyVars Name -> [LHsType Name] lHsQTyVarsToTypes tvs - = [ noLoc (HsTyVar (noLoc (hsLTyVarName tv))) + = [ noLoc (HsTyVar NotPromoted (noLoc (hsLTyVarName tv))) | tv <- hsQTvExplicit tvs ] -------------------------------------------------------------------------------- -- cgit v1.2.3 From 7f1987b35eb7bb15ca2fd93321440af519dd8cd5 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Tue, 24 Jan 2017 21:57:56 +0200 Subject: Changes to match #13163 in GHC --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 8 ++++---- haddock-api/src/Haddock/Interface/Create.hs | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/Create.hs') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index aff61cfc..b97f0ead 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -152,11 +152,11 @@ imports src@(_, imps, _, _) = everything (<|>) ie src ++ mapMaybe (imp . GHC.unLoc) imps where ie term = case cast term of - (Just (GHC.IEVar v)) -> pure $ var v - (Just (GHC.IEThingAbs t)) -> pure $ typ t - (Just (GHC.IEThingAll t)) -> pure $ typ t + (Just (GHC.IEVar v)) -> pure $ var $ GHC.ieLWrappedName v + (Just (GHC.IEThingAbs t)) -> pure $ typ $ GHC.ieLWrappedName t + (Just (GHC.IEThingAll t)) -> pure $ typ $ GHC.ieLWrappedName t (Just (GHC.IEThingWith t _ vs _fls)) -> - [typ t] ++ map var vs + [typ $ GHC.ieLWrappedName t] ++ map (var . GHC.ieLWrappedName) vs _ -> empty typ (GHC.L sspan name) = (sspan, RtkType name) var (GHC.L sspan name) = (sspan, RtkVar name) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 4e1a9b3a..4a65fc2a 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -511,10 +511,10 @@ mkExportItems Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls Just exports -> liftM concat $ mapM lookupExport exports where - lookupExport (IEVar (L _ x)) = declWith x - lookupExport (IEThingAbs (L _ t)) = declWith t - lookupExport (IEThingAll (L _ t)) = declWith t - lookupExport (IEThingWith (L _ t) _ _ _) = declWith t + lookupExport (IEVar (L _ x)) = declWith $ ieWrappedName x + lookupExport (IEThingAbs (L _ t)) = declWith $ ieWrappedName t + lookupExport (IEThingAll (L _ t)) = declWith $ ieWrappedName t + lookupExport (IEThingWith (L _ t) _ _ _) = declWith $ ieWrappedName t lookupExport (IEModuleContents (L _ m)) = moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices lookupExport (IEGroup lev docStr) = return $ -- cgit v1.2.3