diff options
| -rw-r--r-- | src/Haddock.hs | 60 |
1 files changed, 28 insertions, 32 deletions
diff --git a/src/Haddock.hs b/src/Haddock.hs index 67c45362..6d975c9b 100644 --- a/src/Haddock.hs +++ b/src/Haddock.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wwarn #-} {-# LANGUAGE CPP, ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock @@ -296,9 +297,8 @@ readInterfaceFiles name_cache_accessor pairs = do catMaybes `liftM` mapM tryReadIface pairs where -- try to read an interface, warn if we can't - tryReadIface (paths, file) = do - eIface <- readInterfaceFile name_cache_accessor file - case eIface of + tryReadIface (paths, file) = + readInterfaceFile name_cache_accessor file >>= \case Left err -> liftIO $ do putStrLn ("Warning: Cannot read " ++ file ++ ":") putStrLn (" " ++ err) @@ -315,22 +315,21 @@ readInterfaceFiles name_cache_accessor pairs = do -- | Start a GHC session with the -haddock flag set. Also turn off -- compilation and linking. Then run the given 'Ghc' action. withGhc :: String -> [String] -> (DynFlags -> Ghc a) -> IO a -withGhc libDir flags ghcActs = do - runGhc (Just libDir) $ do - dynflags <- getSessionDynFlags - let dynflags' = gopt_set dynflags Opt_Haddock - let dynflags'' = dynflags' { - hscTarget = HscNothing, - ghcMode = CompManager, - ghcLink = NoLink - } - dynflags''' <- parseGhcFlags dynflags'' - defaultCleanupHandler dynflags''' $ do - -- ignore the following return-value, which is a list of packages - -- that may need to be re-linked: Haddock doesn't do any - -- dynamic or static linking at all! - _ <- setSessionDynFlags dynflags''' - ghcActs dynflags''' +withGhc libDir flags ghcActs = runGhc (Just libDir) $ do + dynflags <- getSessionDynFlags + let dynflags' = gopt_set dynflags Opt_Haddock + let dynflags'' = dynflags' { + hscTarget = HscNothing, + ghcMode = CompManager, + ghcLink = NoLink + } + dynflags''' <- parseGhcFlags dynflags'' + defaultCleanupHandler dynflags''' $ do + -- ignore the following return-value, which is a list of packages + -- that may need to be re-linked: Haddock doesn't do any + -- dynamic or static linking at all! + _ <- setSessionDynFlags dynflags''' + ghcActs dynflags''' where parseGhcFlags :: MonadIO m => DynFlags -> m DynFlags parseGhcFlags dynflags = do @@ -447,25 +446,22 @@ getPrologue :: DynFlags -> [Flag] -> IO (Maybe (Doc RdrName)) getPrologue dflags flags = case [filename | Flag_Prologue filename <- flags ] of [] -> return Nothing - [filename] -> do - withFile filename ReadMode $ \h -> do - hSetEncoding h utf8 - str <- hGetContents h - case parseParasMaybe dflags str of - Nothing -> - throwE $ "failed to parse haddock prologue from file: " ++ filename - Just doc -> return (Just doc) + [filename] -> withFile filename ReadMode $ \h -> do + hSetEncoding h utf8 + str <- hGetContents h + case parseParasMaybe dflags str of + Nothing -> + throwE $ "failed to parse haddock prologue from file: " ++ filename + Just doc -> return (Just doc) _otherwise -> throwE "multiple -p/--prologue options" #ifdef IN_GHC_TREE getInTreeDir :: IO String -getInTreeDir = do - m <- getExecDir - case m of - Nothing -> error "No GhcDir found" - Just d -> return (d </> ".." </> "lib") +getInTreeDir = getExecDir >>= \case + Nothing -> error "No GhcDir found" + Just d -> return (d </> ".." </> "lib") getExecDir :: IO (Maybe String) |