aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Interface
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Interface')
-rw-r--r--haddock-api/src/Haddock/Interface/AttachInstances.hs6
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs21
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs22
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs10
4 files changed, 39 insertions, 20 deletions
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 23:12:51 +0000