From 2b94a90a23f03a749e3703af330d9585a5de0bae Mon Sep 17 00:00:00 2001
From: Alec Theriault <alec.theriault@gmail.com>
Date: Fri, 26 Oct 2018 14:22:23 -0700
Subject: Avoid some partiality

AFAICT this wasn't causing any crashes, but that's mostly because
we happen not to be forcing `pkgStr` when it would diverge. We come
dangerously close to doing that in `ppHtmlIndex`.

Fixes #569.
---
 haddock-api/src/Haddock.hs | 27 +++++++++++++++++----------
 1 file changed, 17 insertions(+), 10 deletions(-)

(limited to 'haddock-api/src/Haddock.hs')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index dbfba0f4..7a2df3a2 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -268,9 +268,9 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do
     allIfaces        = map toInstalledIface ifaces ++ installedIfaces
     allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ]
 
-    pkgMod           = ifaceMod (head ifaces)
-    pkgKey           = moduleUnitId pkgMod
-    pkgStr           = Just (unitIdString pkgKey)
+    pkgMod           = fmap ifaceMod (listToMaybe ifaces)
+    pkgKey           = fmap moduleUnitId pkgMod
+    pkgStr           = fmap unitIdString pkgKey
     pkgNameVer       = modulePackageInfo dflags flags pkgMod
     pkgName          = fmap (unpackFS . (\(PackageName n) -> n)) (fst pkgNameVer)
     sincePkg         = case sinceQual of
@@ -289,16 +289,22 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do
 
     pkgSrcMap = Map.mapKeys moduleUnitId extSrcMap
     pkgSrcMap'
-      | Flag_HyperlinkedSource `elem` flags =
-          Map.insert pkgKey hypSrcModuleNameUrlFormat pkgSrcMap
-      | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl pkgSrcMap
+      | Flag_HyperlinkedSource `elem` flags
+      , Just k <- pkgKey
+      = Map.insert k hypSrcModuleNameUrlFormat pkgSrcMap
+      | Just srcNameUrl <- srcEntity
+      , Just k <- pkgKey
+      = Map.insert k srcNameUrl pkgSrcMap
       | otherwise = pkgSrcMap
 
     -- TODO: Get these from the interface files as with srcMap
     pkgSrcLMap'
-      | Flag_HyperlinkedSource `elem` flags =
-          Map.singleton pkgKey hypSrcModuleLineUrlFormat
-      | Just path <- srcLEntity = Map.singleton pkgKey path
+      | Flag_HyperlinkedSource `elem` flags
+      , Just k <- pkgKey
+      = Map.singleton k hypSrcModuleLineUrlFormat
+      | Just path <- srcLEntity
+      , Just k <- pkgKey
+      = Map.singleton k path
       | otherwise = Map.empty
 
     sourceUrls' = (srcBase, srcModule', pkgSrcMap', pkgSrcLMap')
@@ -375,7 +381,8 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do
                visibleIfaces odir
       _ -> putStrLn . unlines $
           [ "haddock: Unable to find a package providing module "
-            ++ moduleNameString (moduleName pkgMod) ++ ", skipping Hoogle."
+            ++ maybe "<no-mod>" (moduleNameString . moduleName) pkgMod
+            ++ ", skipping Hoogle."
           , ""
           , "         Perhaps try specifying the desired package explicitly"
             ++ " using the --package-name"
-- 
cgit v1.2.3