From 5459ca8a76825da59ff4c1c11d74812d1931da50 Mon Sep 17 00:00:00 2001
From: Alec Theriault <alec.theriault@gmail.com>
Date: Mon, 7 Oct 2019 15:11:22 -0400
Subject: Prefer un-hyperlinked sources to no sources

It is possible to fail to extract an HIE ast. This is however not a
reason to produce _no_ output - we should still make a colorized HTML
page.
---
 haddock-api/src/Haddock/Backends/Hyperlinker.hs    | 38 ++++++++++++++--------
 .../src/Haddock/Backends/Hyperlinker/Utils.hs      |  2 +-
 2 files changed, 26 insertions(+), 14 deletions(-)

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index 3acd91be..2e665204 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -18,12 +18,13 @@ import Data.Maybe
 import System.Directory
 import System.FilePath
 
-import HieTypes       ( HieFile(..), HieASTs(..) )
+import HieTypes       ( HieFile(..), HieASTs(..), HieAST(..), NodeInfo(..) )
 import HieBin         ( readHieFile, hie_file_result)
 import Data.Map as M
 import FastString     ( mkFastString )
 import Module         ( Module, moduleName )
 import NameCache      ( initNameCache )
+import SrcLoc         ( mkRealSrcLoc, realSrcLocSpan )
 import UniqSupply     ( mkSplitUniqSupply )
 
 
@@ -65,27 +66,38 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = case ifaceHieFile
                  <$> (readHieFile (initNameCache u []) hfp)
 
         -- Get the AST and tokens corresponding to the source file we want
-        let mast | M.size asts == 1 = snd <$> M.lookupMin asts
-                 | otherwise        = M.lookup (mkFastString file) asts
+        let fileFs = mkFastString file
+            mast | M.size asts == 1 = snd <$> M.lookupMin asts
+                 | otherwise        = M.lookup fileFs asts
+            ast = fromMaybe (emptyHieAst fileFs) mast
+            fullAst = recoverFullIfaceTypes df types ast
             tokens = parse df file rawSrc
 
+        -- Warn if we didn't find an AST, but there were still ASTs
+        if M.null asts
+          then pure ()
+          else out verbosity verbose $ unwords [ "couldn't find ast for"
+                                               , file, show (M.keys asts) ]
+
         -- Produce and write out the hyperlinked sources
-        case mast of
-          Just ast ->
-              let fullAst = recoverFullIfaceTypes df types ast
-              in writeUtf8File path . renderToString pretty . render' fullAst $ tokens
-          Nothing
-            | M.size asts == 0 -> return ()
-            | otherwise -> do
-                out verbosity verbose $ unwords [ "couldn't find ast for"
-                                                , file, show (M.keys asts) ]
-                return ()
+        writeUtf8File path . renderToString pretty . render' fullAst $ tokens
     Nothing -> return ()
   where
     df = ifaceDynFlags iface
     render' = render (Just srcCssFile) (Just highlightScript) srcs
     path = srcdir </> hypSrcModuleFile (ifaceMod iface)
 
+    emptyNodeInfo = NodeInfo
+      { nodeAnnotations = mempty
+      , nodeType = []
+      , nodeIdentifiers = mempty
+      }
+    emptyHieAst fileFs = Node
+      { nodeInfo = emptyNodeInfo
+      , nodeSpan = realSrcLocSpan (mkRealSrcLoc fileFs 1 0)
+      , nodeChildren = []
+      }
+
 -- | Name of CSS file in output directory.
 srcCssFile :: FilePath
 srcCssFile = "style.css"
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
index 4e8b88d2..2c48e00b 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
@@ -102,7 +102,7 @@ type PrintedType = String
 -- >       hieAst
 --
 -- However, this is very inefficient (both in time and space) because the
--- mutliple calls to 'recoverFullType' don't share intermediate results. This
+-- multiple calls to 'recoverFullType' don't share intermediate results. This
 -- function fixes that.
 recoverFullIfaceTypes
   :: DynFlags
-- 
cgit v1.2.3