Turn some uses of error into recoverable warnings

This should at the very least not abort when something weird happens. It
does feel like we should have a type that carries these errors until the
end however as the user might not see them unless they are printed at
the end.

2 files changed, 44 insertions, 28 deletions

diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index a0bac8fc..1351d38b 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -18,22 +18,26 @@ import Haddock.Types
 import Haddock.Convert
 import Haddock.GhcUtils
 
-import Control.Arrow
+import Control.Arrow hiding ((<+>))
 import Data.List
 import Data.Ord (comparing)
 import Data.Function (on)
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 
+import Bag (listToBag)
 import Class
+import DynFlags
+import ErrUtils
 import FamInstEnv
 import FastString
 import GHC
-import GhcMonad (withSession)
+import GhcMonad (withSession, logWarnings)
 import Id
 import InstEnv
 import MonadUtils (liftIO)
 import Name
+import Outputable (text, sep, (<+>))
 import PrelNames
 import TcRnDriver (tcRnGetInfo)
 import TcType (tcSplitSigmaTy)
@@ -60,32 +64,37 @@ attachInstances expInfo ifaces instIfaceMap = mapM attach ifaces
       return $ iface { ifaceExportItems = newItems }
 
 
-attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> ExportItem Name -> Ghc (ExportItem Name)
+attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap
+                   -> ExportItem Name
+                   -> Ghc (ExportItem Name)
 attachToExportItem expInfo iface ifaceMap instIfaceMap export =
   case attachFixities export of
     e@ExportDecl { expItemDecl = L _ (TyClD d) } -> do
       mb_info <- getAllInfo (tcdName d)
-      let export' =
-            e {
-              expItemInstances =
-                case mb_info of
-                  Just (_, _, cls_instances, fam_instances) ->
-                    let fam_insts = [ (synifyFamInst i opaque, n)
-                                    | i <- sortBy (comparing instFam) fam_instances
-                                    , let n = instLookup instDocMap (getName i) iface ifaceMap instIfaceMap
-                                    , not $ isNameHidden expInfo (fi_fam i)
-                                    , not $ any (isTypeHidden expInfo) (fi_tys i)
-                                    , let opaque = isTypeHidden expInfo (fi_rhs i)
-                                    ]
-                        cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap)
-                                    | let is = [ (instanceHead' i, getName i) | i <- cls_instances ]
-                                    , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is
-                                    , not $ isInstanceHidden expInfo cls tys
-                                    ]
-                    in cls_insts ++ fam_insts
-                  Nothing -> []
-            }
-      return export'
+      insts <- case mb_info of
+        Just (_, _, cls_instances, fam_instances) ->
+          let fam_insts = [ (synifyFamInst i opaque, n)
+                          | i <- sortBy (comparing instFam) fam_instances
+                          , let n = instLookup instDocMap (getName i) iface ifaceMap instIfaceMap
+                          , not $ isNameHidden expInfo (fi_fam i)
+                          , not $ any (isTypeHidden expInfo) (fi_tys i)
+                          , let opaque = isTypeHidden expInfo (fi_rhs i)
+                          ]
+              cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap)
+                          | let is = [ (instanceHead' i, getName i) | i <- cls_instances ]
+                          , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is
+                          , not $ isInstanceHidden expInfo cls tys
+                          ]
+              -- fam_insts but with failing type fams filtered out
+              cleanFamInsts = [ (fi, n) | (Right fi, n) <- fam_insts ]
+              famInstErrs = [ errm | (Left errm, _) <- fam_insts ]
+          in do
+            dfs <- getDynFlags
+            let mkBug = (text "haddock-bug:" <+>) . text
+            liftIO $ putMsg dfs (sep $ map mkBug famInstErrs)
+            return $ cls_insts ++ cleanFamInsts
+        Nothing -> return []
+      return $ e { expItemInstances = insts }
     e -> return e
   where
     attachFixities e@ExportDecl{ expItemDecl = L _ d } = e { expItemFixities =
@@ -126,7 +135,7 @@ dropSilentArgs dfun theta = drop (dfunNSilent dfun) theta
 -- | Like GHC's getInfo but doesn't cut things out depending on the
 -- interative context, which we don't set sufficiently anyway.
 getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst]))
-getAllInfo name = withSession $ \hsc_env -> do 
+getAllInfo name = withSession $ \hsc_env -> do
    (_msgs, r) <- liftIO $ tcRnGetInfo hsc_env name
    return r
 
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index b66773ae..047960c6 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -45,7 +45,7 @@ import Bag
 import RdrName
 import TcRnTypes
 import FastString (concatFS)
-
+import qualified Outputable as O
 
 -- | Use a 'TypecheckedModule' to produce an 'Interface'.
 -- To do this, we need access to already processed modules in the topological
@@ -618,8 +618,15 @@ hiDecl dflags t = do
     Nothing -> do
       liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t]
       return Nothing
-    Just x -> return (Just (tyThingToLHsDecl x))
-
+    Just x -> case tyThingToLHsDecl x of
+      Left m -> liftErrMsg (tell [bugWarn m]) >> return Nothing
+      Right (m, t) -> liftErrMsg (tell $ map bugWarn m)
+                      >> return (Just $ noLoc t)
+    where
+      warnLine x = O.text "haddock-bug:" O.<+> O.text x O.<>
+                   O.comma O.<+> O.quotes (O.ppr t) O.<+>
+                   O.text "-- Please report this on Haddock issue tracker!"
+      bugWarn = O.showSDoc dflags . warnLine
 
 hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> Bool -> Maybe Fixity -> ErrMsgGhc (ExportItem Name)
 hiValExportItem dflags name doc splice fixity = do