diff options
author | Alec Theriault <alec.theriault@gmail.com> | 2018-10-26 14:22:23 -0700 |
---|---|---|
committer | Alec Theriault <alec.theriault@gmail.com> | 2018-10-26 14:22:23 -0700 |
commit | 2b94a90a23f03a749e3703af330d9585a5de0bae (patch) | |
tree | a9c2debf02b417f4106e0b55cf0bfb918b3c8dbc /haddock-api/src | |
parent | cd520e9907b9a56cae5a2e51413eef1522a37bbb (diff) |
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.
Diffstat (limited to 'haddock-api/src')
-rw-r--r-- | haddock-api/src/Haddock.hs | 27 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 2 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Options.hs | 5 |
3 files changed, 21 insertions, 13 deletions
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 ) |