diff options
author | Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io> | 2020-06-17 15:04:59 -0400 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2020-06-17 16:09:07 -0400 |
commit | 02a1def8d147da88a0433726590f8586f486c760 (patch) | |
tree | 6aee10b7822ba5effbab1ee58d61660eef8ec816 /haddock-api/src/Haddock/Interface | |
parent | e37911553bfe6804d3903f750261f758569b4a26 (diff) |
Adapt Haddock to LinearTypes
See ghc/ghc!852.
Diffstat (limited to 'haddock-api/src/Haddock/Interface')
-rw-r--r-- | haddock-api/src/Haddock/Interface/AttachInstances.hs | 6 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 21 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/Rename.hs | 22 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/Specialize.hs | 10 |
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 |