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.

3 files changed, 141 insertions, 106 deletions

diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index ff7ca560..803c1a3b 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -17,34 +17,36 @@ module Haddock.Convert where
 -- instance heads, which aren't TyThings, so just export everything.
 
 
-import HsSyn
-import TcType ( tcSplitSigmaTy )
-import TypeRep
-import Type(isStrLitTy)
-import Kind ( splitKindFunTys, synTyConResKind, isKind )
-import Name
-import Var
+import Bag ( emptyBag )
+import BasicTypes ( TupleSort(..) )
 import Class
-import TyCon
 import CoAxiom
 import ConLike
+import Data.Either (lefts, rights)
+import Data.List( partition )
+import Data.Monoid (mempty)
 import DataCon
-import PatSyn
 import FamInstEnv
-import BasicTypes ( TupleSort(..) )
+import Haddock.Types
+import HsSyn
+import Kind ( splitKindFunTys, synTyConResKind, isKind )
+import Name
+import PatSyn
+import PrelNames (ipClassName)
+import SrcLoc ( Located, noLoc, unLoc )
+import TcType ( tcSplitSigmaTy )
+import TyCon
+import Type(isStrLitTy)
+import TypeRep
 import TysPrim ( alphaTyVars )
 import TysWiredIn ( listTyConName, eqTyCon )
-import PrelNames (ipClassName)
-import Bag ( emptyBag )
 import Unique ( getUnique )
-import SrcLoc ( Located, noLoc, unLoc )
-import Data.List( partition )
-import Haddock.Types
+import Var
 
 
 -- the main function here! yay!
-tyThingToLHsDecl :: TyThing -> LHsDecl Name
-tyThingToLHsDecl t = noLoc $ case t of
+tyThingToLHsDecl :: TyThing -> Either ErrMsg ([ErrMsg], (HsDecl Name))
+tyThingToLHsDecl t = case t of
   -- ids (functions and zero-argument a.k.a. CAFs) get a type signature.
   -- Including built-in functions like seq.
   -- foreign-imported functions could be represented with ForD
@@ -53,20 +55,22 @@ tyThingToLHsDecl t = noLoc $ case t of
   -- in a future code version we could turn idVarDetails = foreign-call
   -- into a ForD instead of a SigD if we wanted.  Haddock doesn't
   -- need to care.
