diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 146c3cc889d8e54b9557b3c1c20b90873f7dbead..0e62a5e094b5a0a470fd452cffa19442ace5704a 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -43,6 +43,7 @@ import Control.Applicative
import Control.Exception (evaluate)
import Control.Monad
import Data.Traversable
+import GHC.Stack (HasCallStack)
import Avail hiding (avail)
import qualified Avail
@@ -63,16 +64,21 @@ import BasicTypes ( StringLiteral(..), SourceText(..) )
import qualified Outputable as O
import HsDecls ( getConArgs )
+mkExceptionContext :: TypecheckedModule -> String
+mkExceptionContext =
+ ("creating Haddock interface for " ++) . moduleNameString . ms_mod_name . pm_mod_summary . tm_parsed_module
-- | Use a 'TypecheckedModule' to produce an 'Interface'.
-- To do this, we need access to already processed modules in the topological
-- sort. That's what's in the 'IfaceMap'.
-createInterface :: TypecheckedModule
+createInterface :: HasCallStack
+ => TypecheckedModule
-> [Flag] -- Boolean flags
-> IfaceMap -- Locally processed modules
-> InstIfaceMap -- External, already installed interfaces
-> ErrMsgGhc Interface
-createInterface tm flags modMap instIfaceMap = do
+createInterface tm flags modMap instIfaceMap =
+ withExceptionContext (mkExceptionContext tm) $ do
let ms = pm_mod_summary . tm_parsed_module $ tm
mi = moduleInfo tm
@@ -200,7 +206,6 @@ createInterface tm flags modMap instIfaceMap = do
, ifaceTokenizedSrc = tokenizedSrc
}
-
-- | Given all of the @import M as N@ declarations in a package,
-- create a mapping from the module identity of M, to an alias N
-- (if there are multiple aliases, we pick the last one.) This
@@ -634,7 +639,8 @@ collectDocs = go Nothing []
-- We create the export items even if the module is hidden, since they
-- might be useful when creating the export items for other modules.
mkExportItems
- :: Bool -- is it a signature
+ :: HasCallStack
+ => Bool -- is it a signature
-> IfaceMap
-> Maybe Package -- this package
-> Module -- this module
@@ -693,7 +699,8 @@ mkExportItems
availExportItem is_sig modMap thisMod semMod warnings exportedNames
maps fixMap splices instIfaceMap dflags avail
-availExportItem :: Bool -- is it a signature
+availExportItem :: HasCallStack
+ => Bool -- is it a signature
-> IfaceMap
-> Module -- this module
-> Module -- semantic module
@@ -775,7 +782,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
_ -> return []
- availExportDecl :: AvailInfo -> LHsDecl GhcRn
+ availExportDecl :: HasCallStack => AvailInfo -> LHsDecl GhcRn
-> (DocForDecl Name, [(Name, DocForDecl Name)])
-> ErrMsgGhc [ ExportItem GhcRn ]
availExportDecl avail decl (doc, subs)
@@ -1039,7 +1046,7 @@ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNam
-- it might be an individual record selector or a class method. In these
-- cases we have to extract the required declaration (and somehow cobble
-- together a type signature for it...).
-extractDecl :: DeclMap -> Name -> LHsDecl GhcRn -> LHsDecl GhcRn
+extractDecl :: HasCallStack => DeclMap -> Name -> LHsDecl GhcRn -> LHsDecl GhcRn
extractDecl declMap name decl
| name `elem` getMainDeclBinder (unLoc decl) = decl
| otherwise =
@@ -1116,10 +1123,11 @@ extractDecl declMap name decl
_ -> error "internal: extractDecl"
-extractPatternSyn :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn
+extractPatternSyn :: HasCallStack => Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn
extractPatternSyn nm t tvs cons =
case filter matches cons of
- [] -> error "extractPatternSyn: constructor pattern not found"
+ [] -> O.pprPanic "extractPatternSyn" $
+ O.text "constructor pattern " O.<+> O.ppr nm O.<+> O.text "not found in type" O.<+> O.ppr t
con:_ -> extract <$> con
where
matches :: LConDecl GhcRn -> Bool
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 6da45a3b0f052fff9ce50c4443fbfc923ee69991..cd4060cbfa5c6cac73d89592a5a256e1b7d4b1a1 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -36,6 +36,7 @@ import qualified Data.Map as Map
import Documentation.Haddock.Types
import BasicTypes (Fixity(..))
+import Exception (ExceptionMonad(..), ghandle)
import GHC hiding (NoLink)
import DynFlags (Language)
import qualified GHC.LanguageExtensions as LangExt
@@ -620,17 +621,28 @@ tell w = Writer ((), w)
-- | Haddock's own exception type.
-data HaddockException = HaddockException String deriving Typeable
+data HaddockException
+ = HaddockException String
+ | WithContext [String] SomeException
+ deriving Typeable
instance Show HaddockException where
show (HaddockException str) = str
-
+ show (WithContext ctxts se) = unlines $ ["While " ++ ctxt ++ ":\n" | ctxt <- reverse ctxts] ++ [show se]
throwE :: String -> a
instance Exception HaddockException
throwE str = throw (HaddockException str)
+withExceptionContext :: ExceptionMonad m => String -> m a -> m a
+withExceptionContext ctxt =
+ ghandle (\ex ->
+ case ex of
+ HaddockException e -> throw $ WithContext [ctxt] (toException ex)
+ WithContext ctxts se -> throw $ WithContext (ctxt:ctxts) se
+ ) .
+ ghandle (throw . WithContext [ctxt])
-- In "Haddock.Interface.Create", we need to gather
-- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does,
@@ -665,6 +677,12 @@ instance Monad ErrMsgGhc where
instance MonadIO ErrMsgGhc where
liftIO m = WriterGhc (fmap (\x -> (x, [])) (liftIO m))
+instance ExceptionMonad ErrMsgGhc where
+ gcatch act hand = WriterGhc $
+ runWriterGhc act `gcatch` (runWriterGhc . hand)
+ gmask act = WriterGhc $ gmask $ \mask ->
+ runWriterGhc $ act (WriterGhc . mask . runWriterGhc)
+
-----------------------------------------------------------------------------
-- * Pass sensitive types
-----------------------------------------------------------------------------