From 02a1def8d147da88a0433726590f8586f486c760 Mon Sep 17 00:00:00 2001
From: Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io>
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 ++-
html-test/ref/Instances.html | 6 +---
13 files changed, 118 insertions(+), 76 deletions(-)
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 "<coercion type>"
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
diff --git a/html-test/ref/Instances.html b/html-test/ref/Instances.html
index 83092456..403fb18c 100644
--- a/html-test/ref/Instances.html
+++ b/html-test/ref/Instances.html
@@ -594,11 +594,7 @@
></span
> <a href="#" title="Instances"
>Foo</a
- > ((->) a :: <a href="#" title="Data.Kind"
- >Type</a
- > -> <a href="#" title="Data.Kind"
- >Type</a
- >)</span
+ > ((->) a)</span
> <a href="#" class="selflink"
>#</a
></td
--
cgit v1.2.3