aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Interface/Specialize.hs
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Interface/Specialize.hs')
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs97
1 files changed, 67 insertions, 30 deletions
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index a084af90..c6d61d05 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 #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module Haddock.Interface.Specialize
@@ -38,7 +39,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
@@ -57,7 +58,7 @@ specialize specs = go spec_map0
--
-- Again, it is just a convenience function around 'specialize'. Note that
-- length of type list should be the same as the number of binders.
-specializeTyVarBndrs :: LHsQTyVars GhcRn -> [HsType GhcRn] -> HsType GhcRn -> HsType GhcRn
+specializeTyVarBndrs :: Data a => LHsQTyVars GhcRn -> [HsType GhcRn] -> a -> a
specializeTyVarBndrs bndrs typs = specialize $ zip bndrs' typs
where
bndrs' = map (hsTyVarBndrName . unLoc) . hsq_explicit $ bndrs
@@ -74,13 +75,13 @@ specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn]
-> Sig GhcRn
-> Sig GhcRn
specializeSig bndrs typs (TypeSig _ lnames typ) =
- TypeSig noExtField lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}})
+ TypeSig noExtField lnames (typ {hswc_body = noLoc typ'})
where
- true_type :: HsType GhcRn
- true_type = unLoc (hsSigWcType typ)
- typ' :: HsType GhcRn
+ true_type :: HsSigType GhcRn
+ true_type = unLoc (dropWildCards typ)
+ typ' :: HsSigType GhcRn
typ' = rename fv $ specializeTyVarBndrs bndrs typs true_type
- fv = foldr Set.union Set.empty . map freeVariables $ typs
+ fv = foldr Set.union Set.empty . map freeVariablesType $ typs
specializeSig _ _ sig = sig
@@ -121,7 +122,7 @@ sugarTuples typ =
aux apps (HsAppTy _ (L _ ftyp) atyp) = aux (atyp:apps) ftyp
aux apps (HsParTy _ (L _ typ')) = aux apps typ'
aux apps (HsTyVar _ _ (L _ name))
- | isBuiltInSyntax name' && suitable = HsTupleTy noExtField HsBoxedTuple apps
+ | isBuiltInSyntax name' && suitable = HsTupleTy noExtField HsBoxedOrConstraintTuple apps
where
name' = getName name
strName = getOccString name
@@ -176,19 +177,25 @@ parseTupleArity _ = Nothing
-- not converted to 'String' or alike to avoid new allocations. Additionally,
-- since it is stored mostly in 'Set', fast comparison of 'FastString' is also
-- quite nice.
-type NameRep = FastString
+newtype NameRep
+ = NameRep FastString
+ deriving (Eq)
+
+instance Ord NameRep where
+ compare (NameRep fs1) (NameRep fs2) = uniqCompareFS fs1 fs2
+
getNameRep :: NamedThing name => name -> NameRep
-getNameRep = getOccFS
+getNameRep = NameRep . getOccFS
nameRepString :: NameRep -> String
-nameRepString = unpackFS
+nameRepString (NameRep fs) = unpackFS fs
stringNameRep :: String -> NameRep
-stringNameRep = mkFastString
+stringNameRep = NameRep . mkFastString
setInternalNameRep :: SetName name => NameRep -> name -> name
-setInternalNameRep = setInternalOccName . mkVarOccFS
+setInternalNameRep (NameRep fs) = setInternalOccName (mkVarOccFS fs)
setInternalOccName :: SetName name => OccName -> name -> name
setInternalOccName occ name =
@@ -198,23 +205,37 @@ setInternalOccName occ name =
nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname)
--- | Compute set of free variables of given type.
-freeVariables :: HsType GhcRn -> Set Name
-freeVariables =
- everythingWithState Set.empty Set.union query
+-- | Compute set of free variables of a given 'HsType'.
+freeVariablesType :: HsType GhcRn -> Set Name
+freeVariablesType =
+ everythingWithState Set.empty Set.union
+ (mkQ (\ctx -> (Set.empty, ctx)) queryType)
+
+-- | Compute set of free variables of a given 'HsType'.
+freeVariablesSigType :: HsSigType GhcRn -> Set Name
+freeVariablesSigType =
+ everythingWithState Set.empty Set.union
+ (mkQ (\ctx -> (Set.empty, ctx)) queryType `extQ` querySigType)
+
+queryType :: HsType GhcRn -> Set Name -> (Set Name, Set Name)
+queryType term ctx = case term of
+ HsForAllTy _ tele _ ->
+ (Set.empty, Set.union ctx (teleNames tele))
+ HsTyVar _ _ (L _ name)
+ | getName name `Set.member` ctx -> (Set.empty, ctx)
+ | otherwise -> (Set.singleton $ getName name, ctx)
+ _ -> (Set.empty, ctx)
where
- query term ctx = case cast term :: Maybe (HsType GhcRn) of
- Just (HsForAllTy _ tele _) ->
- (Set.empty, Set.union ctx (teleNames tele))
- Just (HsTyVar _ _ (L _ name))
- | getName name `Set.member` ctx -> (Set.empty, ctx)
- | otherwise -> (Set.singleton $ getName name, ctx)
- _ -> (Set.empty, ctx)
-
+ teleNames :: HsForAllTelescope GhcRn -> Set Name
teleNames (HsForAllVis _ bndrs) = bndrsNames bndrs
teleNames (HsForAllInvis _ bndrs) = bndrsNames bndrs
- bndrsNames = Set.fromList . map (getName . hsTyVarBndrName . unLoc)
+querySigType :: HsSigType GhcRn -> Set Name -> (Set Name, Set Name)
+querySigType (HsSig { sig_bndrs = outer_bndrs }) ctx =
+ (Set.empty, Set.union ctx (bndrsNames (hsOuterExplicitBndrs outer_bndrs)))
+
+bndrsNames :: [LHsTyVarBndr flag GhcRn] -> Set Name
+bndrsNames = Set.fromList . map (getName . tyVarName . unLoc)
-- | Make given type visually unambiguous.
@@ -225,12 +246,12 @@ freeVariables =
-- different type variable than latter one. Applying 'rename' function
-- will fix that type to be visually unambiguous again (making it something
-- like @(a -> b0) -> b@).
-rename :: Set Name -> HsType GhcRn -> HsType GhcRn
-rename fv typ = evalState (renameType typ) env
+rename :: Set Name -> HsSigType GhcRn -> HsSigType GhcRn
+rename fv typ = evalState (renameSigType typ) env
where
env = RenameEnv
{ rneHeadFVs = Map.fromList . map mkPair . Set.toList $ fv
- , rneSigFVs = Set.map getNameRep $ freeVariables typ
+ , rneSigFVs = Set.map getNameRep $ freeVariablesSigType typ
, rneCtx = Map.empty
}
mkPair name = (getNameRep name, name)
@@ -245,6 +266,17 @@ data RenameEnv name = RenameEnv
}
+renameSigType :: HsSigType GhcRn -> Rename (IdP GhcRn) (HsSigType GhcRn)
+renameSigType (HsSig x bndrs body) =
+ HsSig x <$> renameOuterTyVarBndrs bndrs <*> renameLType body
+
+renameOuterTyVarBndrs :: HsOuterTyVarBndrs flag GhcRn
+ -> Rename (IdP GhcRn) (HsOuterTyVarBndrs flag GhcRn)
+renameOuterTyVarBndrs (HsOuterImplicit imp_tvs) =
+ HsOuterImplicit <$> mapM renameName imp_tvs
+renameOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) =
+ HsOuterExplicit x <$> mapM renameLBinder exp_bndrs
+
renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn)
renameType (HsForAllTy x tele lt) =
HsForAllTy x
@@ -271,7 +303,7 @@ renameType t@(HsSpliceTy _ _) = pure t
renameType (HsDocTy x lt doc) = HsDocTy x <$> renameLType lt <*> pure doc
renameType (HsBangTy x bang lt) = HsBangTy x bang <$> renameLType lt
renameType t@(HsRecTy _ _) = pure t
-renameType t@(XHsType (NHsCoreTy _)) = pure t
+renameType t@(XHsType _) = pure t
renameType (HsExplicitListTy x ip ltys) =
HsExplicitListTy x ip <$> renameLTypes ltys
renameType (HsExplicitTupleTy x ltys) =
@@ -362,3 +394,8 @@ alternativeNames name =
located :: Functor f => (a -> f b) -> Located a -> f (Located b)
located f (L loc e) = L loc <$> f e
+
+
+tyVarName :: HsTyVarBndr flag GhcRn -> IdP GhcRn
+tyVarName (UserTyVar _ _ name) = unLoc name
+tyVarName (KindedTyVar _ _ (L _ name) _) = name
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 17:14:43 +0000