diff options
Diffstat (limited to 'haddock-api/src/Haddock')
-rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 19 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 28 |
2 files changed, 29 insertions, 18 deletions
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" |