aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorMateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>2014-03-13 21:28:09 +0000
committerMateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>2014-03-13 21:28:09 +0000
commitf5532d27aa6849305dfa7042ccbf900a56555a2f (patch)
treecea3b20b57872100b07c1f7eb2967d9cafd6de60 /src
parent5bcc09947718bec704ff9561dc193ba3c50a1ccf (diff)
Style only
Diffstat (limited to 'src')
-rw-r--r--src/Haddock.hs60
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)