diff options
Diffstat (limited to 'haddock-api/src/Haddock')
| -rw-r--r-- | haddock-api/src/Haddock/Convert.hs | 175 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/AttachInstances.hs | 59 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 13 |
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 |