From 279a662adc83dba2e24bd0b99f7da9d63455f840 Mon Sep 17 00:00:00 2001 From: jpmoresmau Date: Tue, 20 Jan 2015 18:27:16 +0100 Subject: Links to source location of class instance definitions --- haddock-api/src/Haddock/Backends/LaTeX.hs | 4 +-- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 18 +++++----- haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 44 +++++++++++++++++------- 3 files changed, 43 insertions(+), 23 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index b717fc01..ee5bc861 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -544,14 +544,14 @@ ppDocInstances unicode (i : rest) (is, rest') = spanWith isUndocdInstance rest isUndocdInstance :: DocInstance a -> Maybe (InstHead a) -isUndocdInstance (i,Nothing) = Just i +isUndocdInstance (L _ i,Nothing) = Just i isUndocdInstance _ = Nothing -- | Print a possibly commented instance. The instance header is printed inside -- an 'argBox'. The comment is printed to the right of the box in normal comment -- style. ppDocInstance :: Bool -> DocInstance DocName -> LaTeX -ppDocInstance unicode (instHead, doc) = +ppDocInstance unicode (L _ instHead, doc) = declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX $ fmap _doc doc) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 3bf4322d..d24a3f04 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -18,7 +18,6 @@ module Haddock.Backends.Xhtml.Decl ( tyvarNames ) where - import Haddock.Backends.Xhtml.DocMarkup import Haddock.Backends.Xhtml.Layout import Haddock.Backends.Xhtml.Names @@ -270,7 +269,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode = subEquations qual $ map (ppTyFamEqn . unLoc) eqns | otherwise - = ppInstances instances docname unicode qual + = ppInstances links instances docname unicode qual -- Individual equation of a closed type family ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs @@ -492,18 +491,19 @@ ppClassDecl summary links instances fixities loc d subdocs ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs where wrap | p = parens | otherwise = id - instancesBit = ppInstances instances nm unicode qual + instancesBit = ppInstances links instances nm unicode qual ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" -ppInstances :: [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html -ppInstances instances baseName unicode qual - = subInstances qual instName (map instDecl instances) +ppInstances :: LinksInfo -> [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html +ppInstances links instances baseName unicode qual + = subInstances qual instName links True baseName (map instDecl instances) + -- force Splice = True to use line URLs where instName = getOccString $ getName baseName - instDecl :: DocInstance DocName -> SubDecl - instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, []) + instDecl :: DocInstance DocName -> (SubDecl,SrcSpan) + instDecl (L l inst, maybeDoc) = ((instHead inst, maybeDoc, []),l) instHead (n, ks, ts, ClassInst cs) = ppContextNoLocs cs unicode qual <+> ppAppNameTypes n ks ts unicode qual instHead (n, ks, ts, TypeInst rhs) = keyword "type" @@ -582,7 +582,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl (map unLoc (con_names (unLoc c)))) fixities ] - instancesBit = ppInstances instances docname unicode qual + instancesBit = ppInstances links instances docname unicode qual diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index b2c60534..923958a7 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -148,6 +148,20 @@ subTable qual decls = Just $ table << aboves (concatMap subRow decls) docElement td << fmap (docToHtml Nothing qual) mdoc) : map (cell . (td <<)) subs +-- | Sub table with source information (optional). +subTableSrc :: Qualification -> LinksInfo -> Bool -> DocName -> [(SubDecl,SrcSpan)] -> Maybe Html +subTableSrc _ _ _ _ [] = Nothing +subTableSrc qual lnks splice dn decls = Just $ table << aboves (concatMap subRow decls) + where + subRow ((decl, mdoc, subs),loc) = + (td ! [theclass "src"] << decl + <+> linkHtml loc + <-> + docElement td << fmap (docToHtml Nothing qual) mdoc + ) + : map (cell . (td <<)) subs + linkHtml loc@(RealSrcSpan _) = links lnks loc splice dn + linkHtml _ = noHtml subBlock :: [Html] -> Maybe Html subBlock [] = Nothing @@ -174,13 +188,15 @@ subEquations :: Qualification -> [SubDecl] -> Html subEquations qual = divSubDecls "equations" "Equations" . subTable qual +-- | Generate sub table for instance declarations, with source subInstances :: Qualification -> String -- ^ Class name, used for anchor generation - -> [SubDecl] -> Html -subInstances qual nm = maybe noHtml wrap . instTable + -> LinksInfo -> Bool -> DocName + -> [(SubDecl,SrcSpan)] -> Html +subInstances qual nm lnks splice dn = maybe noHtml wrap . instTable where wrap = (subSection <<) . (subCaption +++) - instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTable qual + instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice dn subSection = thediv ! [theclass "subs instances"] subCaption = paragraph ! collapseControl id_ True "caption" << "Instances" id_ = makeAnchorId $ "i:" ++ nm @@ -200,12 +216,19 @@ declElem = paragraph ! [theclass "src"] -- a box for top level documented names -- it adds a source and wiki link at the right hand side of the box topDeclElem :: LinksInfo -> SrcSpan -> Bool -> [DocName] -> Html -> Html -topDeclElem ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice names html = - declElem << (html <+> srcLink <+> wikiLink) +topDeclElem lnks loc splice names html = + declElem << (html <+> (links lnks loc splice $ head names)) + -- FIXME: is it ok to simply take the first name? + +-- | Adds a source and wiki link at the right hand side of the box. +-- Name must be documented, otherwise we wouldn't get here. +links :: LinksInfo -> SrcSpan -> Bool -> DocName -> Html +links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice (Documented n mdl) = + (srcLink <+> wikiLink) where srcLink = let nameUrl = Map.lookup origPkg sourceMap lineUrl = Map.lookup origPkg lineMap mUrl | splice = lineUrl - -- Use the lineUrl as a backup + -- Use the lineUrl as a backup | otherwise = maybe lineUrl Just nameUrl in case mUrl of Nothing -> noHtml @@ -227,10 +250,7 @@ topDeclElem ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice names htm origMod = nameModule n origPkg = modulePackageKey origMod - -- Name must be documented, otherwise we wouldn't get here - Documented n mdl = head names - -- FIXME: is it ok to simply take the first name? - fname = case loc of - RealSrcSpan l -> unpackFS (srcSpanFile l) - UnhelpfulSpan _ -> error "topDeclElem UnhelpfulSpan" + RealSrcSpan l -> unpackFS (srcSpanFile l) + UnhelpfulSpan _ -> error "links: UnhelpfulSpan" +links _ _ _ _ = noHtml -- cgit v1.2.3 From 89fc5605c865d0e0ce5ed7e396102e678426533b Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Tue, 9 Sep 2014 01:03:27 -0500 Subject: Follow API changes in D538 Signed-off-by: Austin Seipp (cherry picked from commit d61bbc75890e4eb0ad508b9c2a27b91f691213e6) --- haddock-api/src/Haddock/Backends/Hoogle.hs | 6 +++--- haddock-api/src/Haddock/Backends/LaTeX.hs | 22 +++++++++++----------- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 26 +++++++++++++------------- haddock-api/src/Haddock/Convert.hs | 22 +++++++++++----------- haddock-api/src/Haddock/GhcUtils.hs | 14 +++----------- haddock-api/src/Haddock/Interface/Create.hs | 18 +++++++++--------- haddock-api/src/Haddock/Interface/Rename.hs | 18 +++++++++--------- haddock-api/src/Haddock/Utils.hs | 4 ++-- 8 files changed, 61 insertions(+), 69 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index dd10bb0a..fe656a4b 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -145,7 +145,7 @@ ppClass dflags x = out dflags x{tcdSigs=[]} : concatMap (ppSig dflags . addContext . unL) (tcdSigs x) where addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs - addContext (MinimalSig sig) = MinimalSig sig + addContext (MinimalSig src sig) = MinimalSig src sig addContext _ = error "expected TypeSig" f (HsForAllTy a b c con d) = HsForAllTy a b c (reL (context : unLoc con)) d @@ -189,7 +189,7 @@ ppCtor dflags dat subdocs con where f (PrefixCon args) = [typeSig name $ args ++ [resType]] f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] - f (RecCon recs) = f (PrefixCon $ map cd_fld_type (map unLoc recs)) ++ concat + f (RecCon (L _ recs)) = f (PrefixCon $ map cd_fld_type (map unLoc recs)) ++ concat [(concatMap (lookupCon dflags subdocs) (cd_fld_names r)) ++ [out dflags (map unL $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] @@ -203,7 +203,7 @@ ppCtor dflags dat subdocs con resType = case con_res con of ResTyH98 -> apps $ map (reL . HsTyVar) $ (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat] - ResTyGADT x -> x + ResTyGADT _ x -> x --------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index ee5bc861..125e1b3a 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -477,7 +477,7 @@ rDoc = maybeDoc . fmap latexStripTrailingWhitespace ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName - -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])] + -> LHsTyVarBndrs DocName -> [Located ([Located DocName], [Located DocName])] -> Bool -> LaTeX ppClassHdr summ lctxt n tvs fds unicode = keyword "class" @@ -486,13 +486,13 @@ ppClassHdr summ lctxt n tvs fds unicode = <+> ppFds fds unicode -ppFds :: [Located ([DocName], [DocName])] -> Bool -> LaTeX +ppFds :: [Located ([Located DocName], [Located DocName])] -> 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 vars1) <+> arrow unicode <+> - hsep (map ppDocName vars2) + fundep (vars1,vars2) = hsep (map (ppDocName . unLoc) vars1) <+> arrow unicode <+> + hsep (map (ppDocName . unLoc) vars2) ppClassDecl :: [DocInstance DocName] -> SrcSpan @@ -598,8 +598,8 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode (whereBit, leaders) | null cons = (empty,[]) | otherwise = case resTy of - ResTyGADT _ -> (decltt (keyword "where"), repeat empty) - _ -> (empty, (decltt (text "=") : repeat (decltt (text "|")))) + ResTyGADT _ _ -> (decltt (keyword "where"), repeat empty) + _ -> (empty, (decltt (text "=") : repeat (decltt (text "|")))) constrBit | null cons = Nothing @@ -636,7 +636,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = map (ppLParendType unicode) args)) <-> rDoc mbDoc <+> nl - RecCon fields -> + RecCon (L _ fields) -> (decltt (header_ unicode <+> ppOcc) <-> rDoc mbDoc <+> nl) $$ @@ -648,11 +648,11 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = ppLParendType unicode arg2 ]) <-> rDoc mbDoc <+> nl - ResTyGADT resTy -> case con_details con of + ResTyGADT _ resTy -> case con_details con of -- prefix & infix could also use hsConDeclArgTys if it seemed to -- simplify the code. PrefixCon args -> doGADTCon args resTy - cd@(RecCon fields) -> doGADTCon (hsConDeclArgTys cd) resTy <+> nl $$ + cd@(RecCon (L _ fields)) -> doGADTCon (hsConDeclArgTys cd) resTy <+> nl $$ doRecordFields fields InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy @@ -948,8 +948,8 @@ ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u ppr_tylit :: HsTyLit -> Bool -> LaTeX -ppr_tylit (HsNumTy n) _ = integer n -ppr_tylit (HsStrTy s) _ = text (show s) +ppr_tylit (HsNumTy _ n) _ = integer n +ppr_tylit (HsStrTy _ s) _ = text (show s) -- XXX: Ok in verbatim, but not otherwise -- XXX: Do something with Unicode parameter? diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index d24a3f04..405a13f8 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -145,7 +145,7 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) ppForAll :: LHsTyVarBndrs DocName -> Unicode -> Qualification -> Html ppForAll tvs unicode qual = - case [ppKTv n k | L _ (KindedTyVar n k) <- hsQTvBndrs tvs] of + case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- hsQTvBndrs tvs] of [] -> noHtml ts -> forallSymbol unicode <+> hsep ts +++ dot where ppKTv n k = parens $ @@ -380,7 +380,7 @@ ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt) ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName - -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])] + -> LHsTyVarBndrs DocName -> [Located ([Located DocName], [Located DocName])] -> Unicode -> Qualification -> Html ppClassHdr summ lctxt n tvs fds unicode qual = keyword "class" @@ -389,13 +389,13 @@ ppClassHdr summ lctxt n tvs fds unicode qual = <+> ppFds fds unicode qual -ppFds :: [Located ([DocName], [DocName])] -> Unicode -> Qualification -> Html +ppFds :: [Located ([Located DocName], [Located DocName])] -> 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 - ppVars = hsep . map (ppDocName qual Prefix True) + ppVars = hsep . map ((ppDocName qual Prefix True) . unLoc) ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, DocForDecl DocName)] @@ -469,7 +469,7 @@ ppClassDecl summary links instances fixities loc d subdocs -- there are different subdocs for different names in a single -- type signature? - minimalBit = case [ s | L _ (MinimalSig s) <- lsigs ] of + minimalBit = case [ s | L _ (MinimalSig _ s) <- lsigs ] of -- Miminal complete definition = every shown method And xs : _ | sort [getName n | Var (L _ n) <- xs] == sort [getName n | L _ (TypeSig ns _ _) <- lsigs, L _ n <- ns] @@ -572,7 +572,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl whereBit | null cons = noHtml | otherwise = case resTy of - ResTyGADT _ -> keyword "where" + ResTyGADT _ _ -> keyword "where" _ -> noHtml constrBit = subConstructors qual @@ -600,7 +600,7 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of PrefixCon args -> (header_ unicode qual +++ hsep (ppOcc : map (ppLParendType unicode qual) args), noHtml, noHtml) - RecCon fields -> + RecCon (L _ fields) -> (header_ unicode qual +++ ppOcc <+> char '{', doRecordFields fields, char '}') @@ -609,7 +609,7 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of ppOccInfix, ppLParendType unicode qual arg2], noHtml, noHtml) - ResTyGADT resTy -> case con_details con of + ResTyGADT _ resTy -> case con_details con of -- prefix & infix could use hsConDeclArgTys if it seemed to -- simplify the code. PrefixCon args -> (doGADTCon args resTy, noHtml, noHtml) @@ -617,7 +617,7 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of -- Constr :: (Context) => { field :: a, field2 :: b } -> Ty (a, b) -- (except each field gets its own line in docs, to match -- non-GADT records) - RecCon fields -> (ppOcc <+> dcolon unicode <+> + RecCon (L _ fields) -> (ppOcc <+> dcolon unicode <+> ppForAllCon forall_ ltvs lcontext unicode qual <+> char '{', doRecordFields fields, char '}' <+> arrow unicode <+> ppLType unicode qual resTy) @@ -682,7 +682,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field ppLParendType unicode qual arg2] <+> fixity - ResTyGADT resTy -> case con_details con of + ResTyGADT _ resTy -> case con_details con of -- prefix & infix could also use hsConDeclArgTys if it seemed to -- simplify the code. PrefixCon args -> doGADTCon args resTy @@ -690,7 +690,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy fieldPart = case con_details con of - RecCon fields -> [doRecordFields fields] + RecCon (L _ fields) -> [doRecordFields fields] _ -> [] doRecordFields fields = subFields qual @@ -907,8 +907,8 @@ ppr_mono_ty _ (HsNamedWildcardTy name) _ q = ppDocName q Prefix True name ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n ppr_tylit :: HsTyLit -> Html -ppr_tylit (HsNumTy n) = toHtml (show n) -ppr_tylit (HsStrTy s) = toHtml (show s) +ppr_tylit (HsNumTy _ n) = toHtml (show n) +ppr_tylit (HsStrTy _ s) = toHtml (show s) ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Unicode -> Qualification -> Html diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index ac7f8bd8..5cbf5f97 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -31,7 +31,7 @@ import Kind ( splitKindFunTys, synTyConResKind, isKind ) import Name import PatSyn import PrelNames (ipClassName) -import SrcLoc ( Located, noLoc, unLoc ) +import SrcLoc ( Located, noLoc, unLoc, noSrcSpan ) import TcType ( tcSplitSigmaTy ) import TyCon import Type (isStrLitTy, mkFunTys) @@ -74,9 +74,9 @@ tyThingToLHsDecl t = case t of , tcdLName = synifyName cl , tcdTyVars = synifyTyVars (classTyVars cl) , tcdFDs = map (\ (l,r) -> noLoc - (map getName l, map getName r) ) $ + (map (noLoc . getName) l, map (noLoc . getName) r) ) $ snd $ classTvsFds cl - , tcdSigs = noLoc (MinimalSig . fmap noLoc $ classMinimalDef cl) : + , tcdSigs = noLoc (MinimalSig mempty . fmap noLoc $ classMinimalDef cl) : map (noLoc . synifyIdSig DeleteTopLevelQuantification) (classMethods cl) , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature @@ -145,7 +145,7 @@ synifyTyCon coax tc DataDecl { tcdLName = synifyName tc , tcdTyVars = -- tyConTyVars doesn't work on fun/prim, but we can make them up: let mk_hs_tv realKind fakeTyVar - = noLoc $ KindedTyVar (getName fakeTyVar) + = noLoc $ KindedTyVar (noLoc (getName fakeTyVar)) (synifyKindSig realKind) in HsQTvs { hsq_kvs = [] -- No kind polymorphism , hsq_tvs = zipWith mk_hs_tv (fst (splitKindFunTys (tyConKind tc))) @@ -264,8 +264,8 @@ synifyDataCon use_gadt_syntax dc = linear_tys = zipWith (\ty bang -> let tySyn = synifyType WithinType ty src_bang = case bang of - HsUnpack {} -> HsSrcBang (Just True) True - HsStrict -> HsSrcBang (Just False) True + HsUnpack {} -> HsSrcBang Nothing (Just True) True + HsStrict -> HsSrcBang Nothing (Just False) True _ -> bang in case src_bang of HsNoBang -> tySyn @@ -278,13 +278,13 @@ synifyDataCon use_gadt_syntax dc = (dataConFieldLabels dc) linear_tys hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of (True,True) -> Left "synifyDataCon: contradiction!" - (True,False) -> return $ RecCon field_tys + (True,False) -> return $ RecCon (noLoc field_tys) (False,False) -> return $ PrefixCon linear_tys (False,True) -> case linear_tys of [a,b] -> return $ InfixCon a b _ -> Left "synifyDataCon: infix with non-2 args?" hs_res_ty = if use_gadt_syntax - then ResTyGADT (synifyType WithinType res_ty) + then ResTyGADT noSrcSpan (synifyType WithinType res_ty) else ResTyH98 -- finally we get synifyDataCon's result! in hs_arg_tys >>= @@ -312,7 +312,7 @@ synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs (kvs, tvs) = partition isKindVar ktvs synifyTyVar tv | isLiftedTypeKind kind = noLoc (UserTyVar name) - | otherwise = noLoc (KindedTyVar name (synifyKindSig kind)) + | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind)) where kind = tyVarKind tv name = getName tv @@ -383,8 +383,8 @@ synifyType s forallty@(ForAllTy _tv _ty) = synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t synifyTyLit :: TyLit -> HsTyLit -synifyTyLit (NumTyLit n) = HsNumTy n -synifyTyLit (StrTyLit s) = HsStrTy s +synifyTyLit (NumTyLit n) = HsNumTy mempty n +synifyTyLit (StrTyLit s) = HsStrTy mempty s synifyKindSig :: Kind -> LHsKind Name synifyKindSig k = synifyType WithinType k diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 416f5d71..5caefa77 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -91,8 +91,8 @@ 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 nwcs) = +filterSigNames _ orig@(MinimalSig _ _) = Just orig +filterSigNames p (TypeSig ns ty nwcs) = case filter (p . unLoc) ns of [] -> Nothing filtered -> Just (TypeSig filtered ty nwcs) @@ -169,14 +169,6 @@ before :: Located a -> Located a -> Bool before = (<) `on` getLoc -instance Foldable (GenLocated l) where - foldMap f (L _ x) = f x - - -instance Traversable (GenLocated l) where - mapM f (L l x) = (return . L l) =<< f x - traverse f (L l x) = L l <$> f x - ------------------------------------------------------------------------------- -- * NamedThing instances ------------------------------------------------------------------------------- @@ -197,7 +189,7 @@ class Parent a where instance Parent (ConDecl Name) where children con = case con_details con of - RecCon fields -> map unL $ concatMap (cd_fld_names . unL) fields + RecCon fields -> map unL $ concatMap (cd_fld_names . unL) (unL fields) _ -> [] instance Parent (TyClDecl Name) where diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 98a715a9..9ef3d1b1 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -194,8 +194,8 @@ moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name parseWarning dflags gre w = force $ case w of - DeprecatedTxt msg -> format "Deprecated: " (concatFS $ map unLoc msg) - WarningTxt msg -> format "Warning: " (concatFS $ map unLoc msg) + DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map unLoc msg) + WarningTxt _ msg -> format "Warning: " (concatFS $ map unLoc msg) where format x xs = DocWarning . DocParagraph . DocAppend (DocString x) . processDocString dflags gre $ HsDocString xs @@ -335,7 +335,7 @@ subordinates instMap decl = case decl of | c <- cons, cname <- con_names c ] fields = [ (unL n, maybeToList $ fmap unL doc, M.empty) | RecCon flds <- map con_details cons - , L _ (ConDeclField ns _ doc) <- flds + , L _ (ConDeclField ns _ doc) <- (unLoc flds) , n <- ns ] -- | Extract function argument docs from inside types. @@ -496,7 +496,7 @@ mkExportItems Just exports -> liftM concat $ mapM lookupExport exports where lookupExport (IEVar (L _ x)) = declWith x - lookupExport (IEThingAbs t) = declWith t + lookupExport (IEThingAbs (L _ t)) = declWith t lookupExport (IEThingAll (L _ t)) = declWith t lookupExport (IEThingWith (L _ t) _) = declWith t lookupExport (IEModuleContents (L _ m)) = @@ -553,7 +553,7 @@ mkExportItems L loc (TyClD cl@ClassDecl{}) -> do mdef <- liftGhcToErrMsgGhc $ minimalDef t - let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef + let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . fmap noLoc) mdef return [ mkExportDecl t (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ] @@ -745,7 +745,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices)) mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do mdef <- liftGhcToErrMsgGhc $ minimalDef name - let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef + let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . 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 @@ -785,7 +785,7 @@ extractDecl name mdl decl InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) -> let matches = [ d | L _ d <- insts , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d) - , ConDeclField { cd_fld_names = ns } <- map unLoc rec + , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) , L _ n <- ns , n == name ] @@ -818,13 +818,13 @@ extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm mdl t tvs (L _ con : rest) = case con_details con of - RecCon fields | ((n,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> + RecCon (L _ fields) | ((n,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))) []) _ -> extractRecSel nm mdl t tvs rest where matching_fields flds = [ (n,f) | f@(L _ (ConDeclField ns _ _)) <- flds, n <- ns, unLoc n == nm ] data_ty - | ResTyGADT ty <- con_res con = ty + | ResTyGADT _ ty <- con_res con = ty | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 7f69b91e..ee9f8fc4 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -250,10 +250,10 @@ renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName) renameLTyVarBndr (L loc (UserTyVar n)) = do { n' <- rename n ; return (L loc (UserTyVar n')) } -renameLTyVarBndr (L loc (KindedTyVar n kind)) +renameLTyVarBndr (L loc (KindedTyVar (L lv n) kind)) = do { n' <- rename n ; kind' <- renameLKind kind - ; return (L loc (KindedTyVar n' kind')) } + ; return (L loc (KindedTyVar (L lv n') kind')) } renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName]) renameLContext (L loc context) = do @@ -330,9 +330,9 @@ renameTyClD d = case d of where renameLFunDep (L loc (xs, ys)) = do - xs' <- mapM rename xs - ys' <- mapM rename ys - return (L loc (xs', ys')) + xs' <- mapM rename (map unLoc xs) + ys' <- mapM rename (map unLoc ys) + return (L loc (map noLoc xs', map noLoc ys')) renameLSig (L loc sig) = return . L loc =<< renameSig sig @@ -377,9 +377,9 @@ renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars , con_details = details', con_res = restype', con_doc = mbldoc' }) where - renameDetails (RecCon fields) = do + renameDetails (RecCon (L l fields)) = do fields' <- mapM renameConDeclFieldField fields - return (RecCon fields') + return (RecCon (L l fields')) renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps renameDetails (InfixCon a b) = do a' <- renameLType a @@ -387,7 +387,7 @@ renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars return (InfixCon a' b') renameResType (ResTyH98) = return ResTyH98 - renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t + renameResType (ResTyGADT l t) = return . ResTyGADT l =<< renameLType t renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName) @@ -414,7 +414,7 @@ renameSig sig = case sig of FixSig (FixitySig lnames fixity) -> do lnames' <- mapM renameL lnames return $ FixSig (FixitySig lnames' fixity) - MinimalSig s -> MinimalSig <$> traverse renameL s + MinimalSig src s -> MinimalSig src <$> traverse renameL s -- we have filtered out all other kinds of signatures in Interface.Create _ -> error "expected TypeSig" diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 9a821b2e..4fed3a1e 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -154,8 +154,8 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] case con_details d of PrefixCon _ -> Just d RecCon fields - | all field_avail fields -> Just d - | otherwise -> Just (d { con_details = PrefixCon (field_types (map unL fields)) }) + | all field_avail (unL fields) -> Just d + | otherwise -> Just (d { con_details = PrefixCon (field_types (map unL (unL fields))) }) -- if we have *all* the field names available, then -- keep the record declaration. Otherwise degrade to -- a constructor declaration. This isn't quite right, but -- cgit v1.2.3 From 10437c8cfe3524eee7e1cc297cd6ae7dff16dbb3 Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Thu, 26 Mar 2015 16:31:40 +0000 Subject: Remove now redundant imports --- haddock-api/src/Haddock/Backends/Xhtml.hs | 1 - haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 1 - haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs | 2 -- haddock-api/src/Haddock/Backends/Xhtml/Themes.hs | 2 -- haddock-api/src/Haddock/GhcUtils.hs | 1 - haddock-api/src/Haddock/Interface/LexParseRn.hs | 1 - haddock-api/src/Haddock/Interface/ParseModuleHeader.hs | 1 - haddock-api/src/Haddock/InterfaceFile.hs | 1 - 8 files changed, 10 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 65a7e6c4..948ef641 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -36,7 +36,6 @@ import Haddock.GhcUtils import Control.Monad ( when, unless ) import Data.Char ( toUpper ) -import Data.Functor ( (<$>) ) import Data.List ( sortBy, groupBy, intercalate, isPrefixOf ) import Data.Maybe import System.FilePath hiding ( () ) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 405a13f8..952d29c9 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -27,7 +27,6 @@ import Haddock.GhcUtils import Haddock.Types import Haddock.Doc (combineDocumentation) -import Control.Applicative import Data.List ( intersperse, sort ) import qualified Data.Map as Map import Data.Maybe diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index 96d734eb..e807eb94 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -19,8 +19,6 @@ module Haddock.Backends.Xhtml.DocMarkup ( docElement, docSection, docSection_, ) where -import Control.Applicative ((<$>)) - import Data.List import Haddock.Backends.Xhtml.Names import Haddock.Backends.Xhtml.Utils diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs index 79b093ec..10d6ab10 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs @@ -18,7 +18,6 @@ module Haddock.Backends.Xhtml.Themes ( import Haddock.Options -import Control.Applicative import Control.Monad (liftM) import Data.Char (toLower) import Data.Either (lefts, rights) @@ -206,4 +205,3 @@ liftEither f = either Left (Right . f) concatEither :: [Either a [b]] -> Either a [b] concatEither = liftEither concat . sequenceEither - diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 5caefa77..ce4ca38a 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -16,7 +16,6 @@ module Haddock.GhcUtils where -import Control.Applicative ( (<$>) ) import Control.Arrow import Data.Function diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 35abf8a6..614e606b 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -18,7 +18,6 @@ module Haddock.Interface.LexParseRn , processModuleHeader ) where -import Control.Applicative import Data.IntSet (toList) import Data.List import Documentation.Haddock.Doc (metaDocConcat) diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs index d92e8b2a..e7d2a085 100644 --- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs +++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs @@ -11,7 +11,6 @@ ----------------------------------------------------------------------------- module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where -import Control.Applicative ((<$>)) import Control.Monad (mplus) import Data.Char import DynFlags diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index b0df5491..4b39d315 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -25,7 +25,6 @@ import Haddock.Utils hiding (out) import Control.Monad import Data.Array -import Data.Functor ((<$>)) import Data.IORef import Data.List import qualified Data.Map as Map -- cgit v1.2.3 From bb0ecbb4053a593cc8ef80a277c4ef40b13998d5 Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Fri, 27 Mar 2015 01:14:11 +0000 Subject: Fix Hoogle display of constructors Fixes #361 --- CHANGES | 2 ++ haddock-api/src/Haddock/Backends/Hoogle.hs | 5 ++++- 2 files changed, 6 insertions(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/CHANGES b/CHANGES index 419a7be7..15ab0a24 100644 --- a/CHANGES +++ b/CHANGES @@ -35,6 +35,8 @@ Changes in version 2.16.0 * Don't default to type constructors for out-of-scope names (#253 and #375) + * Fix Hoogle display of constructors (#361) + Changes in version 2.15.0 * Always read in prologue files as UTF8 (#286 and Cabal #1721) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index fe656a4b..ef86958e 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -198,7 +198,10 @@ ppCtor dflags dat subdocs con apps = foldl1 (\x y -> reL $ HsAppTy x y) typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (makeExplicit $ unL $ funs flds) - name = out dflags $ map unL $ con_names con + + -- We print the constructors as comma-separated list. See GHC + -- docs for con_names on why it is a list to begin with. + name = showSDocUnqual dflags . interpp'SP . map unL $ con_names con resType = case con_res con of ResTyH98 -> apps $ map (reL . HsTyVar) $ -- cgit v1.2.3 From fdc4e8a1cafdb5accb8cef05c60579df9d438fd7 Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Fri, 27 Mar 2015 01:45:18 +0000 Subject: Fully qualify names in Hoogle instances output Closes #263 --- haddock-api/src/Haddock/Backends/Hoogle.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index ef86958e..3ffa582f 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -95,13 +95,15 @@ dropComment (x:xs) = x : dropComment xs dropComment [] = [] -out :: Outputable a => DynFlags -> a -> String -out dflags = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual dflags . ppr +outWith :: Outputable a => (SDoc -> String) -> a -> [Char] +outWith p = f . unwords . map (dropWhile isSpace) . lines . p . ppr where f xs | " " `isPrefixOf` xs = f $ drop 19 xs f (x:xs) = x : f xs f [] = [] +out :: Outputable a => DynFlags -> a -> String +out dflags = outWith $ showSDocUnqual dflags operator :: String -> String operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")" @@ -156,8 +158,8 @@ ppClass dflags x = out dflags x{tcdSigs=[]} : ppInstance :: DynFlags -> ClsInst -> [String] -ppInstance dflags x = [dropComment $ out dflags x] - +ppInstance dflags x = + [dropComment $ outWith (showSDocForUser dflags alwaysQualify) x] ppSynonym :: DynFlags -> TyClDecl Name -> [String] ppSynonym dflags x = [out dflags x] -- cgit v1.2.3 From 1a65ec54ce8516dc2d09af3b1d20fedd21e64ad6 Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Fri, 27 Mar 2015 02:43:55 +0000 Subject: Output method documentation in Hoogle backend One thing of note is that we no longer preserve grouping of methods and print each method on its own line. We could preserve it if no documentation is present for any methods in the group if someone asks for it though. Fixes #259 --- CHANGES | 2 ++ haddock-api/src/Haddock/Backends/Hoogle.hs | 32 ++++++++++++++++++++---------- 2 files changed, 23 insertions(+), 11 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/CHANGES b/CHANGES index f436cf64..7aba49ae 100644 --- a/CHANGES +++ b/CHANGES @@ -39,6 +39,8 @@ Changes in version 2.16.0 * Fully qualify names in Hoogle instances output (#263) + * Output method documentation in Hoogle backend (#259) + Changes in version 2.15.0 * Always read in prologue files as UTF8 (#286 and Cabal #1721) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 3ffa582f..12dfc1f5 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -109,6 +109,8 @@ operator :: String -> String operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")" operator x = x +commaSeparate :: Outputable a => DynFlags -> [a] -> String +commaSeparate dflags = showSDocUnqual dflags . interpp'SP --------------------------------------------------------------------- -- How to print each export @@ -121,30 +123,38 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl where f (TyClD d@DataDecl{}) = ppData dflags d subdocs f (TyClD d@SynDecl{}) = ppSynonym dflags d - f (TyClD d@ClassDecl{}) = ppClass dflags d + f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ [] f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ [] f (SigD sig) = ppSig dflags sig f _ = [] ppExport _ _ = [] - -ppSig :: DynFlags -> Sig Name -> [String] -ppSig dflags (TypeSig names sig _) - = [operator prettyNames ++ " :: " ++ outHsType dflags typ] +ppSigWithDoc :: DynFlags -> Sig Name -> [(Name, DocForDecl Name)] -> [String] +ppSigWithDoc dflags (TypeSig names sig _) subdocs + = concatMap mkDocSig names where - prettyNames = intercalate ", " $ map (out dflags) names + mkDocSig n = concatMap (ppDocumentation dflags) (getDoc n) + ++ [mkSig n] + mkSig n = operator (out dflags n) ++ " :: " ++ outHsType dflags typ + + getDoc :: Located Name -> [Documentation Name] + getDoc n = maybe [] (return . fst) (lookup (unL n) subdocs) + typ = case unL sig of HsForAllTy Explicit a b c d -> HsForAllTy Implicit a b c d HsForAllTy Qualified a b c d -> HsForAllTy Implicit a b c d x -> x -ppSig _ _ = [] +ppSigWithDoc _ _ _ = [] + +ppSig :: DynFlags -> Sig Name -> [String] +ppSig dflags x = ppSigWithDoc dflags x [] -- note: does not yet output documentation for class methods -ppClass :: DynFlags -> TyClDecl Name -> [String] -ppClass dflags x = out dflags x{tcdSigs=[]} : - concatMap (ppSig dflags . addContext . unL) (tcdSigs x) +ppClass :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] +ppClass dflags x subdocs = out dflags x{tcdSigs=[]} : + concatMap (flip (ppSigWithDoc dflags) subdocs . addContext . unL) (tcdSigs x) where addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs addContext (MinimalSig src sig) = MinimalSig src sig @@ -203,7 +213,7 @@ ppCtor dflags dat subdocs con -- We print the constructors as comma-separated list. See GHC -- docs for con_names on why it is a list to begin with. - name = showSDocUnqual dflags . interpp'SP . map unL $ con_names con + name = commaSeparate dflags . map unL $ con_names con resType = case con_res con of ResTyH98 -> apps $ map (reL . HsTyVar) $ -- cgit v1.2.3 From e49d473bf33fa374c60462ad178ac539f026c3ff Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Fri, 27 Mar 2015 03:04:21 +0000 Subject: Don't print instance safety information in Hoogle Fixes #168 --- CHANGES | 2 ++ haddock-api/src/Haddock/Backends/Hoogle.hs | 13 +++++++++++-- 2 files changed, 13 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/CHANGES b/CHANGES index 7aba49ae..af90b4fc 100644 --- a/CHANGES +++ b/CHANGES @@ -41,6 +41,8 @@ Changes in version 2.16.0 * Output method documentation in Hoogle backend (#259) + * Don't print instance safety information in Hoogle (#168) + Changes in version 2.15.0 * Always read in prologue files as UTF8 (#286 and Cabal #1721) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 12dfc1f5..914e3466 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -15,7 +15,8 @@ module Haddock.Backends.Hoogle ( ppHoogle ) where - +import BasicTypes (OverlapFlag(..), OverlapMode(..)) +import InstEnv (ClsInst(..)) import Haddock.GhcUtils import Haddock.Types hiding (Version) import Haddock.Utils hiding (out) @@ -169,7 +170,15 @@ ppClass dflags x subdocs = out dflags x{tcdSigs=[]} : ppInstance :: DynFlags -> ClsInst -> [String] ppInstance dflags x = - [dropComment $ outWith (showSDocForUser dflags alwaysQualify) x] + [dropComment $ outWith (showSDocForUser dflags alwaysQualify) cls] + where + -- As per #168, we don't want safety information about the class + -- in Hoogle output. The easiest way to achieve this is to set the + -- 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 + , isSafeOverlap = False } } ppSynonym :: DynFlags -> TyClDecl Name -> [String] ppSynonym dflags x = [out dflags x] -- cgit v1.2.3 From 5d04e313cc52ecf88b0fd0b3d0d39ce6a8dc7406 Mon Sep 17 00:00:00 2001 From: watashi Date: Sun, 26 Apr 2015 16:35:28 -0700 Subject: Do not insert anchor for section headings in contents box --- .gitignore | 3 + .../src/Haddock/Backends/Xhtml/DocMarkup.hs | 5 +- html-test/ref/Bug387.html | 111 +++++++++++++++++++++ html-test/src/Bug387.hs | 12 +++ 4 files changed, 130 insertions(+), 1 deletion(-) create mode 100644 html-test/ref/Bug387.html create mode 100644 html-test/src/Bug387.hs (limited to 'haddock-api/src/Haddock/Backends') diff --git a/.gitignore b/.gitignore index 6b8d26e0..2d3f4516 100644 --- a/.gitignore +++ b/.gitignore @@ -12,3 +12,6 @@ /doc/configure tags TAGS + +.cabal-sandbox +cabal.sandbox.config diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index e807eb94..c23f3f08 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -62,7 +62,10 @@ parHtmlMarkup qual insertAnchors ppId = Markup { then anchor ! [href url] << fromMaybe url mLabel else toHtml $ fromMaybe url mLabel, - markupAName = \aname -> namedAnchor aname << "", + markupAName = \aname + -> if insertAnchors + then namedAnchor aname << "" + else noHtml, markupPic = \(Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)), markupProperty = pre . toHtml, markupExample = examplesToHtml, diff --git a/html-test/ref/Bug387.html b/html-test/ref/Bug387.html new file mode 100644 index 00000000..2d2009b1 --- /dev/null +++ b/html-test/ref/Bug387.html @@ -0,0 +1,111 @@ + +Bug387
Safe HaskellSafe

Bug387

Synopsis

Section1

test1 :: Int

Section2

test2 :: Int

diff --git a/html-test/src/Bug387.hs b/html-test/src/Bug387.hs new file mode 100644 index 00000000..d9fed34e --- /dev/null +++ b/html-test/src/Bug387.hs @@ -0,0 +1,12 @@ +module Bug387 + ( -- * Section1#a:section1# + test1 + -- * Section2#a:section2# + , test2 + ) where + +test1 :: Int +test1 = 223 + +test2 :: Int +test2 = 42 -- cgit v1.2.3 From bf31846b9f7280b5e75f09e91ca18c4ced37af08 Mon Sep 17 00:00:00 2001 From: Murray Campbell Date: Sun, 26 Apr 2015 13:49:01 -0700 Subject: Change ModuleTree Node to carry PackageKey and SourcePackageId to resolve #385 Signed-off-by: Austin Seipp (cherry picked from commit 2380f07c430c525b205ce2eae6dab23c8388d899) --- haddock-api/src/Haddock/Backends/Xhtml.hs | 4 +-- haddock-api/src/Haddock/ModuleTree.hs | 41 +++++++++++++++++-------------- 2 files changed, 24 insertions(+), 21 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 948ef641..90cb9fa4 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -288,7 +288,7 @@ mkNodeList qual ss p ts = case ts of mkNode :: Qualification -> [String] -> String -> ModuleTree -> Html -mkNode qual ss p (Node s leaf pkg short ts) = +mkNode qual ss p (Node s leaf pkg srcPkg short ts) = htmlModule <+> shortDescr +++ htmlPkg +++ subtree where modAttrs = case (ts, leaf) of @@ -312,7 +312,7 @@ mkNode qual ss p (Node s leaf pkg short ts) = mdl = intercalate "." (reverse (s:ss)) shortDescr = maybe noHtml (origDocToHtml qual) short - htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) pkg + htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) srcPkg subtree = mkNodeList qual (s:ss) p ts ! collapseSection p True "" diff --git a/haddock-api/src/Haddock/ModuleTree.hs b/haddock-api/src/Haddock/ModuleTree.hs index eec1342e..2f731214 100644 --- a/haddock-api/src/Haddock/ModuleTree.hs +++ b/haddock-api/src/Haddock/ModuleTree.hs @@ -15,41 +15,44 @@ module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where import Haddock.Types ( MDoc ) import GHC ( Name ) -import Module ( Module, moduleNameString, moduleName, modulePackageKey ) +import Module ( Module, moduleNameString, moduleName, modulePackageKey, packageKeyString ) import DynFlags ( DynFlags ) import Packages ( lookupPackage ) import PackageConfig ( sourcePackageIdString ) -data ModuleTree = Node String Bool (Maybe String) (Maybe (MDoc Name)) [ModuleTree] +data ModuleTree = Node String Bool (Maybe String) (Maybe String) (Maybe (MDoc Name)) [ModuleTree] mkModuleTree :: DynFlags -> Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree] mkModuleTree dflags showPkgs mods = - foldr fn [] [ (splitModule mdl, modPkg mdl, short) | (mdl, short) <- mods ] + foldr fn [] [ (splitModule mdl, modPkg mdl, modSrcPkg mdl, short) | (mdl, short) <- mods ] where - modPkg mod_ | showPkgs = fmap sourcePackageIdString - (lookupPackage dflags (modulePackageKey mod_)) + modPkg mod_ | showPkgs = Just (packageKeyString (modulePackageKey mod_)) | otherwise = Nothing - fn (mod_,pkg,short) = addToTrees mod_ pkg short - - -addToTrees :: [String] -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -> [ModuleTree] -addToTrees [] _ _ ts = ts -addToTrees ss pkg short [] = mkSubTree ss pkg short -addToTrees (s1:ss) pkg short (t@(Node s2 leaf node_pkg node_short subs) : ts) - | s1 > s2 = t : addToTrees (s1:ss) pkg short ts - | s1 == s2 = Node s2 (leaf || null ss) this_pkg this_short (addToTrees ss pkg short subs) : ts - | otherwise = mkSubTree (s1:ss) pkg short ++ t : ts + modSrcPkg mod_ | showPkgs = fmap sourcePackageIdString + (lookupPackage dflags (modulePackageKey mod_)) + | otherwise = Nothing + fn (mod_,pkg,srcPkg,short) = addToTrees mod_ pkg srcPkg short + + +addToTrees :: [String] -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -> [ModuleTree] +addToTrees [] _ _ _ ts = ts +addToTrees ss pkg srcPkg short [] = mkSubTree ss pkg srcPkg short +addToTrees (s1:ss) pkg srcPkg short (t@(Node s2 leaf node_pkg node_srcPkg node_short subs) : ts) + | s1 > s2 = t : addToTrees (s1:ss) pkg srcPkg short ts + | s1 == s2 = Node s2 (leaf || null ss) this_pkg this_srcPkg this_short (addToTrees ss pkg srcPkg short subs) : ts + | otherwise = mkSubTree (s1:ss) pkg srcPkg short ++ t : ts where this_pkg = if null ss then pkg else node_pkg + this_srcPkg = if null ss then srcPkg else node_srcPkg this_short = if null ss then short else node_short -mkSubTree :: [String] -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -mkSubTree [] _ _ = [] -mkSubTree [s] pkg short = [Node s True pkg short []] -mkSubTree (s:ss) pkg short = [Node s (null ss) Nothing Nothing (mkSubTree ss pkg short)] +mkSubTree :: [String] -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] +mkSubTree [] _ _ _ = [] +mkSubTree [s] pkg srcPkg short = [Node s True pkg srcPkg short []] +mkSubTree (s:ss) pkg srcPkg short = [Node s (null ss) Nothing Nothing Nothing (mkSubTree ss pkg srcPkg short)] splitModule :: Module -> [String] -- cgit v1.2.3 From 3d11080b9f56a901593b6237d674d617a429e64a Mon Sep 17 00:00:00 2001 From: jpmoresmau Date: Sun, 17 May 2015 15:31:03 +0200 Subject: Attach to instance location the name that has the same location file Fixes #383 --- haddock-api/src/Haddock/Backends/LaTeX.hs | 4 ++-- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 6 +++--- haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 24 +++++++++++----------- .../src/Haddock/Interface/AttachInstances.hs | 23 ++++++++++++++++----- haddock-api/src/Haddock/Interface/Rename.hs | 5 +++-- haddock-api/src/Haddock/Types.hs | 2 +- 6 files changed, 39 insertions(+), 25 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 125e1b3a..2febd5ae 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -544,14 +544,14 @@ ppDocInstances unicode (i : rest) (is, rest') = spanWith isUndocdInstance rest isUndocdInstance :: DocInstance a -> Maybe (InstHead a) -isUndocdInstance (L _ i,Nothing) = Just i +isUndocdInstance (i,Nothing,_) = Just i isUndocdInstance _ = Nothing -- | Print a possibly commented instance. The instance header is printed inside -- an 'argBox'. The comment is printed to the right of the box in normal comment -- style. ppDocInstance :: Bool -> DocInstance DocName -> LaTeX -ppDocInstance unicode (L _ instHead, doc) = +ppDocInstance unicode (instHead, doc, _) = declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX $ fmap _doc doc) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 952d29c9..df85a492 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -497,12 +497,12 @@ ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppS ppInstances :: LinksInfo -> [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html ppInstances links instances baseName unicode qual - = subInstances qual instName links True baseName (map instDecl instances) + = subInstances qual instName links True (map instDecl instances) -- force Splice = True to use line URLs where instName = getOccString $ getName baseName - instDecl :: DocInstance DocName -> (SubDecl,SrcSpan) - instDecl (L l inst, maybeDoc) = ((instHead inst, maybeDoc, []),l) + instDecl :: DocInstance DocName -> (SubDecl,Located DocName) + instDecl (inst, maybeDoc,l) = ((instHead inst, maybeDoc, []),l) instHead (n, ks, ts, ClassInst cs) = ppContextNoLocs cs unicode qual <+> ppAppNameTypes n ks ts unicode qual instHead (n, ks, ts, TypeInst rhs) = keyword "type" diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index 923958a7..e686d648 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -44,7 +44,6 @@ import Haddock.Backends.Xhtml.Types import Haddock.Backends.Xhtml.Utils import Haddock.Types import Haddock.Utils (makeAnchorId) - import qualified Data.Map as Map import Text.XHtml hiding ( name, title, p, quote ) @@ -148,20 +147,21 @@ subTable qual decls = Just $ table << aboves (concatMap subRow decls) docElement td << fmap (docToHtml Nothing qual) mdoc) : map (cell . (td <<)) subs + -- | Sub table with source information (optional). -subTableSrc :: Qualification -> LinksInfo -> Bool -> DocName -> [(SubDecl,SrcSpan)] -> Maybe Html -subTableSrc _ _ _ _ [] = Nothing -subTableSrc qual lnks splice dn decls = Just $ table << aboves (concatMap subRow decls) +subTableSrc :: Qualification -> LinksInfo -> Bool -> [(SubDecl,Located DocName)] -> Maybe Html +subTableSrc _ _ _ [] = Nothing +subTableSrc qual lnks splice decls = Just $ table << aboves (concatMap subRow decls) where - subRow ((decl, mdoc, subs),loc) = + subRow ((decl, mdoc, subs),L loc dn) = (td ! [theclass "src"] << decl - <+> linkHtml loc + <+> linkHtml loc dn <-> docElement td << fmap (docToHtml Nothing qual) mdoc ) : map (cell . (td <<)) subs - linkHtml loc@(RealSrcSpan _) = links lnks loc splice dn - linkHtml _ = noHtml + linkHtml loc@(RealSrcSpan _) dn = links lnks loc splice dn + linkHtml _ _ = noHtml subBlock :: [Html] -> Maybe Html subBlock [] = Nothing @@ -191,12 +191,12 @@ subEquations qual = divSubDecls "equations" "Equations" . subTable qual -- | Generate sub table for instance declarations, with source subInstances :: Qualification -> String -- ^ Class name, used for anchor generation - -> LinksInfo -> Bool -> DocName - -> [(SubDecl,SrcSpan)] -> Html -subInstances qual nm lnks splice dn = maybe noHtml wrap . instTable + -> LinksInfo -> Bool + -> [(SubDecl,Located DocName)] -> Html +subInstances qual nm lnks splice = maybe noHtml wrap . instTable where wrap = (subSection <<) . (subCaption +++) - instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice dn + instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice subSection = thediv ! [theclass "subs instances"] subCaption = paragraph ! collapseControl id_ True "caption" << "Instances" id_ = makeAnchorId $ "i:" ++ nm diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 37203d63..fc530507 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -38,6 +38,7 @@ import MonadUtils (liftIO) import Name import Outputable (text, sep, (<+>)) import PrelNames +import SrcLoc import TcRnDriver (tcRnGetInfo) import TcType (tcSplitSigmaTy) import TyCon @@ -68,11 +69,11 @@ attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> Ghc (ExportItem Name) attachToExportItem expInfo iface ifaceMap instIfaceMap export = case attachFixities export of - e@ExportDecl { expItemDecl = L _ (TyClD d) } -> do + e@ExportDecl { expItemDecl = L eSpan (TyClD d) } -> do mb_info <- getAllInfo (tcdName d) insts <- case mb_info of Just (_, _, cls_instances, fam_instances) -> - let fam_insts = [ (L (getSrcSpan n) $ synifyFamInst i opaque, doc) + let fam_insts = [ (synifyFamInst i opaque, doc,spanNameE n (synifyFamInst i opaque) (L eSpan (tcdName d)) ) | i <- sortBy (comparing instFam) fam_instances , let n = getName i , let doc = instLookup instDocMap n iface ifaceMap instIfaceMap @@ -80,14 +81,14 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export = , not $ any (isTypeHidden expInfo) (fi_tys i) , let opaque = isTypeHidden expInfo (fi_rhs i) ] - cls_insts = [ (L (getSrcSpan n) $ synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap) + cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, spanName n (synifyInstHead i) (L eSpan (tcdName d))) | let is = [ (instanceHead' i, getName i) | i <- cls_instances ] , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is , not $ isInstanceHidden expInfo cls tys ] -- fam_insts but with failing type fams filtered out - cleanFamInsts = [ (L l fi, n) | (L l (Right fi), n) <- fam_insts ] - famInstErrs = [ errm | (L _ (Left errm), _) <- fam_insts ] + cleanFamInsts = [ (fi, n, L l r) | (Right fi, n, L l (Right r)) <- fam_insts ] + famInstErrs = [ errm | (Left errm, _, _) <- fam_insts ] in do dfs <- getDynFlags let mkBug = (text "haddock-bug:" <+>) . text @@ -106,6 +107,18 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export = ] } attachFixities e = e + -- spanName: attach the location to the name that is the same file as the instance location + spanName s (clsn,_,_,_) (L instL instn) = + let s1 = getSrcSpan s + sn = if srcSpanFileName_maybe s1 == srcSpanFileName_maybe instL + then instn + else clsn + in L (getSrcSpan s) sn + -- spanName on Either + spanNameE s (Left e) _ = L (getSrcSpan s) (Left e) + spanNameE s (Right ok) linst = + let L l r = spanName s ok linst + in L l (Right r) instLookup :: (InstalledInterface -> Map.Map Name a) -> Name diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index ee9f8fc4..1a559764 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -498,10 +498,11 @@ renameExportItem item = case item of decl' <- renameLDecl decl doc' <- renameDocForDecl doc subs' <- mapM renameSub subs - instances' <- forM instances $ \(L l inst, idoc) -> do + instances' <- forM instances $ \(inst, idoc, L l n) -> do inst' <- renameInstHead inst + n' <- rename n idoc' <- mapM renameDoc idoc - return (L l inst', idoc') + return (inst', idoc',L l n') fixities' <- forM fixities $ \(name, fixity) -> do name' <- lookupRn name return (name', fixity) diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index f9cf6e17..14995098 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -300,7 +300,7 @@ instance OutputableBndr a => Outputable (InstType a) where ppr (DataInst a) = text "DataInst" <+> ppr a -- | An instance head that may have documentation and a source location. -type DocInstance name = (Located (InstHead name), Maybe (MDoc name)) +type DocInstance name = (InstHead name, Maybe (MDoc name), Located name) -- | The head of an instance. Consists of a class name, a list of kind -- parameters, a list of type parameters and an instance type -- cgit v1.2.3 From a476b251e363b3b0ed30c75cf72a19fc275d6440 Mon Sep 17 00:00:00 2001 From: Phil Ruffwind Date: Fri, 12 Jun 2015 12:59:24 -0400 Subject: Fix alignment of Source links in instance table in Firefox Due to a Firefox bug [1], a combination of 'whitespace: nowrap' on the parent element with 'float: right' on the inner element can cause the floated element to be displaced downwards for no apparent reason. To work around this, the left side is wrapped in its own and set to 'float: left'. As a precautionary measure to prevent the parent element from collapsing entirely, we also add the classic "clearfix" hack. The latter is not strictly needed but it helps prevent bugs if the layout is altered again in the future. Fixes #384. Remark: line 159 of src/Haddock/Backends/Xhtml/Layout.hs was indented to prevent confusion over the operator precedence of (<+>) vs (<<). [1]: https://bugzilla.mozilla.org/show_bug.cgi?id=488725 --- haddock-api/resources/html/Ocean.std-theme/ocean.css | 13 +++++++++++++ haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 5 +++-- 2 files changed, 16 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/resources/html/Ocean.std-theme/ocean.css b/haddock-api/resources/html/Ocean.std-theme/ocean.css index ef652a21..1110b407 100644 --- a/haddock-api/resources/html/Ocean.std-theme/ocean.css +++ b/haddock-api/resources/html/Ocean.std-theme/ocean.css @@ -416,6 +416,14 @@ div#style-menu-holder { margin-top: 0.8em; } +.clearfix:after { + clear: both; + content: " "; + display: block; + height: 0; + visibility: hidden; +} + .subs dl { margin: 0; } @@ -455,6 +463,11 @@ div#style-menu-holder { margin-left: 1em; } +/* Workaround for bug in Firefox (issue #384) */ +.inst-left { + float: left; +} + .top p.src { border-top: 1px solid #ccc; } diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index e686d648..914a7a7e 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -154,8 +154,9 @@ subTableSrc _ _ _ [] = Nothing subTableSrc qual lnks splice decls = Just $ table << aboves (concatMap subRow decls) where subRow ((decl, mdoc, subs),L loc dn) = - (td ! [theclass "src"] << decl - <+> linkHtml loc dn + (td ! [theclass "src clearfix"] << + (thespan ! [theclass "inst-left"] << decl) + <+> linkHtml loc dn <-> docElement td << fmap (docToHtml Nothing qual) mdoc ) -- cgit v1.2.3 From ce0237fa8f482a64dc8ea3ec409a1482ac89e6ac Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 4 Jun 2015 19:27:34 +0200 Subject: Create scaffolding for Haskell source parser module. --- haddock-api/haddock-api.cabal | 1 + .../src/Haddock/Backends/Hyperlinker/Parser.hs | 36 ++++++++++++++++++++++ 2 files changed, 37 insertions(+) create mode 100644 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 3bc22263..b90e3bff 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -79,6 +79,7 @@ library Haddock.Backends.LaTeX Haddock.Backends.HaddockDB Haddock.Backends.Hoogle + Haddock.Backends.Hyperlinker.Parser Haddock.ModuleTree Haddock.Types Haddock.Doc diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs new file mode 100644 index 00000000..11a92b57 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -0,0 +1,36 @@ +module Haddock.Backends.Hyperlinker.Parser (parse) where + +data Token = Token + { tkType :: TokenType + , tkValue :: String + , tkSpan :: Span + } + +data Position = Position + { posRow :: !Int + , posCol :: !Int + } + +data Span = Span + { spStart :: Position + , spEnd :: Position + } + +data TokenType + = Identifier + | Comment + | Whitespace + | Operator + | Symbol + +parse :: String -> [Token] +parse = tokenize . tag . chunk + +chunk :: String -> [String] +chunk = undefined + +tag :: [String] -> [(Span, String)] +tag = undefined + +tokenize :: [(Span, String)] -> [Token] +tokenize = undefined -- cgit v1.2.3 From e17f62506ecf20d61781c610d6fbb5f3c8cd132e Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 4 Jun 2015 19:59:27 +0200 Subject: Implement function for tagging parsed chunks with source spans. --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 11a92b57..4bcc0c8a 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -30,7 +30,14 @@ chunk :: String -> [String] chunk = undefined tag :: [String] -> [(Span, String)] -tag = undefined +tag = + reverse . snd . foldl aux (Position 1 1, []) + where + aux (pos, cs) c = + let pos' = if c == "\n" + then pos { posRow = posRow pos + 1, posCol = 1 } + else pos { posCol = posCol pos + length c } + in (pos', (Span pos pos', c):cs) tokenize :: [(Span, String)] -> [Token] tokenize = undefined -- cgit v1.2.3 From 413f7f322cd174e2ba4116dbf53c1b3c0d6a4f77 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 4 Jun 2015 21:10:26 +0200 Subject: Implement simple string chunking based on HsColour library. --- .../src/Haddock/Backends/Hyperlinker/Parser.hs | 28 +++++++++++++++++++++- 1 file changed, 27 insertions(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 4bcc0c8a..4e0d7382 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -1,5 +1,8 @@ module Haddock.Backends.Hyperlinker.Parser (parse) where +import Data.Char +import Data.List + data Token = Token { tkType :: TokenType , tkValue :: String @@ -27,7 +30,30 @@ parse :: String -> [Token] parse = tokenize . tag . chunk chunk :: String -> [String] -chunk = undefined +chunk [] = [] +chunk str@(c:_) + | isSpace c = chunk' $ span isSpace str +chunk str + | "--" `isPrefixOf` str = chunk' $ span (not . (== '\n')) str + | "{-" `isPrefixOf` str = chunk' $ chunkComment 0 str + | otherwise = chunk' $ head $ lex str + +chunk' :: (String, String) -> [String] +chunk' (c, rest) = c:(chunk rest) + +chunkComment :: Int -> String -> (String, String) +chunkComment _ [] = ("", "") +chunkComment depth ('{':'-':str) = + let (c, rest) = chunkComment (depth + 1) str + in ("{-" ++ c, rest) +chunkComment depth ('-':'}':str) + | depth == 1 = ("-}", str) + | otherwise = + let (c, rest) = chunkComment (depth - 1) str + in ("-}" ++ c, rest) +chunkComment depth (e:str) = + let (c, rest) = chunkComment depth str + in (e:c, rest) tag :: [String] -> [(Span, String)] tag = -- cgit v1.2.3 From 6fb8d5abbcc92f5155fdc9596ca1c87fe87f6187 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 4 Jun 2015 23:21:17 +0200 Subject: Create basic token classification method. --- .../src/Haddock/Backends/Hyperlinker/Parser.hs | 104 +++++++++++++++++++-- 1 file changed, 98 insertions(+), 6 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 4e0d7382..be6b7ce5 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -20,11 +20,18 @@ data Span = Span } data TokenType - = Identifier - | Comment - | Whitespace - | Operator - | Symbol + = TkIdentifier + | TkKeyword + | TkString + | TkChar + | TkNumber + | TkOperator + | TkGlyph + | TkSpecial + | TkSpace + | TkComment + | TkCpp + | TkUnknown parse :: String -> [Token] parse = tokenize . tag . chunk @@ -66,4 +73,89 @@ tag = in (pos', (Span pos pos', c):cs) tokenize :: [(Span, String)] -> [Token] -tokenize = undefined +tokenize = + map aux + where + aux (sp, str) = Token + { tkType = classify str + , tkValue = str + , tkSpan = sp + } + +classify :: String -> TokenType +classify (c:_) + | isSpace c = TkSpace + | isDigit c = TkNumber + | c `elem` special = TkSpecial + | c == '#' = TkCpp + | c == '"' = TkString + | c == '\'' = TkChar +classify str + | str `elem` keywords = TkKeyword + | str `elem` glyphs = TkGlyph + | all (`elem` symbols) str = TkOperator + | "--" `isPrefixOf` str = TkComment + | "{-" `isPrefixOf` str = TkComment + | isIdentifier str = TkIdentifier + | otherwise = TkUnknown + +keywords :: [String] +keywords = + [ "as" + , "case" + , "class" + , "data" + , "default" + , "deriving" + , "do" + , "else" + , "hiding" + , "if" + , "import" + , "in" + , "infix" + , "infixl" + , "infixr" + , "instance" + , "let" + , "module" + , "newtype" + , "of" + , "qualified" + , "then" + , "type" + , "where" + , "forall" + , "mdo" + ] + +glyphs :: [String] +glyphs = + [ ".." + , ":" + , "::" + , "=" + , "\\" + , "|" + , "<-" + , "->" + , "@" + , "~" + , "~#" + , "=>" + , "-" + , "!" + ] + +special :: [Char] +special = "()[]{},;`" + +-- TODO: Add support for any Unicode symbol or punctuation. +-- source: http://stackoverflow.com/questions/10548170/what-characters-are-permitted-for-haskell-operators +symbols :: [Char] +symbols = "!#$%&*+./<=>?@\\^|-~:" + +isIdentifier :: String -> Bool +isIdentifier (c:str) + | isLetter c = all (\c' -> isAlphaNum c' || c == '\'') str +isIdentifier _ = False -- cgit v1.2.3 From 57d4c9cff1d60f7dd0f8dafae5537218b63da90f Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 5 Jun 2015 00:07:52 +0200 Subject: Adapt source span tagging to work with current whitespace handling. --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index be6b7ce5..53ff1f65 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -67,10 +67,13 @@ tag = reverse . snd . foldl aux (Position 1 1, []) where aux (pos, cs) c = - let pos' = if c == "\n" - then pos { posRow = posRow pos + 1, posCol = 1 } - else pos { posCol = posCol pos + length c } - in (pos', (Span pos pos', c):cs) + let pos' = move pos c + in (pos', ((Span pos pos', c):cs)) + move pos str@(c:_) + | isSpace c = foldl move' pos str + move pos str = pos { posCol = posCol pos + length str } + move' pos '\n' = pos { posRow = posRow pos + 1, posCol = 1 } + move' pos _ = pos { posCol = posCol pos + 1 } tokenize :: [(Span, String)] -> [Token] tokenize = -- cgit v1.2.3 From c7ecc590090d7f1a4ce8e6d0233c41350202a4bd Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 5 Jun 2015 00:16:15 +0200 Subject: Add record accessors to exports of hyperlinker parser module. --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 53ff1f65..4130ab6c 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -1,4 +1,9 @@ -module Haddock.Backends.Hyperlinker.Parser (parse) where +module Haddock.Backends.Hyperlinker.Parser + ( parse + , tkType, tkValue, tkSpan + , posRow, posCol + , spStart, spEnd + ) where import Data.Char import Data.List -- cgit v1.2.3 From 7b607883d0cea7a795275a2484a33bd89a3b4fc6 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 5 Jun 2015 11:56:01 +0200 Subject: Make parser module export all types and associated accessors. --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 4130ab6c..7a162f6d 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -1,8 +1,7 @@ module Haddock.Backends.Hyperlinker.Parser ( parse - , tkType, tkValue, tkSpan - , posRow, posCol - , spStart, spEnd + , Token(..), TokenType(..) + , Position(..), Span(..) ) where import Data.Char -- cgit v1.2.3 From 5e904cb1c3d769d5b99d459838b4b5368c8c1fb7 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 5 Jun 2015 12:59:10 +0200 Subject: Create simple HTML renderer for parsed source file. --- haddock-api/haddock-api.cabal | 3 ++- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 26 ++++++++++++++++++++++ 2 files changed, 28 insertions(+), 1 deletion(-) create mode 100644 haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index b90e3bff..6c6dc810 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -57,6 +57,8 @@ library exposed-modules: Documentation.Haddock + Haddock.Backends.Hyperlinker.Parser + Haddock.Backends.Hyperlinker.Renderer other-modules: Haddock @@ -79,7 +81,6 @@ library Haddock.Backends.LaTeX Haddock.Backends.HaddockDB Haddock.Backends.Hoogle - Haddock.Backends.Hyperlinker.Parser Haddock.ModuleTree Haddock.Types Haddock.Doc diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs new file mode 100644 index 00000000..eaf5b37b --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -0,0 +1,26 @@ +module Haddock.Backends.Hyperlinker.Renderer where + +import Haddock.Backends.Hyperlinker.Parser + +import Data.Monoid +import Text.XHtml + +render :: [Token] -> Html +render = body . pre . foldr (<>) noHtml . map renderToken + +renderToken :: Token -> Html +renderToken (Token t v _) = thespan (toHtml v) ! tokenAttrs t + +tokenAttrs :: TokenType -> [HtmlAttr] +tokenAttrs TkIdentifier = [theclass "hs-identifier"] +tokenAttrs TkKeyword = [theclass "hs-keyword"] +tokenAttrs TkString = [theclass "hs-string"] +tokenAttrs TkChar = [theclass "hs-char"] +tokenAttrs TkNumber = [theclass "hs-number"] +tokenAttrs TkOperator = [theclass "hs-operator"] +tokenAttrs TkGlyph = [theclass "hs-glyph"] +tokenAttrs TkSpecial = [theclass "hs-special"] +tokenAttrs TkSpace = [] +tokenAttrs TkComment = [theclass "hs-comment"] +tokenAttrs TkCpp = [theclass "hs-cpp"] +tokenAttrs TkUnknown = [] -- cgit v1.2.3 From 1a43f35e2dacc9837f9762fd211d63ae6cc7b4a3 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 5 Jun 2015 13:58:47 +0200 Subject: Add support for specifying the CSS file path in HTML source renderer. --- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 45 ++++++++++++++-------- 1 file changed, 30 insertions(+), 15 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index eaf5b37b..9ebb8707 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -3,24 +3,39 @@ module Haddock.Backends.Hyperlinker.Renderer where import Haddock.Backends.Hyperlinker.Parser import Data.Monoid -import Text.XHtml +import Text.XHtml (Html, HtmlAttr, (!)) +import qualified Text.XHtml as Html -render :: [Token] -> Html -render = body . pre . foldr (<>) noHtml . map renderToken +render :: Maybe FilePath -> [Token] -> Html +render css tokens = header css <> body tokens -renderToken :: Token -> Html -renderToken (Token t v _) = thespan (toHtml v) ! tokenAttrs t +body :: [Token] -> Html +body = Html.body . Html.pre . mconcat . map token + +header :: Maybe FilePath -> Html +header Nothing = Html.noHtml +header (Just css) = + Html.header $ Html.thelink Html.noHtml ! attrs + where + attrs = + [ Html.rel "stylesheet" + , Html.href css + , Html.thetype "text/css" + ] + +token :: Token -> Html +token (Token t v _) = Html.thespan (Html.toHtml v) ! tokenAttrs t tokenAttrs :: TokenType -> [HtmlAttr] -tokenAttrs TkIdentifier = [theclass "hs-identifier"] -tokenAttrs TkKeyword = [theclass "hs-keyword"] -tokenAttrs TkString = [theclass "hs-string"] -tokenAttrs TkChar = [theclass "hs-char"] -tokenAttrs TkNumber = [theclass "hs-number"] -tokenAttrs TkOperator = [theclass "hs-operator"] -tokenAttrs TkGlyph = [theclass "hs-glyph"] -tokenAttrs TkSpecial = [theclass "hs-special"] +tokenAttrs TkIdentifier = [Html.theclass "hs-identifier"] +tokenAttrs TkKeyword = [Html.theclass "hs-keyword"] +tokenAttrs TkString = [Html.theclass "hs-string"] +tokenAttrs TkChar = [Html.theclass "hs-char"] +tokenAttrs TkNumber = [Html.theclass "hs-number"] +tokenAttrs TkOperator = [Html.theclass "hs-operator"] +tokenAttrs TkGlyph = [Html.theclass "hs-glyph"] +tokenAttrs TkSpecial = [Html.theclass "hs-special"] tokenAttrs TkSpace = [] -tokenAttrs TkComment = [theclass "hs-comment"] -tokenAttrs TkCpp = [theclass "hs-cpp"] +tokenAttrs TkComment = [Html.theclass "hs-comment"] +tokenAttrs TkCpp = [Html.theclass "hs-cpp"] tokenAttrs TkUnknown = [] -- cgit v1.2.3 From 01a2e7c5ab873c0041624a6ec0b0a54eb7da60cc Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 5 Jun 2015 14:39:28 +0200 Subject: Fix identifier recognition in Haskell source parser. --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 7a162f6d..9d58728f 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -163,6 +163,9 @@ symbols :: [Char] symbols = "!#$%&*+./<=>?@\\^|-~:" isIdentifier :: String -> Bool -isIdentifier (c:str) - | isLetter c = all (\c' -> isAlphaNum c' || c == '\'') str +isIdentifier (s:str) + | (isLower' s || isUpper s) && all isAlphaNum' str = True + where + isLower' c = isLower c || c == '_' + isAlphaNum' c = isAlphaNum c || c == '_' || c == '\'' isIdentifier _ = False -- cgit v1.2.3 From ffd0e8028f15f3616f1b3eaaf98459c0c75c6313 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 5 Jun 2015 14:56:59 +0200 Subject: Fix comment recognition in Haskell source parser. --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 9d58728f..29edb4c3 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -90,6 +90,9 @@ tokenize = } classify :: String -> TokenType +classify str + | "--" `isPrefixOf` str = TkComment + | "{-" `isPrefixOf` str = TkComment classify (c:_) | isSpace c = TkSpace | isDigit c = TkNumber @@ -101,8 +104,6 @@ classify str | str `elem` keywords = TkKeyword | str `elem` glyphs = TkGlyph | all (`elem` symbols) str = TkOperator - | "--" `isPrefixOf` str = TkComment - | "{-" `isPrefixOf` str = TkComment | isIdentifier str = TkIdentifier | otherwise = TkUnknown -- cgit v1.2.3 From e5bd5d39550692f936c973637f8ec8d314919359 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 5 Jun 2015 15:12:40 +0200 Subject: Add support for recognizing compiler pragmas in source parser. --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 2 ++ haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 1 + 2 files changed, 3 insertions(+) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 29edb4c3..0e1ad5b2 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -35,6 +35,7 @@ data TokenType | TkSpace | TkComment | TkCpp + | TkPragma | TkUnknown parse :: String -> [Token] @@ -92,6 +93,7 @@ tokenize = classify :: String -> TokenType classify str | "--" `isPrefixOf` str = TkComment + | "{-#" `isPrefixOf` str = TkPragma | "{-" `isPrefixOf` str = TkComment classify (c:_) | isSpace c = TkSpace diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 9ebb8707..39d7d183 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -38,4 +38,5 @@ tokenAttrs TkSpecial = [Html.theclass "hs-special"] tokenAttrs TkSpace = [] tokenAttrs TkComment = [Html.theclass "hs-comment"] tokenAttrs TkCpp = [Html.theclass "hs-cpp"] +tokenAttrs TkPragma = [Html.theclass "hs-pragma"] tokenAttrs TkUnknown = [] -- cgit v1.2.3 From d275f87c4cfa1e8da042f70659331121afa9a15c Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 6 Jun 2015 19:27:37 +0200 Subject: Create scaffolding of module for associating tokens with AST names. --- haddock-api/haddock-api.cabal | 1 + haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 20 ++++++++++++++++++++ 2 files changed, 21 insertions(+) create mode 100644 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 6c6dc810..109e5f95 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -59,6 +59,7 @@ library Documentation.Haddock Haddock.Backends.Hyperlinker.Parser Haddock.Backends.Hyperlinker.Renderer + Haddock.Backends.Hyperlinker.Ast other-modules: Haddock diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs new file mode 100644 index 00000000..abd3ca2b --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -0,0 +1,20 @@ +module Haddock.Backends.Hyperlinker.Ast where + +import qualified GHC + +import Haddock.Backends.Hyperlinker.Parser + +data RichToken = RichToken + { rtkToken :: Token + , rtkName :: Maybe GHC.Name + } + +enrich :: GHC.RenamedSource -> [Token] -> [RichToken] +enrich src = + map $ \token -> RichToken + { rtkToken = token + , rtkName = lookupName src $ tkSpan token + } + +lookupName :: GHC.RenamedSource -> Span -> Maybe GHC.Name +lookupName = undefined -- cgit v1.2.3 From 74de0021815f0642a89017fbb1fbdf18064cb5ea Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 6 Jun 2015 19:36:53 +0200 Subject: Implement utility method for extracting variable identifiers from AST. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index abd3ca2b..62c0d439 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -1,6 +1,10 @@ +{-# LANGUAGE RankNTypes #-} + module Haddock.Backends.Hyperlinker.Ast where import qualified GHC +import Data.Data +import Control.Applicative import Haddock.Backends.Hyperlinker.Parser @@ -18,3 +22,15 @@ enrich src = lookupName :: GHC.RenamedSource -> Span -> Maybe GHC.Name lookupName = undefined + +everything :: (r -> r -> r) -> (forall a. Data a => a -> r) + -> (forall a. Data a => a -> r) +everything k f x = foldl k (f x) (gmapQ (everything k f) x) + +variables :: GHC.RenamedSource -> [(GHC.SrcSpan, GHC.Name)] +variables = + everything (<|>) var + where + var term = case cast term of + (Just (GHC.L sspan (GHC.HsVar sid))) -> pure (sspan, sid) + _ -> empty -- cgit v1.2.3 From d06a2b502e7909dff517a7c825e772b493bade24 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 6 Jun 2015 20:04:02 +0200 Subject: Create simple mechanism for associating tokens with AST names. --- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 30 +++++++++++++++++----- 1 file changed, 23 insertions(+), 7 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 62c0d439..031ddd5c 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -2,11 +2,13 @@ module Haddock.Backends.Hyperlinker.Ast where +import Haddock.Backends.Hyperlinker.Parser + import qualified GHC -import Data.Data -import Control.Applicative -import Haddock.Backends.Hyperlinker.Parser +import Control.Applicative +import Data.Data +import Data.Maybe data RichToken = RichToken { rtkToken :: Token @@ -17,20 +19,34 @@ enrich :: GHC.RenamedSource -> [Token] -> [RichToken] enrich src = map $ \token -> RichToken { rtkToken = token - , rtkName = lookupName src $ tkSpan token + , rtkName = lookupBySpan (tkSpan token) nameMap } + where + nameMap = variables src + +type NameMap = [(GHC.SrcSpan, GHC.Name)] -lookupName :: GHC.RenamedSource -> Span -> Maybe GHC.Name -lookupName = undefined +lookupBySpan :: Span -> NameMap -> Maybe GHC.Name +lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst) everything :: (r -> r -> r) -> (forall a. Data a => a -> r) -> (forall a. Data a => a -> r) everything k f x = foldl k (f x) (gmapQ (everything k f) x) -variables :: GHC.RenamedSource -> [(GHC.SrcSpan, GHC.Name)] +variables :: GHC.RenamedSource -> NameMap variables = everything (<|>) var where var term = case cast term of (Just (GHC.L sspan (GHC.HsVar sid))) -> pure (sspan, sid) _ -> empty + +matches :: Span -> GHC.SrcSpan -> Bool +matches tspan (GHC.RealSrcSpan aspan) + | rs && cs && re && ce = True + where + rs = (posRow . spStart) tspan == GHC.srcSpanStartLine aspan + cs = (posCol . spStart) tspan == GHC.srcSpanStartCol aspan + re = (posRow . spEnd) tspan == GHC.srcSpanEndLine aspan + ce = (posCol . spEnd) tspan == GHC.srcSpanStartLine aspan +matches _ _ = False -- cgit v1.2.3 From cb3ece1a493eb444ccb61b6ad3c74e922184b63e Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 6 Jun 2015 21:43:15 +0200 Subject: Add dummy support for hyperlinking named tokens. --- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 23 +++++++++++++++++++--- 1 file changed, 20 insertions(+), 3 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 39d7d183..32d2c863 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -1,16 +1,20 @@ module Haddock.Backends.Hyperlinker.Renderer where import Haddock.Backends.Hyperlinker.Parser +import Haddock.Backends.Hyperlinker.Ast + +import qualified GHC +import qualified Name as GHC import Data.Monoid import Text.XHtml (Html, HtmlAttr, (!)) import qualified Text.XHtml as Html -render :: Maybe FilePath -> [Token] -> Html +render :: Maybe FilePath -> [RichToken] -> Html render css tokens = header css <> body tokens -body :: [Token] -> Html -body = Html.body . Html.pre . mconcat . map token +body :: [RichToken] -> Html +body = Html.body . Html.pre . mconcat . map richToken header :: Maybe FilePath -> Html header Nothing = Html.noHtml @@ -23,6 +27,10 @@ header (Just css) = , Html.thetype "text/css" ] +richToken :: RichToken -> Html +richToken (RichToken t Nothing) = token t +richToken (RichToken t (Just name)) = Html.anchor (token t) ! nameAttrs name + token :: Token -> Html token (Token t v _) = Html.thespan (Html.toHtml v) ! tokenAttrs t @@ -40,3 +48,12 @@ tokenAttrs TkComment = [Html.theclass "hs-comment"] tokenAttrs TkCpp = [Html.theclass "hs-cpp"] tokenAttrs TkPragma = [Html.theclass "hs-pragma"] tokenAttrs TkUnknown = [] + +nameAttrs :: GHC.Name -> [HtmlAttr] +nameAttrs name = + [ Html.href (maybe "" id mmod ++ "#" ++ ident) + , Html.theclass "varid-reference" + ] + where + mmod = GHC.moduleNameString . GHC.moduleName <$> GHC.nameModule_maybe name + ident = GHC.occNameString . GHC.nameOccName $ name -- cgit v1.2.3 From 7d43b8a8c9538692beb91a4c3a485e82b40559ab Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 6 Jun 2015 22:37:28 +0200 Subject: Fix span matcher bug causing wrong items being hyperlinked. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 031ddd5c..7d88b7fb 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -48,5 +48,5 @@ matches tspan (GHC.RealSrcSpan aspan) rs = (posRow . spStart) tspan == GHC.srcSpanStartLine aspan cs = (posCol . spStart) tspan == GHC.srcSpanStartCol aspan re = (posRow . spEnd) tspan == GHC.srcSpanEndLine aspan - ce = (posCol . spEnd) tspan == GHC.srcSpanStartLine aspan + ce = (posCol . spEnd) tspan == GHC.srcSpanEndCol aspan matches _ _ = False -- cgit v1.2.3 From 9a51a6d3f686736354e26137363ea979a5e38076 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 6 Jun 2015 23:40:36 +0200 Subject: Constrain elements exported by hyperlinker modules. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 5 ++++- haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 2 +- 2 files changed, 5 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 7d88b7fb..a24945ea 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -1,6 +1,9 @@ {-# LANGUAGE RankNTypes #-} -module Haddock.Backends.Hyperlinker.Ast where +module Haddock.Backends.Hyperlinker.Ast + ( enrich + , RichToken(..) + ) where import Haddock.Backends.Hyperlinker.Parser diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 32d2c863..3c6fe14f 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -1,4 +1,4 @@ -module Haddock.Backends.Hyperlinker.Renderer where +module Haddock.Backends.Hyperlinker.Renderer (render) where import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Ast -- cgit v1.2.3 From 666af8d2f29c05d22bb5930d115c42509528bb90 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sun, 7 Jun 2015 21:35:55 +0200 Subject: Add support for type token recognition. --- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 35 +++++++++--- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 64 ++++++++++++++-------- 2 files changed, 68 insertions(+), 31 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index a24945ea..0ccf010b 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -2,7 +2,7 @@ module Haddock.Backends.Hyperlinker.Ast ( enrich - , RichToken(..) + , RichToken(..), RichTokenType(..), TokenDetails(..) ) where import Haddock.Backends.Hyperlinker.Parser @@ -15,33 +15,52 @@ import Data.Maybe data RichToken = RichToken { rtkToken :: Token - , rtkName :: Maybe GHC.Name + , rtkDetails :: Maybe TokenDetails } +data TokenDetails = TokenDetails + { rtkType :: RichTokenType + , rtkName :: GHC.Name + } + +data RichTokenType + = RtkVar + | RtkType + enrich :: GHC.RenamedSource -> [Token] -> [RichToken] enrich src = map $ \token -> RichToken { rtkToken = token - , rtkName = lookupBySpan (tkSpan token) nameMap + , rtkDetails = lookupBySpan (tkSpan token) detailsMap } where - nameMap = variables src + detailsMap = variables src ++ types src -type NameMap = [(GHC.SrcSpan, GHC.Name)] +type DetailsMap = [(GHC.SrcSpan, TokenDetails)] -lookupBySpan :: Span -> NameMap -> Maybe GHC.Name +lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst) everything :: (r -> r -> r) -> (forall a. Data a => a -> r) -> (forall a. Data a => a -> r) everything k f x = foldl k (f x) (gmapQ (everything k f) x) -variables :: GHC.RenamedSource -> NameMap +variables :: GHC.RenamedSource -> DetailsMap variables = everything (<|>) var where var term = case cast term of - (Just (GHC.L sspan (GHC.HsVar sid))) -> pure (sspan, sid) + (Just (GHC.L sspan (GHC.HsVar name))) -> + pure (sspan, TokenDetails RtkVar name) + _ -> empty + +types :: GHC.RenamedSource -> DetailsMap +types = + everything (<|>) ty + where + ty term = case cast term of + (Just (GHC.L sspan (GHC.HsTyVar name))) -> + pure (sspan, TokenDetails RtkType name) _ -> empty matches :: Span -> GHC.SrcSpan -> Bool diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 3c6fe14f..c2bca438 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -6,10 +6,14 @@ import Haddock.Backends.Hyperlinker.Ast import qualified GHC import qualified Name as GHC +import Data.List import Data.Monoid + import Text.XHtml (Html, HtmlAttr, (!)) import qualified Text.XHtml as Html +type StyleClass = String + render :: Maybe FilePath -> [RichToken] -> Html render css tokens = header css <> body tokens @@ -28,29 +32,43 @@ header (Just css) = ] richToken :: RichToken -> Html -richToken (RichToken t Nothing) = token t -richToken (RichToken t (Just name)) = Html.anchor (token t) ! nameAttrs name - -token :: Token -> Html -token (Token t v _) = Html.thespan (Html.toHtml v) ! tokenAttrs t - -tokenAttrs :: TokenType -> [HtmlAttr] -tokenAttrs TkIdentifier = [Html.theclass "hs-identifier"] -tokenAttrs TkKeyword = [Html.theclass "hs-keyword"] -tokenAttrs TkString = [Html.theclass "hs-string"] -tokenAttrs TkChar = [Html.theclass "hs-char"] -tokenAttrs TkNumber = [Html.theclass "hs-number"] -tokenAttrs TkOperator = [Html.theclass "hs-operator"] -tokenAttrs TkGlyph = [Html.theclass "hs-glyph"] -tokenAttrs TkSpecial = [Html.theclass "hs-special"] -tokenAttrs TkSpace = [] -tokenAttrs TkComment = [Html.theclass "hs-comment"] -tokenAttrs TkCpp = [Html.theclass "hs-cpp"] -tokenAttrs TkPragma = [Html.theclass "hs-pragma"] -tokenAttrs TkUnknown = [] - -nameAttrs :: GHC.Name -> [HtmlAttr] -nameAttrs name = +richToken (RichToken tok Nothing) = + tokenSpan tok ! attrs + where + attrs = [ multiclass . tokenStyle . tkType $ tok ] +richToken (RichToken tok (Just det)) = + Html.anchor content ! (anchorAttrs . rtkName) det + where + content = tokenSpan tok ! [ multiclass style] + style = (tokenStyle . tkType) tok ++ (richTokenStyle . rtkType) det + +tokenSpan :: Token -> Html +tokenSpan = Html.thespan . Html.toHtml . tkValue + +richTokenStyle :: RichTokenType -> [StyleClass] +richTokenStyle RtkVar = ["hs-var"] +richTokenStyle RtkType = ["hs-type"] + +tokenStyle :: TokenType -> [StyleClass] +tokenStyle TkIdentifier = ["hs-identifier"] +tokenStyle TkKeyword = ["hs-keyword"] +tokenStyle TkString = ["hs-string"] +tokenStyle TkChar = ["hs-char"] +tokenStyle TkNumber = ["hs-number"] +tokenStyle TkOperator = ["hs-operator"] +tokenStyle TkGlyph = ["hs-glyph"] +tokenStyle TkSpecial = ["hs-special"] +tokenStyle TkSpace = [] +tokenStyle TkComment = ["hs-comment"] +tokenStyle TkCpp = ["hs-cpp"] +tokenStyle TkPragma = ["hs-pragma"] +tokenStyle TkUnknown = [] + +multiclass :: [StyleClass] -> HtmlAttr +multiclass = Html.theclass . intercalate " " + +anchorAttrs :: GHC.Name -> [HtmlAttr] +anchorAttrs name = [ Html.href (maybe "" id mmod ++ "#" ++ ident) , Html.theclass "varid-reference" ] -- cgit v1.2.3 From 70656933ca6935bde0a00310f37440e02c3f21ff Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 8 Jun 2015 00:13:12 +0200 Subject: Add support for binding token recognition. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 20 +++++++++++++++++++- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 1 + 2 files changed, 20 insertions(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 0ccf010b..19ebbe77 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} module Haddock.Backends.Hyperlinker.Ast ( enrich @@ -26,6 +27,7 @@ data TokenDetails = TokenDetails data RichTokenType = RtkVar | RtkType + | RtkBind enrich :: GHC.RenamedSource -> [Token] -> [RichToken] enrich src = @@ -34,7 +36,7 @@ enrich src = , rtkDetails = lookupBySpan (tkSpan token) detailsMap } where - detailsMap = variables src ++ types src + detailsMap = variables src ++ types src ++ binds src type DetailsMap = [(GHC.SrcSpan, TokenDetails)] @@ -45,6 +47,9 @@ everything :: (r -> r -> r) -> (forall a. Data a => a -> r) -> (forall a. Data a => a -> r) everything k f x = foldl k (f x) (gmapQ (everything k f) x) +combine :: Alternative f => (forall a. Data a => a -> f r) -> (forall a. Data a => a -> f r) -> (forall a. Data a => a -> f r) +combine f g x = f x <|> g x + variables :: GHC.RenamedSource -> DetailsMap variables = everything (<|>) var @@ -63,6 +68,19 @@ types = pure (sspan, TokenDetails RtkType name) _ -> empty +binds :: GHC.RenamedSource -> DetailsMap +binds = + everything (<|>) (fun `combine` pat) + where + fun term = case cast term of + (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) -> + pure (sspan, TokenDetails RtkBind name) + _ -> empty + pat term = case cast term of + (Just (GHC.L sspan (GHC.VarPat name))) -> + pure (sspan, TokenDetails RtkBind name) + _ -> empty + matches :: Span -> GHC.SrcSpan -> Bool matches tspan (GHC.RealSrcSpan aspan) | rs && cs && re && ce = True diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index c2bca438..57851c22 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -48,6 +48,7 @@ tokenSpan = Html.thespan . Html.toHtml . tkValue richTokenStyle :: RichTokenType -> [StyleClass] richTokenStyle RtkVar = ["hs-var"] richTokenStyle RtkType = ["hs-type"] +richTokenStyle RtkBind = ["hs-bind"] tokenStyle :: TokenType -> [StyleClass] tokenStyle TkIdentifier = ["hs-identifier"] -- cgit v1.2.3 From 21984e4cfcc076ce8cbee934028a1b37aaca930b Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 8 Jun 2015 00:54:58 +0200 Subject: Implement go-to-definition mechanism for local bindings. --- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 30 +++++++++++++++++----- 1 file changed, 23 insertions(+), 7 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 57851c22..995e24e6 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -5,6 +5,7 @@ import Haddock.Backends.Hyperlinker.Ast import qualified GHC import qualified Name as GHC +import qualified Unique as GHC import Data.List import Data.Monoid @@ -37,7 +38,7 @@ richToken (RichToken tok Nothing) = where attrs = [ multiclass . tokenStyle . tkType $ tok ] richToken (RichToken tok (Just det)) = - Html.anchor content ! (anchorAttrs . rtkName) det + internalAnchor det . hyperlink det $ content where content = tokenSpan tok ! [ multiclass style] style = (tokenStyle . tkType) tok ++ (richTokenStyle . rtkType) det @@ -48,7 +49,7 @@ tokenSpan = Html.thespan . Html.toHtml . tkValue richTokenStyle :: RichTokenType -> [StyleClass] richTokenStyle RtkVar = ["hs-var"] richTokenStyle RtkType = ["hs-type"] -richTokenStyle RtkBind = ["hs-bind"] +richTokenStyle RtkBind = [] tokenStyle :: TokenType -> [StyleClass] tokenStyle TkIdentifier = ["hs-identifier"] @@ -68,11 +69,26 @@ tokenStyle TkUnknown = [] multiclass :: [StyleClass] -> HtmlAttr multiclass = Html.theclass . intercalate " " -anchorAttrs :: GHC.Name -> [HtmlAttr] -anchorAttrs name = - [ Html.href (maybe "" id mmod ++ "#" ++ ident) - , Html.theclass "varid-reference" - ] +internalAnchor :: TokenDetails -> Html -> Html +internalAnchor (TokenDetails RtkBind name) content = + Html.anchor content ! [ Html.name $ internalAnchorIdent name ] +internalAnchor _ content = content + +internalAnchorIdent :: GHC.Name -> String +internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique + +hyperlink :: TokenDetails -> Html -> Html +hyperlink (TokenDetails _ name) = if GHC.isInternalName name + then internalHyperlink name + else externalHyperlink name + +internalHyperlink :: GHC.Name -> Html -> Html +internalHyperlink name content = + Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] + +externalHyperlink :: GHC.Name -> Html -> Html +externalHyperlink name content = + Html.anchor content ! [ Html.href $ maybe "" id mmod ++ "#" ++ ident ] where mmod = GHC.moduleNameString . GHC.moduleName <$> GHC.nameModule_maybe name ident = GHC.occNameString . GHC.nameOccName $ name -- cgit v1.2.3 From c84a3ef8ebca5fb396ee9dc8cb2654f7891f5c0e Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 8 Jun 2015 14:12:58 +0200 Subject: Implement module export- and import-list item hyperlinking. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 19ebbe77..2325aa21 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -36,7 +36,12 @@ enrich src = , rtkDetails = lookupBySpan (tkSpan token) detailsMap } where - detailsMap = variables src ++ types src ++ binds src + detailsMap = concat + [ variables src + , types src + , binds src + , imports src + ] type DetailsMap = [(GHC.SrcSpan, TokenDetails)] @@ -81,6 +86,19 @@ binds = pure (sspan, TokenDetails RtkBind name) _ -> empty +imports :: GHC.RenamedSource -> DetailsMap +imports = + everything (<|>) ie + 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.IEThingWith t vs)) -> [typ t] ++ map var vs + _ -> empty + typ (GHC.L sspan name) = (sspan, TokenDetails RtkType name) + var (GHC.L sspan name) = (sspan, TokenDetails RtkVar name) + matches :: Span -> GHC.SrcSpan -> Bool matches tspan (GHC.RealSrcSpan aspan) | rs && cs && re && ce = True -- cgit v1.2.3 From fab61bb80c2d8059e91aece7677cf349cd34a8db Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 8 Jun 2015 15:05:35 +0200 Subject: Fix span matching to allow parenthesized operators hyperlinking. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 2325aa21..05d6a52e 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -101,10 +101,10 @@ imports = matches :: Span -> GHC.SrcSpan -> Bool matches tspan (GHC.RealSrcSpan aspan) - | rs && cs && re && ce = True + | saspan <= stspan && etspan <= easpan = True where - rs = (posRow . spStart) tspan == GHC.srcSpanStartLine aspan - cs = (posCol . spStart) tspan == GHC.srcSpanStartCol aspan - re = (posRow . spEnd) tspan == GHC.srcSpanEndLine aspan - ce = (posCol . spEnd) tspan == GHC.srcSpanEndCol aspan + stspan = (posRow . spStart $ tspan, posCol . spStart $ tspan) + etspan = (posRow . spEnd $ tspan, posCol . spEnd $ tspan) + saspan = (GHC.srcSpanStartLine aspan, GHC.srcSpanStartCol aspan) + easpan = (GHC.srcSpanEndLine aspan, GHC.srcSpanEndCol aspan) matches _ _ = False -- cgit v1.2.3 From b31513dbacb48102b4c5d2fd6de1982161d81fae Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 8 Jun 2015 15:16:06 +0200 Subject: Fix weird hyperlinking of parenthesized operators. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 7 ++++++- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 1 + 2 files changed, 7 insertions(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 05d6a52e..2749096e 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -33,7 +33,7 @@ enrich :: GHC.RenamedSource -> [Token] -> [RichToken] enrich src = map $ \token -> RichToken { rtkToken = token - , rtkDetails = lookupBySpan (tkSpan token) detailsMap + , rtkDetails = enrichToken token detailsMap } where detailsMap = concat @@ -45,6 +45,11 @@ enrich src = type DetailsMap = [(GHC.SrcSpan, TokenDetails)] +enrichToken :: Token -> DetailsMap -> Maybe TokenDetails +enrichToken (Token typ _ spn) dm + | typ `elem` [TkIdentifier, TkOperator] = lookupBySpan spn dm +enrichToken _ _ = Nothing + lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 0e1ad5b2..70a69279 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -37,6 +37,7 @@ data TokenType | TkCpp | TkPragma | TkUnknown + deriving (Eq) parse :: String -> [Token] parse = tokenize . tag . chunk -- cgit v1.2.3 From 162b02ed6f50709ea203bf7706eee5804e455419 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 12 Jun 2015 01:03:13 +0200 Subject: Add support for type declaration anchors. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 21 ++++++++++++++++----- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 14 +++++++++++--- 2 files changed, 27 insertions(+), 8 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 2749096e..39bbacf5 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -28,6 +28,7 @@ data RichTokenType = RtkVar | RtkType | RtkBind + | RtkDecl enrich :: GHC.RenamedSource -> [Token] -> [RichToken] enrich src = @@ -36,11 +37,12 @@ enrich src = , rtkDetails = enrichToken token detailsMap } where - detailsMap = concat - [ variables src - , types src - , binds src - , imports src + detailsMap = concatMap ($ src) + [ variables + , types + , binds + , imports + , decls ] type DetailsMap = [(GHC.SrcSpan, TokenDetails)] @@ -91,6 +93,15 @@ binds = pure (sspan, TokenDetails RtkBind name) _ -> empty +decls :: GHC.RenamedSource -> DetailsMap +decls (group, _, _, _) = concatMap ($ group) + [ map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds + ] + where + typ (GHC.L _ t) = + let (GHC.L sspan name) = GHC.tcdLName t + in (sspan, TokenDetails RtkDecl name) + imports :: GHC.RenamedSource -> DetailsMap imports = everything (<|>) ie diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 995e24e6..b7cc5aeb 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -38,7 +38,7 @@ richToken (RichToken tok Nothing) = where attrs = [ multiclass . tokenStyle . tkType $ tok ] richToken (RichToken tok (Just det)) = - internalAnchor det . hyperlink det $ content + externalAnchor det . internalAnchor det . hyperlink det $ content where content = tokenSpan tok ! [ multiclass style] style = (tokenStyle . tkType) tok ++ (richTokenStyle . rtkType) det @@ -49,7 +49,7 @@ tokenSpan = Html.thespan . Html.toHtml . tkValue richTokenStyle :: RichTokenType -> [StyleClass] richTokenStyle RtkVar = ["hs-var"] richTokenStyle RtkType = ["hs-type"] -richTokenStyle RtkBind = [] +richTokenStyle _ = [] tokenStyle :: TokenType -> [StyleClass] tokenStyle TkIdentifier = ["hs-identifier"] @@ -69,11 +69,19 @@ tokenStyle TkUnknown = [] multiclass :: [StyleClass] -> HtmlAttr multiclass = Html.theclass . intercalate " " +externalAnchor :: TokenDetails -> Html -> Html +externalAnchor (TokenDetails RtkDecl name) content = + Html.anchor content ! [ Html.name $ externalAnchorIdent name ] +externalAnchor _ content = content + internalAnchor :: TokenDetails -> Html -> Html internalAnchor (TokenDetails RtkBind name) content = Html.anchor content ! [ Html.name $ internalAnchorIdent name ] internalAnchor _ content = content +externalAnchorIdent :: GHC.Name -> String +externalAnchorIdent = GHC.occNameString . GHC.nameOccName + internalAnchorIdent :: GHC.Name -> String internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique @@ -91,4 +99,4 @@ externalHyperlink name content = Html.anchor content ! [ Html.href $ maybe "" id mmod ++ "#" ++ ident ] where mmod = GHC.moduleNameString . GHC.moduleName <$> GHC.nameModule_maybe name - ident = GHC.occNameString . GHC.nameOccName $ name + ident = externalAnchorIdent name -- cgit v1.2.3 From c6786894f71809ecfa377a44beab0771a3bc7985 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 12 Jun 2015 01:36:49 +0200 Subject: Add support for top-level function declaration anchors. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 39bbacf5..cb9508ef 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -40,9 +40,9 @@ enrich src = detailsMap = concatMap ($ src) [ variables , types + , decls , binds , imports - , decls ] type DetailsMap = [(GHC.SrcSpan, TokenDetails)] @@ -96,11 +96,16 @@ binds = decls :: GHC.RenamedSource -> DetailsMap decls (group, _, _, _) = concatMap ($ group) [ map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds + , everything (<|>) fun ] where typ (GHC.L _ t) = let (GHC.L sspan name) = GHC.tcdLName t in (sspan, TokenDetails RtkDecl name) + fun term = case cast term of + (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) + | GHC.isExternalName name -> pure (sspan, TokenDetails RtkDecl name) + _ -> empty imports :: GHC.RenamedSource -> DetailsMap imports = -- cgit v1.2.3 From 1064953c6590c05303c6cbd2230b9e13d3ba1376 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 12 Jun 2015 10:57:30 +0200 Subject: Fix external anchors to contain HTML file extension. --- haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index b7cc5aeb..99a0f337 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -96,7 +96,7 @@ internalHyperlink name content = externalHyperlink :: GHC.Name -> Html -> Html externalHyperlink name content = - Html.anchor content ! [ Html.href $ maybe "" id mmod ++ "#" ++ ident ] + Html.anchor content ! [ Html.href $ maybe "" id mmod ++ ".html#" ++ ident ] where mmod = GHC.moduleNameString . GHC.moduleName <$> GHC.nameModule_maybe name ident = externalAnchorIdent name -- cgit v1.2.3 From 60db14903e01f4c26f179230c7b6190a7b99fb51 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 17 Jun 2015 21:49:46 +0200 Subject: Refactor the way AST names are handled within detailed tokens. --- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 37 +++++++++++----------- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 17 ++++++---- 2 files changed, 29 insertions(+), 25 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index cb9508ef..3c07ff3c 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -3,7 +3,7 @@ module Haddock.Backends.Hyperlinker.Ast ( enrich - , RichToken(..), RichTokenType(..), TokenDetails(..) + , RichToken(..), TokenDetails(..), rtkName ) where import Haddock.Backends.Hyperlinker.Parser @@ -19,16 +19,17 @@ data RichToken = RichToken , rtkDetails :: Maybe TokenDetails } -data TokenDetails = TokenDetails - { rtkType :: RichTokenType - , rtkName :: GHC.Name - } +data TokenDetails + = RtkVar GHC.Name + | RtkType GHC.Name + | RtkBind GHC.Name + | RtkDecl GHC.Name -data RichTokenType - = RtkVar - | RtkType - | RtkBind - | RtkDecl +rtkName :: TokenDetails -> GHC.Name +rtkName (RtkVar name) = name +rtkName (RtkType name) = name +rtkName (RtkBind name) = name +rtkName (RtkDecl name) = name enrich :: GHC.RenamedSource -> [Token] -> [RichToken] enrich src = @@ -68,7 +69,7 @@ variables = where var term = case cast term of (Just (GHC.L sspan (GHC.HsVar name))) -> - pure (sspan, TokenDetails RtkVar name) + pure (sspan, RtkVar name) _ -> empty types :: GHC.RenamedSource -> DetailsMap @@ -77,7 +78,7 @@ types = where ty term = case cast term of (Just (GHC.L sspan (GHC.HsTyVar name))) -> - pure (sspan, TokenDetails RtkType name) + pure (sspan, RtkType name) _ -> empty binds :: GHC.RenamedSource -> DetailsMap @@ -86,11 +87,11 @@ binds = where fun term = case cast term of (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) -> - pure (sspan, TokenDetails RtkBind name) + pure (sspan, RtkBind name) _ -> empty pat term = case cast term of (Just (GHC.L sspan (GHC.VarPat name))) -> - pure (sspan, TokenDetails RtkBind name) + pure (sspan, RtkBind name) _ -> empty decls :: GHC.RenamedSource -> DetailsMap @@ -101,10 +102,10 @@ decls (group, _, _, _) = concatMap ($ group) where typ (GHC.L _ t) = let (GHC.L sspan name) = GHC.tcdLName t - in (sspan, TokenDetails RtkDecl name) + in (sspan, RtkDecl name) fun term = case cast term of (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) - | GHC.isExternalName name -> pure (sspan, TokenDetails RtkDecl name) + | GHC.isExternalName name -> pure (sspan, RtkDecl name) _ -> empty imports :: GHC.RenamedSource -> DetailsMap @@ -117,8 +118,8 @@ imports = (Just (GHC.IEThingAll t)) -> pure $ typ t (Just (GHC.IEThingWith t vs)) -> [typ t] ++ map var vs _ -> empty - typ (GHC.L sspan name) = (sspan, TokenDetails RtkType name) - var (GHC.L sspan name) = (sspan, TokenDetails RtkVar name) + typ (GHC.L sspan name) = (sspan, RtkType name) + var (GHC.L sspan name) = (sspan, RtkVar name) matches :: Span -> GHC.SrcSpan -> Bool matches tspan (GHC.RealSrcSpan aspan) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 99a0f337..e08d8974 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -41,14 +41,14 @@ richToken (RichToken tok (Just det)) = externalAnchor det . internalAnchor det . hyperlink det $ content where content = tokenSpan tok ! [ multiclass style] - style = (tokenStyle . tkType) tok ++ (richTokenStyle . rtkType) det + style = (tokenStyle . tkType) tok ++ richTokenStyle det tokenSpan :: Token -> Html tokenSpan = Html.thespan . Html.toHtml . tkValue -richTokenStyle :: RichTokenType -> [StyleClass] -richTokenStyle RtkVar = ["hs-var"] -richTokenStyle RtkType = ["hs-type"] +richTokenStyle :: TokenDetails -> [StyleClass] +richTokenStyle (RtkVar _) = ["hs-var"] +richTokenStyle (RtkType _) = ["hs-type"] richTokenStyle _ = [] tokenStyle :: TokenType -> [StyleClass] @@ -70,12 +70,12 @@ multiclass :: [StyleClass] -> HtmlAttr multiclass = Html.theclass . intercalate " " externalAnchor :: TokenDetails -> Html -> Html -externalAnchor (TokenDetails RtkDecl name) content = +externalAnchor (RtkDecl name) content = Html.anchor content ! [ Html.name $ externalAnchorIdent name ] externalAnchor _ content = content internalAnchor :: TokenDetails -> Html -> Html -internalAnchor (TokenDetails RtkBind name) content = +internalAnchor (RtkBind name) content = Html.anchor content ! [ Html.name $ internalAnchorIdent name ] internalAnchor _ content = content @@ -86,9 +86,12 @@ internalAnchorIdent :: GHC.Name -> String internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique hyperlink :: TokenDetails -> Html -> Html -hyperlink (TokenDetails _ name) = if GHC.isInternalName name +hyperlink details = + if GHC.isInternalName $ name then internalHyperlink name else externalHyperlink name + where + name = rtkName details internalHyperlink :: GHC.Name -> Html -> Html internalHyperlink name content = -- cgit v1.2.3 From a85224a68b51b70035446ad8e5565d571c4a10d4 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 17 Jun 2015 22:22:49 +0200 Subject: Implement hyperlinking of imported module names. --- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 19 +++++++++------ .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 28 +++++++++++++--------- 2 files changed, 29 insertions(+), 18 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 3c07ff3c..10389958 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -24,12 +24,14 @@ data TokenDetails | RtkType GHC.Name | RtkBind GHC.Name | RtkDecl GHC.Name + | RtkModule GHC.ModuleName -rtkName :: TokenDetails -> GHC.Name -rtkName (RtkVar name) = name -rtkName (RtkType name) = name -rtkName (RtkBind name) = name -rtkName (RtkDecl name) = name +rtkName :: TokenDetails -> Either GHC.Name GHC.ModuleName +rtkName (RtkVar name) = Left name +rtkName (RtkType name) = Left name +rtkName (RtkBind name) = Left name +rtkName (RtkDecl name) = Left name +rtkName (RtkModule name) = Right name enrich :: GHC.RenamedSource -> [Token] -> [RichToken] enrich src = @@ -109,8 +111,8 @@ decls (group, _, _, _) = concatMap ($ group) _ -> empty imports :: GHC.RenamedSource -> DetailsMap -imports = - everything (<|>) ie +imports src@(_, imps, _, _) = + everything (<|>) ie src ++ map (imp . GHC.unLoc) imps where ie term = case cast term of (Just (GHC.IEVar v)) -> pure $ var v @@ -120,6 +122,9 @@ imports = _ -> empty typ (GHC.L sspan name) = (sspan, RtkType name) var (GHC.L sspan name) = (sspan, RtkVar name) + imp idecl = + let (GHC.L sspan name) = GHC.ideclName idecl + in (sspan, RtkModule name) matches :: Span -> GHC.SrcSpan -> Bool matches tspan (GHC.RealSrcSpan aspan) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index e08d8974..70524759 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -8,6 +8,7 @@ import qualified Name as GHC import qualified Unique as GHC import Data.List +import Data.Maybe import Data.Monoid import Text.XHtml (Html, HtmlAttr, (!)) @@ -86,20 +87,25 @@ internalAnchorIdent :: GHC.Name -> String internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique hyperlink :: TokenDetails -> Html -> Html -hyperlink details = - if GHC.isInternalName $ name - then internalHyperlink name - else externalHyperlink name - where - name = rtkName details +hyperlink details = case rtkName details of + Left name -> + if GHC.isInternalName name + then internalHyperlink name + else externalHyperlink mname (Just name) + where + mname = GHC.moduleName <$> GHC.nameModule_maybe name + Right name -> externalHyperlink (Just name) Nothing internalHyperlink :: GHC.Name -> Html -> Html internalHyperlink name content = Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] -externalHyperlink :: GHC.Name -> Html -> Html -externalHyperlink name content = - Html.anchor content ! [ Html.href $ maybe "" id mmod ++ ".html#" ++ ident ] +externalHyperlink :: Maybe GHC.ModuleName -> Maybe GHC.Name -> Html -> Html +externalHyperlink mmname miname content = + Html.anchor content ! [ Html.href $ path ++ anchor ] where - mmod = GHC.moduleNameString . GHC.moduleName <$> GHC.nameModule_maybe name - ident = externalAnchorIdent name + path = fromMaybe "" $ modulePath <$> mmname + anchor = fromMaybe "" $ ("#" ++) . externalAnchorIdent <$> miname + +modulePath :: GHC.ModuleName -> String +modulePath name = GHC.moduleNameString name ++ ".html" -- cgit v1.2.3 From ebd60c5cd0c3642c2d5542c0e126be0a4ec111d9 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 17 Jun 2015 23:43:31 +0200 Subject: Fix parsing of single line comments with broken up newlines. --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 70a69279..3ecfc7e7 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -47,13 +47,23 @@ chunk [] = [] chunk str@(c:_) | isSpace c = chunk' $ span isSpace str chunk str - | "--" `isPrefixOf` str = chunk' $ span (not . (== '\n')) str + | "--" `isPrefixOf` str = chunk' $ spanToNewline str | "{-" `isPrefixOf` str = chunk' $ chunkComment 0 str | otherwise = chunk' $ head $ lex str chunk' :: (String, String) -> [String] chunk' (c, rest) = c:(chunk rest) +spanToNewline :: String -> (String, String) +spanToNewline [] = ([], []) +spanToNewline ('\\':'\n':str) = + let (str', rest) = spanToNewline str + in ('\\':'\n':str', rest) +spanToNewline ('\n':str) = ("\n", str) +spanToNewline (c:str) = + let (str', rest) = spanToNewline str + in (c:str', rest) + chunkComment :: Int -> String -> (String, String) chunkComment _ [] = ("", "") chunkComment depth ('{':'-':str) = -- cgit v1.2.3 From a7888aefa4011d919b887ff31fcf8651af5632be Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 18 Jun 2015 00:25:56 +0200 Subject: Fix bug with improper newline handling. --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 3ecfc7e7..bfee4a7f 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -59,7 +59,7 @@ spanToNewline [] = ([], []) spanToNewline ('\\':'\n':str) = let (str', rest) = spanToNewline str in ('\\':'\n':str', rest) -spanToNewline ('\n':str) = ("\n", str) +spanToNewline str@('\n':_) = ("", str) spanToNewline (c:str) = let (str', rest) = spanToNewline str in (c:str', rest) -- cgit v1.2.3 From 45cc27fe79492a7b921574796a7ea8fdac4c5af2 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 18 Jun 2015 14:29:59 +0200 Subject: Fix issues with escaped newlines in comments. --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 13 +++++-------- 1 file changed, 5 insertions(+), 8 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index bfee4a7f..fa5a58b3 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -82,14 +82,11 @@ tag :: [String] -> [(Span, String)] tag = reverse . snd . foldl aux (Position 1 1, []) where - aux (pos, cs) c = - let pos' = move pos c - in (pos', ((Span pos pos', c):cs)) - move pos str@(c:_) - | isSpace c = foldl move' pos str - move pos str = pos { posCol = posCol pos + length str } - move' pos '\n' = pos { posRow = posRow pos + 1, posCol = 1 } - move' pos _ = pos { posCol = posCol pos + 1 } + aux (pos, cs) str = + let pos' = foldl move pos str + in (pos', (Span pos pos', str):cs) + move pos '\n' = pos { posRow = posRow pos + 1, posCol = 1 } + move pos _ = pos { posCol = posCol pos + 1 } tokenize :: [(Span, String)] -> [Token] tokenize = -- cgit v1.2.3 From 61942ce564edcb3c0a64051042c8ed850f2090bd Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 18 Jun 2015 15:19:59 +0200 Subject: Add support for parsing C preprocessor macros. --- .../src/Haddock/Backends/Hyperlinker/Parser.hs | 20 ++++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index fa5a58b3..7f408165 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -6,6 +6,7 @@ module Haddock.Backends.Hyperlinker.Parser import Data.Char import Data.List +import Data.Maybe data Token = Token { tkType :: TokenType @@ -45,14 +46,15 @@ parse = tokenize . tag . chunk chunk :: String -> [String] chunk [] = [] chunk str@(c:_) - | isSpace c = chunk' $ span isSpace str + | isSpace c = + let (space, mcpp, rest) = spanSpaceOrCpp str + in [space] ++ maybeToList mcpp ++ chunk rest chunk str | "--" `isPrefixOf` str = chunk' $ spanToNewline str | "{-" `isPrefixOf` str = chunk' $ chunkComment 0 str | otherwise = chunk' $ head $ lex str - -chunk' :: (String, String) -> [String] -chunk' (c, rest) = c:(chunk rest) + where + chunk' (c, rest) = c:(chunk rest) spanToNewline :: String -> (String, String) spanToNewline [] = ([], []) @@ -64,6 +66,16 @@ spanToNewline (c:str) = let (str', rest) = spanToNewline str in (c:str', rest) +spanSpaceOrCpp :: String -> (String, Maybe String, String) +spanSpaceOrCpp ('\n':'#':str) = + let (str', rest) = spanToNewline str + in ("\n", Just $ '#':str', rest) +spanSpaceOrCpp (c:str') + | isSpace c = + let (space, mcpp, rest) = spanSpaceOrCpp str' + in (c:space, mcpp, rest) +spanSpaceOrCpp str = ("", Nothing, str) + chunkComment :: Int -> String -> (String, String) chunkComment _ [] = ("", "") chunkComment depth ('{':'-':str) = -- cgit v1.2.3 From 416c384a981593005c9c6bf87ac27b7c2f9b8695 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sun, 21 Jun 2015 23:48:03 +0200 Subject: Add some documentation for parser module of source hyperlinker. --- .../src/Haddock/Backends/Hyperlinker/Parser.hs | 39 ++++++++++++++++++++++ 1 file changed, 39 insertions(+) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 7f408165..6e195dba 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -40,9 +40,20 @@ data TokenType | TkUnknown deriving (Eq) +-- | Turn source code string into a stream of more descriptive tokens. +-- +-- Result should retain original file layout (including comments, whitespace, +-- etc.), i.e. the following "law" should hold: +-- +-- @concat . map 'tkValue' . 'parse' = id@ parse :: String -> [Token] parse = tokenize . tag . chunk +-- | Split raw source string to more meaningful chunks. +-- +-- This is the initial stage of tokenization process. Each chunk is either +-- a comment (including comment delimiters), a whitespace string, preprocessor +-- macro (and all its content until the end of a line) or valid Haskell lexeme. chunk :: String -> [String] chunk [] = [] chunk str@(c:_) @@ -56,6 +67,11 @@ chunk str where chunk' (c, rest) = c:(chunk rest) +-- | Split input to "first line" string and the rest of it. +-- +-- Ideally, this should be done simply with @'break' (== '\n')@. However, +-- Haskell also allows line-unbreaking (or whatever it is called) so things +-- are not as simple and this function deals with that. spanToNewline :: String -> (String, String) spanToNewline [] = ([], []) spanToNewline ('\\':'\n':str) = @@ -66,6 +82,16 @@ spanToNewline (c:str) = let (str', rest) = spanToNewline str in (c:str', rest) +-- | Split input to whitespace string, (optional) preprocessor directive and +-- the rest of it. +-- +-- Again, using something like @'span' 'isSpace'@ would be nice to chunk input +-- to whitespace. The problem is with /#/ symbol - if it is placed at the very +-- beginning of a line, it should be recognized as preprocessor macro. In any +-- other case, it is ordinary Haskell symbol and can be used to declare +-- operators. Hence, while dealing with whitespace we also check whether there +-- happens to be /#/ symbol just after a newline character - if that is the +-- case, we begin treating the whole line as preprocessor macro. spanSpaceOrCpp :: String -> (String, Maybe String, String) spanSpaceOrCpp ('\n':'#':str) = let (str', rest) = spanToNewline str @@ -76,6 +102,10 @@ spanSpaceOrCpp (c:str') in (c:space, mcpp, rest) spanSpaceOrCpp str = ("", Nothing, str) +-- | Split input to comment content (including delimiters) and the rest. +-- +-- Again, some more logic than simple 'span' is required because of Haskell +-- comment nesting policy. chunkComment :: Int -> String -> (String, String) chunkComment _ [] = ("", "") chunkComment depth ('{':'-':str) = @@ -90,6 +120,7 @@ chunkComment depth (e:str) = let (c, rest) = chunkComment depth str in (e:c, rest) +-- | Assign source location for each chunk in given stream. tag :: [String] -> [(Span, String)] tag = reverse . snd . foldl aux (Position 1 1, []) @@ -100,6 +131,7 @@ tag = move pos '\n' = pos { posRow = posRow pos + 1, posCol = 1 } move pos _ = pos { posCol = posCol pos + 1 } +-- | Turn unrecognised chunk stream to more descriptive token stream. tokenize :: [(Span, String)] -> [Token] tokenize = map aux @@ -110,6 +142,13 @@ tokenize = , tkSpan = sp } +-- | Classify given string as appropriate Haskell token. +-- +-- This method is based on Haskell 98 Report lexical structure description: +-- https://www.haskell.org/onlinereport/lexemes.html +-- +-- However, this is probably far from being perfect and most probably does not +-- handle correctly all corner cases. classify :: String -> TokenType classify str | "--" `isPrefixOf` str = TkComment -- cgit v1.2.3 From 937a6011d253a77cda98ec112a839cd08ac7e7ca Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 22 Jun 2015 00:20:44 +0200 Subject: Add some documentation for AST module of source hyperlinker. --- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 56 ++++++++++++++++++---- 1 file changed, 46 insertions(+), 10 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 10389958..275f10e9 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -33,6 +33,7 @@ rtkName (RtkBind name) = Left name rtkName (RtkDecl name) = Left name rtkName (RtkModule name) = Right name +-- | Add more detailed information to token stream using GHC API. enrich :: GHC.RenamedSource -> [Token] -> [RichToken] enrich src = map $ \token -> RichToken @@ -48,23 +49,24 @@ enrich src = , imports ] +-- | A map containing association between source locations and "details" of +-- this location. +-- +-- For the time being, it is just a list of pairs. However, looking up things +-- in such structure has linear complexity. We cannot use any hashmap-like +-- stuff because source locations are not ordered. In the future, this should +-- be replaced with interval tree data structure. type DetailsMap = [(GHC.SrcSpan, TokenDetails)] +lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails +lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst) + enrichToken :: Token -> DetailsMap -> Maybe TokenDetails enrichToken (Token typ _ spn) dm | typ `elem` [TkIdentifier, TkOperator] = lookupBySpan spn dm enrichToken _ _ = Nothing -lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails -lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst) - -everything :: (r -> r -> r) -> (forall a. Data a => a -> r) - -> (forall a. Data a => a -> r) -everything k f x = foldl k (f x) (gmapQ (everything k f) x) - -combine :: Alternative f => (forall a. Data a => a -> f r) -> (forall a. Data a => a -> f r) -> (forall a. Data a => a -> f r) -combine f g x = f x <|> g x - +-- | Obtain details map for variables ("normally" used identifiers). variables :: GHC.RenamedSource -> DetailsMap variables = everything (<|>) var @@ -74,6 +76,7 @@ variables = pure (sspan, RtkVar name) _ -> empty +-- | Obtain details map for types. types :: GHC.RenamedSource -> DetailsMap types = everything (<|>) ty @@ -83,6 +86,11 @@ types = pure (sspan, RtkType name) _ -> empty +-- | Obtain details map for identifier bindings. +-- +-- That includes both identifiers bound by pattern matching or declared using +-- ordinary assignment (in top-level declarations, let-expressions and where +-- clauses). binds :: GHC.RenamedSource -> DetailsMap binds = everything (<|>) (fun `combine` pat) @@ -96,6 +104,7 @@ binds = pure (sspan, RtkBind name) _ -> empty +-- | Obtain details map for top-level declarations. decls :: GHC.RenamedSource -> DetailsMap decls (group, _, _, _) = concatMap ($ group) [ map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds @@ -110,6 +119,10 @@ decls (group, _, _, _) = concatMap ($ group) | GHC.isExternalName name -> pure (sspan, RtkDecl name) _ -> empty +-- | Obtain details map for import declarations. +-- +-- This map also includes type and variable details for items in export and +-- import lists. imports :: GHC.RenamedSource -> DetailsMap imports src@(_, imps, _, _) = everything (<|>) ie src ++ map (imp . GHC.unLoc) imps @@ -126,6 +139,15 @@ imports src@(_, imps, _, _) = let (GHC.L sspan name) = GHC.ideclName idecl in (sspan, RtkModule name) +-- | Check whether token stream span matches GHC source span. +-- +-- Currently, it is implemented as checking whether "our" span is contained +-- in GHC span. The reason for that is because GHC span are generally wider +-- and may spread across couple tokens. For example, @(>>=)@ consists of three +-- tokens: @(@, @>>=@, @)@, but GHC source span associated with @>>=@ variable +-- contains @(@ and @)@. Similarly, qualified identifiers like @Foo.Bar.quux@ +-- are tokenized as @Foo@, @.@, @Bar@, @.@, @quux@ but GHC source span +-- associated with @quux@ contains all five elements. matches :: Span -> GHC.SrcSpan -> Bool matches tspan (GHC.RealSrcSpan aspan) | saspan <= stspan && etspan <= easpan = True @@ -135,3 +157,17 @@ matches tspan (GHC.RealSrcSpan aspan) saspan = (GHC.srcSpanStartLine aspan, GHC.srcSpanStartCol aspan) easpan = (GHC.srcSpanEndLine aspan, GHC.srcSpanEndCol aspan) matches _ _ = False + +-- | Perform a query on each level of a tree. +-- +-- This is stolen directly from SYB package and copied here to not introduce +-- additional dependencies. +everything :: (r -> r -> r) -> (forall a. Data a => a -> r) + -> (forall a. Data a => a -> r) +everything k f x = foldl k (f x) (gmapQ (everything k f) x) + +-- | Combine two queries into one using alternative combinator. +combine :: Alternative f => (forall a. Data a => a -> f r) + -> (forall a. Data a => a -> f r) + -> (forall a. Data a => a -> f r) +combine f g x = f x <|> g x -- cgit v1.2.3 From 62d44cd1d37d83fa93d169c2e5b5b758fcc231d6 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 22 Jun 2015 16:09:54 +0200 Subject: Create hyperlinker module and plug it into the Haddock pipeline. --- haddock-api/haddock-api.cabal | 1 + haddock-api/src/Haddock.hs | 4 ++++ haddock-api/src/Haddock/Backends/Hyperlinker.hs | 25 +++++++++++++++++++++++++ haddock.cabal | 1 + 4 files changed, 31 insertions(+) create mode 100644 haddock-api/src/Haddock/Backends/Hyperlinker.hs (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 109e5f95..6ffde976 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -82,6 +82,7 @@ library Haddock.Backends.LaTeX Haddock.Backends.HaddockDB Haddock.Backends.Hoogle + Haddock.Backends.Hyperlinker Haddock.ModuleTree Haddock.Types Haddock.Doc diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 3e58aba3..e45456ab 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -30,6 +30,7 @@ import Haddock.Backends.Xhtml import Haddock.Backends.Xhtml.Themes (getThemes) import Haddock.Backends.LaTeX import Haddock.Backends.Hoogle +import Haddock.Backends.Hyperlinker import Haddock.Interface import Haddock.Parser import Haddock.Types @@ -308,6 +309,9 @@ render dflags flags qual ifaces installedIfaces srcMap = do ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style libDir + when (Flag_HyperlinkedSource `elem` flags) $ do + ppHyperlinkedSource odir libDir Nothing visibleIfaces + -- | From GHC 7.10, this function has a potential to crash with a -- nasty message such as @expectJust getPackageDetails@ because -- package name and versions can no longer reliably be extracted in diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs new file mode 100644 index 00000000..88619474 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -0,0 +1,25 @@ +module Haddock.Backends.Hyperlinker (ppHyperlinkedSource) where + +import Haddock.Types +import Haddock.Backends.Hyperlinker.Renderer + +import GHC +import Text.XHtml hiding (()) +import System.Directory +import System.FilePath + +ppHyperlinkedSource :: FilePath -> FilePath -> Maybe FilePath -> [Interface] + -> IO () +ppHyperlinkedSource outdir libdir mstyle ifaces = do + createDirectoryIfMissing True (outdir "src") + mapM_ (ppHyperlinkedModuleSource outdir mstyle) ifaces + +ppHyperlinkedModuleSource :: FilePath -> Maybe FilePath -> Interface -> IO () +ppHyperlinkedModuleSource outdir mstyle iface = case ifaceTokenizedSrc iface of + Just tokens -> writeFile path $ showHtml . render mstyle $ tokens + Nothing -> return () + where + path = outdir "src" moduleSourceFile (ifaceMod iface) + +moduleSourceFile :: Module -> FilePath +moduleSourceFile = (++ ".html") . moduleNameString . moduleName diff --git a/haddock.cabal b/haddock.cabal index ed570f53..0aebefd8 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -101,6 +101,7 @@ executable haddock Haddock.Backends.LaTeX Haddock.Backends.HaddockDB Haddock.Backends.Hoogle + Haddock.Backends.Hyperlinker Haddock.ModuleTree Haddock.Types Haddock.Doc -- cgit v1.2.3 From 6f16398a26a12d58b3ba7f1924e2b6b00e68f5f7 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 22 Jun 2015 17:20:37 +0200 Subject: Add support for providing custom CSS files for hyperlinked source. --- haddock-api/haddock-api.cabal | 1 + haddock-api/resources/html/solarized.css | 55 +++++++++++++++++++++++++ haddock-api/src/Haddock.hs | 3 +- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 26 +++++++++--- haddock-api/src/Haddock/Options.hs | 6 +++ 5 files changed, 84 insertions(+), 7 deletions(-) create mode 100644 haddock-api/resources/html/solarized.css (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 6ffde976..14656994 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -18,6 +18,7 @@ stability: experimental data-dir: resources data-files: + html/solarized.css html/frames.html html/haddock-util.js html/Classic.theme/haskell_icon.gif diff --git a/haddock-api/resources/html/solarized.css b/haddock-api/resources/html/solarized.css new file mode 100644 index 00000000..e4bff385 --- /dev/null +++ b/haddock-api/resources/html/solarized.css @@ -0,0 +1,55 @@ +body { + background-color: #fdf6e3; +} + +.hs-identifier { + color: #073642; +} + +.hs-identifier.hs-var { +} + +.hs-identifier.hs-type { + color: #5f5faf; +} + +.hs-keyword { + color: #af005f; +} + +.hs-string, .hs-char { + color: #cb4b16; +} + +.hs-number { + color: #268bd2; +} + +.hs-operator { + color: #d33682; +} + +.hs-glyph, .hs-special { + color: #dc322f; +} + +.hs-comment { + color: #8a8a8a; +} + +.hs-pragma { + color: #2aa198; +} + +.hs-cpp { + color: #859900; +} + +a:link, a:visited { + text-decoration: none; + border-bottom: 1px solid #eee8d5; +} + +a:hover { + background-color: #eee8d5; +} diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index e45456ab..698122e3 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -244,6 +244,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do opt_index_url = optIndexUrl flags odir = outputDir flags opt_latex_style = optLaTeXStyle flags + opt_source_css = optSourceCssFile flags visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ] @@ -310,7 +311,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do libDir when (Flag_HyperlinkedSource `elem` flags) $ do - ppHyperlinkedSource odir libDir Nothing visibleIfaces + ppHyperlinkedSource odir libDir opt_source_css visibleIfaces -- | From GHC 7.10, this function has a potential to crash with a -- nasty message such as @expectJust getPackageDetails@ because diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 88619474..66392a67 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -5,21 +5,35 @@ import Haddock.Backends.Hyperlinker.Renderer import GHC import Text.XHtml hiding (()) + +import Data.Maybe import System.Directory import System.FilePath ppHyperlinkedSource :: FilePath -> FilePath -> Maybe FilePath -> [Interface] -> IO () ppHyperlinkedSource outdir libdir mstyle ifaces = do - createDirectoryIfMissing True (outdir "src") - mapM_ (ppHyperlinkedModuleSource outdir mstyle) ifaces + createDirectoryIfMissing True $ srcPath outdir + let cssFile = fromMaybe (defaultCssFile libdir) mstyle + copyFile cssFile $ srcPath outdir srcCssFile + mapM_ (ppHyperlinkedModuleSource outdir) ifaces -ppHyperlinkedModuleSource :: FilePath -> Maybe FilePath -> Interface -> IO () -ppHyperlinkedModuleSource outdir mstyle iface = case ifaceTokenizedSrc iface of - Just tokens -> writeFile path $ showHtml . render mstyle $ tokens +ppHyperlinkedModuleSource :: FilePath -> Interface -> IO () +ppHyperlinkedModuleSource outdir iface = case ifaceTokenizedSrc iface of + Just tokens -> writeFile path $ showHtml . render mSrcCssFile $ tokens Nothing -> return () where - path = outdir "src" moduleSourceFile (ifaceMod iface) + mSrcCssFile = Just $ srcCssFile + path = srcPath outdir moduleSourceFile (ifaceMod iface) moduleSourceFile :: Module -> FilePath moduleSourceFile = (++ ".html") . moduleNameString . moduleName + +srcPath :: FilePath -> FilePath +srcPath outdir = outdir "src" + +srcCssFile :: FilePath +srcCssFile = "style.css" + +defaultCssFile :: FilePath -> FilePath +defaultCssFile libdir = libdir "html" "solarized.css" diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index c9d5688c..f84989ef 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -21,6 +21,7 @@ module Haddock.Options ( optContentsUrl, optIndexUrl, optCssFile, + optSourceCssFile, sourceUrls, wikiUrls, optDumpInterfaceFile, @@ -67,6 +68,7 @@ data Flag | Flag_LaTeX | Flag_LaTeXStyle String | Flag_HyperlinkedSource + | Flag_SourceCss String | Flag_Help | Flag_Verbosity String | Flag_Version @@ -119,6 +121,8 @@ options backwardsCompat = "output for Hoogle; you may want --package-name and --package-version too", Option [] ["hyperlinked-source"] (NoArg Flag_HyperlinkedSource) "generate highlighted and hyperlinked source code (for use with --html)", + Option [] ["source-css"] (ReqArg Flag_SourceCss "FILE") + "use custom CSS file instead of default one in hyperlinked source", Option [] ["source-base"] (ReqArg Flag_SourceBaseURL "URL") "URL for a source code link on the contents\nand index pages", Option ['s'] (if backwardsCompat then ["source", "source-module"] else ["source-module"]) @@ -242,6 +246,8 @@ optIndexUrl flags = optLast [ url | Flag_UseIndex url <- flags ] optCssFile :: [Flag] -> Maybe FilePath optCssFile flags = optLast [ str | Flag_CSS str <- flags ] +optSourceCssFile :: [Flag] -> Maybe FilePath +optSourceCssFile flags = optLast [ str | Flag_SourceCss str <- flags ] sourceUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String, Maybe String) sourceUrls flags = -- cgit v1.2.3 From a6bd86a8550d5d7e8bdb12e1d09036b9f88eed73 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 22 Jun 2015 17:41:31 +0200 Subject: Add support for fancy highlighting upon hovering over identifier. --- haddock-api/haddock-api.cabal | 1 + haddock-api/resources/html/highlight.js | 46 ++++++++++++++++++++++ haddock-api/src/Haddock/Backends/Hyperlinker.hs | 10 ++++- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 23 +++++++---- 4 files changed, 70 insertions(+), 10 deletions(-) create mode 100644 haddock-api/resources/html/highlight.js (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 14656994..216627cc 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -21,6 +21,7 @@ data-files: html/solarized.css html/frames.html html/haddock-util.js + html/highlight.js html/Classic.theme/haskell_icon.gif html/Classic.theme/minus.gif html/Classic.theme/plus.gif diff --git a/haddock-api/resources/html/highlight.js b/haddock-api/resources/html/highlight.js new file mode 100644 index 00000000..639cf5d5 --- /dev/null +++ b/haddock-api/resources/html/highlight.js @@ -0,0 +1,46 @@ + +var styleForRule = function (rule) { + var sheets = document.styleSheets; + for (var s = 0; s < sheets.length; s++) { + var rules = sheets[s].cssRules; + for (var r = 0; r < rules.length; r++) { + if (rules[r].selectorText == rule) { + return rules[r].style; + } + } + } +}; + +var highlight = function () { + var color = styleForRule("a:hover")["background-color"]; + var links = document.getElementsByTagName('a'); + for (var i = 0; i < links.length; i++) { + var that = links[i]; + if (this.href == that.href) { + that.style["background-color"] = color; + } + } +}; + +/* + * I have no idea what is the proper antonym for "highlight" in this + * context. "Diminish"? "Unhighlight"? "Lowlight" sounds ridiculously + * so I like it. + */ +var lowlight = function () { + var links = document.getElementsByTagName('a'); + for (var i = 0; i < links.length; i++) { + var that = links[i]; + if (this.href == that.href) { + that.style["background-color"] = ""; + } + } +}; + +window.onload = function () { + var links = document.getElementsByTagName('a'); + for (var i = 0; i < links.length; i++) { + links[i].onmouseover = highlight; + links[i].onmouseout = lowlight; + } +}; diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 66392a67..9337307c 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -16,14 +16,17 @@ ppHyperlinkedSource outdir libdir mstyle ifaces = do createDirectoryIfMissing True $ srcPath outdir let cssFile = fromMaybe (defaultCssFile libdir) mstyle copyFile cssFile $ srcPath outdir srcCssFile + copyFile (libdir "html" highlightScript) $ + srcPath outdir highlightScript mapM_ (ppHyperlinkedModuleSource outdir) ifaces ppHyperlinkedModuleSource :: FilePath -> Interface -> IO () ppHyperlinkedModuleSource outdir iface = case ifaceTokenizedSrc iface of - Just tokens -> writeFile path $ showHtml . render mSrcCssFile $ tokens + Just tokens -> writeFile path $ showHtml . render mCssFile mJsFile $ tokens Nothing -> return () where - mSrcCssFile = Just $ srcCssFile + mCssFile = Just $ srcCssFile + mJsFile = Just $ highlightScript path = srcPath outdir moduleSourceFile (ifaceMod iface) moduleSourceFile :: Module -> FilePath @@ -35,5 +38,8 @@ srcPath outdir = outdir "src" srcCssFile :: FilePath srcCssFile = "style.css" +highlightScript :: FilePath +highlightScript = "highlight.js" + defaultCssFile :: FilePath -> FilePath defaultCssFile libdir = libdir "html" "solarized.css" diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 70524759..6d6d2012 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -16,21 +16,28 @@ import qualified Text.XHtml as Html type StyleClass = String -render :: Maybe FilePath -> [RichToken] -> Html -render css tokens = header css <> body tokens +render :: Maybe FilePath -> Maybe FilePath -> [RichToken] -> Html +render mcss mjs tokens = header mcss mjs <> body tokens body :: [RichToken] -> Html body = Html.body . Html.pre . mconcat . map richToken -header :: Maybe FilePath -> Html -header Nothing = Html.noHtml -header (Just css) = - Html.header $ Html.thelink Html.noHtml ! attrs +header :: Maybe FilePath -> Maybe FilePath -> Html +header mcss mjs + | isNothing mcss && isNothing mjs = Html.noHtml +header mcss mjs = + Html.header $ css mcss <> js mjs where - attrs = + css Nothing = Html.noHtml + css (Just cssFile) = Html.thelink Html.noHtml ! [ Html.rel "stylesheet" - , Html.href css , Html.thetype "text/css" + , Html.href cssFile + ] + js Nothing = Html.noHtml + js (Just jsFile) = Html.script Html.noHtml ! + [ Html.thetype "text/javascript" + , Html.src jsFile ] richToken :: RichToken -> Html -- cgit v1.2.3 From affd889d1b192d2cb9787c92202317b9e9401922 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 26 Jun 2015 21:13:12 +0200 Subject: Make source hyperlinker generate output in apropriate directory. --- haddock-api/src/Haddock.hs | 10 ++++-- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 41 +++++++++++++++---------- haddock-api/src/Haddock/Utils.hs | 5 +++ 3 files changed, 38 insertions(+), 18 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 698122e3..01e4cd45 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -258,10 +258,16 @@ render dflags flags qual ifaces installedIfaces srcMap = do pkgNameVer = modulePackageInfo dflags flags pkgMod (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags + + srcModule' + | isJust srcModule = srcModule + | Flag_HyperlinkedSource `elem` flags = Just defaultModuleSourceUrl + | otherwise = Nothing + srcMap' = maybe srcMap (\path -> Map.insert pkgKey path srcMap) srcEntity -- TODO: Get these from the interface files as with srcMap srcLMap' = maybe Map.empty (\path -> Map.singleton pkgKey path) srcLEntity - sourceUrls' = (srcBase, srcModule, srcMap', srcLMap') + sourceUrls' = (srcBase, srcModule', srcMap', srcLMap') libDir <- getHaddockLibDir flags prologue <- getPrologue dflags flags @@ -311,7 +317,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do libDir when (Flag_HyperlinkedSource `elem` flags) $ do - ppHyperlinkedSource odir libDir opt_source_css visibleIfaces + ppHyperlinkedSource odir libDir opt_source_css sourceUrls' visibleIfaces -- | From GHC 7.10, this function has a potential to crash with a -- nasty message such as @expectJust getPackageDetails@ because diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 9337307c..2ed4dbdd 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -1,45 +1,54 @@ module Haddock.Backends.Hyperlinker (ppHyperlinkedSource) where import Haddock.Types +import Haddock.Utils +import Haddock.Backends.Xhtml.Types +import Haddock.Backends.Xhtml.Utils import Haddock.Backends.Hyperlinker.Renderer -import GHC import Text.XHtml hiding (()) import Data.Maybe import System.Directory import System.FilePath -ppHyperlinkedSource :: FilePath -> FilePath -> Maybe FilePath -> [Interface] +ppHyperlinkedSource :: FilePath -> FilePath + -> Maybe FilePath + -> SourceURLs + -> [Interface] -> IO () -ppHyperlinkedSource outdir libdir mstyle ifaces = do - createDirectoryIfMissing True $ srcPath outdir +ppHyperlinkedSource outdir libdir mstyle urls ifaces = do + createDirectoryIfMissing True srcdir let cssFile = fromMaybe (defaultCssFile libdir) mstyle - copyFile cssFile $ srcPath outdir srcCssFile + copyFile cssFile $ srcdir srcCssFile copyFile (libdir "html" highlightScript) $ - srcPath outdir highlightScript - mapM_ (ppHyperlinkedModuleSource outdir) ifaces + srcdir highlightScript + mapM_ (ppHyperlinkedModuleSource outdir urls) ifaces + where + srcdir = srcPath outdir urls -ppHyperlinkedModuleSource :: FilePath -> Interface -> IO () -ppHyperlinkedModuleSource outdir iface = case ifaceTokenizedSrc iface of +ppHyperlinkedModuleSource :: FilePath -> SourceURLs -> Interface -> IO () +ppHyperlinkedModuleSource outdir urls iface = case ifaceTokenizedSrc iface of Just tokens -> writeFile path $ showHtml . render mCssFile mJsFile $ tokens Nothing -> return () where mCssFile = Just $ srcCssFile mJsFile = Just $ highlightScript - path = srcPath outdir moduleSourceFile (ifaceMod iface) - -moduleSourceFile :: Module -> FilePath -moduleSourceFile = (++ ".html") . moduleNameString . moduleName + srcFile = spliceURL Nothing (Just $ ifaceMod iface) Nothing Nothing $ + srcModUrl urls + path = outdir srcFile -srcPath :: FilePath -> FilePath -srcPath outdir = outdir "src" +srcPath :: FilePath -> SourceURLs -> FilePath +srcPath outdir urls = outdir takeDirectory (srcModUrl urls) srcCssFile :: FilePath -srcCssFile = "style.css" +srcCssFile = "srcstyle.css" highlightScript :: FilePath highlightScript = "highlight.js" defaultCssFile :: FilePath -> FilePath defaultCssFile libdir = libdir "html" "solarized.css" + +srcModUrl :: SourceURLs -> String +srcModUrl (_, mModSrcUrl, _, _) = fromMaybe defaultModuleSourceUrl mModSrcUrl diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 4fed3a1e..78c78aca 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -29,6 +29,7 @@ module Haddock.Utils ( moduleNameUrl, moduleNameUrl', moduleUrl, nameAnchorId, makeAnchorId, + defaultModuleSourceUrl, -- * Miscellaneous utilities getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr, @@ -277,6 +278,10 @@ makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r -- NB: '-' is legal in IDs, but we use it as the escape char +defaultModuleSourceUrl :: String +defaultModuleSourceUrl = "src/%{MODULE}.html" + + ------------------------------------------------------------------------------- -- * Files we need to copy from our $libdir ------------------------------------------------------------------------------- -- cgit v1.2.3 From 844c09d0c1d724e0f0f0698654f2f85f5f58be19 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 26 Jun 2015 22:24:57 +0200 Subject: Create module with hyperlinker utility functions. --- haddock-api/haddock-api.cabal | 1 + haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs | 18 ++++++++++++++++++ 2 files changed, 19 insertions(+) create mode 100644 haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 216627cc..7670f888 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -85,6 +85,7 @@ library Haddock.Backends.HaddockDB Haddock.Backends.Hoogle Haddock.Backends.Hyperlinker + Haddock.Backends.Hyperlinker.Utils Haddock.ModuleTree Haddock.Types Haddock.Doc diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs new file mode 100644 index 00000000..25ed942b --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs @@ -0,0 +1,18 @@ +module Haddock.Backends.Hyperlinker.Utils + ( srcModUrl + , srcNameUrlMap + ) where + +import Haddock.Utils +import Haddock.Backends.Xhtml.Types + +import GHC + +import Data.Maybe +import Data.Map (Map) + +srcModUrl :: SourceURLs -> String +srcModUrl (_, mModUrl, _, _) = fromMaybe defaultModuleSourceUrl mModUrl + +srcNameUrlMap :: SourceURLs -> Map PackageKey FilePath +srcNameUrlMap (_, _, nameUrlMap, _) = nameUrlMap -- cgit v1.2.3 From d58bcf24dfa4333e7893935eb86c036be28125b1 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 26 Jun 2015 22:41:07 +0200 Subject: Make external hyperlinks point to locations specified by source URLs. --- haddock-api/src/Haddock.hs | 7 ++- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 8 ++-- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 52 +++++++++++++--------- haddock-api/src/Haddock/Utils.hs | 5 ++- 4 files changed, 44 insertions(+), 28 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 01e4cd45..3105edf5 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -264,7 +264,12 @@ render dflags flags qual ifaces installedIfaces srcMap = do | Flag_HyperlinkedSource `elem` flags = Just defaultModuleSourceUrl | otherwise = Nothing - srcMap' = maybe srcMap (\path -> Map.insert pkgKey path srcMap) srcEntity + srcMap' + | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl srcMap + | Flag_HyperlinkedSource `elem` flags = + Map.insert pkgKey defaultNameSourceUrl srcMap + | otherwise = srcMap + -- TODO: Get these from the interface files as with srcMap srcLMap' = maybe Map.empty (\path -> Map.singleton pkgKey path) srcLEntity sourceUrls' = (srcBase, srcModule', srcMap', srcLMap') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 2ed4dbdd..6c66e0c6 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -1,10 +1,10 @@ module Haddock.Backends.Hyperlinker (ppHyperlinkedSource) where import Haddock.Types -import Haddock.Utils import Haddock.Backends.Xhtml.Types import Haddock.Backends.Xhtml.Utils import Haddock.Backends.Hyperlinker.Renderer +import Haddock.Backends.Hyperlinker.Utils import Text.XHtml hiding (()) @@ -29,7 +29,8 @@ ppHyperlinkedSource outdir libdir mstyle urls ifaces = do ppHyperlinkedModuleSource :: FilePath -> SourceURLs -> Interface -> IO () ppHyperlinkedModuleSource outdir urls iface = case ifaceTokenizedSrc iface of - Just tokens -> writeFile path $ showHtml . render mCssFile mJsFile $ tokens + Just tokens -> + writeFile path $ showHtml . render mCssFile mJsFile urls $ tokens Nothing -> return () where mCssFile = Just $ srcCssFile @@ -49,6 +50,3 @@ highlightScript = "highlight.js" defaultCssFile :: FilePath -> FilePath defaultCssFile libdir = libdir "html" "solarized.css" - -srcModUrl :: SourceURLs -> String -srcModUrl (_, mModSrcUrl, _, _) = fromMaybe defaultModuleSourceUrl mModSrcUrl diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 6d6d2012..2df62938 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -2,12 +2,16 @@ module Haddock.Backends.Hyperlinker.Renderer (render) where import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Ast +import Haddock.Backends.Hyperlinker.Utils +import Haddock.Backends.Xhtml.Types +import Haddock.Backends.Xhtml.Utils import qualified GHC import qualified Name as GHC import qualified Unique as GHC import Data.List +import qualified Data.Map as Map import Data.Maybe import Data.Monoid @@ -16,11 +20,11 @@ import qualified Text.XHtml as Html type StyleClass = String -render :: Maybe FilePath -> Maybe FilePath -> [RichToken] -> Html -render mcss mjs tokens = header mcss mjs <> body tokens +render :: Maybe FilePath -> Maybe FilePath -> SourceURLs -> [RichToken] -> Html +render mcss mjs urls tokens = header mcss mjs <> body urls tokens -body :: [RichToken] -> Html -body = Html.body . Html.pre . mconcat . map richToken +body :: SourceURLs -> [RichToken] -> Html +body urls = Html.body . Html.pre . mconcat . map (richToken urls) header :: Maybe FilePath -> Maybe FilePath -> Html header mcss mjs @@ -40,13 +44,13 @@ header mcss mjs = , Html.src jsFile ] -richToken :: RichToken -> Html -richToken (RichToken tok Nothing) = +richToken :: SourceURLs -> RichToken -> Html +richToken _ (RichToken tok Nothing) = tokenSpan tok ! attrs where attrs = [ multiclass . tokenStyle . tkType $ tok ] -richToken (RichToken tok (Just det)) = - externalAnchor det . internalAnchor det . hyperlink det $ content +richToken urls (RichToken tok (Just det)) = + externalAnchor det . internalAnchor det . hyperlink urls det $ content where content = tokenSpan tok ! [ multiclass style] style = (tokenStyle . tkType) tok ++ richTokenStyle det @@ -93,26 +97,32 @@ externalAnchorIdent = GHC.occNameString . GHC.nameOccName internalAnchorIdent :: GHC.Name -> String internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique -hyperlink :: TokenDetails -> Html -> Html -hyperlink details = case rtkName details of +hyperlink :: SourceURLs -> TokenDetails -> Html -> Html +hyperlink urls details = case rtkName details of Left name -> if GHC.isInternalName name then internalHyperlink name - else externalHyperlink mname (Just name) - where - mname = GHC.moduleName <$> GHC.nameModule_maybe name - Right name -> externalHyperlink (Just name) Nothing + else externalNameHyperlink urls name + Right name -> externalModHyperlink name internalHyperlink :: GHC.Name -> Html -> Html internalHyperlink name content = Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] -externalHyperlink :: Maybe GHC.ModuleName -> Maybe GHC.Name -> Html -> Html -externalHyperlink mmname miname content = - Html.anchor content ! [ Html.href $ path ++ anchor ] +externalNameHyperlink :: SourceURLs -> GHC.Name -> Html -> Html +externalNameHyperlink urls name = + case Map.lookup key $ srcNameUrlMap urls of + Just url -> externalNameHyperlink' url name + Nothing -> id where - path = fromMaybe "" $ modulePath <$> mmname - anchor = fromMaybe "" $ ("#" ++) . externalAnchorIdent <$> miname + key = GHC.modulePackageKey . GHC.nameModule $ name -modulePath :: GHC.ModuleName -> String -modulePath name = GHC.moduleNameString name ++ ".html" +externalNameHyperlink' :: String -> GHC.Name -> Html -> Html +externalNameHyperlink' url name content = + Html.anchor content ! [ Html.href $ href ] + where + mdl = GHC.nameModule name + href = spliceURL Nothing (Just mdl) (Just name) Nothing url + +externalModHyperlink :: GHC.ModuleName -> Html -> Html +externalModHyperlink _ = id -- TODO diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 78c78aca..047d9fd0 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -29,7 +29,7 @@ module Haddock.Utils ( moduleNameUrl, moduleNameUrl', moduleUrl, nameAnchorId, makeAnchorId, - defaultModuleSourceUrl, + defaultModuleSourceUrl, defaultNameSourceUrl, -- * Miscellaneous utilities getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr, @@ -281,6 +281,9 @@ makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r defaultModuleSourceUrl :: String defaultModuleSourceUrl = "src/%{MODULE}.html" +defaultNameSourceUrl :: String +defaultNameSourceUrl = defaultModuleSourceUrl ++ "#%{NAME}" + ------------------------------------------------------------------------------- -- * Files we need to copy from our $libdir -- cgit v1.2.3 From ab070206d67748232995a262b533957a5a7b9315 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 27 Jun 2015 18:03:56 +0200 Subject: Rewrite source generation to fixed links and directory structure. --- haddock-api/src/Haddock.hs | 11 +++-- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 29 +++++------- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 52 +++++++++------------- .../src/Haddock/Backends/Hyperlinker/Utils.hs | 48 +++++++++++++++----- haddock-api/src/Haddock/Backends/Xhtml/Utils.hs | 14 +++--- haddock-api/src/Haddock/Utils.hs | 8 ---- 6 files changed, 85 insertions(+), 77 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 3105edf5..d596c075 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -260,14 +260,13 @@ render dflags flags qual ifaces installedIfaces srcMap = do (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags srcModule' - | isJust srcModule = srcModule - | Flag_HyperlinkedSource `elem` flags = Just defaultModuleSourceUrl - | otherwise = Nothing + | Flag_HyperlinkedSource `elem` flags = Just hypSrcModuleUrlFormat + | otherwise = srcModule srcMap' - | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl srcMap | Flag_HyperlinkedSource `elem` flags = - Map.insert pkgKey defaultNameSourceUrl srcMap + Map.insert pkgKey hypSrcModuleNameUrlFormat srcMap + | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl srcMap | otherwise = srcMap -- TODO: Get these from the interface files as with srcMap @@ -322,7 +321,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do libDir when (Flag_HyperlinkedSource `elem` flags) $ do - ppHyperlinkedSource odir libDir opt_source_css sourceUrls' visibleIfaces + ppHyperlinkedSource odir libDir opt_source_css visibleIfaces -- | From GHC 7.10, this function has a potential to crash with a -- nasty message such as @expectJust getPackageDetails@ because diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 6c66e0c6..f197eaa3 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -1,8 +1,9 @@ -module Haddock.Backends.Hyperlinker (ppHyperlinkedSource) where +module Haddock.Backends.Hyperlinker + ( ppHyperlinkedSource + , module Haddock.Backends.Hyperlinker.Utils + ) where import Haddock.Types -import Haddock.Backends.Xhtml.Types -import Haddock.Backends.Xhtml.Utils import Haddock.Backends.Hyperlinker.Renderer import Haddock.Backends.Hyperlinker.Utils @@ -14,36 +15,30 @@ import System.FilePath ppHyperlinkedSource :: FilePath -> FilePath -> Maybe FilePath - -> SourceURLs -> [Interface] -> IO () -ppHyperlinkedSource outdir libdir mstyle urls ifaces = do +ppHyperlinkedSource outdir libdir mstyle ifaces = do createDirectoryIfMissing True srcdir let cssFile = fromMaybe (defaultCssFile libdir) mstyle copyFile cssFile $ srcdir srcCssFile copyFile (libdir "html" highlightScript) $ srcdir highlightScript - mapM_ (ppHyperlinkedModuleSource outdir urls) ifaces + mapM_ (ppHyperlinkedModuleSource srcdir) ifaces where - srcdir = srcPath outdir urls + srcdir = outdir hypSrcDir -ppHyperlinkedModuleSource :: FilePath -> SourceURLs -> Interface -> IO () -ppHyperlinkedModuleSource outdir urls iface = case ifaceTokenizedSrc iface of +ppHyperlinkedModuleSource :: FilePath -> Interface -> IO () +ppHyperlinkedModuleSource srcdir iface = case ifaceTokenizedSrc iface of Just tokens -> - writeFile path $ showHtml . render mCssFile mJsFile urls $ tokens + writeFile path $ showHtml . render mCssFile mJsFile $ tokens Nothing -> return () where mCssFile = Just $ srcCssFile mJsFile = Just $ highlightScript - srcFile = spliceURL Nothing (Just $ ifaceMod iface) Nothing Nothing $ - srcModUrl urls - path = outdir srcFile - -srcPath :: FilePath -> SourceURLs -> FilePath -srcPath outdir urls = outdir takeDirectory (srcModUrl urls) + path = srcdir hypSrcModuleFile (ifaceMod iface) srcCssFile :: FilePath -srcCssFile = "srcstyle.css" +srcCssFile = "style.css" highlightScript :: FilePath highlightScript = "highlight.js" diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 2df62938..d8ea5ec7 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -3,15 +3,12 @@ module Haddock.Backends.Hyperlinker.Renderer (render) where import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Ast import Haddock.Backends.Hyperlinker.Utils -import Haddock.Backends.Xhtml.Types -import Haddock.Backends.Xhtml.Utils import qualified GHC import qualified Name as GHC import qualified Unique as GHC import Data.List -import qualified Data.Map as Map import Data.Maybe import Data.Monoid @@ -20,11 +17,11 @@ import qualified Text.XHtml as Html type StyleClass = String -render :: Maybe FilePath -> Maybe FilePath -> SourceURLs -> [RichToken] -> Html -render mcss mjs urls tokens = header mcss mjs <> body urls tokens +render :: Maybe FilePath -> Maybe FilePath -> [RichToken] -> Html +render mcss mjs tokens = header mcss mjs <> body tokens -body :: SourceURLs -> [RichToken] -> Html -body urls = Html.body . Html.pre . mconcat . map (richToken urls) +body :: [RichToken] -> Html +body = Html.body . Html.pre . mconcat . map richToken header :: Maybe FilePath -> Maybe FilePath -> Html header mcss mjs @@ -39,18 +36,18 @@ header mcss mjs = , Html.href cssFile ] js Nothing = Html.noHtml - js (Just jsFile) = Html.script Html.noHtml ! + js (Just scriptFile) = Html.script Html.noHtml ! [ Html.thetype "text/javascript" - , Html.src jsFile + , Html.src scriptFile ] -richToken :: SourceURLs -> RichToken -> Html -richToken _ (RichToken tok Nothing) = +richToken :: RichToken -> Html +richToken (RichToken tok Nothing) = tokenSpan tok ! attrs where attrs = [ multiclass . tokenStyle . tkType $ tok ] -richToken urls (RichToken tok (Just det)) = - externalAnchor det . internalAnchor det . hyperlink urls det $ content +richToken (RichToken tok (Just det)) = + externalAnchor det . internalAnchor det . hyperlink det $ content where content = tokenSpan tok ! [ multiclass style] style = (tokenStyle . tkType) tok ++ richTokenStyle det @@ -92,37 +89,30 @@ internalAnchor (RtkBind name) content = internalAnchor _ content = content externalAnchorIdent :: GHC.Name -> String -externalAnchorIdent = GHC.occNameString . GHC.nameOccName +externalAnchorIdent = hypSrcNameUrl internalAnchorIdent :: GHC.Name -> String internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique -hyperlink :: SourceURLs -> TokenDetails -> Html -> Html -hyperlink urls details = case rtkName details of +hyperlink :: TokenDetails -> Html -> Html +hyperlink details = case rtkName details of Left name -> if GHC.isInternalName name then internalHyperlink name - else externalNameHyperlink urls name + else externalNameHyperlink name Right name -> externalModHyperlink name internalHyperlink :: GHC.Name -> Html -> Html internalHyperlink name content = Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] -externalNameHyperlink :: SourceURLs -> GHC.Name -> Html -> Html -externalNameHyperlink urls name = - case Map.lookup key $ srcNameUrlMap urls of - Just url -> externalNameHyperlink' url name - Nothing -> id +externalNameHyperlink :: GHC.Name -> Html -> Html +externalNameHyperlink name content = + Html.anchor content ! [ Html.href href ] where - key = GHC.modulePackageKey . GHC.nameModule $ name - -externalNameHyperlink' :: String -> GHC.Name -> Html -> Html -externalNameHyperlink' url name content = - Html.anchor content ! [ Html.href $ href ] - where - mdl = GHC.nameModule name - href = spliceURL Nothing (Just mdl) (Just name) Nothing url + href = hypSrcModuleNameUrl (GHC.nameModule name) name externalModHyperlink :: GHC.ModuleName -> Html -> Html -externalModHyperlink _ = id -- TODO +externalModHyperlink mdl content = + Html.anchor content ! [ Html.href $ hypSrcModuleUrl' mdl ] + diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs index 25ed942b..9ba8446d 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs @@ -1,18 +1,46 @@ module Haddock.Backends.Hyperlinker.Utils - ( srcModUrl - , srcNameUrlMap + ( hypSrcDir, hypSrcModuleFile, hypSrcModuleFile' + , hypSrcModuleUrl, hypSrcModuleUrl', hypSrcNameUrl, hypSrcModuleNameUrl + , hypSrcModuleUrlFormat, hypSrcModuleNameUrlFormat, ) where -import Haddock.Utils -import Haddock.Backends.Xhtml.Types +import Haddock.Backends.Xhtml.Utils import GHC +import System.FilePath.Posix (()) -import Data.Maybe -import Data.Map (Map) -srcModUrl :: SourceURLs -> String -srcModUrl (_, mModUrl, _, _) = fromMaybe defaultModuleSourceUrl mModUrl +hypSrcDir :: FilePath +hypSrcDir = "src" -srcNameUrlMap :: SourceURLs -> Map PackageKey FilePath -srcNameUrlMap (_, _, nameUrlMap, _) = nameUrlMap +hypSrcModuleFile :: Module -> FilePath +hypSrcModuleFile = hypSrcModuleFile' . moduleName + +hypSrcModuleFile' :: ModuleName -> FilePath +hypSrcModuleFile' mdl = spliceURL' + Nothing (Just mdl) Nothing Nothing moduleFormat + +hypSrcModuleUrl :: Module -> String +hypSrcModuleUrl = hypSrcModuleFile + +hypSrcModuleUrl' :: ModuleName -> String +hypSrcModuleUrl' = hypSrcModuleFile' + +hypSrcNameUrl :: Name -> String +hypSrcNameUrl name = spliceURL + Nothing Nothing (Just name) Nothing nameFormat + +hypSrcModuleNameUrl :: Module -> Name -> String +hypSrcModuleNameUrl mdl name = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name + +hypSrcModuleUrlFormat :: String +hypSrcModuleUrlFormat = hypSrcDir moduleFormat + +hypSrcModuleNameUrlFormat :: String +hypSrcModuleNameUrlFormat = hypSrcModuleUrlFormat ++ "#" ++ nameFormat + +moduleFormat :: String +moduleFormat = "%{MODULE}.html" + +nameFormat :: String +nameFormat = "%{NAME}" diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs index cbcbbd6d..36ecf863 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs @@ -14,7 +14,7 @@ module Haddock.Backends.Xhtml.Utils ( renderToString, namedAnchor, linkedAnchor, - spliceURL, + spliceURL, spliceURL', groupId, (<+>), (<=>), char, @@ -29,7 +29,6 @@ module Haddock.Backends.Xhtml.Utils ( ) where -import Haddock.GhcUtils import Haddock.Utils import Data.Maybe @@ -38,18 +37,23 @@ import Text.XHtml hiding ( name, title, p, quote ) import qualified Text.XHtml as XHtml import GHC ( SrcSpan(..), srcSpanStartLine, Name ) -import Module ( Module ) +import Module ( Module, ModuleName, moduleName, moduleNameString ) import Name ( getOccString, nameOccName, isValOcc ) spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name -> Maybe SrcSpan -> String -> String -spliceURL maybe_file maybe_mod maybe_name maybe_loc = run +spliceURL mfile mmod = spliceURL' mfile (moduleName <$> mmod) + + +spliceURL' :: Maybe FilePath -> Maybe ModuleName -> Maybe GHC.Name -> + Maybe SrcSpan -> String -> String +spliceURL' maybe_file maybe_mod maybe_name maybe_loc = run where file = fromMaybe "" maybe_file mdl = case maybe_mod of Nothing -> "" - Just m -> moduleString m + Just m -> moduleNameString m (name, kind) = case maybe_name of diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 047d9fd0..4fed3a1e 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -29,7 +29,6 @@ module Haddock.Utils ( moduleNameUrl, moduleNameUrl', moduleUrl, nameAnchorId, makeAnchorId, - defaultModuleSourceUrl, defaultNameSourceUrl, -- * Miscellaneous utilities getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr, @@ -278,13 +277,6 @@ makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r -- NB: '-' is legal in IDs, but we use it as the escape char -defaultModuleSourceUrl :: String -defaultModuleSourceUrl = "src/%{MODULE}.html" - -defaultNameSourceUrl :: String -defaultNameSourceUrl = defaultModuleSourceUrl ++ "#%{NAME}" - - ------------------------------------------------------------------------------- -- * Files we need to copy from our $libdir ------------------------------------------------------------------------------- -- cgit v1.2.3 From a6eb5a19b13bc4dfa79d0e55e5992dfa403aa3c3 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sun, 28 Jun 2015 21:00:55 +0200 Subject: Add basic support for cross-package hyperlink generation. --- haddock-api/src/Haddock.hs | 2 +- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 25 ++++++------- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 42 +++++++++++++--------- 3 files changed, 40 insertions(+), 29 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index d596c075..caaa1eef 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -321,7 +321,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do libDir when (Flag_HyperlinkedSource `elem` flags) $ do - ppHyperlinkedSource odir libDir opt_source_css visibleIfaces + ppHyperlinkedSource odir libDir opt_source_css pkgKey srcMap visibleIfaces -- | From GHC 7.10, this function has a potential to crash with a -- nasty message such as @expectJust getPackageDetails@ because diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index f197eaa3..f2caa2c1 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -8,33 +8,34 @@ import Haddock.Backends.Hyperlinker.Renderer import Haddock.Backends.Hyperlinker.Utils import Text.XHtml hiding (()) +import GHC import Data.Maybe import System.Directory import System.FilePath -ppHyperlinkedSource :: FilePath -> FilePath - -> Maybe FilePath - -> [Interface] +ppHyperlinkedSource :: FilePath -> FilePath -> Maybe FilePath + -> PackageKey -> SrcMap -> [Interface] -> IO () -ppHyperlinkedSource outdir libdir mstyle ifaces = do +ppHyperlinkedSource outdir libdir mstyle pkg srcs ifaces = do createDirectoryIfMissing True srcdir let cssFile = fromMaybe (defaultCssFile libdir) mstyle copyFile cssFile $ srcdir srcCssFile copyFile (libdir "html" highlightScript) $ srcdir highlightScript - mapM_ (ppHyperlinkedModuleSource srcdir) ifaces + mapM_ (ppHyperlinkedModuleSource srcdir pkg srcs) ifaces where srcdir = outdir hypSrcDir -ppHyperlinkedModuleSource :: FilePath -> Interface -> IO () -ppHyperlinkedModuleSource srcdir iface = case ifaceTokenizedSrc iface of - Just tokens -> - writeFile path $ showHtml . render mCssFile mJsFile $ tokens - Nothing -> return () +ppHyperlinkedModuleSource :: FilePath + -> PackageKey -> SrcMap -> Interface + -> IO () +ppHyperlinkedModuleSource srcdir pkg srcs iface = + case ifaceTokenizedSrc iface of + Just tokens -> writeFile path . showHtml . render' $ tokens + Nothing -> return () where - mCssFile = Just $ srcCssFile - mJsFile = Just $ highlightScript + render' = render (Just srcCssFile) (Just highlightScript) pkg srcs path = srcdir hypSrcModuleFile (ifaceMod iface) srcCssFile :: FilePath diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index d8ea5ec7..b05a5b8a 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -1,5 +1,6 @@ module Haddock.Backends.Hyperlinker.Renderer (render) where +import Haddock.Types import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Ast import Haddock.Backends.Hyperlinker.Utils @@ -8,20 +9,25 @@ import qualified GHC import qualified Name as GHC import qualified Unique as GHC +import System.FilePath.Posix (()) + import Data.List import Data.Maybe import Data.Monoid +import qualified Data.Map as Map import Text.XHtml (Html, HtmlAttr, (!)) import qualified Text.XHtml as Html type StyleClass = String -render :: Maybe FilePath -> Maybe FilePath -> [RichToken] -> Html -render mcss mjs tokens = header mcss mjs <> body tokens +render :: Maybe FilePath -> Maybe FilePath + -> GHC.PackageKey -> SrcMap -> [RichToken] + -> Html +render mcss mjs pkg srcs tokens = header mcss mjs <> body pkg srcs tokens -body :: [RichToken] -> Html -body = Html.body . Html.pre . mconcat . map richToken +body :: GHC.PackageKey -> SrcMap -> [RichToken] -> Html +body pkg srcs = Html.body . Html.pre . mconcat . map (richToken pkg srcs) header :: Maybe FilePath -> Maybe FilePath -> Html header mcss mjs @@ -41,13 +47,13 @@ header mcss mjs = , Html.src scriptFile ] -richToken :: RichToken -> Html -richToken (RichToken tok Nothing) = +richToken :: GHC.PackageKey -> SrcMap -> RichToken -> Html +richToken _ _ (RichToken tok Nothing) = tokenSpan tok ! attrs where attrs = [ multiclass . tokenStyle . tkType $ tok ] -richToken (RichToken tok (Just det)) = - externalAnchor det . internalAnchor det . hyperlink det $ content +richToken pkg srcs (RichToken tok (Just det)) = + externalAnchor det . internalAnchor det . hyperlink pkg srcs det $ content where content = tokenSpan tok ! [ multiclass style] style = (tokenStyle . tkType) tok ++ richTokenStyle det @@ -94,25 +100,29 @@ externalAnchorIdent = hypSrcNameUrl internalAnchorIdent :: GHC.Name -> String internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique -hyperlink :: TokenDetails -> Html -> Html -hyperlink details = case rtkName details of +hyperlink :: GHC.PackageKey -> SrcMap -> TokenDetails -> Html -> Html +hyperlink pkg srcs details = case rtkName details of Left name -> if GHC.isInternalName name then internalHyperlink name - else externalNameHyperlink name + else externalNameHyperlink pkg srcs name Right name -> externalModHyperlink name internalHyperlink :: GHC.Name -> Html -> Html internalHyperlink name content = Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] -externalNameHyperlink :: GHC.Name -> Html -> Html -externalNameHyperlink name content = - Html.anchor content ! [ Html.href href ] +externalNameHyperlink :: GHC.PackageKey -> SrcMap -> GHC.Name -> Html -> Html +externalNameHyperlink pkg srcs name content + | namePkg == pkg = Html.anchor content ! + [ Html.href $ hypSrcModuleNameUrl mdl name ] + | Just path <- Map.lookup namePkg srcs = Html.anchor content ! + [ Html.href $ path hypSrcModuleNameUrl mdl name ] + | otherwise = content where - href = hypSrcModuleNameUrl (GHC.nameModule name) name + mdl = GHC.nameModule name + namePkg = GHC.modulePackageKey mdl externalModHyperlink :: GHC.ModuleName -> Html -> Html externalModHyperlink mdl content = Html.anchor content ! [ Html.href $ hypSrcModuleUrl' mdl ] - -- cgit v1.2.3 From 98cb99c2398a2e2b4467da0a1755d24422384f14 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sun, 28 Jun 2015 21:33:03 +0200 Subject: Disable generating hyperlinks for module references. --- haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index b05a5b8a..89d9b60d 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -123,6 +123,13 @@ externalNameHyperlink pkg srcs name content mdl = GHC.nameModule name namePkg = GHC.modulePackageKey mdl +-- TODO: Implement module hyperlinks. +-- +-- Unfortunately, 'ModuleName' is not enough to provide viable cross-package +-- hyperlink. And the problem is that GHC AST does not have other information +-- on imported modules, so for the time being, we do not provide such reference +-- either. externalModHyperlink :: GHC.ModuleName -> Html -> Html -externalModHyperlink mdl content = - Html.anchor content ! [ Html.href $ hypSrcModuleUrl' mdl ] +externalModHyperlink _ content = + content + --Html.anchor content ! [ Html.href $ hypSrcModuleUrl' mdl ] -- cgit v1.2.3 From 311b3cc529097ef83a8212439dafcabb86534c62 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sun, 28 Jun 2015 22:28:00 +0200 Subject: Prevent source parser from throwing exception when lexing fails. --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 6e195dba..bab5ba0a 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -63,7 +63,9 @@ chunk str@(c:_) chunk str | "--" `isPrefixOf` str = chunk' $ spanToNewline str | "{-" `isPrefixOf` str = chunk' $ chunkComment 0 str - | otherwise = chunk' $ head $ lex str + | otherwise = case lex str of + (tok:_) -> chunk' tok + [] -> [str] where chunk' (c, rest) = c:(chunk rest) -- cgit v1.2.3 From 5a86381db3d73b4b68fdaae5c150a84e91e80c09 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 29 Jun 2015 16:10:03 +0200 Subject: Make hyperlinker generate correct anchors for data constructors. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 275f10e9..c32bb722 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -107,17 +107,22 @@ binds = -- | Obtain details map for top-level declarations. decls :: GHC.RenamedSource -> DetailsMap decls (group, _, _, _) = concatMap ($ group) - [ map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds + [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds , everything (<|>) fun ] where - typ (GHC.L _ t) = - let (GHC.L sspan name) = GHC.tcdLName t - in (sspan, RtkDecl name) + typ (GHC.L _ t) = case t of + GHC.DataDecl (GHC.L sspan name) _ defn _ -> + [(sspan, RtkDecl name)] ++ concatMap con (GHC.dd_cons defn) + _ -> + let (GHC.L sspan name) = GHC.tcdLName t + in pure (sspan, RtkDecl name) fun term = case cast term of (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) | GHC.isExternalName name -> pure (sspan, RtkDecl name) _ -> empty + con (GHC.L _ t) = flip map (GHC.con_names t) $ + \(GHC.L sspan name) -> (sspan, RtkDecl name) -- | Obtain details map for import declarations. -- -- cgit v1.2.3 From 46b1520fcc8ef56825bd42ecf1c1fa8ec899ee58 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 29 Jun 2015 17:33:59 +0200 Subject: Make hyperlinker generate anchors for record field declarations. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index c32bb722..5efcd2ed 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -112,17 +112,19 @@ decls (group, _, _, _) = concatMap ($ group) ] where typ (GHC.L _ t) = case t of - GHC.DataDecl (GHC.L sspan name) _ defn _ -> - [(sspan, RtkDecl name)] ++ concatMap con (GHC.dd_cons defn) - _ -> - let (GHC.L sspan name) = GHC.tcdLName t - in pure (sspan, RtkDecl name) + GHC.DataDecl name _ defn _ -> + [decl name] ++ concatMap con (GHC.dd_cons defn) + _ -> pure . decl $ GHC.tcdLName t fun term = case cast term of (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) | GHC.isExternalName name -> pure (sspan, RtkDecl name) _ -> empty - con (GHC.L _ t) = flip map (GHC.con_names t) $ - \(GHC.L sspan name) -> (sspan, RtkDecl name) + con (GHC.L _ t) = + map decl (GHC.con_names t) ++ everything (<|>) fld t + fld term = case cast term of + Just field -> map decl $ GHC.cd_fld_names field + Nothing -> empty + decl (GHC.L sspan name) = (sspan, RtkDecl name) -- | Obtain details map for import declarations. -- -- cgit v1.2.3 From d6cfd266b30066a5452514b26e50b740104a982b Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 29 Jun 2015 23:00:54 +0200 Subject: Add support for hyperlinking constructor names in patters. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 2 ++ 1 file changed, 2 insertions(+) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 5efcd2ed..fd3f2f1e 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -102,6 +102,8 @@ binds = pat term = case cast term of (Just (GHC.L sspan (GHC.VarPat name))) -> pure (sspan, RtkBind name) + (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) _))) -> + pure (sspan, RtkVar name) _ -> empty -- | Obtain details map for top-level declarations. -- cgit v1.2.3 From a1d3cb1d86340cd670e50f88e1cb8bf4a4e64f7b Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 29 Jun 2015 23:15:26 +0200 Subject: Add support for hyperlinking field names in record patterns. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index fd3f2f1e..3b0e0f44 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -102,7 +102,11 @@ binds = pat term = case cast term of (Just (GHC.L sspan (GHC.VarPat name))) -> pure (sspan, RtkBind name) - (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) _))) -> + (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) -> + [(sspan, RtkVar name)] ++ everything (<|>) rec recs + _ -> empty + rec term = case cast term of + (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.Name) _)) -> pure (sspan, RtkVar name) _ -> empty -- cgit v1.2.3 From 7d269444ea9c55a2b364ead45fe06d435fa078b2 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 29 Jun 2015 23:41:10 +0200 Subject: Add support for hyperlinking field names in record expressions. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 3b0e0f44..c41b5e5f 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -69,11 +69,17 @@ enrichToken _ _ = Nothing -- | Obtain details map for variables ("normally" used identifiers). variables :: GHC.RenamedSource -> DetailsMap variables = - everything (<|>) var + everything (<|>) (var `combine` rec) where var term = case cast term of (Just (GHC.L sspan (GHC.HsVar name))) -> pure (sspan, RtkVar name) + (Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _))) -> + pure (sspan, RtkVar name) + _ -> empty + rec term = case cast term of + Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LHsExpr GHC.Name) _) -> + pure (sspan, RtkVar name) _ -> empty -- | Obtain details map for types. -- cgit v1.2.3 From 6bebd572bc673d10ed68096f935cdc5a9d1839b5 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Tue, 30 Jun 2015 21:58:08 +0200 Subject: Make hyperlinker respect pretty-printer flag and add documentation. --- haddock-api/src/Haddock.hs | 2 +- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 30 +++++++++++++++++++------ 2 files changed, 24 insertions(+), 8 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index c76966fc..02e19531 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -321,7 +321,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do libDir when (Flag_HyperlinkedSource `elem` flags) $ do - ppHyperlinkedSource odir libDir opt_source_css pkgKey srcMap ifaces + ppHyperlinkedSource odir libDir opt_source_css pretty pkgKey srcMap ifaces -- | From GHC 7.10, this function has a potential to crash with a -- nasty message such as @expectJust getPackageDetails@ because diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index f2caa2c1..1fadef49 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -14,35 +14,51 @@ import Data.Maybe import System.Directory import System.FilePath -ppHyperlinkedSource :: FilePath -> FilePath -> Maybe FilePath - -> PackageKey -> SrcMap -> [Interface] + +-- | Generate hyperlinked source for given interfaces. +-- +-- Note that list of interfaces should also contain interfaces normally hidden +-- when generating documentation. Otherwise this could lead to dead links in +-- produced source. +ppHyperlinkedSource :: FilePath -- ^ Output directory + -> FilePath -- ^ Resource directory + -> Maybe FilePath -- ^ Custom CSS file path + -> Bool -- ^ Flag indicating whether to pretty-print HTML + -> PackageKey -- ^ Package for which we create source + -> SrcMap -- ^ Paths to external sources + -> [Interface] -- ^ Interfaces for which we create source -> IO () -ppHyperlinkedSource outdir libdir mstyle pkg srcs ifaces = do +ppHyperlinkedSource outdir libdir mstyle pretty pkg srcs ifaces = do createDirectoryIfMissing True srcdir let cssFile = fromMaybe (defaultCssFile libdir) mstyle copyFile cssFile $ srcdir srcCssFile copyFile (libdir "html" highlightScript) $ srcdir highlightScript - mapM_ (ppHyperlinkedModuleSource srcdir pkg srcs) ifaces + mapM_ (ppHyperlinkedModuleSource srcdir pretty pkg srcs) ifaces where srcdir = outdir hypSrcDir -ppHyperlinkedModuleSource :: FilePath +-- | Generate hyperlinked source for particular interface. +ppHyperlinkedModuleSource :: FilePath -> Bool -> PackageKey -> SrcMap -> Interface -> IO () -ppHyperlinkedModuleSource srcdir pkg srcs iface = +ppHyperlinkedModuleSource srcdir pretty pkg srcs iface = case ifaceTokenizedSrc iface of - Just tokens -> writeFile path . showHtml . render' $ tokens + Just tokens -> writeFile path . html . render' $ tokens Nothing -> return () where render' = render (Just srcCssFile) (Just highlightScript) pkg srcs + html = if pretty then renderHtml else showHtml path = srcdir hypSrcModuleFile (ifaceMod iface) +-- | Name of CSS file in output directory. srcCssFile :: FilePath srcCssFile = "style.css" +-- | Name of highlight script in output and resource directory. highlightScript :: FilePath highlightScript = "highlight.js" +-- | Path to default CSS file. defaultCssFile :: FilePath -> FilePath defaultCssFile libdir = libdir "html" "solarized.css" -- cgit v1.2.3 From f3d1f3cbd6e99f5d477a78e05c13b65b9e8b3fae Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sun, 28 Jun 2015 00:49:17 +0200 Subject: Add basic tests related to comment parsing. --- .../src/Haddock/Backends/Hyperlinker/Parser.hs | 2 +- .../Haddock/Backends/Hyperlinker/ParserSpec.hs | 37 +++++++++++++++++++++- 2 files changed, 37 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index bab5ba0a..019075a1 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -38,7 +38,7 @@ data TokenType | TkCpp | TkPragma | TkUnknown - deriving (Eq) + deriving (Show, Eq) -- | Turn source code string into a stream of more descriptive tokens. -- diff --git a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs index c85fa47e..d5964224 100644 --- a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs +++ b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs @@ -9,9 +9,44 @@ import Haddock.Backends.Hyperlinker.Parser main :: IO () main = hspec spec + spec :: Spec spec = do describe "parse" parseSpec + parseSpec :: Spec -parseSpec = return () +parseSpec = do + + context "when parsing single-line comments" $ do + + it "should ignore content until the end of line" $ + "-- some very simple comment\nidentifier" + `shouldParseTo` + [TkComment, TkSpace, TkIdentifier] + + it "should allow endline escaping" $ + "-- first line\\\nsecond line\\\nand another one" + `shouldParseTo` + [TkComment] + + context "when parsing multi-line comments" $ do + + it "should support nested comments" $ + "{- comment {- nested -} still comment -} {- next comment -}" + `shouldParseTo` + [TkComment, TkSpace, TkComment] + + it "should distinguish compiler pragma" $ + "{- comment -}{-# LANGUAGE GADTs #-}{- comment -}" + `shouldParseTo` + [TkComment, TkPragma, TkComment] + + it "should recognize preprocessor directives" $ do + "\n#define foo bar" `shouldParseTo` [TkSpace, TkCpp] + "x # y" `shouldParseTo` + [TkIdentifier, TkSpace, TkCpp, TkSpace,TkIdentifier] + + +shouldParseTo :: String -> [TokenType] -> Expectation +str `shouldParseTo` tokens = map tkType (parse str) `shouldBe` tokens -- cgit v1.2.3 From b91ee2f4f0869d1c1076813019ce858c53738042 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 1 Jul 2015 18:32:19 +0200 Subject: Add support for hyperlinking synonyms in patterns. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 2 ++ 1 file changed, 2 insertions(+) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index c41b5e5f..8777e26d 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -110,6 +110,8 @@ binds = pure (sspan, RtkBind name) (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) -> [(sspan, RtkVar name)] ++ everything (<|>) rec recs + (Just (GHC.L _ (GHC.AsPat (GHC.L sspan name) _))) -> + pure (sspan, RtkBind name) _ -> empty rec term = case cast term of (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.Name) _)) -> -- cgit v1.2.3 From dd781d18eca0d8c28350093d78926d4a9b474827 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 1 Jul 2015 19:06:04 +0200 Subject: Add support for hyperlinking universally quantified type variables. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 8777e26d..79e31db7 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -99,7 +99,7 @@ types = -- clauses). binds :: GHC.RenamedSource -> DetailsMap binds = - everything (<|>) (fun `combine` pat) + everything (<|>) (fun `combine` pat `combine` tvar) where fun term = case cast term of (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) -> @@ -117,6 +117,12 @@ binds = (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.Name) _)) -> pure (sspan, RtkVar name) _ -> empty + tvar term = case cast term of + (Just (GHC.L sspan (GHC.UserTyVar name))) -> + pure (sspan, RtkBind name) + (Just (GHC.L _ (GHC.KindedTyVar (GHC.L sspan name) _))) -> + pure (sspan, RtkBind name) + _ -> empty -- | Obtain details map for top-level declarations. decls :: GHC.RenamedSource -> DetailsMap -- cgit v1.2.3 From 980664b29a588eef44d8048d4beedce4d2a96b09 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 1 Jul 2015 21:01:42 +0200 Subject: Document some functions in XHTML utlity module. --- haddock-api/src/Haddock/Backends/Xhtml/Utils.hs | 8 ++++++++ 1 file changed, 8 insertions(+) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs index 36ecf863..5166549a 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs @@ -41,11 +41,19 @@ import Module ( Module, ModuleName, moduleName, moduleNameString ) import Name ( getOccString, nameOccName, isValOcc ) +-- | Replace placeholder string elements with provided values. +-- +-- Used to generate URL for customized external paths, usually provided with +-- @--source-module@, @--source-entity@ and related command-line arguments. +-- +-- >>> spliceURL Nothing mmod mname Nothing "output/%{MODULE}.hs#%{NAME}" +-- "output/Foo.hs#foo" spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name -> Maybe SrcSpan -> String -> String spliceURL mfile mmod = spliceURL' mfile (moduleName <$> mmod) +-- | Same as 'spliceURL' but takes 'ModuleName' instead of 'Module'. spliceURL' :: Maybe FilePath -> Maybe ModuleName -> Maybe GHC.Name -> Maybe SrcSpan -> String -> String spliceURL' maybe_file maybe_mod maybe_name maybe_loc = run -- cgit v1.2.3 From 868248d5e847e29ffede5b6c7d20f08a3ec7eb47 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 1 Jul 2015 22:25:21 +0200 Subject: Make hyperlinker render qualified names as one entity. --- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 1 + .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 50 +++++++++++++++++++--- 2 files changed, 46 insertions(+), 5 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 79e31db7..decb1206 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -25,6 +25,7 @@ data TokenDetails | RtkBind GHC.Name | RtkDecl GHC.Name | RtkModule GHC.ModuleName + deriving (Eq) rtkName :: TokenDetails -> Either GHC.Name GHC.ModuleName rtkName (RtkVar name) = Left name diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 89d9b60d..ddb2e5b9 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -19,15 +19,46 @@ import qualified Data.Map as Map import Text.XHtml (Html, HtmlAttr, (!)) import qualified Text.XHtml as Html + type StyleClass = String + render :: Maybe FilePath -> Maybe FilePath -> GHC.PackageKey -> SrcMap -> [RichToken] -> Html render mcss mjs pkg srcs tokens = header mcss mjs <> body pkg srcs tokens + +data TokenGroup + = GrpNormal Token + | GrpRich TokenDetails [Token] + + +-- | Group consecutive tokens pointing to the same element. +-- +-- We want to render qualified identifiers as one entity. For example, +-- @Bar.Baz.foo@ consists of 5 tokens (@Bar@, @.@, @Baz@, @.@, @foo@) but for +-- better user experience when highlighting and clicking links, these tokens +-- should be regarded as one identifier. Therefore, before rendering we must +-- group consecutive elements pointing to the same 'GHC.Name' (note that even +-- dot token has it if it is part of qualified name). +groupTokens :: [RichToken] -> [TokenGroup] +groupTokens [] = [] +groupTokens ((RichToken tok Nothing):rest) = (GrpNormal tok):(groupTokens rest) +groupTokens ((RichToken tok (Just det)):rest) = + let (grp, rest') = span same rest + in (GrpRich det (tok:(map rtkToken grp))):(groupTokens rest') + where + same (RichToken _ (Just det')) = det == det' + same _ = False + + body :: GHC.PackageKey -> SrcMap -> [RichToken] -> Html -body pkg srcs = Html.body . Html.pre . mconcat . map (richToken pkg srcs) +body pkg srcs tokens = + Html.body . Html.pre $ hypsrc + where + hypsrc = mconcat . map (tokenGroup pkg srcs) . groupTokens $ tokens + header :: Maybe FilePath -> Maybe FilePath -> Html header mcss mjs @@ -47,20 +78,29 @@ header mcss mjs = , Html.src scriptFile ] -richToken :: GHC.PackageKey -> SrcMap -> RichToken -> Html -richToken _ _ (RichToken tok Nothing) = + +tokenGroup :: GHC.PackageKey -> SrcMap -> TokenGroup -> Html +tokenGroup _ _ (GrpNormal tok) = tokenSpan tok ! attrs where attrs = [ multiclass . tokenStyle . tkType $ tok ] -richToken pkg srcs (RichToken tok (Just det)) = +tokenGroup pkg srcs (GrpRich det tokens) = externalAnchor det . internalAnchor det . hyperlink pkg srcs det $ content where - content = tokenSpan tok ! [ multiclass style] + content = mconcat . map (richToken det) $ tokens + + +richToken :: TokenDetails -> Token -> Html +richToken det tok = + tokenSpan tok ! [ multiclass style ] + where style = (tokenStyle . tkType) tok ++ richTokenStyle det + tokenSpan :: Token -> Html tokenSpan = Html.thespan . Html.toHtml . tkValue + richTokenStyle :: TokenDetails -> [StyleClass] richTokenStyle (RtkVar _) = ["hs-var"] richTokenStyle (RtkType _) = ["hs-type"] -- cgit v1.2.3 From 0d0550cdcf3fa7ceff88e2572f7ffb341b9f760d Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 2 Jul 2015 12:32:59 +0200 Subject: Fix crash happening when hyperlinking type family declarations. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 1 + 1 file changed, 1 insertion(+) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index decb1206..c12ac35a 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -135,6 +135,7 @@ decls (group, _, _, _) = concatMap ($ group) typ (GHC.L _ t) = case t of GHC.DataDecl name _ defn _ -> [decl name] ++ concatMap con (GHC.dd_cons defn) + GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam _ -> pure . decl $ GHC.tcdLName t fun term = case cast term of (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) -- cgit v1.2.3 From 5c01af0e605c2bd16382cbd0de7102f1fbc2f361 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 2 Jul 2015 12:47:03 +0200 Subject: Add support for anchoring data family constructor declarations. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index c12ac35a..b592326d 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -129,20 +129,21 @@ binds = decls :: GHC.RenamedSource -> DetailsMap decls (group, _, _, _) = concatMap ($ group) [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds - , everything (<|>) fun + , everything (<|>) (fun `combine` con) ] where typ (GHC.L _ t) = case t of - GHC.DataDecl name _ defn _ -> - [decl name] ++ concatMap con (GHC.dd_cons defn) + GHC.DataDecl name _ _ _ -> pure . decl $ name GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam _ -> pure . decl $ GHC.tcdLName t fun term = case cast term of (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) | GHC.isExternalName name -> pure (sspan, RtkDecl name) _ -> empty - con (GHC.L _ t) = - map decl (GHC.con_names t) ++ everything (<|>) fld t + con term = case cast term of + (Just cdcl) -> + map decl (GHC.con_names cdcl) ++ everything (<|>) fld cdcl + Nothing -> empty fld term = case cast term of Just field -> map decl $ GHC.cd_fld_names field Nothing -> empty -- cgit v1.2.3 From 28e93ceec440d0d1ed053bbf3c20e4bdcd6d5f4e Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 2 Jul 2015 13:31:05 +0200 Subject: Improve support for hyperlinking type families. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 8 +++++++- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 1 + 2 files changed, 8 insertions(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index b592326d..4b60ca37 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -129,7 +129,7 @@ binds = decls :: GHC.RenamedSource -> DetailsMap decls (group, _, _, _) = concatMap ($ group) [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds - , everything (<|>) (fun `combine` con) + , everything (<|>) (fun `combine` con `combine` ins) ] where typ (GHC.L _ t) = case t of @@ -144,10 +144,16 @@ decls (group, _, _, _) = concatMap ($ group) (Just cdcl) -> map decl (GHC.con_names cdcl) ++ everything (<|>) fld cdcl Nothing -> empty + ins term = case cast term of + (Just (GHC.DataFamInstD inst)) -> pure . tyref $ GHC.dfid_tycon inst + (Just (GHC.TyFamInstD (GHC.TyFamInstDecl (GHC.L _ eqn) _))) -> + pure . tyref $ GHC.tfe_tycon eqn + _ -> empty fld term = case cast term of Just field -> map decl $ GHC.cd_fld_names field Nothing -> empty decl (GHC.L sspan name) = (sspan, RtkDecl name) + tyref (GHC.L sspan name) = (sspan, RtkType name) -- | Obtain details map for import declarations. -- diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 019075a1..37cc5377 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -197,6 +197,7 @@ keywords = , "type" , "where" , "forall" + , "family" , "mdo" ] -- cgit v1.2.3 From aa6c6deba47af1c21765ed09dc0317825aa1d78d Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 2 Jul 2015 13:41:38 +0200 Subject: Fix issue with operators being recognized as preprocessor directives. --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 6 +++--- hypsrc-test/src/Operators.hs | 4 ++++ 2 files changed, 7 insertions(+), 3 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 37cc5377..d927aa08 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -156,17 +156,17 @@ classify str | "--" `isPrefixOf` str = TkComment | "{-#" `isPrefixOf` str = TkPragma | "{-" `isPrefixOf` str = TkComment -classify (c:_) +classify str@(c:_) | isSpace c = TkSpace | isDigit c = TkNumber | c `elem` special = TkSpecial + | str `elem` glyphs = TkGlyph + | all (`elem` symbols) str = TkOperator | c == '#' = TkCpp | c == '"' = TkString | c == '\'' = TkChar classify str | str `elem` keywords = TkKeyword - | str `elem` glyphs = TkGlyph - | all (`elem` symbols) str = TkOperator | isIdentifier str = TkIdentifier | otherwise = TkUnknown diff --git a/hypsrc-test/src/Operators.hs b/hypsrc-test/src/Operators.hs index bc76c2d3..8e86ab0b 100644 --- a/hypsrc-test/src/Operators.hs +++ b/hypsrc-test/src/Operators.hs @@ -16,3 +16,7 @@ a */\* b = concatMap (*** b) a (**/\**) :: [[a]] -> [[a]] -> [[a]] a **/\** b = zipWith (*/\*) [a +++ b] (a $$$ b) + + +(#.#) :: a -> b -> (c -> (a, b)) +a #.# b = const $ (a, b) -- cgit v1.2.3 From d761512f239b17f8e9824629595d75aa46e55554 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 2 Jul 2015 18:53:28 +0200 Subject: Add support for anchoring signatures in type class declarations. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 5 +++++ 1 file changed, 5 insertions(+) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 4b60ca37..98c9770f 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -1,5 +1,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} + module Haddock.Backends.Hyperlinker.Ast ( enrich @@ -135,6 +137,7 @@ decls (group, _, _, _) = concatMap ($ group) typ (GHC.L _ t) = case t of GHC.DataDecl name _ _ _ -> pure . decl $ name GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam + GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs _ -> pure . decl $ GHC.tcdLName t fun term = case cast term of (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) @@ -152,6 +155,8 @@ decls (group, _, _, _) = concatMap ($ group) fld term = case cast term of Just field -> map decl $ GHC.cd_fld_names field Nothing -> empty + 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) -- cgit v1.2.3 From ef3b8691ea607bd4f67d5dc77bb226cf57ec4c30 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Thu, 2 Jul 2015 19:04:47 +0200 Subject: Make hyperlinker generate anchors only to top-level value bindings. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 98c9770f..1e121c2e 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -131,7 +131,8 @@ binds = decls :: GHC.RenamedSource -> DetailsMap decls (group, _, _, _) = concatMap ($ group) [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds - , everything (<|>) (fun `combine` con `combine` ins) + , everything (<|>) fun . GHC.hs_valds + , everything (<|>) (con `combine` ins) ] where typ (GHC.L _ t) = case t of -- cgit v1.2.3 From a86147030e0f8fe33ebd4b358ac04d3beb45c3f8 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 4 Jul 2015 17:15:26 +0200 Subject: Remove potentially dangerous record access in hyperlinker AST module. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 1e121c2e..9d5c127d 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -137,9 +137,9 @@ decls (group, _, _, _) = concatMap ($ group) where typ (GHC.L _ t) = case t of GHC.DataDecl name _ _ _ -> pure . decl $ name + GHC.SynDecl name _ _ _ -> pure . decl $ name GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs - _ -> pure . decl $ GHC.tcdLName t fun term = case cast term of (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) | GHC.isExternalName name -> pure (sspan, RtkDecl name) -- cgit v1.2.3 From 99980dcc63d696c7912ff1f0d2faadcce169f184 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sun, 5 Jul 2015 17:06:36 +0200 Subject: Refactor source path mapping to use modules as indices. --- haddock-api/src/Haddock.hs | 27 ++++++++++------ haddock-api/src/Haddock/Backends/Hyperlinker.hs | 15 ++++----- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 36 ++++++++++------------ haddock-api/src/Haddock/InterfaceFile.hs | 11 ++++--- haddock-api/src/Haddock/Types.hs | 9 +++++- 5 files changed, 55 insertions(+), 43 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 5a1c6abe..5c48d28b 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -46,6 +46,7 @@ import Data.List (isPrefixOf) import Control.Exception import Data.Maybe import Data.IORef +import Data.Map (Map) import qualified Data.Map as Map import System.IO import System.Exit @@ -228,13 +229,14 @@ renderStep dflags flags qual pkgs interfaces = do let ifaceFiles = map snd pkgs installedIfaces = concatMap ifInstalledIfaces ifaceFiles - srcMap = Map.fromList [ (ifPackageKey if_, x) | ((_, Just x), if_) <- pkgs ] - render dflags flags qual interfaces installedIfaces srcMap + extSrcMap = Map.fromList + [ (ifModule ifile, path) | ((_, Just path), ifile) <- pkgs ] + render dflags flags qual interfaces installedIfaces extSrcMap -- | Render the interfaces with whatever backend is specified in the flags. -render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> SrcMap -> IO () -render dflags flags qual ifaces installedIfaces srcMap = do +render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> Map Module FilePath -> IO () +render dflags flags qual ifaces installedIfaces extSrcMap = do let title = fromMaybe "" (optTitle flags) @@ -264,15 +266,20 @@ render dflags flags qual ifaces installedIfaces srcMap = do | Flag_HyperlinkedSource `elem` flags = Just hypSrcModuleUrlFormat | otherwise = srcModule - srcMap' + srcMap = Map.union + (Map.map SrcExternal extSrcMap) + (Map.fromList [ (ifaceMod iface, SrcLocal) | iface <- ifaces ]) + + pkgSrcMap = Map.mapKeys modulePackageKey extSrcMap + pkgSrcMap' | Flag_HyperlinkedSource `elem` flags = - Map.insert pkgKey hypSrcModuleNameUrlFormat srcMap - | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl srcMap - | otherwise = srcMap + Map.insert pkgKey hypSrcModuleNameUrlFormat pkgSrcMap + | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl pkgSrcMap + | otherwise = pkgSrcMap -- TODO: Get these from the interface files as with srcMap srcLMap' = maybe Map.empty (\path -> Map.singleton pkgKey path) srcLEntity - sourceUrls' = (srcBase, srcModule', srcMap', srcLMap') + sourceUrls' = (srcBase, srcModule', pkgSrcMap', srcLMap') libDir <- getHaddockLibDir flags prologue <- getPrologue dflags flags @@ -322,7 +329,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do libDir when (Flag_HyperlinkedSource `elem` flags) $ do - ppHyperlinkedSource odir libDir opt_source_css pretty pkgKey srcMap ifaces + ppHyperlinkedSource odir libDir opt_source_css pretty srcMap ifaces -- | From GHC 7.10, this function has a potential to crash with a -- nasty message such as @expectJust getPackageDetails@ because diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 1fadef49..f007f970 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -8,7 +8,6 @@ import Haddock.Backends.Hyperlinker.Renderer import Haddock.Backends.Hyperlinker.Utils import Text.XHtml hiding (()) -import GHC import Data.Maybe import System.Directory @@ -24,30 +23,28 @@ ppHyperlinkedSource :: FilePath -- ^ Output directory -> FilePath -- ^ Resource directory -> Maybe FilePath -- ^ Custom CSS file path -> Bool -- ^ Flag indicating whether to pretty-print HTML - -> PackageKey -- ^ Package for which we create source - -> SrcMap -- ^ Paths to external sources + -> SrcMap -- ^ Paths to sources -> [Interface] -- ^ Interfaces for which we create source -> IO () -ppHyperlinkedSource outdir libdir mstyle pretty pkg srcs ifaces = do +ppHyperlinkedSource outdir libdir mstyle pretty srcs ifaces = do createDirectoryIfMissing True srcdir let cssFile = fromMaybe (defaultCssFile libdir) mstyle copyFile cssFile $ srcdir srcCssFile copyFile (libdir "html" highlightScript) $ srcdir highlightScript - mapM_ (ppHyperlinkedModuleSource srcdir pretty pkg srcs) ifaces + mapM_ (ppHyperlinkedModuleSource srcdir pretty srcs) ifaces where srcdir = outdir hypSrcDir -- | Generate hyperlinked source for particular interface. -ppHyperlinkedModuleSource :: FilePath -> Bool - -> PackageKey -> SrcMap -> Interface +ppHyperlinkedModuleSource :: FilePath -> Bool -> SrcMap -> Interface -> IO () -ppHyperlinkedModuleSource srcdir pretty pkg srcs iface = +ppHyperlinkedModuleSource srcdir pretty srcs iface = case ifaceTokenizedSrc iface of Just tokens -> writeFile path . html . render' $ tokens Nothing -> return () where - render' = render (Just srcCssFile) (Just highlightScript) pkg srcs + render' = render (Just srcCssFile) (Just highlightScript) srcs html = if pretty then renderHtml else showHtml path = srcdir hypSrcModuleFile (ifaceMod iface) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index ddb2e5b9..a4d7bc2d 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -23,10 +23,9 @@ import qualified Text.XHtml as Html type StyleClass = String -render :: Maybe FilePath -> Maybe FilePath - -> GHC.PackageKey -> SrcMap -> [RichToken] +render :: Maybe FilePath -> Maybe FilePath -> SrcMap -> [RichToken] -> Html -render mcss mjs pkg srcs tokens = header mcss mjs <> body pkg srcs tokens +render mcss mjs srcs tokens = header mcss mjs <> body srcs tokens data TokenGroup @@ -53,11 +52,11 @@ groupTokens ((RichToken tok (Just det)):rest) = same _ = False -body :: GHC.PackageKey -> SrcMap -> [RichToken] -> Html -body pkg srcs tokens = +body :: SrcMap -> [RichToken] -> Html +body srcs tokens = Html.body . Html.pre $ hypsrc where - hypsrc = mconcat . map (tokenGroup pkg srcs) . groupTokens $ tokens + hypsrc = mconcat . map (tokenGroup srcs) . groupTokens $ tokens header :: Maybe FilePath -> Maybe FilePath -> Html @@ -79,13 +78,13 @@ header mcss mjs = ] -tokenGroup :: GHC.PackageKey -> SrcMap -> TokenGroup -> Html -tokenGroup _ _ (GrpNormal tok) = +tokenGroup :: SrcMap -> TokenGroup -> Html +tokenGroup _ (GrpNormal tok) = tokenSpan tok ! attrs where attrs = [ multiclass . tokenStyle . tkType $ tok ] -tokenGroup pkg srcs (GrpRich det tokens) = - externalAnchor det . internalAnchor det . hyperlink pkg srcs det $ content +tokenGroup srcs (GrpRich det tokens) = + externalAnchor det . internalAnchor det . hyperlink srcs det $ content where content = mconcat . map (richToken det) $ tokens @@ -140,28 +139,27 @@ externalAnchorIdent = hypSrcNameUrl internalAnchorIdent :: GHC.Name -> String internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique -hyperlink :: GHC.PackageKey -> SrcMap -> TokenDetails -> Html -> Html -hyperlink pkg srcs details = case rtkName details of +hyperlink :: SrcMap -> TokenDetails -> Html -> Html +hyperlink srcs details = case rtkName details of Left name -> if GHC.isInternalName name then internalHyperlink name - else externalNameHyperlink pkg srcs name + else externalNameHyperlink srcs name Right name -> externalModHyperlink name internalHyperlink :: GHC.Name -> Html -> Html internalHyperlink name content = Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] -externalNameHyperlink :: GHC.PackageKey -> SrcMap -> GHC.Name -> Html -> Html -externalNameHyperlink pkg srcs name content - | namePkg == pkg = Html.anchor content ! +externalNameHyperlink :: SrcMap -> GHC.Name -> Html -> Html +externalNameHyperlink srcs name content = case Map.lookup mdl srcs of + Just SrcLocal -> Html.anchor content ! [ Html.href $ hypSrcModuleNameUrl mdl name ] - | Just path <- Map.lookup namePkg srcs = Html.anchor content ! + Just (SrcExternal path) -> Html.anchor content ! [ Html.href $ path hypSrcModuleNameUrl mdl name ] - | otherwise = content + Nothing -> content where mdl = GHC.nameModule name - namePkg = GHC.modulePackageKey mdl -- TODO: Implement module hyperlinks. -- diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 4b39d315..d5762ce8 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -14,7 +14,7 @@ -- Reading and writing the .haddock interface file ----------------------------------------------------------------------------- module Haddock.InterfaceFile ( - InterfaceFile(..), ifPackageKey, + InterfaceFile(..), ifModule, ifPackageKey, readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor, writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility ) where @@ -51,11 +51,14 @@ data InterfaceFile = InterfaceFile { } -ifPackageKey :: InterfaceFile -> PackageKey -ifPackageKey if_ = +ifModule :: InterfaceFile -> Module +ifModule if_ = case ifInstalledIfaces if_ of [] -> error "empty InterfaceFile" - iface:_ -> modulePackageKey $ instMod iface + iface:_ -> instMod iface + +ifPackageKey :: InterfaceFile -> PackageKey +ifPackageKey = modulePackageKey . ifModule binaryInterfaceMagic :: Word32 diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index fbb5f44c..da4b3eec 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -50,7 +50,7 @@ type SubMap = Map Name [Name] type DeclMap = Map Name [LHsDecl Name] type InstMap = Map SrcSpan Name type FixMap = Map Name Fixity -type SrcMap = Map PackageKey FilePath +type SrcMap = Map Module SrcPath type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources @@ -271,6 +271,13 @@ unrenameDocForDecl (doc, fnArgsDoc) = -- | Type of environment used to cross-reference identifiers in the syntax. type LinkEnv = Map Name Module +-- | Path for making cross-package hyperlinks in generated sources. +-- +-- Used in 'SrcMap' to determine whether module originates in current package +-- or in an external package. +data SrcPath + = SrcExternal FilePath + | SrcLocal -- | Extends 'Name' with cross-reference information. data DocName -- cgit v1.2.3 From fcaa46b054fc3b5a5535a748d3c3283629e3eadf Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 6 Jul 2015 16:39:57 +0200 Subject: Extract main hyperlinker types to separate module. --- haddock-api/haddock-api.cabal | 1 + haddock-api/src/Haddock/Backends/Hyperlinker.hs | 1 + .../src/Haddock/Backends/Hyperlinker/Ast.hs | 27 ++-------- .../src/Haddock/Backends/Hyperlinker/Parser.hs | 40 ++------------- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 4 +- .../src/Haddock/Backends/Hyperlinker/Types.hs | 59 ++++++++++++++++++++++ .../src/Haddock/Backends/Hyperlinker/Utils.hs | 1 + haddock-api/src/Haddock/Interface/Create.hs | 1 + haddock-api/src/Haddock/Types.hs | 3 +- haddock.cabal | 5 ++ 10 files changed, 79 insertions(+), 63 deletions(-) create mode 100644 haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 11567f99..3838c3d8 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -85,6 +85,7 @@ library Haddock.Backends.Hyperlinker.Ast Haddock.Backends.Hyperlinker.Parser Haddock.Backends.Hyperlinker.Renderer + Haddock.Backends.Hyperlinker.Types Haddock.Backends.Hyperlinker.Utils Haddock.ModuleTree Haddock.Types diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index f007f970..4b58190c 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -3,6 +3,7 @@ module Haddock.Backends.Hyperlinker , module Haddock.Backends.Hyperlinker.Utils ) where + import Haddock.Types import Haddock.Backends.Hyperlinker.Renderer import Haddock.Backends.Hyperlinker.Utils diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 9d5c127d..28fdc3f5 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -3,12 +3,10 @@ {-# LANGUAGE RecordWildCards #-} -module Haddock.Backends.Hyperlinker.Ast - ( enrich - , RichToken(..), TokenDetails(..), rtkName - ) where +module Haddock.Backends.Hyperlinker.Ast (enrich) where -import Haddock.Backends.Hyperlinker.Parser + +import Haddock.Backends.Hyperlinker.Types import qualified GHC @@ -16,25 +14,6 @@ import Control.Applicative import Data.Data import Data.Maybe -data RichToken = RichToken - { rtkToken :: Token - , rtkDetails :: Maybe TokenDetails - } - -data TokenDetails - = RtkVar GHC.Name - | RtkType GHC.Name - | RtkBind GHC.Name - | RtkDecl GHC.Name - | RtkModule GHC.ModuleName - deriving (Eq) - -rtkName :: TokenDetails -> Either GHC.Name GHC.ModuleName -rtkName (RtkVar name) = Left name -rtkName (RtkType name) = Left name -rtkName (RtkBind name) = Left name -rtkName (RtkDecl name) = Left name -rtkName (RtkModule name) = Right name -- | Add more detailed information to token stream using GHC API. enrich :: GHC.RenamedSource -> [Token] -> [RichToken] diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index d927aa08..e206413e 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -1,44 +1,12 @@ -module Haddock.Backends.Hyperlinker.Parser - ( parse - , Token(..), TokenType(..) - , Position(..), Span(..) - ) where +module Haddock.Backends.Hyperlinker.Parser (parse) where + import Data.Char import Data.List import Data.Maybe -data Token = Token - { tkType :: TokenType - , tkValue :: String - , tkSpan :: Span - } - -data Position = Position - { posRow :: !Int - , posCol :: !Int - } - -data Span = Span - { spStart :: Position - , spEnd :: Position - } - -data TokenType - = TkIdentifier - | TkKeyword - | TkString - | TkChar - | TkNumber - | TkOperator - | TkGlyph - | TkSpecial - | TkSpace - | TkComment - | TkCpp - | TkPragma - | TkUnknown - deriving (Show, Eq) +import Haddock.Backends.Hyperlinker.Types + -- | Turn source code string into a stream of more descriptive tokens. -- diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index a4d7bc2d..add1465b 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -1,8 +1,8 @@ module Haddock.Backends.Hyperlinker.Renderer (render) where + import Haddock.Types -import Haddock.Backends.Hyperlinker.Parser -import Haddock.Backends.Hyperlinker.Ast +import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Utils import qualified GHC diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs new file mode 100644 index 00000000..19cc5288 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs @@ -0,0 +1,59 @@ +module Haddock.Backends.Hyperlinker.Types where + + +import qualified GHC + + +data Token = Token + { tkType :: TokenType + , tkValue :: String + , tkSpan :: Span + } + +data Position = Position + { posRow :: !Int + , posCol :: !Int + } + +data Span = Span + { spStart :: Position + , spEnd :: Position + } + +data TokenType + = TkIdentifier + | TkKeyword + | TkString + | TkChar + | TkNumber + | TkOperator + | TkGlyph + | TkSpecial + | TkSpace + | TkComment + | TkCpp + | TkPragma + | TkUnknown + deriving (Show, Eq) + + +data RichToken = RichToken + { rtkToken :: Token + , rtkDetails :: Maybe TokenDetails + } + +data TokenDetails + = RtkVar GHC.Name + | RtkType GHC.Name + | RtkBind GHC.Name + | RtkDecl GHC.Name + | RtkModule GHC.ModuleName + deriving (Eq) + + +rtkName :: TokenDetails -> Either GHC.Name GHC.ModuleName +rtkName (RtkVar name) = Left name +rtkName (RtkType name) = Left name +rtkName (RtkBind name) = Left name +rtkName (RtkDecl name) = Left name +rtkName (RtkModule name) = Right name diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs index 9ba8446d..db2bfc76 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs @@ -4,6 +4,7 @@ module Haddock.Backends.Hyperlinker.Utils , hypSrcModuleUrlFormat, hypSrcModuleNameUrlFormat, ) where + import Haddock.Backends.Xhtml.Utils import GHC diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 59f7076f..0599151e 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -21,6 +21,7 @@ import Haddock.GhcUtils import Haddock.Utils import Haddock.Convert import Haddock.Interface.LexParseRn +import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Ast as Hyperlinker import Haddock.Backends.Hyperlinker.Parser as Hyperlinker diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index da4b3eec..90dbb4d4 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -35,7 +35,8 @@ import DynFlags (ExtensionFlag, Language) import OccName import Outputable import Control.Monad (ap) -import Haddock.Backends.Hyperlinker.Ast + +import Haddock.Backends.Hyperlinker.Types ----------------------------------------------------------------------------- -- * Convenient synonyms diff --git a/haddock.cabal b/haddock.cabal index 2a1caee7..8fa9f33d 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -104,6 +104,11 @@ executable haddock Haddock.Backends.HaddockDB Haddock.Backends.Hoogle Haddock.Backends.Hyperlinker + Haddock.Backends.Hyperlinker.Ast + Haddock.Backends.Hyperlinker.Parser + Haddock.Backends.Hyperlinker.Renderer + Haddock.Backends.Hyperlinker.Types + Haddock.Backends.Hyperlinker.Utils Haddock.ModuleTree Haddock.Types Haddock.Doc -- cgit v1.2.3 From 13254609062a16e010d1c5a24e571dfe98ab6f69 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 6 Jul 2015 16:52:13 +0200 Subject: Move source paths types to hyperlinker types module. --- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 2 ++ haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 1 - haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs | 13 +++++++++++++ haddock-api/src/Haddock/Types.hs | 9 --------- 4 files changed, 15 insertions(+), 10 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 4b58190c..248a8a54 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -1,11 +1,13 @@ module Haddock.Backends.Hyperlinker ( ppHyperlinkedSource + , module Haddock.Backends.Hyperlinker.Types , module Haddock.Backends.Hyperlinker.Utils ) where import Haddock.Types import Haddock.Backends.Hyperlinker.Renderer +import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Utils import Text.XHtml hiding (()) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index add1465b..1065897d 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -1,7 +1,6 @@ module Haddock.Backends.Hyperlinker.Renderer (render) where -import Haddock.Types import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Utils diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs index 19cc5288..ecb51a07 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs @@ -3,6 +3,8 @@ module Haddock.Backends.Hyperlinker.Types where import qualified GHC +import Data.Map (Map) + data Token = Token { tkType :: TokenType @@ -57,3 +59,14 @@ rtkName (RtkType name) = Left name rtkName (RtkBind name) = Left name rtkName (RtkDecl name) = Left name rtkName (RtkModule name) = Right name + + +-- | Path for making cross-package hyperlinks in generated sources. +-- +-- Used in 'SrcMap' to determine whether module originates in current package +-- or in an external package. +data SrcPath + = SrcExternal FilePath + | SrcLocal + +type SrcMap = Map GHC.Module SrcPath diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 90dbb4d4..6dd64506 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -51,7 +51,6 @@ type SubMap = Map Name [Name] type DeclMap = Map Name [LHsDecl Name] type InstMap = Map SrcSpan Name type FixMap = Map Name Fixity -type SrcMap = Map Module SrcPath type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources @@ -272,14 +271,6 @@ unrenameDocForDecl (doc, fnArgsDoc) = -- | Type of environment used to cross-reference identifiers in the syntax. type LinkEnv = Map Name Module --- | Path for making cross-package hyperlinks in generated sources. --- --- Used in 'SrcMap' to determine whether module originates in current package --- or in an external package. -data SrcPath - = SrcExternal FilePath - | SrcLocal - -- | Extends 'Name' with cross-reference information. data DocName = Documented Name Module -- cgit v1.2.3 From bbd036ad309c95ce70affa5aa0a77a61aa5569c8 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 6 Jul 2015 17:06:19 +0200 Subject: Add support for hyperlinking modules in import lists. --- haddock-api/src/Haddock.hs | 2 +- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 21 +++++++++------------ .../src/Haddock/Backends/Hyperlinker/Types.hs | 10 +++++++--- 3 files changed, 17 insertions(+), 16 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index d4d8e3e6..350a73ea 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -268,7 +268,7 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do | Flag_HyperlinkedSource `elem` flags = Just hypSrcModuleUrlFormat | otherwise = srcModule - srcMap = Map.union + srcMap = mkSrcMap $ Map.union (Map.map SrcExternal extSrcMap) (Map.fromList [ (ifaceMod iface, SrcLocal) | iface <- ifaces ]) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 1065897d..5037421a 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -144,14 +144,14 @@ hyperlink srcs details = case rtkName details of if GHC.isInternalName name then internalHyperlink name else externalNameHyperlink srcs name - Right name -> externalModHyperlink name + Right name -> externalModHyperlink srcs name internalHyperlink :: GHC.Name -> Html -> Html internalHyperlink name content = Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] externalNameHyperlink :: SrcMap -> GHC.Name -> Html -> Html -externalNameHyperlink srcs name content = case Map.lookup mdl srcs of +externalNameHyperlink (srcs, _) name content = case Map.lookup mdl srcs of Just SrcLocal -> Html.anchor content ! [ Html.href $ hypSrcModuleNameUrl mdl name ] Just (SrcExternal path) -> Html.anchor content ! @@ -160,13 +160,10 @@ externalNameHyperlink srcs name content = case Map.lookup mdl srcs of where mdl = GHC.nameModule name --- TODO: Implement module hyperlinks. --- --- Unfortunately, 'ModuleName' is not enough to provide viable cross-package --- hyperlink. And the problem is that GHC AST does not have other information --- on imported modules, so for the time being, we do not provide such reference --- either. -externalModHyperlink :: GHC.ModuleName -> Html -> Html -externalModHyperlink _ content = - content - --Html.anchor content ! [ Html.href $ hypSrcModuleUrl' mdl ] +externalModHyperlink :: SrcMap -> GHC.ModuleName -> Html -> Html +externalModHyperlink (_, srcs) name content = case Map.lookup name srcs of + Just SrcLocal -> Html.anchor content ! + [ Html.href $ hypSrcModuleUrl' name ] + Just (SrcExternal path) -> Html.anchor content ! + [ Html.href $ path hypSrcModuleUrl' name ] + Nothing -> content diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs index ecb51a07..c3954dc9 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs @@ -4,6 +4,7 @@ module Haddock.Backends.Hyperlinker.Types where import qualified GHC import Data.Map (Map) +import qualified Data.Map as Map data Token = Token @@ -66,7 +67,10 @@ rtkName (RtkModule name) = Right name -- Used in 'SrcMap' to determine whether module originates in current package -- or in an external package. data SrcPath - = SrcExternal FilePath - | SrcLocal + = SrcExternal FilePath + | SrcLocal -type SrcMap = Map GHC.Module SrcPath +type SrcMap = (Map GHC.Module SrcPath, Map GHC.ModuleName SrcPath) + +mkSrcMap :: Map GHC.Module SrcPath -> SrcMap +mkSrcMap srcs = (srcs, Map.mapKeys GHC.moduleName srcs) -- cgit v1.2.3 From b6e9968643bc0ab6c61289ecee7205e4d7bc421a Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 6 Jul 2015 17:26:49 +0200 Subject: Add short documentation for hyperlinker source map type. --- haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs | 9 +++++++++ 1 file changed, 9 insertions(+) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs index c3954dc9..5f4dbc8c 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs @@ -70,6 +70,15 @@ data SrcPath = SrcExternal FilePath | SrcLocal +-- | Mapping from modules to cross-package source paths. +-- +-- This mapping is actually a pair of maps instead of just one map. The reason +-- for this is because when hyperlinking modules in import lists we have no +-- 'GHC.Module' available. On the other hand, we can't just use map with +-- 'GHC.ModuleName' as indices because certain modules may have common name +-- but originate in different packages. Hence, we use both /rich/ and /poor/ +-- versions, where the /poor/ is just projection of /rich/ one cached in pair +-- for better performance. type SrcMap = (Map GHC.Module SrcPath, Map GHC.ModuleName SrcPath) mkSrcMap :: Map GHC.Module SrcPath -> SrcMap -- cgit v1.2.3 From 0e1cad7c38ed1a771794d9332233f784a52d2c1a Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 6 Jul 2015 18:07:20 +0200 Subject: Fix bug with module name being hyperlinked to `Prelude`. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 7 ++++--- haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs | 1 + 2 files changed, 5 insertions(+), 3 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 28fdc3f5..71b73663 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -146,7 +146,7 @@ decls (group, _, _, _) = concatMap ($ group) -- import lists. imports :: GHC.RenamedSource -> DetailsMap imports src@(_, imps, _, _) = - everything (<|>) ie src ++ map (imp . GHC.unLoc) imps + everything (<|>) ie src ++ mapMaybe (imp . GHC.unLoc) imps where ie term = case cast term of (Just (GHC.IEVar v)) -> pure $ var v @@ -156,9 +156,10 @@ imports src@(_, imps, _, _) = _ -> empty typ (GHC.L sspan name) = (sspan, RtkType name) var (GHC.L sspan name) = (sspan, RtkVar name) - imp idecl = + imp idecl | not . GHC.ideclImplicit $ idecl = let (GHC.L sspan name) = GHC.ideclName idecl - in (sspan, RtkModule name) + in Just (sspan, RtkModule name) + imp _ = Nothing -- | Check whether token stream span matches GHC source span. -- diff --git a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs index a76bdcdc..8cd2690e 100644 --- a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs +++ b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs @@ -5,6 +5,7 @@ import Test.Hspec import Test.QuickCheck import Haddock.Backends.Hyperlinker.Parser +import Haddock.Backends.Hyperlinker.Types main :: IO () -- cgit v1.2.3 From 06e675167cc217d5346d706e0d52af0726710e3d Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Tue, 7 Jul 2015 23:58:52 +0100 Subject: Delete trailing whitespace --- haddock-api/resources/html/frames.html | 2 +- haddock-api/resources/html/haddock-util.js | 22 +++++++++++----------- haddock-api/src/Haddock/Backends/HaddockDB.hs | 18 +++++++++--------- haddock-api/src/Haddock/Backends/Xhtml/Utils.hs | 2 +- haddock-api/src/Haddock/Version.hs | 2 +- haddock-library/LICENSE | 4 ++-- html-test/README.markdown | 2 +- html-test/ref/frames.html | 2 +- html-test/ref/haddock-util.js | 22 +++++++++++----------- html-test/src/Bugs.hs | 2 +- hypsrc-test/ref/src/Classes.html | 2 +- hypsrc-test/src/Classes.hs | 2 +- 12 files changed, 41 insertions(+), 41 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/resources/html/frames.html b/haddock-api/resources/html/frames.html index 1b4e38d4..e86edb66 100644 --- a/haddock-api/resources/html/frames.html +++ b/haddock-api/resources/html/frames.html @@ -1,4 +1,4 @@ - diff --git a/haddock-api/resources/html/haddock-util.js b/haddock-api/resources/html/haddock-util.js index 9a6fccf7..ba574356 100644 --- a/haddock-api/resources/html/haddock-util.js +++ b/haddock-api/resources/html/haddock-util.js @@ -131,11 +131,11 @@ function perform_search(full) var text = document.getElementById("searchbox").value.toLowerCase(); if (text == last_search && !full) return; last_search = text; - + var table = document.getElementById("indexlist"); var status = document.getElementById("searchmsg"); var children = table.firstChild.childNodes; - + // first figure out the first node with the prefix var first = bisect(-1); var last = (first == -1 ? -1 : bisect(1)); @@ -166,7 +166,7 @@ function perform_search(full) status.innerHTML = ""; } - + function setclass(first, last, status) { for (var i = first; i <= last; i++) @@ -174,8 +174,8 @@ function perform_search(full) children[i].className = status; } } - - + + // do a binary search, treating 0 as ... // return either -1 (no 0's found) or location of most far match function bisect(dir) @@ -201,9 +201,9 @@ function perform_search(full) if (checkitem(i) == 0) return i; } return -1; - } - - + } + + // from an index, decide what the result is // 0 = match, -1 is lower, 1 is higher function checkitem(i) @@ -212,8 +212,8 @@ function perform_search(full) if (s == text) return 0; else return (s > text ? -1 : 1); } - - + + // from an index, get its string // this abstracts over alternates function getitem(i) @@ -250,7 +250,7 @@ function addMenuItem(html) { function adjustForFrames() { var bodyCls; - + if (parent.location.href == window.location.href) { // not in frames, so add Frames button addMenuItem("Frames"); diff --git a/haddock-api/src/Haddock/Backends/HaddockDB.hs b/haddock-api/src/Haddock/Backends/HaddockDB.hs index 1c248bfb..0bdc9057 100644 --- a/haddock-api/src/Haddock/Backends/HaddockDB.hs +++ b/haddock-api/src/Haddock/Backends/HaddockDB.hs @@ -40,7 +40,7 @@ ppIfaces mods where do_mod (Module mod, iface) = text " text mod <> text "\">" - $$ text "<literal>" + $$ text "<title><literal>" <> text mod <> text "</literal>" $$ text "" @@ -50,10 +50,10 @@ ppIfaces mods $$ vcat (map (do_export mod) (eltsFM (iface_decls iface))) $$ text "" $$ text "" - + do_export mod decl | (nm:_) <- declBinders decl = text "" + $$ text "" <> do_decl decl <> text "" $$ text "" @@ -63,11 +63,11 @@ ppIfaces mods $$ text "" do_export _ _ = empty - do_decl (HsTypeSig _ [nm] ty _) + do_decl (HsTypeSig _ [nm] ty _) = ppHsName nm <> text " :: " <> ppHsType ty do_decl (HsTypeDecl _ nm args ty _) = hsep ([text "type", ppHsName nm ] - ++ map ppHsName args + ++ map ppHsName args ++ [equals, ppHsType ty]) do_decl (HsNewTypeDecl loc ctx nm args con drv _) = hsep ([text "data", ppHsName nm] -- data, not newtype @@ -87,7 +87,7 @@ ppHsConstr :: HsConDecl -> Doc ppHsConstr (HsRecDecl pos name tvs ctxt fieldList maybe_doc) = ppHsName name <> (braces . hsep . punctuate comma . map ppField $ fieldList) -ppHsConstr (HsConDecl pos name tvs ctxt typeList maybe_doc) = +ppHsConstr (HsConDecl pos name tvs ctxt typeList maybe_doc) = hsep (ppHsName name : map ppHsBangType typeList) ppField (HsFieldDecl ns ty doc) @@ -100,7 +100,7 @@ ppHsBangType (HsUnBangedTy ty) = ppHsType ty ppHsContext :: HsContext -> Doc ppHsContext [] = empty -ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+> +ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+> hsep (map ppHsAType b)) context) ppHsType :: HsType -> Doc @@ -109,7 +109,7 @@ ppHsType (HsForAllType Nothing context htype) = ppHsType (HsForAllType (Just tvs) [] htype) = hsep (text "forall" : map ppHsName tvs ++ text "." : [ppHsType htype]) ppHsType (HsForAllType (Just tvs) context htype) = - hsep (text "forall" : map ppHsName tvs ++ text "." : + hsep (text "forall" : map ppHsName tvs ++ text "." : ppHsContext context : text "=>" : [ppHsType htype]) ppHsType (HsTyFun a b) = fsep [ppHsBType a, text "->", ppHsType b] ppHsType (HsTyIP n t) = fsep [(char '?' <> ppHsName n), text "::", ppHsType t] @@ -135,7 +135,7 @@ ppHsQName (UnQual str) = ppHsName str ppHsQName n@(Qual (Module mod) str) | n == unit_con_name = ppHsName str | isSpecial str = ppHsName str - | otherwise + | otherwise = text "" diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs index 5166549a..26bcbf6d 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs @@ -215,7 +215,7 @@ collapseSection id_ state classes = [ identifier sid, theclass cs ] collapseToggle :: String -> [HtmlAttr] collapseToggle id_ = [ strAttr "onclick" js ] where js = "toggleSection('" ++ id_ ++ "')"; - + -- | Attributes for an area that toggles a collapsed area, -- and displays a control. collapseControl :: String -> Bool -> String -> [HtmlAttr] diff --git a/haddock-api/src/Haddock/Version.hs b/haddock-api/src/Haddock/Version.hs index 2ef3a257..4e9a581a 100644 --- a/haddock-api/src/Haddock/Version.hs +++ b/haddock-api/src/Haddock/Version.hs @@ -9,7 +9,7 @@ -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- -module Haddock.Version ( +module Haddock.Version ( projectName, projectVersion, projectUrl ) where diff --git a/haddock-library/LICENSE b/haddock-library/LICENSE index 1636bfcd..460decfc 100644 --- a/haddock-library/LICENSE +++ b/haddock-library/LICENSE @@ -5,11 +5,11 @@ modification, are permitted provided that the following conditions are met: - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR diff --git a/html-test/README.markdown b/html-test/README.markdown index 8d57acab..717bac5c 100644 --- a/html-test/README.markdown +++ b/html-test/README.markdown @@ -1,7 +1,7 @@ This is a testsuite for Haddock that uses the concept of "golden files". That is, it compares output files against a set of reference files. -To add a new test: +To add a new test: 1. Create a module in the `html-test/src` directory. diff --git a/html-test/ref/frames.html b/html-test/ref/frames.html index 1b4e38d4..e86edb66 100644 --- a/html-test/ref/frames.html +++ b/html-test/ref/frames.html @@ -1,4 +1,4 @@ - diff --git a/html-test/ref/haddock-util.js b/html-test/ref/haddock-util.js index 9a6fccf7..ba574356 100644 --- a/html-test/ref/haddock-util.js +++ b/html-test/ref/haddock-util.js @@ -131,11 +131,11 @@ function perform_search(full) var text = document.getElementById("searchbox").value.toLowerCase(); if (text == last_search && !full) return; last_search = text; - + var table = document.getElementById("indexlist"); var status = document.getElementById("searchmsg"); var children = table.firstChild.childNodes; - + // first figure out the first node with the prefix var first = bisect(-1); var last = (first == -1 ? -1 : bisect(1)); @@ -166,7 +166,7 @@ function perform_search(full) status.innerHTML = ""; } - + function setclass(first, last, status) { for (var i = first; i <= last; i++) @@ -174,8 +174,8 @@ function perform_search(full) children[i].className = status; } } - - + + // do a binary search, treating 0 as ... // return either -1 (no 0's found) or location of most far match function bisect(dir) @@ -201,9 +201,9 @@ function perform_search(full) if (checkitem(i) == 0) return i; } return -1; - } - - + } + + // from an index, decide what the result is // 0 = match, -1 is lower, 1 is higher function checkitem(i) @@ -212,8 +212,8 @@ function perform_search(full) if (s == text) return 0; else return (s > text ? -1 : 1); } - - + + // from an index, get its string // this abstracts over alternates function getitem(i) @@ -250,7 +250,7 @@ function addMenuItem(html) { function adjustForFrames() { var bodyCls; - + if (parent.location.href == window.location.href) { // not in frames, so add Frames button addMenuItem("Frames"); diff --git a/html-test/src/Bugs.hs b/html-test/src/Bugs.hs index 8e1f0079..e60bbe8f 100644 --- a/html-test/src/Bugs.hs +++ b/html-test/src/Bugs.hs @@ -1,3 +1,3 @@ module Bugs where -data A a = A a (a -> Int) +data A a = A a (a -> Int) diff --git a/hypsrc-test/ref/src/Classes.html b/hypsrc-test/ref/src/Classes.html index a5a3d243..13c8389a 100644 --- a/hypsrc-test/ref/src/Classes.html +++ b/hypsrc-test/ref/src/Classes.html @@ -408,7 +408,7 @@ >] + > Foo' a where quux :: (a, a) -> a - quux (x, y) = norf [x, y] + quux (x, y) = norf [x, y] norf :: [a] -> a norf = quux . baz . sum . map bar -- cgit v1.2.3 From 06e0766810779180dbc52d15c0df5a2eaaf1881e Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Sat, 11 Jul 2015 14:23:05 +0100 Subject: Fix expansion icon for user-collapsible sections Closes #412 --- CHANGES | 2 ++ haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs | 5 +++-- html-test/ref/Bug335.html | 6 +++--- 3 files changed, 8 insertions(+), 5 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/CHANGES b/CHANGES index ff49b6f5..be829adf 100644 --- a/CHANGES +++ b/CHANGES @@ -23,6 +23,8 @@ Changes in version 2.16.1 * Generate hyperlinked source ourselves (#410, part of GSOC 2015) + * Fix expansion icon for user-collapsible sections (#412) + Changes in version 2.16.0 * Experimental collapsible header support (#335) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index c23f3f08..3fe74a82 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -161,8 +161,9 @@ hackMarkup fmt' h' = UntouchedDoc d -> (markup fmt $ _doc d, [_meta d]) CollapsingHeader (Header lvl titl) par n nm -> let id_ = makeAnchorId $ "ch:" ++ fromMaybe "noid:" nm ++ show n - col' = collapseControl id_ True "caption" - instTable = (thediv ! collapseSection id_ False [] <<) + expanded = False + col' = collapseControl id_ expanded "caption" + instTable = (thediv ! collapseSection id_ expanded [] <<) lvs = zip [1 .. ] [h1, h2, h3, h4, h5, h6] getHeader = fromMaybe caption (lookup lvl lvs) subCaption = getHeader ! col' << markup fmt titl diff --git a/html-test/ref/Bug335.html b/html-test/ref/Bug335.html index 6f3d3820..dbe97422 100644 --- a/html-test/ref/Bug335.html +++ b/html-test/ref/Bug335.html @@ -64,7 +64,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug335.html");}; >f :: ()

ExF:

g :: ()

ExG:

Produced by Haddock version 2.16.0
 version 2.16.1
Date: Mon, 15 Jun 2015 00:06:08 -0400 Subject: Link to the definitions to themselves Currently, the definitions already have an anchor tag that allows URLs with fragment identifiers to locate them, but it is rather inconvenient to obtain such a URL (so-called "permalink") as it would require finding the a link to the corresponding item in the Synopsis or elsewhere. This commit adds hyperlinks to the definitions themselves, allowing users to obtain links to them easily. To preserve the original aesthetics of the definitions, we alter the color of the link so as to be identical to what it was, except it now has a hover effect indicating that it is clickable. Additionally, the anchor now uses the 'id' attribute instead of the (obsolete) 'name' attribute. Closes #407 --- .../resources/html/Ocean.std-theme/ocean.css | 3 +++ haddock-api/src/Haddock/Backends/Xhtml/Names.hs | 21 +++++++++++++-------- 2 files changed, 16 insertions(+), 8 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/resources/html/Ocean.std-theme/ocean.css b/haddock-api/resources/html/Ocean.std-theme/ocean.css index 1110b407..1cc55cb6 100644 --- a/haddock-api/resources/html/Ocean.std-theme/ocean.css +++ b/haddock-api/resources/html/Ocean.std-theme/ocean.css @@ -41,6 +41,9 @@ a[href]:link { color: rgb(196,69,29); } a[href]:visited { color: rgb(171,105,84); } a[href]:hover { text-decoration:underline; } +a[href].def:link, a[href].def:visited { color: black; } +a[href].def:hover { color: rgb(78, 98, 114); } + /* @end */ /* @group Fonts & Sizes */ diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs index cf12da40..c69710d1 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs @@ -110,16 +110,21 @@ ppName notation name = wrapInfix notation (getOccName name) $ toHtml (getOccStri ppBinder :: Bool -> OccName -> Html --- The Bool indicates whether we are generating the summary, in which case --- the binder will be a link to the full definition. -ppBinder True n = linkedAnchor (nameAnchorId n) << ppBinder' Prefix n -ppBinder False n = namedAnchor (nameAnchorId n) ! [theclass "def"] - << ppBinder' Prefix n +ppBinder = ppBinderWith Prefix ppBinderInfix :: Bool -> OccName -> Html -ppBinderInfix True n = linkedAnchor (nameAnchorId n) << ppBinder' Infix n -ppBinderInfix False n = namedAnchor (nameAnchorId n) ! [theclass "def"] - << ppBinder' Infix n +ppBinderInfix = ppBinderWith Infix + +ppBinderWith :: Notation -> Bool -> OccName -> Html +-- 'isRef' indicates whether this is merely a reference from another part of +-- the documentation or is the actual definition; in the latter case, we also +-- set the 'id' and 'class' attributes. +ppBinderWith notation isRef n = + linkedAnchor name ! attributes << ppBinder' notation n + where + name = nameAnchorId n + attributes | isRef = [] + | otherwise = [identifier name, theclass "def"] ppBinder' :: Notation -> OccName -> Html ppBinder' notation n = wrapInfix notation n $ ppOccName n -- cgit v1.2.3 From e190efe089a0bd038c7de41c1c52ef580e52712c Mon Sep 17 00:00:00 2001 From: Phil Ruffwind Date: Sun, 14 Jun 2015 22:47:13 -0400 Subject: Fix typo in Haddock.Backends.Xhtml.Layout: divSynposis -> divSynopsis Closes #408 --- haddock-api/src/Haddock/Backends/Xhtml.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 90cb9fa4..e5e4db3f 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -546,7 +546,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual synopsis | no_doc_at_all = noHtml | otherwise - = divSynposis $ + = divSynopsis $ paragraph ! collapseControl "syn" False "caption" << "Synopsis" +++ shortDeclList ( mapMaybe (processExport True linksInfo unicode qual) exports diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index 914a7a7e..e79c2c3d 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -14,7 +14,7 @@ module Haddock.Backends.Xhtml.Layout ( miniBody, divPackageHeader, divContent, divModuleHeader, divFooter, - divTableOfContents, divDescription, divSynposis, divInterface, + divTableOfContents, divDescription, divSynopsis, divInterface, divIndex, divAlphabet, divModuleList, sectionName, @@ -76,7 +76,7 @@ nonEmptySectionName c divPackageHeader, divContent, divModuleHeader, divFooter, - divTableOfContents, divDescription, divSynposis, divInterface, + divTableOfContents, divDescription, divSynopsis, divInterface, divIndex, divAlphabet, divModuleList :: Html -> Html @@ -86,7 +86,7 @@ divModuleHeader = sectionDiv "module-header" divFooter = sectionDiv "footer" divTableOfContents = sectionDiv "table-of-contents" divDescription = sectionDiv "description" -divSynposis = sectionDiv "synopsis" +divSynopsis = sectionDiv "synopsis" divInterface = sectionDiv "interface" divIndex = sectionDiv "index" divAlphabet = sectionDiv "alphabet" -- cgit v1.2.3 From c274363d5d868c838c382a52428c667090514f86 Mon Sep 17 00:00:00 2001 From: Phil Ruffwind Date: Mon, 27 Jul 2015 05:58:58 -0400 Subject: Fix record field alignment when name is too long Change
to