From 02a1def8d147da88a0433726590f8586f486c760 Mon Sep 17 00:00:00 2001 From: Krzysztof Gogolewski Date: Wed, 17 Jun 2020 15:04:59 -0400 Subject: Adapt Haddock to LinearTypes See ghc/ghc!852. --- haddock-api/src/Haddock/Backends/Hoogle.hs | 10 ++++--- .../src/Haddock/Backends/Hyperlinker/Parser.hs | 1 + .../src/Haddock/Backends/Hyperlinker/Utils.hs | 4 +-- haddock-api/src/Haddock/Backends/LaTeX.hs | 17 ++++++----- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 26 ++++++++-------- haddock-api/src/Haddock/Convert.hs | 35 +++++++++++++++------- haddock-api/src/Haddock/GhcUtils.hs | 32 ++++++++++++-------- .../src/Haddock/Interface/AttachInstances.hs | 6 ++-- haddock-api/src/Haddock/Interface/Create.hs | 21 +++++++------ haddock-api/src/Haddock/Interface/Rename.hs | 22 ++++++++++---- haddock-api/src/Haddock/Interface/Specialize.hs | 10 +++++-- haddock-api/src/Haddock/Utils.hs | 4 ++- 12 files changed, 117 insertions(+), 71 deletions(-) (limited to 'haddock-api/src') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 27a7d804..75a49036 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -36,6 +36,8 @@ import Data.Version import System.Directory import System.FilePath +import GHC.Core.Multiplicity + prefix :: [String] prefix = ["-- Hoogle documentation, generated by Haddock" ,"-- See Hoogle, http://www.haskell.org/hoogle/" @@ -76,7 +78,7 @@ dropHsDocTy = f f (HsBangTy x a b) = HsBangTy x a (g b) f (HsAppTy x a b) = HsAppTy x (g a) (g b) f (HsAppKindTy x a b) = HsAppKindTy x (g a) (g b) - f (HsFunTy x a b) = HsFunTy x (g a) (g b) + f (HsFunTy x w a b) = HsFunTy x w (g a) (g b) f (HsListTy x a) = HsListTy x (g a) f (HsTupleTy x a b) = HsTupleTy x a (map g b) f (HsOpTy x a b c) = HsOpTy x (g a) b (g c) @@ -236,14 +238,14 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} -- AZ:TODO get rid of the concatMap = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConArgs con) where - f (PrefixCon args) = [typeSig name $ args ++ [resType]] + f (PrefixCon args) = [typeSig name $ (map hsScaledThing args) ++ [resType]] f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] - f (RecCon (L _ recs)) = f (PrefixCon $ map cd_fld_type (map unLoc recs)) ++ concat + f (RecCon (L _ recs)) = f (PrefixCon $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat [(concatMap (lookupCon dflags subdocs . noLoc . extFieldOcc . unLoc) (cd_fld_names r)) ++ [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] - funs = foldr1 (\x y -> reL $ HsFunTy noExtField x y) + funs = foldr1 (\x y -> reL $ HsFunTy noExtField HsUnrestrictedArrow x y) apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y) typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 19c72335..6ced4924 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -265,6 +265,7 @@ classify tok = ITvbar -> TkGlyph ITlarrow {} -> TkGlyph ITrarrow {} -> TkGlyph + ITlolly {} -> TkGlyph ITat -> TkGlyph ITtilde -> TkGlyph ITdarrow {} -> TkGlyph diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs index 17ba00f0..ce5ff11c 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs @@ -129,8 +129,8 @@ recoverFullIfaceTypes df flattened ast = fmap (printed A.!) ast go (HLitTy l) = IfaceLitTy l go (HForAllTy ((n,k),af) t) = let b = (getOccFS n, k) in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t - go (HFunTy a b) = IfaceFunTy VisArg a b - go (HQualTy con b) = IfaceFunTy InvisArg con b + go (HFunTy w a b) = IfaceFunTy VisArg w a b + go (HQualTy con b) = IfaceFunTy InvisArg many_ty con b go (HCastTy a) = a go HCoercionTy = IfaceTyVar "" go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 0c323ae5..badb1914 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -41,6 +41,7 @@ import Control.Monad import Data.Maybe import Data.List import Prelude hiding ((<>)) +import GHC.Core.Multiplicity import Haddock.Doc (combineDocumentation) @@ -483,13 +484,13 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ = (decltt leader, ppLContextNoArrow lctxt unicode <+> nl) : do_largs n (darrow unicode) ltype - do_args n leader (HsFunTy _ (L _ (HsRecTy _ fields)) r) + do_args n leader (HsFunTy _ _w (L _ (HsRecTy _ fields)) r) = [ (decltt ldr, latex <+> nl) | (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma) , let latex = ppSideBySideField subdocs unicode field ] ++ do_largs (n+1) (gadtEnd <+> arrow unicode) r - do_args n leader (HsFunTy _ lt r) + do_args n leader (HsFunTy _ _w lt r) = (decltt leader, decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl) : do_largs (n+1) (arrow unicode) r do_args n leader t @@ -773,7 +774,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = | hasArgDocs -> header_ <+> ppOcc | otherwise -> hsep [ header_ , ppOcc - , hsep (map (ppLParendType unicode) args) + , hsep (map ((ppLParendType unicode) . hsScaledThing) args) ] -- Record constructor, e.g. 'Identity { runIdentity :: a }' @@ -783,9 +784,9 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = InfixCon arg1 arg2 | hasArgDocs -> header_ <+> ppOcc | otherwise -> hsep [ header_ - , ppLParendType unicode arg1 + , ppLParendType unicode (hsScaledThing arg1) , ppOccInfix - , ppLParendType unicode arg2 + , ppLParendType unicode (hsScaledThing arg2) ] ConDeclGADT{} @@ -804,10 +805,10 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = (_, RecCon (L _ fields)) -> doRecordFields fields -- Any GADT or a regular H98 prefix data constructor - (_, PrefixCon args) | hasArgDocs -> doConstrArgsWithDocs args + (_, PrefixCon args) | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args) -- An infix H98 data constructor - (_, InfixCon arg1 arg2) | hasArgDocs -> doConstrArgsWithDocs [arg1,arg2] + (_, InfixCon arg1 arg2) | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1,arg2]) _ -> empty @@ -1047,7 +1048,7 @@ ppr_mono_ty (HsForAllTy _ tele ty) unicode ppr_mono_ty (HsQualTy _ ctxt ty) unicode = sep [ ppLContext ctxt unicode , ppr_mono_lty ty unicode ] -ppr_mono_ty (HsFunTy _ ty1 ty2) u +ppr_mono_ty (HsFunTy _ _ ty1 ty2) u = sep [ ppr_mono_lty ty1 u , arrow u <+> ppr_mono_lty ty2 u ] diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 5163fb6b..6e210b61 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -41,6 +41,7 @@ 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 @@ -163,14 +164,14 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ = (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, []) : do_largs n (darrow unicode) ltype - do_args n leader (HsFunTy _ (L _ (HsRecTy _ fields)) r) + do_args n leader (HsFunTy _ _w (L _ (HsRecTy _ fields)) r) = [ (ldr <+> html, mdoc, subs) | (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma) , let (html, mdoc, subs) = ppSideBySideField subdocs unicode qual field ] ++ do_largs (n+1) (gadtEnd <+> arrow unicode) r - do_args n leader (HsFunTy _ lt r) + do_args n leader (HsFunTy _ _w lt r) = (leader <+> ppLFunLhType unicode qual emptyCtxts lt, argDoc n, []) : do_largs (n+1) (arrow unicode) r @@ -836,7 +837,8 @@ ppShortConstrParts summary dataInst con unicode qual -- Prefix constructor, e.g. 'Just a' PrefixCon args -> - ( header_ +++ hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts) args) + ( header_ +++ + hsep (ppOcc : map ((ppLParendType unicode qual HideEmptyContexts) . hsScaledThing) args) , noHtml , noHtml ) @@ -852,9 +854,9 @@ ppShortConstrParts summary dataInst con unicode qual -- Infix constructor, e.g. 'a :| [a]' InfixCon arg1 arg2 -> - ( header_ +++ hsep [ ppLParendType unicode qual HideEmptyContexts arg1 + ( header_ +++ hsep [ ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg1) , ppOccInfix - , ppLParendType unicode qual HideEmptyContexts arg2 + , ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg2) ] , noHtml , noHtml @@ -910,7 +912,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) PrefixCon args | hasArgDocs -> header_ +++ ppOcc <+> fixity | otherwise -> hsep [ header_ +++ ppOcc - , hsep (map (ppLParendType unicode qual HideEmptyContexts) args) + , hsep (map ((ppLParendType unicode qual HideEmptyContexts) . hsScaledThing) args) , fixity ] @@ -920,9 +922,9 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) -- Infix constructor, e.g. 'a :| [a]' InfixCon arg1 arg2 | hasArgDocs -> header_ +++ ppOcc <+> fixity - | otherwise -> hsep [ header_ +++ ppLParendType unicode qual HideEmptyContexts arg1 + | otherwise -> hsep [ header_ +++ ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg1) , ppOccInfix - , ppLParendType unicode qual HideEmptyContexts arg2 + , ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg2) , fixity ] @@ -957,7 +959,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) doConstrArgsWithDocs args = subFields pkg qual $ case con of ConDeclH98{} -> [ (ppLParendType unicode qual HideEmptyContexts arg, mdoc, []) - | (i, arg) <- zip [0..] args + | (i, arg) <- zip [0..] (map hsScaledThing args) , let mdoc = Map.lookup i argDocs ] ConDeclGADT{} -> @@ -1150,14 +1152,14 @@ patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmp case unLoc t of HsForAllTy _ _ s -> hasNonEmptyContext s HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True - HsFunTy _ _ s -> hasNonEmptyContext s + HsFunTy _ _ _ s -> hasNonEmptyContext s _ -> False isFirstContextEmpty :: LHsType name -> Bool isFirstContextEmpty t = case unLoc t of HsForAllTy _ _ s -> isFirstContextEmpty s HsQualTy _ cxt _ -> null (unLoc cxt) - HsFunTy _ _ s -> isFirstContextEmpty s + HsFunTy _ _ _ s -> isFirstContextEmpty s _ -> False @@ -1197,7 +1199,7 @@ ppr_mono_ty (HsTyVar _ prom (L _ name)) _ q _ | otherwise = ppDocName q Prefix True name ppr_mono_ty (HsStarTy _ isUni) u _ _ = toHtml (if u || isUni then "★" else "*") -ppr_mono_ty (HsFunTy _ ty1 ty2) u q e = +ppr_mono_ty (HsFunTy _ _ ty1 ty2) u q e = hsep [ ppr_mono_lty ty1 u q HideEmptyContexts , arrow u <+> ppr_mono_lty ty2 u q e ] diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index b45b6eab..3b73dcd1 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -57,6 +57,8 @@ import Haddock.Types import Haddock.Interface.Specialize import Haddock.GhcUtils ( orderedFVs, defaultRuntimeRepVars ) +import GHC.Core.Multiplicity + import Data.Maybe ( catMaybes, mapMaybe, maybeToList ) @@ -151,7 +153,7 @@ tyThingToLHsDecl prr t = case t of -- a data-constructor alone just gets rendered as a function: AConLike (RealDataCon dc) -> allOK $ SigD noExtField (TypeSig noExtField [synifyName dc] - (synifySigWcType ImplicitizeForAll [] (dataConUserType dc))) + (synifySigWcType ImplicitizeForAll [] (dataConWrapperType dc))) AConLike (PatSynCon ps) -> allOK . SigD noExtField $ PatSynSig noExtField [synifyName ps] (synifyPatSynSigType ps) @@ -205,7 +207,7 @@ synifyTyCon prr _coax tc DataDecl { tcdLName = synifyName tc , tcdTyVars = HsQTvs { hsq_ext = [] -- No kind polymorphism , hsq_explicit = zipWith mk_hs_tv - tyVarKinds + (map scaledThing tyVarKinds) alphaTyVars --a, b, c... which are unfortunately all kind * } @@ -374,7 +376,7 @@ synifyDataCon use_gadt_syntax dc = linear_tys = zipWith (\ty bang -> - let tySyn = synifyType WithinType [] ty + let tySyn = synifyType WithinType [] (scaledThing ty) in case bang of (HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn bang' -> noLoc $ HsBangTy noExtField bang' tySyn) @@ -387,9 +389,9 @@ synifyDataCon use_gadt_syntax dc = hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of (True,True) -> Left "synifyDataCon: contradiction!" (True,False) -> return $ RecCon (noLoc field_tys) - (False,False) -> return $ PrefixCon linear_tys + (False,False) -> return $ PrefixCon (map hsUnrestricted linear_tys) (False,True) -> case linear_tys of - [a,b] -> return $ InfixCon a b + [a,b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b) _ -> Left "synifyDataCon: infix with non-2 args?" -- finally we get synifyDataCon's result! in hs_arg_tys >>= @@ -628,11 +630,12 @@ synifyType _ vs (AppTy t1 t2) = let s1 = synifyType WithinType vs t1 s2 = synifyType WithinType vs t2 in noLoc $ HsAppTy noExtField s1 s2 -synifyType s vs funty@(FunTy InvisArg _ _) = synifySigmaType s vs funty -synifyType _ vs (FunTy VisArg t1 t2) = let +synifyType s vs funty@(FunTy InvisArg _ _ _) = synifySigmaType s vs funty +synifyType _ vs (FunTy VisArg w t1 t2) = let s1 = synifyType WithinType vs t1 s2 = synifyType WithinType vs t2 - in noLoc $ HsFunTy noExtField s1 s2 + w' = synifyMult vs w + in noLoc $ HsFunTy noExtField w' s1 s2 synifyType s vs forallty@(ForAllTy (Bndr _ argf) _ty) = case argf of Required -> synifyVisForAllType vs forallty @@ -749,7 +752,7 @@ noKindTyVars ts ty = let args = map (noKindTyVars ts) xs func = case f of TyVarTy var | (xsKinds, outKind) <- splitFunTys (tyVarKind var) - , xsKinds `eqTypes` map typeKind xs + , map scaledThing xsKinds `eqTypes` map typeKind xs , isLiftedTypeKind outKind -> unitVarSet var TyConApp t ks | t `elem` ts @@ -758,10 +761,20 @@ noKindTyVars ts ty _ -> noKindTyVars ts f in unionVarSets (func : args) noKindTyVars ts (ForAllTy _ t) = noKindTyVars ts t -noKindTyVars ts (FunTy _ t1 t2) = noKindTyVars ts t1 `unionVarSet` noKindTyVars ts t2 +noKindTyVars ts (FunTy _ w t1 t2) = noKindTyVars ts w `unionVarSet` + noKindTyVars ts t1 `unionVarSet` + noKindTyVars ts t2 noKindTyVars ts (CastTy t _) = noKindTyVars ts t noKindTyVars _ _ = emptyVarSet +synifyMult :: [TyVar] -> Mult -> HsArrow GhcRn +synifyMult vs t = case t of + One -> HsLinearArrow + Many -> HsUnrestrictedArrow + ty -> HsExplicitMult (synifyType WithinType vs ty) + + + synifyPatSynType :: PatSyn -> LHsType GhcRn synifyPatSynType ps = let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSigBndr ps @@ -923,5 +936,5 @@ tcSplitPhiTyPreserveSynonyms ty0 = split ty0 [] -- | See Note [Invariant: Never expand type synonyms] tcSplitPredFunTyPreserveSynonyms_maybe :: Type -> Maybe (PredType, Type) -tcSplitPredFunTyPreserveSynonyms_maybe (FunTy InvisArg arg res) = Just (arg, res) +tcSplitPredFunTyPreserveSynonyms_maybe (FunTy InvisArg _ arg res) = Just (arg, res) tcSplitPredFunTyPreserveSynonyms_maybe _ = Nothing diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 73a2bac6..e4d7c2b6 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -33,6 +33,7 @@ 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 ) @@ -205,12 +206,13 @@ getGADTConType (ConDeclGADT { con_forall = L _ has_forall | otherwise = tau_ty +-- tau_ty :: LHsType DocNameI tau_ty = case args of - RecCon flds -> noLoc (HsFunTy noExtField (noLoc (HsRecTy noExtField (unLoc flds))) res_ty) - PrefixCon pos_args -> foldr mkFunTy res_ty pos_args - InfixCon arg1 arg2 -> arg1 `mkFunTy` (arg2 `mkFunTy` res_ty) + RecCon flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty + PrefixCon pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args) + InfixCon arg1 arg2 -> (hsScaledThing arg1) `mkFunTy` ((hsScaledThing arg2) `mkFunTy` res_ty) - mkFunTy a b = noLoc (HsFunTy noExtField a b) + mkFunTy a b = noLoc (HsFunTy noExtField HsUnrestrictedArrow a b) getGADTConType (ConDeclH98 {}) = panic "getGADTConType" -- Should only be called on ConDeclGADT @@ -259,12 +261,14 @@ getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall | otherwise = tau_ty +-- tau_ty :: LHsType DocNameI tau_ty = case args of - RecCon flds -> noLoc (HsFunTy noExtField (noLoc (HsRecTy noExtField (unLoc flds))) res_ty) - PrefixCon pos_args -> foldr mkFunTy res_ty pos_args - InfixCon arg1 arg2 -> arg1 `mkFunTy` (arg2 `mkFunTy` res_ty) + RecCon flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty + PrefixCon pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args) + InfixCon arg1 arg2 -> (hsScaledThing arg1) `mkFunTy` ((hsScaledThing arg2) `mkFunTy` res_ty) - mkFunTy a b = noLoc (HsFunTy noExtField a b) + -- mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI + mkFunTy a b = noLoc (HsFunTy noExtField HsUnrestrictedArrow a b) getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG" -- Should only be called on ConDeclGADT @@ -316,8 +320,8 @@ reparenTypePrec = go = 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) - go p (HsFunTy x ty1 ty2) - = paren p PREC_FUN $ HsFunTy x (goL PREC_FUN ty1) (goL PREC_TOP ty2) + 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) = paren p PREC_CON $ HsAppTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ty) go p (HsAppKindTy x fun_ty arg_ki) @@ -642,7 +646,9 @@ tyCoFVsOfType' (TyVarTy v) a b c = (FV.unitFV v `unionFV` tyCoFVsOfType' tyCoFVsOfType' (TyConApp _ tys) a b c = tyCoFVsOfTypes' tys a b c tyCoFVsOfType' (LitTy {}) a b c = emptyFV a b c tyCoFVsOfType' (AppTy fun arg) a b c = (tyCoFVsOfType' arg `unionFV` tyCoFVsOfType' fun) a b c -tyCoFVsOfType' (FunTy _ arg res) a b c = (tyCoFVsOfType' res `unionFV` tyCoFVsOfType' arg) a b c +tyCoFVsOfType' (FunTy _ w arg res) a b c = (tyCoFVsOfType' w `unionFV` + tyCoFVsOfType' res `unionFV` + tyCoFVsOfType' arg) a b c tyCoFVsOfType' (ForAllTy bndr ty) a b c = tyCoFVsBndr' bndr (tyCoFVsOfType' ty) a b c tyCoFVsOfType' (CastTy ty _) a b c = (tyCoFVsOfType' ty) a b c tyCoFVsOfType' (CoercionTy _ ) a b c = emptyFV a b c @@ -688,8 +694,8 @@ defaultRuntimeRepVars = go emptyVarEnv go subs (TyConApp tc tc_args) = TyConApp tc (map (go subs) tc_args) - go subs (FunTy af arg res) - = FunTy af (go subs arg) (go subs res) + go subs (FunTy af w arg res) + = FunTy af (go subs w) (go subs arg) (go subs res) go subs (AppTy t u) = AppTy (go subs t) (go subs u) diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index ec61fb37..7deb67f9 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -194,13 +194,13 @@ instHead (_, _, cls, args) argCount :: Type -> Int argCount (AppTy t _) = argCount t + 1 argCount (TyConApp _ ts) = length ts -argCount (FunTy _ _ _) = 2 +argCount (FunTy _ _ _ _) = 2 argCount (ForAllTy _ t) = argCount t argCount (CastTy t _) = argCount t argCount _ = 0 simplify :: Type -> SimpleType -simplify (FunTy _ t1 t2) = SimpleType funTyConName [simplify t1, simplify t2] +simplify (FunTy _ _ t1 t2) = SimpleType funTyConName [simplify t1, simplify t2] simplify (ForAllTy _ t) = simplify t simplify (AppTy t1 t2) = SimpleType s (ts ++ maybeToList (simplify_maybe t2)) where (SimpleType s ts) = simplify t1 @@ -255,7 +255,7 @@ isTypeHidden expInfo = typeHidden case t of TyVarTy {} -> False AppTy t1 t2 -> typeHidden t1 || typeHidden t2 - FunTy _ t1 t2 -> typeHidden t1 || typeHidden t2 + FunTy _ _ t1 t2 -> typeHidden t1 || typeHidden t2 TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args ForAllTy bndr ty -> typeHidden (tyVarKind (binderVar bndr)) || typeHidden ty LitTy _ -> False diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 108e9f66..eb3354a4 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -56,6 +56,8 @@ import GHC.Data.FastString ( unpackFS, bytesFS ) import GHC.Types.Basic ( StringLiteral(..), SourceText(..), PromotionFlag(..) ) import qualified GHC.Utils.Outputable as O +import GHC.Core.Multiplicity + -- | Use a 'TypecheckedModule' to produce an 'Interface'. -- To do this, we need access to already processed modules in the topological @@ -486,8 +488,9 @@ subordinates instMap decl = case decl of -- | Extract constructor argument docs from inside constructor decls. conArgDocs :: ConDecl GhcRn -> Map Int HsDocString conArgDocs con = case getConArgs con of - PrefixCon args -> go 0 (map unLoc args ++ ret) - InfixCon arg1 arg2 -> go 0 ([unLoc arg1, unLoc arg2] ++ ret) + PrefixCon args -> go 0 (map (unLoc . hsScaledThing) args ++ ret) + InfixCon arg1 arg2 -> go 0 ([unLoc (hsScaledThing arg1), + unLoc (hsScaledThing arg2)] ++ ret) RecCon _ -> go 1 ret where go n (HsDocTy _ _ (L _ ds) : tys) = M.insert n ds $ go (n+1) tys @@ -514,8 +517,8 @@ typeDocs = go 0 where go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty) go n (HsQualTy { hst_body = ty }) = go n (unLoc ty) - go n (HsFunTy _ (L _ (HsDocTy _ _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty - go n (HsFunTy _ _ ty) = go (n+1) (unLoc ty) + go n (HsFunTy _ _w (L _ (HsDocTy _ _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty + go n (HsFunTy _ _ _ ty) = go (n+1) (unLoc ty) go n (HsDocTy _ _ (L _ doc)) = M.singleton n doc go _ _ = M.empty @@ -1126,9 +1129,9 @@ extractPatternSyn nm t tvs cons = extract con = let args = case getConArgs con of - PrefixCon args' -> args' + PrefixCon args' -> (map hsScaledThing args') RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields - InfixCon arg1 arg2 -> [arg1, arg2] + InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2] typ = longArrow args (data_ty con) typ' = case con of @@ -1137,8 +1140,8 @@ extractPatternSyn nm t tvs cons = typ'' = noLoc (HsQualTy noExtField (noLoc []) typ') in PatSynSig noExtField [noLoc nm] (mkEmptyImplicitBndrs typ'') - longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn - longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField x y)) output inputs + longArrow :: (XFunTy name ~ NoExtField) => [LHsType name] -> LHsType name -> LHsType name + longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField HsUnrestrictedArrow x y)) output inputs data_ty con | ConDeclGADT{} <- con = con_res_ty con @@ -1155,7 +1158,7 @@ extractRecSel _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm t tvs (L _ con : rest) = case getConArgs con of RecCon (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields -> - L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField data_ty (getBangType ty))))) + L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField HsUnrestrictedArrow data_ty (getBangType ty))))) _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)] diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index a0c118f8..80b84e87 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -221,6 +221,11 @@ renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) -> RnM (Maybe (LInjectivityAnn DocNameI)) renameMaybeInjectivityAnn = traverse renameInjectivityAnn +renameArrow :: HsArrow GhcRn -> RnM (HsArrow DocNameI) +renameArrow HsUnrestrictedArrow = return HsUnrestrictedArrow +renameArrow HsLinearArrow = return HsLinearArrow +renameArrow (HsExplicitMult p) = HsExplicitMult <$> renameLType p + renameType :: HsType GhcRn -> RnM (HsType DocNameI) renameType t = case t of HsForAllTy { hst_tele = tele, hst_body = ltype } -> do @@ -249,10 +254,11 @@ renameType t = case t of b' <- renameLKind b return (HsAppKindTy noExtField a' b') - HsFunTy _ a b -> do + HsFunTy _ w a b -> do a' <- renameLType a b' <- renameLType b - return (HsFunTy noExtField a' b') + w' <- renameArrow w + return (HsFunTy noExtField w' a' b') HsListTy _ ty -> return . (HsListTy noExtField) =<< renameLType ty HsIParamTy _ n ty -> liftM (HsIParamTy noExtField n) (renameLType ty) @@ -491,14 +497,20 @@ renameCon decl@(ConDeclGADT { con_names = lnames, con_qvars = ltyvars , con_mb_cxt = lcontext', con_args = details' , con_res_ty = res_ty', con_doc = mbldoc' }) +renameHsScaled :: HsScaled GhcRn (LHsType GhcRn) + -> RnM (HsScaled DocNameI (LHsType DocNameI)) +renameHsScaled (HsScaled w ty) = HsScaled <$> renameArrow w <*> renameLType ty + renameDetails :: HsConDeclDetails GhcRn -> RnM (HsConDeclDetails DocNameI) renameDetails (RecCon (L l fields)) = do fields' <- mapM renameConDeclFieldField fields return (RecCon (L l fields')) -renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps + -- This causes an assertion failure +--renameDetails (PrefixCon ps) = -- return . PrefixCon =<< mapM (_renameLType) ps +renameDetails (PrefixCon ps) = PrefixCon <$> mapM renameHsScaled ps renameDetails (InfixCon a b) = do - a' <- renameLType a - b' <- renameLType b + a' <- renameHsScaled a + b' <- renameHsScaled b return (InfixCon a' b') renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI) diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index e137c258..5c933f25 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -16,7 +16,7 @@ import GHC import GHC.Types.Name import GHC.Data.FastString import GHC.Builtin.Types.Prim ( funTyConName ) -import GHC.Builtin.Types ( listTyConName ) +import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName ) import Control.Monad import Control.Monad.Trans.State @@ -136,7 +136,7 @@ sugarTuples typ = sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb) | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb - | funTyConName == name' = HsFunTy noExtField la lb + | unrestrictedFunTyConName == name' = HsFunTy noExtField HsUnrestrictedArrow la lb where name' = getName name sugarOperators typ = typ @@ -260,7 +260,7 @@ renameType (HsTyVar x ip name) = HsTyVar x ip <$> located renameName name renameType t@(HsStarTy _ _) = pure t renameType (HsAppTy x lf la) = HsAppTy x <$> renameLType lf <*> renameLType la renameType (HsAppKindTy x lt lk) = HsAppKindTy x <$> renameLType lt <*> renameLKind lk -renameType (HsFunTy x la lr) = HsFunTy x <$> renameLType la <*> renameLType lr +renameType (HsFunTy x w la lr) = HsFunTy x <$> renameHsArrow w <*> renameLType la <*> renameLType lr renameType (HsListTy x lt) = HsListTy x <$> renameLType lt renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt renameType (HsSumTy x lt) = HsSumTy x <$> mapM renameLType lt @@ -281,6 +281,10 @@ renameType (HsExplicitTupleTy x ltys) = renameType t@(HsTyLit _ _) = pure t renameType (HsWildCardTy wc) = pure (HsWildCardTy wc) +renameHsArrow :: HsArrow GhcRn -> Rename (IdP GhcRn) (HsArrow GhcRn) +renameHsArrow (HsExplicitMult p) = HsExplicitMult <$> renameLType p +renameHsArrow mult = pure mult + renameLType :: LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn) renameLType = located renameType diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index d72b9004..8346a477 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -90,6 +90,8 @@ import qualified System.Posix.Internals import GHC.Utils.Monad ( MonadIO(..) ) +import GHC.Core.Multiplicity + -------------------------------------------------------------------------------- -- * Logging @@ -200,7 +202,7 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] field_avail :: LConDeclField GhcRn -> Bool field_avail (L _ (ConDeclField _ fs _ _)) = all (\f -> extFieldOcc (unLoc f) `elem` names) fs - field_types flds = [ t | ConDeclField _ _ t _ <- flds ] + field_types flds = [ hsUnrestricted t | ConDeclField _ _ t _ <- flds ] keep _ = Nothing -- cgit v1.2.3