-  AnId i -> SigD (synifyIdSig ImplicitizeForAll i)
+  AnId i -> allOK $ SigD (synifyIdSig ImplicitizeForAll i)
 
   -- type-constructors (e.g. Maybe) are complicated, put the definition
   -- later in the file (also it's used for class associated-types too.)
   ATyCon tc
     | Just cl <- tyConClass_maybe tc -- classes are just a little tedious
-    -> let extractFamilyDecl :: TyClDecl a -> LFamilyDecl a
-           extractFamilyDecl (FamDecl d) = noLoc d
+    -> let extractFamilyDecl :: TyClDecl a -> Either ErrMsg (LFamilyDecl a)
+           extractFamilyDecl (FamDecl d) = return $ noLoc d
            extractFamilyDecl _           =
-             error "tyThingToLHsDecl: impossible associated tycon"
+             Left "tyThingToLHsDecl: impossible associated tycon"
 
            atTyClDecls = [synifyTyCon Nothing at_tc | (at_tc, _) <- classATItems cl]
-           atFamDecls  = map extractFamilyDecl atTyClDecls in
-       TyClD $ ClassDecl
+           atFamDecls  = map extractFamilyDecl (rights atTyClDecls)
+           tyClErrors = lefts atTyClDecls
+           famDeclErrors = lefts atFamDecls
+       in withErrs (tyClErrors ++ famDeclErrors) . TyClD $ ClassDecl
          { tcdCtxt = synifyCtx (classSCTheta cl)
          , tcdLName = synifyName cl
          , tcdTyVars = synifyTyVars (classTyVars cl)
@@ -78,19 +82,19 @@ tyThingToLHsDecl t = noLoc $ case t of
                         (classMethods cl)
          , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature
          -- class associated-types are a subset of TyCon:
-         , tcdATs = atFamDecls
+         , tcdATs = rights atFamDecls
          , tcdATDefs = [] --ignore associated type defaults
          , tcdDocs = [] --we don't have any docs at this point
          , tcdFVs = placeHolderNames }
     | otherwise
-    -> TyClD (synifyTyCon Nothing tc)
+    -> synifyTyCon Nothing tc >>= allOK . TyClD
 
   -- type-constructors (e.g. Maybe) are complicated, put the definition
   -- later in the file (also it's used for class associated-types too.)
-  ACoAxiom ax -> synifyAxiom ax
+  ACoAxiom ax -> synifyAxiom ax >>= allOK
 
   -- a data-constructor alone just gets rendered as a function:
-  AConLike (RealDataCon dc) -> SigD (TypeSig [synifyName dc]
+  AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig [synifyName dc]
     (synifyType ImplicitizeForAll (dataConUserType dc)))
 
   AConLike (PatSynCon ps) ->
@@ -99,7 +103,7 @@ tyThingToLHsDecl t = noLoc $ case t of
 #else
       let (_, _, (req_theta, prov_theta)) = patSynSig ps
 #endif
-      in SigD $ PatSynSig (synifyName ps)
+      in allOK . SigD $ PatSynSig (synifyName ps)
 #if MIN_VERSION_ghc(7,8,3)
                           (fmap (synifyType WithinType) (patSynTyDetails ps))
                           (synifyType WithinType res_ty)
@@ -109,6 +113,9 @@ tyThingToLHsDecl t = noLoc $ case t of
 #endif
                           (synifyCtx req_theta)
                           (synifyCtx prov_theta)
+  where
+    withErrs e x = return (e, x)
+    allOK x = return (mempty, x)
 
 synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn Name
 synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
@@ -122,25 +129,27 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
                                         , hswb_tvs = map tyVarName tvs }
                     , tfie_rhs   = hs_rhs }
 
-synifyAxiom :: CoAxiom br -> HsDecl Name
+synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl Name)
 synifyAxiom ax@(CoAxiom { co_ax_tc = tc })
   | isOpenSynFamilyTyCon tc
   , Just branch <- coAxiomSingleBranch_maybe ax
-  = InstD (TyFamInstD (TyFamInstDecl { tfid_eqn = noLoc $ synifyAxBranch tc branch
-                                     , tfid_fvs = placeHolderNames }))
+  = return $ InstD (TyFamInstD
+                    (TyFamInstDecl { tfid_eqn = noLoc $ synifyAxBranch tc branch
+                                   , tfid_fvs = placeHolderNames }))
 
   | Just ax' <- isClosedSynFamilyTyCon_maybe tc
   , getUnique ax' == getUnique ax   -- without the getUniques, type error
-  = TyClD (synifyTyCon (Just ax) tc)
+  = synifyTyCon (Just ax) tc >>= return . TyClD
 
   | otherwise
-  = error "synifyAxiom: closed/open family confusion"
+  = Left "synifyAxiom: closed/open family confusion"
 
 -- | Turn type constructors into type class declarations
-synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> TyClDecl Name
+synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> Either ErrMsg (TyClDecl Name)
 synifyTyCon coax tc
   | isFunTyCon tc || isPrimTyCon tc
