From 1e335fc0828f6f1927c6d2a125919c59f04c0bc0 Mon Sep 17 00:00:00 2001
From: Alec Theriault <alec.theriault@gmail.com>
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')

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