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.hs61
1 files changed, 32 insertions, 29 deletions
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 84168151..6d2888d3 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -28,13 +28,19 @@ import Data.Set (Set)
import qualified Data.Set as Set
-- | Instantiate all occurrences of given names with corresponding types.
-specialize :: forall name a. (Ord name, DataId name, NamedThing name)
+specialize :: forall name a. (Ord (IdP name), DataId name, NamedThing (IdP name))
=> Data a
- => [(name, HsType name)] -> a -> a
+ => [(IdP name, HsType name)] -> a -> a
specialize specs = go
where
go :: forall x. Data x => x -> x
- go = everywhereButType @name $ mkT $ sugar . specialize_ty_var
+ go = everywhereButType @name $ mkT $ sugar . strip_kind_sig . specialize_ty_var
+
+ strip_kind_sig :: HsType name -> HsType name
+ strip_kind_sig (HsKindSig (L _ t) _) = t
+ strip_kind_sig typ = typ
+
+ specialize_ty_var :: HsType name -> HsType name
specialize_ty_var (HsTyVar _ (L _ name'))
| Just t <- Map.lookup name' spec_map = t
specialize_ty_var typ = typ
@@ -48,7 +54,7 @@ specialize specs = go
--
-- 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 :: (Ord name, DataId name, NamedThing name)
+specializeTyVarBndrs :: (Ord (IdP name), DataId name, NamedThing (IdP name))
=> Data a
=> LHsQTyVars name -> [HsType name]
-> a -> a
@@ -60,14 +66,14 @@ specializeTyVarBndrs bndrs typs =
bname (KindedTyVar (L _ name) _) = name
-specializePseudoFamilyDecl :: (Ord name, DataId name, NamedThing name)
+specializePseudoFamilyDecl :: (Ord (IdP name), DataId name, NamedThing (IdP name))
=> LHsQTyVars name -> [HsType name]
-> PseudoFamilyDecl name
-> PseudoFamilyDecl name
specializePseudoFamilyDecl bndrs typs decl =
decl {pfdTyVars = map (specializeTyVarBndrs bndrs typs) (pfdTyVars decl)}
-specializeSig :: forall name . (Ord name, DataId name, SetName name, NamedThing name)
+specializeSig :: forall name . (Ord (IdP name), DataId name, SetName (IdP name), NamedThing (IdP name))
=> LHsQTyVars name -> [HsType name]
-> Sig name
-> Sig name
@@ -84,7 +90,7 @@ specializeSig _ _ sig = sig
-- | Make all details of instance head (signatures, associated types)
-- specialized to that particular instance type.
-specializeInstHead :: (Ord name, DataId name, SetName name, NamedThing name)
+specializeInstHead :: (Ord (IdP name), DataId name, SetName (IdP name), NamedThing (IdP name))
=> InstHead name -> InstHead name
specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } =
ihd { ihdInstType = instType' }
@@ -104,11 +110,11 @@ specializeInstHead ihd = ihd
-- and tuple literals resulting in types like @[] a@ or @(,,) a b c@. This
-- can be fixed using 'sugar' function, that will turn such types into @[a]@
-- and @(a, b, c)@.
-sugar :: forall name. (NamedThing name, DataId name)
+sugar :: forall name. (NamedThing (IdP name), DataId name)
=> HsType name -> HsType name
sugar = sugarOperators . sugarTuples . sugarLists
-sugarLists :: NamedThing name => HsType name -> HsType name
+sugarLists :: NamedThing (IdP name) => HsType name -> HsType name
sugarLists (HsAppTy (L _ (HsTyVar _ (L _ name))) ltyp)
| isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp
where
@@ -117,7 +123,7 @@ sugarLists (HsAppTy (L _ (HsTyVar _ (L _ name))) ltyp)
sugarLists typ = typ
-sugarTuples :: NamedThing name => HsType name -> HsType name
+sugarTuples :: NamedThing (IdP name) => HsType name -> HsType name
sugarTuples typ =
aux [] typ
where
@@ -134,7 +140,7 @@ sugarTuples typ =
aux _ _ = typ
-sugarOperators :: NamedThing name => HsType name -> HsType name
+sugarOperators :: NamedThing (IdP name) => HsType name -> HsType name
sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar _ (L l name))) la)) lb)
| isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb
| isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb
@@ -202,7 +208,7 @@ setInternalOccName occ name =
-- | Compute set of free variables of given type.
-freeVariables :: forall name. (NamedThing name, DataId name)
+freeVariables :: forall name. (NamedThing (IdP name), DataId name)
=> HsType name -> Set Name
freeVariables =
everythingWithState Set.empty Set.union query
@@ -225,8 +231,8 @@ 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 :: (Eq name, DataId name, SetName name)
- => Set Name -> HsType name -> HsType name
+rename :: (Eq (IdP name), DataId name, SetName (IdP name))
+ => Set Name-> HsType name -> HsType name
rename fv typ = evalState (renameType typ) env
where
env = RenameEnv
@@ -246,8 +252,8 @@ data RenameEnv name = RenameEnv
}
-renameType :: (Eq name, SetName name)
- => HsType name -> Rename name (HsType name)
+renameType :: (Eq (IdP name), SetName (IdP name))
+ => HsType name -> Rename (IdP name) (HsType name)
renameType (HsForAllTy bndrs lt) =
HsForAllTy
<$> mapM (located renameBinder) bndrs
@@ -283,23 +289,22 @@ renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)
renameType (HsAppsTy _) = error "HsAppsTy: Only used before renaming"
-renameLType :: (Eq name, SetName name)
- => LHsType name -> Rename name (LHsType name)
+renameLType :: (Eq (IdP name), SetName (IdP name))
+ => LHsType name -> Rename (IdP name) (LHsType name)
renameLType = located renameType
-renameLTypes :: (Eq name, SetName name)
- => [LHsType name] -> Rename name [LHsType name]
+renameLTypes :: (Eq (IdP name), SetName (IdP name))
+ => [LHsType name] -> Rename (IdP name) [LHsType name]
renameLTypes = mapM renameLType
-renameContext :: (Eq name, SetName name)
- => HsContext name -> Rename name (HsContext name)
+renameContext :: (Eq (IdP name), SetName (IdP name))
+ => HsContext name -> Rename (IdP name) (HsContext name)
renameContext = renameLTypes
-
-renameBinder :: (Eq name, SetName name)
- => HsTyVarBndr name -> Rename name (HsTyVarBndr name)
+renameBinder :: (Eq (IdP name), SetName (IdP name))
+ => HsTyVarBndr name -> Rename (IdP name) (HsTyVarBndr name)
renameBinder (UserTyVar lname) = UserTyVar <$> located renameName lname
renameBinder (KindedTyVar lname lkind) =
KindedTyVar <$> located renameName lname <*> located renameType lkind
@@ -333,9 +338,7 @@ freshName name = do
takenNames :: NamedThing name => Rename name (Set NameRep)
takenNames = do
RenameEnv { .. } <- get
- return $ headReps rneHeadFVs `Set.union`
- rneSigFVs `Set.union`
- ctxElems rneCtx
+ return $ Set.unions [headReps rneHeadFVs, rneSigFVs, ctxElems rneCtx]
where
headReps = Set.fromList . Map.keys
ctxElems = Set.fromList . map getNameRep . Map.elems
@@ -359,6 +362,6 @@ located :: Functor f => (a -> f b) -> Located a -> f (Located b)
located f (L loc e) = L loc <$> f e
-tyVarName :: HsTyVarBndr name -> name
+tyVarName :: HsTyVarBndr name -> IdP name
tyVarName (UserTyVar name) = unLoc name
tyVarName (KindedTyVar (L _ name) _) = name
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 14:52:34 +0000