From 4f75be94f45a0e92553eccefe56230c554333ce7 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sun, 10 Dec 2017 12:22:21 -0800 Subject: Use the GHC lexer for the Hyperlinker backend (#714) * Start changing to use GHC lexer * better cpp * Change SrcSpan to RealSrcSpan * Remove error * Try to stop too many open files * wip * wip * Revert "wip" This reverts commit b605510a195f26315e3d8ca90e6d95a6737553e1. Conflicts: haddock-api/haddock-api.cabal haddock-api/src/Haddock/Interface.hs * Remove pointless 'caching' * Use dlist rather than lists when finding vars * Use a map rather than list * Delete bogus comment * Rebase followup Things now run using the GHC lexer. There are still - stray debug statements - unnecessary changes w.r.t. master * Cleaned up differences w.r.t. current Haddock HEAD Things are looking good. quasiquotes in particular look beautiful: the TH ones (with Haskell source inside) colour/link their contents too! Haven't yet begun to check for possible performance problems. * Support CPP and top-level pragmas The support for these is hackier - but no more hacky than the existing support. * Tests pass, CPP is better recognized The tests were in some cases altered: I consider the new output to be more correct than the old one.... * Fix shrinking of source without tabs in test * Replace 'Position'/'Span' with GHC counterparts Replaces 'Position' -> 'GHC.RealSrcLoc' and 'Span' -> 'GHC.RealSrcSpan'. * Nits * Forgot entry in .cabal * Update changelog --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 19 +++++++------------ 1 file changed, 7 insertions(+), 12 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 57ff72ff..361bc15d 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -12,6 +12,7 @@ import qualified Haddock.Syb as Syb import Haddock.Backends.Hyperlinker.Types import qualified GHC +import qualified SrcLoc import Control.Applicative import Control.Monad (guard) @@ -51,10 +52,10 @@ type DetailsMap = Map.Map Position (Span, TokenDetails) mkDetailsMap :: [(GHC.SrcSpan, TokenDetails)] -> DetailsMap mkDetailsMap xs = - Map.fromListWith select_details [ (start, (token_span, token_details)) + Map.fromListWith select_details [ (start, (span, token_details)) | (ghc_span, token_details) <- xs - , Just !token_span <- [ghcSrcSpanToSpan ghc_span] - , let start = spStart token_span + , GHC.RealSrcSpan span <- [ghc_span] + , let start = SrcLoc.realSrcSpanStart span ] where -- favour token details which appear earlier in the list @@ -62,17 +63,11 @@ mkDetailsMap xs = lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails lookupBySpan span details = do - (_, (tok_span, tok_details)) <- Map.lookupLE (spStart span) details - guard (tok_span `containsSpan` span ) + let pos = SrcLoc.realSrcSpanStart span + (_, (tok_span, tok_details)) <- Map.lookupLE pos details + guard (tok_span `SrcLoc.containsSpan` span) return tok_details -ghcSrcSpanToSpan :: GHC.SrcSpan -> Maybe Span -ghcSrcSpanToSpan (GHC.RealSrcSpan span) = - Just (Span { spStart = Position (GHC.srcSpanStartLine span) (GHC.srcSpanStartCol span) - , spEnd = Position (GHC.srcSpanEndLine span) (GHC.srcSpanEndCol span) - }) -ghcSrcSpanToSpan _ = Nothing - enrichToken :: Token -> DetailsMap -> Maybe TokenDetails enrichToken (Token typ _ spn) dm | typ `elem` [TkIdentifier, TkOperator] = lookupBySpan spn dm -- cgit v1.2.3 From 1e335fc0828f6f1927c6d2a125919c59f04c0bc0 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Mon, 5 Feb 2018 10:15:39 -0800 Subject: Hyperlink pattern synonyms and 'module' imports (#744) Links to pattern synonyms are now generated, as well as links from modules in import lists. Fixes #731. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 361bc15d..841dff76 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -111,6 +111,8 @@ binds = everythingInRenamedSource fun term = case cast term of (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn)) -> pure (sspan, RtkBind name) + (Just (GHC.PatSynBind (GHC.PSB (GHC.L sspan name) _ _ _ _))) -> + pure (sspan, RtkBind name) _ -> empty pat term = case cast term of (Just ((GHC.L sspan (GHC.VarPat name)) :: GHC.LPat GHC.GhcRn)) -> @@ -147,6 +149,8 @@ decls (group, _, _, _) = concatMap ($ group) fun term = case cast term of (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn)) | GHC.isExternalName name -> pure (sspan, RtkDecl name) + (Just (GHC.PatSynBind (GHC.PSB (GHC.L sspan name) _ _ _ _))) + | GHC.isExternalName name -> pure (sspan, RtkDecl name) _ -> empty con term = case cast term of (Just (cdcl :: GHC.ConDecl GHC.GhcRn)) -> @@ -165,6 +169,7 @@ decls (group, _, _, _) = concatMap ($ group) -> map (decl . fmap GHC.selectorFieldOcc) $ GHC.cd_fld_names field Nothing -> empty sig (GHC.L _ (GHC.TypeSig names _)) = map decl names + sig (GHC.L _ (GHC.PatSynSig names _)) = map decl names sig _ = [] decl (GHC.L sspan name) = (sspan, RtkDecl name) tyref (GHC.L sspan name) = (sspan, RtkType name) @@ -183,10 +188,11 @@ imports src@(_, imps, _, _) = (Just (GHC.IEThingAll t)) -> pure $ typ $ GHC.ieLWrappedName t (Just (GHC.IEThingWith t _ vs _fls)) -> [typ $ GHC.ieLWrappedName t] ++ map (var . GHC.ieLWrappedName) vs + (Just (GHC.IEModuleContents m)) -> pure $ modu m _ -> empty typ (GHC.L sspan name) = (sspan, RtkType name) var (GHC.L sspan name) = (sspan, RtkVar name) - imp idecl | not . GHC.ideclImplicit $ idecl = - let (GHC.L sspan name) = GHC.ideclName idecl - in Just (sspan, RtkModule name) - imp _ = Nothing + modu (GHC.L sspan name) = (sspan, RtkModule name) + imp idecl + | not . GHC.ideclImplicit $ idecl = Just (modu (GHC.ideclName idecl)) + | otherwise = Nothing -- cgit v1.2.3 From e870c70cdbe739693c1eacddc42e64106c8ecfdf Mon Sep 17 00:00:00 2001 From: alexbiehl Date: Tue, 6 Feb 2018 13:56:17 +0100 Subject: Hyperlinker: Also link pattern synonym arguments --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 841dff76..02c4ca0b 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -111,8 +111,11 @@ binds = everythingInRenamedSource fun term = case cast term of (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn)) -> pure (sspan, RtkBind name) - (Just (GHC.PatSynBind (GHC.PSB (GHC.L sspan name) _ _ _ _))) -> - pure (sspan, RtkBind name) + (Just (GHC.PatSynBind (GHC.PSB (GHC.L sspan name) _ args _ _))) -> + pure (sspan, RtkBind name) ++ everythingInRenamedSource patsyn_binds args + _ -> empty + patsyn_binds term = case cast term of + (Just (GHC.L sspan (name :: GHC.Name))) -> pure (sspan, RtkVar name) _ -> empty pat term = case cast term of (Just ((GHC.L sspan (GHC.VarPat name)) :: GHC.LPat GHC.GhcRn)) -> -- cgit v1.2.3 From 3077a12b57e1b93a738082aa73fab72e9c3e3f83 Mon Sep 17 00:00:00 2001 From: alexbiehl Date: Mon, 5 Mar 2018 18:10:07 +0100 Subject: Hyperlinker: Links for TyOps, class methods and associated types --- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 15 +++++++- hypsrc-test/ref/src/Classes.html | 40 ++++++++++++++++------ 2 files changed, 44 insertions(+), 11 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 02c4ca0b..3c96db98 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -93,9 +93,12 @@ variables = types :: GHC.RenamedSource -> LTokenDetails types = everythingInRenamedSource ty where + ty :: forall a. Data a => a -> [(GHC.SrcSpan, TokenDetails)] ty term = case cast term of (Just ((GHC.L sspan (GHC.HsTyVar _ name)) :: GHC.LHsType GHC.GhcRn)) -> pure (sspan, RtkType (GHC.unLoc name)) + (Just ((GHC.L sspan (GHC.HsOpTy l name r)) :: GHC.LHsType GHC.GhcRn)) -> + (sspan, RtkType (GHC.unLoc name)):(ty l ++ ty r) _ -> empty -- | Obtain details map for identifier bindings. @@ -141,6 +144,7 @@ decls :: GHC.RenamedSource -> LTokenDetails decls (group, _, _, _) = concatMap ($ group) [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds , everythingInRenamedSource fun . GHC.hs_valds + , everythingInRenamedSource fix . GHC.hs_fixds , everythingInRenamedSource (con `Syb.combine` ins) ] where @@ -148,7 +152,10 @@ decls (group, _, _, _) = concatMap ($ group) GHC.DataDecl { tcdLName = 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 + GHC.ClassDecl{..} -> + [decl tcdLName] + ++ concatMap sig tcdSigs + ++ concatMap tyfam tcdATs fun term = case cast term of (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn)) | GHC.isExternalName name -> pure (sspan, RtkDecl name) @@ -171,8 +178,14 @@ decls (group, _, _, _) = concatMap ($ group) Just (field :: GHC.ConDeclField GHC.GhcRn) -> map (decl . fmap GHC.selectorFieldOcc) $ GHC.cd_fld_names field Nothing -> empty + fix term = case cast term of + Just ((GHC.FixitySig names _) :: GHC.FixitySig GHC.GhcRn) + -> map decl names + Nothing -> empty + tyfam (GHC.L _ (GHC.FamilyDecl{..})) = [decl fdLName] sig (GHC.L _ (GHC.TypeSig names _)) = map decl names sig (GHC.L _ (GHC.PatSynSig names _)) = map decl names + sig (GHC.L _ (GHC.ClassOpSig _ names _)) = map decl names sig _ = [] decl (GHC.L sspan name) = (sspan, RtkDecl name) tyref (GHC.L sspan name) = (sspan, RtkType name) diff --git a/hypsrc-test/ref/src/Classes.html b/hypsrc-test/ref/src/Classes.html index abff8877..d2604e82 100644 --- a/hypsrc-test/ref/src/Classes.html +++ b/hypsrc-test/ref/src/Classes.html @@ -60,8 +60,12 @@ > barbar bazbaz quuxquux norfnorf plughplugh Date: Fri, 20 Apr 2018 07:31:44 +0200 Subject: Don't treat fixity signatures like declarations --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 3c96db98..c4a9091f 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -180,7 +180,7 @@ decls (group, _, _, _) = concatMap ($ group) Nothing -> empty fix term = case cast term of Just ((GHC.FixitySig names _) :: GHC.FixitySig GHC.GhcRn) - -> map decl names + -> map (\(GHC.L sspan x) -> (sspan, RtkVar x)) names Nothing -> empty tyfam (GHC.L _ (GHC.FamilyDecl{..})) = [decl fdLName] sig (GHC.L _ (GHC.TypeSig names _)) = map decl names -- cgit v1.2.3 From 083faee1cec2df01d7ab8a4ef2dc0a28c0c120cf Mon Sep 17 00:00:00 2001 From: Simon Jakobi Date: Wed, 13 Jun 2018 23:28:47 +0200 Subject: Complete FixitySig and FamilyDecl pattern matches --- haddock-api/src/Haddock/Backends/Hoogle.hs | 1 + haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 3 +++ 2 files changed, 4 insertions(+) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 6e8148f7..257a8d6d 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -201,6 +201,7 @@ ppFam dflags decl@(FamilyDecl { fdInfo = info }) -- for Hoogle, so pretend it doesn't have any. ClosedTypeFamily{} -> decl { fdInfo = OpenTypeFamily } _ -> decl +ppFam _ XFamilyDecl {} = panic "ppFam" ppInstance :: DynFlags -> ClsInst -> [String] ppInstance dflags x = diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 220a59fe..0ecf7109 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -183,8 +183,11 @@ decls (group, _, _, _) = concatMap ($ group) fix term = case cast term of Just ((GHC.FixitySig _ names _) :: GHC.FixitySig GHC.GhcRn) -> map (\(GHC.L sspan x) -> (sspan, RtkVar x)) names + Just ((GHC.XFixitySig {}) :: GHC.FixitySig GHC.GhcRn) + -> GHC.panic "haddock:decls" Nothing -> empty tyfam (GHC.L _ (GHC.FamilyDecl{..})) = [decl fdLName] + tyfam (GHC.L _ (GHC.XFamilyDecl {})) = GHC.panic "haddock:dels" sig (GHC.L _ (GHC.TypeSig _ names _)) = map decl names sig (GHC.L _ (GHC.PatSynSig _ names _)) = map decl names sig (GHC.L _ (GHC.ClassOpSig _ _ names _)) = map decl names -- cgit v1.2.3