diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hoogle.hs | 38 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 2 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/LaTeX.hs | 33 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml.hs | 3 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 78 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs | 2 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 2 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Names.hs | 5 |
8 files changed, 85 insertions, 78 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 1a0cccf7..e70a705f 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -72,7 +72,7 @@ ppModule dflags unit_state iface = --------------------------------------------------------------------- -- Utility functions -dropHsDocTy :: HsSigType (GhcPass p) -> HsSigType (GhcPass p) +dropHsDocTy :: HsSigType GhcRn -> HsSigType GhcRn dropHsDocTy = drop_sig_ty where drop_sig_ty (HsSig x a b) = HsSig x a (drop_lty b) @@ -94,8 +94,7 @@ dropHsDocTy = drop_sig_ty drop_ty (HsDocTy _ a _) = drop_ty $ unL a drop_ty x = x -outHsSigType :: (OutputableBndrId p, NoGhcTcPass p ~ p) - => DynFlags -> HsSigType (GhcPass p) -> String +outHsSigType :: DynFlags -> HsSigType GhcRn -> String outHsSigType dflags = out dflags . reparenSigType . dropHsDocTy @@ -154,13 +153,13 @@ ppSigWithDoc dflags sig subdocs = case sig of PatSynSig _ names t -> concatMap (mkDocSig "pattern " t) names _ -> [] where - mkDocSig leader typ n = mkSubdoc dflags n subdocs - [leader ++ pp_sig dflags [n] typ] + mkDocSig leader typ n = mkSubdocN dflags n subdocs + [leader ++ pp_sig dflags [n] typ] ppSig :: DynFlags -> Sig GhcRn -> [String] ppSig dflags x = ppSigWithDoc dflags x [] -pp_sig :: DynFlags -> [Located Name] -> LHsSigType GhcRn -> String +pp_sig :: DynFlags -> [LocatedN Name] -> LHsSigType GhcRn -> String pp_sig dflags names (L _ typ) = operator prettyNames ++ " :: " ++ outHsSigType dflags typ where @@ -187,7 +186,7 @@ ppClass dflags decl subdocs = pprTyFam :: LFamilyDecl GhcRn -> SDoc pprTyFam (L _ at) = vcat' $ map text $ - mkSubdoc dflags (fdLName at) subdocs (ppFam dflags at) + mkSubdocN dflags (fdLName at) subdocs (ppFam dflags at) whereWrapper elems = vcat' [ text "where" <+> lbrace @@ -222,7 +221,7 @@ ppSynonym dflags x = [out dflags x] ppData :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String] ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs - = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=noLoc [] }} : + = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=[] }} : concatMap (ppCtor dflags decl subdocs . unLoc) (dd_cons defn) where @@ -235,7 +234,7 @@ ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs ppData _ _ _ = panic "ppData" -- | for constructors, and named-fields... -lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> Located Name -> [String] +lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> LocatedN Name -> [String] lookupCon dflags subdocs (L _ name) = case lookup name subdocs of Just (d, _) -> ppDocumentation dflags d _ -> [] @@ -248,11 +247,11 @@ ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' } f (PrefixCon _ args) = [typeSig name $ (map hsScaledThing args) ++ [resType]] f (InfixCon a1 a2) = f $ PrefixCon [] [a1,a2] f (RecCon (L _ recs)) = f (PrefixCon [] $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat - [(concatMap (lookupCon dflags subdocs . noLoc . extFieldOcc . unLoc) (cd_fld_names r)) ++ + [(concatMap (lookupCon dflags subdocs . noLocA . extFieldOcc . unLoc) (cd_fld_names r)) ++ [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] - funs = foldr1 (\x y -> reL $ HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y) + funs = foldr1 (\x y -> reL $ HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) x y) apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y) typeSig nm flds = operator nm ++ " :: " ++ @@ -262,12 +261,12 @@ ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' } -- docs for con_names on why it is a list to begin with. name = commaSeparate dflags . map unL $ getConNames con - tyVarArg (UserTyVar _ _ n) = HsTyVar noExtField NotPromoted n - tyVarArg (KindedTyVar _ _ n lty) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) lty + tyVarArg (UserTyVar _ _ n) = HsTyVar noAnn NotPromoted n + tyVarArg (KindedTyVar _ _ n lty) = HsKindSig noAnn (reL (HsTyVar noAnn NotPromoted n)) lty tyVarArg _ = panic "ppCtor" resType = apps $ map reL $ - (HsTyVar noExtField NotPromoted (reL (tcdName dat))) : + (HsTyVar noAnn NotPromoted (reL (tcdName dat))) : map (tyVarArg . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat) ppCtor dflags _dat subdocs (ConDeclGADT { con_names = names @@ -281,15 +280,15 @@ ppCtor dflags _dat subdocs (ConDeclGADT { con_names = names name = out dflags $ map unL names con_sig_ty = HsSig noExtField outer_bndrs theta_ty where theta_ty = case mcxt of - Just theta -> noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = Just theta, hst_body = tau_ty }) + Just theta -> noLocA (HsQualTy { hst_xqual = noExtField, hst_ctxt = Just theta, hst_body = tau_ty }) Nothing -> tau_ty tau_ty = foldr mkFunTy res_ty $ case args of PrefixConGADT pos_args -> map hsScaledThing pos_args RecConGADT (L _ flds) -> map (cd_fld_type . unL) flds - mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b) + mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) a b) ppFixity :: DynFlags -> (Name, Fixity) -> [String] -ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLoc name] fixity) :: FixitySig GhcRn)] +ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLocA name] fixity) :: FixitySig GhcRn)] --------------------------------------------------------------------- @@ -312,7 +311,10 @@ docWith dflags header d lines header ++ ["" | header /= "" && isJust d] ++ maybe [] (showTags . markup (markupTag dflags)) d -mkSubdoc :: DynFlags -> Located Name -> [(Name, DocForDecl Name)] -> [String] -> [String] +mkSubdocN :: DynFlags -> LocatedN Name -> [(Name, DocForDecl Name)] -> [String] -> [String] +mkSubdocN dflags n subdocs s = mkSubdoc dflags (n2l n) subdocs s + +mkSubdoc :: DynFlags -> LocatedA Name -> [(Name, DocForDecl Name)] -> [String] -> [String] mkSubdoc dflags n subdocs s = concatMap (ppDocumentation dflags) getDoc ++ s where getDoc = maybe [] (return . fst) (lookup (unLoc n) subdocs) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 2def35ae..d9a2e0cd 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -360,7 +360,7 @@ classify tok = -- the GHC lexer for more), so we have to manually reverse this. The -- following is a hammer: it smashes _all_ pragma-like block comments into -- pragmas. - ITblockComment c + ITblockComment c _ | isPrefixOf "{-#" c , isSuffixOf "#-}" c -> TkPragma | otherwise -> TkComment diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index e2e16947..abf882f0 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -390,10 +390,11 @@ ppFamHeader (FamilyDecl { fdLName = L _ name injAnn = case injectivity of Nothing -> empty - Just (L _ (InjectivityAnn lhs rhs)) -> hsep ( decltt (text "|") - : ppLDocName lhs - : arrow unicode - : map ppLDocName rhs) + Just (L _ (InjectivityAnn _ lhs rhs)) -> hsep ( decltt (text "|") + : ppLDocName lhs + : arrow unicode + : map ppLDocName rhs) + Just _ -> empty @@ -597,8 +598,8 @@ rDoc = maybeDoc . fmap latexStripTrailingWhitespace ------------------------------------------------------------------------------- -ppClassHdr :: Bool -> Maybe (Located [LHsType DocNameI]) -> DocName - -> LHsQTyVars DocNameI -> [Located ([Located DocName], [Located DocName])] +ppClassHdr :: Bool -> Maybe (LocatedC [LHsType DocNameI]) -> DocName + -> LHsQTyVars DocNameI -> [LHsFunDep DocNameI] -> Bool -> LaTeX ppClassHdr summ lctxt n tvs fds unicode = keyword "class" @@ -606,14 +607,16 @@ ppClassHdr summ lctxt n tvs fds unicode = <+> ppAppDocNameNames summ n (tyvarNames tvs) <+> ppFds fds unicode - -ppFds :: [Located ([Located DocName], [Located DocName])] -> Bool -> LaTeX +-- ppFds :: [Located ([LocatedA DocName], [LocatedA DocName])] -> Bool -> LaTeX +ppFds :: [LHsFunDep DocNameI] -> Bool -> LaTeX ppFds fds unicode = if null fds then empty else char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) where - fundep (vars1,vars2) = hsep (map (ppDocName . unLoc) vars1) <+> arrow unicode <+> + fundep (FunDep _ vars1 vars2) + = hsep (map (ppDocName . unLoc) vars1) <+> arrow unicode <+> hsep (map (ppDocName . unLoc) vars2) + fundep (XFunDep _) = error "ppFds" -- TODO: associated type defaults, docs on default methods @@ -804,7 +807,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = decl = case con of ConDeclH98{ con_args = det , con_ex_tvs = tyVars - , con_forall = L _ forall_ + , con_forall = forall_ , con_mb_cxt = cxt } -> let context = fromMaybeContext cxt header_ = ppConstrHdr forall_ tyVars context unicode @@ -893,7 +896,7 @@ ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) = -- | Pretty-print a bundled pattern synonym -ppSideBySidePat :: [Located DocName] -- ^ pattern name(s) +ppSideBySidePat :: [LocatedN DocName] -- ^ pattern name(s) -> LHsSigType DocNameI -- ^ type of pattern(s) -> DocForDecl DocName -- ^ doc map -> Bool -- ^ unicode @@ -1036,7 +1039,7 @@ sumParens = ubxparens . hsep . punctuate (text " |") -- Stolen from Html and tweaked for LaTeX generation ------------------------------------------------------------------------------- -ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocNameI) -> LaTeX +ppLType, ppLParendType, ppLFunLhType :: Bool -> LHsType DocNameI -> LaTeX ppLType unicode y = ppType unicode (unLoc y) ppLParendType unicode y = ppParendType unicode (unLoc y) ppLFunLhType unicode y = ppFunLhType unicode (unLoc y) @@ -1104,9 +1107,9 @@ ppr_mono_ty (HsFunTy _ mult ty1 ty2) u = sep [ ppr_mono_lty ty1 u , arr <+> ppr_mono_lty ty2 u ] where arr = case mult of - HsLinearArrow _ -> lollipop u + HsLinearArrow _ _ -> lollipop u HsUnrestrictedArrow _ -> arrow u - HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u <+> arrow u + HsExplicitMult _ _ m -> multAnnotation <> ppr_mono_lty m u <+> arrow u ppr_mono_ty (HsBangTy _ b ty) u = ppBang b <> ppLParendType u ty ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name @@ -1187,7 +1190,7 @@ ppOccName = text . occNameString ppDocName :: DocName -> LaTeX ppDocName = ppOccName . nameOccName . getName -ppLDocName :: Located DocName -> LaTeX +ppLDocName :: GenLocated l DocName -> LaTeX ppLDocName (L _ d) = ppDocName d diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 1bdbf81b..d390a95a 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -49,8 +49,7 @@ import qualified Data.Map as Map hiding ( Map ) import qualified Data.Set as Set hiding ( Set ) import Data.Ord ( comparing ) -import GHC.Driver.Session (Language(..)) -import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..) ) +import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..), anchor ) import GHC.Types.Name import GHC.Unit.State diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index e48f9bdd..8de1b1b8 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -58,22 +58,22 @@ ppDecl :: Bool -- ^ print summary info only -> Qualification -> Html ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode pkg qual = case decl of - TyClD _ (FamDecl _ d) -> ppFamDecl summ False links instances fixities loc mbDoc d splice unicode pkg qual - TyClD _ d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode pkg qual - TyClD _ d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual - TyClD _ d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual - SigD _ (TypeSig _ lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames + TyClD _ (FamDecl _ d) -> ppFamDecl summ False links instances fixities (locA loc) mbDoc d splice unicode pkg qual + TyClD _ d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs (locA loc) mbDoc d pats splice unicode pkg qual + TyClD _ d@(SynDecl {}) -> ppTySyn summ links fixities (locA loc) (mbDoc, fnArgsDoc) d splice unicode pkg qual + TyClD _ d@(ClassDecl {}) -> ppClassDecl summ links instances fixities (locA loc) mbDoc subdocs d splice unicode pkg qual + SigD _ (TypeSig _ lnames lty) -> ppLFunSig summ links (locA loc) (mbDoc, fnArgsDoc) lnames (dropWildCards lty) fixities splice unicode pkg qual - SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames + SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links (locA loc) (mbDoc, fnArgsDoc) lnames lty fixities splice unicode pkg qual - ForD _ d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual + ForD _ d -> ppFor summ links (locA loc) (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual InstD _ _ -> noHtml DerivD _ _ -> noHtml _ -> error "declaration not supported by ppDecl" ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - [Located DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] -> + [LocatedN DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppLFunSig summary links loc doc lnames lty fixities splice unicode pkg qual = ppFunSig summary links loc noHtml doc (map unLoc lnames) lty fixities @@ -90,7 +90,7 @@ ppFunSig summary links loc leader doc docnames typ fixities splice unicode pkg q -- | Pretty print a pattern synonym ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName - -> [Located DocName] -- ^ names of patterns in declaration + -> [LocatedN DocName] -- ^ names of patterns in declaration -> LHsSigType DocNameI -- ^ type of patterns in declaration -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html @@ -249,7 +249,7 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars sig_type = mkHsImplicitSigTypeI ltype hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars unicode qual (hsQTvExplicit ltyvars)) - full = hdr <+> equals <+> ppPatSigType unicode qual (noLoc sig_type) + full = hdr <+> equals <+> ppPatSigType unicode qual (noLocA sig_type) occ = nameOccName . getName $ name fixs | summary = noHtml @@ -330,7 +330,7 @@ ppPseudoFamDecl links splice , pfdTyVars = tvs , pfdLName = L loc name }) unicode qual = - topDeclElem links loc splice [name] leader + topDeclElem links (locA loc) splice [name] leader where leader = hsep [ ppFamilyLeader True info , ppAppNameTypes name (map unLoc tvs) unicode qual @@ -361,10 +361,11 @@ ppFamHeader summary associated (FamilyDecl { fdInfo = info injAnn = case injectivity of Nothing -> noHtml - Just (L _ (InjectivityAnn lhs rhs)) -> hsep ( keyword "|" - : ppLDocName qual Raw lhs - : arrow unicode - : map (ppLDocName qual Raw) rhs) + Just (L _ (InjectivityAnn _ lhs rhs)) -> hsep ( keyword "|" + : ppLDocName qual Raw lhs + : arrow unicode + : map (ppLDocName qual Raw) rhs) + Just _ -> error "ppFamHeader:XInjectivityAnn" -- | Print the keywords that begin the family declaration ppFamilyLeader :: Bool -> FamilyInfo DocNameI -> Html @@ -474,8 +475,8 @@ ppHsContext cxt unicode qual = parenList (map (ppType unicode qual HideEmptyCont ------------------------------------------------------------------------------- -ppClassHdr :: Bool -> Maybe (Located [LHsType DocNameI]) -> DocName - -> LHsQTyVars DocNameI -> [Located ([Located DocName], [Located DocName])] +ppClassHdr :: Bool -> Maybe (LocatedC [LHsType DocNameI]) -> DocName + -> LHsQTyVars DocNameI -> [LHsFunDep DocNameI] -> Unicode -> Qualification -> Html ppClassHdr summ lctxt n tvs fds unicode qual = keyword "class" @@ -484,12 +485,13 @@ ppClassHdr summ lctxt n tvs fds unicode qual = <+> ppFds fds unicode qual -ppFds :: [Located ([Located DocName], [Located DocName])] -> Unicode -> Qualification -> Html +ppFds :: [LHsFunDep DocNameI] -> Unicode -> Qualification -> Html ppFds fds unicode qual = if null fds then noHtml else char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) where - fundep (vars1,vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2 + fundep (FunDep _ vars1 vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2 + fundep (XFunDep _) = error "ppFds" ppVars = hsep . map ((ppDocName qual Prefix True) . unLoc) ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocNameI -> SrcSpan @@ -572,9 +574,9 @@ ppClassDecl summary links instances fixities loc d subdocs lookupDAT name = Map.lookup (getName name) defaultAssocTys defaultAssocTys = Map.fromList [ (getName name, (vs, typ)) - | L _ (TyFamInstDecl (FamEqn { feqn_rhs = typ - , feqn_tycon = L _ name - , feqn_pats = vs })) <- atsDefs + | L _ (TyFamInstDecl _ (FamEqn { feqn_rhs = typ + , feqn_tycon = L _ name + , feqn_pats = vs })) <- atsDefs ] -- Methods @@ -723,7 +725,7 @@ ppInstanceSigs links splice unicode qual sigs = do L _ rtyp = dropWildCards typ -- Instance methods signatures are synified and thus don't have a useful -- SrcSpan value. Use the methods name location instead. - return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLoc $ head $ lnames) names rtyp + return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLocA $ head $ lnames) names rtyp lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 @@ -828,7 +830,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats [ ppSideBySideConstr subdocs subfixs unicode pkg qual c | c <- cons , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) - (map unLoc (getConNamesI (unLoc c)))) fixities + (map unL (getConNamesI (unLoc c)))) fixities ] patternBit = subPatterns pkg qual @@ -855,7 +857,7 @@ ppShortConstrParts summary dataInst con unicode qual = case con of ConDeclH98{ con_args = det , con_ex_tvs = tyVars - , con_forall = L _ forall_ + , con_forall = forall_ , con_mb_cxt = cxt } -> let context = fromMaybeContext cxt header_ = ppConstrHdr forall_ tyVars context unicode qual @@ -895,7 +897,7 @@ ppShortConstrParts summary dataInst con unicode qual ) where - occ = map (nameOccName . getName . unLoc) $ getConNamesI con + occ = map (nameOccName . getName . unL) $ getConNamesI con ppOcc = hsep (punctuate comma (map (ppBinder summary) occ)) ppOccInfix = hsep (punctuate comma (map (ppBinderInfix summary) occ)) @@ -912,10 +914,10 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) ) where -- Find the name of a constructors in the decl (`getConName` always returns a non-empty list) - aConName = unLoc (head (getConNamesI con)) + aConName = unL (head (getConNamesI con)) fixity = ppFixities fixities qual - occ = map (nameOccName . getName . unLoc) $ getConNamesI con + occ = map (nameOccName . getName . unL) $ getConNamesI con ppOcc = hsep (punctuate comma (map (ppBinder False) occ)) ppOccInfix = hsep (punctuate comma (map (ppBinderInfix False) occ)) @@ -927,7 +929,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) decl = case con of ConDeclH98{ con_args = det , con_ex_tvs = tyVars - , con_forall = L _ forall_ + , con_forall = forall_ , con_mb_cxt = cxt } -> let context = fromMaybeContext cxt header_ = ppConstrHdr forall_ tyVars context unicode qual @@ -994,7 +996,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. - mbDoc = lookup (unLoc $ head $ getConNamesI con) subdocs >>= + mbDoc = lookup (unL $ head $ getConNamesI con) subdocs >>= combineDocumentation . fst @@ -1044,7 +1046,7 @@ ppShortField summary unicode qual (ConDeclField _ names ltype _) -- | Pretty print an expanded pattern (for bundled patterns) ppSideBySidePat :: [(DocName, Fixity)] -> Unicode -> Qualification - -> [Located DocName] -- ^ pattern name(s) + -> [LocatedN DocName] -- ^ pattern name(s) -> LHsSigType DocNameI -- ^ type of pattern(s) -> DocForDecl DocName -- ^ doc map -> SubDecl @@ -1121,7 +1123,7 @@ sumParens = ubxSumList -- * Rendering of HsType -------------------------------------------------------------------------------- -ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> Located (HsType DocNameI) -> Html +ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> LHsType DocNameI -> Html ppLType unicode qual emptyCtxts y = ppType unicode qual emptyCtxts (unLoc y) ppLParendType unicode qual emptyCtxts y = ppParendType unicode qual emptyCtxts (unLoc y) ppLFunLhType unicode qual emptyCtxts y = ppFunLhType unicode qual emptyCtxts (unLoc y) @@ -1153,7 +1155,7 @@ instance RenderableBndrFlag () where ppHsTyVarBndr _ qual (UserTyVar _ _ (L _ name)) = ppDocName qual Raw False name ppHsTyVarBndr unicode qual (KindedTyVar _ _ name kind) = - parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> + parens (ppDocName qual Raw False (unL name) <+> dcolon unicode <+> ppLKind unicode qual kind) instance RenderableBndrFlag Specificity where @@ -1162,10 +1164,10 @@ instance RenderableBndrFlag Specificity where ppHsTyVarBndr _ qual (UserTyVar _ InferredSpec (L _ name)) = braces $ ppDocName qual Raw False name ppHsTyVarBndr unicode qual (KindedTyVar _ SpecifiedSpec name kind) = - parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> + parens (ppDocName qual Raw False (unL name) <+> dcolon unicode <+> ppLKind unicode qual kind) ppHsTyVarBndr unicode qual (KindedTyVar _ InferredSpec name kind) = - braces (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> + braces (ppDocName qual Raw False (unL name) <+> dcolon unicode <+> ppLKind unicode qual kind) ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html @@ -1246,9 +1248,9 @@ ppr_mono_ty (HsFunTy _ mult ty1 ty2) u q e = , arr <+> ppr_mono_lty ty2 u q e ] where arr = case mult of - HsLinearArrow _ -> lollipop u + HsLinearArrow _ _ -> lollipop u HsUnrestrictedArrow _ -> arrow u - HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u + HsExplicitMult _ _ m -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u ppr_mono_ty (HsTupleTy _ con tys) u q _ = tupleParens con (map (ppLType u q HideEmptyContexts) tys) @@ -1283,7 +1285,7 @@ ppr_mono_ty (HsOpTy _ ty1 op ty2) unicode qual _ -- `(:)` is valid in type signature only as constructor to promoted list -- and needs to be quoted in code so we explicitly quote it here too. ppr_op - | (getOccString . getName . unLoc) op == ":" = promoQuote ppr_op' + | (getOccString . getName . unL) op == ":" = promoQuote ppr_op' | otherwise = ppr_op' ppr_op' = ppLDocName qual Infix op diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index 7670b193..b8f5ac0f 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -31,7 +31,7 @@ import Haddock.Doc (combineDocumentation, emptyMetaDoc, import Text.XHtml hiding ( name, p, quote ) import Data.Maybe (fromMaybe) -import GHC +import GHC hiding (anchor) import GHC.Types.Name diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index d61d6d9b..8f04a21f 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -51,7 +51,7 @@ import Text.XHtml hiding ( name, title, quote ) import Data.Maybe (fromMaybe) import GHC.Data.FastString ( unpackFS ) -import GHC +import GHC hiding (anchor) import GHC.Types.Name (nameOccName) -------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs index b324fa38..6dfc60fa 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs @@ -27,7 +27,7 @@ import Text.XHtml hiding ( name, p, quote ) import qualified Data.Map as M import Data.List ( stripPrefix ) -import GHC hiding (LexicalFixity(..)) +import GHC hiding (LexicalFixity(..), anchor) import GHC.Types.Name import GHC.Types.Name.Reader import GHC.Data.FastString (unpackFS) @@ -57,9 +57,10 @@ ppUncheckedLink _ x = linkIdOcc' mdl (Just occ) << occHtml occHtml = toHtml (showWrapped (occNameString . snd) x) -- TODO: apply ppQualifyName -- The Bool indicates if it is to be rendered in infix notation -ppLDocName :: Qualification -> Notation -> Located DocName -> Html +ppLDocName :: Qualification -> Notation -> GenLocated l DocName -> Html ppLDocName qual notation (L _ d) = ppDocName qual notation True d + ppDocName :: Qualification -> Notation -> Bool -> DocName -> Html ppDocName qual notation insertAnchors docName = case docName of |