From 730a2163245cf7aaf389458113e6fa338eca7865 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sat, 28 Mar 2020 12:04:16 -0400 Subject: Use TTG empty extensions to remove some `error`'s None of these error cases should ever have been reachable, so this is just a matter of leveraging the type system to assert this. * Use the `NoExtCon` and `noExtCon` to handle case matches for no extension constructors, instead of throwing an `error`. * Use the extension field of `HsSpliceTy` to ensure that this variant of `HsType` cannot exist in an `HsType DocNameI`. --- haddock-api/src/Haddock/Backends/LaTeX.hs | 5 +++-- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 3 ++- haddock-api/src/Haddock/GhcUtils.hs | 15 +++++++-------- haddock-api/src/Haddock/Interface/Rename.hs | 4 ++-- haddock-api/src/Haddock/Interface/Specialize.hs | 17 +++++------------ haddock-api/src/Haddock/Types.hs | 3 ++- 6 files changed, 21 insertions(+), 26 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 63b12a14..d52c136f 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -39,6 +39,7 @@ import Data.Char import Control.Monad import Data.Maybe import Data.List ( sort ) +import Data.Void ( absurd ) import Prelude hiding ((<>)) import Haddock.Doc (combineDocumentation) @@ -530,7 +531,7 @@ ppTyVars unicode = map (ppHsTyVarBndr unicode . unLoc) tyvarNames :: LHsQTyVars DocNameI -> [Name] -tyvarNames = map (getName . hsLTyVarNameI) . hsQTvExplicit +tyvarNames = map (getName . hsTyVarBndrName . unLoc) . hsQTvExplicit declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX @@ -1080,7 +1081,7 @@ ppr_mono_ty (HsSumTy _ tys) u = sumParens (map (ppLType u) tys) ppr_mono_ty (HsKindSig _ ty kind) u = ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind ppr_mono_ty (HsListTy _ ty) u = brackets (ppr_mono_lty ty u) ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u -ppr_mono_ty (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" +ppr_mono_ty (HsSpliceTy v _) _ = absurd v ppr_mono_ty (HsRecTy {}) _ = text "{..}" ppr_mono_ty (XHsType (NHsCoreTy {})) _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index b450dc94..25669ca7 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -32,6 +32,7 @@ import Haddock.Doc (combineDocumentation) import Data.List ( intersperse, sort ) import qualified Data.Map as Map import Data.Maybe +import Data.Void ( absurd ) import Text.XHtml hiding ( name, title, p, quote ) import BasicTypes (PromotionFlag(..), isPromoted) @@ -1215,7 +1216,7 @@ ppr_mono_ty (HsKindSig _ ty kind) u q e = ppr_mono_ty (HsListTy _ ty) u q _ = brackets (ppr_mono_lty ty u q HideEmptyContexts) ppr_mono_ty (HsIParamTy _ (L _ n) ty) u q _ = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u q HideEmptyContexts -ppr_mono_ty (HsSpliceTy {}) _ _ _ = error "ppr_mono_ty HsSpliceTy" +ppr_mono_ty (HsSpliceTy v _) _ _ _ = absurd v ppr_mono_ty (HsRecTy {}) _ _ _ = toHtml "{..}" -- Can now legally occur in ConDeclGADT, the output here is to provide a -- placeholder in the signature, which is followed by the field diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 77d6ec39..f600997a 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -165,18 +165,17 @@ nubByName f ns = go emptyNameSet ns where y = f x + -- --------------------------------------------------------------------- -- These functions are duplicated from the GHC API, as they must be -- instantiated at DocNameI instead of (GhcPass _). -hsTyVarNameI :: HsTyVarBndr DocNameI -> DocName -hsTyVarNameI (UserTyVar _ (L _ n)) = n -hsTyVarNameI (KindedTyVar _ (L _ n) _) = n -hsTyVarNameI (XTyVarBndr nec) = noExtCon nec - -hsLTyVarNameI :: LHsTyVarBndr DocNameI -> DocName -hsLTyVarNameI = hsTyVarNameI . unLoc +-- | Like 'hsTyVarName' from GHC API, but not instantiated at (GhcPass _) +hsTyVarBndrName :: (XXTyVarBndr n ~ NoExtCon) => HsTyVarBndr n -> IdP n +hsTyVarBndrName (UserTyVar _ name) = unLoc name +hsTyVarBndrName (KindedTyVar _ (L _ name) _) = name +hsTyVarBndrName (XTyVarBndr nec) = noExtCon nec getConNamesI :: ConDecl DocNameI -> [Located DocName] getConNamesI ConDeclH98 {con_name = name} = [name] @@ -311,7 +310,7 @@ restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) [] -> defn { dd_ND = DataType, dd_cons = [] } [con] -> defn { dd_cons = [con] } _ -> error "Should not happen" -restrictDataDefn _ (XHsDataDefn _) = error "restrictDataDefn" +restrictDataDefn _ (XHsDataDefn nec) = noExtCon nec restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 0b122b07..ce3878b8 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -313,7 +313,7 @@ renameLTyVarBndr (L loc (KindedTyVar x (L lv n) kind)) = do { n' <- rename n ; kind' <- renameLKind kind ; return (L loc (KindedTyVar x (L lv n') kind')) } -renameLTyVarBndr (L _ (XTyVarBndr _ )) = error "haddock:renameLTyVarBndr" +renameLTyVarBndr (L _ (XTyVarBndr nec)) = noExtCon nec renameLContext :: Located [LHsType GhcRn] -> RnM (Located [LHsType DocNameI]) renameLContext (L loc context) = do @@ -512,7 +512,7 @@ renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI) renameLFieldOcc (L l (FieldOcc sel lbl)) = do sel' <- rename sel return $ L l (FieldOcc sel' lbl) -renameLFieldOcc (L _ (XFieldOcc _)) = error "haddock:renameLFieldOcc" +renameLFieldOcc (L _ (XFieldOcc nec)) = noExtCon nec renameSig :: Sig GhcRn -> RnM (Sig DocNameI) renameSig sig = case sig of diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 03cc1b7e..19b03596 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -9,6 +9,7 @@ module Haddock.Interface.Specialize ) where +import Haddock.GhcUtils ( hsTyVarBndrName ) import Haddock.Syb import Haddock.Types @@ -56,13 +57,9 @@ specialize specs = go spec_map0 -- Again, it is just a convenience function around 'specialize'. Note that -- length of type list should be the same as the number of binders. specializeTyVarBndrs :: LHsQTyVars GhcRn -> [HsType GhcRn] -> HsType GhcRn -> HsType GhcRn -specializeTyVarBndrs bndrs typs = - specialize $ zip bndrs' typs +specializeTyVarBndrs bndrs typs = specialize $ zip bndrs' typs where - bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs - bname (UserTyVar _ (L _ name)) = name - bname (KindedTyVar _ (L _ name) _) = name - bname (XTyVarBndr _) = error "haddock:specializeTyVarBndrs" + bndrs' = map (hsTyVarBndrName . unLoc) . hsq_explicit $ bndrs @@ -212,7 +209,7 @@ freeVariables = | getName name `Set.member` ctx -> (Set.empty, ctx) | otherwise -> (Set.singleton $ getName name, ctx) _ -> (Set.empty, ctx) - bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) + bndrsNames = Set.fromList . map (getName . hsTyVarBndrName . unLoc) -- | Make given type visually unambiguous. @@ -295,7 +292,7 @@ renameBinder :: HsTyVarBndr GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr GhcRn) renameBinder (UserTyVar x lname) = UserTyVar x <$> located renameName lname renameBinder (KindedTyVar x lname lkind) = KindedTyVar x <$> located renameName lname <*> located renameType lkind -renameBinder (XTyVarBndr _) = error "haddock:renameBinder" +renameBinder (XTyVarBndr nec) = noExtCon nec -- | Core renaming logic. renameName :: (Eq name, SetName name) => name -> Rename name name @@ -349,7 +346,3 @@ located :: Functor f => (a -> f b) -> Located a -> f (Located b) located f (L loc e) = L loc <$> f e -tyVarName :: HsTyVarBndr name -> IdP name -tyVarName (UserTyVar _ name) = unLoc name -tyVarName (KindedTyVar _ (L _ name) _) = name -tyVarName (XTyVarBndr _ ) = error "haddock:tyVarName" diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 28e3caed..ec76fb72 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -35,6 +35,7 @@ import Control.Monad.IO.Class (MonadIO(..)) import Data.Typeable (Typeable) import Data.Map (Map) import Data.Data (Data) +import Data.Void (Void) import Documentation.Haddock.Types import BasicTypes (Fixity(..), PromotionFlag(..)) @@ -713,7 +714,7 @@ type instance XOpTy DocNameI = NoExtField type instance XParTy DocNameI = NoExtField type instance XIParamTy DocNameI = NoExtField type instance XKindSig DocNameI = NoExtField -type instance XSpliceTy DocNameI = NoExtField +type instance XSpliceTy DocNameI = Void -- see `renameHsSpliceTy` type instance XDocTy DocNameI = NoExtField type instance XBangTy DocNameI = NoExtField type instance XRecTy DocNameI = NoExtField -- cgit v1.2.3