From a8ca2ae8737d29145fe57a7709e59be8cb7a00dc Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Mon, 2 Apr 2018 23:37:50 +0200 Subject: Match GHC for TTG implemented on HsBinds, D4581 --- haddock-api/src/Haddock/Backends/Hoogle.hs | 4 +- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 6 +-- haddock-api/src/Haddock/Backends/LaTeX.hs | 24 ++++++------ haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 20 +++++----- haddock-api/src/Haddock/Convert.hs | 10 ++--- haddock-api/src/Haddock/GhcUtils.hs | 44 +++++++++++----------- haddock-api/src/Haddock/Interface/Create.hs | 16 ++++---- haddock-api/src/Haddock/Interface/Rename.hs | 20 +++++----- haddock-api/src/Haddock/Interface/Specialize.hs | 4 +- haddock-api/src/Haddock/Types.hs | 7 ++++ haddock-api/src/Haddock/Utils.hs | 10 ++--- 11 files changed, 86 insertions(+), 79 deletions(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 9e0b5102..09f62a19 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -138,7 +138,7 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl ppExport _ _ = [] ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String] -ppSigWithDoc dflags (TypeSig names sig) subdocs +ppSigWithDoc dflags (TypeSig _ names sig) subdocs = concatMap mkDocSig names where mkDocSig n = concatMap (ppDocumentation dflags) (getDoc n) @@ -262,7 +262,7 @@ ppCtor dflags _dat subdocs con@(ConDeclGADT { }) name = out dflags $ map unL $ getConNames con ppFixity :: DynFlags -> (Name, Fixity) -> [String] -ppFixity dflags (name, fixity) = [out dflags ((FixitySig [noLoc name] fixity) :: FixitySig GhcRn)] +ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExt [noLoc name] fixity) :: FixitySig GhcRn)] --------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 3d7575eb..19d638d9 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -114,7 +114,7 @@ binds = everythingInRenamedSource (fun `Syb.combine` pat `Syb.combine` tvar) where fun term = case cast term of - (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn)) -> + (Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn)) -> pure (sspan, RtkBind name) _ -> empty pat term = case cast term of @@ -150,7 +150,7 @@ decls (group, _, _, _) = concatMap ($ group) GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs fun term = case cast term of - (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn)) + (Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn)) | GHC.isExternalName name -> pure (sspan, RtkDecl name) _ -> empty con term = case cast term of @@ -169,7 +169,7 @@ decls (group, _, _, _) = concatMap ($ group) Just (field :: GHC.ConDeclField GHC.GhcRn) -> map (decl . fmap GHC.extFieldOcc) $ GHC.cd_fld_names field Nothing -> empty - sig (GHC.L _ (GHC.TypeSig names _)) = map decl names + sig (GHC.L _ (GHC.TypeSig _ names _)) = map decl names sig _ = [] decl (GHC.L sspan name) = (sspan, RtkDecl name) tyref (GHC.L sspan name) = (sspan, RtkType name) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 1229a8d3..4535979e 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -216,7 +216,7 @@ processExports (e : es) = isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsType DocNameI) -isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames t)) +isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig _ lnames t)) , expItemMbDoc = (Documentation Nothing Nothing, argDocs) } | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t)) isSimpleSig _ = Nothing @@ -257,8 +257,8 @@ declNames :: LHsDecl DocNameI ) declNames (L _ decl) = case decl of TyClD d -> (empty, [tcdName d]) - SigD (TypeSig lnames _ ) -> (empty, map unLoc lnames) - SigD (PatSynSig lnames _) -> (text "pattern", map unLoc lnames) + SigD (TypeSig _ lnames _ ) -> (empty, map unLoc lnames) + SigD (PatSynSig _ lnames _) -> (text "pattern", map unLoc lnames) ForD (ForeignImport (L _ n) _ _ _) -> (empty, [n]) ForD (ForeignExport (L _ n) _ _ _) -> (empty, [n]) _ -> error "declaration not supported by declNames" @@ -300,13 +300,13 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of -- TyClD d@TySynonym{} -- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode -- Family instances happen via FamInst now - TyClD d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode - SigD (TypeSig lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode - SigD (PatSynSig lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode - ForD d -> ppFor (doc, fnArgsDoc) d unicode - InstD _ -> empty - DerivD _ -> empty - _ -> error "declaration not supported by ppDecl" + TyClD d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode + SigD (TypeSig _ lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode + SigD (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode + ForD d -> ppFor (doc, fnArgsDoc) d unicode + InstD _ -> empty + DerivD _ -> empty + _ -> error "declaration not supported by ppDecl" where unicode = False @@ -548,7 +548,7 @@ ppClassDecl instances doc subdocs methodTable = text "\\haddockpremethods{}\\textbf{Methods}" $$ vcat [ ppFunSig doc names (hsSigWcType typ) unicode - | L _ (TypeSig lnames typ) <- lsigs + | L _ (TypeSig _ lnames typ) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] -- FIXME: is taking just the first name ok? Is it possible that @@ -647,7 +647,7 @@ ppDataDecl pats instances subdocs doc dataDecl unicode = text "\\enspace" <+> emph (text "Bundled Patterns") <> text "\\par" $$ text "\\haddockbeginconstrs" $$ vcat [ empty <-> ppSideBySidePat lnames typ d unicode - | (SigD (PatSynSig lnames typ), d) <- pats + | (SigD (PatSynSig _ lnames typ), d) <- pats ] $$ text "\\end{tabulary}\\par" diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index a4f2a4a5..5f253cbd 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -58,9 +58,9 @@ ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdoc TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode qual TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual - SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames + SigD (TypeSig _ lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames (hsSigWcType lty) fixities splice unicode qual - SigD (PatSynSig lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames + SigD (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames (hsSigType lty) fixities splice unicode qual ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual InstD _ -> noHtml @@ -513,7 +513,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t [ ppFunSig summary links loc doc names (hsSigWcType typ) [] splice unicode qual - | L _ (TypeSig lnames typ) <- sigs + | L _ (TypeSig _ lnames typ) <- sigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] -- FIXME: is taking just the first name ok? Is it possible that @@ -561,7 +561,7 @@ ppClassDecl summary links instances fixities loc d subdocs methodBit = subMethods [ ppFunSig summary links loc doc names (hsSigType typ) subfixs splice unicode qual - | L _ (ClassOpSig _ lnames typ) <- lsigs + | L _ (ClassOpSig _ _ lnames typ) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs subfixs = [ f | n <- names , f@(n',_) <- fixities @@ -570,15 +570,15 @@ ppClassDecl summary links instances fixities loc d subdocs -- N.B. taking just the first name is ok. Signatures with multiple names -- are expanded so that each name gets its own signature. - minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of + minimalBit = case [ s | MinimalSig _ _ (L _ s) <- sigs ] of -- Miminal complete definition = every shown method And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] == - sort [getName n | TypeSig ns _ <- sigs, L _ n <- ns] + sort [getName n | TypeSig _ ns _ <- sigs, L _ n <- ns] -> noHtml -- Minimal complete definition = the only shown method Var (L _ n) : _ | [getName n] == - [getName n' | L _ (TypeSig ns _) <- lsigs, L _ n' <- ns] + [getName n' | L _ (TypeSig _ ns _) <- lsigs, L _ n' <- ns] -> noHtml -- Minimal complete definition = nothing @@ -679,7 +679,7 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification -> [Sig DocNameI] -> [Html] ppInstanceSigs links splice unicode qual sigs = do - TypeSig lnames typ <- sigs + TypeSig _ lnames typ <- sigs let names = map unLoc lnames L _ rtyp = hsSigWcType typ -- Instance methods signatures are synified and thus don't have a useful @@ -746,7 +746,7 @@ ppShortDataDecl summary dataInst dataDecl pats unicode qual , dcolon unicode , ppPatSigType unicode qual (hsSigType typ) ] - | (SigD (PatSynSig lnames typ),_) <- pats + | (SigD (PatSynSig _ lnames typ),_) <- pats ] @@ -793,7 +793,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats patternBit = subPatterns qual [ ppSideBySidePat subfixs unicode qual lnames typ d - | (SigD (PatSynSig lnames typ), d) <- pats + | (SigD (PatSynSig _ lnames typ), d) <- pats , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) (map unLoc lnames)) fixities ] diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index fac448a2..fd9f0089 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -85,7 +85,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 NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) : + , tcdSigs = noLoc (MinimalSig noExt NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) : map (noLoc . synifyTcIdSig DeleteTopLevelQuantification) (classMethods cl) , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature @@ -102,11 +102,11 @@ tyThingToLHsDecl t = case t of ACoAxiom ax -> synifyAxiom ax >>= allOK -- a data-constructor alone just gets rendered as a function: - AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig [synifyName dc] + AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig noExt [synifyName dc] (synifySigWcType ImplicitizeForAll (dataConUserType dc))) AConLike (PatSynCon ps) -> - allOK . SigD $ PatSynSig [synifyName ps] (synifyPatSynSigType ps) + allOK . SigD $ PatSynSig noExt [synifyName ps] (synifyPatSynSigType ps) where withErrs e x = return (e, x) allOK x = return (mempty, x) @@ -331,10 +331,10 @@ synifyName n = L (srcLocSpan (getSrcLoc n)) (getName n) synifyIdSig :: SynifyTypeState -> Id -> Sig GhcRn -synifyIdSig s i = TypeSig [synifyName i] (synifySigWcType s (varType i)) +synifyIdSig s i = TypeSig noExt [synifyName i] (synifySigWcType s (varType i)) synifyTcIdSig :: SynifyTypeState -> Id -> Sig GhcRn -synifyTcIdSig s i = ClassOpSig False [synifyName i] (synifySigType s (varType i)) +synifyTcIdSig s i = ClassOpSig noExt False [synifyName i] (synifySigType s (varType i)) synifyCtx :: [PredType] -> LHsContext GhcRn synifyCtx = noLoc . map (synifyType WithinType) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 48a9f99e..14111a6a 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -74,30 +74,30 @@ getInstLoc (TyFamInstD (TyFamInstDecl -- foo, bar :: Types.. -- but only one of the names is exported and we have to change the -- type signature to only include the exported names. -filterLSigNames :: (IdP name -> Bool) -> LSig name -> Maybe (LSig name) +filterLSigNames :: (IdP (GhcPass p) -> Bool) -> LSig (GhcPass p) -> Maybe (LSig (GhcPass p)) filterLSigNames p (L loc sig) = L loc <$> (filterSigNames p sig) -filterSigNames :: (IdP name -> Bool) -> Sig name -> Maybe (Sig name) -filterSigNames p orig@(SpecSig n _ _) = ifTrueJust (p $ unLoc n) orig -filterSigNames p orig@(InlineSig n _) = ifTrueJust (p $ unLoc n) orig -filterSigNames p (FixSig (FixitySig ns ty)) = +filterSigNames :: (IdP (GhcPass p) -> Bool) -> Sig (GhcPass p) -> Maybe (Sig (GhcPass p)) +filterSigNames p orig@(SpecSig _ n _ _) = ifTrueJust (p $ unLoc n) orig +filterSigNames p orig@(InlineSig _ n _) = ifTrueJust (p $ unLoc n) orig +filterSigNames p (FixSig _ (FixitySig _ ns ty)) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (FixSig (FixitySig filtered ty)) -filterSigNames _ orig@(MinimalSig _ _) = Just orig -filterSigNames p (TypeSig ns ty) = + filtered -> Just (FixSig noExt (FixitySig noExt filtered ty)) +filterSigNames _ orig@(MinimalSig _ _ _) = Just orig +filterSigNames p (TypeSig _ ns ty) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (TypeSig filtered ty) -filterSigNames p (ClassOpSig is_default ns ty) = + filtered -> Just (TypeSig noExt filtered ty) +filterSigNames p (ClassOpSig _ is_default ns ty) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (ClassOpSig is_default filtered ty) -filterSigNames p (PatSynSig ns ty) = + filtered -> Just (ClassOpSig noExt is_default filtered ty) +filterSigNames p (PatSynSig _ ns ty) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (PatSynSig filtered ty) -filterSigNames _ _ = Nothing + filtered -> Just (PatSynSig noExt filtered ty) +filterSigNames _ _ = Nothing ifTrueJust :: Bool -> name -> Maybe name ifTrueJust True = Just @@ -107,13 +107,13 @@ sigName :: LSig name -> [IdP name] sigName (L _ sig) = sigNameNoLoc sig sigNameNoLoc :: Sig name -> [IdP name] -sigNameNoLoc (TypeSig ns _) = map unLoc ns -sigNameNoLoc (ClassOpSig _ ns _) = map unLoc ns -sigNameNoLoc (PatSynSig ns _) = map unLoc ns -sigNameNoLoc (SpecSig n _ _) = [unLoc n] -sigNameNoLoc (InlineSig n _) = [unLoc n] -sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns -sigNameNoLoc _ = [] +sigNameNoLoc (TypeSig _ ns _) = map unLoc ns +sigNameNoLoc (ClassOpSig _ _ ns _) = map unLoc ns +sigNameNoLoc (PatSynSig _ ns _) = map unLoc ns +sigNameNoLoc (SpecSig _ n _ _) = [unLoc n] +sigNameNoLoc (InlineSig _ n _) = [unLoc n] +sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns +sigNameNoLoc _ = [] -- | Was this signature given by the user? isUserLSig :: LSig name -> Bool @@ -258,7 +258,7 @@ instance Parent (TyClDecl GhcRn) where $ (dd_cons . tcdDataDefn) $ d | isClassDecl d = map (unL . fdLName . unL) (tcdATs d) ++ - [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ] + [ unL n | L _ (TypeSig _ ns _) <- tcdSigs d, n <- ns ] | otherwise = [] diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 88b8bc67..c119f3c3 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -481,9 +481,9 @@ conArgDocs con = case getConArgs con of -- | 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 (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 @@ -519,7 +519,7 @@ 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 _ (FixitySig _ ns f) <- hs_fixds group_, L _ n <- ns ] @@ -729,7 +729,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames L loc (TyClD cl@ClassDecl{}) -> do mdef <- liftGhcToErrMsgGhc $ minimalDef t - let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef + let sig = maybeToList $ fmap (noLoc . MinimalSig noExt NoSourceText . noLoc . fmap noLoc) mdef availExportDecl avail (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ @@ -1022,7 +1022,7 @@ extractDecl declMap name decl matchesMethod = [ lsig | lsig <- tcdSigs d - , ClassOpSig False _ _ <- pure $ unLoc lsig + , ClassOpSig _ False _ _ <- pure $ unLoc lsig -- Note: exclude `default` declarations (see #505) , name `elem` sigName lsig ] @@ -1097,7 +1097,7 @@ extractPatternSyn nm t tvs cons = ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExt cxt typ) _ -> typ typ'' = noLoc (HsQualTy noExt (noLoc []) typ') - in PatSynSig [noLoc nm] (mkEmptyImplicitBndrs typ'') + in PatSynSig noExt [noLoc nm] (mkEmptyImplicitBndrs typ'') longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExt x y)) output inputs @@ -1113,7 +1113,7 @@ extractRecSel _ _ _ [] = error "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 [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExt data_ty (getBangType ty))))) + L l (TypeSig noExt [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExt 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/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index c8d9cb7d..0652ae47 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -480,24 +480,24 @@ renameLFieldOcc (L _ (XFieldOcc _)) = error "haddock:renameLFieldOcc" renameSig :: Sig GhcRn -> RnM (Sig DocNameI) renameSig sig = case sig of - TypeSig lnames ltype -> do + TypeSig _ lnames ltype -> do lnames' <- mapM renameL lnames ltype' <- renameLSigWcType ltype - return (TypeSig lnames' ltype') - ClassOpSig is_default lnames sig_ty -> do + return (TypeSig noExt lnames' ltype') + ClassOpSig _ is_default lnames sig_ty -> do lnames' <- mapM renameL lnames ltype' <- renameLSigType sig_ty - return (ClassOpSig is_default lnames' ltype') - PatSynSig lnames sig_ty -> do + return (ClassOpSig noExt is_default lnames' ltype') + PatSynSig _ lnames sig_ty -> do lnames' <- mapM renameL lnames sig_ty' <- renameLSigType sig_ty - return $ PatSynSig lnames' sig_ty' - FixSig (FixitySig lnames fixity) -> do + return $ PatSynSig noExt lnames' sig_ty' + FixSig _ (FixitySig _ lnames fixity) -> do lnames' <- mapM renameL lnames - return $ FixSig (FixitySig lnames' fixity) - MinimalSig src (L l s) -> do + return $ FixSig noExt (FixitySig noExt lnames' fixity) + MinimalSig _ src (L l s) -> do s' <- traverse renameL s - return $ MinimalSig src (L l s') + return $ MinimalSig noExt 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 18d93fae..b84a676f 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -73,8 +73,8 @@ specializePseudoFamilyDecl bndrs typs decl = specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn] -> Sig GhcRn -> Sig GhcRn -specializeSig bndrs typs (TypeSig lnames typ) = - TypeSig lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}}) +specializeSig bndrs typs (TypeSig _ lnames typ) = + TypeSig noExt lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}}) where true_type :: HsType GhcRn true_type = unLoc (hsSigWcType typ) diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index b4b16d62..2234894c 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -696,3 +696,10 @@ type instance XXTyVarBndr DocNameI = PlaceHolder type instance XFieldOcc DocNameI = DocName type instance XXFieldOcc DocNameI = PlaceHolder + +type instance XFixitySig DocNameI = PlaceHolder +type instance XFixSig DocNameI = PlaceHolder +type instance XPatSynSig DocNameI = PlaceHolder +type instance XClassOpSig DocNameI = PlaceHolder +type instance XTypeSig DocNameI = PlaceHolder +type instance XMinimalSig DocNameI = PlaceHolder diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 5de539c0..1ebf7ffa 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -131,18 +131,18 @@ mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty) addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn -- Add the class context to a class-op signature -addClassContext cls tvs0 (L pos (ClassOpSig _ lname ltype)) - = L pos (TypeSig lname (mkEmptySigWcType (go (hsSigType ltype)))) +addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype)) + = L pos (TypeSig noExt lname (mkEmptySigWcType (go (hsSigType ltype)))) -- The mkEmptySigWcType is suspicious where go (L loc (HsForAllTy { hst_bndrs = tvs, hst_body = ty })) - = L loc (HsForAllTy { hst_xforall = PlaceHolder + = L loc (HsForAllTy { hst_xforall = noExt , hst_bndrs = tvs, hst_body = go ty }) go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) - = L loc (HsQualTy { hst_xqual = PlaceHolder + = L loc (HsQualTy { hst_xqual = noExt , hst_ctxt = add_ctxt ctxt, hst_body = ty }) go (L loc ty) - = L loc (HsQualTy { hst_xqual = PlaceHolder + = L loc (HsQualTy { hst_xqual = noExt , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty }) extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0) -- cgit v1.2.3