Skip to content
This repository was archived by the owner on Aug 3, 2024. It is now read-only.

Commit 1f704e3

Browse files
pepeiborraalexbiehl
authored andcommitted
Improve error messages with context information (#1060)
1 parent daeb1aa commit 1f704e3

File tree

2 files changed

+37
-11
lines changed

2 files changed

+37
-11
lines changed

haddock-api/src/Haddock/Interface/Create.hs

Lines changed: 17 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -43,6 +43,7 @@ import Control.Applicative
4343
import Control.Exception (evaluate)
4444
import Control.Monad
4545
import Data.Traversable
46+
import GHC.Stack (HasCallStack)
4647

4748
import Avail hiding (avail)
4849
import qualified Avail
@@ -63,16 +64,21 @@ import BasicTypes ( StringLiteral(..), SourceText(..) )
6364
import qualified Outputable as O
6465
import HsDecls ( getConArgs )
6566

67+
mkExceptionContext :: TypecheckedModule -> String
68+
mkExceptionContext =
69+
("creating Haddock interface for " ++) . moduleNameString . ms_mod_name . pm_mod_summary . tm_parsed_module
6670

6771
-- | Use a 'TypecheckedModule' to produce an 'Interface'.
6872
-- To do this, we need access to already processed modules in the topological
6973
-- sort. That's what's in the 'IfaceMap'.
70-
createInterface :: TypecheckedModule
74+
createInterface :: HasCallStack
75+
=> TypecheckedModule
7176
-> [Flag] -- Boolean flags
7277
-> IfaceMap -- Locally processed modules
7378
-> InstIfaceMap -- External, already installed interfaces
7479
-> ErrMsgGhc Interface
75-
createInterface tm flags modMap instIfaceMap = do
80+
createInterface tm flags modMap instIfaceMap =
81+
withExceptionContext (mkExceptionContext tm) $ do
7682

7783
let ms = pm_mod_summary . tm_parsed_module $ tm
7884
mi = moduleInfo tm
@@ -200,7 +206,6 @@ createInterface tm flags modMap instIfaceMap = do
200206
, ifaceTokenizedSrc = tokenizedSrc
201207
}
202208

203-
204209
-- | Given all of the @import M as N@ declarations in a package,
205210
-- create a mapping from the module identity of M, to an alias N
206211
-- (if there are multiple aliases, we pick the last one.) This
@@ -634,7 +639,8 @@ collectDocs = go Nothing []
634639
-- We create the export items even if the module is hidden, since they
635640
-- might be useful when creating the export items for other modules.
636641
mkExportItems
637-
:: Bool -- is it a signature
642+
:: HasCallStack
643+
=> Bool -- is it a signature
638644
-> IfaceMap
639645
-> Maybe Package -- this package
640646
-> Module -- this module
@@ -693,7 +699,8 @@ mkExportItems
693699
availExportItem is_sig modMap thisMod semMod warnings exportedNames
694700
maps fixMap splices instIfaceMap dflags avail
695701

696-
availExportItem :: Bool -- is it a signature
702+
availExportItem :: HasCallStack
703+
=> Bool -- is it a signature
697704
-> IfaceMap
698705
-> Module -- this module
699706
-> Module -- semantic module
@@ -775,7 +782,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
775782

776783
_ -> return []
777784

778-
availExportDecl :: AvailInfo -> LHsDecl GhcRn
785+
availExportDecl :: HasCallStack => AvailInfo -> LHsDecl GhcRn
779786
-> (DocForDecl Name, [(Name, DocForDecl Name)])
780787
-> ErrMsgGhc [ ExportItem GhcRn ]
781788
availExportDecl avail decl (doc, subs)
@@ -1039,7 +1046,7 @@ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNam
10391046
-- it might be an individual record selector or a class method. In these
10401047
-- cases we have to extract the required declaration (and somehow cobble
10411048
-- together a type signature for it...).
1042-
extractDecl :: DeclMap -> Name -> LHsDecl GhcRn -> LHsDecl GhcRn
1049+
extractDecl :: HasCallStack => DeclMap -> Name -> LHsDecl GhcRn -> LHsDecl GhcRn
10431050
extractDecl declMap name decl
10441051
| name `elem` getMainDeclBinder (unLoc decl) = decl
10451052
| otherwise =
@@ -1116,10 +1123,11 @@ extractDecl declMap name decl
11161123
_ -> error "internal: extractDecl"
11171124

11181125

1119-
extractPatternSyn :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn
1126+
extractPatternSyn :: HasCallStack => Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn
11201127
extractPatternSyn nm t tvs cons =
11211128
case filter matches cons of
1122-
[] -> error "extractPatternSyn: constructor pattern not found"
1129+
[] -> O.pprPanic "extractPatternSyn" $
1130+
O.text "constructor pattern " O.<+> O.ppr nm O.<+> O.text "not found in type" O.<+> O.ppr t
11231131
con:_ -> extract <$> con
11241132
where
11251133
matches :: LConDecl GhcRn -> Bool

haddock-api/src/Haddock/Types.hs

Lines changed: 20 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -36,6 +36,7 @@ import qualified Data.Map as Map
3636
import Documentation.Haddock.Types
3737
import BasicTypes (Fixity(..))
3838

39+
import Exception (ExceptionMonad(..), ghandle)
3940
import GHC hiding (NoLink)
4041
import DynFlags (Language)
4142
import qualified GHC.LanguageExtensions as LangExt
@@ -620,17 +621,28 @@ tell w = Writer ((), w)
620621

621622

622623
-- | Haddock's own exception type.
623-
data HaddockException = HaddockException String deriving Typeable
624+
data HaddockException
625+
= HaddockException String
626+
| WithContext [String] SomeException
627+
deriving Typeable
624628

625629

626630
instance Show HaddockException where
627631
show (HaddockException str) = str
628-
632+
show (WithContext ctxts se) = unlines $ ["While " ++ ctxt ++ ":\n" | ctxt <- reverse ctxts] ++ [show se]
629633

630634
throwE :: String -> a
631635
instance Exception HaddockException
632636
throwE str = throw (HaddockException str)
633637

638+
withExceptionContext :: ExceptionMonad m => String -> m a -> m a
639+
withExceptionContext ctxt =
640+
ghandle (\ex ->
641+
case ex of
642+
HaddockException e -> throw $ WithContext [ctxt] (toException ex)
643+
WithContext ctxts se -> throw $ WithContext (ctxt:ctxts) se
644+
) .
645+
ghandle (throw . WithContext [ctxt])
634646

635647
-- In "Haddock.Interface.Create", we need to gather
636648
-- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does,
@@ -665,6 +677,12 @@ instance Monad ErrMsgGhc where
665677
instance MonadIO ErrMsgGhc where
666678
liftIO m = WriterGhc (fmap (\x -> (x, [])) (liftIO m))
667679

680+
instance ExceptionMonad ErrMsgGhc where
681+
gcatch act hand = WriterGhc $
682+
runWriterGhc act `gcatch` (runWriterGhc . hand)
683+
gmask act = WriterGhc $ gmask $ \mask ->
684+
runWriterGhc $ act (WriterGhc . mask . runWriterGhc)
685+
668686
-----------------------------------------------------------------------------
669687
-- * Pass sensitive types
670688
-----------------------------------------------------------------------------

0 commit comments

Comments
 (0)