-  = DataDecl { tcdLName = synifyName tc
+  = return $
+    DataDecl { tcdLName = synifyName tc
              , tcdTyVars =       -- tyConTyVars doesn't work on fun/prim, but we can make them up:
                          let mk_hs_tv realKind fakeTyVar
                                 = noLoc $ KindedTyVar (getName fakeTyVar)
@@ -164,33 +173,38 @@ synifyTyCon coax tc
   = case synTyConRhs_maybe tc of
       Just rhs ->
         let info = case rhs of
-              OpenSynFamilyTyCon -> OpenTypeFamily
+              OpenSynFamilyTyCon -> return OpenTypeFamily
               ClosedSynFamilyTyCon (CoAxiom { co_ax_branches = branches }) ->
-                ClosedTypeFamily (brListMap (noLoc . synifyAxBranch tc) branches)
-              BuiltInSynFamTyCon {} -> ClosedTypeFamily []
-              AbstractClosedSynFamilyTyCon {} -> ClosedTypeFamily []
-              _ -> error "synifyTyCon: type/data family confusion"
-        in FamDecl (FamilyDecl { fdInfo = info
+                return $ ClosedTypeFamily
+                  (brListMap (noLoc . synifyAxBranch tc) branches)
+              BuiltInSynFamTyCon {} -> return $ ClosedTypeFamily []
+              AbstractClosedSynFamilyTyCon {} -> return $ ClosedTypeFamily []
+              _ -> Left "synifyTyCon: type/data family confusion"
+        in info >>= \i ->
+           return (FamDecl
+                   (FamilyDecl { fdInfo = i
                                , fdLName = synifyName tc
                                , fdTyVars = synifyTyVars (tyConTyVars tc)
-                               , fdKindSig = Just (synifyKindSig (synTyConResKind tc)) })
-      Nothing -> error "synifyTyCon: impossible open type synonym?"
+                               , fdKindSig =
+                                 Just (synifyKindSig (synTyConResKind tc))
+                               }))
+      Nothing -> Left "synifyTyCon: impossible open type synonym?"
 
   | isDataFamilyTyCon tc
   = --(why no "isOpenAlgTyCon"?)
     case algTyConRhs tc of
-        DataFamilyTyCon ->
+        DataFamilyTyCon -> return $
           FamDecl (FamilyDecl DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
                               Nothing) --always kind '*'
-        _ -> error "synifyTyCon: impossible open data type?"
+        _ -> Left "synifyTyCon: impossible open data type?"
   | isSynTyCon tc
   = case synTyConRhs_maybe tc of
-        Just (SynonymTyCon ty) ->
+        Just (SynonymTyCon ty) -> return $
           SynDecl { tcdLName = synifyName tc
                   , tcdTyVars = synifyTyVars (tyConTyVars tc)
                   , tcdRhs = synifyType WithinType ty
                   , tcdFVs = placeHolderNames }
-        _ -> error "synifyTyCon: impossible synTyCon"
+        _ -> Left "synifyTyCon: impossible synTyCon"
   | otherwise =
   -- (closed) newtype and data
   let
@@ -219,7 +233,9 @@ synifyTyCon coax tc
   -- in prefix position), since, otherwise, the logic (at best) gets much more
   -- complicated. (would use dataConIsInfix.)
   use_gadt_syntax = any (not . isVanillaDataCon) (tyConDataCons tc)
-  cons = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc)
+  consRaw = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc)
+  cons = rights consRaw
+  dataConErrs = lefts consRaw
   -- "deriving" doesn't affect the signature, no need to specify any.
   alg_deriv = Nothing
   defn = HsDataDefn { dd_ND      = alg_nd
@@ -228,16 +244,19 @@ synifyTyCon coax tc
                     , dd_kindSig = fmap synifyKindSig kindSig
                     , dd_cons    = cons
                     , dd_derivs  = alg_deriv }
- in DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdDataDefn = defn
-             , tcdFVs = placeHolderNames }
+ in case lefts consRaw of
+  [] -> return $
+        DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdDataDefn = defn
+                 , tcdFVs = placeHolderNames }
+  ms -> Left $ unlines dataConErrs
 
 -- User beware: it is your responsibility to pass True (use_gadt_syntax)
 -- for any constructor that would be misrepresented by omitting its
 -- result-type.
 -- But you might want pass False in simple enough cases,
 -- if you think it looks better.
-synifyDataCon :: Bool -> DataCon -> LConDecl Name
-synifyDataCon use_gadt_syntax dc = noLoc $
+synifyDataCon :: Bool -> DataCon -> Either ErrMsg (LConDecl Name)
+synifyDataCon use_gadt_syntax dc =
  let
   -- dataConIsInfix allegedly tells us whether it was declared with
   -- infix *syntax*.
