diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
| -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"  | 
