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 +++++++++++++++++----------
 haddock-api/src/Haddock/Interface/Create.hs |  2 +-
 haddock-api/src/Haddock/Options.hs          |  5 +++--
 3 files changed, 21 insertions(+), 13 deletions(-)

(limited to 'haddock-api')

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"
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index c4df2090..a4408434 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -85,7 +85,7 @@ createInterface tm flags modMap instIfaceMap = do
       !instances     = modInfoInstances mi
       !fam_instances = md_fam_insts md
       !exportedNames = modInfoExportsWithSelectors mi
-      (pkgNameFS, _) = modulePackageInfo dflags flags mdl
+      (pkgNameFS, _) = modulePackageInfo dflags flags (Just mdl)
       pkgName        = fmap (unpackFS . (\(PackageName n) -> n)) pkgNameFS
 
       (TcGblEnv { tcg_rdr_env = gre
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index b5e987d8..bdc98406 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -371,9 +371,10 @@ modulePackageInfo :: DynFlags
                   -> [Flag] -- ^ Haddock flags are checked as they may contain
                             -- the package name or version provided by the user
                             -- which we prioritise
-                  -> Module
+                  -> Maybe Module
                   -> (Maybe PackageName, Maybe Data.Version.Version)
-modulePackageInfo dflags flags modu =
+modulePackageInfo _dflags _flags Nothing = (Nothing, Nothing)
+modulePackageInfo dflags flags (Just modu) =
   ( optPackageName flags    <|> fmap packageName pkgDb
   , optPackageVersion flags <|> fmap packageVersion pkgDb
   )
-- 
cgit v1.2.3