@@ -270,19 +289,21 @@ synifyDataCon use_gadt_syntax dc = noLoc $
                                            (synifyName field) synTy Nothing)
                 (dataConFieldLabels dc) linear_tys
   hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of
-          (True,True) -> error "synifyDataCon: contradiction!"
-          (True,False) -> RecCon field_tys
-          (False,False) -> PrefixCon linear_tys
+          (True,True) -> Left "synifyDataCon: contradiction!"
+          (True,False) -> return $ RecCon field_tys
+          (False,False) -> return $ PrefixCon linear_tys
           (False,True) -> case linear_tys of
-                           [a,b] -> InfixCon a b
-                           _ -> error "synifyDataCon: infix with non-2 args?"
+                           [a,b] -> return $ InfixCon a b
+                           _ -> Left "synifyDataCon: infix with non-2 args?"
   hs_res_ty = if use_gadt_syntax
               then ResTyGADT (synifyType WithinType res_ty)
               else ResTyH98
  -- finally we get synifyDataCon's result!
- in ConDecl name Implicit{-we don't know nor care-}
-      qvars ctx hs_arg_tys hs_res_ty Nothing
-      False --we don't want any "deprecated GADT syntax" warnings!
+ in hs_arg_tys >>=
+      \hat -> return . noLoc $ ConDecl name Implicit {-we don't know nor care-}
+                qvars ctx hat hs_res_ty Nothing
+                -- we don't want any "deprecated GADT syntax" warnings!
+                False
 
 
 synifyName :: NamedThing n => n -> Located Name
@@ -362,18 +383,16 @@ synifyType _ (FunTy t1 t2) = let
   in noLoc $ HsFunTy s1 s2
 synifyType s forallty@(ForAllTy _tv _ty) =
   let (tvs, ctx, tau) = tcSplitSigmaTy forallty
-  in case s of
-    DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau
-    _ -> let
-      forallPlicitness = case s of
-              WithinType -> Explicit
-              ImplicitizeForAll -> Implicit
-              _ -> error "synifyType: impossible case!!!"
       sTvs = synifyTyVars tvs
       sCtx = synifyCtx ctx
       sTau = synifyType WithinType tau
-     in noLoc $
-           HsForAllTy forallPlicitness sTvs sCtx sTau
+      mkHsForAllTy forallPlicitness =
+        noLoc $ HsForAllTy forallPlicitness sTvs sCtx sTau
+  in case s of
+    DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau
+    WithinType -> mkHsForAllTy Explicit
+    ImplicitizeForAll -> mkHsForAllTy Implicit
+
 synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t
 
 synifyTyLit :: TyLit -> HsTyLit
@@ -393,14 +412,14 @@ synifyInstHead (_, preds, cls, types) =
   where (ks,ts) = break (not . isKind) types
 
 -- Convert a family instance, this could be a type family or data family
-synifyFamInst :: FamInst -> Bool -> InstHead Name
+synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead Name)
 synifyFamInst fi opaque =
-  ( fi_fam fi
-  , map (unLoc . synifyType WithinType) ks
-  , map (unLoc . synifyType WithinType) ts
-  , case fi_flavor fi of
-      SynFamilyInst | opaque -> TypeInst Nothing
-      SynFamilyInst -> TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi
-      DataFamilyInst c -> DataInst $ synifyTyCon (Just $ famInstAxiom fi) c
-  )
+  let fff = case fi_flavor fi of
+        SynFamilyInst | opaque -> return $ TypeInst Nothing
+        SynFamilyInst ->
+          return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi
+        DataFamilyInst c ->
+          synifyTyCon (Just $ famInstAxiom fi) c >>= return . DataInst
+  in fff >>= \f' -> return (fi_fam fi , map (unLoc . synifyType WithinType) ks,
+                            map (unLoc . synifyType WithinType) ts , f')
   where (ks,ts) = break (not . isKind) $ fi_tys fi
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