From 7e6628febc482b4ad451f49ad416722375d1b170 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Fri, 26 Jun 2020 15:29:18 +0530 Subject: Update for modular ping pong --- haddock-api/src/Haddock/Backends/Hoogle.hs | 2 +- haddock-api/src/Haddock/Backends/LaTeX.hs | 1 - haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 5 +- haddock-api/src/Haddock/Convert.hs | 2 - haddock-api/src/Haddock/GhcUtils.hs | 62 +++++++++------------- .../src/Haddock/Interface/AttachInstances.hs | 1 - haddock-api/src/Haddock/Interface/Create.hs | 8 +-- haddock-api/src/Haddock/Interface/Rename.hs | 16 +++--- haddock-api/src/Haddock/Interface/Specialize.hs | 9 ++-- haddock-api/src/Haddock/Types.hs | 8 ++- haddock-api/src/Haddock/Utils.hs | 3 +- 11 files changed, 52 insertions(+), 65 deletions(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 75a49036..d280ed23 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -69,7 +69,7 @@ ppModule dflags iface = --------------------------------------------------------------------- -- Utility functions -dropHsDocTy :: HsType a -> HsType a +dropHsDocTy :: HsType (GhcPass p) -> HsType (GhcPass p) dropHsDocTy = f where g (L src x) = L src (f x) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index badb1914..c439be8f 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -41,7 +41,6 @@ import Control.Monad import Data.Maybe import Data.List import Prelude hiding ((<>)) -import GHC.Core.Multiplicity import Haddock.Doc (combineDocumentation) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 6e210b61..20e099ee 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -41,7 +41,6 @@ import GHC.Exts import GHC.Types.Name import GHC.Data.BooleanFormula import GHC.Types.Name.Reader ( rdrNameOcc ) -import GHC.Core.Multiplicity -- | Pretty print a declaration ppDecl :: Bool -- ^ print summary info only @@ -1143,18 +1142,16 @@ ppLKind unicode qual y = ppKind unicode qual (unLoc y) ppKind :: Unicode -> Qualification -> HsKind DocNameI -> Html ppKind unicode qual ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode qual HideEmptyContexts -patSigContext :: LHsType name -> HideEmptyContexts +patSigContext :: LHsType DocNameI -> HideEmptyContexts patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmptyToplevelContexts | otherwise = HideEmptyContexts where - hasNonEmptyContext :: LHsType name -> Bool hasNonEmptyContext t = case unLoc t of HsForAllTy _ _ s -> hasNonEmptyContext s HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True HsFunTy _ _ _ s -> hasNonEmptyContext s _ -> False - isFirstContextEmpty :: LHsType name -> Bool isFirstContextEmpty t = case unLoc t of HsForAllTy _ _ s -> isFirstContextEmpty s diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 3b73dcd1..d8f7206f 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -35,7 +35,6 @@ import GHC.Types.Name import GHC.Types.Name.Set ( emptyNameSet ) import GHC.Types.Name.Reader ( mkVarUnqual ) import GHC.Core.PatSyn -import GHC.Types.SrcLoc ( Located, noLoc, unLoc, GenLocated(..), srcLocSpan ) import GHC.Tc.Utils.TcType import GHC.Core.TyCon import GHC.Core.Type @@ -57,7 +56,6 @@ import Haddock.Types import Haddock.Interface.Specialize import Haddock.GhcUtils ( orderedFVs, defaultRuntimeRepVars ) -import GHC.Core.Multiplicity import Data.Maybe ( catMaybes, mapMaybe, maybeToList ) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 3abb6481..6fae5f58 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -1,5 +1,8 @@ {-# LANGUAGE BangPatterns, StandaloneDeriving, FlexibleInstances, ViewPatterns #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} @@ -23,17 +26,14 @@ import Data.Char ( isSpace ) import Haddock.Types( DocName, DocNameI ) -import GHC.Utils.Exception import GHC.Utils.FV as FV import GHC.Utils.Outputable ( Outputable, panic, showPpr ) import GHC.Types.Name -import GHC.Types.Name.Set import GHC.Unit.Module import GHC.Driver.Types import GHC import GHC.Core.Class import GHC.Driver.Session -import GHC.Core.Multiplicity import GHC.Types.SrcLoc ( advanceSrcLoc ) import GHC.Types.Var ( Specificity, VarBndr(..), TyVarBinder , tyVarKind, updateTyVarKind, isInvisibleArgFlag ) @@ -50,6 +50,8 @@ import Data.ByteString ( ByteString ) import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BS +import GHC.HsToCore.Docs + moduleString :: Module -> String moduleString = moduleNameString . moduleName @@ -89,25 +91,12 @@ ifTrueJust :: Bool -> name -> Maybe name ifTrueJust True = Just ifTrueJust False = const Nothing -sigName :: LSig name -> [IdP name] +sigName :: LSig GhcRn -> [IdP GhcRn] sigName (L _ sig) = sigNameNoLoc sig -sigNameNoLoc :: Sig name -> [IdP name] -sigNameNoLoc (TypeSig _ ns _) = map unLoc ns -sigNameNoLoc (ClassOpSig _ _ ns _) = map unLoc ns -sigNameNoLoc (PatSynSig _ ns _) = map unLoc ns -sigNameNoLoc (SpecSig _ n _ _) = [unLoc n] -sigNameNoLoc (InlineSig _ n _) = [unLoc n] -sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns -sigNameNoLoc _ = [] - -- | Was this signature given by the user? -isUserLSig :: LSig name -> Bool -isUserLSig (L _ (TypeSig {})) = True -isUserLSig (L _ (ClassOpSig {})) = True -isUserLSig (L _ (PatSynSig {})) = True -isUserLSig _ = False - +isUserLSig :: forall p. UnXRec p => LSig p -> Bool +isUserLSig = isUserSig . unXRec @p isClassD :: HsDecl a -> Bool isClassD (TyClD _ d) = isClassDecl d @@ -258,18 +247,18 @@ data Precedence -- -- We cannot add parens that may be required by fixities because we do not have -- any fixity information to work with in the first place :(. -reparenTypePrec :: (XParTy a ~ NoExtField) => Precedence -> HsType a -> HsType a +reparenTypePrec :: forall a. (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => Precedence -> HsType a -> HsType a reparenTypePrec = go where -- Shorter name for 'reparenType' - go :: (XParTy a ~ NoExtField) => Precedence -> HsType a -> HsType a + go :: Precedence -> HsType a -> HsType a go _ (HsBangTy x b ty) = HsBangTy x b (reparenLType ty) go _ (HsTupleTy x con tys) = HsTupleTy x con (map reparenLType tys) go _ (HsSumTy x tys) = HsSumTy x (map reparenLType tys) go _ (HsKindSig x ty kind) = HsKindSig x (reparenLType ty) (reparenLType kind) go _ (HsListTy x ty) = HsListTy x (reparenLType ty) - go _ (HsRecTy x flds) = HsRecTy x (map (fmap reparenConDeclField) flds) + go _ (HsRecTy x flds) = HsRecTy x (map (mapXRec @a reparenConDeclField) flds) go p (HsDocTy x ty d) = HsDocTy x (goL p ty) d go _ (HsExplicitListTy x p tys) = HsExplicitListTy x p (map reparenLType tys) go _ (HsExplicitTupleTy x tys) = HsExplicitTupleTy x (map reparenLType tys) @@ -278,7 +267,7 @@ reparenTypePrec = go go p (HsForAllTy x tele ty) = paren p PREC_CTX $ HsForAllTy x (reparenHsForAllTelescope tele) (reparenLType ty) go p (HsQualTy x ctxt ty) - = paren p PREC_FUN $ HsQualTy x (fmap (map reparenLType) ctxt) (reparenLType ty) + = paren p PREC_FUN $ HsQualTy x (mapXRec @a (map reparenLType) ctxt) (reparenLType ty) go p (HsFunTy x w ty1 ty2) = paren p PREC_FUN $ HsFunTy x w (goL PREC_FUN ty1) (goL PREC_TOP ty2) go p (HsAppTy x fun_ty arg_ty) @@ -287,7 +276,7 @@ reparenTypePrec = go = paren p PREC_CON $ HsAppKindTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ki) go p (HsOpTy x ty1 op ty2) = paren p PREC_FUN $ HsOpTy x (goL PREC_OP ty1) op (goL PREC_OP ty2) - go p (HsParTy _ t) = unLoc $ goL p t -- pretend the paren doesn't exist - it will be added back if needed + go p (HsParTy _ t) = unXRec @a $ goL p t -- pretend the paren doesn't exist - it will be added back if needed go _ t@HsTyVar{} = t go _ t@HsStarTy{} = t go _ t@HsSpliceTy{} = t @@ -296,43 +285,42 @@ reparenTypePrec = go go _ t@XHsType{} = t -- Located variant of 'go' - goL :: (XParTy a ~ NoExtField) => Precedence -> LHsType a -> LHsType a - goL ctxt_prec = fmap (go ctxt_prec) + goL :: Precedence -> LHsType a -> LHsType a + goL ctxt_prec = mapXRec @a (go ctxt_prec) -- Optionally wrap a type in parens - paren :: (XParTy a ~ NoExtField) - => Precedence -- Precedence of context + paren :: Precedence -- Precedence of context -> Precedence -- Precedence of top-level operator -> HsType a -> HsType a -- Wrap in parens if (ctxt >= op) - paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy noExtField . noLoc + paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy noExtField . wrapXRec @a | otherwise = id -- | Add parenthesis around the types in a 'HsType' (see 'reparenTypePrec') -reparenType :: (XParTy a ~ NoExtField) => HsType a -> HsType a +reparenType :: (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => HsType a -> HsType a reparenType = reparenTypePrec PREC_TOP -- | Add parenthesis around the types in a 'LHsType' (see 'reparenTypePrec') -reparenLType :: (XParTy a ~ NoExtField) => LHsType a -> LHsType a -reparenLType = fmap reparenType +reparenLType :: forall a. (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => LHsType a -> LHsType a +reparenLType = mapXRec @a reparenType -- | Add parentheses around the types in an 'HsForAllTelescope' (see 'reparenTypePrec') -reparenHsForAllTelescope :: (XParTy a ~ NoExtField) +reparenHsForAllTelescope :: forall a. (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => HsForAllTelescope a -> HsForAllTelescope a reparenHsForAllTelescope (HsForAllVis x bndrs) = - HsForAllVis x (map (fmap reparenTyVar) bndrs) + HsForAllVis x (map (mapXRec @a reparenTyVar) bndrs) reparenHsForAllTelescope (HsForAllInvis x bndrs) = - HsForAllInvis x (map (fmap reparenTyVar) bndrs) + HsForAllInvis x (map (mapXRec @a reparenTyVar) bndrs) reparenHsForAllTelescope v@XHsForAllTelescope{} = v -- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec') -reparenTyVar :: (XParTy a ~ NoExtField) => HsTyVarBndr flag a -> HsTyVarBndr flag a +reparenTyVar :: (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => HsTyVarBndr flag a -> HsTyVarBndr flag a reparenTyVar (UserTyVar x flag n) = UserTyVar x flag n reparenTyVar (KindedTyVar x flag n kind) = KindedTyVar x flag n (reparenLType kind) reparenTyVar v@XTyVarBndr{} = v -- | Add parenthesis around the types in a 'ConDeclField' (see 'reparenTypePrec') -reparenConDeclField :: (XParTy a ~ NoExtField) => ConDeclField a -> ConDeclField a +reparenConDeclField :: (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => ConDeclField a -> ConDeclField a reparenConDeclField (ConDeclField x n t d) = ConDeclField x n (reparenLType t) d reparenConDeclField c@XConDeclField{} = c diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 0840bd77..d5fe878b 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -17,7 +17,6 @@ module Haddock.Interface.AttachInstances (attachInstances) where import Haddock.Types import Haddock.Convert -import Haddock.GhcUtils import Control.Applicative ((<|>)) import Control.Arrow hiding ((<+>)) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 7b9674a6..1f223282 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -34,7 +34,6 @@ import qualified Data.Map as M import Data.Map (Map) import Data.List import Data.Maybe -import Control.Applicative import Control.Monad import Data.Traversable @@ -49,7 +48,6 @@ import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Unit.State -import GHC.Data.Bag import GHC.Types.Name.Reader import GHC.Tc.Types import GHC.Data.FastString ( unpackFS, bytesFS ) @@ -57,8 +55,6 @@ import GHC.Types.Basic ( StringLiteral(..), SourceText(..), PromotionFlag(..) ) import qualified GHC.Utils.Outputable as O import GHC.HsToCore.Docs hiding (mkMaps) -import GHC.Core.Multiplicity - -- | Use a 'TypecheckedModule' to produce an 'Interface'. -- To do this, we need access to already processed modules in the topological @@ -240,7 +236,7 @@ mkAliasMap state mRenamedSource = -- -- With our mapping we know that we can display exported modules M1 and M2. -- -unrestrictedModuleImports :: [ImportDecl name] -> M.Map ModuleName [ModuleName] +unrestrictedModuleImports :: [ImportDecl GhcRn] -> M.Map ModuleName [ModuleName] unrestrictedModuleImports idecls = M.map (map (unLoc . ideclName)) $ M.filter (all isInteresting) impModMap @@ -958,7 +954,7 @@ extractPatternSyn nm t tvs cons = typ'' = noLoc (HsQualTy noExtField (noLoc []) typ') in PatSynSig noExtField [noLoc nm] (mkEmptyImplicitBndrs typ'') - longArrow :: (XFunTy name ~ NoExtField) => [LHsType name] -> LHsType name -> LHsType name + longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField HsUnrestrictedArrow x y)) output inputs data_ty con diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 27bad4b9..39a1ae17 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -474,7 +474,8 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI) renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars , con_mb_cxt = lcontext, con_args = details - , con_doc = mbldoc }) = do + , con_doc = mbldoc + , con_forall = forall }) = do lname' <- renameL lname ltyvars' <- mapM renameLTyVarBndr ltyvars lcontext' <- traverse renameLContext lcontext @@ -482,21 +483,24 @@ renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars mbldoc' <- mapM renameLDocHsSyn mbldoc return (decl { con_ext = noExtField, con_name = lname', con_ex_tvs = ltyvars' , con_mb_cxt = lcontext' + , con_forall = forall -- Remove when #18311 is fixed , con_args = details', con_doc = mbldoc' }) -renameCon decl@(ConDeclGADT { con_names = lnames, con_qvars = ltyvars +renameCon ConDeclGADT { con_names = lnames, con_qvars = ltyvars , con_mb_cxt = lcontext, con_args = details - , con_res_ty = res_ty - , con_doc = mbldoc }) = do + , con_res_ty = res_ty, con_forall = forall + , con_doc = mbldoc } = do lnames' <- mapM renameL lnames ltyvars' <- mapM renameLTyVarBndr ltyvars lcontext' <- traverse renameLContext lcontext details' <- renameDetails details res_ty' <- renameLType res_ty mbldoc' <- mapM renameLDocHsSyn mbldoc - return (decl { con_g_ext = noExtField, con_names = lnames', con_qvars = ltyvars' + return (ConDeclGADT + { con_g_ext = noExtField, con_names = lnames', con_qvars = ltyvars' , con_mb_cxt = lcontext', con_args = details' - , con_res_ty = res_ty', con_doc = mbldoc' }) + , con_res_ty = res_ty', con_doc = mbldoc' + , con_forall = forall}) -- Remove when #18311 is fixed renameHsScaled :: HsScaled GhcRn (LHsType GhcRn) -> RnM (HsScaled DocNameI (LHsType DocNameI)) diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 5c933f25..66627c15 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -3,6 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GADTs #-} module Haddock.Interface.Specialize ( specializeInstHead @@ -15,7 +16,6 @@ import Haddock.Types import GHC import GHC.Types.Name import GHC.Data.FastString -import GHC.Builtin.Types.Prim ( funTyConName ) import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName ) import Control.Monad @@ -36,7 +36,7 @@ specialize specs = go spec_map0 go :: forall x. Data x => Map Name (HsType GhcRn) -> x -> x go spec_map = everywhereButType @Name $ mkT $ sugar . strip_kind_sig . specialize_ty_var spec_map - strip_kind_sig :: HsType name -> HsType name + strip_kind_sig :: HsType GhcRn -> HsType GhcRn strip_kind_sig (HsKindSig _ (L _ t) _) = t strip_kind_sig typ = typ @@ -205,6 +205,7 @@ freeVariables :: HsType GhcRn -> Set Name freeVariables = everythingWithState Set.empty Set.union query where + query :: forall a . Data a => a -> Set Name -> (Set Name, Set Name) query term ctx = case cast term :: Maybe (HsType GhcRn) of Just (HsForAllTy _ tele _) -> (Set.empty, Set.union ctx (teleNames tele)) @@ -213,6 +214,7 @@ freeVariables = | otherwise -> (Set.singleton $ getName name, ctx) _ -> (Set.empty, ctx) + teleNames :: HsForAllTelescope GhcRn -> Set Name teleNames (HsForAllVis _ bndrs) = bndrsNames bndrs teleNames (HsForAllInvis _ bndrs) = bndrsNames bndrs @@ -366,7 +368,6 @@ located :: Functor f => (a -> f b) -> Located a -> f (Located b) located f (L loc e) = L loc <$> f e -tyVarName :: HsTyVarBndr flag name -> IdP name +tyVarName :: HsTyVarBndr flag GhcRn -> IdP GhcRn 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 21c7d19b..89fd6658 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -669,7 +669,13 @@ instance MonadIO ErrMsgGhc where -- * Pass sensitive types ----------------------------------------------------------------------------- -type instance XRec DocNameI f = Located (f DocNameI) +type instance XRec DocNameI a = Located a +instance UnXRec DocNameI where + unXRec = unLoc +instance MapXRec DocNameI where + mapXRec = fmap +instance WrapXRec DocNameI where + wrapXRec = noLoc type instance XForAllTy DocNameI = NoExtField type instance XQualTy DocNameI = NoExtField diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 8346a477..33fbd000 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Utils @@ -90,8 +91,6 @@ import qualified System.Posix.Internals import GHC.Utils.Monad ( MonadIO(..) ) -import GHC.Core.Multiplicity - -------------------------------------------------------------------------------- -- * Logging -- cgit v1.2.3